Annotation of gforth/cross.fs, revision 1.23
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
123: -7 Constant :dodoes
124: -8 Constant :doesjump
1.1 anton 125:
126: >CROSS
127:
1.20 pazsan 128: bigendian
129: [IF]
130: : T! ( n addr -- ) >r s>d r> tcell bounds swap 1-
131: DO maxbyte ud/mod rot I c! -1 +LOOP 2drop ;
132: : T@ ( addr -- n ) >r 0 0 r> tcell bounds
133: DO maxbyte * swap maxbyte um* rot + swap I c@ + swap LOOP d>s ;
1.19 pazsan 134: [ELSE]
1.20 pazsan 135: : T! ( n addr -- ) >r s>d r> tcell bounds
136: DO maxbyte ud/mod rot I c! LOOP 2drop ;
137: : T@ ( addr -- n ) >r 0 0 r> tcell bounds swap 1-
138: DO maxbyte * swap maxbyte um* rot + swap I c@ + swap -1 +LOOP d>s ;
1.1 anton 139: [THEN]
140:
141: \ Memory initialisation 05dec92py
142: \ Fixed bug in else part 11may93jaw
143:
144: [IFDEF] Memory \ Memory is a bigFORTH feature
1.5 pazsan 145: also Memory
1.1 anton 146: : initmem ( var len -- )
147: 2dup swap handle! >r @ r> erase ;
1.5 pazsan 148: toss
1.1 anton 149: [ELSE]
150: : initmem ( var len -- )
151: tuck allocate abort" CROSS: No memory for target"
152: ( len var adr ) dup rot !
153: ( len adr ) swap erase ;
154: [THEN]
155:
156: \ MakeKernal 12dec92py
157:
158: >MINIMAL
159: : makekernal ( targetsize -- targetsize )
160: bit$ over 1- cell>bit rshift 1+ initmem
161: image over initmem tdp off ;
162:
163: >CROSS
164: \ Bit string manipulation 06oct92py
165: \ 9may93jaw
166: CREATE Bittable 80 c, 40 c, 20 c, 10 c, 8 c, 4 c, 2 c, 1 c,
167: : bits ( n -- n ) chars Bittable + c@ ;
168:
169: : >bit ( addr n -- c-addr mask ) 8 /mod rot + swap bits ;
170: : +bit ( addr n -- ) >bit over c@ or swap c! ;
1.4 pazsan 171: : -bit ( addr n -- ) >bit invert over c@ and swap c! ;
1.1 anton 172: : relon ( taddr -- ) bit$ @ swap cell/ +bit ;
1.4 pazsan 173: : reloff ( taddr -- ) bit$ @ swap cell/ -bit ;
1.1 anton 174:
175: \ Target memory access 06oct92py
176:
177: : align+ ( taddr -- rest )
178: cell tuck 1- and - [ cell 1- ] Literal and ;
1.22 anton 179: : cfalign+ ( taddr -- rest )
180: \ see kernal.fs:cfaligned
181: float tuck 1- and - [ float 1- ] Literal and ;
1.1 anton 182:
183: >TARGET
184: : aligned ( taddr -- ta-addr ) dup align+ + ;
185: \ assumes cell alignment granularity (as GNU C)
186:
1.22 anton 187: : cfaligned ( taddr1 -- taddr2 )
188: \ see kernal.fs
189: dup cfalign+ + ;
190:
1.1 anton 191: >CROSS
192: : >image ( taddr -- absaddr ) image @ + ;
193: >TARGET
1.19 pazsan 194: : @ ( taddr -- w ) >image t@ ;
195: : ! ( w taddr -- ) >image t! ;
1.1 anton 196: : c@ ( taddr -- char ) >image c@ ;
197: : c! ( char taddr -- ) >image c! ;
1.7 anton 198: : 2@ ( taddr -- x1 x2 ) T dup cell+ @ swap @ H ;
199: : 2! ( x1 x2 taddr -- ) T swap over ! cell+ ! H ;
1.1 anton 200:
201: \ Target compilation primitives 06oct92py
202: \ included A! 16may93jaw
203:
204: : here ( -- there ) there ;
205: : allot ( n -- ) tdp +! ;
206: : , ( w -- ) T here H cell T allot ! H ;
207: : c, ( char -- ) T here 1 allot c! H ;
208: : align ( -- ) T here H align+ 0 ?DO bl T c, H LOOP ;
1.22 anton 209: : cfalign ( -- )
210: T here H cfalign+ 0 ?DO bl T c, H LOOP ;
1.1 anton 211:
212: : A! dup relon T ! H ;
213: : A, ( w -- ) T here H relon T , H ;
214:
215: >CROSS
216:
217: \ threading modell 13dec92py
218:
219: \ generic threading modell
220: : docol, ( -- ) :docol T A, 0 , H ;
221:
222: >TARGET
223: : >body ( cfa -- pfa ) T cell+ cell+ H ;
224: >CROSS
225:
1.3 pazsan 226: : dodoes, ( -- ) T :doesjump A, 0 , H ;
1.1 anton 227:
228: \ Ghost Builder 06oct92py
229:
230: \ <T T> new version with temp variable 10may93jaw
231:
232: VARIABLE VocTemp
233:
234: : <T get-current VocTemp ! also Ghosts definitions ;
235: : T> previous VocTemp @ set-current ;
236:
237: 4711 Constant <fwd> 4712 Constant <res>
238: 4713 Constant <imm>
239:
240: \ iForth makes only immediate directly after create
241: \ make atonce trick! ?
242:
243: Variable atonce atonce off
244:
245: : NoExec true ABORT" CROSS: Don't execute ghost" ;
246:
247: : GhostHeader <fwd> , 0 , ['] NoExec , ;
248:
249: : >magic ; : >link cell+ ; : >exec cell+ cell+ ;
250: : >end 3 cells + ;
251:
1.11 pazsan 252: Variable last-ghost
1.1 anton 253: : Make-Ghost ( "name" -- ghost )
254: >in @ GhostName swap >in !
255: <T Create atonce @ IF immediate atonce off THEN
256: here tuck swap ! ghostheader T>
1.11 pazsan 257: DOES> dup last-ghost ! >exec @ execute ;
1.1 anton 258:
259: \ ghost words 14oct92py
260: \ changed: 10may93py/jaw
261:
262: : gfind ( string -- ghost true/1 / string false )
263: \ searches for string in word-list ghosts
264: \ !! wouldn't it be simpler to just use search-wordlist ? ae
1.5 pazsan 265: dup count [ ' ghosts >body ] ALiteral search-wordlist
1.13 pazsan 266: dup IF >r >body nip r> THEN ;
1.1 anton 267:
268: VARIABLE Already
269:
270: : ghost ( "name" -- ghost )
271: Already off
1.13 pazsan 272: >in @ bl word gfind IF Already on nip EXIT THEN
1.1 anton 273: drop >in ! Make-Ghost ;
274:
275: \ resolve 14oct92py
276:
277: : resolve-loop ( ghost tcfa -- ghost tcfa )
278: >r dup >link @
279: BEGIN dup WHILE dup T @ H r@ rot T ! H REPEAT drop r> ;
280:
281: \ exists 9may93jaw
282:
283: : exists ( ghost tcfa -- )
284: over GhostNames
285: BEGIN @ dup
286: WHILE 2dup cell+ @ =
287: UNTIL
1.18 pazsan 288: 2 cells + count cr ." CROSS: Exists: " type 4 spaces drop
1.1 anton 289: swap cell+ !
290: ELSE true ABORT" CROSS: Ghostnames inconsistent"
291: THEN ;
292:
293: : resolve ( ghost tcfa -- )
294: over >magic @ <fwd> <> IF exists EXIT THEN
295: resolve-loop over >link ! <res> swap >magic ! ;
296:
297: \ gexecute ghost, 01nov92py
298:
299: : do-forward ( ghost -- )
300: >link dup @ there rot ! T A, H ;
301: : do-resolve ( ghost -- )
302: >link @ T A, H ;
303:
304: : gexecute ( ghost -- ) dup @
305: <fwd> = IF do-forward ELSE do-resolve THEN ;
306: : ghost, ghost gexecute ;
307:
308: \ .unresolved 11may93jaw
309:
310: variable ResolveFlag
311:
312: \ ?touched 11may93jaw
313:
314: : ?touched ( ghost -- flag ) dup >magic @ <fwd> = swap >link @
315: 0 <> and ;
316:
317: : ?resolved ( ghostname -- )
318: dup cell+ @ ?touched
319: IF cell+ cell+ count cr type ResolveFlag on ELSE drop THEN ;
320:
321: >MINIMAL
322: : .unresolved ( -- )
323: ResolveFlag off cr ." Unresolved: "
324: Ghostnames
325: BEGIN @ dup
326: WHILE dup ?resolved
1.10 anton 327: REPEAT drop ResolveFlag @
328: IF
1.11 pazsan 329: abort" Unresolved words!"
1.10 anton 330: ELSE
331: ." Nothing!"
332: THEN
333: cr ;
1.1 anton 334:
335: >CROSS
336: \ Header states 12dec92py
337:
338: : flag! ( 8b -- ) tlast @ dup >r T c@ xor r> c! H ;
339:
340: VARIABLE ^imm
341:
342: >TARGET
343: : immediate 20 flag!
1.18 pazsan 344: ^imm @ @ dup <imm> = IF drop EXIT THEN
1.1 anton 345: <res> <> ABORT" CROSS: Cannot immediate a unresolved word"
346: <imm> ^imm @ ! ;
1.8 pazsan 347: : restrict 40 flag! ;
1.1 anton 348: >CROSS
349:
350: \ ALIAS2 ansforth conform alias 9may93jaw
351:
352: : ALIAS2 create here 0 , DOES> @ execute ;
353: \ usage:
1.18 pazsan 354: \ ' <name> alias2 bla !
1.1 anton 355:
356: \ Target Header Creation 01nov92py
357:
358: : string, ( addr count -- )
359: dup T c, H bounds DO I c@ T c, H LOOP ;
1.22 anton 360: : name, ( "name" -- ) bl word count string, T cfalign H ;
1.1 anton 361: : view, ( -- ) ( dummy ) ;
362:
363: VARIABLE CreateFlag CreateFlag off
364:
365: : (Theader ( "name" -- ghost ) T align H view,
366: tlast @ dup 0> IF T 1 cells - THEN A, H there tlast !
367: >in @ name, >in ! T here H tlastcfa !
368: CreateFlag @ IF
1.18 pazsan 369: >in @ alias2 swap >in ! \ create alias in target
370: >in @ ghost swap >in !
371: swap also ghosts ' previous swap ! \ tick ghost and store in alias
372: CreateFlag off
1.1 anton 373: ELSE ghost THEN
374: dup >magic ^imm ! \ a pointer for immediate
375: Already @ IF dup >end tdoes !
376: ELSE 0 tdoes ! THEN
377: 80 flag! ;
378:
379: VARIABLE ;Resolve 1 cells allot
380:
1.11 pazsan 381: : Theader ( "name" -- ghost )
382: (THeader dup there resolve 0 ;Resolve ! ;
1.1 anton 383:
384: >TARGET
385: : Alias ( cfa -- ) \ name
386: (THeader over resolve T A, H 80 flag! ;
387: >CROSS
388:
389: \ Conditionals and Comments 11may93jaw
390:
391: : ;Cond
392: postpone ;
393: swap ! ; immediate
394:
395: : Cond: ( -- ) \ name {code } ;
396: atonce on
397: ghost
398: >exec
399: :NONAME ;
400:
401: : restrict? ( -- )
402: \ aborts on interprete state - ae
403: state @ 0= ABORT" CROSS: Restricted" ;
404:
405: : Comment ( -- )
406: >in @ atonce on ghost swap >in ! ' swap >exec ! ;
407:
408: Comment ( Comment \
409:
410: \ Predefined ghosts 12dec92py
411:
412: ghost 0= drop
413: ghost branch ghost ?branch 2drop
414: ghost (do) ghost (?do) 2drop
415: ghost (for) drop
416: ghost (loop) ghost (+loop) 2drop
417: ghost (next) drop
1.2 pazsan 418: ghost unloop ghost ;S 2drop
1.1 anton 419: ghost lit ghost (compile) ghost ! 2drop drop
420: ghost (;code) ghost noop 2drop
421: ghost (.") ghost (S") ghost (ABORT") 2drop drop
1.9 pazsan 422: ghost '
1.1 anton 423:
424: \ compile 10may93jaw
425:
426: : compile ( -- ) \ name
427: restrict?
1.13 pazsan 428: bl word gfind dup 0= ABORT" CROSS: Can't compile "
1.1 anton 429: 0> ( immediate? )
430: IF >exec @ compile,
431: ELSE postpone literal postpone gexecute THEN ;
432: immediate
433:
434: >TARGET
1.13 pazsan 435: : ' ( -- cfa ) bl word gfind 0= ABORT" CROSS: undefined "
1.1 anton 436: dup >magic @ <fwd> = ABORT" CROSS: forward " >link @ ;
437:
438: Cond: ['] compile lit ghost gexecute ;Cond
1.14 anton 439:
440: Cond: chars ;Cond
1.1 anton 441:
442: >CROSS
443: \ tLiteral 12dec92py
444:
445: : lit, ( n -- ) compile lit T , H ;
446: : alit, ( n -- ) compile lit T A, H ;
447:
448: >TARGET
449: Cond: Literal ( n -- ) restrict? lit, ;Cond
450: Cond: ALiteral ( n -- ) restrict? alit, ;Cond
451:
452: : Char ( "<char>" -- ) bl word char+ c@ ;
453: Cond: [Char] ( "<char>" -- ) restrict? Char lit, ;Cond
454:
455: >CROSS
456: \ Target compiling loop 12dec92py
457: \ ">tib trick thrown out 10may93jaw
458: \ number? defined at the top 11may93jaw
459:
460: \ compiled word might leave items on stack!
461: : tcom ( in name -- )
462: gfind ?dup IF 0> IF nip >exec @ execute
463: ELSE nip gexecute THEN EXIT THEN
464: number? dup IF 0> IF swap lit, THEN lit, drop
465: ELSE 2drop >in !
466: ghost gexecute THEN ;
467:
468: >TARGET
469: \ : ; DOES> 13dec92py
470: \ ] 9may93py/jaw
471:
472: : ] state on
473: BEGIN
1.13 pazsan 474: BEGIN >in @ bl word
1.1 anton 475: dup c@ 0= WHILE 2drop refill 0=
476: ABORT" CROSS: End of file while target compiling"
477: REPEAT
478: tcom
479: state @
480: 0=
481: UNTIL ;
482:
483: \ by the way: defining a second interpreter (a compiler-)loop
484: \ is not allowed if a system should be ans conform
485:
486: : : ( -- colon-sys ) \ Name
487: (THeader ;Resolve ! there ;Resolve cell+ !
488: docol, depth T ] H ;
489:
1.2 pazsan 490: Cond: EXIT ( -- ) restrict? compile ;S ;Cond
1.6 anton 491:
492: Cond: ?EXIT ( -- ) 1 abort" CROSS: using ?exit" ;Cond
1.2 pazsan 493:
1.1 anton 494: Cond: ; ( -- ) restrict?
495: depth ?dup IF 1- <> ABORT" CROSS: Stack changed"
496: ELSE true ABORT" CROSS: Stack empty" THEN
1.2 pazsan 497: compile ;S state off
1.1 anton 498: ;Resolve @
499: IF ;Resolve @ ;Resolve cell+ @ resolve THEN
500: ;Cond
501: Cond: [ restrict? state off ;Cond
502:
503: >CROSS
504: : !does :dodoes tlastcfa @ tuck T ! cell+ ! H ;
505:
506: >TARGET
507: Cond: DOES> restrict?
508: compile (;code) dodoes, tdoes @ ?dup IF @ T here H resolve THEN
509: ;Cond
510: : DOES> dodoes, T here H !does depth T ] H ;
511:
512: >CROSS
513: \ Creation 01nov92py
514:
515: \ Builder 11may93jaw
516:
517: : Builder ( Create do: "name" -- )
518: >in @ alias2 swap dup >in ! >r >r
519: Make-Ghost rot swap >exec ! ,
520: r> r> >in !
1.11 pazsan 521: also ghosts ' previous swap ! ;
522: \ DOES> dup >exec @ execute ;
1.1 anton 523:
524: : gdoes, ( ghost -- ) >end @ dup >magic @ <fwd> <>
525: IF dup >link @ dup 0< IF T A, 0 , H drop EXIT THEN drop THEN
1.4 pazsan 526: :dodoes T A, H gexecute T here H cell - reloff ;
1.1 anton 527:
1.11 pazsan 528: : TCreate ( -- )
529: last-ghost @
1.1 anton 530: CreateFlag on
1.11 pazsan 531: Theader >r dup gdoes,
532: >end @ >exec @ r> >exec ! ;
1.1 anton 533:
534: : Build: ( -- [xt] [colon-sys] )
535: :noname postpone TCreate ;
536:
537: : gdoes> ( ghost -- addr flag )
1.11 pazsan 538: last-ghost @
1.1 anton 539: state @ IF gexecute true EXIT THEN
540: cell+ @ T >body H false ;
541:
542: \ DO: ;DO 11may93jaw
543: \ changed to ?EXIT 10may93jaw
544:
545: : DO: ( -- addr [xt] [colon-sys] )
546: here ghostheader
1.11 pazsan 547: :noname postpone gdoes> postpone ?EXIT ;
1.1 anton 548:
549: : ;DO ( addr [xt] [colon-sys] -- )
550: postpone ; ( S addr xt )
551: over >exec ! ; immediate
552:
553: : by ( -- addr ) \ Name
554: ghost >end @ ;
555:
556: >TARGET
557: \ Variables and Constants 05dec92py
558:
559: Build: ;
560: DO: ( ghost -- addr ) ;DO
561: Builder Create
562: by Create :dovar resolve
563:
564: Build: T 0 , H ;
565: by Create
566: Builder Variable
567:
568: Build: T 0 A, H ;
569: by Create
570: Builder AVariable
571:
1.3 pazsan 572: \ User variables 04may94py
573:
574: >CROSS
575: Variable tup 0 tup !
576: Variable tudp 0 tudp !
577: : u, ( n -- udp )
578: tup @ tudp @ + T ! H
1.19 pazsan 579: tudp @ dup T cell+ H tudp ! ;
1.3 pazsan 580: : au, ( n -- udp )
581: tup @ tudp @ + T A! H
1.19 pazsan 582: tudp @ dup T cell+ H tudp ! ;
1.3 pazsan 583: >TARGET
584:
585: Build: T 0 u, , H ;
586: DO: ( ghost -- up-addr ) T @ H tup @ + ;DO
1.1 anton 587: Builder User
1.3 pazsan 588: by User :douser resolve
1.1 anton 589:
1.3 pazsan 590: Build: T 0 u, , 0 u, drop H ;
591: by User
1.1 anton 592: Builder 2User
593:
1.3 pazsan 594: Build: T 0 au, , H ;
595: by User
1.1 anton 596: Builder AUser
597:
598: Build: ( n -- ) T , H ;
599: DO: ( ghost -- n ) T @ H ;DO
600: Builder Constant
601: by Constant :docon resolve
602:
603: Build: ( n -- ) T A, H ;
604: by Constant
605: Builder AConstant
606:
607: Build: T 0 , H ;
608: by Constant
609: Builder Value
610:
611: Build: ( -- ) compile noop ;
612: DO: ( ghost -- ) ABORT" CROSS: Don't execute" ;DO
613: Builder Defer
1.10 anton 614: by Defer :dodefer resolve
1.1 anton 615:
616: \ structural conditionals 17dec92py
617:
618: >CROSS
619: : ?struc ( flag -- ) ABORT" CROSS: unstructured " ;
620: : sys? ( sys -- sys ) dup 0= ?struc ;
621: : >mark ( -- sys ) T here 0 , H ;
622: : >resolve ( sys -- ) T here over - swap ! H ;
623: : <resolve ( sys -- ) T here - , H ;
624: >TARGET
625:
626: \ Structural Conditionals 12dec92py
627:
628: Cond: BUT restrict? sys? swap ;Cond
629: Cond: YET restrict? sys? dup ;Cond
630:
631: >CROSS
632: Variable tleavings
633: >TARGET
634:
635: Cond: DONE ( addr -- ) restrict? tleavings @
636: BEGIN 2dup u> 0= WHILE dup T @ H swap >resolve REPEAT
637: tleavings ! drop ;Cond
638:
639: >CROSS
640: : (leave T here H tleavings @ T , H tleavings ! ;
641: >TARGET
642:
643: Cond: LEAVE restrict? compile branch (leave ;Cond
644: Cond: ?LEAVE restrict? compile 0= compile ?branch (leave ;Cond
645:
646: \ Structural Conditionals 12dec92py
647:
648: Cond: AHEAD restrict? compile branch >mark ;Cond
649: Cond: IF restrict? compile ?branch >mark ;Cond
650: Cond: THEN restrict? sys? dup T @ H ?struc >resolve ;Cond
651: Cond: ELSE restrict? sys? compile AHEAD swap compile THEN ;Cond
652:
653: Cond: BEGIN restrict? T here H ;Cond
654: Cond: WHILE restrict? sys? compile IF swap ;Cond
655: Cond: AGAIN restrict? sys? compile branch <resolve ;Cond
656: Cond: UNTIL restrict? sys? compile ?branch <resolve ;Cond
657: Cond: REPEAT restrict? over 0= ?struc compile AGAIN compile THEN ;Cond
658:
659: \ Structural Conditionals 12dec92py
660:
661: Cond: DO restrict? compile (do) T here H ;Cond
662: Cond: ?DO restrict? compile (?do) (leave T here H ;Cond
663: Cond: FOR restrict? compile (for) T here H ;Cond
664:
665: >CROSS
666: : loop] dup <resolve cell - compile DONE compile unloop ;
667: >TARGET
668:
669: Cond: LOOP restrict? sys? compile (loop) loop] ;Cond
670: Cond: +LOOP restrict? sys? compile (+loop) loop] ;Cond
671: Cond: NEXT restrict? sys? compile (next) loop] ;Cond
672:
673: \ String words 23feb93py
674:
675: : ," [char] " parse string, T align H ;
676:
677: Cond: ." restrict? compile (.") T ," H ;Cond
678: Cond: S" restrict? compile (S") T ," H ;Cond
679: Cond: ABORT" restrict? compile (ABORT") T ," H ;Cond
680:
681: Cond: IS T ' >body H compile ALiteral compile ! ;Cond
682: : IS T ' >body ! H ;
1.9 pazsan 683: Cond: TO T ' >body H compile ALiteral compile ! ;Cond
684: : TO T ' >body ! H ;
1.1 anton 685:
686: \ LINKED ERR" ENV" 2ENV" 18may93jaw
687:
688: \ linked list primitive
689: : linked T here over @ A, swap ! H ;
690:
691: : err" s" ErrLink linked" evaluate T , H
692: [char] " parse string, T align H ;
693:
694: : env" [char] " parse s" EnvLink linked" evaluate
695: string, T align , H ;
696:
697: : 2env" [char] " parse s" EnvLink linked" evaluate
698: here >r string, T align , , H
699: r> dup T c@ H 80 and swap T c! H ;
700:
701: \ compile must be last 22feb93py
702:
703: Cond: compile ( -- ) restrict? \ name
1.13 pazsan 704: bl word gfind dup 0= ABORT" CROSS: Can't compile"
1.1 anton 705: 0> IF gexecute
706: ELSE dup >magic @ <imm> =
707: IF gexecute
708: ELSE compile (compile) gexecute THEN THEN ;Cond
709:
710: Cond: postpone ( -- ) restrict? \ name
1.13 pazsan 711: bl word gfind dup 0= ABORT" CROSS: Can't compile"
1.1 anton 712: 0> IF gexecute
713: ELSE dup >magic @ <imm> =
714: IF gexecute
715: ELSE compile (compile) gexecute THEN THEN ;Cond
716:
717: >MINIMAL
718: also minimal
719: \ Usefull words 13feb93py
720:
721: : KB 400 * ;
722:
723: \ define new [IFDEF] and [IFUNDEF] 20may93jaw
724:
1.13 pazsan 725: : there? bl word gfind IF >magic @ <fwd> <> ELSE drop false THEN ;
1.1 anton 726:
727: : [IFDEF] there? postpone [IF] ;
728: : [IFUNDEF] there? 0= postpone [IF] ;
729:
730: \ C: \- \+ Conditional Compiling 09jun93jaw
731:
732: : C: >in @ there? 0=
733: IF >in ! T : H
734: ELSE drop
735: BEGIN bl word dup c@
736: IF count comment? s" ;" compare 0= ?EXIT
737: ELSE refill 0= ABORT" CROSS: Out of Input while C:"
738: THEN
739: AGAIN
740: THEN ;
741:
742: also minimal
743:
744: : \- there? IF postpone \ THEN ;
745: : \+ there? 0= IF postpone \ THEN ;
746:
747: : [IF] postpone [IF] ;
748: : [THEN] postpone [THEN] ;
749: : [ELSE] postpone [ELSE] ;
750:
751: Cond: [IF] [IF] ;Cond
752: Cond: [IFDEF] [IFDEF] ;Cond
753: Cond: [IFUNDEF] [IFUNDEF] ;Cond
754: Cond: [THEN] [THEN] ;Cond
755: Cond: [ELSE] [ELSE] ;Cond
756:
757: \ save-cross 17mar93py
758:
759: \ i'm not interested in bigforth features this time 10may93jaw
760: \ [IFDEF] file
761: \ also file
762: \ [THEN]
763: \ included throw after create-file 11may93jaw
764:
1.12 anton 765: bigendian Constant bigendian
1.1 anton 766:
767: : save-cross ( "name" -- )
768: bl parse ." Saving to " 2dup type
769: w/o bin create-file throw >r
1.16 pazsan 770: s" gforth00" r@ write-file throw \ write magic
771: image @ there r@ write-file throw \ write image
772: bit$ @ there 1- cell>bit rshift 1+
773: r@ write-file throw \ write tags
1.1 anton 774: r> close-file throw ;
775:
776: \ words that should be in minimal
777:
778: : + + ; : 1- 1- ;
779: : - - ; : 2* 2* ;
1.11 pazsan 780: : * * ; : / / ;
1.1 anton 781: : dup dup ; : over over ;
782: : swap swap ; : rot rot ;
1.19 pazsan 783: : drop drop ; : = = ;
1.13 pazsan 784: : lshift lshift ; : 2/ 2/ ;
1.19 pazsan 785: : . . ;
1.13 pazsan 786: cell constant cell
1.1 anton 787:
788: \ include bug5.fs
789: \ only forth also minimal definitions
790:
791: : \ postpone \ ;
792: : ( postpone ( ;
793: : include bl word count included ;
794: : .( [char] ) parse type ;
795: : cr cr ;
796:
797: : times 0 ?DO dup T c, H LOOP drop ; \ used for space table creation
798: only forth also minimal definitions
799:
800: \ cross-compiler words
801:
802: : decimal decimal ;
803: : hex hex ;
804:
1.3 pazsan 805: : tudp T tudp H ;
806: : tup T tup H ; minimal
1.1 anton 807:
808: \ for debugging...
809: : order order ;
810: : words words ;
811: : .s .s ;
812:
813: : bye bye ;
814:
815: \ turnkey direction
816: : H forth ; immediate
817: : T minimal ; immediate
818: : G ghosts ; immediate
819:
820: : turnkey 0 set-order also Target definitions
821: also Minimal also ;
822:
823: \ these ones are pefered:
824:
825: : lock turnkey ;
826: : unlock forth also cross ;
827:
828: unlock definitions also minimal
829: : lock lock ;
830: lock
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>