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