1: \ compiler definitions 14sep97jaw
2:
3: \ Copyright (C) 1995,1996,1997,1998,2000,2003,2004,2005,2006,2007,2008,2009,2010,2011,2012 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 3
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, see http://www.gnu.org/licenses/.
19:
20: \ \ Revisions-Log
21:
22: \ put in seperate file 14sep97jaw
23:
24: \ \ here allot , c, A, 17dec92py
25:
26: [IFUNDEF] allot
27: [IFUNDEF] forthstart
28: : allot ( n -- ) \ core
29: dup unused u> -8 and throw
30: dp +! ;
31: [THEN]
32: [THEN]
33:
34: \ we default to this version if we have nothing else 05May99jaw
35: [IFUNDEF] allot
36: : allot ( n -- ) \ core
37: \G Reserve @i{n} address units of data space without
38: \G initialization. @i{n} is a signed number, passing a negative
39: \G @i{n} releases memory. In ANS Forth you can only deallocate
40: \G memory from the current contiguous region in this way. In
41: \G Gforth you can deallocate anything in this way but named words.
42: \G The system does not check this restriction.
43: here +
44: dup 1- usable-dictionary-end forthstart within -8 and throw
45: dp ! ;
46: [THEN]
47:
48: : c, ( c -- ) \ core c-comma
49: \G Reserve data space for one char and store @i{c} in the space.
50: here 1 chars allot c! ;
51:
52: : , ( w -- ) \ core comma
53: \G Reserve data space for one cell and store @i{w} in the space.
54: here cell allot ! ;
55:
56: : 2, ( w1 w2 -- ) \ gforth
57: \G Reserve data space for two cells and store the double @i{w1
58: \G w2} there, @i{w2} first (lower address).
59: here 2 cells allot 2! ;
60:
61: \ : aligned ( addr -- addr' ) \ core
62: \ [ cell 1- ] Literal + [ -1 cells ] Literal and ;
63:
64: : align ( -- ) \ core
65: \G If the data-space pointer is not aligned, reserve enough space to align it.
66: here dup aligned swap ?DO bl c, LOOP ;
67:
68: \ : faligned ( addr -- f-addr ) \ float f-aligned
69: \ [ 1 floats 1- ] Literal + [ -1 floats ] Literal and ;
70:
71: : falign ( -- ) \ float f-align
72: \G If the data-space pointer is not float-aligned, reserve
73: \G enough space to align it.
74: here dup faligned swap
75: ?DO
76: bl c,
77: LOOP ;
78:
79: : maxalign ( -- ) \ gforth
80: \G Align data-space pointer for all alignment requirements.
81: here dup maxaligned swap
82: ?DO
83: bl c,
84: LOOP ;
85:
86: \ the code field is aligned if its body is maxaligned
87: ' maxalign Alias cfalign ( -- ) \ gforth
88: \G Align data-space pointer for code field requirements (i.e., such
89: \G that the corresponding body is maxaligned).
90:
91: ' , alias A, ( addr -- ) \ gforth
92:
93: ' NOOP ALIAS const
94:
95: \ \ Header 23feb93py
96:
97: \ input-stream, nextname and noname are quite ugly (passing
98: \ information through global variables), but they are useful for dealing
99: \ with existing/independent defining words
100:
101: : string, ( c-addr u -- ) \ gforth
102: \G puts down string as cstring
103: dup alias-mask or c,
104: here swap chars dup allot move ;
105:
106: : longstring, ( c-addr u -- ) \ gforth
107: \G puts down string as longcstring
108: dup , here swap chars dup allot move ;
109:
110: [IFDEF] prelude-mask
111: variable next-prelude
112:
113: : prelude, ( -- )
114: next-prelude @ if
115: align next-prelude @ ,
116: then ;
117: [THEN]
118:
119: : header, ( c-addr u -- ) \ gforth
120: name-too-long?
121: dup max-name-length @ max max-name-length !
122: [ [IFDEF] prelude-mask ] prelude, [ [THEN] ]
123: align here last !
124: current @ 1 or A, \ link field; before revealing, it contains the
125: \ tagged reveal-into wordlist
126: longstring, alias-mask lastflags cset
127: next-prelude @ 0<> prelude-mask and lastflags cset
128: next-prelude off
129: cfalign ;
130:
131: defer record-name ( -- ) ' noop is record-name
132: \ record next name in tags file
133: defer (header)
134: defer header ( -- ) \ gforth
135: ' (header) IS header
136:
137: : input-stream-header ( "name" -- )
138: parse-name name-too-short? header, ;
139:
140: : input-stream ( -- ) \ general
141: \G switches back to getting the name from the input stream ;
142: ['] input-stream-header IS (header) ;
143:
144: ' input-stream-header IS (header)
145:
146: 2variable nextname-string
147:
148: : nextname-header ( -- )
149: nextname-string 2@ header,
150: nextname-string free-mem-var
151: input-stream ;
152:
153: \ the next name is given in the string
154:
155: : nextname ( c-addr u -- ) \ gforth
156: \g The next defined word will have the name @var{c-addr u}; the
157: \g defining word will leave the input stream alone.
158: name-too-long?
159: nextname-string free-mem-var
160: save-mem nextname-string 2!
161: ['] nextname-header IS (header) ;
162:
163: : noname-header ( -- )
164: 0 last ! cfalign
165: input-stream ;
166:
167: : noname ( -- ) \ gforth
168: \g The next defined word will be anonymous. The defining word will
169: \g leave the input stream alone. The xt of the defined word will
170: \g be given by @code{latestxt}.
171: ['] noname-header IS (header) ;
172:
173: : latestxt ( -- xt ) \ gforth
174: \G @i{xt} is the execution token of the last word defined.
175: \ The main purpose of this word is to get the xt of words defined using noname
176: lastcfa @ ;
177:
178: ' latestxt alias lastxt \ gforth-obsolete
179: \G old name for @code{latestxt}.
180:
181: : latest ( -- nt ) \ gforth
182: \G @var{nt} is the name token of the last word defined; it is 0 if the
183: \G last word has no name.
184: last @ ;
185:
186: \ \ literals 17dec92py
187:
188: : Literal ( compilation n -- ; run-time -- n ) \ core
189: \G Compilation semantics: compile the run-time semantics.@*
190: \G Run-time Semantics: push @i{n}.@*
191: \G Interpretation semantics: undefined.
192: postpone lit , ; immediate restrict
193:
194: : 2Literal ( compilation w1 w2 -- ; run-time -- w1 w2 ) \ double two-literal
195: \G Compile appropriate code such that, at run-time, @i{w1 w2} are
196: \G placed on the stack. Interpretation semantics are undefined.
197: swap postpone Literal postpone Literal ; immediate restrict
198:
199: : ALiteral ( compilation addr -- ; run-time -- addr ) \ gforth
200: postpone lit A, ; immediate restrict
201:
202: Defer char@ ( addr u -- char addr' u' )
203: :noname over c@ -rot 1 /string ; IS char@
204:
205: : char ( '<spaces>ccc' -- c ) \ core
206: \G Skip leading spaces. Parse the string @i{ccc} and return @i{c}, the
207: \G display code representing the first character of @i{ccc}.
208: parse-name char@ 2drop ;
209:
210: : [char] ( compilation '<spaces>ccc' -- ; run-time -- c ) \ core bracket-char
211: \G Compilation: skip leading spaces. Parse the string
212: \G @i{ccc}. Run-time: return @i{c}, the display code
213: \G representing the first character of @i{ccc}. Interpretation
214: \G semantics for this word are undefined.
215: char postpone Literal ; immediate restrict
216:
217: \ \ threading 17mar93py
218:
219: has? ec 0= [IF]
220: ' noop Alias recurse
221: \g Call the current definition.
222: unlock tlastcfa @ lock AConstant lastcfa
223: \ this is the alias pointer in the recurse header, named lastcfa.
224: \ changing lastcfa now changes where recurse aliases to
225: \ it's always an alias of the current definition
226: \ it won't work in a flash/rom environment, therefore for Gforth EC
227: \ we stick to the traditional implementation
228: [ELSE]
229: : recurse ( compilation -- ; run-time ?? -- ?? ) \ core
230: \g Call the current definition.
231: latestxt compile, ; immediate restrict
232: [THEN]
233:
234: : cfa, ( code-address -- ) \ gforth cfa-comma
235: here
236: dup lastcfa !
237: 0 A, 0 ,
238: code-address! ;
239:
240: [IFUNDEF] compile,
241: defer compile, ( xt -- ) \ core-ext compile-comma
242: \G Compile the word represented by the execution token @i{xt}
243: \G into the current definition.
244:
245: ' , is compile,
246: [THEN]
247:
248: defer basic-block-end ( -- )
249:
250: :noname ( -- )
251: 0 compile-prim1 ;
252: is basic-block-end
253:
254: has? primcentric [IF]
255: has? peephole [IF]
256: \ dynamic only
257: : peephole-compile, ( xt -- )
258: \ compile xt, appending its code to the current dynamic superinstruction
259: here swap , compile-prim1 ;
260: [ELSE]
261: : peephole-compile, ( xt -- addr ) @ , ;
262: [THEN]
263:
264: : compile-to-prims, ( xt -- )
265: \G compile xt to use primitives (and their peephole optimization)
266: \G instead of ","-ing the xt.
267: \ !! all POSTPONEs here postpone primitives; this can be optimized
268: dup >does-code if
269: ['] does-exec peephole-compile, , EXIT
270: \ dup >body POSTPONE literal ['] call peephole-compile, >does-code , EXIT
271: then
272: dup >code-address CASE
273: dovalue: OF >body ['] lit@ peephole-compile, , EXIT ENDOF
274: docon: OF >body @ ['] lit peephole-compile, , EXIT ENDOF
275: \ docon: OF >body POSTPONE literal ['] @ peephole-compile, EXIT ENDOF
276: \ docon is also used by VALUEs, so don't @ at compile time
277: docol: OF >body ['] call peephole-compile, , EXIT ENDOF
278: dovar: OF >body ['] lit peephole-compile, , EXIT ENDOF
279: douser: OF >body @ ['] useraddr peephole-compile, , EXIT ENDOF
280: dodefer: OF >body ['] lit-perform peephole-compile, , EXIT ENDOF
281: dofield: OF >body @ ['] lit+ peephole-compile, , EXIT ENDOF
282: \ dofield: OF >body @ POSTPONE literal ['] + peephole-compile, EXIT ENDOF
283: doabicode: OF >body ['] abi-call peephole-compile, , EXIT ENDOF
284: do;abicode: OF ['] ;abi-code-exec peephole-compile, , EXIT ENDOF
285: \ code words and ;code-defined words (code words could be
286: \ optimized, if we could identify them):
287: dup in-dictionary? IF ( xt code-address )
288: over >body = if ( xt )
289: \ definitely a CODE word
290: peephole-compile, EXIT THEN
291: \ not sure, might be a ;CODE word
292: ['] lit-execute peephole-compile, , EXIT
293: \ drop POSTPONE literal ['] execute peephole-compile, EXIT
294: THEN
295: ENDCASE
296: peephole-compile, ;
297:
298: ' compile-to-prims, IS compile,
299: [ELSE]
300: ' , is compile,
301: [THEN]
302:
303: : !does ( addr -- ) \ gforth store-does
304: latestxt does-code! ;
305:
306: : (compile) ( -- ) \ gforth-obsolete: dummy
307: true abort" (compile) doesn't work, use POSTPONE instead" ;
308:
309: \ \ ticks
310:
311: : name>comp ( nt -- w xt ) \ gforth name-to-comp
312: \G @i{w xt} is the compilation token for the word @i{nt}.
313: (name>comp)
314: 1 = if
315: ['] execute
316: else
317: ['] compile,
318: then ;
319:
320: : [(')] ( compilation "name" -- ; run-time -- nt ) \ gforth bracket-paren-tick
321: (') postpone ALiteral ; immediate restrict
322:
323: : ['] ( compilation. "name" -- ; run-time. -- xt ) \ core bracket-tick
324: \g @i{xt} represents @i{name}'s interpretation
325: \g semantics. Perform @code{-14 throw} if the word has no
326: \g interpretation semantics.
327: ' postpone ALiteral ; immediate restrict
328:
329: : COMP' ( "name" -- w xt ) \ gforth comp-tick
330: \g Compilation token @i{w xt} represents @i{name}'s compilation semantics.
331: (') name>comp ;
332:
333: : [COMP'] ( compilation "name" -- ; run-time -- w xt ) \ gforth bracket-comp-tick
334: \g Compilation token @i{w xt} represents @i{name}'s compilation semantics.
335: COMP' swap POSTPONE Aliteral POSTPONE ALiteral ; immediate restrict
336:
337: : postpone, ( w xt -- ) \ gforth postpone-comma
338: \g Compile the compilation semantics represented by the
339: \g compilation token @i{w xt}.
340: dup ['] execute =
341: if
342: drop compile,
343: else
344: swap POSTPONE aliteral compile,
345: then ;
346:
347: has? recognizer [IF]
348: include ./recognizer.fs
349: [ELSE]
350: : POSTPONE ( "name" -- ) \ core
351: \g Compiles the compilation semantics of @i{name}.
352: COMP' postpone, ; immediate
353: [THEN]
354:
355: \ \ compiler loop
356:
357: has? recognizer 0= [IF]
358: : compiler1 ( c-addr u -- ... xt )
359: 2dup find-name [ [IFDEF] prelude-mask ] run-prelude [ [THEN] ] dup
360: if ( c-addr u nt )
361: nip nip name>comp
362: else
363: drop
364: 2dup 2>r snumber? dup
365: IF
366: 0>
367: IF
368: ['] 2literal
369: ELSE
370: ['] literal
371: THEN
372: 2rdrop
373: ELSE
374: drop 2r> compiler-notfound1
375: THEN
376: then ;
377:
378: : [ ( -- ) \ core left-bracket
379: \G Enter interpretation state. Immediate word.
380: ['] interpreter1 IS parser1 state off ; immediate
381:
382: : ] ( -- ) \ core right-bracket
383: \G Enter compilation state.
384: ['] compiler1 IS parser1 state on ;
385: [THEN]
386:
387: \ \ Strings 22feb93py
388:
389: : S, ( addr u -- )
390: \ allot string as counted string
391: here over char+ allot place align ;
392:
393: : mem, ( addr u -- )
394: \ allot the memory block HERE (do alignment yourself)
395: here over allot swap move ;
396:
397: : ," ( "string"<"> -- )
398: [char] " parse s, ;
399:
400: \ \ Header states 23feb93py
401:
402: \ problematic only for big endian machines
403:
404: : cset ( bmask c-addr -- )
405: tuck @ or swap ! ;
406:
407: : creset ( bmask c-addr -- )
408: tuck @ swap invert and swap ! ;
409:
410: : ctoggle ( bmask c-addr -- )
411: tuck @ xor swap ! ;
412:
413: : lastflags ( -- c-addr )
414: \ the address of the flags byte in the last header
415: \ aborts if the last defined word was headerless
416: latest dup 0= abort" last word was headerless" cell+ ;
417:
418: : immediate ( -- ) \ core
419: \G Make the compilation semantics of a word be to @code{execute}
420: \G the execution semantics.
421: immediate-mask lastflags cset ;
422:
423: : restrict ( -- ) \ gforth
424: \G A synonym for @code{compile-only}
425: restrict-mask lastflags cset ;
426:
427: ' restrict alias compile-only ( -- ) \ gforth
428: \G Remove the interpretation semantics of a word.
429:
430: \ \ Create Variable User Constant 17mar93py
431:
432: : Alias ( xt "name" -- ) \ gforth
433: Header reveal
434: alias-mask lastflags creset
435: dup A, lastcfa ! ;
436:
437: : Create ( "name" -- ) \ core
438: Header reveal dovar: cfa, ;
439:
440: : buffer: ( u "name" -- ) \ core ext
441: Create allot ;
442:
443: : Variable ( "name" -- ) \ core
444: Create 0 , ;
445:
446: : AVariable ( "name" -- ) \ gforth
447: Create 0 A, ;
448:
449: : 2Variable ( "name" -- ) \ double two-variable
450: Create 0 , 0 , ;
451:
452: : uallot ( n -- ) \ gforth
453: udp @ swap udp +! ;
454:
455: : User ( "name" -- ) \ gforth
456: Header reveal douser: cfa, cell uallot , ;
457:
458: : AUser ( "name" -- ) \ gforth
459: User ;
460:
461: : (Constant) Header reveal docon: cfa, ;
462:
463: : (Value) Header reveal dovalue: cfa, ;
464:
465: : Constant ( w "name" -- ) \ core
466: \G Define a constant @i{name} with value @i{w}.
467: \G
468: \G @i{name} execution: @i{-- w}
469: (Constant) , ;
470:
471: : AConstant ( addr "name" -- ) \ gforth
472: (Constant) A, ;
473:
474: : Value ( w "name" -- ) \ core-ext
475: (Value) , ;
476:
477: : AValue ( w "name" -- ) \ core-ext
478: (Value) A, ;
479:
480: : 2Constant ( w1 w2 "name" -- ) \ double two-constant
481: Create ( w1 w2 "name" -- )
482: 2,
483: DOES> ( -- w1 w2 )
484: 2@ ;
485:
486: : (Field) Header reveal dofield: cfa, ;
487:
488: \ \ interpret/compile:
489:
490: struct
491: >body
492: cell% field interpret/compile-int
493: cell% field interpret/compile-comp
494: end-struct interpret/compile-struct
495:
496: : interpret/compile: ( interp-xt comp-xt "name" -- ) \ gforth
497: Create immediate swap A, A,
498: DOES>
499: abort" executed primary cfa of an interpret/compile: word" ;
500: \ state @ IF cell+ THEN perform ;
501:
502: \ IS Defer What's Defers TO 24feb93py
503:
504: defer defer-default ( -- )
505: ' abort is defer-default
506: \ default action for deferred words (overridden by a warning later)
507:
508: : Defer ( "name" -- ) \ gforth
509: \G Define a deferred word @i{name}; its execution semantics can be
510: \G set with @code{defer!} or @code{is} (and they have to, before first
511: \G executing @i{name}.
512: Header Reveal dodefer: cfa,
513: ['] defer-default A, ;
514:
515: : defer@ ( xt-deferred -- xt ) \ gforth defer-fetch
516: \G @i{xt} represents the word currently associated with the deferred
517: \G word @i{xt-deferred}.
518: >body @ ;
519:
520: : Defers ( compilation "name" -- ; run-time ... -- ... ) \ gforth
521: \G Compiles the present contents of the deferred word @i{name}
522: \G into the current definition. I.e., this produces static
523: \G binding as if @i{name} was not deferred.
524: ' defer@ compile, ; immediate
525:
526: : does>-like ( xt -- )
527: \ xt ( addr -- ) is !does or !;abi-code etc, addr is the address
528: \ that should be stored right after the code address.
529: >r ;-hook ?struc
530: exit-like
531: here [ has? peephole [IF] ] 5 [ [ELSE] ] 4 [ [THEN] ] cells +
532: postpone aliteral r> compile, [compile] exit
533: [ has? peephole [IF] ] finish-code [ [THEN] ]
534: defstart ;
535:
536: :noname
537: here !does ]
538: defstart :-hook ;
539: :noname
540: ['] !does does>-like :-hook ;
541: interpret/compile: DOES> ( compilation colon-sys1 -- colon-sys2 ; run-time nest-sys -- ) \ core does
542:
543: : defer! ( xt xt-deferred -- ) \ gforth defer-store
544: \G Changes the @code{defer}red word @var{xt-deferred} to execute @var{xt}.
545: >body ! ;
546:
547: : <IS> ( "name" xt -- ) \ gforth
548: \g Changes the @code{defer}red word @var{name} to execute @var{xt}.
549: record-name ' defer! ;
550:
551: : [IS] ( compilation "name" -- ; run-time xt -- ) \ gforth bracket-is
552: \g At run-time, changes the @code{defer}red word @var{name} to
553: \g execute @var{xt}.
554: record-name ' postpone ALiteral postpone defer! ; immediate restrict
555:
556: ' <IS>
557: ' [IS]
558: interpret/compile: IS ( compilation/interpretation "name-deferred" -- ; run-time xt -- ) \ gforth
559: \G Changes the @code{defer}red word @var{name} to execute @var{xt}.
560: \G Its compilation semantics parses at compile time.
561:
562: ' <IS>
563: ' [IS]
564: interpret/compile: TO ( w "name" -- ) \ core-ext
565:
566: : interpret/compile? ( xt -- flag )
567: >does-code ['] DOES> >does-code = ;
568:
569: \ \ : ; 24feb93py
570:
571: defer :-hook ( sys1 -- sys2 )
572: defer free-old-local-names ( -- )
573: defer ;-hook ( sys2 -- sys1 )
574:
575: 0 Constant defstart
576:
577: : (:noname) ( -- colon-sys )
578: \ common factor of : and :noname
579: docol: cfa,
580: defstart ] :-hook ;
581:
582: : : ( "name" -- colon-sys ) \ core colon
583: free-old-local-names
584: Header (:noname) ;
585:
586: : :noname ( -- xt colon-sys ) \ core-ext colon-no-name
587: 0 last !
588: cfalign here (:noname) ;
589:
590: : ; ( compilation colon-sys -- ; run-time nest-sys ) \ core semicolon
591: ;-hook ?struc [compile] exit
592: [ has? peephole [IF] ] finish-code [ [THEN] ]
593: reveal postpone [ ; immediate restrict
594:
595: \ \ Search list handling: reveal words, recursive 23feb93py
596:
597: : last? ( -- false / nfa nfa )
598: latest ?dup ;
599:
600: Variable warnings ( -- addr ) \ gforth
601: G -1 warnings T !
602:
603: : (reveal) ( nt wid -- )
604: wordlist-id dup >r
605: @ over ( name>link ) !
606: r> ! ;
607:
608: \ make entry in wordlist-map
609: ' (reveal) f83search reveal-method !
610:
611: : check-shadow ( addr count wid -- )
612: \G prints a warning if the string is already present in the wordlist
613: >r 2dup 2dup r> (search-wordlist) warnings @ and ?dup if
614: >stderr
615: ." redefined " name>string 2dup type
616: str= 0= if
617: ." with " type
618: else
619: 2drop
620: then
621: space space EXIT
622: then
623: 2drop 2drop ;
624:
625: : reveal ( -- ) \ gforth
626: last?
627: if \ the last word has a header
628: dup ( name>link ) @ 1 and
629: if \ it is still hidden
630: dup ( name>link ) @ 1 xor ( nt wid )
631: 2dup >r name>string r> check-shadow ( nt wid )
632: dup wordlist-map @ reveal-method perform
633: else
634: drop
635: then
636: then ;
637:
638: : rehash ( wid -- )
639: dup wordlist-map @ rehash-method perform ;
640:
641: ' reveal alias recursive ( compilation -- ; run-time -- ) \ gforth
642: \g Make the current definition visible, enabling it to call itself
643: \g recursively.
644: 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