[gforth] / gforth / kernel / comp.fs  

gforth: gforth/kernel/comp.fs


1 : pazsan 1.1 \ compiler definitions 14sep97jaw
2 :    
3 : anton 1.6 \ Copyright (C) 1995,1996,1997,1998 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., 675 Mass Ave, Cambridge, MA 02139, USA.
20 :    
21 : pazsan 1.1 \ \ Revisions-Log
22 :    
23 :     \ put in seperate file 14sep97jaw
24 :    
25 :     \ \ here allot , c, A, 17dec92py
26 :    
27 :     : allot ( n -- ) \ core
28 : crook 1.11 \G Reserve or release @var{n} address units of data space; @var{n}
29 :     \G is a signed number. There are restrictions on releasing data
30 :     \G space.
31 : anton 1.12 here +
32 :     dup 1- usable-dictionary-end forthstart within -8 and throw
33 :     dp ! ;
34 : pazsan 1.1
35 :     : c, ( c -- ) \ core
36 : crook 1.11 \G Reserve data space for one char and store @var{c} in the space.
37 : pazsan 1.1 here 1 chars allot c! ;
38 :    
39 : crook 1.11 : , ( w -- ) \ core
40 :     \G Reserve data space for one cell and store @var{w} in the space.
41 : pazsan 1.1 here cell allot ! ;
42 :    
43 :     : 2, ( w1 w2 -- ) \ gforth
44 : crook 1.11 \G Reserve data space for two cells and store the double @var{w1
45 :     \G w2} in the space.
46 : pazsan 1.1 here 2 cells allot 2! ;
47 :    
48 :     \ : aligned ( addr -- addr' ) \ core
49 :     \ [ cell 1- ] Literal + [ -1 cells ] Literal and ;
50 :    
51 :     : align ( -- ) \ core
52 :     here dup aligned swap ?DO bl c, LOOP ;
53 :    
54 :     \ : faligned ( addr -- f-addr ) \ float
55 :     \ [ 1 floats 1- ] Literal + [ -1 floats ] Literal and ;
56 :    
57 :     : falign ( -- ) \ float
58 :     here dup faligned swap
59 :     ?DO
60 :     bl c,
61 :     LOOP ;
62 :    
63 : anton 1.9 : maxalign ( -- ) \ gforth
64 : pazsan 1.1 here dup maxaligned swap
65 :     ?DO
66 :     bl c,
67 :     LOOP ;
68 :    
69 :     \ the code field is aligned if its body is maxaligned
70 :     ' maxalign Alias cfalign ( -- ) \ gforth
71 :    
72 :     ' , alias A, ( addr -- ) \ gforth
73 :    
74 :     ' NOOP ALIAS const
75 :    
76 :     \ \ Header 23feb93py
77 :    
78 :     \ input-stream, nextname and noname are quite ugly (passing
79 :     \ information through global variables), but they are useful for dealing
80 :     \ with existing/independent defining words
81 :    
82 :     defer (header)
83 :     defer header ( -- ) \ gforth
84 :     ' (header) IS header
85 :    
86 :     : string, ( c-addr u -- ) \ gforth
87 :     \G puts down string as cstring
88 :     dup c, here swap chars dup allot move ;
89 :    
90 :     : header, ( c-addr u -- ) \ gforth
91 :     name-too-long?
92 :     align here last !
93 :     current @ 1 or A, \ link field; before revealing, it contains the
94 :     \ tagged reveal-into wordlist
95 :     string, cfalign
96 :     alias-mask lastflags cset ;
97 :    
98 :     : input-stream-header ( "name" -- )
99 :     name name-too-short? header, ;
100 :    
101 :     : input-stream ( -- ) \ general
102 :     \G switches back to getting the name from the input stream ;
103 :     ['] input-stream-header IS (header) ;
104 :    
105 :     ' input-stream-header IS (header)
106 :    
107 :     \ !! make that a 2variable
108 :     create nextname-buffer 32 chars allot
109 :    
110 :     : nextname-header ( -- )
111 :     nextname-buffer count header,
112 :     input-stream ;
113 :    
114 :     \ the next name is given in the string
115 :    
116 :     : nextname ( c-addr u -- ) \ gforth
117 :     name-too-long?
118 :     nextname-buffer c! ( c-addr )
119 :     nextname-buffer count move
120 :     ['] nextname-header IS (header) ;
121 :    
122 :     : noname-header ( -- )
123 :     0 last ! cfalign
124 :     input-stream ;
125 :    
126 :     : noname ( -- ) \ gforth
127 :     \ the next defined word remains anonymous. The xt of that word is given by lastxt
128 :     ['] noname-header IS (header) ;
129 :    
130 :     : lastxt ( -- xt ) \ gforth
131 :     \ xt is the execution token of the last word defined. The main purpose of this word is to get the xt of words defined using noname
132 :     lastcfa @ ;
133 :    
134 :     \ \ literals 17dec92py
135 :    
136 :     : Literal ( compilation n -- ; run-time -- n ) \ core
137 : crook 1.10 \G Compile appropriate code such that, at run-time, @var{n} is placed
138 : crook 1.8 \G on the stack. Interpretation semantics are undefined.
139 : pazsan 1.1 postpone lit , ; immediate restrict
140 :    
141 :     : ALiteral ( compilation addr -- ; run-time -- addr ) \ gforth
142 :     postpone lit A, ; immediate restrict
143 :    
144 : crook 1.8 : char ( '<spaces>ccc' -- c ) \ core
145 : crook 1.10 \G Skip leading spaces. Parse the string @var{ccc} and return @var{c}, the
146 :     \G display code representing the first character of @var{ccc}.
147 : pazsan 1.1 bl word char+ c@ ;
148 :    
149 : crook 1.8 : [char] ( compilation '<spaces>ccc' -- ; run-time -- c ) \ core bracket-char
150 : crook 1.10 \G Compilation: skip leading spaces. Parse the string
151 :     \G @var{ccc}. Run-time: return @var{c}, the display code
152 :     \G representing the first character of @var{ccc}. Interpretation
153 :     \G semantics for this word are undefined.
154 : pazsan 1.1 char postpone Literal ; immediate restrict
155 :    
156 :     \ \ threading 17mar93py
157 :    
158 :     : cfa, ( code-address -- ) \ gforth cfa-comma
159 :     here
160 :     dup lastcfa !
161 :     0 A, 0 , code-address! ;
162 :    
163 :     : compile, ( xt -- ) \ core-ext compile-comma
164 : crook 1.10 \G Compile the word represented by the execution token, @var{xt}.
165 : pazsan 1.1 A, ;
166 :    
167 :     : !does ( addr -- ) \ gforth store-does
168 :     lastxt does-code! ;
169 :    
170 :     : (does>) ( R: addr -- )
171 :     r> cfaligned /does-handler + !does ;
172 :    
173 :     : dodoes, ( -- )
174 :     cfalign here /does-handler allot does-handler! ;
175 :    
176 :     : (compile) ( -- ) \ gforth
177 :     r> dup cell+ >r @ compile, ;
178 :    
179 : anton 1.4 : postpone, ( w xt -- ) \ gforth postpone-comma
180 : crook 1.10 \g Compile the compilation semantics represented by @var{w xt}.
181 : pazsan 1.1 dup ['] execute =
182 :     if
183 :     drop compile,
184 :     else
185 :     dup ['] compile, =
186 :     if
187 :     drop POSTPONE (compile) compile,
188 :     else
189 :     swap POSTPONE aliteral compile,
190 :     then
191 :     then ;
192 :    
193 :     : POSTPONE ( "name" -- ) \ core
194 :     \g Compiles the compilation semantics of @var{name}.
195 :     COMP' postpone, ; immediate restrict
196 :    
197 :     struct
198 :     >body
199 :     cell% field interpret/compile-int
200 :     cell% field interpret/compile-comp
201 :     end-struct interpret/compile-struct
202 :    
203 :     : interpret/compile: ( interp-xt comp-xt "name" -- ) \ gforth
204 :     Create immediate swap A, A,
205 :     DOES>
206 :     abort" executed primary cfa of an interpret/compile: word" ;
207 :     \ state @ IF cell+ THEN perform ;
208 :    
209 :     \ \ ticks
210 :    
211 :     : name>comp ( nt -- w xt ) \ gforth
212 :     \G @var{w xt} is the compilation token for the word @var{nt}.
213 :     (name>comp)
214 :     1 = if
215 :     ['] execute
216 :     else
217 :     ['] compile,
218 :     then ;
219 :    
220 :     : [(')] ( compilation "name" -- ; run-time -- nt ) \ gforth bracket-paren-tick
221 :     (') postpone ALiteral ; immediate restrict
222 :    
223 :     : ['] ( compilation. "name" -- ; run-time. -- xt ) \ core bracket-tick
224 :     \g @var{xt} represents @var{name}'s interpretation
225 :     \g semantics. Performs @code{-14 throw} if the word has no
226 :     \g interpretation semantics.
227 :     ' postpone ALiteral ; immediate restrict
228 :    
229 : anton 1.5 : COMP' ( "name" -- w xt ) \ gforth comp-tick
230 : pazsan 1.1 \g @var{w xt} represents @var{name}'s compilation semantics.
231 :     (') name>comp ;
232 :    
233 :     : [COMP'] ( compilation "name" -- ; run-time -- w xt ) \ gforth bracket-comp-tick
234 :     \g @var{w xt} represents @var{name}'s compilation semantics.
235 :     COMP' swap POSTPONE Aliteral POSTPONE ALiteral ; immediate restrict
236 :    
237 :     \ \ recurse 17may93jaw
238 :    
239 :     : recurse ( compilation -- ; run-time ?? -- ?? ) \ core
240 : crook 1.10 \g Call the current definition.
241 : pazsan 1.1 lastxt compile, ; immediate restrict
242 :    
243 :     \ \ compiler loop
244 :    
245 :     : compiler ( c-addr u -- )
246 :     2dup find-name dup
247 :     if ( c-addr u nt )
248 :     nip nip name>comp execute
249 :     else
250 :     drop
251 :     2dup snumber? dup
252 :     IF
253 :     0>
254 :     IF
255 :     swap postpone Literal
256 :     THEN
257 :     postpone Literal
258 :     2drop
259 :     ELSE
260 :     drop compiler-notfound
261 :     THEN
262 :     then ;
263 :    
264 :     : [ ( -- ) \ core left-bracket
265 : crook 1.8 \G Enter interpretation state. Immediate word.
266 : pazsan 1.1 ['] interpreter IS parser state off ; immediate
267 :    
268 :     : ] ( -- ) \ core right-bracket
269 : crook 1.8 \G Enter compilation state.
270 : pazsan 1.1 ['] compiler IS parser state on ;
271 :    
272 :     \ \ Strings 22feb93py
273 :    
274 :     : ," ( "string"<"> -- ) [char] " parse
275 :     here over char+ allot place align ;
276 :    
277 :     : SLiteral ( Compilation c-addr1 u ; run-time -- c-addr2 u ) \ string
278 : crook 1.10 \G Compilation: compile the string specified by @var{c-addr1},
279 :     \G @var{u} into the current definition. Run-time: return
280 :     \G @var{c-addr2 u} describing the address and length of the
281 :     \G string.
282 : pazsan 1.1 postpone (S") here over char+ allot place align ;
283 :     immediate restrict
284 :    
285 :     \ \ abort" 22feb93py
286 :    
287 :     : abort" ( compilation 'ccc"' -- ; run-time f -- ) \ core,exception-ext abort-quote
288 : crook 1.10 \G If any bit of @var{f} is non-zero, perform the function of @code{-2 throw},
289 :     \G displaying the string @var{ccc} if there is no exception frame on the
290 :     \G exception stack.
291 : pazsan 1.1 postpone (abort") ," ; immediate restrict
292 :    
293 :     \ \ Header states 23feb93py
294 :    
295 :     : cset ( bmask c-addr -- )
296 :     tuck c@ or swap c! ;
297 :    
298 :     : creset ( bmask c-addr -- )
299 :     tuck c@ swap invert and swap c! ;
300 :    
301 :     : ctoggle ( bmask c-addr -- )
302 :     tuck c@ xor swap c! ;
303 :    
304 :     : lastflags ( -- c-addr )
305 :     \ the address of the flags byte in the last header
306 :     \ aborts if the last defined word was headerless
307 :     last @ dup 0= abort" last word was headerless" cell+ ;
308 :    
309 :     : immediate ( -- ) \ core
310 : crook 1.10 \G Make the compilation semantics of a word be to @code{execute}
311 :     \G the execution semantics.
312 : pazsan 1.1 immediate-mask lastflags cset ;
313 :    
314 :     : restrict ( -- ) \ gforth
315 : crook 1.10 \G A synonym for @code{compile-only}
316 : pazsan 1.1 restrict-mask lastflags cset ;
317 :     ' restrict alias compile-only ( -- ) \ gforth
318 : crook 1.10 \G Remove the interpretation semantics of a word.
319 : pazsan 1.1
320 :     \ \ Create Variable User Constant 17mar93py
321 :    
322 :     : Alias ( cfa "name" -- ) \ gforth
323 :     Header reveal
324 :     alias-mask lastflags creset
325 :     dup A, lastcfa ! ;
326 :    
327 :     doer? :dovar [IF]
328 :    
329 :     : Create ( "name" -- ) \ core
330 :     Header reveal dovar: cfa, ;
331 :     [ELSE]
332 :    
333 :     : Create ( "name" -- ) \ core
334 :     Header reveal here lastcfa ! 0 A, 0 , DOES> ;
335 :     [THEN]
336 :    
337 :     : Variable ( "name" -- ) \ core
338 :     Create 0 , ;
339 :    
340 :     : AVariable ( "name" -- ) \ gforth
341 :     Create 0 A, ;
342 :    
343 :     : 2Variable ( "name" -- ) \ double
344 :     create 0 , 0 , ;
345 :    
346 :     : uallot ( n -- ) udp @ swap udp +! ;
347 :    
348 :     doer? :douser [IF]
349 :    
350 :     : User ( "name" -- ) \ gforth
351 :     Header reveal douser: cfa, cell uallot , ;
352 :    
353 :     : AUser ( "name" -- ) \ gforth
354 :     User ;
355 :     [ELSE]
356 :    
357 :     : User Create cell uallot , DOES> @ up @ + ;
358 :    
359 :     : AUser User ;
360 :     [THEN]
361 :    
362 :     doer? :docon [IF]
363 :     : (Constant) Header reveal docon: cfa, ;
364 :     [ELSE]
365 :     : (Constant) Create DOES> @ ;
366 :     [THEN]
367 :    
368 :     : Constant ( w "name" -- ) \ core
369 :     \G Defines constant @var{name}
370 :     \G
371 :     \G @var{name} execution: @var{-- w}
372 :     (Constant) , ;
373 :    
374 :     : AConstant ( addr "name" -- ) \ gforth
375 :     (Constant) A, ;
376 :    
377 :     : Value ( w "name" -- ) \ core-ext
378 :     (Constant) , ;
379 :    
380 :     : 2Constant ( w1 w2 "name" -- ) \ double
381 :     Create ( w1 w2 "name" -- )
382 :     2,
383 :     DOES> ( -- w1 w2 )
384 :     2@ ;
385 :    
386 :     doer? :dofield [IF]
387 :     : (Field) Header reveal dofield: cfa, ;
388 :     [ELSE]
389 :     : (Field) Create DOES> @ + ;
390 :     [THEN]
391 :     \ IS Defer What's Defers TO 24feb93py
392 :    
393 :     doer? :dodefer [IF]
394 :    
395 :     : Defer ( "name" -- ) \ gforth
396 :     \ !! shouldn't it be initialized with abort or something similar?
397 :     Header Reveal dodefer: cfa,
398 :     ['] noop A, ;
399 :     [ELSE]
400 :    
401 :     : Defer ( "name" -- ) \ gforth
402 :     Create ['] noop A,
403 :     DOES> @ execute ;
404 :     [THEN]
405 :    
406 :     : Defers ( "name" -- ) \ gforth
407 :     ' >body @ compile, ; immediate
408 :    
409 :     \ \ : ; 24feb93py
410 :    
411 :     defer :-hook ( sys1 -- sys2 )
412 :    
413 :     defer ;-hook ( sys2 -- sys1 )
414 :    
415 : anton 1.7 : (:noname) ( -- colon-sys )
416 :     \ common factor of : and :noname
417 :     docol: cfa, defstart ] :-hook ;
418 :    
419 : pazsan 1.1 : : ( "name" -- colon-sys ) \ core colon
420 : anton 1.7 Header (:noname) ;
421 :    
422 :     : :noname ( -- xt colon-sys ) \ core-ext colon-no-name
423 :     0 last !
424 :     cfalign here (:noname) ;
425 : pazsan 1.1
426 :     : ; ( compilation colon-sys -- ; run-time nest-sys ) \ core semicolon
427 :     ;-hook ?struc postpone exit reveal postpone [ ; immediate restrict
428 :    
429 :     \ \ Search list handling: reveal words, recursive 23feb93py
430 :    
431 :     : last? ( -- false / nfa nfa )
432 :     last @ ?dup ;
433 :    
434 :     : (reveal) ( nt wid -- )
435 : pazsan 1.3 wordlist-id dup >r
436 : pazsan 1.1 @ over ( name>link ) !
437 :     r> ! ;
438 :    
439 :     \ make entry in wordlist-map
440 :     ' (reveal) f83search reveal-method !
441 :    
442 :     Variable warnings ( -- addr ) \ gforth
443 :     G -1 warnings T !
444 :    
445 :     : check-shadow ( addr count wid -- )
446 : pazsan 1.2 \G prints a warning if the string is already present in the wordlist
447 :     >r 2dup 2dup r> (search-wordlist) warnings @ and ?dup if
448 :     >stderr
449 :     ." redefined " name>string 2dup type
450 :     compare 0<> if
451 :     ." with " type
452 :     else
453 :     2drop
454 :     then
455 :     space space EXIT
456 :     then
457 :     2drop 2drop ;
458 : pazsan 1.1
459 :     : reveal ( -- ) \ gforth
460 :     last?
461 :     if \ the last word has a header
462 :     dup ( name>link ) @ 1 and
463 :     if \ it is still hidden
464 :     dup ( name>link ) @ 1 xor ( nt wid )
465 :     2dup >r name>string r> check-shadow ( nt wid )
466 :     dup wordlist-map @ reveal-method perform
467 :     else
468 :     drop
469 :     then
470 :     then ;
471 :    
472 :     : rehash ( wid -- )
473 :     dup wordlist-map @ rehash-method perform ;
474 :    
475 :     ' reveal alias recursive ( compilation -- ; run-time -- ) \ gforth
476 : crook 1.10 \g Make the current definition visible, enabling it to call itself
477 : pazsan 1.1 \g recursively.
478 :     immediate restrict

CVS Admin

Powered by ViewCVS 1.0-dev
(Powered by ViewCVS)

ViewCVS and CVS Help