File:
[gforth] /
gforth /
cross.fs
Revision
1.58:
download - view:
text,
annotated -
select for diffs
Tue Dec 8 22:02:38 1998 UTC (25 years, 4 months ago) by
anton
Branches:
MAIN
CVS tags:
HEAD
updated dates in copyright messages
inserted copyright messages in most files that did not have them
removed outdated files engine/32bit.h engine/strsig.c
1: \ CROSS.FS The Cross-Compiler 06oct92py
2: \ Idea and implementation: Bernd Paysan (py)
3:
4: \ Copyright (C) 1995,1996,1997,1998 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: \ romable extansions 27apr97-5jun97jaw
44: \ environmental query support 01sep97jaw
45: \ added own [IF] ... [ELSE] ... [THEN] 14sep97jaw
46: \ extra resolver for doers 20sep97jaw
47: \ added killref for DOES> 20sep97jaw
48:
49:
50: hex \ the defualt base for the cross-compiler is hex !!
51: Warnings off
52:
53: \ words that are generaly useful
54:
55: : >wordlist ( vocabulary-xt -- wordlist-struct )
56: also execute get-order swap >r 1- set-order r> ;
57:
58: : umax 2dup u< IF swap THEN drop ;
59: : umin 2dup u> IF swap THEN drop ;
60:
61: : string, ( c-addr u -- )
62: \ puts down string as cstring
63: dup c, here swap chars dup allot move ;
64:
65: : SetValue ( n -- <name> )
66: \G Same behaviour as "Value" if the <name> is not defined
67: \G Same behaviour as "to" if <name> is defined
68: \G SetValue searches in the current vocabulary
69: save-input bl word >r restore-input throw r> count
70: get-current search-wordlist
71: IF ['] to execute ELSE Value THEN ;
72:
73: : DefaultValue ( n -- <name> )
74: \G Same behaviour as "Value" if the <name> is not defined
75: \G DefaultValue searches in the current vocabulary
76: save-input bl word >r restore-input throw r> count
77: get-current search-wordlist
78: IF bl word drop 2drop ELSE Value THEN ;
79:
80: hex
81:
82: Vocabulary Cross
83: Vocabulary Target
84: Vocabulary Ghosts
85: VOCABULARY Minimal
86: only Forth also Target also also
87: definitions Forth
88:
89: : T previous Cross also Target ; immediate
90: : G Ghosts ; immediate
91: : H previous Forth also Cross ; immediate
92:
93: forth definitions
94:
95: : T previous Cross also Target ; immediate
96: : G Ghosts ; immediate
97:
98: : >cross also Cross definitions previous ;
99: : >target also Target definitions previous ;
100: : >minimal also Minimal definitions previous ;
101:
102: H
103:
104: >CROSS
105:
106: \ 1 Constant Cross-Flag \ to check whether assembler compiler plug-ins are
107: \ for cross-compiling
108: \ No! we use "[IFUNDEF]" there to find out whether we are target compiling!!!
109:
110: : comment? ( c-addr u -- c-addr u )
111: 2dup s" (" compare 0=
112: IF postpone (
113: ELSE 2dup s" \" compare 0= IF postpone \ THEN
114: THEN ;
115:
116: \ Begin CROSS COMPILER:
117:
118:
119:
120: \ \ -------------------- Error Handling 05aug97jaw
121:
122: \ Flags
123:
124: also forth definitions \ these values may be predefined before
125: \ the cross-compiler is loaded
126:
127: false DefaultValue stack-warn \ check on empty stack at any definition
128: false DefaultValue create-forward-warn \ warn on forward declaration of created words
129:
130: [IFUNDEF] DebugMaskSrouce Variable DebugMaskSource 0 DebugMaskSource ! [THEN]
131: [IFUNDEF] DebugMaskCross Variable DebugMaskCross 0 DebugMaskCross ! [THEN]
132:
133: previous >CROSS
134:
135: : .dec
136: base @ decimal swap . base ! ;
137:
138: : .sourcepos
139: cr sourcefilename type ." :"
140: sourceline# .dec ;
141:
142: : warnhead
143: \G display error-message head
144: \G perhaps with linenumber and filename
145: .sourcepos ." Warning: " ;
146:
147: : empty? depth IF .sourcepos ." Stack not empty!" THEN ;
148:
149: stack-warn [IF]
150: : defempty? empty? ;
151: [ELSE]
152: : defempty? ; immediate
153: [THEN]
154:
155:
156:
157: \ \ GhostNames Ghosts 9may93jaw
158:
159: \ second name source to search trough list
160:
161: VARIABLE GhostNames
162: 0 GhostNames !
163:
164: : GhostName ( -- addr )
165: here GhostNames @ , GhostNames ! here 0 ,
166: bl word count
167: \ 2dup type space
168: string, \ !! cfalign ?
169: align ;
170:
171: \ Ghost Builder 06oct92py
172:
173: \ <T T> new version with temp variable 10may93jaw
174:
175: VARIABLE VocTemp
176:
177: : <T get-current VocTemp ! also Ghosts definitions ;
178: : T> previous VocTemp @ set-current ;
179:
180: hex
181: 4711 Constant <fwd> 4712 Constant <res>
182: 4713 Constant <imm> 4714 Constant <do:>
183:
184: \ iForth makes only immediate directly after create
185: \ make atonce trick! ?
186:
187: Variable atonce atonce off
188:
189: : NoExec true ABORT" CROSS: Don't execute ghost" ;
190:
191: : GhostHeader <fwd> , 0 , ['] NoExec , ;
192:
193: : >magic ; \ type of ghost
194: : >link cell+ ; \ pointer where ghost is in target, or if unresolved
195: \ points to the where we have to resolve (linked-list)
196: : >exec cell+ cell+ ; \ execution symantics (while target compiling) of ghost
197: : >end 3 cells + ; \ room for additional tags
198: \ for builder (create, variable...) words the
199: \ execution symantics of words built are placed here
200:
201: Variable executed-ghost \ last executed ghost, needed in tcreate and gdoes>
202: Variable last-ghost \ last ghost that is created
203: Variable last-header-ghost \ last ghost definitions with header
204:
205: : Make-Ghost ( "name" -- ghost )
206: >in @ GhostName swap >in !
207: <T Create atonce @ IF immediate atonce off THEN
208: here tuck swap ! ghostheader T>
209: dup last-ghost !
210: DOES> dup executed-ghost ! >exec @ execute ;
211:
212: \ ghost words 14oct92py
213: \ changed: 10may93py/jaw
214:
215: : gfind ( string -- ghost true/1 / string false )
216: \ searches for string in word-list ghosts
217: dup count [ ' ghosts >wordlist ] ALiteral search-wordlist
218: dup IF >r >body nip r> THEN ;
219:
220: : gdiscover ( xt -- ghost true | xt false )
221: GhostNames
222: BEGIN @ dup
223: WHILE 2dup
224: cell+ @ dup >magic @ <fwd> <>
225: >r >link @ = r> and
226: IF cell+ @ nip true EXIT THEN
227: REPEAT
228: drop false ;
229:
230: VARIABLE Already
231:
232: : ghost ( "name" -- ghost )
233: Already off
234: >in @ bl word gfind IF Already on nip EXIT THEN
235: drop >in ! Make-Ghost ;
236:
237: : >ghostname ( ghost -- adr len )
238: GhostNames
239: BEGIN @ dup
240: WHILE 2dup cell+ @ =
241: UNTIL nip 2 cells + count
242: ELSE 2drop
243: \ true abort" CROSS: Ghostnames inconsistent"
244: s" ?!?!?!"
245: THEN ;
246:
247: ' >ghostname ALIAS @name
248:
249: : forward? ( ghost -- flag )
250: >magic @ <fwd> = ;
251:
252: \ Predefined ghosts 12dec92py
253:
254: ghost 0= drop
255: ghost branch ghost ?branch 2drop
256: ghost (do) ghost (?do) 2drop
257: ghost (for) drop
258: ghost (loop) ghost (+loop) 2drop
259: ghost (next) drop
260: ghost unloop ghost ;S 2drop
261: ghost lit ghost (compile) ghost ! 2drop drop
262: ghost (does>) ghost noop 2drop
263: ghost (.") ghost (S") ghost (ABORT") 2drop drop
264: ghost ' drop
265: ghost :docol ghost :doesjump ghost :dodoes 2drop drop
266: ghost :dovar drop
267: ghost over ghost = ghost drop 2drop drop
268: ghost - drop
269: ghost 2drop drop
270: ghost 2dup drop
271:
272: \ \ Parameter for target systems 06oct92py
273:
274: \ we define it ans like...
275: wordlist Constant target-environment
276:
277: VARIABLE env-current \ save information of current dictionary to restore with environ>
278:
279: : >ENVIRON get-current env-current ! target-environment set-current ;
280: : ENVIRON> env-current @ set-current ;
281:
282: >TARGET
283:
284: : environment?
285: target-environment search-wordlist
286: IF execute true ELSE false THEN ;
287:
288: : e? name T environment? H 0= ABORT" environment variable not defined!" ;
289:
290: : has? name T environment? H
291: IF \ environment variable is present, return its value
292: ELSE \ environment variable is not present, return false
293: \ !! JAW abort is just for testing
294: false true ABORT" arg"
295: THEN ;
296:
297: : $has? T environment? H IF ELSE false THEN ;
298:
299: >ENVIRON get-order get-current swap 1+ set-order
300: true SetValue compiler
301: true SetValue cross
302: true SetValue standard-threading
303: >TARGET previous
304:
305: mach-file count included hex
306:
307: >ENVIRON
308:
309: T has? ec H
310: [IF]
311: false DefaultValue relocate
312: false DefaultValue file
313: false DefaultValue OS
314: false DefaultValue prims
315: false DefaultValue floating
316: false DefaultValue glocals
317: false DefaultValue dcomps
318: false DefaultValue hash
319: false DefaultValue xconds
320: false DefaultValue header
321: [THEN]
322:
323: true DefaultValue interpreter
324: true DefaultValue ITC
325: false DefaultValue rom
326:
327: >TARGET
328: s" relocate" T environment? H
329: [IF] SetValue NIL
330: [ELSE] >ENVIRON T NIL H SetValue relocate
331: [THEN]
332:
333: >CROSS
334:
335: \ \ Create additional parameters 19jan95py
336:
337: 1 8 lshift Constant maxbyte
338: T
339: NIL Constant TNIL
340: cell Constant tcell
341: cell<< Constant tcell<<
342: cell>bit Constant tcell>bit
343: bits/byte Constant tbits/byte
344: bits/byte 8 / Constant tchar
345: float Constant tfloat
346: 1 bits/byte lshift Constant tmaxbyte
347: H
348:
349: \ Variables 06oct92py
350:
351: Variable image
352: Variable tlast TNIL tlast ! \ Last name field
353: Variable tlastcfa \ Last code field
354: Variable tdoes \ Resolve does> calls
355: Variable bit$
356:
357: \ statistics 10jun97jaw
358:
359: Variable headers-named 0 headers-named !
360: Variable user-vars 0 user-vars !
361:
362: \ Memory initialisation 05dec92py
363:
364: [IFDEF] Memory \ Memory is a bigFORTH feature
365: also Memory
366: : initmem ( var len -- )
367: 2dup swap handle! >r @ r> erase ;
368: toss
369: [ELSE]
370: : initmem ( var len -- )
371: tuck allocate abort" CROSS: No memory for target"
372: ( len var adr ) dup rot !
373: ( len adr ) swap erase ;
374: [THEN]
375:
376: \ MakeKernal 12dec92py
377:
378: : makekernel ( targetsize -- targetsize )
379: bit$ over 1- tcell>bit rshift 1+ initmem
380: image over initmem ;
381:
382: >MINIMAL
383: : makekernel makekernel ;
384:
385:
386: >CROSS
387:
388: \ \ memregion.fs
389:
390:
391: Variable last-defined-region \ pointer to last defined region
392: Variable region-link \ linked list with all regions
393: Variable mirrored-link \ linked list for mirrored regions
394: 0 dup mirrored-link ! region-link !
395:
396:
397: : >rdp 2 cells + ;
398: : >rlen cell+ ;
399: : >rstart ;
400:
401:
402: : region ( addr len -- ) \G create a new region
403: \ check whether predefined region exists
404: save-input bl word find >r >r restore-input throw r> r> 0=
405: IF \ make region
406: drop
407: save-input create restore-input throw
408: here last-defined-region !
409: over ( startaddr ) , ( length ) , ( dp ) ,
410: region-link linked name string,
411: ELSE \ store new parameters in region
412: bl word drop
413: >body >r r@ last-defined-region !
414: r@ cell+ ! dup r@ ! r> 2 cells + !
415: THEN ;
416:
417: : borders ( region -- startaddr endaddr ) \G returns lower and upper region border
418: dup @ swap cell+ @ over + ;
419:
420: : extent ( region -- startaddr len ) \G returns the really used area
421: dup @ swap 2 cells + @ over - ;
422:
423: : area ( region -- startaddr totallen ) \G returns the total area
424: dup @ swap cell+ @ ;
425:
426: : mirrored \G mark a region as mirrored
427: mirrored-link
428: linked last-defined-region @ , ;
429:
430: : .addr
431: base @ >r hex
432: tcell 2 u>
433: IF s>d <# # # # # '. hold # # # # #> type
434: ELSE s>d <# # # # # # #> type
435: THEN r> base ! ;
436:
437: : .regions \G display region statistic
438:
439: \ we want to list the regions in the right order
440: \ so first collect all regions on stack
441: 0 region-link @
442: BEGIN dup WHILE dup @ REPEAT drop
443: BEGIN dup
444: WHILE cr 3 cells - >r
445: r@ 4 cells + count tuck type
446: 12 swap - 0 max spaces space
447: ." Start: " r@ @ dup .addr space
448: ." End: " r@ 1 cells + @ + .addr space
449: ." DP: " r> 2 cells + @ .addr
450: REPEAT drop
451: s" rom" T $has? H 0= ?EXIT
452: cr ." Mirrored:"
453: mirrored-link @
454: BEGIN dup
455: WHILE space dup cell+ @ 4 cells + count type @
456: REPEAT drop cr
457: ;
458:
459: \ -------- predefined regions
460:
461: 0 0 region address-space
462: \ total memory addressed and used by the target system
463:
464: 0 0 region dictionary
465: \ rom area for the compiler
466:
467: T has? rom H
468: [IF]
469: 0 0 region ram-dictionary mirrored
470: \ ram area for the compiler
471: [ELSE]
472: ' dictionary ALIAS ram-dictionary
473: [THEN]
474:
475: 0 0 region return-stack
476:
477: 0 0 region data-stack
478:
479: 0 0 region tib-region
480:
481: ' dictionary ALIAS rom-dictionary
482:
483:
484: : setup-target ( -- ) \G initialize targets memory space
485: s" rom" T $has? H
486: IF \ check for ram and rom...
487: address-space area nip
488: ram-dictionary area nip
489: rom-dictionary area nip
490: and and 0=
491: ABORT" CROSS: define address-space, rom- , ram-dictionary, with rom-support!"
492: THEN
493: address-space area nip
494: IF
495: address-space area
496: ELSE
497: dictionary area
498: THEN
499: dup 0=
500: ABORT" CROSS: define at least address-space or dictionary!!"
501: + makekernel drop ;
502:
503: \ \ switched tdp for rom support 03jun97jaw
504:
505: \ second value is here to store some maximal value for statistics
506: \ tempdp is also embedded here but has nothing to do with rom support
507: \ (needs switched dp)
508:
509: variable tempdp 0 , \ temporary dp for resolving
510: variable tempdp-save
511:
512: 0 [IF]
513: variable romdp 0 , \ Dictionary-Pointer for ramarea
514: variable ramdp 0 , \ Dictionary-Pointer for romarea
515:
516: \
517: variable sramdp \ start of ram-area for forth
518: variable sromdp \ start of rom-area for forth
519:
520: [THEN]
521:
522:
523: 0 value tdp
524: variable fixed \ flag: true: no automatic switching
525: \ false: switching is done automatically
526:
527: \ Switch-Policy:
528: \
529: \ a header is always compiled into rom
530: \ after a created word (create and variable) compilation goes to ram
531: \
532: \ Be careful: If you want to make the data behind create into rom
533: \ you have to put >rom before create!
534:
535: variable constflag constflag off
536:
537: : (switchram)
538: fixed @ ?EXIT s" rom" T $has? H 0= ?EXIT
539: ram-dictionary >rdp to tdp ;
540:
541: : switchram
542: constflag @
543: IF constflag off ELSE (switchram) THEN ;
544:
545: : switchrom
546: fixed @ ?EXIT rom-dictionary >rdp to tdp ;
547:
548: : >tempdp ( addr -- )
549: tdp tempdp-save ! tempdp to tdp tdp ! ;
550: : tempdp> ( -- )
551: tempdp-save @ to tdp ;
552:
553: : >ram fixed off (switchram) fixed on ;
554: : >rom fixed off switchrom fixed on ;
555: : >auto fixed off switchrom ;
556:
557:
558:
559: \ : romstart dup sromdp ! romdp ! ;
560: \ : ramstart dup sramdp ! ramdp ! ;
561:
562: \ default compilation goed to rom
563: \ when romable support is off, only the rom switch is used (!!)
564: >auto
565:
566: : there tdp @ ;
567:
568: >TARGET
569:
570: \ \ Target Memory Handling
571:
572: \ Byte ordering and cell size 06oct92py
573:
574: : cell+ tcell + ;
575: : cells tcell<< lshift ;
576: : chars ;
577: : char+ 1 + ;
578: : floats tfloat * ;
579:
580: >CROSS
581: : cell/ tcell<< rshift ;
582: >TARGET
583: 20 CONSTANT bl
584: \ TNIL Constant NIL
585:
586: >CROSS
587:
588: bigendian
589: [IF]
590: : S! ( n addr -- ) >r s>d r> tcell bounds swap 1-
591: DO maxbyte ud/mod rot I c! -1 +LOOP 2drop ;
592: : S@ ( addr -- n ) >r 0 0 r> tcell bounds
593: DO maxbyte * swap maxbyte um* rot + swap I c@ + swap LOOP d>s ;
594: : Sc! ( n addr -- ) >r s>d r> tchar bounds swap 1-
595: DO maxbyte ud/mod rot I c! -1 +LOOP 2drop ;
596: : Sc@ ( addr -- n ) >r 0 0 r> tchar bounds
597: DO maxbyte * swap maxbyte um* rot + swap I c@ + swap LOOP d>s ;
598: [ELSE]
599: : S! ( n addr -- ) >r s>d r> tcell bounds
600: DO maxbyte ud/mod rot I c! LOOP 2drop ;
601: : S@ ( addr -- n ) >r 0 0 r> tcell bounds swap 1-
602: DO maxbyte * swap maxbyte um* rot + swap I c@ + swap -1 +LOOP d>s ;
603: : Sc! ( n addr -- ) >r s>d r> tchar bounds
604: DO maxbyte ud/mod rot I c! LOOP 2drop ;
605: : Sc@ ( addr -- n ) >r 0 0 r> tchar bounds swap 1-
606: DO maxbyte * swap maxbyte um* rot + swap I c@ + swap -1 +LOOP d>s ;
607: [THEN]
608:
609: >CROSS
610: \ Bit string manipulation 06oct92py
611: \ 9may93jaw
612: CREATE Bittable 80 c, 40 c, 20 c, 10 c, 8 c, 4 c, 2 c, 1 c,
613: : bits ( n -- n ) chars Bittable + c@ ;
614:
615: : >bit ( addr n -- c-addr mask ) 8 /mod rot + swap bits ;
616: : +bit ( addr n -- ) >bit over c@ or swap c! ;
617: : -bit ( addr n -- ) >bit invert over c@ and swap c! ;
618: : relon ( taddr -- ) bit$ @ swap cell/ +bit ;
619: : reloff ( taddr -- ) bit$ @ swap cell/ -bit ;
620:
621: \ Target memory access 06oct92py
622:
623: : align+ ( taddr -- rest )
624: tcell tuck 1- and - [ tcell 1- ] Literal and ;
625: : cfalign+ ( taddr -- rest )
626: \ see kernel.fs:cfaligned
627: /maxalign tuck 1- and - [ /maxalign 1- ] Literal and ;
628:
629: >TARGET
630: : aligned ( taddr -- ta-addr ) dup align+ + ;
631: \ assumes cell alignment granularity (as GNU C)
632:
633: : cfaligned ( taddr1 -- taddr2 )
634: \ see kernel.fs
635: dup cfalign+ + ;
636:
637: >CROSS
638: : >image ( taddr -- absaddr ) image @ + ;
639: >TARGET
640: : @ ( taddr -- w ) >image S@ ;
641: : ! ( w taddr -- ) >image S! ;
642: : c@ ( taddr -- char ) >image Sc@ ;
643: : c! ( char taddr -- ) >image Sc! ;
644: : 2@ ( taddr -- x1 x2 ) T dup cell+ @ swap @ H ;
645: : 2! ( x1 x2 taddr -- ) T swap over ! cell+ ! H ;
646:
647: \ Target compilation primitives 06oct92py
648: \ included A! 16may93jaw
649:
650: : here ( -- there ) there ;
651: : allot ( n -- ) tdp +! ;
652: : , ( w -- ) T here H tcell T allot ! H T here drop H ;
653: : c, ( char -- ) T here tchar allot c! H ;
654: : align ( -- ) T here H align+ 0 ?DO bl T c, H LOOP ;
655: : cfalign ( -- )
656: T here H cfalign+ 0 ?DO bl T c, H LOOP ;
657:
658: : A! dup relon T ! H ;
659: : A, ( w -- ) T here H relon T , H ;
660:
661: >CROSS
662:
663: : tcmove ( source dest len -- )
664: \G cmove in target memory
665: tchar * bounds
666: ?DO dup T c@ H I T c! H 1+
667: tchar +LOOP drop ;
668:
669: >TARGET
670: H also Forth definitions \ ." asm: " order
671:
672: : X also target bl word find
673: IF state @ IF compile,
674: ELSE execute THEN
675: ELSE previous ABORT" Cross: access method not supported!"
676: THEN
677: previous ; immediate
678:
679: [IFDEF] asm-include asm-include [THEN] hex
680:
681: previous
682: >CROSS H
683:
684: \ \ -------------------- Compiler Plug Ins 01aug97jaw
685:
686: \ Compiler States
687:
688: Variable comp-state
689: 0 Constant interpreting
690: 1 Constant compiling
691: 2 Constant resolving
692: 3 Constant assembling
693:
694: Defer lit, ( n -- )
695: Defer alit, ( n -- )
696:
697: Defer branch, ( target-addr -- ) \ compiles a branch
698: Defer ?branch, ( target-addr -- ) \ compiles a ?branch
699: Defer branchmark, ( -- branch-addr ) \ reserves room for a branch
700: Defer ?branchmark, ( -- branch-addr ) \ reserves room for a ?branch
701: Defer ?domark, ( -- branch-addr ) \ reserves room for a ?do branch
702: Defer branchto, ( -- ) \ actual program position is target of a branch (do e.g. alignment)
703: Defer branchtoresolve, ( branch-addr -- ) \ resolves a forward reference from branchmark
704: Defer branchfrom, ( -- ) \ ?!
705: Defer branchtomark, ( -- target-addr ) \ marks a branch destination
706:
707: Defer colon, ( tcfa -- ) \ compiles call to tcfa at current position
708: Defer colonmark, ( -- addr ) \ marks a colon call
709: Defer colon-resolve ( tcfa addr -- )
710:
711: Defer addr-resolve ( target-addr addr -- )
712: Defer doer-resolve ( ghost res-pnt target-addr addr -- ghost res-pnt )
713:
714: Defer do, ( -- do-token )
715: Defer ?do, ( -- ?do-token )
716: Defer for, ( -- for-token )
717: Defer loop, ( do-token / ?do-token -- )
718: Defer +loop, ( do-token / ?do-token -- )
719: Defer next, ( for-token )
720:
721: [IFUNDEF] ca>native
722: defer ca>native
723: [THEN]
724:
725: >TARGET
726: DEFER >body \ we need the system >body
727: \ and the target >body
728: >CROSS
729: T 2 cells H VALUE xt>body
730: DEFER doprim, \ compiles start of a primitive
731: DEFER docol, \ compiles start of a colon definition
732: DEFER doer,
733: DEFER fini, \ compiles end of definition ;s
734: DEFER doeshandler,
735: DEFER dodoes,
736:
737: DEFER ]comp \ starts compilation
738: DEFER comp[ \ ends compilation
739:
740: : (cc) T a, H ; ' (cc) IS colon,
741:
742: : (cr) >tempdp ]comp colon, comp[ tempdp> ; ' (cr) IS colon-resolve
743: : (ar) T ! H ; ' (ar) IS addr-resolve
744: : (dr) ( ghost res-pnt target-addr addr )
745: >tempdp drop over
746: dup >magic @ <do:> =
747: IF doer,
748: ELSE dodoes,
749: THEN
750: tempdp> ; ' (dr) IS doer-resolve
751:
752: : (cm) ( -- addr )
753: T here align H
754: -1 colon, ; ' (cm) IS colonmark,
755:
756: >TARGET
757: : compile, colon, ;
758: >CROSS
759:
760: \ file loading
761:
762: : >fl-id 1 cells + ;
763: : >fl-name 2 cells + ;
764:
765: Variable filelist 0 filelist !
766: 0 Value filemem
767: : loadfile filemem >fl-name ;
768:
769: 1 [IF] \ !! JAW WIP
770:
771: : add-included-file ( adr len -- )
772: dup char+ >fl-name allocate throw >r
773: r@ >fl-name place
774: filelist @ r@ !
775: r> dup filelist ! to FileMem
776: ;
777:
778: : included? ( c-addr u -- f )
779: filelist
780: BEGIN @ dup
781: WHILE >r r@ 1 cells + count compare 0=
782: IF rdrop 2drop true EXIT THEN
783: r>
784: REPEAT
785: 2drop drop false ;
786:
787: : included
788: \ cr ." Including: " 2dup type ." ..."
789: FileMem >r
790: 2dup add-included-file included
791: r> to FileMem ;
792:
793: : include bl word count included ;
794:
795: : require bl word count included ;
796:
797: [THEN]
798:
799: \ resolve structure
800:
801: : >next ; \ link to next field
802: : >tag cell+ ; \ indecates type of reference: 0: call, 1: address, 2: doer
803: : >taddr cell+ cell+ ;
804: : >ghost 3 cells + ;
805: : >file 4 cells + ;
806: : >line 5 cells + ;
807:
808: : (refered) ( ghost addr tag -- )
809: \G creates a reference to ghost at address taddr
810: rot >r here r@ >link @ , r> >link !
811: ( taddr tag ) ,
812: ( taddr ) ,
813: last-header-ghost @ ,
814: loadfile ,
815: sourceline# ,
816: ;
817:
818: : refered ( ghost tag -- )
819: \G creates a resolve structure
820: T here aligned H swap (refered)
821: ;
822:
823: : killref ( addr ghost -- )
824: \G kills a forward reference to ghost at position addr
825: \G this is used to eleminate a :dovar refence after making a DOES>
826: dup >magic @ <fwd> <> IF 2drop EXIT THEN
827: swap >r >link
828: BEGIN dup @ dup ( addr last this )
829: WHILE dup >taddr @ r@ =
830: IF @ over !
831: ELSE nip THEN
832: REPEAT rdrop 2drop
833: ;
834:
835: Defer resolve-warning
836:
837: : reswarn-test ( ghost res-struct -- ghost res-struct )
838: over cr ." Resolving " >ghostname type dup ." in " >ghost @ >ghostname type ;
839:
840: : reswarn-forward ( ghost res-struct -- ghost res-struct )
841: over warnhead >ghostname type dup ." is referenced in "
842: >ghost @ >ghostname type ;
843:
844: \ ' reswarn-test IS resolve-warning
845:
846: \ resolve 14oct92py
847:
848: : resolve-loop ( ghost resolve-list tcfa -- )
849: >r
850: BEGIN dup WHILE
851: \ dup >tag @ 2 = IF reswarn-forward THEN
852: resolve-warning
853: r@ over >taddr @
854: 2 pick >tag @
855: CASE 0 OF colon-resolve ENDOF
856: 1 OF addr-resolve ENDOF
857: 2 OF doer-resolve ENDOF
858: ENDCASE
859: @ \ next list element
860: REPEAT 2drop rdrop
861: ;
862:
863: \ : resolve-loop ( ghost tcfa -- ghost tcfa )
864: \ >r dup >link @
865: \ BEGIN dup WHILE dup T @ H r@ rot T ! H REPEAT drop r> ;
866:
867: \ exists 9may93jaw
868:
869: Variable TWarnings
870: TWarnings on
871: Variable Exists-Warnings
872: Exists-Warnings on
873:
874: : exists ( ghost tcfa -- )
875: over GhostNames
876: BEGIN @ dup
877: WHILE 2dup cell+ @ =
878: UNTIL
879: 2 cells + count
880: TWarnings @ Exists-Warnings @ and
881: IF warnhead type ." exists"
882: ELSE 2drop THEN
883: drop swap >link !
884: ELSE true abort" CROSS: Ghostnames inconsistent "
885: THEN ;
886:
887: : resolve ( ghost tcfa -- )
888: \G resolve referencies to ghost with tcfa
889: \ is ghost resolved?, second resolve means another definition with the
890: \ same name
891: over forward? 0= IF exists EXIT THEN
892: \ get linked-list
893: swap >r r@ >link @ swap \ ( list tcfa R: ghost )
894: \ mark ghost as resolved
895: dup r@ >link ! <res> r@ >magic !
896: \ loop through forward referencies
897: r> -rot
898: comp-state @ >r Resolving comp-state !
899: resolve-loop
900: r> comp-state !
901:
902: ['] noop IS resolve-warning
903: ;
904:
905: \ gexecute ghost, 01nov92py
906:
907: : is-forward ( ghost -- )
908: colonmark, 0 (refered) ; \ compile space for call
909:
910: : is-resolved ( ghost -- )
911: >link @ colon, ; \ compile-call
912:
913: : gexecute ( ghost -- )
914: dup @ <fwd> = IF is-forward ELSE is-resolved THEN ;
915:
916: : addr, ( ghost -- )
917: dup @ <fwd> = IF 1 refered 0 T a, H ELSE >link @ T a, H THEN ;
918:
919: \ !! : ghost, ghost gexecute ;
920:
921: \ .unresolved 11may93jaw
922:
923: variable ResolveFlag
924:
925: \ ?touched 11may93jaw
926:
927: : ?touched ( ghost -- flag ) dup forward? swap >link @
928: 0 <> and ;
929:
930: : .forwarddefs ( ghost -- )
931: ." appeared in:"
932: >link
933: BEGIN @ dup
934: WHILE cr 5 spaces
935: dup >ghost @ >ghostname type
936: ." file " dup >file @ ?dup IF count type ELSE ." CON" THEN
937: ." line " dup >line @ .dec
938: REPEAT
939: drop ;
940:
941: : ?resolved ( ghostname -- )
942: dup cell+ @ ?touched
943: IF dup
944: cell+ cell+ count cr type ResolveFlag on
945: cell+ @ .forwarddefs
946: ELSE drop
947: THEN ;
948:
949: >MINIMAL
950: : .unresolved ( -- )
951: ResolveFlag off cr ." Unresolved: "
952: Ghostnames
953: BEGIN @ dup
954: WHILE dup ?resolved
955: REPEAT drop ResolveFlag @
956: IF
957: -1 abort" Unresolved words!"
958: ELSE
959: ." Nothing!"
960: THEN
961: cr ;
962:
963: : .stats
964: base @ >r decimal
965: cr ." named Headers: " headers-named @ .
966: r> base ! ;
967:
968: >CROSS
969: \ Header states 12dec92py
970:
971: : flag! ( 8b -- ) tlast @ dup >r T c@ xor r> c! H ;
972:
973: VARIABLE ^imm
974:
975: >TARGET
976: : immediate 40 flag!
977: ^imm @ @ dup <imm> = IF drop EXIT THEN
978: <res> <> ABORT" CROSS: Cannot immediate a unresolved word"
979: <imm> ^imm @ ! ;
980: : restrict 20 flag! ;
981:
982: : isdoer
983: \G define a forth word as doer, this makes obviously only sence on
984: \G forth processors such as the PSC1000
985: <do:> last-header-ghost @ >magic ! ;
986: >CROSS
987:
988: \ ALIAS2 ansforth conform alias 9may93jaw
989:
990: : ALIAS2 create here 0 , DOES> @ execute ;
991: \ usage:
992: \ ' <name> alias2 bla !
993:
994: \ Target Header Creation 01nov92py
995:
996: >TARGET
997: : string, ( addr count -- )
998: dup T c, H bounds ?DO I c@ T c, H LOOP ;
999: : name, ( "name" -- ) bl word count T string, cfalign H ;
1000: : view, ( -- ) ( dummy ) ;
1001: >CROSS
1002:
1003: \ Target Document Creation (goes to crossdoc.fd) 05jul95py
1004:
1005: s" ./doc/crossdoc.fd" r/w create-file throw value doc-file-id
1006: \ contains the file-id of the documentation file
1007:
1008: : T-\G ( -- )
1009: source >in @ /string doc-file-id write-line throw
1010: postpone \ ;
1011:
1012: Variable to-doc to-doc on
1013:
1014: : cross-doc-entry ( -- )
1015: to-doc @ tlast @ 0<> and \ not an anonymous (i.e. noname) header
1016: IF
1017: s" " doc-file-id write-line throw
1018: s" make-doc " doc-file-id write-file throw
1019: tlast @ >image count $1F and doc-file-id write-file throw
1020: >in @
1021: [char] ( parse 2drop
1022: [char] ) parse doc-file-id write-file throw
1023: s" )" doc-file-id write-file throw
1024: [char] \ parse 2drop
1025: T-\G
1026: >in !
1027: THEN ;
1028:
1029: \ Target TAGS creation
1030:
1031: s" kernel.TAGS" r/w create-file throw value tag-file-id
1032: \ contains the file-id of the tags file
1033:
1034: Create tag-beg 2 c, 7F c, bl c,
1035: Create tag-end 2 c, bl c, 01 c,
1036: Create tag-bof 1 c, 0C c,
1037:
1038: 2variable last-loadfilename 0 0 last-loadfilename 2!
1039:
1040: : put-load-file-name ( -- )
1041: loadfilename 2@ last-loadfilename 2@ d<>
1042: IF
1043: tag-bof count tag-file-id write-line throw
1044: sourcefilename 2dup
1045: tag-file-id write-file throw
1046: last-loadfilename 2!
1047: s" ,0" tag-file-id write-line throw
1048: THEN ;
1049:
1050: : cross-tag-entry ( -- )
1051: tlast @ 0<> \ not an anonymous (i.e. noname) header
1052: IF
1053: put-load-file-name
1054: source >in @ min tag-file-id write-file throw
1055: tag-beg count tag-file-id write-file throw
1056: tlast @ >image count $1F and tag-file-id write-file throw
1057: tag-end count tag-file-id write-file throw
1058: base @ decimal sourceline# 0 <# #s #> tag-file-id write-file throw
1059: \ >in @ 0 <# #s [char] , hold #> tag-file-id write-line throw
1060: s" ,0" tag-file-id write-line throw
1061: base !
1062: THEN ;
1063:
1064: \ Check for words
1065:
1066: Defer skip? ' false IS skip?
1067:
1068: : defined? ( -- flag ) \ name
1069: ghost forward? 0= ;
1070:
1071: : needed? ( -- flag ) \ name
1072: \G returns a false flag when
1073: \G a word is not defined
1074: \G a forward reference exists
1075: \G so the definition is not skipped!
1076: bl word gfind
1077: IF dup forward?
1078: nip
1079: 0=
1080: ELSE drop true THEN ;
1081:
1082: : doer? ( -- flag ) \ name
1083: ghost >magic @ <do:> = ;
1084:
1085: : skip-defs ( -- )
1086: BEGIN refill WHILE source -trailing nip 0= UNTIL THEN ;
1087:
1088: \ Target header creation
1089:
1090: Variable CreateFlag
1091: CreateFlag off
1092:
1093: Variable NoHeaderFlag
1094: NoHeaderFlag off
1095:
1096: : 0.r ( n1 n2 -- )
1097: base @ >r hex
1098: 0 swap <# 0 ?DO # LOOP #> type
1099: r> base ! ;
1100: : .sym
1101: bounds
1102: DO I c@ dup
1103: CASE '/ OF drop ." \/" ENDOF
1104: '\ OF drop ." \\" ENDOF
1105: dup OF emit ENDOF
1106: ENDCASE
1107: LOOP ;
1108:
1109: : (Theader ( "name" -- ghost )
1110: \ >in @ bl word count type 2 spaces >in !
1111: \ wordheaders will always be compiled to rom
1112: switchrom
1113: \ build header in target
1114: NoHeaderFlag @
1115: IF NoHeaderFlag off
1116: ELSE
1117: T align H view,
1118: tlast @ dup 0> IF T 1 cells - THEN A, H there tlast !
1119: 1 headers-named +! \ Statistic
1120: >in @ T name, H >in !
1121: THEN
1122: T cfalign here H tlastcfa !
1123: \ Symbol table
1124: \ >in @ cr ." sym:s/CFA=" there 4 0.r ." /" bl word count .sym ." /g" cr >in !
1125: CreateFlag @
1126: IF
1127: >in @ alias2 swap >in ! \ create alias in target
1128: >in @ ghost swap >in !
1129: swap also ghosts ' previous swap ! \ tick ghost and store in alias
1130: CreateFlag off
1131: ELSE ghost
1132: THEN
1133: dup Last-Header-Ghost !
1134: dup >magic ^imm ! \ a pointer for immediate
1135: Already @
1136: IF dup >end tdoes !
1137: ELSE 0 tdoes !
1138: THEN
1139: 80 flag!
1140: cross-doc-entry cross-tag-entry ;
1141:
1142: VARIABLE ;Resolve 1 cells allot
1143: \ this is the resolver information from ":"
1144: \ resolving is done by ";"
1145:
1146: : Theader ( "name" -- ghost )
1147: (THeader dup there resolve 0 ;Resolve ! ;
1148:
1149: >TARGET
1150: : Alias ( cfa -- ) \ name
1151: >in @ skip? IF 2drop EXIT THEN >in !
1152: dup 0< s" prims" T $has? H 0= and
1153: IF
1154: .sourcepos ." needs prim: " >in @ bl word count type >in ! cr
1155: THEN
1156: (THeader over resolve T A, H 80 flag! ;
1157: : Alias: ( cfa -- ) \ name
1158: >in @ skip? IF 2drop EXIT THEN >in !
1159: dup 0< s" prims" T $has? H 0= and
1160: IF
1161: .sourcepos ." needs doer: " >in @ bl word count type >in ! cr
1162: THEN
1163: ghost tuck swap resolve <do:> swap >magic ! ;
1164: >CROSS
1165:
1166: \ Conditionals and Comments 11may93jaw
1167:
1168: : ;Cond
1169: postpone ;
1170: swap ! ; immediate
1171:
1172: : Cond: ( -- ) \ name {code } ;
1173: atonce on
1174: ghost
1175: >exec
1176: :NONAME ;
1177:
1178: : restrict? ( -- )
1179: \ aborts on interprete state - ae
1180: state @ 0= ABORT" CROSS: Restricted" ;
1181:
1182: : Comment ( -- )
1183: >in @ atonce on ghost swap >in ! ' swap >exec ! ;
1184:
1185: Comment ( Comment \
1186:
1187: \ compile 10may93jaw
1188:
1189: : compile ( -- ) \ name
1190: restrict?
1191: bl word gfind dup 0= ABORT" CROSS: Can't compile "
1192: 0> ( immediate? )
1193: IF >exec @ compile,
1194: ELSE postpone literal postpone gexecute THEN ;
1195: immediate
1196:
1197: : [G']
1198: \G ticks a ghost and returns its address
1199: bl word gfind 0= ABORT" CROSS: Ghost don't exists"
1200: state @
1201: IF postpone literal
1202: THEN ; immediate
1203:
1204: : ghost>cfa
1205: dup forward? ABORT" CROSS: forward " >link @ ;
1206:
1207: >TARGET
1208:
1209: : ' ( -- cfa )
1210: \ returns the target-cfa of a ghost
1211: bl word gfind 0= ABORT" CROSS: Ghost don't exists"
1212: ghost>cfa ;
1213:
1214: Cond: ['] T ' H alit, ;Cond
1215:
1216: >CROSS
1217:
1218: : [T']
1219: \ returns the target-cfa of a ghost, or compiles it as literal
1220: postpone [G'] state @ IF postpone ghost>cfa ELSE ghost>cfa THEN ; immediate
1221:
1222: \ \ threading modell 13dec92py
1223: \ modularized 14jun97jaw
1224:
1225: : fillcfa ( usedcells -- )
1226: T cells H xt>body swap - 0 ?DO 0 T c, H LOOP ;
1227:
1228: : (>body) ( cfa -- pfa ) xt>body + ; ' (>body) T IS >body H
1229:
1230: : (doer,) ( ghost -- ) ]comp gexecute comp[ 1 fillcfa ; ' (doer,) IS doer,
1231:
1232: : (docol,) ( -- ) [G'] :docol doer, ; ' (docol,) IS docol,
1233:
1234: : (doprim,) ( -- )
1235: there xt>body + ca>native T a, H 1 fillcfa ; ' (doprim,) IS doprim,
1236:
1237: : (doeshandler,) ( -- )
1238: T cfalign H compile :doesjump T 0 , H ; ' (doeshandler,) IS doeshandler,
1239:
1240: : (dodoes,) ( does-action-ghost -- )
1241: ]comp [G'] :dodoes gexecute comp[
1242: addr,
1243: T here H tcell - reloff 2 fillcfa ; ' (dodoes,) IS dodoes,
1244:
1245: : (lit,) ( n -- ) compile lit T , H ; ' (lit,) IS lit,
1246:
1247: : (alit,) ( n -- ) lit, T here cell - H relon ; ' (alit,) IS alit,
1248:
1249: : (fini,) compile ;s ; ' (fini,) IS fini,
1250:
1251: [IFUNDEF] (code)
1252: Defer (code)
1253: Defer (end-code)
1254: [THEN]
1255:
1256: >TARGET
1257: : Code
1258: defempty?
1259: (THeader there resolve
1260: [ T e? prims H 0= [IF] T e? ITC H [ELSE] true [THEN] ] [IF]
1261: doprim,
1262: [THEN]
1263: depth (code) ;
1264:
1265: : Code:
1266: defempty?
1267: ghost dup there ca>native resolve <do:> swap >magic !
1268: depth (code) ;
1269:
1270: : end-code
1271: (end-code)
1272: depth ?dup IF 1- <> ABORT" CROSS: Stack changed"
1273: ELSE true ABORT" CROSS: Stack empty" THEN
1274: ;
1275:
1276: ( Cond ) : chars tchar * ; ( Cond )
1277:
1278: >CROSS
1279:
1280: \ tLiteral 12dec92py
1281:
1282: >TARGET
1283: Cond: \G T-\G ;Cond
1284:
1285: Cond: Literal ( n -- ) restrict? lit, ;Cond
1286: Cond: ALiteral ( n -- ) restrict? alit, ;Cond
1287:
1288: : Char ( "<char>" -- ) bl word char+ c@ ;
1289: Cond: [Char] ( "<char>" -- ) restrict? Char lit, ;Cond
1290:
1291: \ some special literals 27jan97jaw
1292:
1293: \ !! Known Bug: Special Literals and plug-ins work only correct
1294: \ on 16 and 32 Bit Targets and 32 Bit Hosts!
1295:
1296: Cond: MAXU
1297: restrict?
1298: tcell 1 cells u>
1299: IF compile lit tcell 0 ?DO FF T c, H LOOP
1300: ELSE $ffffffff lit, THEN
1301: ;Cond
1302:
1303: Cond: MINI
1304: restrict?
1305: tcell 1 cells u>
1306: IF compile lit bigendian
1307: IF 80 T c, H tcell 1 ?DO 0 T c, H LOOP
1308: ELSE tcell 1 ?DO 0 T c, H LOOP 80 T c, H
1309: THEN
1310: ELSE tcell 2 = IF $8000 ELSE $80000000 THEN lit, THEN
1311: ;Cond
1312:
1313: Cond: MAXI
1314: restrict?
1315: tcell 1 cells u>
1316: IF compile lit bigendian
1317: IF 7F T c, H tcell 1 ?DO FF T c, H LOOP
1318: ELSE tcell 1 ?DO FF T c, H LOOP 7F T c, H
1319: THEN
1320: ELSE tcell 2 = IF $7fff ELSE $7fffffff THEN lit, THEN
1321: ;Cond
1322:
1323: >CROSS
1324: \ Target compiling loop 12dec92py
1325: \ ">tib trick thrown out 10may93jaw
1326: \ number? defined at the top 11may93jaw
1327:
1328: \ compiled word might leave items on stack!
1329: : tcom ( in name -- )
1330: gfind ?dup IF 0> IF nip >exec @ execute
1331: ELSE nip gexecute THEN EXIT THEN
1332: number? dup IF 0> IF swap lit, THEN lit, drop
1333: ELSE 2drop >in !
1334: ghost gexecute THEN ;
1335:
1336: >TARGET
1337: \ : ; DOES> 13dec92py
1338: \ ] 9may93py/jaw
1339:
1340: : ] state on
1341: Compiling comp-state !
1342: BEGIN
1343: BEGIN >in @ bl word
1344: dup c@ 0= WHILE 2drop refill 0=
1345: ABORT" CROSS: End of file while target compiling"
1346: REPEAT
1347: tcom
1348: state @
1349: 0=
1350: UNTIL ;
1351:
1352: \ by the way: defining a second interpreter (a compiler-)loop
1353: \ is not allowed if a system should be ans conform
1354:
1355: : : ( -- colon-sys ) \ Name
1356: defempty?
1357: constflag off \ don't let this flag work over colon defs
1358: \ just to go sure nothing unwanted happens
1359: >in @ skip? IF drop skip-defs EXIT THEN >in !
1360: (THeader ;Resolve ! there ;Resolve cell+ !
1361: docol, ]comp depth T ] H ;
1362:
1363: : :noname ( -- colon-sys )
1364: T cfalign H there docol, 0 ;Resolve ! depth T ] H ;
1365:
1366: Cond: EXIT ( -- ) restrict? compile ;S ;Cond
1367:
1368: Cond: ?EXIT ( -- ) 1 abort" CROSS: using ?exit" ;Cond
1369:
1370: >CROSS
1371: : LastXT ;Resolve @ 0= abort" CROSS: no definition for LastXT"
1372: ;Resolve cell+ @ ;
1373:
1374: >TARGET
1375:
1376: Cond: recurse ( -- ) Last-Ghost @ gexecute ;Cond
1377:
1378: Cond: ; ( -- ) restrict?
1379: depth ?dup IF 1- <> ABORT" CROSS: Stack changed"
1380: ELSE true ABORT" CROSS: Stack empty" THEN
1381: fini,
1382: comp[
1383: state off
1384: ;Resolve @
1385: IF ;Resolve @ ;Resolve cell+ @ resolve THEN
1386: Interpreting comp-state !
1387: ;Cond
1388: Cond: [ restrict? state off Interpreting comp-state ! ;Cond
1389:
1390: >CROSS
1391:
1392: Create GhostDummy ghostheader
1393: <res> GhostDummy >magic !
1394:
1395: : !does ( does-action -- )
1396: \ !! zusammenziehen und dodoes, machen!
1397: tlastcfa @ [G'] :dovar killref
1398: \ tlastcfa @ dup there >r tdp ! compile :dodoes r> tdp ! T cell+ ! H ;
1399: \ !! geht so nicht, da dodoes, ghost will!
1400: GhostDummy >link ! GhostDummy
1401: tlastcfa @ >tempdp dodoes, tempdp> ;
1402:
1403: >TARGET
1404: Cond: DOES> restrict?
1405: compile (does>) doeshandler,
1406: \ resolve words made by builders
1407: tdoes @ ?dup IF @ T here H resolve THEN
1408: ;Cond
1409: : DOES> switchrom doeshandler, T here H !does depth T ] H ;
1410:
1411: >CROSS
1412: \ Creation 01nov92py
1413:
1414: \ Builder 11may93jaw
1415:
1416: : Builder ( Create-xt do:-xt "name" -- )
1417: \ builds up a builder in current vocabulary
1418: \ create-xt is executed when word is interpreted
1419: \ do:-xt is executet when the created word from builder is executed
1420: \ for do:-xt an additional entry after the normal ghost-enrys is used
1421:
1422: >in @ alias2 swap dup >in ! >r >r
1423: Make-Ghost
1424: rot swap >exec dup @ ['] NoExec <>
1425: IF 2drop ELSE ! THEN
1426: ,
1427: r> r> >in !
1428: also ghosts ' previous swap ! ;
1429: \ DOES> dup >exec @ execute ;
1430:
1431: : gdoes, ( ghost -- )
1432: \ makes the codefield for a word that is built
1433: >end @ dup forward? 0=
1434: IF
1435: dup >magic @ <do:> =
1436: IF doer,
1437: ELSE dodoes,
1438: THEN
1439: EXIT
1440: THEN
1441: \ compile :dodoes gexecute
1442: \ T here H tcell - reloff
1443: 2 refered
1444: 0 fillcfa
1445: ;
1446:
1447: : TCreate ( <name> -- )
1448: executed-ghost @
1449: CreateFlag on
1450: create-forward-warn
1451: IF ['] reswarn-forward IS resolve-warning THEN
1452: Theader >r dup gdoes,
1453: \ stores execution symantic in the built word
1454: >end @ >exec @ r> >exec ! ;
1455:
1456: : RTCreate ( <name> -- )
1457: \ creates a new word with code-field in ram
1458: executed-ghost @
1459: CreateFlag on
1460: create-forward-warn
1461: IF ['] reswarn-forward IS resolve-warning THEN
1462: \ make Alias
1463: (THeader there 0 T a, H 80 flag! ( S executed-ghost new-ghost )
1464: \ store poiter to code-field
1465: switchram T cfalign H
1466: there swap T ! H
1467: there tlastcfa !
1468: dup there resolve 0 ;Resolve !
1469: >r dup gdoes,
1470: >end @ >exec @ r> >exec ! ;
1471:
1472: : Build: ( -- [xt] [colon-sys] )
1473: :noname postpone TCreate ;
1474:
1475: : BuildSmart: ( -- [xt] [colon-sys] )
1476: :noname
1477: [ T has? rom H [IF] ]
1478: postpone RTCreate
1479: [ [ELSE] ]
1480: postpone TCreate
1481: [ [THEN] ] ;
1482:
1483: : gdoes> ( ghost -- addr flag )
1484: executed-ghost @
1485: state @ IF gexecute true EXIT THEN
1486: >link @ T >body H false ;
1487:
1488: \ DO: ;DO 11may93jaw
1489: \ changed to ?EXIT 10may93jaw
1490:
1491: : DO: ( -- addr [xt] [colon-sys] )
1492: here ghostheader
1493: :noname postpone gdoes> postpone ?EXIT ;
1494:
1495: : by: ( -- addr [xt] [colon-sys] ) \ name
1496: ghost
1497: :noname postpone gdoes> postpone ?EXIT ;
1498:
1499: : ;DO ( addr [xt] [colon-sys] -- addr )
1500: postpone ; ( S addr xt )
1501: over >exec ! ; immediate
1502:
1503: : by ( -- addr ) \ Name
1504: ghost >end @ ;
1505:
1506: >TARGET
1507: \ Variables and Constants 05dec92py
1508:
1509: Build: ( n -- ) ;
1510: by: :docon ( ghost -- n ) T @ H ;DO
1511: Builder (Constant)
1512:
1513: Build: ( n -- ) T , H ;
1514: by (Constant)
1515: Builder Constant
1516:
1517: Build: ( n -- ) T A, H ;
1518: by (Constant)
1519: Builder AConstant
1520:
1521: Build: ( d -- ) T , , H ;
1522: DO: ( ghost -- d ) T dup cell+ @ swap @ H ;DO
1523: Builder 2Constant
1524:
1525: BuildSmart: ;
1526: by: :dovar ( ghost -- addr ) ;DO
1527: Builder Create
1528:
1529: T has? rom H [IF]
1530: Build: ( -- ) T here 0 , H switchram T align here swap ! 0 , H ( switchrom ) ;
1531: by (Constant)
1532: Builder Variable
1533: [ELSE]
1534: Build: T 0 , H ;
1535: by Create
1536: Builder Variable
1537: [THEN]
1538:
1539: T has? rom H [IF]
1540: Build: ( -- ) T here 0 , H switchram T align here swap ! 0 , 0 , H ( switchrom ) ;
1541: by (Constant)
1542: Builder 2Variable
1543: [ELSE]
1544: Build: T 0 , 0 , H ;
1545: by Create
1546: Builder 2Variable
1547: [THEN]
1548:
1549: T has? rom H [IF]
1550: Build: ( -- ) T here 0 , H switchram T align here swap ! 0 , H ( switchrom ) ;
1551: by (Constant)
1552: Builder AVariable
1553: [ELSE]
1554: Build: T 0 A, H ;
1555: by Create
1556: Builder AVariable
1557: [THEN]
1558:
1559: \ User variables 04may94py
1560:
1561: >CROSS
1562: Variable tup 0 tup !
1563: Variable tudp 0 tudp !
1564: : u, ( n -- udp )
1565: tup @ tudp @ + T ! H
1566: tudp @ dup T cell+ H tudp ! ;
1567: : au, ( n -- udp )
1568: tup @ tudp @ + T A! H
1569: tudp @ dup T cell+ H tudp ! ;
1570: >TARGET
1571:
1572: Build: T 0 u, , H ;
1573: by: :douser ( ghost -- up-addr ) T @ H tup @ + ;DO
1574: Builder User
1575:
1576: Build: T 0 u, , 0 u, drop H ;
1577: by User
1578: Builder 2User
1579:
1580: Build: T 0 au, , H ;
1581: by User
1582: Builder AUser
1583:
1584: BuildSmart: T , H ;
1585: by (Constant)
1586: Builder Value
1587:
1588: BuildSmart: T A, H ;
1589: by (Constant)
1590: Builder AValue
1591:
1592: BuildSmart: ( -- ) [T'] noop T A, H ;
1593: by: :dodefer ( ghost -- ) ABORT" CROSS: Don't execute" ;DO
1594: Builder Defer
1595:
1596: BuildSmart: ( inter comp -- ) swap T immediate A, A, H ;
1597: DO: ( ghost -- ) ABORT" CROSS: Don't execute" ;DO
1598: Builder interpret/compile:
1599:
1600: \ Sturctures 23feb95py
1601:
1602: >CROSS
1603: : nalign ( addr1 n -- addr2 )
1604: \ addr2 is the aligned version of addr1 wrt the alignment size n
1605: 1- tuck + swap invert and ;
1606: >TARGET
1607:
1608: Build: ;
1609: by: :dofield T @ H + ;DO
1610: Builder (Field)
1611:
1612: Build: ( align1 offset1 align size "name" -- align2 offset2 )
1613: rot dup T , H ( align1 align size offset1 )
1614: + >r nalign r> ;
1615: by (Field)
1616: Builder Field
1617:
1618: : struct T 1 chars 0 H ;
1619: : end-struct T 2Constant H ;
1620:
1621: : cell% ( n -- size align )
1622: T 1 cells H dup ;
1623:
1624: \ ' 2Constant Alias2 end-struct
1625: \ 0 1 T Chars H 2Constant struct
1626:
1627: \ structural conditionals 17dec92py
1628:
1629: >CROSS
1630: : ?struc ( flag -- ) ABORT" CROSS: unstructured " ;
1631: : sys? ( sys -- sys ) dup 0= ?struc ;
1632: : >mark ( -- sys ) T here ( dup ." M" hex. ) 0 , H ;
1633:
1634: : branchoffset ( src dest -- ) - ;
1635:
1636: : >resolve ( sys -- ) T here ( dup ." >" hex. ) over branchoffset swap ! H ;
1637:
1638: : <resolve ( sys -- ) T here ( dup ." <" hex. ) branchoffset , H ;
1639:
1640: :noname compile branch T here branchoffset , H ;
1641: IS branch, ( target-addr -- )
1642: :noname compile ?branch T here branchoffset , H ;
1643: IS ?branch, ( target-addr -- )
1644: :noname compile branch T here 0 , H ;
1645: IS branchmark, ( -- branchtoken )
1646: :noname compile ?branch T here 0 , H ;
1647: IS ?branchmark, ( -- branchtoken )
1648: :noname T here 0 , H ;
1649: IS ?domark, ( -- branchtoken )
1650: :noname dup T @ H ?struc T here over branchoffset swap ! H ;
1651: IS branchtoresolve, ( branchtoken -- )
1652: :noname branchto, T here H ;
1653: IS branchtomark, ( -- target-addr )
1654:
1655: >TARGET
1656:
1657: \ Structural Conditionals 12dec92py
1658:
1659: Cond: BUT restrict? sys? swap ;Cond
1660: Cond: YET restrict? sys? dup ;Cond
1661:
1662: 0 [IF]
1663: >CROSS
1664: Variable tleavings
1665: >TARGET
1666:
1667: Cond: DONE ( addr -- ) restrict? tleavings @
1668: BEGIN 2dup u> 0= WHILE dup T @ H swap >resolve REPEAT
1669: tleavings ! drop ;Cond
1670:
1671: >CROSS
1672: : (leave) T here H tleavings @ T , H tleavings ! ;
1673: >TARGET
1674:
1675: Cond: LEAVE restrict? compile branch (leave) ;Cond
1676: Cond: ?LEAVE restrict? compile 0= compile ?branch (leave) ;Cond
1677:
1678: [ELSE]
1679: \ !! This is WIP
1680: \ The problem is (?DO)!
1681: \ perhaps we need a plug-in for (?DO)
1682:
1683: >CROSS
1684: Variable tleavings 0 tleavings !
1685: : (done) ( addr -- )
1686: tleavings @
1687: BEGIN dup
1688: WHILE
1689: >r dup r@ cell+ @ \ address of branch
1690: u> 0= \ lower than DO?
1691: WHILE
1692: r@ 2 cells + @ \ branch token
1693: branchtoresolve,
1694: r@ @ r> free throw
1695: REPEAT r> THEN
1696: tleavings ! drop ;
1697:
1698: >TARGET
1699:
1700: Cond: DONE ( addr -- ) restrict? (done) ;Cond
1701:
1702: >CROSS
1703: : (leave) ( branchtoken -- )
1704: 3 cells allocate throw >r
1705: T here H r@ cell+ !
1706: r@ 2 cells + !
1707: tleavings @ r@ !
1708: r> tleavings ! ;
1709: >TARGET
1710:
1711: Cond: LEAVE restrict? branchmark, (leave) ;Cond
1712: Cond: ?LEAVE restrict? compile 0= ?branchmark, (leave) ;Cond
1713:
1714: [THEN]
1715:
1716: >CROSS
1717: \ !!JW ToDo : Move to general tools section
1718:
1719: : to1 ( x1 x2 xn n -- addr )
1720: \G packs n stack elements in a allocated memory region
1721: dup dup 1+ cells allocate throw dup >r swap 1+
1722: 0 DO tuck ! cell+ LOOP
1723: drop r> ;
1724: : 1to ( addr -- x1 x2 xn )
1725: \G unpacks the elements saved by to1
1726: dup @ swap over cells + swap
1727: 0 DO dup @ swap 1 cells - LOOP
1728: free throw ;
1729:
1730: : loop] branchto, dup <resolve tcell - (done) ;
1731:
1732: : skiploop] ?dup IF branchto, branchtoresolve, THEN ;
1733:
1734: >TARGET
1735:
1736: \ Structural Conditionals 12dec92py
1737:
1738: >TARGET
1739: Cond: AHEAD restrict? branchmark, ;Cond
1740: Cond: IF restrict? ?branchmark, ;Cond
1741: Cond: THEN restrict? sys? branchto, branchtoresolve, ;Cond
1742: Cond: ELSE restrict? sys? compile AHEAD swap compile THEN ;Cond
1743:
1744: Cond: BEGIN restrict? branchtomark, ;Cond
1745: Cond: WHILE restrict? sys? compile IF swap ;Cond
1746: Cond: AGAIN restrict? sys? branch, ;Cond
1747: Cond: UNTIL restrict? sys? ?branch, ;Cond
1748: Cond: REPEAT restrict? over 0= ?struc compile AGAIN compile THEN ;Cond
1749:
1750: Cond: CASE restrict? 0 ;Cond
1751: Cond: OF restrict? 1+ >r compile over compile =
1752: compile IF compile drop r> ;Cond
1753: Cond: ENDOF restrict? >r compile ELSE r> ;Cond
1754: Cond: ENDCASE restrict? compile drop 0 ?DO compile THEN LOOP ;Cond
1755:
1756: \ Structural Conditionals 12dec92py
1757:
1758: :noname
1759: 0 compile (do)
1760: branchtomark, 2 to1 ;
1761: IS do, ( -- target-addr )
1762:
1763: \ :noname
1764: \ compile 2dup compile = compile IF
1765: \ compile 2drop compile ELSE
1766: \ compile (do) branchtomark, 2 to1 ;
1767: \ IS ?do,
1768:
1769: :noname
1770: 0 compile (?do) ?domark, (leave)
1771: branchtomark, 2 to1 ;
1772: IS ?do, ( -- target-addr )
1773: :noname compile (for) branchtomark, ;
1774: IS for, ( -- target-addr )
1775: :noname 1to compile (loop) loop] compile unloop skiploop] ;
1776: IS loop, ( target-addr -- )
1777: :noname 1to compile (+loop) loop] compile unloop skiploop] ;
1778: IS +loop, ( target-addr -- )
1779: :noname compile (next) loop] compile unloop ;
1780: IS next, ( target-addr -- )
1781:
1782: Cond: DO restrict? do, ;Cond
1783: Cond: ?DO restrict? ?do, ;Cond
1784: Cond: FOR restrict? for, ;Cond
1785:
1786: Cond: LOOP restrict? sys? loop, ;Cond
1787: Cond: +LOOP restrict? sys? +loop, ;Cond
1788: Cond: NEXT restrict? sys? next, ;Cond
1789:
1790: \ String words 23feb93py
1791:
1792: : ," [char] " parse T string, align H ;
1793:
1794: Cond: ." restrict? compile (.") T ," H ;Cond
1795: Cond: S" restrict? compile (S") T ," H ;Cond
1796: Cond: ABORT" restrict? compile (ABORT") T ," H ;Cond
1797:
1798: Cond: IS T ' >body H compile ALiteral compile ! ;Cond
1799: : IS T ' >body ! H ;
1800: Cond: TO T ' >body H compile ALiteral compile ! ;Cond
1801: : TO T ' >body ! H ;
1802:
1803: Cond: defers T ' >body @ compile, H ;Cond
1804: : on T -1 swap ! H ;
1805: : off T 0 swap ! H ;
1806:
1807: \ LINKED ERR" ENV" 2ENV" 18may93jaw
1808:
1809: \ linked list primitive
1810: : linked T here over @ A, swap ! H ;
1811: : chained T linked A, H ;
1812:
1813: : err" s" ErrLink linked" evaluate T , H
1814: [char] " parse T string, align H ;
1815:
1816: : env" [char] " parse s" EnvLink linked" evaluate
1817: T string, align , H ;
1818:
1819: : 2env" [char] " parse s" EnvLink linked" evaluate
1820: here >r T string, align , , H
1821: r> dup T c@ H 80 and swap T c! H ;
1822:
1823: \ compile must be last 22feb93py
1824:
1825: Cond: compile ( -- ) restrict? \ name
1826: bl word gfind dup 0= ABORT" CROSS: Can't compile"
1827: 0> IF gexecute
1828: ELSE dup >magic @ <imm> =
1829: IF gexecute
1830: ELSE compile (compile) addr, THEN THEN ;Cond
1831:
1832: Cond: postpone ( -- ) restrict? \ name
1833: bl word gfind dup 0= ABORT" CROSS: Can't compile"
1834: 0> IF gexecute
1835: ELSE dup >magic @ <imm> =
1836: IF gexecute
1837: ELSE compile (compile) addr, THEN THEN ;Cond
1838:
1839: \ \ minimal definitions
1840:
1841: >MINIMAL
1842: also minimal
1843: \ Usefull words 13feb93py
1844:
1845: : KB 400 * ;
1846:
1847: \ \ [IF] [ELSE] [THEN] ... 14sep97jaw
1848:
1849: \ it is useful to define our own structures and not to rely
1850: \ on the words in the compiler
1851: \ The words in the compiler might be defined with vocabularies
1852: \ this doesn't work with our self-made compile-loop
1853:
1854: Create parsed 20 chars allot \ store word we parsed
1855:
1856: : upcase
1857: parsed count bounds
1858: ?DO I c@ toupper I c! LOOP ;
1859:
1860: : [ELSE]
1861: 1 BEGIN
1862: BEGIN bl word count dup WHILE
1863: comment? parsed place upcase parsed count
1864: 2dup s" [IF]" compare 0= >r
1865: 2dup s" [IFUNDEF]" compare 0= >r
1866: 2dup s" [IFDEF]" compare 0= r> or r> or
1867: IF 2drop 1+
1868: ELSE 2dup s" [ELSE]" compare 0=
1869: IF 2drop 1- dup
1870: IF 1+
1871: THEN
1872: ELSE
1873: 2dup s" [ENDIF]" compare 0= >r
1874: s" [THEN]" compare 0= r> or
1875: IF 1- THEN
1876: THEN
1877: THEN
1878: ?dup 0= ?EXIT
1879: REPEAT
1880: 2drop refill 0=
1881: UNTIL drop ; immediate
1882:
1883: : [THEN] ( -- ) ; immediate
1884:
1885: : [ENDIF] ( -- ) ; immediate
1886:
1887: : [IF] ( flag -- )
1888: 0= IF postpone [ELSE] THEN ; immediate
1889:
1890: Cond: [IF] postpone [IF] ;Cond
1891: Cond: [THEN] postpone [THEN] ;Cond
1892: Cond: [ELSE] postpone [ELSE] ;Cond
1893:
1894: \ define new [IFDEF] and [IFUNDEF] 20may93jaw
1895:
1896: : defined? defined? ;
1897: : needed? needed? ;
1898: : doer? doer? ;
1899:
1900: \ we want to use IFDEF on compiler directives (e.g. E?) in the source, too
1901:
1902: : directive?
1903: bl word count [ ' target >wordlist ] aliteral search-wordlist
1904: dup IF nip THEN ;
1905:
1906: : [IFDEF] >in @ directive? swap >in !
1907: 0= IF defined? ELSE name 2drop true THEN
1908: postpone [IF] ;
1909:
1910: : [IFUNDEF] defined? 0= postpone [IF] ;
1911:
1912: Cond: [IFDEF] postpone [IFDEF] ;Cond
1913:
1914: Cond: [IFUNDEF] postpone [IFUNDEF] ;Cond
1915:
1916: \ C: \- \+ Conditional Compiling 09jun93jaw
1917:
1918: : C: >in @ defined? 0=
1919: IF >in ! T : H
1920: ELSE drop
1921: BEGIN bl word dup c@
1922: IF count comment? s" ;" compare 0= ?EXIT
1923: ELSE refill 0= ABORT" CROSS: Out of Input while C:"
1924: THEN
1925: AGAIN
1926: THEN ;
1927:
1928: also minimal
1929:
1930: \G doesn't skip line when bit is set in debugmask
1931: : \D name evaluate debugmasksource @ and 0= IF postpone \ THEN ;
1932:
1933: \G interprets the line if word is not defined
1934: : \- defined? IF postpone \ THEN ;
1935:
1936: \G interprets the line if word is defined
1937: : \+ defined? 0= IF postpone \ THEN ;
1938:
1939: Cond: \- \- ;Cond
1940: Cond: \+ \+ ;Cond
1941: Cond: \D \D ;Cond
1942:
1943: : ?? bl word find IF execute ELSE drop 0 THEN ;
1944:
1945: : needed:
1946: \G defines ghost for words that we want to be compiled
1947: BEGIN >in @ bl word c@ WHILE >in ! ghost drop REPEAT drop ;
1948:
1949: previous
1950:
1951: \ save-cross 17mar93py
1952:
1953: >CROSS
1954: Create magic s" Gforth10" here over allot swap move
1955:
1956: char 1 bigendian + tcell + magic 7 + c!
1957:
1958: : save-cross ( "image-name" "binary-name" -- )
1959: bl parse ." Saving to " 2dup type cr
1960: w/o bin create-file throw >r
1961: TNIL IF
1962: s" #! " r@ write-file throw
1963: bl parse r@ write-file throw
1964: s" -i" r@ write-file throw
1965: #lf r@ emit-file throw
1966: r@ dup file-position throw drop 8 mod 8 swap ( file-id limit index )
1967: ?do
1968: bl over emit-file throw
1969: loop
1970: drop
1971: magic 8 r@ write-file throw \ write magic
1972: ELSE
1973: bl parse 2drop
1974: THEN
1975: image @ there
1976: r@ write-file throw \ write image
1977: TNIL IF
1978: bit$ @ there 1- tcell>bit rshift 1+
1979: r@ write-file throw \ write tags
1980: THEN
1981: r> close-file throw ;
1982:
1983: : save-region ( addr len -- )
1984: bl parse w/o bin create-file throw >r
1985: swap image @ + swap r@ write-file throw
1986: r> close-file throw ;
1987:
1988: \ words that should be in minimal
1989:
1990: create s-buffer 50 chars allot
1991:
1992: >MINIMAL
1993: also minimal
1994:
1995: bigendian Constant bigendian
1996: : here there ;
1997:
1998: \ compiler directives
1999: : >ram >ram ;
2000: : >rom >rom ;
2001: : >auto >auto ;
2002: : >tempdp >tempdp ;
2003: : tempdp> tempdp> ;
2004: : const constflag on ;
2005: : warnings name 3 = 0= twarnings ! drop ;
2006: : | NoHeaderFlag on ;
2007:
2008: : save-cross save-cross ;
2009: : save-region save-region ;
2010: : tdump swap >image swap dump ;
2011:
2012: also forth
2013: [IFDEF] Label : Label defempty? Label ; [THEN]
2014: [IFDEF] start-macros : start-macros defempty? start-macros ; [THEN]
2015: [IFDEF] builttag : builttag builttag ; [THEN]
2016: previous
2017:
2018: : s" [char] " parse s-buffer place s-buffer count ; \ for environment?
2019: : + + ;
2020: : 1+ 1 + ;
2021: : 2+ 2 + ;
2022: : or or ;
2023: : 1- 1- ;
2024: : - - ;
2025: : and and ;
2026: : or or ;
2027: : 2* 2* ;
2028: : * * ;
2029: : / / ;
2030: : dup dup ;
2031: : over over ;
2032: : swap swap ;
2033: : rot rot ;
2034: : drop drop ;
2035: : = = ;
2036: : 0= 0= ;
2037: : lshift lshift ;
2038: : 2/ 2/ ;
2039: : . . ;
2040:
2041: : all-words ['] false IS skip? ;
2042: : needed-words ['] needed? IS skip? ;
2043: : undef-words ['] defined? IS skip? ;
2044:
2045: : \ postpone \ ; immediate
2046: : \G T-\G ; immediate
2047: : ( postpone ( ; immediate
2048: : include bl word count included ;
2049: : require require ;
2050: : .( [char] ) parse type ;
2051: : ." [char] " parse type ;
2052: : cr cr ;
2053:
2054: : times 0 ?DO dup T c, H LOOP drop ; \ used for space table creation
2055: only forth also minimal definitions
2056:
2057: \ cross-compiler words
2058:
2059: : decimal decimal ;
2060: : hex hex ;
2061:
2062: : tudp T tudp H ;
2063: : tup T tup H ;
2064:
2065: : doc-off false T to-doc H ! ;
2066: : doc-on true T to-doc H ! ;
2067: [IFDEF] dbg : dbg dbg ; [THEN]
2068:
2069: minimal
2070:
2071: \ for debugging...
2072: : order order ;
2073: : hwords words ;
2074: : words also ghosts words previous ;
2075: : .s .s ;
2076: : bye bye ;
2077:
2078: \ turnkey direction
2079: : H forth ; immediate
2080: : T minimal ; immediate
2081: : G ghosts ; immediate
2082:
2083: : turnkey 0 set-order also Target definitions
2084: also Minimal also ;
2085:
2086: \ these ones are pefered:
2087:
2088: : lock turnkey ;
2089: : unlock forth also cross ;
2090:
2091: : [[ also unlock ;
2092: : ]] previous previous ;
2093:
2094: unlock definitions also minimal
2095: : lock lock ;
2096: 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