home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PROGRAMS / UTILS / LASER / FPC35_5.ZIP / FPCSRC.ZIP / SEQREAD.SEQ < prev    next >
Encoding:
Text File  |  1989-07-05  |  17.9 KB  |  466 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. DECIMAL
  12.  
  13. \       Read sequential lines from a file, delimited by CRLF.
  14.  
  15.     0 VALUE WITHPATH            \ should the PATH be included in the file var
  16. 16384 VALUE IBLEN               \ current input buffer length
  17. 16384 VALUE IBFULL              \ full buffer size, used to restore IBLEN
  18.  
  19. \ A couple of editor words, needed to give the information editor when
  20. \ a compile error has occured.
  21.     0 VALUE SCREENCHAR
  22.   $0A VALUE DELIMITER
  23.  
  24. \ The value of OBLEN can be reduced to 64 if you want to read lines from
  25. \ normal Forth BLOCK files. You should use BLKTOSEQ.SEQ for this though.
  26.  
  27.   255 VALUE OBLEN               \ output buffer length
  28.  
  29.     0 VALUE INSTART
  30.     0 VALUE INLENGTH
  31.     0 VALUE INBSEG                \ the input buffer
  32.    VARIABLE TOTALLINES
  33.      CREATE OUTBUF OBLEN 1+ ALLOT \ the line output buffer
  34.  
  35. 7 B/HCB * CONSTANT MAXNEST        \  maximum of 7 hcb's
  36.  
  37.        CREATE HNDLS MAXNEST B/HCB + ALLOT
  38.         HNDLS ' SEQHANDLE >BODY !-T           \ PRESET POINTER
  39.      VARIABLE FILEPOINTER 2 allot \ most recent read
  40.      VARIABLE LOADING             \ Are we in the proccess of loading a file?
  41.             0 LOADING !-T         \ initialize to not loading.
  42.        CREATE CONHNDL B/HCB  ALLOT      1 CONHNDL >HNDLE !-T
  43.        CREATE PRNHNDL B/HCB  ALLOT      4 PRNHNDL >HNDLE !-T
  44.  
  45. : CONSOLEL      ( SEG C1 -- )
  46.                 OUTPAUSE
  47.                 SWAP >R SP@ 1 CONHNDL R> EXHWRITE 2DROP
  48.                 #OUT INCR ;
  49.  
  50. : (CONSOLE)     ( C1 -- )
  51.                 ?CS: SWAP CONSOLEL ;
  52.  
  53. : PRINTL        ( SEC C1 -- )
  54.                 OUTPAUSE
  55.                 SWAP >R SP@ 1 PRNHNDL R> EXHWRITE 2DROP
  56.                 #OUT INCR ;
  57.  
  58. : (PRINT)       ( C1 --- )
  59.                 ?CS: SWAP PRINTL ;
  60.  
  61. : PRNTYPEL      ( SEG A1 N1 --- )
  62.                 OUTPAUSE
  63.                 0MAX ROT PRNHNDL SWAP EXHWRITE #OUT +! ;
  64.  
  65. : CONTYPEL      ( SEG A1 N1 --- )
  66.                 OUTPAUSE
  67.                 0MAX ROT CONHNDL SWAP EXHWRITE #OUT +! ;
  68.  
  69. : (TYPEL)       ( SEG A1 N1 --- )       \ External type, from other segment
  70.                 PRINTING @
  71.                 IF      PRNTYPEL
  72.                 ELSE    CONTYPEL
  73.                 THEN    ;
  74.  
  75. : (TYPE)        ( A1 N1 --- )
  76.                 ?CS: -ROT TYPEL ;
  77.  
  78. DEFER LOADSTAT  ' NOOP IS LOADSTAT
  79.  
  80. : SEQHANDLE+        ( --- A1 )
  81.                 seqhandle b/hcb + ;
  82.  
  83. : .SEQHANDLE        ( --- )
  84.                 seqhandle count type ;
  85.  
  86. CODE CURPOINTER ( handle --- double-current )
  87.                 pop bx
  88.                 add bx, # hndloffset
  89.                 mov bx, 0 [bx]
  90.                 sub cx, cx
  91.                 mov dx, cx
  92.                 mov ax, # $4201  \ from end of file
  93.                 int $21
  94.                 push ax
  95.                 push dx
  96.                 next
  97.                 end-code
  98.  
  99. : SAVEPOINTER   ( --- )
  100.                 seqhandle curpointer inlength 0 d- filepointer 2! ;
  101.  
  102. CODE GET_ALINE  ( --- a1 )
  103.                 push es                         \ Save ES for later restoral
  104.                 mov di, ' instart >body         \ Searching from INSTART
  105.                 mov ax, ' DELIMITER >body       \ Searching for line delimiter
  106.                 mov cx, ' inlength >body        \ for INLENGTH clipped to OBLEN
  107.                 cmp cx, ' oblen >body           \ if INLENGTH > OBLEN
  108.               > if      mov cx, ' oblen >body   \ clip search length to OBLEN
  109.                 then    mov dx, cx              \ save search length in DX
  110.           cx<>0 if      mov es, ' inbseg >body  \ searching INBSEG segment
  111.                         repnz           scasb   \ Scan for Linefeed char
  112.                 then    sub dx, cx              \ DX = length of line
  113.                 sub ' inlength >body dx         \ subtract line from remaining
  114.                 mov outbuf dl byte              \ set the length of OUTBUF
  115.                 mov bx, si                      \ save IP for later restoral
  116.                 mov si, ' instart >body         \ moving from INSTART
  117.                 add ' instart >body dx          \ set start to after line
  118.                 mov cx, dx                      \ cx = length to move
  119.                 mov di, # outbuf 1+             \ moving to OUTBUF
  120.                 mov ds, ' inbseg >body          \ from INBSEG segment
  121.                 mov ax, cs      mov es, ax      \ to CODE segment
  122.           cx<>0 if      repnz   movsb           \ move the line to OUTBUF
  123.                 then
  124.                 mov ax, cs      mov ds, ax      \ restore DS
  125.                 mov si, bx                      \ restore IP
  126.                 inc loadline word               \ bump line counter
  127.                 pop es                          \ restore ES
  128.                 mov ax, # outbuf                \ return address of buffer
  129.                 1push           end-code
  130.  
  131. : FILLBUFF      ( --- )         \ Refill the input buffer.
  132.                 inbseg instart over 0 inlength cmovel
  133.                 %off> instart
  134.                 inlength iblen inlength -
  135.                 seqhandle inbseg exhread        \ perform the actual read
  136.                 %+!> inlength                   \ adjust buffer length
  137.                                 \
  138.                                 \ strip off any Control Z's at end of file by
  139.                 -6 -1           \ scaning the last 6 chars of the read buffer
  140.                                 \ when a FILLBUFF occurs.
  141.                 do      inlength i + 0< ?leave          \ leave if begin buf
  142.                         inbseg inlength i + c@L 26 =    \ is it ^Z?
  143.                         if      bl
  144.                                 inbseg inlength i + c!L \ change to BLANK
  145.                         then
  146.             -1 +loop    savepointer ;
  147.  
  148. CODE ?FILLBUFF  ( --- )         \ refill INBUF if needed
  149.                 cmp ' inlength >body # oblen 1+ word
  150.             u>= if      mov bx, # filepointer   \ Set BX to point to FILEPOINTER
  151.                         sub cx, cx              \ clear CX
  152.                         mov cl, outbuf          \ read byte length of OUTBUF
  153.                         add 2 [bx], cx          \ Add to 32bit contents
  154.                         adc 0 [bx], # 0
  155.                         next
  156.                 then                            \ If we got here, then
  157.                 mov ax, # ' fillbuff            \ go and re-fill the buffer
  158.                 jmp ax
  159.                 end-code
  160.  
  161. : LINEREAD      ( --- a1 )      \ read a line delimited by CRLF
  162.                 ?fillbuff       \ re-fill buffer if needed.
  163.                 get_aline ;     \ returns line including CRLF
  164.  
  165. : (DOERROR)     ( a1 n1 --- )
  166.                 2>r
  167.                 cr ." file = " .seqhandle
  168.                 ."  at Line " loadline @ u.
  169.                 cr outbuf count type cr
  170.                 >in @ 1- here c@ - 0MAX
  171.                 dup %!> screenchar 0
  172.                 ?do ASCII - emit loop
  173.                 ." ^-- " 2r> type space
  174.                 quit    ;
  175.  
  176. DEFER DOERROR   ' (DOERROR) IS DOERROR
  177.  
  178. $0A VALUE DEFBASE
  179.  
  180. : HEXBASE       ( --- )
  181.                 hex base @ %!> defbase ;
  182.  
  183. : DECIMALBASE   ( --- )
  184.                 decimal base @ %!> defbase ;
  185.  
  186. : NOBASE        ( --- )
  187.                 %off> defbase ;
  188.  
  189. : .BASE         ( --- )
  190.                 ." Current BASE in DECIMAL is "
  191.                 base @ dup decimal . base ! ;
  192.  
  193. : ?BASE_RESTORE ( f1 --- )              \ Restore the base to the default
  194.                 if      defbase ?dup    \ base if f1 = true, and defbase
  195.                         if      base !  \ is not zero
  196.                         then
  197.                 then    ;
  198.  
  199. : (?SERROR)     ( a1 n1 f1 --- )
  200.                 dup ?base_restore
  201.                 %@> loading
  202.                 if
  203.                         if      2>R sp0 @ sp! printing off loading off
  204.                                 ['] <run> is run errfix
  205.                                 2R> doerror
  206.                                 quit                    \ error from disk
  207.                         else    2drop                   \ no error comes here
  208.                         then
  209.                 else    (?error)       \ command line error
  210.                 then    ;
  211.  
  212. ' (?SERROR) IS ?ERROR
  213.  
  214. : ?SEQRANGE     ( --- )         \ Verify seqhandle points to a handle in
  215.                                 \ the HNDLS array
  216.                 seqhandle hndls maxnest over + between 0=
  217.                 abort" SEQHANDLE is not set to the HANDLE stack" ;
  218.  
  219. : SEQUP         ( --- )
  220.                 ?SEQRANGE
  221.                 seqhandle >hndle @ -1 >
  222.                 if      seqhandle b/hcb + dup hndls maxnest + U< 0=
  223.                         abort" Nested too deeply on FLOAD, use CLOSEALL"
  224.                         dup %!> seqhandle clr-hcb
  225.                 then    ;
  226.  
  227. : SEQINIT       ( --- )
  228.                 noop hndls %!> seqhandle
  229.                 hndls   maxnest over + swap
  230.                 do      i clr-hcb
  231.          b/hcb +loop
  232.                 iblen paragraph alloc 8 = memchk nip %!> inbseg
  233.                 conhndl clr-hcb " CON." ">$ conhndl $>handle
  234.                 1 conhndl >hndle !
  235.                 prnhndl clr-hcb " PRN." ">$ prnhndl $>handle
  236.                 4 prnhndl >hndle ! ;
  237.  
  238. : IBRESET       ( --- )
  239.                 %off> instart
  240.                 %off> inlength ;
  241.  
  242. : $HOPEN        ( A1 --- F1 )   \ Returns a boolean for open successful
  243.                 seqhandle hclose drop
  244.                 seqhandle $>handle
  245.                 seqhandle hopen
  246.                 ibreset ;
  247.  
  248. DEFER GETFILE       ( --- <a1> f1 )     \ return a1 filename addr and
  249.  
  250. ' FALSE IS GETFILE                      \ Default to failed
  251.  
  252. : FILE>TIB      ( a1 --- )              \ given a counted string a1, insert it
  253.                 count \ 2dup type space   \ into the Terminal Input Buffer.
  254.                 2dup true -rot over + swap
  255.                 do      i c@ ASCII . =
  256.                         if      drop false leave
  257.                         then
  258.                 loop    >r dup #tib ! >in off
  259.                 tib swap cmove r>
  260.                 if      ASCII . #tib @ tib + c!
  261.                         #tib incr
  262.                 then    ;
  263.  
  264. : GFL           ( --- )                 \ optionally prompt for file if non
  265.                                         \ is currently in the TIB.
  266.                 more? 0=
  267.                 if      getfile 0= abort" No filename specified"
  268.                         dup count type space
  269.                         file>tib
  270.                 then    ;
  271.  
  272. : SEEK          ( d1 --- )  \ Move the filepointer in seqhandle to the offset
  273.                 seqhandle movepointer ;   \ specified by d1.
  274.  
  275. 0 VALUE LISTVAR
  276.  
  277. : SHOWLINES     ( --- )         \ enable displaying of loaded lines
  278.                 -1 %!> listvar ;
  279.  
  280. : HIDELINES     ( --- )         \ disable displaying of loaded lines
  281.                 0 %!> listvar ;
  282.  
  283. CODE CRLF>BL'S  ( a1 --- a1 )   \ change CRLF at end of string to blanks
  284.                 pop bx          \ leaving the string address on the stack
  285.                 push bx         \ Same as -> DUP COUNT + 2- DUP @ $0D0A =
  286.                 mov al, 0 [bx]  \            IF 8224 SWAP ! ELSE DROP DROP ;
  287.                 sub ah, ah
  288.                 add bx, ax
  289.                 dec bx
  290.                 cmp 0 [bx], # $0A0D word        \ if line ends in CRLF
  291.              0= if      mov 0 [bx], # 8224 word \ change then to blanks
  292.                 then    next
  293.                 end-code
  294.  
  295. CODE SETTIB     ( a1 --- )      \ Set TIB to counted string a1
  296.                 pop bx
  297.                 mov al, 0 [bx]
  298.                 inc bx
  299.                 mov 'tib bx
  300.                 sub ah, ah
  301.                 mov #tib ax
  302.                 mov >in # 0
  303.                 next
  304.                 end-code
  305.  
  306. : .LOADLINE     ( a1 --- a1 )
  307.                 cr loadline @ 5 u.r space
  308.                 dup count type ;
  309.  
  310. CODE ?.LOADLINE ( a1 --- a1 )
  311.                 mov cx, ' listvar >body
  312.                 inc cx
  313.           cx<>0 if      next                    \ if LISTVAR = -1, leave
  314.                 then
  315.                 mov ax, # ' .loadline           \ if LISTVAR <> zero, continue
  316.                 jmp ax  end-code
  317.  
  318. CODE LENGTH.CHECK ( a1 --- a1 f1 )
  319.                 mov ax, # true
  320.                 mov cx, ' inlength >body        \ if read length <> 0
  321.           cx<>0 if      1push                   \ then we aren't done
  322.                 then
  323.                 pop di                          \ get a copy of line buf ptr
  324.                 push di
  325.                 cmp 0 [di], # 0 byte            \ if line buffer <> 0
  326.             0<> if      1push                   \ then we aren't done
  327.                 then
  328.                 mov ax, # false
  329.                 1push   end-code                \ else we are done
  330.  
  331. : FILLTIB       ( --- )
  332.                 lineread crlf>bl's ?.loadline settib ;
  333.  
  334. : SEQDOWN       ( --- )
  335.                 ?SEQRANGE
  336.                 seqhandle hclose drop           \ close the file
  337.                 seqhandle clr-hcb               \ clear the handle
  338.                 seqhandle b/hcb -               \ decrease handle by b/hcb
  339.                 hndls maxnest + b/hcb - umin    \ clip below stack end
  340.                 hndls umax %!> seqhandle        \ and above stack begin
  341.                 seqhandle >hndle @ -1 <>        \ if a file is open
  342.                 loading @ and                   \ and we are loading
  343.                 if      filepointer 2@
  344.                         seqhandle movepointer   \ adjust file pointer
  345.                         IBRESET                 \ reset read pointers
  346.                         >in @ filltib >in !     \ re-fill TIB,
  347.                                                 \ but preserve >IN
  348.                 then    ;
  349.  
  350. : CLOSE         ( --- )
  351.                 seqdown ;
  352.  
  353. : CLOSEALL      ( --- )
  354.                 ?SEQRANGE
  355.                 begin   seqhandle hndls u>
  356.                 while   seqdown
  357.                 repeat  seqdown ;
  358.  
  359. : <LOAD>        ( --- )
  360.                 loadstat
  361.                 ibfull %!> iblen         \ set maximum length read buffer
  362.                 true  %save!> loading
  363.                       %save>  'tib
  364.                       %save>  >in
  365.                 false %save!> #tib
  366.                       %save>  loadline
  367.                       %save>  run
  368.                 0 %!> screenchar
  369.                 begin   lineread
  370.                         length.check
  371.                 while   crlf>bl's ?.loadline settib run
  372.                 repeat  drop
  373.                 %@> loadline %+!> totallines
  374.                 %restore> run
  375.                 %restore> loadline
  376.                 %restore> #tib
  377.                 %restore> >in
  378.                 %restore> 'tib
  379.                 %restore> loading
  380.                 loading @               \ if we are still loading,
  381.                 if      256   %!> iblen \ use a small read buffer
  382.                 else    ibfull %!> iblen \ else use the full size buffer
  383.                 then    ;
  384.  
  385. DEFER LOADER    ' <LOAD> IS LOADER
  386.  
  387. : >LINE         ( n1 --- )
  388.                 0.0 seqhandle movepointer
  389.                 loadline off
  390.                 IBRESET
  391.                 1-      0MAX   ?dup
  392.                 if
  393. \                       cr ." Stepping to line " dup 1+ u. ." .."
  394.                         0
  395.                        ?do      lineread c@ 0= ?leave
  396.                         loop
  397.                 then    ;
  398.  
  399.  TRUE VALUE ?LOADED,    \ Allow disabling LOADED, for one time.
  400. FALSE VALUE ?NOLOADED,
  401.  
  402. : LOADED,       ( --- )
  403.                 ?noloaded, ?exit
  404.                 ?loaded, 0=
  405.                 if      %on> ?loaded, exit
  406.                 then
  407.                 %save> 'tib
  408.                 %save> >in
  409.                 %save> #tib             \ save interpretation status
  410.                 seqhandle count
  411.                 withpath 0=             \ Should the PATH not be
  412.                 if                      \ included in the file VARIABLE?
  413.                         begin   2dup
  414.                                 ASCII \ scan dup   \ skip the leading path
  415.                         while   2swap 2drop
  416.                                 1 -1 d+
  417.                         repeat  2drop
  418.                 then
  419.                 %!> #tib                \ set #tib
  420.                 %!> 'tib                \ set tib to seqhandle
  421.                 %off> >in               \ clear >in
  422.                 %save> context          \ save current context
  423.                 %save> current          \  and current vocab state
  424.                 files definitions       \ select files vocabulary
  425.                 variable                \ make the header
  426.                 %restore> current
  427.                 %restore> context       \ restore vocabulary state
  428.                 %restore> #tib
  429.                 %restore> >in
  430.                 %restore> 'tib ;
  431.  
  432. : <FLOAD>       ( --- )
  433.                 #tib @ >r
  434.                 0 %save!> loadline
  435.                 loaded,
  436.                 0.0 seqhandle movepointer
  437.                 loader
  438.                 %restore> loadline
  439.                 r> %+!> loadline ;
  440.  
  441. : CHARREAD      ( --- c1 )      \ Read a character from the current file.
  442.                 loading @
  443.         if      begin   %@> >in   %@> #tib =    \ If nothing in line
  444.                         inlength 0> and         \ and input buf not empty
  445.                 while   ?fillbuff               \ Optionally refill buffer
  446.                         filltib                 \ refill the TIB
  447.                 repeat
  448.         then    %@> >in   %incr> >in   tib + c@ ;
  449.  
  450. : ?FILEOPEN     ( --- )                 \ Verify a file is open.
  451.                 seqhandle >hndle @ 0<
  452.                 abort" A file MUST be open to perform this operation." ;
  453.  
  454. : OK            ( --- )         \ Load currently open file
  455.                 ?fileopen
  456.                 IBRESET
  457.                 <fload> ;
  458.  
  459.  
  460. : \S            ( n1 --- )              \ Ignore the rest of the file.
  461.                 seqhandle endfile 2drop \ Move to end of file
  462.                 loadline off
  463.                 IBRESET
  464.                 %@> #tib %!> >in ;      \ Ignore rest of line
  465.  
  466.