File:  [gforth] / gforth / kernel / input.fs
Revision 1.26: download - view: text, annotated - select for diffs
Sat Dec 31 15:29:26 2011 UTC (10 years, 7 months ago) by anton
Branches: MAIN
CVS tags: HEAD
updated copyright years

    1: \ Input handling (object oriented)                      22oct00py
    2: 
    3: \ Copyright (C) 2000,2003,2004,2005,2006,2007,2011 Free Software Foundation, Inc.
    4: 
    5: \ This file is part of Gforth.
    6: 
    7: \ Gforth is free software; you can redistribute it and/or
    8: \ modify it under the terms of the GNU General Public License
    9: \ as published by the Free Software Foundation, either version 3
   10: \ of the License, or (at your option) any later version.
   11: 
   12: \ This program is distributed in the hope that it will be useful,
   13: \ but WITHOUT ANY WARRANTY; without even the implied warranty of
   14: \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   15: \ GNU General Public License for more details.
   16: 
   17: \ You should have received a copy of the GNU General Public License
   18: \ along with this program. If not, see http://www.gnu.org/licenses/.
   19: 
   20: \ input handling structure:
   21: 
   22: | : input-method ( m "name" -- m' )  Create dup , cell+
   23: DOES> ( ... -- ... ) @ current-input @ @ + perform ;
   24: | : input-var ( v size "name" -- v' )  Create  over , +
   25: DOES> ( -- addr ) @ current-input @ + ;
   26: 
   27: 0
   28: input-method source ( -- addr u ) \ core source
   29:     \G Return address @i{addr} and length @i{u} of the current input
   30:     \G buffer
   31: input-method refill ( -- flag ) \ core-ext,block-ext,file-ext
   32:     \G Attempt to fill the input buffer from the input source.  When
   33:     \G the input source is the user input device, attempt to receive
   34:     \G input into the terminal input device. If successful, make the
   35:     \G result the input buffer, set @code{>IN} to 0 and return true;
   36:     \G otherwise return false. When the input source is a block, add 1
   37:     \G to the value of @code{BLK} to make the next block the input
   38:     \G source and current input buffer, and set @code{>IN} to 0;
   39:     \G return true if the new value of @code{BLK} is a valid block
   40:     \G number, false otherwise. When the input source is a text file,
   41:     \G attempt to read the next line from the file. If successful,
   42:     \G make the result the current input buffer, set @code{>IN} to 0
   43:     \G and return true; otherwise, return false.  A successful result
   44:     \G includes receipt of a line containing 0 characters.
   45: input-method source-id ( -- 0 | -1 | fileid ) \ core-ext,file source-i-d
   46:     \G Return 0 (the input source is the user input device), -1 (the
   47:     \G input source is a string being processed by @code{evaluate}) or
   48:     \G a @i{fileid} (the input source is the file specified by
   49:     \G @i{fileid}).
   50: | input-method (save-input) ( -- x1 .. xn n ) \ gforth
   51: | input-method (restore-input) ( x1 .. xn n -- ) \ gforth
   52: drop
   53: 
   54: cell \ the first cell points to the method table
   55: cell input-var >in ( -- addr ) \ core to-in
   56:     \G @code{input-var} variable -- @i{a-addr} is the address of a
   57:     \G cell containing the char offset from the start of the input
   58:     \G buffer to the start of the parse area.
   59: 2 cells input-var input-lexeme ( -- a-addr ) \ gforth-internal
   60:     \G @code{input-var} variable -- @i{a-addr} is the address of two
   61:     \G cells containing the string (in c-addr u form) parsed with
   62:     \G @code{parse}, @code{parse-name} or @code{word}.  If you do your
   63:     \G own parsing, you can set it with @code{input-lexeme!}.
   64: cell input-var #tib ( -- addr ) \ core-ext-obsolescent number-t-i-b
   65:     \G @code{input-var} variable -- @i{a-addr} is the address of a
   66:     \G cell containing the number of characters in the terminal input
   67:     \G buffer. OBSOLESCENT: @code{source} superceeds the function of
   68:     \G this word.
   69: cell input-var max#tib ( -- addr ) \ gforth max-number-t-i-b
   70:     \G @code{input-var} variable -- This cell contains the maximum
   71:     \G size of the current tib.
   72: cell input-var old-input ( -- addr ) \ gforth
   73:     \G @code{input-var} variable -- This cell contains the pointer to
   74:     \G the previous input buffer
   75: cell input-var loadline ( -- addr ) \ gforth
   76:     \G @code{input-var} variable -- This cell contains the line that's
   77:     \G currently loaded from
   78: has? file [IF]
   79: cell input-var loadfile ( -- addr ) \ gforth
   80:     \G @code{input-var} variable -- This cell contains the file the
   81:     \G input buffer is associated with (0 if none)
   82: cell input-var blk ( -- addr ) \ block b-l-k
   83:     \G @code{input-var} variable -- This cell contains the current
   84:     \G block number (or 0 if the current input source is not a block).
   85: cell input-var #fill-bytes ( -- addr ) \ gforth
   86:     \G @code{input-var} variable -- number of bytes read via
   87:     \G (read-line) by the last refill
   88: 2 cells input-var loadfilename ( -- addr ) \ gforth
   89:     \G @code{input-var} variable -- addr u describes name of currently
   90:     \G interpreted input (file name or somesuch)
   91: [THEN]
   92: 0 input-var tib ( -- addr ) \ core-ext-obsolescent t-i-b
   93: 
   94: Constant tib+
   95: 
   96: \ helper words
   97: 
   98: : input-lexeme! ( c-addr u -- )
   99:     \ record that the current lexeme us c-addr u
  100:     input-lexeme 2! ;
  101: 
  102: : input-start-line ( -- )
  103:     >in off  source drop 0 input-lexeme! ;
  104: 
  105: \ terminal input implementation
  106: 
  107: :noname ( in 1 -- ) 1 <> -12 and throw >in ! ;
  108:                        \ restore-input
  109: :noname ( -- in 1 ) >in @ 1 ;     \ save-input
  110: ' false                \ source-id
  111: :noname ( -- flag ) [ has? file [IF] ] 
  112:     stdin file-eof?  IF  false  EXIT  THEN [ [THEN] ]
  113:     tib max#tib @ accept #tib !
  114:     input-start-line true 1 loadline +! ;     \ refill
  115: :noname ( -- addr u ) tib #tib @ ;   \ source
  116: 
  117: | Create terminal-input   A, A, A, A, A,
  118: :noname ( -- addr u ) tib @ #tib @ ; \ source
  119: | Create evaluate-input
  120:     A,                  \ source
  121:     ' false A,          \ refill
  122:     ' true A,           \ source-id
  123:     terminal-input 3 cells + @ A, \ terminal::restore-input
  124:     terminal-input 4 cells + @ A, \ terminal::save-input
  125: 
  126: \ file input implementation
  127: 
  128: has? file [IF]
  129: : read-line ( c_addr u1 wfileid -- u2 flag wior ) \ file
  130:     (read-line) nip ;
  131: 
  132: :noname  ( in line# udpos 4 -- ) 4 <> -12 and throw
  133:     loadfile @ reposition-file throw
  134:     refill 0= -36 and throw \ should never throw
  135:     loadline ! >in ! ; \ restore-input
  136: :noname  ( -- in line# udpos 4 ) >in @ sourceline#
  137:     loadfile @ file-position throw #fill-bytes @ 0 d-
  138:     4 ;                \ save-input
  139: :noname  ( -- file ) loadfile @ ;  \ source-id
  140: :noname  ( -- flag )
  141:     #tib off #fill-bytes off input-start-line
  142:     BEGIN
  143: 	tib max#tib @ #tib @ /string
  144: 	loadfile @ (read-line) throw #fill-bytes +!
  145: 	swap #tib +!
  146: 	\ auto-expanding the tib
  147: 	dup #tib @ #fill-bytes @ = and WHILE
  148: 	    drop max#tib @ 2* expand-tib
  149:     REPEAT
  150:     1 loadline +! ;
  151:                        \ refill
  152: terminal-input @       \ source -> terminal-input::source
  153: 
  154: | Create file-input  A, A, A, A, A,
  155: [THEN]
  156: 
  157: \ push-file, pop-file
  158: 
  159: : new-tib ( method n -- ) \ gforth
  160:     \G Create a new entry of the tib stack, size @i{n}, method table
  161:     \G @i{method}.
  162:     dup >r tib+ + dup allocate throw tuck swap 0 fill
  163:     current-input @ swap current-input ! old-input ! r> max#tib !
  164:     current-input @ ! ;
  165: : expand-tib ( n -- )
  166:     dup tib+ + current-input @ swap resize throw current-input !
  167:     max#tib ! tib max#tib @ #tib @ /string 0 fill ;
  168: has? file [IF]
  169: : push-file  ( -- ) \ gforth
  170:     \G Create a new file input buffer
  171:     file-input def#tib new-tib ;
  172: [THEN]
  173: : pop-file ( throw-code -- throw-code ) \ gforth
  174:     \G pop and free the current top input buffer
  175:     dup IF
  176: 	input-error-data >error
  177:     THEN
  178:     current-input @ old-input @ current-input ! free throw ;
  179: 
  180: \ save-input, restore-input
  181: 
  182: : save-input ( -- x1 .. xn n ) \ core-ext
  183:     \G The @i{n} entries @i{xn - x1} describe the current state of the
  184:     \G input source specification, in some platform-dependent way that can
  185:     \G be used by @code{restore-input}.
  186:     (save-input) current-input @ swap 1+ ;
  187: : restore-input ( x1 .. xn n -- flag ) \ core-ext
  188:     \G Attempt to restore the input source specification to the state
  189:     \G described by the @i{n} entries @i{xn - x1}. @i{flag} is true if
  190:     \G the restore fails.  In Gforth with the new input code, it fails
  191:     \G only with a flag that can be used to throw again; it is also
  192:     \G possible to save and restore between different active input
  193:     \G streams. Note that closing the input streams must happen in the
  194:     \G reverse order as they have been opened, but in between
  195:     \G everything is allowed.
  196:     current-input @ >r swap current-input ! 1- dup >r
  197:     ['] (restore-input) catch
  198:     dup IF  r> 0 ?DO  nip  LOOP  r> current-input !  EXIT  THEN
  199:     rdrop rdrop ;
  200: 
  201: \ create terminal input block
  202: 
  203: : create-input ( -- )
  204:     \G create a new terminal input
  205:     terminal-input def#tib new-tib ;
  206:     \ s" *the terminal*" loadfilename 2!
  207: 
  208: : execute-parsing-wrapper ( ... addr1 u1 xt addr2 u2 -- ... ) \ gforth-internal
  209:     \ addr1 u1 is the string to be processed, xt is the word for
  210:     \ processing it, addr2 u2 is the name of the input source
  211:     rot >r 2>r evaluate-input cell new-tib 2r> 
  212: [ has? file [IF] ]
  213:     loadfilename 2!
  214: [ [ELSE] ]
  215:     2drop
  216: [ [THEN] ]
  217:     -1 loadline ! #tib ! tib !
  218:     r> catch pop-file throw ;
  219: 
  220: : execute-parsing ( ... addr u xt -- ... ) \ gforth
  221: \G Make @i{addr u} the current input source, execute @i{xt @code{(
  222: \G ... -- ... )}}, then restore the previous input source.
  223:     s" *evaluated string*" execute-parsing-wrapper ;
  224: 
  225: : evaluate ( ... addr u -- ... ) \ core,block
  226: \G Save the current input source specification. Store @code{-1} in
  227: \G @code{source-id} and @code{0} in @code{blk}. Set @code{>IN} to
  228: \G @code{0} and make the string @i{c-addr u} the input source and
  229: \G input buffer. Interpret. When the parse area is empty, restore the
  230: \G input source specification.
  231:     ['] interpret execute-parsing ;
  232: 
  233: \ clear tibstack
  234: 
  235: : clear-tibstack ( -- ) \ gforth
  236:     \G clears the tibstack; if there is none, create the bottom entry:
  237:     \G the terminal input buffer.
  238:     current-input @ 0= IF  create-input  THEN
  239:     BEGIN  old-input @  WHILE  0 pop-file drop  REPEAT ;
  240: 
  241: : query ( -- ) \ core-ext-obsolescent
  242:     \G Make the user input device the input source. Receive input into
  243:     \G the Terminal Input Buffer. Set @code{>IN} to zero. OBSOLESCENT:
  244:     \G superceeded by @code{accept}.
  245:     clear-tibstack  refill 0= -39 and throw ;
  246: 
  247: \ load a file
  248: 
  249: has? file [IF]
  250: defer line-end-hook ( -- ) \ gforth
  251: \G called at every end-of-line when text-interpreting from a file    
  252: \ alternatively we could use a wrapper for REFILL
  253: ' noop is line-end-hook
  254:     
  255: : read-loop ( i*x -- j*x ) \ gforth
  256:     \G refill and interpret a file until EOF
  257:     BEGIN  refill  WHILE  interpret line-end-hook REPEAT ;
  258: 
  259: : execute-parsing-named-file ( i*x wfileid filename-addr filename-u xt -- j*x )
  260:     >r push-file \ dup 2* cells included-files 2@ drop + 2@ type
  261:     loadfilename 2!  loadfile !
  262:     r> catch
  263:     loadfile @ close-file swap 2dup or
  264:     pop-file  drop throw throw ;
  265: 
  266: : execute-parsing-file ( i*x fileid xt -- j*x ) \ gforth
  267: \G Make @i{fileid} the current input source, execute @i{xt @code{( i*x
  268: \G -- j*x )}}, then restore the previous input source.
  269:     s" *a file*" rot execute-parsing-named-file ;
  270: 
  271: : include-file ( i*x wfileid -- j*x ) \ file
  272:     \G Interpret (process using the text interpreter) the contents of
  273:     \G the file @var{wfileid}.
  274:     ['] read-loop execute-parsing-file ;
  275: [THEN]

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>