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