1: \ compiler definitions 14sep97jaw
2:
3: \ Copyright (C) 1995,1996,1997,1998,2000,2003,2004,2005,2006,2007,2008,2009,2010,2011 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 [ has? flash [IF] ] flashc! [ [ELSE] ] c! [ [THEN] ] ;
51:
52: : , ( w -- ) \ core comma
53: \G Reserve data space for one cell and store @i{w} in the space.
54: here cell allot [ has? flash [IF] ] flash! [ [ELSE] ] ! [ [THEN] ] ;
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 [ has? flash [IF] ] tuck flash! cell+ flash!
60: [ [ELSE] ] 2! [ [THEN] ] ;
61:
62: \ : aligned ( addr -- addr' ) \ core
63: \ [ cell 1- ] Literal + [ -1 cells ] Literal and ;
64:
65: : align ( -- ) \ core
66: \G If the data-space pointer is not aligned, reserve enough space to align it.
67: here dup aligned swap ?DO bl c, LOOP ;
68:
69: : maxalign ( -- ) \ gforth
70: \G Align data-space pointer for all alignment requirements.
71: here dup maxaligned swap
72: ?DO
73: bl c,
74: LOOP ;
75:
76: \ the code field is aligned if its body is maxaligned
77: ' maxalign Alias cfalign ( -- ) \ gforth
78: \G Align data-space pointer for code field requirements (i.e., such
79: \G that the corresponding body is maxaligned).
80:
81: ' , alias A, ( addr -- ) \ gforth
82:
83: ' NOOP ALIAS const
84:
85: \ \ Header 23feb93py
86:
87: \ input-stream, nextname and noname are quite ugly (passing
88: \ information through global variables), but they are useful for dealing
89: \ with existing/independent defining words
90:
91: : string, ( c-addr u -- ) \ gforth
92: \G puts down string as cstring
93: dup [ has? rom [IF] ] $E0 [ [ELSE] ] alias-mask [ [THEN] ] or c,
94: [ has? flash [IF] ]
95: bounds ?DO I c@ c, LOOP
96: [ [ELSE] ]
97: here swap chars dup allot move
98: [ [THEN] ] ;
99:
100: : longstring, ( c-addr u -- ) \ gforth
101: \G puts down string as longcstring
102: dup , here swap chars dup allot move ;
103:
104: [IFDEF] prelude-mask
105: variable next-prelude
106:
107: : prelude, ( -- )
108: next-prelude @ if
109: align next-prelude @ ,
110: then ;
111: [THEN]
112:
113: : header, ( c-addr u -- ) \ gforth
114: name-too-long?
115: dup max-name-length @ max max-name-length !
116: [ [IFDEF] prelude-mask ] prelude, [ [THEN] ]
117: align here last !
118: -1 A,
119: string,
120: cfalign ;
121:
122: : header ( "name" -- )
123: parse-name name-too-short? header, ;
124:
125: : latestxt ( -- xt ) \ gforth
126: \G @i{xt} is the execution token of the last word defined.
127: \ The main purpose of this word is to get the xt of words defined using noname
128: lastcfa @ ;
129:
130: : latest ( -- nt ) \ gforth
131: \G @var{nt} is the name token of the last word defined; it is 0 if the
132: \G last word has no name.
133: last @ ;
134:
135: \ \ literals 17dec92py
136:
137: : Literal ( compilation n -- ; run-time -- n ) \ core
138: \G Compilation semantics: compile the run-time semantics.@*
139: \G Run-time Semantics: push @i{n}.@*
140: \G Interpretation semantics: undefined.
141: [ [IFDEF] lit, ]
142: lit,
143: [ [ELSE] ]
144: postpone lit ,
145: [ [THEN] ] ; immediate restrict
146:
147: : 2Literal ( compilation w1 w2 -- ; run-time -- w1 w2 ) \ double two-literal
148: \G Compile appropriate code such that, at run-time, @i{w1 w2} are
149: \G placed on the stack. Interpretation semantics are undefined.
150: swap postpone Literal postpone Literal ; immediate restrict
151:
152: : ALiteral ( compilation addr -- ; run-time -- addr ) \ gforth
153: [ [IFDEF] alit, ]
154: alit,
155: [ [ELSE] ]
156: postpone lit A,
157: [ [THEN] ] ; immediate restrict
158:
159: Defer char@ ( addr u -- char addr' u' )
160: :noname over c@ -rot 1 /string ; IS char@
161:
162: : char ( '<spaces>ccc' -- c ) \ core
163: \G Skip leading spaces. Parse the string @i{ccc} and return @i{c}, the
164: \G display code representing the first character of @i{ccc}.
165: parse-name char@ 2drop ;
166:
167: : [char] ( compilation '<spaces>ccc' -- ; run-time -- c ) \ core bracket-char
168: \G Compilation: skip leading spaces. Parse the string
169: \G @i{ccc}. Run-time: return @i{c}, the display code
170: \G representing the first character of @i{ccc}. Interpretation
171: \G semantics for this word are undefined.
172: char postpone Literal ; immediate restrict
173:
174: \ \ threading 17mar93py
175:
176: : cfa, ( code-address -- ) \ gforth cfa-comma
177: here
178: dup lastcfa !
179: [ has? rom [IF] ] 2 cells allot [ [ELSE] ] 0 A, 0 , [ [THEN] ]
180: code-address! ;
181:
182: [IFUNDEF] compile,
183: defer compile, ( xt -- ) \ core-ext compile-comma
184: \G Compile the word represented by the execution token @i{xt}
185: \G into the current definition.
186:
187: ' , is compile,
188: [THEN]
189:
190: ' , is compile,
191:
192: : !does ( addr -- ) \ gforth store-does
193: latestxt does-code! ;
194:
195: : (compile) ( -- ) \ gforth-obsolete: dummy
196: true abort" (compile) doesn't work, use POSTPONE instead" ;
197:
198: \ \ ticks
199:
200: : name>comp ( nt -- w xt ) \ gforth name-to-comp
201: \G @i{w xt} is the compilation token for the word @i{nt}.
202: (name>comp)
203: 1 = if
204: ['] execute
205: else
206: ['] compile,
207: then ;
208:
209: : [(')] ( compilation "name" -- ; run-time -- nt ) \ gforth bracket-paren-tick
210: (') postpone ALiteral ; immediate restrict
211:
212: : ['] ( compilation. "name" -- ; run-time. -- xt ) \ core bracket-tick
213: \g @i{xt} represents @i{name}'s interpretation
214: \g semantics. Perform @code{-14 throw} if the word has no
215: \g interpretation semantics.
216: ' postpone ALiteral ; immediate restrict
217:
218: : COMP' ( "name" -- w xt ) \ gforth comp-tick
219: \g Compilation token @i{w xt} represents @i{name}'s compilation semantics.
220: (') name>comp ;
221:
222: : [COMP'] ( compilation "name" -- ; run-time -- w xt ) \ gforth bracket-comp-tick
223: \g Compilation token @i{w xt} represents @i{name}'s compilation semantics.
224: COMP' swap POSTPONE Aliteral POSTPONE ALiteral ; immediate restrict
225:
226: : postpone, ( w xt -- ) \ gforth postpone-comma
227: \g Compile the compilation semantics represented by the
228: \g compilation token @i{w xt}.
229: dup ['] execute =
230: if
231: drop compile,
232: else
233: swap POSTPONE aliteral compile,
234: then ;
235:
236: : POSTPONE ( "name" -- ) \ core
237: \g Compiles the compilation semantics of @i{name}.
238: COMP' postpone, ; immediate
239:
240: \ \ recurse 17may93jaw
241:
242: : recurse ( compilation -- ; run-time ?? -- ?? ) \ core
243: \g Call the current definition.
244: latestxt compile, ; immediate restrict
245:
246: \ \ compiler loop
247:
248: : compiler1 ( c-addr u -- ... xt )
249: 2dup find-name [ [IFDEF] prelude-mask ] run-prelude [ [THEN] ] dup
250: if ( c-addr u nt )
251: nip nip name>comp
252: else
253: drop
254: 2dup 2>r snumber? dup
255: IF
256: 0>
257: IF
258: ['] 2literal
259: ELSE
260: ['] literal
261: THEN
262: 2rdrop
263: ELSE
264: drop 2r> compiler-notfound1
265: THEN
266: then ;
267:
268: : [ ( -- ) \ core left-bracket
269: \G Enter interpretation state. Immediate word.
270: ['] interpreter1 IS parser1 state off ; immediate
271:
272: : ] ( -- ) \ core right-bracket
273: \G Enter compilation state.
274: ['] compiler1 IS parser1 state on ;
275:
276: \ \ Strings 22feb93py
277:
278: : S, ( addr u -- )
279: \ allot string as counted string
280: [ has? flash [IF] ]
281: dup c, bounds ?DO I c@ c, LOOP
282: [ [ELSE] ]
283: here over char+ allot place align
284: [ [THEN] ] ;
285:
286: : mem, ( addr u -- )
287: \ allot the memory block HERE (do alignment yourself)
288: [ has? flash [IF] ]
289: bounds ?DO I c@ c, LOOP
290: [ [ELSE] ]
291: here over allot swap move
292: [ [THEN] ] ;
293:
294: : ," ( "string"<"> -- )
295: [char] " parse s, ;
296:
297: \ \ Header states 23feb93py
298:
299: \ problematic only for big endian machines
300:
301: : cset ( bmask c-addr -- )
302: tuck c@ or swap c! ;
303:
304: : creset ( bmask c-addr -- )
305: tuck c@ swap invert and swap c! ;
306:
307: : ctoggle ( bmask c-addr -- )
308: tuck c@ xor swap c! ;
309:
310: : lastflags ( -- c-addr )
311: \ the address of the flags byte in the last header
312: \ aborts if the last defined word was headerless
313: latest dup 0= abort" last word was headerless" cell+ ;
314:
315: : immediate ( -- ) \ core
316: \G Make the compilation semantics of a word be to @code{execute}
317: \G the execution semantics.
318: immediate-mask lastflags [ has? rom [IF] ] creset [ [ELSE] ] cset [ [THEN] ] ;
319:
320: : restrict ( -- ) \ gforth
321: \G A synonym for @code{compile-only}
322: restrict-mask lastflags [ has? rom [IF] ] creset [ [ELSE] ] cset [ [THEN] ] ;
323:
324: ' restrict alias compile-only ( -- ) \ gforth
325: \G Remove the interpretation semantics of a word.
326:
327: \ \ Create Variable User Constant 17mar93py
328:
329: : Alias ( xt "name" -- ) \ gforth
330: Header reveal
331: alias-mask lastflags creset
332: dup A, lastcfa ! ;
333:
334: doer? :dovar [IF]
335:
336: : Create ( "name" -- ) \ core
337: Header reveal dovar: cfa, ;
338: [ELSE]
339:
340: : Create ( "name" -- ) \ core
341: Header reveal here lastcfa ! 0 A, 0 , DOES> ;
342: [THEN]
343:
344: : buffer: ( u "name" -- ) \ core ext
345: Create allot ;
346:
347: has? flash [IF]
348: : (variable) dpp @ normal-dp = IF Create dpp @
349: ELSE normal-dp @ Constant dpp @ ram THEN ;
350: : Variable ( "name" -- ) \ core
351: (Variable) 0 , dpp ! ;
352:
353: : 2Variable ( "name" -- ) \ double two-variable
354: (Variable) 0 , 0 , dpp ! ;
355: [ELSE]
356: : Variable ( "name" -- ) \ core
357: Create 0 , ;
358:
359: : 2Variable ( "name" -- ) \ double two-variable
360: Create 0 , 0 , ;
361: [THEN]
362:
363: has? no-userspace 0= [IF]
364: : uallot ( n -- ) \ gforth
365: udp @ swap udp +! ;
366:
367: doer? :douser [IF]
368:
369: : User ( "name" -- ) \ gforth
370: Header reveal douser: cfa, cell uallot , ;
371: [ELSE]
372:
373: : User Create cell uallot , DOES> @ up @ + ;
374: [THEN]
375: [THEN]
376:
377: doer? :docon [IF]
378: : (Constant) Header reveal docon: cfa, ;
379: [ELSE]
380: : (Constant) Create DOES> @ ;
381: [THEN]
382:
383: doer? :dovalue [IF]
384: : (Value) Header reveal dovalue: cfa, ;
385: [ELSE]
386: has? rom [IF]
387: : (Value) Create DOES> @ @ ;
388: [ELSE]
389: : (Value) Create DOES> @ ;
390: [THEN]
391: [THEN]
392:
393: : Constant ( w "name" -- ) \ core
394: \G Define a constant @i{name} with value @i{w}.
395: \G
396: \G @i{name} execution: @i{-- w}
397: (Constant) , ;
398:
399: : AConstant ( addr "name" -- ) \ gforth
400: (Constant) A, ;
401:
402: has? flash [IF]
403: : Value ( w "name" -- ) \ core-ext
404: (Value) dpp @ >r here cell allot >r
405: ram here >r , r> r> flash! r> dpp ! ;
406:
407: ' Value alias AValue
408: [ELSE]
409: : Value ( w "name" -- ) \ core-ext
410: (Value) , ;
411: [THEN]
412:
413: : 2Constant ( w1 w2 "name" -- ) \ double two-constant
414: Create ( w1 w2 "name" -- )
415: 2,
416: DOES> ( -- w1 w2 )
417: 2@ ;
418:
419: doer? :dofield [IF]
420: : (Field) Header reveal dofield: cfa, ;
421: [ELSE]
422: : (Field) Create DOES> @ + ;
423: [THEN]
424:
425: \ \ interpret/compile:
426:
427: struct
428: >body
429: cell% field interpret/compile-int
430: cell% field interpret/compile-comp
431: end-struct interpret/compile-struct
432:
433: : interpret/compile: ( interp-xt comp-xt "name" -- ) \ gforth
434: Create immediate swap A, A,
435: DOES>
436: abort" executed primary cfa of an interpret/compile: word" ;
437: \ state @ IF cell+ THEN perform ;
438:
439: \ IS Defer What's Defers TO 24feb93py
440:
441: defer defer-default ( -- )
442: ' abort is defer-default
443: \ default action for deferred words (overridden by a warning later)
444:
445: doer? :dodefer [IF]
446:
447: : Defer ( "name" -- ) \ gforth
448: \G Define a deferred word @i{name}; its execution semantics can be
449: \G set with @code{defer!} or @code{is} (and they have to, before first
450: \G executing @i{name}.
451: Header Reveal dodefer: cfa,
452: [ has? rom [IF] ] here >r cell allot
453: dpp @ ram here r> flash! ['] defer-default A, dpp !
454: [ [ELSE] ] ['] defer-default A, [ [THEN] ] ;
455:
456: [ELSE]
457:
458: has? rom [IF]
459: : Defer ( "name" -- ) \ gforth
460: Create here >r cell allot
461: dpp @ ram here r> flash! ['] defer-default A, dpp !
462: DOES> @ @ execute ;
463: [ELSE]
464: : Defer ( "name" -- ) \ gforth
465: Create ['] defer-default A,
466: DOES> @ execute ;
467: [THEN]
468: [THEN]
469:
470: : defer@ ( xt-deferred -- xt ) \ gforth defer-fetch
471: \G @i{xt} represents the word currently associated with the deferred
472: \G word @i{xt-deferred}.
473: >body @ [ has? rom [IF] ] @ [ [THEN] ] ;
474:
475: : Defers ( compilation "name" -- ; run-time ... -- ... ) \ gforth
476: \G Compiles the present contents of the deferred word @i{name}
477: \G into the current definition. I.e., this produces static
478: \G binding as if @i{name} was not deferred.
479: ' defer@ compile, ; immediate
480:
481: : does>-like ( xt -- )
482: \ xt ( addr -- ) is !does or !;abi-code etc, addr is the address
483: \ that should be stored right after the code address.
484: >r ;-hook ?struc
485: [ has? xconds [IF] ] exit-like [ [THEN] ]
486: here [ has? peephole [IF] ] 5 [ [ELSE] ] 4 [ [THEN] ] cells +
487: postpone aliteral r> compile, [compile] exit
488: [ has? peephole [IF] ] finish-code [ [THEN] ]
489: defstart ;
490:
491: :noname
492: here !does ]
493: defstart :-hook ;
494: :noname
495: ['] !does does>-like :-hook ;
496: interpret/compile: DOES> ( compilation colon-sys1 -- colon-sys2 ; run-time nest-sys -- ) \ core does
497:
498: : defer! ( xt xt-deferred -- ) \ gforth defer-store
499: \G Changes the @code{defer}red word @var{xt-deferred} to execute @var{xt}.
500: >body [ has? rom [IF] ] @ [ [THEN] ] ! ;
501:
502: : <IS> ( "name" xt -- ) \ gforth
503: \g Changes the @code{defer}red word @var{name} to execute @var{xt}.
504: ' defer! ;
505:
506: : [IS] ( compilation "name" -- ; run-time xt -- ) \ gforth bracket-is
507: \g At run-time, changes the @code{defer}red word @var{name} to
508: \g execute @var{xt}.
509: ' postpone ALiteral postpone defer! ; immediate restrict
510:
511: ' <IS>
512: ' [IS]
513: interpret/compile: IS ( compilation/interpretation "name-deferred" -- ; run-time xt -- ) \ gforth
514: \G Changes the @code{defer}red word @var{name} to execute @var{xt}.
515: \G Its compilation semantics parses at compile time.
516:
517: ' <IS>
518: ' [IS]
519: interpret/compile: TO ( w "name" -- ) \ core-ext
520:
521: : interpret/compile? ( xt -- flag )
522: >does-code ['] DOES> >does-code = ;
523:
524: \ \ : ; 24feb93py
525:
526: defer :-hook ( sys1 -- sys2 )
527:
528: defer ;-hook ( sys2 -- sys1 )
529:
530: 0 Constant defstart
531:
532: [IFDEF] docol,
533: : (:noname) ( -- colon-sys )
534: \ common factor of : and :noname
535: docol, ]comp
536: [ELSE]
537: : (:noname) ( -- colon-sys )
538: \ common factor of : and :noname
539: docol: cfa,
540: [THEN]
541: defstart ] :-hook ;
542:
543: : : ( "name" -- colon-sys ) \ core colon
544: Header (:noname) ;
545:
546: : :noname ( -- xt colon-sys ) \ core-ext colon-no-name
547: 0 last !
548: cfalign here (:noname) ;
549:
550: [IFDEF] fini,
551: : ; ( compilation colon-sys -- ; run-time nest-sys ) \ core semicolon
552: ;-hook ?struc fini, comp[ reveal postpone [ ; immediate restrict
553: [ELSE]
554: : ; ( compilation colon-sys -- ; run-time nest-sys ) \ core semicolon
555: ;-hook ?struc [compile] exit
556: [ has? peephole [IF] ] finish-code [ [THEN] ]
557: reveal postpone [ ; immediate restrict
558: [THEN]
559:
560: \ \ Search list handling: reveal words, recursive 23feb93py
561:
562: : last? ( -- false / nfa nfa )
563: latest ?dup ;
564:
565: Variable warnings ( -- addr ) \ gforth
566: G -1 warnings T !
567:
568: : reveal ( -- ) \ gforth
569: last?
570: if \ the last word has a header
571: dup ( name>link ) @ -1 =
572: if \ it is still hidden
573: forth-wordlist dup >r @ over
574: [ has? flash [IF] ] flash! [ [ELSE] ] ! [ [THEN] ] r> !
575: else
576: drop
577: then
578: then ;
579:
580: ' reveal alias recursive ( compilation -- ; run-time -- ) \ gforth
581: \g Make the current definition visible, enabling it to call itself
582: \g recursively.
583: immediate restrict
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to comp-ec.fs CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [gforth] / gforth / kernel