\ Input handling (object oriented) 22oct00py
\ Copyright (C) 2000,2003,2004,2005 Free Software Foundation, Inc.
\ This file is part of Gforth.
\ Gforth is free software; you can redistribute it and/or
\ modify it under the terms of the GNU General Public License
\ as published by the Free Software Foundation; either version 2
\ of the License, or (at your option) any later version.
\ This program is distributed in the hope that it will be useful,
\ but WITHOUT ANY WARRANTY; without even the implied warranty of
\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
\ GNU General Public License for more details.
\ You should have received a copy of the GNU General Public License
\ along with this program; if not, write to the Free Software
\ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
\ input handling structure:
| : input-method ( m "name" -- m' ) Create dup , cell+
DOES> ( ... -- ... ) @ current-input @ @ + perform ;
| : input-var ( v size "name" -- v' ) Create over , +
DOES> ( -- addr ) @ current-input @ + ;
0
input-method source ( -- addr u ) \ core-ext,file source
\G Return address @i{addr} and length @i{u} of the current input
\G buffer
input-method refill ( -- flag ) \ core-ext,block-ext,file-ext
\G Attempt to fill the input buffer from the input source. When
\G the input source is the user input device, attempt to receive
\G input into the terminal input device. If successful, make the
\G result the input buffer, set @code{>IN} to 0 and return true;
\G otherwise return false. When the input source is a block, add 1
\G to the value of @code{BLK} to make the next block the input
\G source and current input buffer, and set @code{>IN} to 0;
\G return true if the new value of @code{BLK} is a valid block
\G number, false otherwise. When the input source is a text file,
\G attempt to read the next line from the file. If successful,
\G make the result the current input buffer, set @code{>IN} to 0
\G and return true; otherwise, return false. A successful result
\G includes receipt of a line containing 0 characters.
input-method source-id ( -- 0 | -1 | fileid ) \ core-ext,file source-i-d
\G Return 0 (the input source is the user input device), -1 (the
\G input source is a string being processed by @code{evaluate}) or
\G a @i{fileid} (the input source is the file specified by
\G @i{fileid}).
| input-method (save-input) ( -- x1 .. xn n ) \ gforth
| input-method (restore-input) ( x1 .. xn n -- ) \ gforth
drop
cell \ the first cell points to the method table
cell input-var >in ( -- addr ) \ core to-in
\G @code{input-var} variable -- @i{a-addr} is the address of a
\G cell containing the char offset from the start of the input
\G buffer to the start of the parse area.
cell input-var input-start-parse ( -- addr ) \ gforth
\G @code{input-var} variable -- @i{a-addr} is the address of a
\G cell containing a pointer to the start of the last parsed
\G string (but after skipped characters, if any); this is set
\G automatically by @code{parse}, @code{parse-name} and
\G @code{word}, but not if you set @code{>in} yourself.
cell input-var #tib ( -- addr ) \ core-ext number-t-i-b
\G @code{input-var} variable -- @i{a-addr} is the address of a
\G cell containing the number of characters in the terminal input
\G buffer. OBSOLESCENT: @code{source} superceeds the function of
\G this word.
cell input-var max#tib ( -- addr ) \ gforth max-number-t-i-b
\G @code{input-var} variable -- This cell contains the maximum
\G size of the current tib.
cell input-var old-input ( -- addr ) \ gforth
\G @code{input-var} variable -- This cell contains the pointer to
\G the previous input buffer
cell input-var loadline ( -- addr ) \ gforth
\G @code{input-var} variable -- This cell contains the line that's
\G currently loaded from
has? file [IF]
cell input-var loadfile ( -- addr ) \ gforth
\G @code{input-var} variable -- This cell contains the file the
\G input buffer is associated with (0 if none)
cell input-var blk ( -- addr ) \ block
\G @code{input-var} variable -- This cell contains the current
\G block number
cell input-var #fill-bytes ( -- addr ) \ gforth
\G @code{input-var} variable -- number of bytes read via
\G (read-line) by the last refill
2 cells input-var loadfilename ( -- addr ) \ gforth
\G @code{input-var} variable -- addr u describes name of currently
\G interpreted input (file name or somesuch)
[THEN]
0 input-var tib ( -- addr ) \ core
Constant tib+
\ helper words
: input-start-line ( -- )
>in off input-start-parse off ;
: start-lexeme ( c-addr -- )
\ record that the current lexeme starts at c-addr
source drop - input-start-parse ! ;
\ terminal input implementation
:noname ( in 1 -- ) 1 <> -12 and throw >in ! ;
\ restore-input
:noname ( -- in 1 ) >in @ 1 ; \ save-input
' false \ source-id
:noname ( -- flag ) [ has? file [IF] ]
stdin file-eof? IF false EXIT THEN [ [THEN] ]
tib max#tib @ accept #tib !
input-start-line true 1 loadline +! ; \ refill
:noname ( -- addr u ) tib #tib @ ; \ source
| Create terminal-input A, A, A, A, A,
:noname ( -- addr u ) tib @ #tib @ ; \ source
| Create evaluate-input
A, \ source
' false A, \ refill
' true A, \ source-id
terminal-input 3 cells + @ A, \ terminal::restore-input
terminal-input 4 cells + @ A, \ terminal::save-input
\ file input implementation
has? file [IF]
: read-line ( c_addr u1 wfileid -- u2 flag wior ) \ file
(read-line) nip ;
:noname ( in line# udpos 4 -- ) 4 <> -12 and throw
loadfile @ reposition-file throw
refill 0= -36 and throw \ should never throw
loadline ! >in ! ; \ restore-input
:noname ( -- in line# udpos 4 ) >in @ sourceline#
loadfile @ file-position throw #fill-bytes @ 0 d-
4 ; \ save-input
:noname ( -- file ) loadfile @ ; \ source-id
:noname ( -- flag )
#tib off #fill-bytes off input-start-line
BEGIN
tib max#tib @ #tib @ /string
loadfile @ (read-line) throw #fill-bytes +!
swap #tib +!
\ auto-expanding the tib
dup #tib @ #fill-bytes @ = and WHILE
drop max#tib @ 2* expand-tib
REPEAT
1 loadline +! ;
\ refill
terminal-input @ \ source -> terminal-input::source
| Create file-input A, A, A, A, A,
[THEN]
\ push-file, pop-file
: new-tib ( method n -- ) \ gforth
\G Create a new entry of the tib stack, size @i{n}, method table
\G @i{method}.
dup >r tib+ + dup allocate throw tuck swap 0 fill
current-input @ swap current-input ! old-input ! r> max#tib !
current-input @ ! ;
: expand-tib ( n -- )
dup tib+ + current-input @ swap resize throw current-input !
max#tib ! tib max#tib @ #tib @ /string 0 fill ;
has? file [IF]
: push-file ( -- ) \ gforth
\G Create a new file input buffer
file-input def#tib new-tib ;
[THEN]
: pop-file ( throw-code -- throw-code ) \ gforth
\G pop and free the current top input buffer
dup IF
input-error-data >error
THEN
current-input @ old-input @ current-input ! free throw ;
\ save-input, restore-input
: save-input ( -- x1 .. xn n ) \ core-ext
\G The @i{n} entries @i{xn - x1} describe the current state of the
\G input source specification, in some platform-dependent way that can
\G be used by @code{restore-input}.
(save-input) current-input @ swap 1+ ;
: restore-input ( x1 .. xn n -- flag ) \ core-ext
\G Attempt to restore the input source specification to the state
\G described by the @i{n} entries @i{xn - x1}. @i{flag} is true if
\G the restore fails. In Gforth with the new input code, it fails
\G only with a flag that can be used to throw again; it is also
\G possible to save and restore between different active input
\G streams. Note that closing the input streams must happen in the
\G reverse order as they have been opened, but in between
\G everything is allowed.
current-input @ >r swap current-input ! 1- dup >r
['] (restore-input) catch
dup IF r> 0 ?DO nip LOOP r> current-input ! EXIT THEN
rdrop rdrop ;
\ create terminal input block
: create-input ( -- )
\G create a new terminal input
terminal-input def#tib new-tib ;
\ s" *the terminal*" loadfilename 2!
: execute-parsing-wrapper ( ... addr1 u1 xt addr2 u2 -- ... ) \ gforth-internal
\ addr1 u1 is the string to be processed, xt is the word for
\ processing it, addr2 u2 is the name of the input source
rot >r 2>r evaluate-input cell new-tib 2r>
[ has? file [IF] ]
loadfilename 2!
[ [ELSE] ]
2drop
[ [THEN] ]
-1 loadline ! #tib ! tib !
r> catch pop-file throw ;
: execute-parsing ( ... addr u xt -- ... ) \ gforth
\G Make @i{addr u} the current input source, execute @i{xt @code{(
\G ... -- ... )}}, then restore the previous input source.
s" *evaluated string*" execute-parsing-wrapper ;
: evaluate ( ... addr u -- ... ) \ core,block
\G Save the current input source specification. Store @code{-1} in
\G @code{source-id} and @code{0} in @code{blk}. Set @code{>IN} to
\G @code{0} and make the string @i{c-addr u} the input source and
\G input buffer. Interpret. When the parse area is empty, restore the
\G input source specification.
['] interpret execute-parsing ;
\ clear tibstack
: clear-tibstack ( -- ) \ gforth
\G clears the tibstack; if there is none, create the bottom entry:
\G the terminal input buffer.
current-input @ 0= IF create-input THEN
BEGIN old-input @ WHILE 0 pop-file drop REPEAT ;
: query ( -- ) \ core-ext
\G Make the user input device the input source. Receive input into
\G the Terminal Input Buffer. Set @code{>IN} to zero. OBSOLESCENT:
\G superceeded by @code{accept}.
clear-tibstack refill 0= -39 and throw ;
\ load a file
has? file [IF]
defer line-end-hook ( -- ) \ gforth
\G called at every end-of-line when text-interpreting from a file
\ alternatively we could use a wrapper for REFILL
' noop is line-end-hook
: read-loop ( i*x -- j*x ) \ gforth
\G refill and interpret a file until EOF
BEGIN refill WHILE interpret line-end-hook REPEAT ;
: execute-parsing-named-file ( i*x wfileid filename-addr filename-u xt -- j*x )
>r push-file \ dup 2* cells included-files 2@ drop + 2@ type
loadfilename 2! loadfile !
r> catch
loadfile @ close-file swap 2dup or
pop-file drop throw throw ;
: execute-parsing-file ( i*x fileid xt -- j*x ) \ gforth
\G Make @i{fileid} the current input source, execute @i{xt @code{( i*x
\G -- j*x )}}, then restore the previous input source.
s" *a file*" rot execute-parsing-named-file ;
: include-file ( i*x wfileid -- j*x ) \ file
\G Interpret (process using the text interpreter) the contents of
\G the file @var{wfileid}.
['] read-loop execute-parsing-file ;
[THEN]
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>