Annotation of gforth/cross.fs, revision 1.28
1.1 anton 1: \ CROSS.FS The Cross-Compiler 06oct92py
1.23 pazsan 2: \ $Id: cross.fs,v 1.22 1995/02/06 18:14:30 anton Exp $
1.1 anton 3: \ Idea and implementation: Bernd Paysan (py)
1.15 pazsan 4: \ Copyright 1992-94 by the GNU Forth Development Group
1.1 anton 5:
6: \ Log:
7: \ changed in ; [ to state off 12may93jaw
8: \ included place +place 12may93jaw
9: \ for a created word (variable, constant...)
10: \ is now an alias in the target voabulary.
11: \ this means it is no longer necessary to
12: \ switch between vocabularies for variable
13: \ initialization 12may93jaw
14: \ discovered error in DOES>
15: \ replaced !does with (;code) 16may93jaw
16: \ made complete redesign and
17: \ introduced two vocs method
18: \ to be asure that the right words
19: \ are found 08jun93jaw
20: \ btw: ! works not with 16 bit
21: \ targets 09jun93jaw
22: \ added: 2user and value 11jun93jaw
23:
1.9 pazsan 24: \ include other.fs \ ansforth extentions for cross
1.1 anton 25:
1.23 pazsan 26: : string, ( c-addr u -- )
27: \ puts down string as cstring
28: dup c, here swap chars dup allot move ;
29: ' falign Alias cfalign
1.5 pazsan 30: : comment? ( c-addr u -- c-addr u )
31: 2dup s" (" compare 0=
32: IF postpone (
33: ELSE 2dup s" \" compare 0= IF postpone \ THEN
34: THEN ;
35:
1.1 anton 36: decimal
37:
38: \ Begin CROSS COMPILER:
39:
40: \ GhostNames 9may93jaw
41: \ second name source to search trough list
42:
43: VARIABLE GhostNames
44: 0 GhostNames !
45: : GhostName ( -- addr )
1.22 anton 46: here GhostNames @ , GhostNames ! here 0 ,
47: bl word count
48: \ 2dup type space
49: string, cfalign ;
1.1 anton 50:
51: hex
52:
53:
54: Vocabulary Cross
55: Vocabulary Target
56: Vocabulary Ghosts
57: VOCABULARY Minimal
58: only Forth also Target also also
59: definitions Forth
60:
61: : T previous Cross also Target ; immediate
62: : G Ghosts ; immediate
63: : H previous Forth also Cross ; immediate
64:
65: forth definitions
66:
67: : T previous Cross also Target ; immediate
68: : G Ghosts ; immediate
69:
70: : >cross also Cross definitions previous ;
71: : >target also Target definitions previous ;
72: : >minimal also Minimal definitions previous ;
73:
74: H
75:
76: >CROSS
77:
78: \ Variables 06oct92py
79:
80: -1 Constant NIL
81: Variable image
82: Variable tlast NIL tlast ! \ Last name field
83: Variable tlastcfa \ Last code field
84: Variable tdoes \ Resolve does> calls
85: Variable bit$
86: Variable tdp
87: : there tdp @ ;
88:
89: \ Parameter for target systems 06oct92py
90:
1.13 pazsan 91: included
1.1 anton 92:
1.19 pazsan 93: \ Create additional parameters 19jan95py
94:
95: T
96: cell Constant tcell
97: cell<< Constant tcell<<
98: cell>bit Constant tcell>bit
99: bits/byte Constant tbits/byte
100: float Constant tfloat
101: 1 bits/byte lshift Constant maxbyte
102: H
103:
1.1 anton 104: >TARGET
105:
106: \ Byte ordering and cell size 06oct92py
107:
1.19 pazsan 108: : cell+ tcell + ;
109: : cells tcell<< lshift ;
1.1 anton 110: : chars ;
1.19 pazsan 111: : floats tfloat * ;
1.6 anton 112:
1.1 anton 113: >CROSS
1.19 pazsan 114: : cell/ tcell<< rshift ;
1.1 anton 115: >TARGET
116: 20 CONSTANT bl
117: -1 Constant NIL
118: -2 Constant :docol
119: -3 Constant :docon
120: -4 Constant :dovar
1.3 pazsan 121: -5 Constant :douser
1.10 anton 122: -6 Constant :dodefer
1.24 pazsan 123: -7 Constant :dostruc
124: -8 Constant :dodoes
125: -9 Constant :doesjump
1.1 anton 126:
127: >CROSS
128:
1.20 pazsan 129: bigendian
130: [IF]
131: : T! ( n addr -- ) >r s>d r> tcell bounds swap 1-
132: DO maxbyte ud/mod rot I c! -1 +LOOP 2drop ;
133: : T@ ( addr -- n ) >r 0 0 r> tcell bounds
134: DO maxbyte * swap maxbyte um* rot + swap I c@ + swap LOOP d>s ;
1.19 pazsan 135: [ELSE]
1.20 pazsan 136: : T! ( n addr -- ) >r s>d r> tcell bounds
137: DO maxbyte ud/mod rot I c! LOOP 2drop ;
138: : T@ ( addr -- n ) >r 0 0 r> tcell bounds swap 1-
139: DO maxbyte * swap maxbyte um* rot + swap I c@ + swap -1 +LOOP d>s ;
1.1 anton 140: [THEN]
141:
142: \ Memory initialisation 05dec92py
143: \ Fixed bug in else part 11may93jaw
144:
145: [IFDEF] Memory \ Memory is a bigFORTH feature
1.5 pazsan 146: also Memory
1.1 anton 147: : initmem ( var len -- )
148: 2dup swap handle! >r @ r> erase ;
1.5 pazsan 149: toss
1.1 anton 150: [ELSE]
151: : initmem ( var len -- )
152: tuck allocate abort" CROSS: No memory for target"
153: ( len var adr ) dup rot !
154: ( len adr ) swap erase ;
155: [THEN]
156:
157: \ MakeKernal 12dec92py
158:
159: >MINIMAL
160: : makekernal ( targetsize -- targetsize )
161: bit$ over 1- cell>bit rshift 1+ initmem
162: image over initmem tdp off ;
163:
164: >CROSS
165: \ Bit string manipulation 06oct92py
166: \ 9may93jaw
167: CREATE Bittable 80 c, 40 c, 20 c, 10 c, 8 c, 4 c, 2 c, 1 c,
168: : bits ( n -- n ) chars Bittable + c@ ;
169:
170: : >bit ( addr n -- c-addr mask ) 8 /mod rot + swap bits ;
171: : +bit ( addr n -- ) >bit over c@ or swap c! ;
1.4 pazsan 172: : -bit ( addr n -- ) >bit invert over c@ and swap c! ;
1.1 anton 173: : relon ( taddr -- ) bit$ @ swap cell/ +bit ;
1.4 pazsan 174: : reloff ( taddr -- ) bit$ @ swap cell/ -bit ;
1.1 anton 175:
176: \ Target memory access 06oct92py
177:
178: : align+ ( taddr -- rest )
179: cell tuck 1- and - [ cell 1- ] Literal and ;
1.22 anton 180: : cfalign+ ( taddr -- rest )
181: \ see kernal.fs:cfaligned
182: float tuck 1- and - [ float 1- ] Literal and ;
1.1 anton 183:
184: >TARGET
185: : aligned ( taddr -- ta-addr ) dup align+ + ;
186: \ assumes cell alignment granularity (as GNU C)
187:
1.22 anton 188: : cfaligned ( taddr1 -- taddr2 )
189: \ see kernal.fs
190: dup cfalign+ + ;
191:
1.1 anton 192: >CROSS
193: : >image ( taddr -- absaddr ) image @ + ;
194: >TARGET
1.19 pazsan 195: : @ ( taddr -- w ) >image t@ ;
196: : ! ( w taddr -- ) >image t! ;
1.1 anton 197: : c@ ( taddr -- char ) >image c@ ;
198: : c! ( char taddr -- ) >image c! ;
1.7 anton 199: : 2@ ( taddr -- x1 x2 ) T dup cell+ @ swap @ H ;
200: : 2! ( x1 x2 taddr -- ) T swap over ! cell+ ! H ;
1.1 anton 201:
202: \ Target compilation primitives 06oct92py
203: \ included A! 16may93jaw
204:
205: : here ( -- there ) there ;
206: : allot ( n -- ) tdp +! ;
207: : , ( w -- ) T here H cell T allot ! H ;
208: : c, ( char -- ) T here 1 allot c! H ;
209: : align ( -- ) T here H align+ 0 ?DO bl T c, H LOOP ;
1.22 anton 210: : cfalign ( -- )
211: T here H cfalign+ 0 ?DO bl T c, H LOOP ;
1.1 anton 212:
213: : A! dup relon T ! H ;
214: : A, ( w -- ) T here H relon T , H ;
215:
216: >CROSS
217:
218: \ threading modell 13dec92py
219:
220: \ generic threading modell
221: : docol, ( -- ) :docol T A, 0 , H ;
222:
223: >TARGET
224: : >body ( cfa -- pfa ) T cell+ cell+ H ;
225: >CROSS
226:
1.3 pazsan 227: : dodoes, ( -- ) T :doesjump A, 0 , H ;
1.1 anton 228:
229: \ Ghost Builder 06oct92py
230:
231: \ <T T> new version with temp variable 10may93jaw
232:
233: VARIABLE VocTemp
234:
235: : <T get-current VocTemp ! also Ghosts definitions ;
236: : T> previous VocTemp @ set-current ;
237:
238: 4711 Constant <fwd> 4712 Constant <res>
239: 4713 Constant <imm>
240:
241: \ iForth makes only immediate directly after create
242: \ make atonce trick! ?
243:
244: Variable atonce atonce off
245:
246: : NoExec true ABORT" CROSS: Don't execute ghost" ;
247:
248: : GhostHeader <fwd> , 0 , ['] NoExec , ;
249:
250: : >magic ; : >link cell+ ; : >exec cell+ cell+ ;
251: : >end 3 cells + ;
252:
1.11 pazsan 253: Variable last-ghost
1.1 anton 254: : Make-Ghost ( "name" -- ghost )
255: >in @ GhostName swap >in !
256: <T Create atonce @ IF immediate atonce off THEN
257: here tuck swap ! ghostheader T>
1.11 pazsan 258: DOES> dup last-ghost ! >exec @ execute ;
1.1 anton 259:
260: \ ghost words 14oct92py
261: \ changed: 10may93py/jaw
262:
263: : gfind ( string -- ghost true/1 / string false )
264: \ searches for string in word-list ghosts
265: \ !! wouldn't it be simpler to just use search-wordlist ? ae
1.5 pazsan 266: dup count [ ' ghosts >body ] ALiteral search-wordlist
1.13 pazsan 267: dup IF >r >body nip r> THEN ;
1.1 anton 268:
269: VARIABLE Already
270:
271: : ghost ( "name" -- ghost )
272: Already off
1.13 pazsan 273: >in @ bl word gfind IF Already on nip EXIT THEN
1.1 anton 274: drop >in ! Make-Ghost ;
275:
276: \ resolve 14oct92py
277:
278: : resolve-loop ( ghost tcfa -- ghost tcfa )
279: >r dup >link @
280: BEGIN dup WHILE dup T @ H r@ rot T ! H REPEAT drop r> ;
281:
282: \ exists 9may93jaw
283:
284: : exists ( ghost tcfa -- )
285: over GhostNames
286: BEGIN @ dup
287: WHILE 2dup cell+ @ =
288: UNTIL
1.18 pazsan 289: 2 cells + count cr ." CROSS: Exists: " type 4 spaces drop
1.1 anton 290: swap cell+ !
1.24 pazsan 291: ELSE true abort" CROSS: Ghostnames inconsistent "
1.1 anton 292: THEN ;
293:
294: : resolve ( ghost tcfa -- )
295: over >magic @ <fwd> <> IF exists EXIT THEN
296: resolve-loop over >link ! <res> swap >magic ! ;
297:
298: \ gexecute ghost, 01nov92py
299:
300: : do-forward ( ghost -- )
301: >link dup @ there rot ! T A, H ;
302: : do-resolve ( ghost -- )
303: >link @ T A, H ;
304:
305: : gexecute ( ghost -- ) dup @
306: <fwd> = IF do-forward ELSE do-resolve THEN ;
307: : ghost, ghost gexecute ;
308:
309: \ .unresolved 11may93jaw
310:
311: variable ResolveFlag
312:
313: \ ?touched 11may93jaw
314:
315: : ?touched ( ghost -- flag ) dup >magic @ <fwd> = swap >link @
316: 0 <> and ;
317:
318: : ?resolved ( ghostname -- )
319: dup cell+ @ ?touched
320: IF cell+ cell+ count cr type ResolveFlag on ELSE drop THEN ;
321:
322: >MINIMAL
323: : .unresolved ( -- )
324: ResolveFlag off cr ." Unresolved: "
325: Ghostnames
326: BEGIN @ dup
327: WHILE dup ?resolved
1.10 anton 328: REPEAT drop ResolveFlag @
329: IF
1.11 pazsan 330: abort" Unresolved words!"
1.10 anton 331: ELSE
332: ." Nothing!"
333: THEN
334: cr ;
1.1 anton 335:
336: >CROSS
337: \ Header states 12dec92py
338:
339: : flag! ( 8b -- ) tlast @ dup >r T c@ xor r> c! H ;
340:
341: VARIABLE ^imm
342:
343: >TARGET
344: : immediate 20 flag!
1.18 pazsan 345: ^imm @ @ dup <imm> = IF drop EXIT THEN
1.1 anton 346: <res> <> ABORT" CROSS: Cannot immediate a unresolved word"
347: <imm> ^imm @ ! ;
1.8 pazsan 348: : restrict 40 flag! ;
1.1 anton 349: >CROSS
350:
351: \ ALIAS2 ansforth conform alias 9may93jaw
352:
353: : ALIAS2 create here 0 , DOES> @ execute ;
354: \ usage:
1.18 pazsan 355: \ ' <name> alias2 bla !
1.1 anton 356:
357: \ Target Header Creation 01nov92py
358:
359: : string, ( addr count -- )
1.28 ! pazsan 360: dup T c, H bounds ?DO I c@ T c, H LOOP ;
1.22 anton 361: : name, ( "name" -- ) bl word count string, T cfalign H ;
1.1 anton 362: : view, ( -- ) ( dummy ) ;
363:
1.25 pazsan 364: \ Target Document Creation (goes to crossdoc.fd) 05jul95py
365:
366: s" crossdoc.fd" r/w create-file throw value doc-file-id
367: \ contains the file-id of the documentation file
368:
369: : \G ( -- )
370: source >in @ /string doc-file-id write-line throw
371: source >in ! drop ; immediate
372:
373: Variable to-doc
374:
375: : cross-doc-entry ( -- )
376: to-doc @ tlast @ 0<> and \ not an anonymous (i.e. noname) header
377: IF
378: s" " doc-file-id write-line throw
379: s" make-doc " doc-file-id write-file throw
380: tlast @ >image count $1F and doc-file-id write-file throw
381: >in @
382: [char] ( parse 2drop
383: [char] ) parse doc-file-id write-file throw
384: s" )" doc-file-id write-file throw
385: [char] \ parse 2drop
386: POSTPONE \g
387: >in !
388: THEN to-doc on ;
389:
1.28 ! pazsan 390: \ Target TAGS creation
! 391:
! 392: s" TAGS" r/w create-file throw value tag-file-id
! 393: \ contains the file-id of the tags file
! 394:
! 395: Create tag-beg 2 c, 7F c, bl c,
! 396: Create tag-end 2 c, bl c, 01 c,
! 397: Create tag-bof 1 c, 0C c,
! 398:
! 399: 2variable last-loadfilename 0 0 last-loadfilename 2!
! 400:
! 401: : put-load-file-name ( -- )
! 402: loadfilename 2@ last-loadfilename 2@ d<>
! 403: IF
! 404: tag-bof count tag-file-id write-line throw
! 405: loadfilename 2@ 2dup
! 406: tag-file-id write-file throw
! 407: last-loadfilename 2!
! 408: s" ,0" tag-file-id write-line throw
! 409: THEN ;
! 410:
! 411: : cross-tag-entry ( -- )
! 412: tlast @ 0<> \ not an anonymous (i.e. noname) header
! 413: IF
! 414: put-load-file-name
! 415: source >in @ min tag-file-id write-file throw
! 416: tag-beg count tag-file-id write-file throw
! 417: tlast @ >image count $1F and tag-file-id write-file throw
! 418: tag-end count tag-file-id write-file throw
! 419: base @ decimal loadline @ 0 <# #s #> tag-file-id write-file throw
! 420: \ >in @ 0 <# #s [char] , hold #> tag-file-id write-line throw
! 421: s" ,0" tag-file-id write-line throw
! 422: base !
! 423: THEN ;
! 424:
! 425: \ Target header creation
! 426:
1.1 anton 427: VARIABLE CreateFlag CreateFlag off
428:
429: : (Theader ( "name" -- ghost ) T align H view,
430: tlast @ dup 0> IF T 1 cells - THEN A, H there tlast !
431: >in @ name, >in ! T here H tlastcfa !
432: CreateFlag @ IF
1.18 pazsan 433: >in @ alias2 swap >in ! \ create alias in target
434: >in @ ghost swap >in !
435: swap also ghosts ' previous swap ! \ tick ghost and store in alias
436: CreateFlag off
1.1 anton 437: ELSE ghost THEN
438: dup >magic ^imm ! \ a pointer for immediate
439: Already @ IF dup >end tdoes !
440: ELSE 0 tdoes ! THEN
1.25 pazsan 441: 80 flag!
1.28 ! pazsan 442: cross-doc-entry cross-tag-entry ;
1.1 anton 443:
444: VARIABLE ;Resolve 1 cells allot
445:
1.11 pazsan 446: : Theader ( "name" -- ghost )
447: (THeader dup there resolve 0 ;Resolve ! ;
1.1 anton 448:
449: >TARGET
450: : Alias ( cfa -- ) \ name
1.25 pazsan 451: dup 0< IF to-doc off THEN
1.1 anton 452: (THeader over resolve T A, H 80 flag! ;
453: >CROSS
454:
455: \ Conditionals and Comments 11may93jaw
456:
457: : ;Cond
458: postpone ;
459: swap ! ; immediate
460:
461: : Cond: ( -- ) \ name {code } ;
462: atonce on
463: ghost
464: >exec
465: :NONAME ;
466:
467: : restrict? ( -- )
468: \ aborts on interprete state - ae
469: state @ 0= ABORT" CROSS: Restricted" ;
470:
471: : Comment ( -- )
472: >in @ atonce on ghost swap >in ! ' swap >exec ! ;
473:
474: Comment ( Comment \
475:
476: \ Predefined ghosts 12dec92py
477:
478: ghost 0= drop
479: ghost branch ghost ?branch 2drop
480: ghost (do) ghost (?do) 2drop
481: ghost (for) drop
482: ghost (loop) ghost (+loop) 2drop
483: ghost (next) drop
1.2 pazsan 484: ghost unloop ghost ;S 2drop
1.1 anton 485: ghost lit ghost (compile) ghost ! 2drop drop
486: ghost (;code) ghost noop 2drop
487: ghost (.") ghost (S") ghost (ABORT") 2drop drop
1.9 pazsan 488: ghost '
1.1 anton 489:
490: \ compile 10may93jaw
491:
492: : compile ( -- ) \ name
493: restrict?
1.13 pazsan 494: bl word gfind dup 0= ABORT" CROSS: Can't compile "
1.1 anton 495: 0> ( immediate? )
496: IF >exec @ compile,
497: ELSE postpone literal postpone gexecute THEN ;
498: immediate
499:
500: >TARGET
1.13 pazsan 501: : ' ( -- cfa ) bl word gfind 0= ABORT" CROSS: undefined "
1.1 anton 502: dup >magic @ <fwd> = ABORT" CROSS: forward " >link @ ;
503:
504: Cond: ['] compile lit ghost gexecute ;Cond
1.14 anton 505:
506: Cond: chars ;Cond
1.1 anton 507:
508: >CROSS
509: \ tLiteral 12dec92py
510:
511: : lit, ( n -- ) compile lit T , H ;
512: : alit, ( n -- ) compile lit T A, H ;
513:
514: >TARGET
515: Cond: Literal ( n -- ) restrict? lit, ;Cond
516: Cond: ALiteral ( n -- ) restrict? alit, ;Cond
517:
518: : Char ( "<char>" -- ) bl word char+ c@ ;
519: Cond: [Char] ( "<char>" -- ) restrict? Char lit, ;Cond
520:
521: >CROSS
522: \ Target compiling loop 12dec92py
523: \ ">tib trick thrown out 10may93jaw
524: \ number? defined at the top 11may93jaw
525:
526: \ compiled word might leave items on stack!
527: : tcom ( in name -- )
528: gfind ?dup IF 0> IF nip >exec @ execute
529: ELSE nip gexecute THEN EXIT THEN
530: number? dup IF 0> IF swap lit, THEN lit, drop
531: ELSE 2drop >in !
532: ghost gexecute THEN ;
533:
534: >TARGET
535: \ : ; DOES> 13dec92py
536: \ ] 9may93py/jaw
537:
538: : ] state on
539: BEGIN
1.13 pazsan 540: BEGIN >in @ bl word
1.1 anton 541: dup c@ 0= WHILE 2drop refill 0=
542: ABORT" CROSS: End of file while target compiling"
543: REPEAT
544: tcom
545: state @
546: 0=
547: UNTIL ;
548:
549: \ by the way: defining a second interpreter (a compiler-)loop
550: \ is not allowed if a system should be ans conform
551:
552: : : ( -- colon-sys ) \ Name
553: (THeader ;Resolve ! there ;Resolve cell+ !
554: docol, depth T ] H ;
555:
1.2 pazsan 556: Cond: EXIT ( -- ) restrict? compile ;S ;Cond
1.6 anton 557:
558: Cond: ?EXIT ( -- ) 1 abort" CROSS: using ?exit" ;Cond
1.2 pazsan 559:
1.1 anton 560: Cond: ; ( -- ) restrict?
561: depth ?dup IF 1- <> ABORT" CROSS: Stack changed"
562: ELSE true ABORT" CROSS: Stack empty" THEN
1.2 pazsan 563: compile ;S state off
1.1 anton 564: ;Resolve @
565: IF ;Resolve @ ;Resolve cell+ @ resolve THEN
566: ;Cond
567: Cond: [ restrict? state off ;Cond
568:
569: >CROSS
570: : !does :dodoes tlastcfa @ tuck T ! cell+ ! H ;
571:
572: >TARGET
573: Cond: DOES> restrict?
574: compile (;code) dodoes, tdoes @ ?dup IF @ T here H resolve THEN
575: ;Cond
576: : DOES> dodoes, T here H !does depth T ] H ;
577:
578: >CROSS
579: \ Creation 01nov92py
580:
581: \ Builder 11may93jaw
582:
583: : Builder ( Create do: "name" -- )
584: >in @ alias2 swap dup >in ! >r >r
585: Make-Ghost rot swap >exec ! ,
586: r> r> >in !
1.11 pazsan 587: also ghosts ' previous swap ! ;
588: \ DOES> dup >exec @ execute ;
1.1 anton 589:
590: : gdoes, ( ghost -- ) >end @ dup >magic @ <fwd> <>
591: IF dup >link @ dup 0< IF T A, 0 , H drop EXIT THEN drop THEN
1.4 pazsan 592: :dodoes T A, H gexecute T here H cell - reloff ;
1.1 anton 593:
1.11 pazsan 594: : TCreate ( -- )
595: last-ghost @
1.1 anton 596: CreateFlag on
1.11 pazsan 597: Theader >r dup gdoes,
598: >end @ >exec @ r> >exec ! ;
1.1 anton 599:
600: : Build: ( -- [xt] [colon-sys] )
601: :noname postpone TCreate ;
602:
603: : gdoes> ( ghost -- addr flag )
1.11 pazsan 604: last-ghost @
1.1 anton 605: state @ IF gexecute true EXIT THEN
606: cell+ @ T >body H false ;
607:
608: \ DO: ;DO 11may93jaw
609: \ changed to ?EXIT 10may93jaw
610:
611: : DO: ( -- addr [xt] [colon-sys] )
612: here ghostheader
1.11 pazsan 613: :noname postpone gdoes> postpone ?EXIT ;
1.1 anton 614:
615: : ;DO ( addr [xt] [colon-sys] -- )
616: postpone ; ( S addr xt )
617: over >exec ! ; immediate
618:
619: : by ( -- addr ) \ Name
620: ghost >end @ ;
621:
622: >TARGET
623: \ Variables and Constants 05dec92py
624:
625: Build: ;
626: DO: ( ghost -- addr ) ;DO
627: Builder Create
628: by Create :dovar resolve
629:
630: Build: T 0 , H ;
631: by Create
632: Builder Variable
633:
634: Build: T 0 A, H ;
635: by Create
636: Builder AVariable
637:
1.3 pazsan 638: \ User variables 04may94py
639:
640: >CROSS
641: Variable tup 0 tup !
642: Variable tudp 0 tudp !
643: : u, ( n -- udp )
644: tup @ tudp @ + T ! H
1.19 pazsan 645: tudp @ dup T cell+ H tudp ! ;
1.3 pazsan 646: : au, ( n -- udp )
647: tup @ tudp @ + T A! H
1.19 pazsan 648: tudp @ dup T cell+ H tudp ! ;
1.3 pazsan 649: >TARGET
650:
651: Build: T 0 u, , H ;
652: DO: ( ghost -- up-addr ) T @ H tup @ + ;DO
1.1 anton 653: Builder User
1.3 pazsan 654: by User :douser resolve
1.1 anton 655:
1.3 pazsan 656: Build: T 0 u, , 0 u, drop H ;
657: by User
1.1 anton 658: Builder 2User
659:
1.3 pazsan 660: Build: T 0 au, , H ;
661: by User
1.1 anton 662: Builder AUser
663:
664: Build: ( n -- ) T , H ;
665: DO: ( ghost -- n ) T @ H ;DO
666: Builder Constant
667: by Constant :docon resolve
668:
669: Build: ( n -- ) T A, H ;
670: by Constant
671: Builder AConstant
672:
1.24 pazsan 673: Build: ( d -- ) T , , H ;
674: DO: ( ghost -- d ) T dup cell+ @ swap @ H ;DO
675: Builder 2Constant
676:
1.1 anton 677: Build: T 0 , H ;
678: by Constant
679: Builder Value
680:
681: Build: ( -- ) compile noop ;
682: DO: ( ghost -- ) ABORT" CROSS: Don't execute" ;DO
683: Builder Defer
1.10 anton 684: by Defer :dodefer resolve
1.24 pazsan 685:
686: \ Sturctures 23feb95py
687:
688: >CROSS
689: : nalign ( addr1 n -- addr2 )
690: \ addr2 is the aligned version of addr1 wrt the alignment size n
691: 1- tuck + swap invert and ;
692: >TARGET
693:
694: Build: >r rot r@ nalign dup T , H ( align1 size offset )
695: + swap r> nalign ;
696: DO: T @ H + ;DO
697: Builder Field
698: by Field :dostruc resolve
699:
700: : struct T 0 1 chars H ;
701: : end-struct T 2Constant H ;
702:
703: : cells: ( n -- size align )
704: T cells 1 cells H ;
705:
706: \ ' 2Constant Alias2 end-struct
707: \ 0 1 T Chars H 2Constant struct
1.1 anton 708:
709: \ structural conditionals 17dec92py
710:
711: >CROSS
712: : ?struc ( flag -- ) ABORT" CROSS: unstructured " ;
713: : sys? ( sys -- sys ) dup 0= ?struc ;
714: : >mark ( -- sys ) T here 0 , H ;
715: : >resolve ( sys -- ) T here over - swap ! H ;
716: : <resolve ( sys -- ) T here - , H ;
717: >TARGET
718:
719: \ Structural Conditionals 12dec92py
720:
721: Cond: BUT restrict? sys? swap ;Cond
722: Cond: YET restrict? sys? dup ;Cond
723:
724: >CROSS
725: Variable tleavings
726: >TARGET
727:
728: Cond: DONE ( addr -- ) restrict? tleavings @
729: BEGIN 2dup u> 0= WHILE dup T @ H swap >resolve REPEAT
730: tleavings ! drop ;Cond
731:
732: >CROSS
733: : (leave T here H tleavings @ T , H tleavings ! ;
734: >TARGET
735:
736: Cond: LEAVE restrict? compile branch (leave ;Cond
737: Cond: ?LEAVE restrict? compile 0= compile ?branch (leave ;Cond
738:
739: \ Structural Conditionals 12dec92py
740:
741: Cond: AHEAD restrict? compile branch >mark ;Cond
742: Cond: IF restrict? compile ?branch >mark ;Cond
743: Cond: THEN restrict? sys? dup T @ H ?struc >resolve ;Cond
744: Cond: ELSE restrict? sys? compile AHEAD swap compile THEN ;Cond
745:
746: Cond: BEGIN restrict? T here H ;Cond
747: Cond: WHILE restrict? sys? compile IF swap ;Cond
748: Cond: AGAIN restrict? sys? compile branch <resolve ;Cond
749: Cond: UNTIL restrict? sys? compile ?branch <resolve ;Cond
750: Cond: REPEAT restrict? over 0= ?struc compile AGAIN compile THEN ;Cond
751:
752: \ Structural Conditionals 12dec92py
753:
754: Cond: DO restrict? compile (do) T here H ;Cond
755: Cond: ?DO restrict? compile (?do) (leave T here H ;Cond
756: Cond: FOR restrict? compile (for) T here H ;Cond
757:
758: >CROSS
759: : loop] dup <resolve cell - compile DONE compile unloop ;
760: >TARGET
761:
762: Cond: LOOP restrict? sys? compile (loop) loop] ;Cond
763: Cond: +LOOP restrict? sys? compile (+loop) loop] ;Cond
764: Cond: NEXT restrict? sys? compile (next) loop] ;Cond
765:
766: \ String words 23feb93py
767:
768: : ," [char] " parse string, T align H ;
769:
770: Cond: ." restrict? compile (.") T ," H ;Cond
771: Cond: S" restrict? compile (S") T ," H ;Cond
772: Cond: ABORT" restrict? compile (ABORT") T ," H ;Cond
773:
774: Cond: IS T ' >body H compile ALiteral compile ! ;Cond
775: : IS T ' >body ! H ;
1.9 pazsan 776: Cond: TO T ' >body H compile ALiteral compile ! ;Cond
777: : TO T ' >body ! H ;
1.1 anton 778:
779: \ LINKED ERR" ENV" 2ENV" 18may93jaw
780:
781: \ linked list primitive
782: : linked T here over @ A, swap ! H ;
783:
784: : err" s" ErrLink linked" evaluate T , H
785: [char] " parse string, T align H ;
786:
787: : env" [char] " parse s" EnvLink linked" evaluate
788: string, T align , H ;
789:
790: : 2env" [char] " parse s" EnvLink linked" evaluate
791: here >r string, T align , , H
792: r> dup T c@ H 80 and swap T c! H ;
793:
794: \ compile must be last 22feb93py
795:
796: Cond: compile ( -- ) restrict? \ name
1.13 pazsan 797: bl word gfind dup 0= ABORT" CROSS: Can't compile"
1.1 anton 798: 0> IF gexecute
799: ELSE dup >magic @ <imm> =
800: IF gexecute
801: ELSE compile (compile) gexecute THEN THEN ;Cond
802:
803: Cond: postpone ( -- ) restrict? \ name
1.13 pazsan 804: bl word gfind dup 0= ABORT" CROSS: Can't compile"
1.1 anton 805: 0> IF gexecute
806: ELSE dup >magic @ <imm> =
807: IF gexecute
808: ELSE compile (compile) gexecute THEN THEN ;Cond
809:
810: >MINIMAL
811: also minimal
812: \ Usefull words 13feb93py
813:
814: : KB 400 * ;
815:
816: \ define new [IFDEF] and [IFUNDEF] 20may93jaw
817:
1.13 pazsan 818: : there? bl word gfind IF >magic @ <fwd> <> ELSE drop false THEN ;
1.1 anton 819:
820: : [IFDEF] there? postpone [IF] ;
821: : [IFUNDEF] there? 0= postpone [IF] ;
822:
823: \ C: \- \+ Conditional Compiling 09jun93jaw
824:
825: : C: >in @ there? 0=
826: IF >in ! T : H
827: ELSE drop
828: BEGIN bl word dup c@
829: IF count comment? s" ;" compare 0= ?EXIT
830: ELSE refill 0= ABORT" CROSS: Out of Input while C:"
831: THEN
832: AGAIN
833: THEN ;
834:
835: also minimal
836:
837: : \- there? IF postpone \ THEN ;
838: : \+ there? 0= IF postpone \ THEN ;
839:
840: : [IF] postpone [IF] ;
841: : [THEN] postpone [THEN] ;
842: : [ELSE] postpone [ELSE] ;
843:
844: Cond: [IF] [IF] ;Cond
845: Cond: [IFDEF] [IFDEF] ;Cond
846: Cond: [IFUNDEF] [IFUNDEF] ;Cond
847: Cond: [THEN] [THEN] ;Cond
848: Cond: [ELSE] [ELSE] ;Cond
849:
850: \ save-cross 17mar93py
851:
852: \ i'm not interested in bigforth features this time 10may93jaw
853: \ [IFDEF] file
854: \ also file
855: \ [THEN]
856: \ included throw after create-file 11may93jaw
857:
1.12 anton 858: bigendian Constant bigendian
1.1 anton 859:
1.26 pazsan 860: Create magic s" gforth00" here over allot swap move
861:
862: [char] 1 bigendian + cell + magic 7 + c!
863:
1.1 anton 864: : save-cross ( "name" -- )
865: bl parse ." Saving to " 2dup type
866: w/o bin create-file throw >r
1.26 pazsan 867: magic 8 r@ write-file throw \ write magic
1.16 pazsan 868: image @ there r@ write-file throw \ write image
869: bit$ @ there 1- cell>bit rshift 1+
870: r@ write-file throw \ write tags
1.1 anton 871: r> close-file throw ;
872:
873: \ words that should be in minimal
874:
875: : + + ; : 1- 1- ;
876: : - - ; : 2* 2* ;
1.11 pazsan 877: : * * ; : / / ;
1.1 anton 878: : dup dup ; : over over ;
879: : swap swap ; : rot rot ;
1.19 pazsan 880: : drop drop ; : = = ;
1.13 pazsan 881: : lshift lshift ; : 2/ 2/ ;
1.19 pazsan 882: : . . ;
1.13 pazsan 883: cell constant cell
1.1 anton 884:
885: \ include bug5.fs
886: \ only forth also minimal definitions
887:
1.25 pazsan 888: : \ postpone \ ;
889: : \G postpone \G ;
890: : ( postpone ( ;
1.1 anton 891: : include bl word count included ;
892: : .( [char] ) parse type ;
893: : cr cr ;
894:
895: : times 0 ?DO dup T c, H LOOP drop ; \ used for space table creation
896: only forth also minimal definitions
897:
898: \ cross-compiler words
899:
900: : decimal decimal ;
901: : hex hex ;
902:
1.3 pazsan 903: : tudp T tudp H ;
904: : tup T tup H ; minimal
1.1 anton 905:
906: \ for debugging...
907: : order order ;
908: : words words ;
909: : .s .s ;
910:
911: : bye bye ;
912:
913: \ turnkey direction
914: : H forth ; immediate
915: : T minimal ; immediate
916: : G ghosts ; immediate
917:
918: : turnkey 0 set-order also Target definitions
919: also Minimal also ;
920:
921: \ these ones are pefered:
922:
923: : lock turnkey ;
924: : unlock forth also cross ;
925:
926: unlock definitions also minimal
927: : lock lock ;
928: 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