home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / CLIPPER / MISC / FFA.ZIP / SEQREAD.SEQ < prev    next >
Encoding:
Text File  |  1988-01-06  |  8.8 KB  |  239 lines
  1. \ SEQREAD.SEQ   Sequential read and load file           by Tom Zimmer
  2.  
  3. \ Link this file into the FILELIST chain.
  4.  
  5. FILES DEFINITIONS
  6.  
  7. VARIABLE SEQREAD.SEQ
  8.  
  9. FORTH DEFINITIONS
  10.  
  11. \       Read sequential lines from a file, delimited by CRLF.
  12.  
  13. 1024 constant IBLEN             \ input buffer length
  14.  256 constant OBLEN             \ output buffer length
  15.      variable INLEN             \ input text length
  16.    0 CONSTANT INBSEG            \ the input buffer
  17.        CREATE OUTBUF OBLEN ALLOT \ the line output buffer
  18.  
  19. 5 b/hcb * constant MAXNEST        \  maximum of 5 hcb's
  20.  
  21.        create HNDLS maxnest allot
  22.         HNDLS SHNDL !-T           \ Preset pointer
  23.      variable LOADOFF             \ line offset of error
  24.      variable FILEPOINTER 2 allot \ most recent read
  25.      variable LOADING             \ Are we in the proccess of loading a file?
  26.             0 LOADING !-T         \ initialize to not loading.
  27.  
  28. DEFER LOADSTAT  ' NOOP IS LOADSTAT
  29.  
  30. : SHNDL+        ( --- A1 )
  31.                 SHNDL @ B/HCB + ;
  32.  
  33. : .FILE         ( --- )
  34.                 shndl @ count type ;
  35.  
  36. : GET_ALINE     ( --- )
  37.                 INBSEG SSEG !
  38.                 0 inlen @ 10 scan dup   \ really looks for LF
  39.                 if 1 -1 d+ then inlen !
  40.                 dup oblen 1- min dup >R outbuf c!
  41.                 INBSEG 0 ?CS: outbuf 1+ R> cmoveL
  42.                 INBSEG SWAP OVER 0 inlen @ cmoveL
  43.                 errorline incr
  44.                 ?CS: SSEG ! ;
  45.  
  46. : FILEPOINTER+  ( --- )
  47.                  outbuf c@ 0 filepointer 2@ d+ filepointer 2! ;
  48.  
  49. HEX
  50.  
  51. CODE CURPOINTER ( handle --- double-current )
  52.                 pop bx
  53.                 ADD bx, # HNDLOFFSET
  54.                 mov ax, 0 [bx]
  55.                 mov bx, ax
  56.                 mov cx, # 0
  57.                 mov dx, # 0
  58.                 mov ax, # 4201  \ from end of file
  59.                 int 21
  60.                 push ax
  61.                 push dx
  62.                 next
  63.                 end-code
  64. DECIMAL
  65.  
  66. : SAVEPOINTER   ( --- )
  67.                 shndl @ curpointer inlen @ 0 d- filepointer 2! ;
  68.  
  69. : ?FILLBUFF     ( --- )         \ refill INBUF
  70.                 inlen @ oblen u<
  71.                 if      inlen @ iblen over - shndl @ INBSEG EXHREAD
  72.                         inlen +! savepointer
  73.                 else    filepointer+
  74.                 then    ;
  75.  
  76. : <LINEREAD>    ( --- a1 )      \ read a line delimited by CRLF
  77.                 ?fillbuff       \ re-fill buffer if needed.
  78.                 get_aline       \ returns line including CRLF
  79.                 outbuf ;
  80.  
  81. DEFER LINEREAD  ' <LINEREAD> IS LINEREAD
  82.  
  83. : (?SERROR)     ( ADDR N1 BOOL --- )
  84.                 LOADING @
  85.                 IF
  86.                         IF      >R >R SP0 @ SP! PRINTING OFF
  87.                                 LOADING OFF
  88.                                 DECIMAL CR ." File = " .FILE
  89.                                 ."  at Line " errorline @ u.
  90.                                 CR OUTBUF COUNT TYPE
  91.                                 CR >IN @ 1- HERE C@ - 0 MAX
  92.                                 DUP LOADOFF ! 0
  93.                                 ?DO ASCII - EMIT LOOP
  94.                                 ." ^-- " R> R> TYPE SPACE
  95.                                 ['] <RUN> IS RUN QUIT   \ Disk error
  96.                         ELSE    2DROP                   \ No error comes here
  97.                         THEN
  98.                 ELSE    ['] <RUN> IS RUN (?ERROR)       \ Command line error
  99.                 THEN    ;
  100.  
  101. : SEQUP         ( --- )
  102.                 shndl @ >hndle @ -1 <>
  103.                 if      shndl @ b/hcb + dup hndls maxnest + U>
  104.                         abort" Nested too deeply on SLOAD!"
  105.                         dup shndl ! clr-hcb
  106.                 then    ;
  107.  
  108. : SEQINIT       ( --- )
  109.                 NOOP HNDLS SHNDL !
  110.                 HNDLS   MAXNEST OVER + SWAP
  111.                 DO      I CLR-HCB
  112.          B/HCB +LOOP
  113.                 IBLEN 0 16 UM/MOD NIP 1+ ALLOC 8 = MEMCHK NIP
  114.                 [ ' INBSEG >BODY ] LITERAL ! ;
  115.  
  116. : SEQDOWN       ( --- )
  117.                 shndl @ hclose drop
  118.                 shndl @ b/hcb - hndls max shndl !
  119.                 shndl @ >hndle @ -1 <>
  120.                 if      filepointer 2@ shndl @ movepointer
  121.                         >in off span off #tib off inlen off
  122.                 then    ;
  123.  
  124. : CLOSE         ( --- )
  125.                 SEQDOWN ;
  126.  
  127. : $HOPEN        ( A1 --- F1 )   \ Returns a boolean for open successful
  128.                 shndl @ dup >r hclose drop
  129.                 r@ $>handle r> hopen ;
  130.  
  131. : SEEK          ( d1 --- )            \ Move the filepointer in SHNDL to the
  132.                 shndl @ movepointer ;   \ specified by d1.
  133.  
  134. variable LVR
  135.  
  136. : SHOWLINES     ( --- ) lvr on ;
  137.  
  138. : HIDELINES     ( --- ) lvr off ;
  139.  
  140. : FILLTIB       ( --- )
  141.                 span @ loadline +!
  142.                 lineread
  143.                 dup count + 2- 8224 swap !
  144.                 lvr @
  145.                 if      CR loadline @ 5 u.r space
  146.                         DUP COUNT TYPE
  147.                 then    dup 1+ 'tib ! c@ dup span ! #tib !
  148.                 >in off ;
  149.  
  150. : <LOAD>        ( --- )
  151.                 loadstat
  152.                 loading  dup @ >r on
  153.                 'tib @ >r >in @ >r span @ >r SPAN OFF errorline @ >r
  154.                 begin   span @ loadline +!
  155.                         lineread inlen @ 0>
  156.                 while   dup count + 2- 8224 swap !
  157.                         lvr @
  158.                         if      CR errorline @ 5 u.r space
  159.                                 DUP COUNT TYPE
  160.                         then    dup 1+ 'tib ! c@ dup span ! #tib !
  161.                         >in off run
  162.                         INLEN @ oblen < if LOADSTAT then
  163.                 repeat  drop r> errorline !
  164.                         r> dup span ! #tib ! r> >in ! r> 'tib !
  165.                         r> loading  ! loadstat ;
  166.  
  167. DEFER LOADER    ' <LOAD> IS LOADER
  168.  
  169. : >LINE         ( n1 --- )
  170.                 0.0 shndl @ movepointer
  171.                 loadline off inlen off errorline off
  172.                 1-      0 max   ?dup
  173.                 if      cr ." Stepping to line " dup 1+ u. ." .."
  174.                         0
  175.                        ?do      errorline incr
  176.                                 lineread c@ dup loadline +! 0= ?leave
  177.                         loop
  178.                 then    ;
  179.  
  180. : LOADED,       ( --- )
  181.                 'TIB @ >R >IN @ >R SPAN @ >R    \ SAVE STATE
  182.                 SHNDL @ COUNT
  183.                 BEGIN   2DUP ASCII \ SCAN DUP   \ Skip the leading PATH
  184.                 WHILE   2SWAP 2DROP
  185.                         1 -1 D+
  186.                 REPEAT  2DROP DUP SPAN ! #TIB ! \ Set SPAN and #TIB
  187.                 'TIB !                          \ Set TIB to SHNDL
  188.                 >IN OFF                         \ Set >IN
  189.                 CONTEXT @ >R                    \ Save current context
  190.                 CURRENT @ >R                    \  and current vocab state
  191.                 FILES DEFINITIONS               \ select FILES vocabulary
  192.                 VARIABLE                        \ Make the header
  193.                 R> CURRENT ! R> CONTEXT !       \ restore vocabulary state
  194.                 R> DUP SPAN ! #TIB !            \ Restore STATE
  195.                 R> >IN ! R> 'TIB ! ;
  196.  
  197. : <FLOAD>       ( --- )
  198.                 LOADED,
  199.                 0.0 shndl @ movepointer
  200.                 loadline dup @ >r off
  201.                 errorline off
  202.                 LOADER
  203.                 r> loadline ! ;
  204.  
  205. : FLOAD         ( --- t1 )
  206.                 [']  ?error >body @ >r
  207.                 sequp inlen off
  208.                 [']  (?SERROR) IS ?ERROR
  209.                 >IN @ BL WORD C@ OVER >IN ! + >R
  210.                 outbuf off loadoff off shndl @ !hcb
  211.                 R> 0 filepointer 2@ d+ >R >R
  212.                 shndl @ hopen 0<>
  213.                 if      cr ." Open Error in " .file
  214.                         abort
  215.                 then    <fload>
  216.                 R> R> filepointer 2!
  217.                 shndl @ c@ 6 + loadline +!      \ adj for filename length
  218.                                                 \ and "FLOAD ".
  219.                 seqdown r> is ?error ;
  220.  
  221. : CHARREAD      ( --- c1 )      \ Read a character from the current file.
  222.                 loading @
  223.         if      begin   >in @ span @ =          \ If nothing in line
  224.                         inlen @ 0> and          \ and input buf not empty
  225.                 while   ?fillbuff               \ Optionally refill buffer
  226.                         filltib                 \ refill the TIB
  227.                 repeat
  228.         then    >in @   >in incr  tib + c@ ;
  229.  
  230. : OK            ( --- )         \ Load currently open file
  231.                 inlen off <fload> ;
  232.  
  233.  
  234. : \S            ( n1 --- )              \ Ignore the rest of the file.
  235.                 shndl @ endfile 2drop   \ Move to end of file
  236.                 loadline off inlen off  \ Reset input buffers
  237.                 span @ >in ! ;          \ Ignore rest of line
  238.  
  239.