1: \ CROSS.FS The Cross-Compiler 06oct92py
2: \ Idea and implementation: Bernd Paysan (py)
3:
4: \ Copyright (C) 1995 Free Software Foundation, Inc.
5:
6: \ This file is part of Gforth.
7:
8: \ Gforth is free software; you can redistribute it and/or
9: \ modify it under the terms of the GNU General Public License
10: \ as published by the Free Software Foundation; either version 2
11: \ of the License, or (at your option) any later version.
12:
13: \ This program is distributed in the hope that it will be useful,
14: \ but WITHOUT ANY WARRANTY; without even the implied warranty of
15: \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16: \ GNU General Public License for more details.
17:
18: \ You should have received a copy of the GNU General Public License
19: \ along with this program; if not, write to the Free Software
20: \ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
21:
22: \ Log:
23: \ changed in ; [ to state off 12may93jaw
24: \ included place +place 12may93jaw
25: \ for a created word (variable, constant...)
26: \ is now an alias in the target voabulary.
27: \ this means it is no longer necessary to
28: \ switch between vocabularies for variable
29: \ initialization 12may93jaw
30: \ discovered error in DOES>
31: \ replaced !does with (;code) 16may93jaw
32: \ made complete redesign and
33: \ introduced two vocs method
34: \ to be asure that the right words
35: \ are found 08jun93jaw
36: \ btw: ! works not with 16 bit
37: \ targets 09jun93jaw
38: \ added: 2user and value 11jun93jaw
39:
40: \ needed? works better now!!! 01mar97jaw
41: \ mach file is only loaded into target
42: \ cell corrected
43:
44:
45: \ include other.fs \ ansforth extentions for cross
46:
47: : string, ( c-addr u -- )
48: \ puts down string as cstring
49: dup c, here swap chars dup allot move ;
50: ' falign Alias cfalign
51: : comment? ( c-addr u -- c-addr u )
52: 2dup s" (" compare 0=
53: IF postpone (
54: ELSE 2dup s" \" compare 0= IF postpone \ THEN
55: THEN ;
56:
57: decimal
58:
59: \ Begin CROSS COMPILER:
60:
61: \ GhostNames 9may93jaw
62: \ second name source to search trough list
63:
64: VARIABLE GhostNames
65: 0 GhostNames !
66: : GhostName ( -- addr )
67: here GhostNames @ , GhostNames ! here 0 ,
68: bl word count
69: \ 2dup type space
70: string, cfalign ;
71:
72: hex
73:
74:
75: Vocabulary Cross
76: Vocabulary Target
77: Vocabulary Ghosts
78: VOCABULARY Minimal
79: only Forth also Target also also
80: definitions Forth
81:
82: : T previous Cross also Target ; immediate
83: : G Ghosts ; immediate
84: : H previous Forth also Cross ; immediate
85:
86: forth definitions
87:
88: : T previous Cross also Target ; immediate
89: : G Ghosts ; immediate
90:
91: : >cross also Cross definitions previous ;
92: : >target also Target definitions previous ;
93: : >minimal also Minimal definitions previous ;
94:
95: H
96:
97: >CROSS
98:
99: \ Parameter for target systems 06oct92py
100:
101: >TARGET
102: mach-file count included
103:
104: [IFUNDEF] has-interpreter true CONSTANT has-interpreter [THEN]
105:
106: also Forth definitions
107:
108: [IFDEF] asm-include asm-include [THEN]
109:
110: previous
111: hex
112:
113: >CROSS
114:
115: \ Create additional parameters 19jan95py
116:
117: T
118: NIL Constant TNIL
119: cell Constant tcell
120: cell<< Constant tcell<<
121: cell>bit Constant tcell>bit
122: bits/byte Constant tbits/byte
123: float Constant tfloat
124: 1 bits/byte lshift Constant maxbyte
125: H
126:
127: \ Variables 06oct92py
128:
129: Variable image
130: Variable tlast TNIL tlast ! \ Last name field
131: Variable tlastcfa \ Last code field
132: Variable tdoes \ Resolve does> calls
133: Variable bit$
134: Variable tdp
135: : there tdp @ ;
136:
137:
138: >TARGET
139:
140: \ Byte ordering and cell size 06oct92py
141:
142: : cell+ tcell + ;
143: : cells tcell<< lshift ;
144: : chars ;
145: : char+ 1 + ;
146: : floats tfloat * ;
147:
148: >CROSS
149: : cell/ tcell<< rshift ;
150: >TARGET
151: 20 CONSTANT bl
152: TNIL Constant NIL
153:
154: >CROSS
155:
156: bigendian
157: [IF]
158: : T! ( n addr -- ) >r s>d r> tcell bounds swap 1-
159: DO maxbyte ud/mod rot I c! -1 +LOOP 2drop ;
160: : T@ ( addr -- n ) >r 0 0 r> tcell bounds
161: DO maxbyte * swap maxbyte um* rot + swap I c@ + swap LOOP d>s ;
162: [ELSE]
163: : T! ( n addr -- ) >r s>d r> tcell bounds
164: DO maxbyte ud/mod rot I c! LOOP 2drop ;
165: : T@ ( addr -- n ) >r 0 0 r> tcell bounds swap 1-
166: DO maxbyte * swap maxbyte um* rot + swap I c@ + swap -1 +LOOP d>s ;
167: [THEN]
168:
169: \ Memory initialisation 05dec92py
170: \ Fixed bug in else part 11may93jaw
171:
172: [IFDEF] Memory \ Memory is a bigFORTH feature
173: also Memory
174: : initmem ( var len -- )
175: 2dup swap handle! >r @ r> erase ;
176: toss
177: [ELSE]
178: : initmem ( var len -- )
179: tuck allocate abort" CROSS: No memory for target"
180: ( len var adr ) dup rot !
181: ( len adr ) swap erase ;
182: [THEN]
183:
184: \ MakeKernal 12dec92py
185:
186: >MINIMAL
187: : makekernel ( targetsize -- targetsize )
188: bit$ over 1- tcell>bit rshift 1+ initmem
189: image over initmem tdp off ;
190:
191: >CROSS
192: \ Bit string manipulation 06oct92py
193: \ 9may93jaw
194: CREATE Bittable 80 c, 40 c, 20 c, 10 c, 8 c, 4 c, 2 c, 1 c,
195: : bits ( n -- n ) chars Bittable + c@ ;
196:
197: : >bit ( addr n -- c-addr mask ) 8 /mod rot + swap bits ;
198: : +bit ( addr n -- ) >bit over c@ or swap c! ;
199: : -bit ( addr n -- ) >bit invert over c@ and swap c! ;
200: : relon ( taddr -- ) bit$ @ swap cell/ +bit ;
201: : reloff ( taddr -- ) bit$ @ swap cell/ -bit ;
202:
203: \ Target memory access 06oct92py
204:
205: : align+ ( taddr -- rest )
206: tcell tuck 1- and - [ tcell 1- ] Literal and ;
207: : cfalign+ ( taddr -- rest )
208: \ see kernel.fs:cfaligned
209: /maxalign tuck 1- and - [ /maxalign 1- ] Literal and ;
210:
211: >TARGET
212: : aligned ( taddr -- ta-addr ) dup align+ + ;
213: \ assumes cell alignment granularity (as GNU C)
214:
215: : cfaligned ( taddr1 -- taddr2 )
216: \ see kernel.fs
217: dup cfalign+ + ;
218:
219: >CROSS
220: : >image ( taddr -- absaddr ) image @ + ;
221: >TARGET
222: : @ ( taddr -- w ) >image t@ ;
223: : ! ( w taddr -- ) >image t! ;
224: : c@ ( taddr -- char ) >image c@ ;
225: : c! ( char taddr -- ) >image c! ;
226: : 2@ ( taddr -- x1 x2 ) T dup cell+ @ swap @ H ;
227: : 2! ( x1 x2 taddr -- ) T swap over ! cell+ ! H ;
228:
229: \ Target compilation primitives 06oct92py
230: \ included A! 16may93jaw
231:
232: : here ( -- there ) there ;
233: : allot ( n -- ) tdp +! ;
234: : , ( w -- ) T here H tcell T allot ! H ;
235: : c, ( char -- ) T here 1 allot c! H ;
236: : align ( -- ) T here H align+ 0 ?DO bl T c, H LOOP ;
237: : cfalign ( -- )
238: T here H cfalign+ 0 ?DO bl T c, H LOOP ;
239:
240: : A! dup relon T ! H ;
241: : A, ( w -- ) T here H relon T , H ;
242:
243: >CROSS
244:
245: \ threading modell 13dec92py
246:
247: >TARGET
248: : >body ( cfa -- pfa ) T cell+ cell+ H ;
249: >CROSS
250:
251: \ Ghost Builder 06oct92py
252:
253: \ <T T> new version with temp variable 10may93jaw
254:
255: VARIABLE VocTemp
256:
257: : <T get-current VocTemp ! also Ghosts definitions ;
258: : T> previous VocTemp @ set-current ;
259:
260: hex
261: 4711 Constant <fwd> 4712 Constant <res>
262: 4713 Constant <imm> 4714 Constant <do:>
263:
264: \ iForth makes only immediate directly after create
265: \ make atonce trick! ?
266:
267: Variable atonce atonce off
268:
269: : NoExec true ABORT" CROSS: Don't execute ghost" ;
270:
271: : GhostHeader <fwd> , 0 , ['] NoExec , ;
272:
273: : >magic ;
274: : >link cell+ ;
275: : >exec cell+ cell+ ;
276: : >end 3 cells + ;
277:
278: Variable last-ghost
279: : Make-Ghost ( "name" -- ghost )
280: >in @ GhostName swap >in !
281: <T Create atonce @ IF immediate atonce off THEN
282: here tuck swap ! ghostheader T>
283: DOES> dup last-ghost ! >exec @ execute ;
284:
285: variable cfalist 0 cfalist !
286:
287: : markcfa
288: cfalist here over @ , swap ! , ;
289:
290: \ ghost words 14oct92py
291: \ changed: 10may93py/jaw
292:
293: : gfind ( string -- ghost true/1 / string false )
294: \ searches for string in word-list ghosts
295: dup count [ ' ghosts >body ] ALiteral search-wordlist
296: dup IF >r >body nip r> THEN ;
297:
298: VARIABLE Already
299:
300: : ghost ( "name" -- ghost )
301: Already off
302: >in @ bl word gfind IF Already on nip EXIT THEN
303: drop >in ! Make-Ghost ;
304:
305: \ resolve 14oct92py
306:
307: : resolve-loop ( ghost tcfa -- ghost tcfa )
308: >r dup >link @
309: BEGIN dup WHILE dup T @ H r@ rot T ! H REPEAT drop r> ;
310:
311: \ exists 9may93jaw
312:
313: : exists ( ghost tcfa -- )
314: over GhostNames
315: BEGIN @ dup
316: WHILE 2dup cell+ @ =
317: UNTIL
318: 2 cells + count cr ." CROSS: Exists: " type 4 spaces drop
319: swap cell+ !
320: ELSE true abort" CROSS: Ghostnames inconsistent "
321: THEN ;
322:
323: : resolve ( ghost tcfa -- )
324: over >magic @ <fwd> <> IF exists EXIT THEN
325: resolve-loop over >link ! <res> swap >magic ! ;
326:
327: \ gexecute ghost, 01nov92py
328:
329: : do-forward ( ghost -- )
330: >link dup @ there rot ! T A, H ;
331: : do-resolve ( ghost -- )
332: >link @ T A, H ;
333:
334: : gexecute ( ghost -- ) dup @
335: <fwd> = IF do-forward ELSE do-resolve THEN ;
336: : ghost, ghost gexecute ;
337:
338: \ .unresolved 11may93jaw
339:
340: variable ResolveFlag
341:
342: \ ?touched 11may93jaw
343:
344: : ?touched ( ghost -- flag ) dup >magic @ <fwd> = swap >link @
345: 0 <> and ;
346:
347: : ?resolved ( ghostname -- )
348: dup cell+ @ ?touched
349: IF cell+ cell+ count cr type ResolveFlag on ELSE drop THEN ;
350:
351: >MINIMAL
352: : .unresolved ( -- )
353: ResolveFlag off cr ." Unresolved: "
354: Ghostnames
355: BEGIN @ dup
356: WHILE dup ?resolved
357: REPEAT drop ResolveFlag @
358: IF
359: -1 abort" Unresolved words!"
360: ELSE
361: ." Nothing!"
362: THEN
363: cr ;
364:
365: >CROSS
366: \ Header states 12dec92py
367:
368: : flag! ( 8b -- ) tlast @ dup >r T c@ xor r> c! H ;
369:
370: VARIABLE ^imm
371:
372: >TARGET
373: : immediate 40 flag!
374: ^imm @ @ dup <imm> = IF drop EXIT THEN
375: <res> <> ABORT" CROSS: Cannot immediate a unresolved word"
376: <imm> ^imm @ ! ;
377: : restrict 20 flag! ;
378: >CROSS
379:
380: \ ALIAS2 ansforth conform alias 9may93jaw
381:
382: : ALIAS2 create here 0 , DOES> @ execute ;
383: \ usage:
384: \ ' <name> alias2 bla !
385:
386: \ Target Header Creation 01nov92py
387:
388: : string, ( addr count -- )
389: dup T c, H bounds ?DO I c@ T c, H LOOP ;
390: : name, ( "name" -- ) bl word count string, T cfalign H ;
391: : view, ( -- ) ( dummy ) ;
392:
393: \ Target Document Creation (goes to crossdoc.fd) 05jul95py
394:
395: s" doc/crossdoc.fd" r/w create-file throw value doc-file-id
396: \ contains the file-id of the documentation file
397:
398: : T-\G ( -- )
399: source >in @ /string doc-file-id write-line throw
400: postpone \ ;
401:
402: Variable to-doc to-doc on
403:
404: : cross-doc-entry ( -- )
405: to-doc @ tlast @ 0<> and \ not an anonymous (i.e. noname) header
406: IF
407: s" " doc-file-id write-line throw
408: s" make-doc " doc-file-id write-file throw
409: tlast @ >image count $1F and doc-file-id write-file throw
410: >in @
411: [char] ( parse 2drop
412: [char] ) parse doc-file-id write-file throw
413: s" )" doc-file-id write-file throw
414: [char] \ parse 2drop
415: T-\G
416: >in !
417: THEN ;
418:
419: \ Target TAGS creation
420:
421: s" kernel.TAGS" r/w create-file throw value tag-file-id
422: \ contains the file-id of the tags file
423:
424: Create tag-beg 2 c, 7F c, bl c,
425: Create tag-end 2 c, bl c, 01 c,
426: Create tag-bof 1 c, 0C c,
427:
428: 2variable last-loadfilename 0 0 last-loadfilename 2!
429:
430: : put-load-file-name ( -- )
431: loadfilename 2@ last-loadfilename 2@ d<>
432: IF
433: tag-bof count tag-file-id write-line throw
434: sourcefilename 2dup
435: tag-file-id write-file throw
436: last-loadfilename 2!
437: s" ,0" tag-file-id write-line throw
438: THEN ;
439:
440: : cross-tag-entry ( -- )
441: tlast @ 0<> \ not an anonymous (i.e. noname) header
442: IF
443: put-load-file-name
444: source >in @ min tag-file-id write-file throw
445: tag-beg count tag-file-id write-file throw
446: tlast @ >image count $1F and tag-file-id write-file throw
447: tag-end count tag-file-id write-file throw
448: base @ decimal sourceline# 0 <# #s #> tag-file-id write-file throw
449: \ >in @ 0 <# #s [char] , hold #> tag-file-id write-line throw
450: s" ,0" tag-file-id write-line throw
451: base !
452: THEN ;
453:
454: \ Check for words
455:
456: Defer skip? ' false IS skip?
457:
458: : defined? ( -- flag ) \ name
459: ghost >magic @ <fwd> <> ;
460:
461: : needed? ( -- flag ) \ name
462: \G returns a false flag when
463: \G a word is not defined
464: \G a forward reference exists
465: \G so the definition is not skipped!
466: bl word gfind
467: IF dup >magic @ <fwd> =
468: \ swap >link @ 0<> and
469: nip
470: 0=
471: ELSE drop true THEN ;
472:
473: : doer? ( -- flag ) \ name
474: ghost >magic @ <do:> = ;
475:
476: : skip-defs ( -- )
477: BEGIN refill WHILE source -trailing nip 0= UNTIL THEN ;
478:
479: \ Target header creation
480:
481: VARIABLE CreateFlag CreateFlag off
482:
483: : (Theader ( "name" -- ghost )
484: \ >in @ bl word count type 2 spaces >in !
485: T align H view,
486: tlast @ dup 0> IF T 1 cells - THEN A, H there tlast !
487: >in @ name, >in ! T here H tlastcfa !
488: CreateFlag @ IF
489: >in @ alias2 swap >in ! \ create alias in target
490: >in @ ghost swap >in !
491: swap also ghosts ' previous swap ! \ tick ghost and store in alias
492: CreateFlag off
493: ELSE ghost THEN
494: dup >magic ^imm ! \ a pointer for immediate
495: Already @ IF dup >end tdoes !
496: ELSE 0 tdoes ! THEN
497: 80 flag!
498: cross-doc-entry cross-tag-entry ;
499:
500: VARIABLE ;Resolve 1 cells allot
501:
502: : Theader ( "name" -- ghost )
503: (THeader dup there resolve 0 ;Resolve ! ;
504:
505: >TARGET
506: : Alias ( cfa -- ) \ name
507: >in @ skip? IF 2drop EXIT THEN >in !
508: dup 0< has-prims 0= and
509: IF
510: ." needs prim: " >in @ bl word count type >in ! cr
511: THEN
512: (THeader over resolve T A, H 80 flag! ;
513: : Alias: ( cfa -- ) \ name
514: >in @ skip? IF 2drop EXIT THEN >in !
515: dup 0< has-prims 0= and
516: IF
517: ." needs doer: " >in @ bl word count type >in ! cr
518: THEN
519: ghost tuck swap resolve <do:> swap >magic ! ;
520: >CROSS
521:
522: \ Conditionals and Comments 11may93jaw
523:
524: : ;Cond
525: postpone ;
526: swap ! ; immediate
527:
528: : Cond: ( -- ) \ name {code } ;
529: atonce on
530: ghost
531: >exec
532: :NONAME ;
533:
534: : restrict? ( -- )
535: \ aborts on interprete state - ae
536: state @ 0= ABORT" CROSS: Restricted" ;
537:
538: : Comment ( -- )
539: >in @ atonce on ghost swap >in ! ' swap >exec ! ;
540:
541: Comment ( Comment \
542:
543: \ Predefined ghosts 12dec92py
544:
545: ghost 0= drop
546: ghost branch ghost ?branch 2drop
547: ghost (do) ghost (?do) 2drop
548: ghost (for) drop
549: ghost (loop) ghost (+loop) 2drop
550: ghost (next) drop
551: ghost unloop ghost ;S 2drop
552: ghost lit ghost (compile) ghost ! 2drop drop
553: ghost (does>) ghost noop 2drop
554: ghost (.") ghost (S") ghost (ABORT") 2drop drop
555: ghost ' drop
556: ghost :docol ghost :doesjump ghost :dodoes 2drop drop
557: ghost over ghost = ghost drop 2drop drop
558:
559: \ compile 10may93jaw
560:
561: : compile ( -- ) \ name
562: restrict?
563: bl word gfind dup 0= ABORT" CROSS: Can't compile "
564: 0> ( immediate? )
565: IF >exec @ compile,
566: ELSE postpone literal postpone gexecute THEN ;
567: immediate
568:
569: \ generic threading modell
570: : docol, ( -- ) compile :docol T 0 , H ;
571:
572: : dodoes, ( -- ) T cfalign H compile :doesjump T 0 , H ;
573:
574: [IFUNDEF] (code)
575: Defer (code)
576: Defer (end-code)
577: [THEN]
578:
579: [IFUNDEF] ca>native
580: defer ca>native
581: [THEN]
582:
583: >TARGET
584: : Code
585: (THeader there resolve
586: [ has-prims 0= [IF] ITC [ELSE] true [THEN] ] [IF]
587: there 2 T cells H + ca>native T a, 0 , H
588: [THEN]
589: depth (code) ;
590:
591: : Code:
592: ghost dup there ca>native resolve <do:> swap >magic !
593: depth (code) ;
594:
595: : end-code
596: depth ?dup IF 1- <> ABORT" CROSS: Stack changed"
597: ELSE true ABORT" CROSS: Stack empty" THEN
598: (end-code) ;
599:
600: : ' ( -- cfa ) bl word gfind 0= ABORT" CROSS: undefined "
601: dup >magic @ <fwd> = ABORT" CROSS: forward " >link @ ;
602:
603: Cond: ['] compile lit ghost gexecute ;Cond
604:
605: Cond: chars ;Cond
606:
607: >CROSS
608: \ tLiteral 12dec92py
609:
610: : lit, ( n -- ) compile lit T , H ;
611: : alit, ( n -- ) compile lit T A, H ;
612:
613: >TARGET
614: Cond: \G T-\G ;Cond
615:
616: Cond: Literal ( n -- ) restrict? lit, ;Cond
617: Cond: ALiteral ( n -- ) restrict? alit, ;Cond
618:
619: : Char ( "<char>" -- ) bl word char+ c@ ;
620: Cond: [Char] ( "<char>" -- ) restrict? Char lit, ;Cond
621:
622: \ some special literals 27jan97jaw
623:
624: Cond: MAXU
625: restrict? compile lit
626: tcell 0 ?DO FF T c, H LOOP ;Cond
627:
628: Cond: MINI
629: restrict? compile lit
630: bigendian IF
631: 80 T c, H tcell 1 ?DO 0 T c, H LOOP
632: ELSE
633: tcell 1 ?DO 0 T c, H LOOP 80 T c, H
634: THEN
635: ;Cond
636:
637: Cond: MAXI
638: restrict? compile lit
639: bigendian IF
640: 7F T c, H tcell 1 ?DO FF T c, H LOOP
641: ELSE
642: tcell 1 ?DO FF T c, H LOOP 7F T c, H
643: THEN
644: ;Cond
645:
646: >CROSS
647: \ Target compiling loop 12dec92py
648: \ ">tib trick thrown out 10may93jaw
649: \ number? defined at the top 11may93jaw
650:
651: \ compiled word might leave items on stack!
652: : tcom ( in name -- )
653: gfind ?dup IF 0> IF nip >exec @ execute
654: ELSE nip gexecute THEN EXIT THEN
655: number? dup IF 0> IF swap lit, THEN lit, drop
656: ELSE 2drop >in !
657: ghost gexecute THEN ;
658:
659: >TARGET
660: \ : ; DOES> 13dec92py
661: \ ] 9may93py/jaw
662:
663: : ] state on
664: BEGIN
665: BEGIN >in @ bl word
666: dup c@ 0= WHILE 2drop refill 0=
667: ABORT" CROSS: End of file while target compiling"
668: REPEAT
669: tcom
670: state @
671: 0=
672: UNTIL ;
673:
674: \ by the way: defining a second interpreter (a compiler-)loop
675: \ is not allowed if a system should be ans conform
676:
677: : : ( -- colon-sys ) \ Name
678: >in @ skip? IF drop skip-defs EXIT THEN >in !
679: (THeader ;Resolve ! there ;Resolve cell+ !
680: docol, depth T ] H ;
681:
682: : :noname ( -- colon-sys )
683: T cfalign H there docol, depth T ] H ;
684:
685: Cond: EXIT ( -- ) restrict? compile ;S ;Cond
686:
687: Cond: ?EXIT ( -- ) 1 abort" CROSS: using ?exit" ;Cond
688:
689: Cond: ; ( -- ) restrict?
690: depth ?dup IF 1- <> ABORT" CROSS: Stack changed"
691: ELSE true ABORT" CROSS: Stack empty" THEN
692: compile ;S state off
693: ;Resolve @
694: IF ;Resolve @ ;Resolve cell+ @ resolve THEN
695: ;Cond
696: Cond: [ restrict? state off ;Cond
697:
698: >CROSS
699: : !does
700: tlastcfa @ dup there >r tdp ! compile :dodoes r> tdp ! T cell+ ! H ;
701:
702: >TARGET
703: Cond: DOES> restrict?
704: compile (does>) dodoes, tdoes @ ?dup IF @ T here H resolve THEN
705: ;Cond
706: : DOES> dodoes, T here H !does depth T ] H ;
707:
708: >CROSS
709: \ Creation 01nov92py
710:
711: \ Builder 11may93jaw
712:
713: : Builder ( Create do: "name" -- )
714: >in @ alias2 swap dup >in ! >r >r
715: Make-Ghost rot swap >exec ! ,
716: r> r> >in !
717: also ghosts ' previous swap ! ;
718: \ DOES> dup >exec @ execute ;
719:
720: : gdoes, ( ghost -- ) >end @ dup >magic @ <fwd> <>
721: IF
722: dup >magic @ <do:> =
723: IF gexecute T 0 , H EXIT THEN
724: THEN
725: compile :dodoes gexecute T here H tcell - reloff ;
726:
727: : TCreate ( -- )
728: last-ghost @
729: CreateFlag on
730: Theader >r dup gdoes,
731: >end @ >exec @ r> >exec ! ;
732:
733: : Build: ( -- [xt] [colon-sys] )
734: :noname postpone TCreate ;
735:
736: : gdoes> ( ghost -- addr flag )
737: last-ghost @
738: state @ IF gexecute true EXIT THEN
739: cell+ @ T >body H false ;
740:
741: \ DO: ;DO 11may93jaw
742: \ changed to ?EXIT 10may93jaw
743:
744: : DO: ( -- addr [xt] [colon-sys] )
745: here ghostheader
746: :noname postpone gdoes> postpone ?EXIT ;
747:
748: : by: ( -- addr [xt] [colon-sys] ) \ name
749: ghost
750: :noname postpone gdoes> postpone ?EXIT ;
751:
752: : ;DO ( addr [xt] [colon-sys] -- )
753: postpone ; ( S addr xt )
754: over >exec ! ; immediate
755:
756: : by ( -- addr ) \ Name
757: ghost >end @ ;
758:
759: >TARGET
760: \ Variables and Constants 05dec92py
761:
762: Build: ;
763: by: :dovar ( ghost -- addr ) ;DO
764: Builder Create
765:
766: Build: T 0 , H ;
767: by Create
768: Builder Variable
769:
770: Build: T 0 A, H ;
771: by Create
772: Builder AVariable
773:
774: \ User variables 04may94py
775:
776: >CROSS
777: Variable tup 0 tup !
778: Variable tudp 0 tudp !
779: : u, ( n -- udp )
780: tup @ tudp @ + T ! H
781: tudp @ dup T cell+ H tudp ! ;
782: : au, ( n -- udp )
783: tup @ tudp @ + T A! H
784: tudp @ dup T cell+ H tudp ! ;
785: >TARGET
786:
787: Build: T 0 u, , H ;
788: by: :douser ( ghost -- up-addr ) T @ H tup @ + ;DO
789: Builder User
790:
791: Build: T 0 u, , 0 u, drop H ;
792: by User
793: Builder 2User
794:
795: Build: T 0 au, , H ;
796: by User
797: Builder AUser
798:
799: Build: ( n -- ) ;
800: by: :docon ( ghost -- n ) T @ H ;DO
801: Builder (Constant)
802:
803: Build: ( n -- ) T , H ;
804: by (Constant)
805: Builder Constant
806:
807: Build: ( n -- ) T A, H ;
808: by (Constant)
809: Builder AConstant
810:
811: Build: ( d -- ) T , , H ;
812: DO: ( ghost -- d ) T dup cell+ @ swap @ H ;DO
813: Builder 2Constant
814:
815: Build: T , H ;
816: by (Constant)
817: Builder Value
818:
819: Build: T A, H ;
820: by (Constant)
821: Builder AValue
822:
823: Build: ( -- ) compile noop ;
824: by: :dodefer ( ghost -- ) ABORT" CROSS: Don't execute" ;DO
825: Builder Defer
826:
827: Build: ( inter comp -- ) swap T immediate A, A, H ;
828: DO: ( ghost -- ) ABORT" CROSS: Don't execute" ;DO
829: Builder interpret/compile:
830:
831: \ Sturctures 23feb95py
832:
833: >CROSS
834: : nalign ( addr1 n -- addr2 )
835: \ addr2 is the aligned version of addr1 wrt the alignment size n
836: 1- tuck + swap invert and ;
837: >TARGET
838:
839: Build: ;
840: by: :dofield T @ H + ;DO
841: Builder (Field)
842:
843: Build: >r rot r@ nalign dup T , H ( align1 size offset )
844: + swap r> nalign ;
845: by (Field)
846: Builder Field
847:
848: : struct T 0 1 chars H ;
849: : end-struct T 2Constant H ;
850:
851: : cells: ( n -- size align )
852: T cells 1 cells H ;
853:
854: \ ' 2Constant Alias2 end-struct
855: \ 0 1 T Chars H 2Constant struct
856:
857: \ structural conditionals 17dec92py
858:
859: >CROSS
860: : ?struc ( flag -- ) ABORT" CROSS: unstructured " ;
861: : sys? ( sys -- sys ) dup 0= ?struc ;
862: : >mark ( -- sys ) T here 0 , H ;
863: : >resolve ( sys -- ) T here over - swap ! H ;
864: : <resolve ( sys -- ) T here - , H ;
865: >TARGET
866:
867: \ Structural Conditionals 12dec92py
868:
869: Cond: BUT restrict? sys? swap ;Cond
870: Cond: YET restrict? sys? dup ;Cond
871:
872: >CROSS
873: Variable tleavings
874: >TARGET
875:
876: Cond: DONE ( addr -- ) restrict? tleavings @
877: BEGIN 2dup u> 0= WHILE dup T @ H swap >resolve REPEAT
878: tleavings ! drop ;Cond
879:
880: >CROSS
881: : (leave T here H tleavings @ T , H tleavings ! ;
882: >TARGET
883:
884: Cond: LEAVE restrict? compile branch (leave ;Cond
885: Cond: ?LEAVE restrict? compile 0= compile ?branch (leave ;Cond
886:
887: \ Structural Conditionals 12dec92py
888:
889: Cond: AHEAD restrict? compile branch >mark ;Cond
890: Cond: IF restrict? compile ?branch >mark ;Cond
891: Cond: THEN restrict? sys? dup T @ H ?struc >resolve ;Cond
892: Cond: ELSE restrict? sys? compile AHEAD swap compile THEN ;Cond
893:
894: Cond: BEGIN restrict? T here H ;Cond
895: Cond: WHILE restrict? sys? compile IF swap ;Cond
896: Cond: AGAIN restrict? sys? compile branch <resolve ;Cond
897: Cond: UNTIL restrict? sys? compile ?branch <resolve ;Cond
898: Cond: REPEAT restrict? over 0= ?struc compile AGAIN compile THEN ;Cond
899:
900: Cond: CASE restrict? 0 ;Cond
901: Cond: OF restrict? 1+ >r compile over compile = compile IF compile drop
902: r> ;Cond
903: Cond: ENDOF restrict? >r compile ELSE r> ;Cond
904: Cond: ENDCASE restrict? compile drop 0 ?DO compile THEN LOOP ;Cond
905:
906: \ Structural Conditionals 12dec92py
907:
908: Cond: DO restrict? compile (do) T here H ;Cond
909: Cond: ?DO restrict? compile (?do) T (leave here H ;Cond
910: Cond: FOR restrict? compile (for) T here H ;Cond
911:
912: >CROSS
913: : loop] dup <resolve tcell - compile DONE compile unloop ;
914: >TARGET
915:
916: Cond: LOOP restrict? sys? compile (loop) loop] ;Cond
917: Cond: +LOOP restrict? sys? compile (+loop) loop] ;Cond
918: Cond: NEXT restrict? sys? compile (next) loop] ;Cond
919:
920: \ String words 23feb93py
921:
922: : ," [char] " parse string, T align H ;
923:
924: Cond: ." restrict? compile (.") T ," H ;Cond
925: Cond: S" restrict? compile (S") T ," H ;Cond
926: Cond: ABORT" restrict? compile (ABORT") T ," H ;Cond
927:
928: Cond: IS T ' >body H compile ALiteral compile ! ;Cond
929: : IS T ' >body ! H ;
930: Cond: TO T ' >body H compile ALiteral compile ! ;Cond
931: : TO T ' >body ! H ;
932:
933: \ LINKED ERR" ENV" 2ENV" 18may93jaw
934:
935: \ linked list primitive
936: : linked T here over @ A, swap ! H ;
937:
938: : err" s" ErrLink linked" evaluate T , H
939: [char] " parse string, T align H ;
940:
941: : env" [char] " parse s" EnvLink linked" evaluate
942: string, T align , H ;
943:
944: : 2env" [char] " parse s" EnvLink linked" evaluate
945: here >r string, T align , , H
946: r> dup T c@ H 80 and swap T c! H ;
947:
948: \ compile must be last 22feb93py
949:
950: Cond: compile ( -- ) restrict? \ name
951: bl word gfind dup 0= ABORT" CROSS: Can't compile"
952: 0> IF gexecute
953: ELSE dup >magic @ <imm> =
954: IF gexecute
955: ELSE compile (compile) gexecute THEN THEN ;Cond
956:
957: Cond: postpone ( -- ) restrict? \ name
958: bl word gfind dup 0= ABORT" CROSS: Can't compile"
959: 0> IF gexecute
960: ELSE dup >magic @ <imm> =
961: IF gexecute
962: ELSE compile (compile) gexecute THEN THEN ;Cond
963:
964: >MINIMAL
965: also minimal
966: \ Usefull words 13feb93py
967:
968: : KB 400 * ;
969:
970: \ define new [IFDEF] and [IFUNDEF] 20may93jaw
971:
972: : defined? defined? ;
973: : needed? needed? ;
974: : doer? doer? ;
975:
976: : [IFDEF] defined? postpone [IF] ;
977: : [IFUNDEF] defined? 0= postpone [IF] ;
978:
979: \ C: \- \+ Conditional Compiling 09jun93jaw
980:
981: : C: >in @ defined? 0=
982: IF >in ! T : H
983: ELSE drop
984: BEGIN bl word dup c@
985: IF count comment? s" ;" compare 0= ?EXIT
986: ELSE refill 0= ABORT" CROSS: Out of Input while C:"
987: THEN
988: AGAIN
989: THEN ;
990:
991: also minimal
992:
993: \G interprets the line if word is not defined
994: : \- defined? IF postpone \ THEN ;
995:
996: \G interprets the line if word is defined
997: : \+ defined? 0= IF postpone \ THEN ;
998:
999: Cond: \- \- ;Cond
1000: Cond: \+ \+ ;Cond
1001:
1002: : ?? bl word find IF execute ELSE drop 0 THEN ;
1003:
1004: : needed:
1005: \G defines ghost for words that we want to be compiled
1006: BEGIN >in @ bl word c@ WHILE >in ! ghost drop REPEAT drop ;
1007:
1008: : [IF] postpone [IF] ;
1009: : [THEN] postpone [THEN] ;
1010: : [ELSE] postpone [ELSE] ;
1011:
1012: Cond: [IF] [IF] ;Cond
1013: Cond: [IFDEF] [IFDEF] ;Cond
1014: Cond: [IFUNDEF] [IFUNDEF] ;Cond
1015: Cond: [THEN] [THEN] ;Cond
1016: Cond: [ELSE] [ELSE] ;Cond
1017:
1018: previous
1019:
1020: \ save-cross 17mar93py
1021:
1022: >CROSS
1023: Create magic s" Gforth10" here over allot swap move
1024:
1025: char 1 bigendian + tcell + magic 7 + c!
1026:
1027: : save-cross ( "image-name" "binary-name" -- )
1028: bl parse ." Saving to " 2dup type cr
1029: w/o bin create-file throw >r
1030: TNIL IF
1031: s" #! " r@ write-file throw
1032: bl parse r@ write-file throw
1033: s" -i" r@ write-file throw
1034: #lf r@ emit-file throw
1035: r@ dup file-position throw drop 8 mod 8 swap ( file-id limit index )
1036: ?do
1037: bl over emit-file throw
1038: loop
1039: drop
1040: magic 8 r@ write-file throw \ write magic
1041: ELSE
1042: bl parse 2drop
1043: THEN
1044: image @ there r@ write-file throw \ write image
1045: TNIL IF
1046: bit$ @ there 1- tcell>bit rshift 1+
1047: r@ write-file throw \ write tags
1048: THEN
1049: r> close-file throw ;
1050:
1051: \ words that should be in minimal
1052: >MINIMAL
1053: also minimal
1054:
1055: bigendian Constant bigendian
1056: : save-cross save-cross ;
1057: : here there ;
1058: also forth
1059: [IFDEF] Label : Label Label ; [THEN]
1060: [IFDEF] start-macros : start-macros start-macros ; [THEN]
1061: previous
1062:
1063: : + + ;
1064: : or or ;
1065: : 1- 1- ;
1066: : - - ;
1067: : 2* 2* ;
1068: : * * ;
1069: : / / ;
1070: : dup dup ;
1071: : over over ;
1072: : swap swap ;
1073: : rot rot ;
1074: : drop drop ;
1075: : = = ;
1076: : 0= 0= ;
1077: : lshift lshift ;
1078: : 2/ 2/ ;
1079: : . . ;
1080: : const ;
1081:
1082: \ mach-file count included
1083:
1084: : all-words ['] false IS skip? ;
1085: : needed-words ['] needed? IS skip? ;
1086: : undef-words ['] defined? IS skip? ;
1087:
1088: : \ postpone \ ; immediate
1089: : \G T-\G ; immediate
1090: : ( postpone ( ; immediate
1091: : include bl word count included ;
1092: : .( [char] ) parse type ;
1093: : cr cr ;
1094:
1095: : times 0 ?DO dup T c, H LOOP drop ; \ used for space table creation
1096: only forth also minimal definitions
1097:
1098: \ cross-compiler words
1099:
1100: : decimal decimal ;
1101: : hex hex ;
1102:
1103: : tudp T tudp H ;
1104: : tup T tup H ;
1105:
1106: : doc-off false T to-doc H ! ;
1107: : doc-on true T to-doc H ! ;
1108:
1109: minimal
1110:
1111: \ for debugging...
1112: : order order ;
1113: : words words ;
1114: : .s .s ;
1115:
1116: : bye bye ;
1117:
1118: \ turnkey direction
1119: : H forth ; immediate
1120: : T minimal ; immediate
1121: : G ghosts ; immediate
1122:
1123: : turnkey 0 set-order also Target definitions
1124: also Minimal also ;
1125:
1126: \ these ones are pefered:
1127:
1128: : lock turnkey ;
1129: : unlock forth also cross ;
1130:
1131: unlock definitions also minimal
1132: : lock lock ;
1133: lock
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to cross.fs CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [gforth] / gforth