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