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