1: \ Input handling (object oriented) 22oct00py
2:
3: \ Copyright (C) 2000 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 2
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, write to the Free Software
19: \ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
20:
21: \ input handling structure:
22:
23: | : input-method ( m "name" -- m' ) Create dup , cell+
24: DOES> ( ... -- ... ) @ current-input @ @ + perform ;
25: | : input-var ( v size "name" -- v' ) Create over , +
26: DOES> ( -- addr ) @ current-input @ + ;
27:
28: 0
29: input-method source ( -- addr u ) \ core-ext,file source
30: \G Return address @i{addr} and length @i{u} of the current input
31: \G buffer
32: input-method refill ( -- flag ) \ core-ext,block-ext,file-ext
33: \G Attempt to fill the input buffer from the input source. When
34: \G the input source is the user input device, attempt to receive
35: \G input into the terminal input device. If successful, make the
36: \G result the input buffer, set @code{>IN} to 0 and return true;
37: \G otherwise return false. When the input source is a block, add 1
38: \G to the value of @code{BLK} to make the next block the input
39: \G source and current input buffer, and set @code{>IN} to 0;
40: \G return true if the new value of @code{BLK} is a valid block
41: \G number, false otherwise. When the input source is a text file,
42: \G attempt to read the next line from the file. If successful,
43: \G make the result the current input buffer, set @code{>IN} to 0
44: \G and return true; otherwise, return false. A successful result
45: \G includes receipt of a line containing 0 characters.
46: input-method source-id ( -- 0 | -1 | fileid ) \ core-ext,file source-i-d
47: \G Return 0 (the input source is the user input device), -1 (the
48: \G input source is a string being processed by @code{evaluate}) or
49: \G a @i{fileid} (the input source is the file specified by
50: \G @i{fileid}).
51: | input-method (save-input) ( -- x1 .. xn n ) \ gforth
52: | input-method (restore-input) ( x1 .. xn n -- ) \ gforth
53: drop
54:
55: cell \ the first cell points to the method table
56: cell input-var >in \ core to-in
57: \G @code{input-var} variable -- @i{a-addr} is the address of a
58: \G cell containing the char offset from the start of the input
59: \G buffer to the start of the parse area.
60: cell input-var #tib \ core-ext number-t-i-b
61: \G @code{input-var} variable -- @i{a-addr} is the address of a
62: \G cell containing the number of characters in the terminal input
63: \G buffer. OBSOLESCENT: @code{source} superceeds the function of
64: \G this word.
65: cell input-var max#tib \ gforth max-number-t-i-b
66: \G @code{input-var} variable -- This cell contains the maximum
67: \G size of the current tib.
68: cell input-var old-input \ gforth
69: \G @code{input-var} variable -- This cell contains the pointer to
70: \G the previous input buffer
71: cell input-var loadline \ gforth
72: \G @code{input-var} variable -- This cell contains the line that's
73: \G currently loaded from
74: has? file [IF]
75: cell input-var loadfile \ gforth
76: \G @code{input-var} variable -- This cell contains the file the
77: \G input buffer is associated with (0 if none)
78: cell input-var blk \ block
79: \G @code{input-var} variable -- This cell contains the current
80: \G block number
81: cell input-var #fill-bytes \ gforth
82: \G @code{input-var} variable -- number of bytes read via
83: \G (read-line) by the last refill
84: 2 cells input-var loadfilename \ gforth
85: \G @code{input-var} variable -- addr u describes name of currently
86: \G interpreted input (file name or somesuch)
87: [THEN]
88: 0 input-var tib
89:
90: Constant tib+
91:
92: \ terminal input implementation
93:
94: :noname ( in 1 -- ) 1 <> -12 and throw >in ! ;
95: \ restore-input
96: :noname ( -- in 1 ) >in @ 1 ; \ save-input
97: ' false \ source-id
98: :noname ( -- flag ) [ has? file [IF] ]
99: stdin file-eof? IF false EXIT THEN [ [THEN] ]
100: tib max#tib @ accept #tib !
101: >in off true 1 loadline +! ; \ refill
102: :noname ( -- addr u ) tib #tib @ ; \ source
103:
104: | Create terminal-input A, A, A, A, A,
105: :noname ( -- addr u ) tib @ #tib @ ; \ source
106: | Create evaluate-input
107: A, \ source
108: ' false A, \ refill
109: ' true A, \ source-id
110: terminal-input 3 cells + @ A, \ terminal::restore-input
111: terminal-input 4 cells + @ A, \ terminal::save-input
112:
113: \ file input implementation
114:
115: has? file [IF]
116: : read-line ( c_addr u1 wfileid -- u2 flag wior ) (read-line) nip ;
117:
118: :noname ( in line# udpos 4 -- ) 4 <> -12 and throw
119: loadfile @ reposition-file throw
120: refill 0= -36 and throw \ should never throw
121: loadline ! >in ! ; \ restore-input
122: :noname ( -- in line# udpos 4 ) >in @ sourceline#
123: loadfile @ file-position throw #fill-bytes @ 0 d-
124: 4 ; \ save-input
125: :noname ( -- file ) loadfile @ ; \ source-id
126: :noname ( -- flag )
127: #tib off #fill-bytes off >in off
128: BEGIN
129: tib max#tib @ #tib @ /string
130: loadfile @ (read-line) throw #fill-bytes +!
131: swap #tib +!
132: \ auto-expanding the tib
133: dup #tib @ #fill-bytes @ = and WHILE
134: drop max#tib @ 2* expand-tib
135: REPEAT
136: 1 loadline +! ;
137: \ refill
138: terminal-input @ \ source -> terminal-input::source
139:
140: | Create file-input A, A, A, A, A,
141: [THEN]
142:
143: \ push-file, pop-file
144:
145: : new-tib ( method n -- ) \ gforth
146: \G Create a new entry of the tib stack, size @i{n}, method table
147: \G @i{method}.
148: dup >r tib+ + dup allocate throw tuck swap 0 fill
149: current-input @ swap current-input ! old-input ! r> max#tib !
150: current-input @ ! ;
151: : expand-tib ( n -- )
152: dup tib+ + current-input @ swap resize throw current-input !
153: max#tib ! tib max#tib @ #tib @ /string 0 fill ;
154: has? file [IF]
155: : push-file ( -- ) \ gforth
156: \G Create a new file input buffer
157: file-input def#tib new-tib ;
158: [THEN]
159: : pop-file ( throw-code -- throw-code ) \ gforth
160: \G pop and free the current top input buffer
161: dup IF
162: source >in @ sourceline#
163: [ has? file [IF] ] sourcefilename [ [THEN] ]
164: >error
165: THEN
166: current-input @ old-input @ current-input ! free throw ;
167:
168: \ save-input, restore-input
169:
170: : save-input ( -- x1 .. xn n ) \ core-ext
171: \G The @i{n} entries @i{xn - x1} describe the current state of the
172: \G input source specification, in some platform-dependent way that can
173: \G be used by @code{restore-input}.
174: (save-input) current-input @ swap 1+ ;
175: : restore-input ( x1 .. xn n -- flag ) \ core-ext
176: \G Attempt to restore the input source specification to the state
177: \G described by the @i{n} entries @i{xn - x1}. @i{flag} is true if
178: \G the restore fails. In Gforth with the new input code, it fails
179: \G only with a flag that can be used to throw again; it is also
180: \G possible to save and restore between different active input
181: \G streams. Note that closing the input streams must happen in the
182: \G reverse order as they have been opened, but in between
183: \G everything is allowed.
184: current-input @ >r swap current-input ! 1- dup >r
185: ['] (restore-input) catch
186: dup IF r> 0 ?DO nip LOOP r> current-input ! EXIT THEN
187: rdrop rdrop ;
188:
189: \ create terminal input block
190:
191: : create-input ( -- )
192: \G create a new terminal input
193: terminal-input def#tib new-tib ;
194: \ s" *the terminal*" loadfilename 2!
195:
196: : evaluate ( addr u -- ) \ core,block
197: \G Save the current input source specification. Store @code{-1} in
198: \G @code{source-id} and @code{0} in @code{blk}. Set @code{>IN} to
199: \G @code{0} and make the string @i{c-addr u} the input source
200: \G and input buffer. Interpret. When the parse area is empty,
201: \G restore the input source specification.
202: evaluate-input cell new-tib
203: [ has? file [IF] ]
204: s" *evaluated string*" loadfilename 2!
205: [ [THEN] ]
206: -1 loadline ! #tib ! tib !
207: ['] interpret catch pop-file throw ;
208:
209: \ clear tibstack
210:
211: : clear-tibstack ( -- ) \ gforth
212: \G clears the tibstack; if there is none, create the bottom entry:
213: \G the terminal input buffer.
214: current-input @ 0= IF create-input THEN
215: BEGIN old-input @ WHILE 0 pop-file drop REPEAT ;
216:
217: : query ( -- ) \ core-ext
218: \G Make the user input device the input source. Receive input into
219: \G the Terminal Input Buffer. Set @code{>IN} to zero. OBSOLESCENT:
220: \G superceeded by @code{accept}.
221: clear-tibstack refill drop ;
222:
223: \ load a file
224:
225: has? file [IF]
226: : read-loop ( i*x -- j*x ) \ gforth
227: \G refill and interpret a file until EOF
228: BEGIN refill WHILE interpret REPEAT ;
229:
230: : include-file2 ( i*x wfileid filename-addr filename-u -- j*x )
231: push-file \ dup 2* cells included-files 2@ drop + 2@ type
232: loadfilename 2! loadfile !
233: ['] read-loop catch
234: loadfile @ close-file swap 2dup or
235: pop-file drop throw throw ;
236:
237: : include-file ( i*x wfileid -- j*x )
238: \G Interpret (process using the text interpreter) the contents of
239: \G the file @var{wfileid}.
240: s" * a file*" include-file2 ;
241: [THEN]
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to input.fs CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [gforth] / gforth / kernel