1: \ compiler definitions 14sep97jaw
2:
3: \ Copyright (C) 1995,1996,1997,1998,2000,2003,2004,2005,2006,2007,2008,2009,2010 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: : AVariable ( "name" -- ) \ gforth
354: (Variable) 0 A, dpp ! ;
355:
356: : 2Variable ( "name" -- ) \ double two-variable
357: (Variable) 0 , 0 , dpp ! ;
358: [ELSE]
359: : Variable ( "name" -- ) \ core
360: Create 0 , ;
361:
362: : AVariable ( "name" -- ) \ gforth
363: Create 0 A, ;
364:
365: : 2Variable ( "name" -- ) \ double two-variable
366: Create 0 , 0 , ;
367: [THEN]
368:
369: has? no-userspace 0= [IF]
370: : uallot ( n -- ) \ gforth
371: udp @ swap udp +! ;
372:
373: doer? :douser [IF]
374:
375: : User ( "name" -- ) \ gforth
376: Header reveal douser: cfa, cell uallot , ;
377:
378: : AUser ( "name" -- ) \ gforth
379: User ;
380: [ELSE]
381:
382: : User Create cell uallot , DOES> @ up @ + ;
383:
384: : AUser User ;
385: [THEN]
386: [THEN]
387:
388: doer? :docon [IF]
389: : (Constant) Header reveal docon: cfa, ;
390: [ELSE]
391: : (Constant) Create DOES> @ ;
392: [THEN]
393:
394: doer? :dovalue [IF]
395: : (Value) Header reveal dovalue: cfa, ;
396: [ELSE]
397: has? rom [IF]
398: : (Value) Create DOES> @ @ ;
399: [ELSE]
400: : (Value) Create DOES> @ ;
401: [THEN]
402: [THEN]
403:
404: : Constant ( w "name" -- ) \ core
405: \G Define a constant @i{name} with value @i{w}.
406: \G
407: \G @i{name} execution: @i{-- w}
408: (Constant) , ;
409:
410: : AConstant ( addr "name" -- ) \ gforth
411: (Constant) A, ;
412:
413: has? flash [IF]
414: : Value ( w "name" -- ) \ core-ext
415: (Value) dpp @ >r here cell allot >r
416: ram here >r , r> r> flash! r> dpp ! ;
417:
418: ' Value alias AValue
419: [ELSE]
420: : Value ( w "name" -- ) \ core-ext
421: (Value) , ;
422:
423: : AValue ( w "name" -- ) \ core-ext
424: (Value) A, ;
425: [THEN]
426:
427: : 2Constant ( w1 w2 "name" -- ) \ double two-constant
428: Create ( w1 w2 "name" -- )
429: 2,
430: DOES> ( -- w1 w2 )
431: 2@ ;
432:
433: doer? :dofield [IF]
434: : (Field) Header reveal dofield: cfa, ;
435: [ELSE]
436: : (Field) Create DOES> @ + ;
437: [THEN]
438:
439: \ \ interpret/compile:
440:
441: struct
442: >body
443: cell% field interpret/compile-int
444: cell% field interpret/compile-comp
445: end-struct interpret/compile-struct
446:
447: : interpret/compile: ( interp-xt comp-xt "name" -- ) \ gforth
448: Create immediate swap A, A,
449: DOES>
450: abort" executed primary cfa of an interpret/compile: word" ;
451: \ state @ IF cell+ THEN perform ;
452:
453: \ IS Defer What's Defers TO 24feb93py
454:
455: defer defer-default ( -- )
456: ' abort is defer-default
457: \ default action for deferred words (overridden by a warning later)
458:
459: doer? :dodefer [IF]
460:
461: : Defer ( "name" -- ) \ gforth
462: \G Define a deferred word @i{name}; its execution semantics can be
463: \G set with @code{defer!} or @code{is} (and they have to, before first
464: \G executing @i{name}.
465: Header Reveal dodefer: cfa,
466: [ has? rom [IF] ] here >r cell allot
467: dpp @ ram here r> flash! ['] defer-default A, dpp !
468: [ [ELSE] ] ['] defer-default A, [ [THEN] ] ;
469:
470: [ELSE]
471:
472: has? rom [IF]
473: : Defer ( "name" -- ) \ gforth
474: Create here >r cell allot
475: dpp @ ram here r> flash! ['] defer-default A, dpp !
476: DOES> @ @ execute ;
477: [ELSE]
478: : Defer ( "name" -- ) \ gforth
479: Create ['] defer-default A,
480: DOES> @ execute ;
481: [THEN]
482: [THEN]
483:
484: : defer@ ( xt-deferred -- xt ) \ gforth defer-fetch
485: \G @i{xt} represents the word currently associated with the deferred
486: \G word @i{xt-deferred}.
487: >body @ [ has? rom [IF] ] @ [ [THEN] ] ;
488:
489: : Defers ( compilation "name" -- ; run-time ... -- ... ) \ gforth
490: \G Compiles the present contents of the deferred word @i{name}
491: \G into the current definition. I.e., this produces static
492: \G binding as if @i{name} was not deferred.
493: ' defer@ compile, ; immediate
494:
495: : does>-like ( xt -- )
496: \ xt ( addr -- ) is !does or !;abi-code etc, addr is the address
497: \ that should be stored right after the code address.
498: >r ;-hook ?struc
499: [ has? xconds [IF] ] exit-like [ [THEN] ]
500: here [ has? peephole [IF] ] 5 [ [ELSE] ] 4 [ [THEN] ] cells +
501: postpone aliteral r> compile, [compile] exit
502: [ has? peephole [IF] ] finish-code [ [THEN] ]
503: defstart ;
504:
505: :noname
506: here !does ]
507: defstart :-hook ;
508: :noname
509: ['] !does does>-like :-hook ;
510: interpret/compile: DOES> ( compilation colon-sys1 -- colon-sys2 ; run-time nest-sys -- ) \ core does
511:
512: : defer! ( xt xt-deferred -- ) \ gforth defer-store
513: \G Changes the @code{defer}red word @var{xt-deferred} to execute @var{xt}.
514: >body [ has? rom [IF] ] @ [ [THEN] ] ! ;
515:
516: : <IS> ( "name" xt -- ) \ gforth
517: \g Changes the @code{defer}red word @var{name} to execute @var{xt}.
518: ' defer! ;
519:
520: : [IS] ( compilation "name" -- ; run-time xt -- ) \ gforth bracket-is
521: \g At run-time, changes the @code{defer}red word @var{name} to
522: \g execute @var{xt}.
523: ' postpone ALiteral postpone defer! ; immediate restrict
524:
525: ' <IS>
526: ' [IS]
527: interpret/compile: IS ( compilation/interpretation "name-deferred" -- ; run-time xt -- ) \ gforth
528: \G Changes the @code{defer}red word @var{name} to execute @var{xt}.
529: \G Its compilation semantics parses at compile time.
530:
531: ' <IS>
532: ' [IS]
533: interpret/compile: TO ( w "name" -- ) \ core-ext
534:
535: : interpret/compile? ( xt -- flag )
536: >does-code ['] DOES> >does-code = ;
537:
538: \ \ : ; 24feb93py
539:
540: defer :-hook ( sys1 -- sys2 )
541:
542: defer ;-hook ( sys2 -- sys1 )
543:
544: 0 Constant defstart
545:
546: [IFDEF] docol,
547: : (:noname) ( -- colon-sys )
548: \ common factor of : and :noname
549: docol, ]comp
550: [ELSE]
551: : (:noname) ( -- colon-sys )
552: \ common factor of : and :noname
553: docol: cfa,
554: [THEN]
555: defstart ] :-hook ;
556:
557: : : ( "name" -- colon-sys ) \ core colon
558: Header (:noname) ;
559:
560: : :noname ( -- xt colon-sys ) \ core-ext colon-no-name
561: 0 last !
562: cfalign here (:noname) ;
563:
564: [IFDEF] fini,
565: : ; ( compilation colon-sys -- ; run-time nest-sys ) \ core semicolon
566: ;-hook ?struc fini, comp[ reveal postpone [ ; immediate restrict
567: [ELSE]
568: : ; ( compilation colon-sys -- ; run-time nest-sys ) \ core semicolon
569: ;-hook ?struc [compile] exit
570: [ has? peephole [IF] ] finish-code [ [THEN] ]
571: reveal postpone [ ; immediate restrict
572: [THEN]
573:
574: \ \ Search list handling: reveal words, recursive 23feb93py
575:
576: : last? ( -- false / nfa nfa )
577: latest ?dup ;
578:
579: Variable warnings ( -- addr ) \ gforth
580: G -1 warnings T !
581:
582: : reveal ( -- ) \ gforth
583: last?
584: if \ the last word has a header
585: dup ( name>link ) @ -1 =
586: if \ it is still hidden
587: forth-wordlist dup >r @ over
588: [ has? flash [IF] ] flash! [ [ELSE] ] ! [ [THEN] ] r> !
589: else
590: drop
591: then
592: then ;
593:
594: ' reveal alias recursive ( compilation -- ; run-time -- ) \ gforth
595: \g Make the current definition visible, enabling it to call itself
596: \g recursively.
597: 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