--- gforth/cross.fs 1997/09/13 12:04:55 1.53 +++ gforth/cross.fs 1999/02/22 19:05:45 1.72 @@ -1,7 +1,7 @@ \ CROSS.FS The Cross-Compiler 06oct92py \ Idea and implementation: Bernd Paysan (py) -\ Copyright (C) 1995 Free Software Foundation, Inc. +\ Copyright (C) 1995,1996,1997,1998,1999 Free Software Foundation, Inc. \ This file is part of Gforth. @@ -19,28 +19,17 @@ \ along with this program; if not, write to the Free Software \ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -\ Log: -\ changed in ; [ to state off 12may93jaw -\ included place +place 12may93jaw -\ for a created word (variable, constant...) -\ is now an alias in the target voabulary. -\ this means it is no longer necessary to -\ switch between vocabularies for variable -\ initialization 12may93jaw -\ discovered error in DOES> -\ replaced !does with (;code) 16may93jaw -\ made complete redesign and -\ introduced two vocs method -\ to be asure that the right words -\ are found 08jun93jaw -\ btw: ! works not with 16 bit -\ targets 09jun93jaw -\ added: 2user and value 11jun93jaw - -\ needed? works better now!!! 01mar97jaw -\ mach file is only loaded into target -\ cell corrected -\ romable extansions 27apr97-5jun97jaw +0 +[IF] + +ToDo: +Crossdoc destination ./doc/crossdoc.fd makes no sense when +cross.fs is uses seperately. jaw +Do we need this char translation with >address and in branchoffset? +(>body also affected) jaw +Clean up mark> and >resolve stuff jaw + +[THEN] hex \ the defualt base for the cross-compiler is hex !! @@ -48,6 +37,7 @@ Warnings off \ words that are generaly useful +: KB 400 * ; : >wordlist ( vocabulary-xt -- wordlist-struct ) also execute get-order swap >r 1- set-order r> ; @@ -59,19 +49,24 @@ Warnings off dup c, here swap chars dup allot move ; : SetValue ( n -- ) -\G Same behaviour as "Value" when the is not defined -\G Same behaviour as "to" when is defined +\G Same behaviour as "Value" if the is not defined +\G Same behaviour as "to" if is defined \G SetValue searches in the current vocabulary - save-input bl word >r restore-input throw r> count - get-current search-wordlist - IF bl word drop >body ! ELSE Value THEN ; + save-input bl word >r restore-input throw r> count + get-current search-wordlist + IF drop >r + \ we have to set current to be topmost context wordlist + get-order get-order get-current swap 1+ set-order + r> ['] to execute + set-order order + ELSE Value THEN ; : DefaultValue ( n -- ) -\G Same behaviour as "Value" when the is not defined -\G SetValue searches in the current vocabulary +\G Same behaviour as "Value" if the is not defined +\G DefaultValue searches in the current vocabulary save-input bl word >r restore-input throw r> count get-current search-wordlist - IF bl word drop drop drop ELSE Value THEN ; + IF bl word drop 2drop ELSE Value THEN ; hex @@ -149,6 +144,7 @@ stack-warn [IF] [THEN] + \ \ GhostNames Ghosts 9may93jaw \ second name source to search trough list @@ -234,7 +230,9 @@ VARIABLE Already BEGIN @ dup WHILE 2dup cell+ @ = UNTIL nip 2 cells + count - ELSE 2drop true abort" CROSS: Ghostnames inconsistent" + ELSE 2drop + \ true abort" CROSS: Ghostnames inconsistent" + s" ?!?!?!" THEN ; ' >ghostname ALIAS @name @@ -256,8 +254,11 @@ ghost (does>) ghost noop ghost (.") ghost (S") ghost (ABORT") 2drop drop ghost ' drop ghost :docol ghost :doesjump ghost :dodoes 2drop drop +ghost :dovar drop ghost over ghost = ghost drop 2drop drop ghost - drop +ghost 2drop drop +ghost 2dup drop \ \ Parameter for target systems 06oct92py @@ -271,13 +272,13 @@ VARIABLE env-current \ save information >TARGET -: environment? +: environment? ( adr len -- [ x ] true | false ) target-environment search-wordlist IF execute true ELSE false THEN ; -: e? name T environment? H 0= ABORT" environment variable not defined!" ; +: e? bl word count T environment? H 0= ABORT" environment variable not defined!" ; -: has? name T environment? H +: has? bl word count T environment? H IF \ environment variable is present, return its value ELSE \ environment variable is not present, return false \ !! JAW abort is just for testing @@ -286,18 +287,34 @@ VARIABLE env-current \ save information : $has? T environment? H IF ELSE false THEN ; ->ENVIRON -false SetValue ionly +>ENVIRON get-order get-current swap 1+ set-order +true SetValue compiler true SetValue cross ->TARGET +true SetValue standard-threading +>TARGET previous + mach-file count included hex >ENVIRON -s" interpreter" T environment? H 0= ?dup nip [IF] true Value interpreter [THEN] -s" ITC" T environment? H 0= ?dup nip [IF] true SetValue ITC [THEN] -s" rom" T environment? H 0= ?dup nip [IF] false Value rom [THEN] +T has? ec H +[IF] +false DefaultValue relocate +false DefaultValue file +false DefaultValue OS +false DefaultValue prims +false DefaultValue floating +false DefaultValue glocals +false DefaultValue dcomps +false DefaultValue hash +false DefaultValue xconds +false DefaultValue header +[THEN] + +true DefaultValue interpreter +true DefaultValue ITC +false DefaultValue rom >TARGET s" relocate" T environment? H @@ -309,15 +326,43 @@ s" relocate" T environment? H \ \ Create additional parameters 19jan95py +\ currently cross only works for host machines with address-unit-bits +\ eual to 8 because of s! and sc! +\ but I start to query the environment just to modularize a little bit + +: check-address-unit-bits ( -- ) +\ s" ADDRESS-UNIT-BITS" environment? +\ IF 8 <> ELSE true THEN +\ ABORT" ADDRESS-UNIT-BITS unknown or not equal to 8!" + +\ shit, this doesn't work because environment? is only defined for +\ gforth.fi and not kernl???.fi + ; + +check-address-unit-bits +8 Constant bits/byte \ we define: byte is address-unit + +1 bits/byte lshift Constant maxbyte +\ this sets byte size for the target machine, an (probably right guess) jaw + T -NIL Constant TNIL -cell Constant tcell -cell<< Constant tcell<< -cell>bit Constant tcell>bit -bits/byte Constant tbits/byte -float Constant tfloat -1 bits/byte lshift Constant maxbyte +NIL Constant TNIL +cell Constant tcell +cell<< Constant tcell<< +cell>bit Constant tcell>bit +bits/char Constant tbits/char +bits/char H bits/byte T / + Constant tchar +float Constant tfloat +1 bits/char lshift Constant tmaxchar +[IFUNDEF] bits/byte +8 Constant tbits/byte +[ELSE] +bits/byte Constant tbits/byte +[THEN] H +tbits/byte bits/byte / Constant tbyte + \ Variables 06oct92py @@ -332,33 +377,14 @@ Variable bit$ Variable headers-named 0 headers-named ! Variable user-vars 0 user-vars ! -\ Memory initialisation 05dec92py - -[IFDEF] Memory \ Memory is a bigFORTH feature - also Memory - : initmem ( var len -- ) - 2dup swap handle! >r @ r> erase ; - toss -[ELSE] - : initmem ( var len -- ) - tuck allocate abort" CROSS: No memory for target" - ( len var adr ) dup rot ! - ( len adr ) swap erase ; -[THEN] - -\ MakeKernal 12dec92py +: target>bitmask-size ( u1 -- u2 ) + 1- tcell>bit rshift 1+ ; -: makekernel ( targetsize -- targetsize ) - bit$ over 1- tcell>bit rshift 1+ initmem - image over initmem ; +: allocatetarget ( size --- adr ) + dup allocate ABORT" CROSS: No memory for target" + swap over swap erase ; ->MINIMAL -: makekernel makekernel ; - - ->CROSS - -\ memregion.fs +\ \ memregion.fs Variable last-defined-region \ pointer to last defined region @@ -367,6 +393,10 @@ Variable mirrored-link \ linked 0 dup mirrored-link ! region-link ! +: >rname 6 cells + ; +: >rbm 5 cells + ; +: >rmem 4 cells + ; +: >rlink 3 cells + ; : >rdp 2 cells + ; : >rlen cell+ ; : >rstart ; @@ -380,27 +410,28 @@ Variable mirrored-link \ linked save-input create restore-input throw here last-defined-region ! over ( startaddr ) , ( length ) , ( dp ) , - region-link linked name string, + region-link linked 0 , 0 , bl word count string, ELSE \ store new parameters in region bl word drop >body >r r@ last-defined-region ! - r@ cell+ ! dup r@ ! r> 2 cells + ! + r@ >rlen ! dup r@ >rstart ! r> >rdp ! THEN ; : borders ( region -- startaddr endaddr ) \G returns lower and upper region border - dup @ swap cell+ @ over + ; + dup >rstart @ swap >rlen @ over + ; : extent ( region -- startaddr len ) \G returns the really used area - dup @ swap 2 cells + @ over - ; + dup >rstart @ swap >rdp @ over - ; : area ( region -- startaddr totallen ) \G returns the total area - dup @ swap cell+ @ ; + dup >rstart swap >rlen @ ; : mirrored \G mark a region as mirrored mirrored-link - linked last-defined-region @ , ; + align linked last-defined-region @ , ; -: .addr +: .addr ( u -- ) +\G prints a 16 or 32 Bit nice hex value base @ >r hex tcell 2 u> IF s>d <# # # # # '. hold # # # # #> type @@ -414,18 +445,19 @@ Variable mirrored-link \ linked 0 region-link @ BEGIN dup WHILE dup @ REPEAT drop BEGIN dup - WHILE cr 3 cells - >r - r@ 4 cells + count tuck type + WHILE cr + 0 >rlink - >r + r@ >rname count tuck type 12 swap - 0 max spaces space - ." Start: " r@ @ dup .addr space - ." End: " r@ 1 cells + @ + .addr space - ." DP: " r> 2 cells + @ .addr + ." Start: " r@ >rstart @ dup .addr space + ." End: " r@ >rlen @ + .addr space + ." DP: " r> >rdp @ .addr REPEAT drop s" rom" T $has? H 0= ?EXIT cr ." Mirrored:" mirrored-link @ BEGIN dup - WHILE space dup cell+ @ 4 cells + count type @ + WHILE space dup cell+ @ >rname count type @ REPEAT drop cr ; @@ -457,10 +489,10 @@ T has? rom H : setup-target ( -- ) \G initialize targets memory space s" rom" T $has? H IF \ check for ram and rom... - address-space area nip - ram-dictionary area nip - rom-dictionary area nip - and and 0= + \ address-space area nip 0<> + ram-dictionary area nip 0<> + rom-dictionary area nip 0<> + and 0= ABORT" CROSS: define address-space, rom- , ram-dictionary, with rom-support!" THEN address-space area nip @@ -469,11 +501,38 @@ T has? rom H ELSE dictionary area THEN - dup 0= + nip 0= ABORT" CROSS: define at least address-space or dictionary!!" - + makekernel drop ; -\ switched tdp for rom support 03jun97jaw + \ allocate target for each region + region-link + BEGIN @ dup + WHILE dup + 0 >rlink - >r + r@ >rlen @ + IF \ allocate mem + r@ >rlen @ dup + + allocatetarget dup image ! + r@ >rmem ! + + target>bitmask-size allocatetarget + dup bit$ ! + r> >rbm ! + + ELSE r> drop THEN + REPEAT drop ; + +\ MakeKernal 22feb99jaw + +: makekernel ( targetsize -- targetsize ) + dup dictionary >rlen ! setup-target ; + +>MINIMAL +: makekernel makekernel ; +>CROSS + +\ \ switched tdp for rom support 03jun97jaw \ second value is here to store some maximal value for statistics \ tempdp is also embedded here but has nothing to do with rom support @@ -507,16 +566,20 @@ variable fixed \ flag: true: no automat variable constflag constflag off +: activate ( region -- ) +\G next code goes to this region + >rdp to tdp ; + : (switchram) fixed @ ?EXIT s" rom" T $has? H 0= ?EXIT - ram-dictionary >rdp to tdp ; + ram-dictionary activate ; : switchram constflag @ IF constflag off ELSE (switchram) THEN ; : switchrom - fixed @ ?EXIT rom-dictionary >rdp to tdp ; + fixed @ ?EXIT rom-dictionary activate ; : >tempdp ( addr -- ) tdp tempdp-save ! tempdp to tdp tdp ! ; @@ -532,7 +595,7 @@ variable constflag constflag off \ : romstart dup sromdp ! romdp ! ; \ : ramstart dup sramdp ! ramdp ! ; -\ default compilation goed to rom +\ default compilation goes to rom \ when romable support is off, only the rom switch is used (!!) >auto @@ -546,8 +609,8 @@ variable constflag constflag off : cell+ tcell + ; : cells tcell<< lshift ; -: chars ; -: char+ 1 + ; +: chars tchar * ; +: char+ tchar + ; : floats tfloat * ; >CROSS @@ -564,14 +627,47 @@ bigendian DO maxbyte ud/mod rot I c! -1 +LOOP 2drop ; : S@ ( addr -- n ) >r 0 0 r> tcell bounds DO maxbyte * swap maxbyte um* rot + swap I c@ + swap LOOP d>s ; + : Sc! ( n addr -- ) >r s>d r> tchar bounds swap 1- + DO maxbyte ud/mod rot I c! -1 +LOOP 2drop ; + : Sc@ ( addr -- n ) >r 0 0 r> tchar bounds + DO maxbyte * swap maxbyte um* rot + swap I c@ + swap LOOP d>s ; [ELSE] : S! ( n addr -- ) >r s>d r> tcell bounds DO maxbyte ud/mod rot I c! LOOP 2drop ; : S@ ( addr -- n ) >r 0 0 r> tcell bounds swap 1- DO maxbyte * swap maxbyte um* rot + swap I c@ + swap -1 +LOOP d>s ; + : Sc! ( n addr -- ) >r s>d r> tchar bounds + DO maxbyte ud/mod rot I c! LOOP 2drop ; + : Sc@ ( addr -- n ) >r 0 0 r> tchar bounds swap 1- + DO maxbyte * swap maxbyte um* rot + swap I c@ + swap -1 +LOOP d>s ; [THEN] ->CROSS +: taddr>region ( taddr -- region | 0 ) +\G finds for a target-address the correct region +\G returns 0 if taddr is not in range of a target memory region + region-link + BEGIN @ dup + WHILE dup >r + 0 >rlink - >r + r@ >rlen @ + IF dup r@ borders within + IF r> r> drop nip EXIT THEN + THEN + r> drop + r> + REPEAT + 2drop 0 ; + +: (>regionimage) ( taddr -- 'taddr ) + dup + \ find region we want to address + taddr>region dup 0= ABORT" Address out of range!" + >r + \ calculate offset in region + r@ >rstart @ - + \ add regions real address in our memory + r> >rmem @ + ; + \ Bit string manipulation 06oct92py \ 9may93jaw CREATE Bittable 80 c, 40 c, 20 c, 10 c, 8 c, 4 c, 2 c, 1 c, @@ -580,8 +676,27 @@ CREATE Bittable 80 c, 40 c, 20 c, 10 c, : >bit ( addr n -- c-addr mask ) 8 /mod rot + swap bits ; : +bit ( addr n -- ) >bit over c@ or swap c! ; : -bit ( addr n -- ) >bit invert over c@ and swap c! ; -: relon ( taddr -- ) bit$ @ swap cell/ +bit ; -: reloff ( taddr -- ) bit$ @ swap cell/ -bit ; + +: (relon) ( taddr -- ) bit$ @ swap cell/ +bit ; +: (reloff) ( taddr -- ) bit$ @ swap cell/ -bit ; + +: (>image) ( taddr -- absaddr ) image @ + ; + +DEFER >image +DEFER relon +DEFER reloff +DEFER correcter + +T has? relocate H +[IF] +' (relon) IS relon +' (reloff) IS reloff +' (>image) IS >image +[ELSE] +' drop IS relon +' drop IS reloff +' (>regionimage) IS >image +[THEN] \ Target memory access 06oct92py @@ -599,13 +714,10 @@ CREATE Bittable 80 c, 40 c, 20 c, 10 c, \ see kernel.fs dup cfalign+ + ; ->CROSS -: >image ( taddr -- absaddr ) image @ + ; ->TARGET : @ ( taddr -- w ) >image S@ ; : ! ( w taddr -- ) >image S! ; -: c@ ( taddr -- char ) >image c@ ; -: c! ( char taddr -- ) >image c! ; +: c@ ( taddr -- char ) >image Sc@ ; +: c! ( char taddr -- ) >image Sc! ; : 2@ ( taddr -- x1 x2 ) T dup cell+ @ swap @ H ; : 2! ( x1 x2 taddr -- ) T swap over ! cell+ ! H ; @@ -615,21 +727,24 @@ CREATE Bittable 80 c, 40 c, 20 c, 10 c, : here ( -- there ) there ; : allot ( n -- ) tdp +! ; : , ( w -- ) T here H tcell T allot ! H T here drop H ; -: c, ( char -- ) T here 1 allot c! H ; -: align ( -- ) T here H align+ 0 ?DO bl T c, H LOOP ; +: c, ( char -- ) T here tchar allot c! H ; +: align ( -- ) T here H align+ 0 ?DO bl T c, tchar H +LOOP ; : cfalign ( -- ) - T here H cfalign+ 0 ?DO bl T c, H LOOP ; + T here H cfalign+ 0 ?DO bl T c, tchar H +LOOP ; -: A! dup relon T ! H ; -: A, ( w -- ) T here H relon T , H ; +: >address dup 0>= IF tbyte / THEN ; \ ?? jaw +: A! swap >address swap dup relon T ! H ; +: A, ( w -- ) >address T here H relon T , H ; >CROSS : tcmove ( source dest len -- ) \G cmove in target memory - bounds + tchar * bounds ?DO dup T c@ H I T c! H 1+ - LOOP drop ; + tchar +LOOP drop ; + +\ \ Load Assembler >TARGET H also Forth definitions \ ." asm: " order @@ -648,19 +763,40 @@ previous \ \ -------------------- Compiler Plug Ins 01aug97jaw +\ Compiler States + +Variable comp-state +0 Constant interpreting +1 Constant compiling +2 Constant resolving +3 Constant assembling + Defer lit, ( n -- ) Defer alit, ( n -- ) -Defer branch, ( target-addr -- ) -Defer ?branch, ( target-addr -- ) -Defer branchmark, ( -- branch-addr ) -Defer ?branchmark, ( -- branch-addr ) -Defer branchto, -Defer branchtoresolve, ( branch-addr -- ) -Defer branchfrom, ( -- ) -Defer branchtomark, ( -- target-addr ) + +Defer branch, ( target-addr -- ) \ compiles a branch +Defer ?branch, ( target-addr -- ) \ compiles a ?branch +Defer branchmark, ( -- branch-addr ) \ reserves room for a branch +Defer ?branchmark, ( -- branch-addr ) \ reserves room for a ?branch +Defer ?domark, ( -- branch-addr ) \ reserves room for a ?do branch +Defer branchto, ( -- ) \ actual program position is target of a branch (do e.g. alignment) +Defer branchtoresolve, ( branch-addr -- ) \ resolves a forward reference from branchmark +Defer branchfrom, ( -- ) \ ?! +Defer branchtomark, ( -- target-addr ) \ marks a branch destination + Defer colon, ( tcfa -- ) \ compiles call to tcfa at current position +Defer colonmark, ( -- addr ) \ marks a colon call Defer colon-resolve ( tcfa addr -- ) + Defer addr-resolve ( target-addr addr -- ) +Defer doer-resolve ( ghost res-pnt target-addr addr -- ghost res-pnt ) + +Defer do, ( -- do-token ) +Defer ?do, ( -- ?do-token ) +Defer for, ( -- for-token ) +Defer loop, ( do-token / ?do-token -- ) +Defer +loop, ( do-token / ?do-token -- ) +Defer next, ( for-token ) [IFUNDEF] ca>native defer ca>native @@ -671,8 +807,8 @@ DEFER >body \ we need the sy \ and the target >body >CROSS T 2 cells H VALUE xt>body -DEFER doprim, -DEFER docol, \ compiles start of definition and doer +DEFER doprim, \ compiles start of a primitive +DEFER docol, \ compiles start of a colon definition DEFER doer, DEFER fini, \ compiles end of definition ;s DEFER doeshandler, @@ -681,9 +817,21 @@ DEFER dodoes, DEFER ]comp \ starts compilation DEFER comp[ \ ends compilation -: (cc) T a, H ; ' (cc) IS colon, -: (cr) >tempdp ]comp colon, comp[ tempdp> ; ' (cr) IS colon-resolve -: (ar) T ! H ; ' (ar) IS addr-resolve +: (cc) T a, H ; ' (cc) IS colon, + +: (cr) >tempdp ]comp colon, comp[ tempdp> ; ' (cr) IS colon-resolve +: (ar) T ! H ; ' (ar) IS addr-resolve +: (dr) ( ghost res-pnt target-addr addr ) + >tempdp drop over + dup >magic @ = + IF doer, + ELSE dodoes, + THEN + tempdp> ; ' (dr) IS doer-resolve + +: (cm) ( -- addr ) + T here align H + -1 colon, ; ' (cm) IS colonmark, >TARGET : compile, colon, ; @@ -691,16 +839,22 @@ DEFER comp[ \ ends compilation \ file loading +: >fl-id 1 cells + ; +: >fl-name 2 cells + ; + Variable filelist 0 filelist ! -0 Value loadfile +Create NoFile ," #load-file#" +0 Value filemem +: loadfile FileMem ?dup IF >fl-name ELSE NoFile THEN ; -0 [IF] \ !! JAW WIP +1 [IF] \ !! JAW WIP : add-included-file ( adr len -- ) - dup 2 cells + allocate throw >r - r@ 1 cells + dup TO loadfile place + dup char+ >fl-name allocate throw >r + r@ >fl-name place filelist @ r@ ! - r> filelist ! ; + r> dup filelist ! to FileMem + ; : included? ( c-addr u -- f ) filelist @@ -712,8 +866,10 @@ Variable filelist 0 filelist ! 2drop drop false ; : included - cr ." Including: " 2dup type ." ..." - 2dup add-included-file included ; +\ cr ." Including: " 2dup type ." ..." + FileMem >r + 2dup add-included-file included + r> to FileMem ; : include bl word count included ; @@ -724,17 +880,37 @@ Variable filelist 0 filelist ! \ resolve structure : >next ; \ link to next field -: >tag cell+ ; \ indecates type of reference: 0: call, 1: address +: >tag cell+ ; \ indecates type of reference: 0: call, 1: address, 2: doer : >taddr cell+ cell+ ; : >ghost 3 cells + ; : >file 4 cells + ; : >line 5 cells + ; +: (refered) ( ghost addr tag -- ) +\G creates a reference to ghost at address taddr + rot >r here r@ >link @ , r> >link ! + ( taddr tag ) , + ( taddr ) , + last-header-ghost @ , + loadfile , + sourceline# , + ; + : refered ( ghost tag -- ) \G creates a resolve structure - swap >r here r@ >link @ , r@ >link ! ( tag ) , - T here aligned H , r> drop last-header-ghost @ , - loadfile , sourceline# , + T here aligned H swap (refered) + ; + +: killref ( addr ghost -- ) +\G kills a forward reference to ghost at position addr +\G this is used to eleminate a :dovar refence after making a DOES> + dup >magic @ <> IF 2drop EXIT THEN + swap >r >link + BEGIN dup @ dup ( addr last this ) + WHILE dup >taddr @ r@ = + IF @ over ! + ELSE nip THEN + REPEAT rdrop 2drop ; Defer resolve-warning @@ -750,16 +926,20 @@ Defer resolve-warning \ resolve 14oct92py - : resolve-loop ( ghost tcfa -- ghost tcfa ) - >r dup >link - BEGIN @ dup WHILE - resolve-warning - r@ over >taddr @ - 2 pick >tag @ - IF addr-resolve - ELSE colon-resolve - THEN - REPEAT drop r> ; + : resolve-loop ( ghost resolve-list tcfa -- ) + >r + BEGIN dup WHILE +\ dup >tag @ 2 = IF reswarn-forward THEN + resolve-warning + r@ over >taddr @ + 2 pick >tag @ + CASE 0 OF colon-resolve ENDOF + 1 OF addr-resolve ENDOF + 2 OF doer-resolve ENDOF + ENDCASE + @ \ next list element + REPEAT 2drop rdrop + ; \ : resolve-loop ( ghost tcfa -- ghost tcfa ) \ >r dup >link @ @@ -786,17 +966,27 @@ Exists-Warnings on THEN ; : resolve ( ghost tcfa -- ) -\ resolve referencies to ghost with tcfa - over forward? 0= IF exists EXIT THEN - resolve-loop over >link ! swap >magic ! - ['] noop IS resolve-warning +\G resolve referencies to ghost with tcfa + \ is ghost resolved?, second resolve means another definition with the + \ same name + over forward? 0= IF exists EXIT THEN + \ get linked-list + swap >r r@ >link @ swap \ ( list tcfa R: ghost ) + \ mark ghost as resolved + dup r@ >link ! r@ >magic ! + \ loop through forward referencies + r> -rot + comp-state @ >r Resolving comp-state ! + resolve-loop + r> comp-state ! + + ['] noop IS resolve-warning ; \ gexecute ghost, 01nov92py : is-forward ( ghost -- ) -\ >link dup @ there rot ! T A, H ; - 0 refered -1 colon, ; + colonmark, 0 (refered) ; \ compile space for call : is-resolved ( ghost -- ) >link @ colon, ; \ compile-call @@ -870,7 +1060,10 @@ VARIABLE ^imm ^imm @ ! ; : restrict 20 flag! ; -: isdoer last-header-ghost @ >magic ! ; +: isdoer +\G define a forth word as doer, this makes obviously only sence on +\G forth processors such as the PSC1000 + last-header-ghost @ >magic ! ; >CROSS \ ALIAS2 ansforth conform alias 9may93jaw @@ -890,7 +1083,7 @@ VARIABLE ^imm \ Target Document Creation (goes to crossdoc.fd) 05jul95py -s" doc/crossdoc.fd" r/w create-file throw value doc-file-id +s" ./doc/crossdoc.fd" r/w create-file throw value doc-file-id \ contains the file-id of the documentation file : T-\G ( -- ) @@ -975,10 +1168,16 @@ Defer skip? ' false IS skip? \ Target header creation +Variable CreateFlag +CreateFlag off -VARIABLE CreateFlag CreateFlag off +Variable NoHeaderFlag +NoHeaderFlag off -: 0.r ( n1 n2 -- ) 0 swap <# 0 ?DO # LOOP #> type ; +: 0.r ( n1 n2 -- ) + base @ >r hex + 0 swap <# 0 ?DO # LOOP #> type + r> base ! ; : .sym bounds DO I c@ dup @@ -986,30 +1185,40 @@ VARIABLE CreateFlag CreateFlag off '\ OF drop ." \\" ENDOF dup OF emit ENDOF ENDCASE - LOOP ; + LOOP ; : (Theader ( "name" -- ghost ) -\ >in @ bl word count type 2 spaces >in ! -\ wordheaders will always be compiled to rom - switchrom - T align H view, - tlast @ dup 0> IF T 1 cells - THEN A, H there tlast ! - 1 headers-named +! \ Statistic - >in @ T name, H >in ! T here H tlastcfa ! - \ Symbol table - \ >in @ cr ." sym:s/CFA=" there 4 0.r ." /" bl word count .sym ." /g" cr >in ! - CreateFlag @ IF - >in @ alias2 swap >in ! \ create alias in target - >in @ ghost swap >in ! - swap also ghosts ' previous swap ! \ tick ghost and store in alias - CreateFlag off - ELSE ghost THEN - dup Last-Header-Ghost ! - dup >magic ^imm ! \ a pointer for immediate - Already @ IF dup >end tdoes ! - ELSE 0 tdoes ! THEN - 80 flag! - cross-doc-entry cross-tag-entry ; + \ >in @ bl word count type 2 spaces >in ! + \ wordheaders will always be compiled to rom + switchrom + \ build header in target + NoHeaderFlag @ + IF NoHeaderFlag off + ELSE + T align H view, + tlast @ dup 0> IF T 1 cells - H THEN T A, H there tlast ! + 1 headers-named +! \ Statistic + >in @ T name, H >in ! + THEN + T cfalign here H tlastcfa ! + \ Symbol table +\ >in @ cr ." sym:s/CFA=" there 4 0.r ." /" bl word count .sym ." /g" cr >in ! + CreateFlag @ + IF + >in @ alias2 swap >in ! \ create alias in target + >in @ ghost swap >in ! + swap also ghosts ' previous swap ! \ tick ghost and store in alias + CreateFlag off + ELSE ghost + THEN + dup Last-Header-Ghost ! + dup >magic ^imm ! \ a pointer for immediate + Already @ + IF dup >end tdoes ! + ELSE 0 tdoes ! + THEN + 80 flag! + cross-doc-entry cross-tag-entry ; VARIABLE ;Resolve 1 cells allot \ this is the resolver information from ":" @@ -1033,6 +1242,11 @@ VARIABLE ;Resolve 1 cells allot .sourcepos ." needs doer: " >in @ bl word count type >in ! cr THEN ghost tuck swap resolve swap >magic ! ; + +Variable prim# +: first-primitive ( n -- ) prim# ! ; +: Primitive ( -- ) \ name + prim# @ T Alias H -1 prim# +! ; >CROSS \ Conditionals and Comments 11may93jaw @@ -1095,7 +1309,7 @@ Cond: ['] T ' H alit, ;Cond \ modularized 14jun97jaw : fillcfa ( usedcells -- ) - T cells H xt>body swap - 0 ?DO 0 T c, H LOOP ; + T cells H xt>body swap - 0 ?DO 0 T c, tchar H +LOOP ; : (>body) ( cfa -- pfa ) xt>body + ; ' (>body) T IS >body H @@ -1116,7 +1330,13 @@ Cond: ['] T ' H alit, ;Cond : (lit,) ( n -- ) compile lit T , H ; ' (lit,) IS lit, -: (alit,) ( n -- ) lit, T here cell - H relon ; ' (alit,) IS alit, +\ if we dont produce relocatable code alit, defaults to lit, jaw +has? relocate +[IF] +: (alit,) ( n -- ) compile lit T a, H ; ' (alit,) IS alit, +[ELSE] +: (alit,) ( n -- ) lit, ; ' (alit,) IS alit, +[THEN] : (fini,) compile ;s ; ' (fini,) IS fini, @@ -1145,7 +1365,7 @@ Defer (end-code) ELSE true ABORT" CROSS: Stack empty" THEN ; -Cond: chars ;Cond +( Cond ) : chars tchar * ; ( Cond ) >CROSS @@ -1210,6 +1430,7 @@ Cond: MAXI \ ] 9may93py/jaw : ] state on + Compiling comp-state ! BEGIN BEGIN >in @ bl word dup c@ 0= WHILE 2drop refill 0= @@ -1254,15 +1475,22 @@ Cond: ; ( -- ) restrict? state off ;Resolve @ IF ;Resolve @ ;Resolve cell+ @ resolve THEN + Interpreting comp-state ! ;Cond -Cond: [ restrict? state off ;Cond +Cond: [ restrict? state off Interpreting comp-state ! ;Cond >CROSS + +Create GhostDummy ghostheader + GhostDummy >magic ! + : !does ( does-action -- ) \ !! zusammenziehen und dodoes, machen! - tlastcfa @ dup there >r tdp ! compile :dodoes r> tdp ! T cell+ ! H ; + tlastcfa @ [G'] :dovar killref +\ tlastcfa @ dup there >r tdp ! compile :dodoes r> tdp ! T cell+ ! H ; \ !! geht so nicht, da dodoes, ghost will! -\ tlastcfa @ >tempdp dodoes, tempdp> ; + GhostDummy >link ! GhostDummy + tlastcfa @ >tempdp dodoes, tempdp> ; >TARGET Cond: DOES> restrict? @@ -1284,7 +1512,10 @@ Cond: DOES> restrict? \ for do:-xt an additional entry after the normal ghost-enrys is used >in @ alias2 swap dup >in ! >r >r - Make-Ghost rot swap >exec ! , + Make-Ghost + rot swap >exec dup @ ['] NoExec <> + IF 2drop ELSE ! THEN + , r> r> >in ! also ghosts ' previous swap ! ; \ DOES> dup >exec @ execute ; @@ -1294,12 +1525,16 @@ Cond: DOES> restrict? >end @ dup forward? 0= IF dup >magic @ = - IF doer, EXIT THEN + IF doer, + ELSE dodoes, + THEN + EXIT THEN \ compile :dodoes gexecute \ T here H tcell - reloff - dodoes, -; + 2 refered + 0 fillcfa + ; : TCreate ( -- ) executed-ghost @ @@ -1384,7 +1619,7 @@ by: :dovar ( ghost -- addr ) ;DO Builder Create T has? rom H [IF] -Build: ( n -- ) T here 0 , H switchram T align here swap ! 0 , H ( switchrom ) ; +Build: ( -- ) T here 0 , H switchram T align here swap ! 0 , H ( switchrom ) ; by (Constant) Builder Variable [ELSE] @@ -1394,7 +1629,17 @@ Builder Variable [THEN] T has? rom H [IF] -Build: ( n -- ) T here 0 , H switchram T align here swap ! 0 , H ( switchrom ) ; +Build: ( -- ) T here 0 , H switchram T align here swap ! 0 , 0 , H ( switchrom ) ; +by (Constant) +Builder 2Variable +[ELSE] +Build: T 0 , 0 , H ; +by Create +Builder 2Variable +[THEN] + +T has? rom H [IF] +Build: ( -- ) T here 0 , H switchram T align here swap ! 0 , H ( switchrom ) ; by (Constant) Builder AVariable [ELSE] @@ -1471,75 +1716,6 @@ Builder Field \ ' 2Constant Alias2 end-struct \ 0 1 T Chars H 2Constant struct -0 [IF] - -\ structural conditionals 17dec92py - ->CROSS -: ?struc ( flag -- ) ABORT" CROSS: unstructured " ; -: sys? ( sys -- sys ) dup 0= ?struc ; -: >mark ( -- sys ) T here ( dup ." M" hex. ) 0 , H ; - -: branchoffset ( src dest -- ) - ; -: >resolve ( sys -- ) T here ( dup ." >" hex. ) over branchoffset swap ! H ; -: TARGET - -\ Structural Conditionals 12dec92py - -Cond: BUT restrict? sys? swap ;Cond -Cond: YET restrict? sys? dup ;Cond - ->CROSS -Variable tleavings ->TARGET - -Cond: DONE ( addr -- ) restrict? tleavings @ - BEGIN 2dup u> 0= WHILE dup T @ H swap >resolve REPEAT - tleavings ! drop ;Cond - ->CROSS -: (leave T here H tleavings @ T , H tleavings ! ; ->TARGET - -Cond: LEAVE restrict? compile branch (leave ;Cond -Cond: ?LEAVE restrict? compile 0= compile ?branch (leave ;Cond - -\ Structural Conditionals 12dec92py - -Cond: AHEAD restrict? compile branch >mark ;Cond -Cond: IF restrict? compile ?branch >mark ;Cond -Cond: THEN restrict? sys? branchto, dup T @ H ?struc >resolve ;Cond -Cond: ELSE restrict? sys? compile AHEAD swap compile THEN ;Cond - -Cond: BEGIN restrict? T branchto, here ( dup ." B" hex. ) H ;Cond -Cond: WHILE restrict? sys? compile IF swap ;Cond -Cond: AGAIN restrict? sys? compile branch r compile over compile = - compile IF compile drop r> ;Cond -Cond: ENDOF restrict? >r compile ELSE r> ;Cond -Cond: ENDCASE restrict? compile drop 0 ?DO compile THEN LOOP ;Cond - -\ Structural Conditionals 12dec92py - -Cond: DO restrict? compile (do) T here H ;Cond -Cond: ?DO restrict? compile (?do) T (leave here H ;Cond -Cond: FOR restrict? compile (for) T here H ;Cond - ->CROSS -: loop] dup TARGET - -Cond: LOOP restrict? sys? compile (loop) loop] ;Cond -Cond: +LOOP restrict? sys? compile (+loop) loop] ;Cond -Cond: NEXT restrict? sys? compile (next) loop] ;Cond - -[ELSE] - \ structural conditionals 17dec92py >CROSS @@ -1547,18 +1723,26 @@ Cond: NEXT restrict? sys? compile ( : sys? ( sys -- sys ) dup 0= ?struc ; : >mark ( -- sys ) T here ( dup ." M" hex. ) 0 , H ; -: branchoffset ( src dest -- ) - ; +: branchoffset ( src dest -- ) - tchar / ; \ ?? jaw : >resolve ( sys -- ) T here ( dup ." >" hex. ) over branchoffset swap ! H ; : TARGET @@ -1567,7 +1751,7 @@ Cond: NEXT restrict? sys? compile ( Cond: BUT restrict? sys? swap ;Cond Cond: YET restrict? sys? dup ;Cond -1 [IF] +0 [IF] >CROSS Variable tleavings >TARGET @@ -1577,11 +1761,11 @@ Cond: DONE ( addr -- ) restrict? tlea tleavings ! drop ;Cond >CROSS -: (leave T here H tleavings @ T , H tleavings ! ; +: (leave) T here H tleavings @ T , H tleavings ! ; >TARGET -Cond: LEAVE restrict? compile branch (leave ;Cond -Cond: ?LEAVE restrict? compile 0= compile ?branch (leave ;Cond +Cond: LEAVE restrict? compile branch (leave) ;Cond +Cond: ?LEAVE restrict? compile 0= compile ?branch (leave) ;Cond [ELSE] \ !! This is WIP @@ -1590,22 +1774,25 @@ Cond: ?LEAVE restrict? compile 0= co >CROSS Variable tleavings 0 tleavings ! +: (done) ( addr -- ) + tleavings @ + BEGIN dup + WHILE + >r dup r@ cell+ @ \ address of branch + u> 0= \ lower than DO? + WHILE + r@ 2 cells + @ \ branch token + branchtoresolve, + r@ @ r> free throw + REPEAT r> THEN + tleavings ! drop ; + >TARGET -Cond: DONE ( addr -- ) - restrict? tleavings @ - BEGIN dup - WHILE >r dup r@ cell+ @ \ address of branch - u> 0= \ lower than DO? - WHILE r@ 2 cells + @ \ branch token - branchtoresolve, - r@ @ r> free throw - REPEAT drop r> - THEN - tleavings ! drop ;Cond +Cond: DONE ( addr -- ) restrict? (done) ;Cond >CROSS -: (leave ( branchtoken -- ) +: (leave) ( branchtoken -- ) 3 cells allocate throw >r T here H r@ cell+ ! r@ 2 cells + ! @@ -1613,11 +1800,31 @@ Cond: DONE ( addr -- ) r> tleavings ! ; >TARGET -Cond: LEAVE restrict? branchmark, (leave ;Cond -Cond: ?LEAVE restrict? compile 0= ?branchmark, (leave ;Cond +Cond: LEAVE restrict? branchmark, (leave) ;Cond +Cond: ?LEAVE restrict? compile 0= ?branchmark, (leave) ;Cond [THEN] +>CROSS +\ !!JW ToDo : Move to general tools section + +: to1 ( x1 x2 xn n -- addr ) +\G packs n stack elements in a allocated memory region + dup dup 1+ cells allocate throw dup >r swap 1+ + 0 DO tuck ! cell+ LOOP + drop r> ; +: 1to ( addr -- x1 x2 xn ) +\G unpacks the elements saved by to1 + dup @ swap over cells + swap + 0 DO dup @ swap 1 cells - LOOP + free throw ; + +: loop] branchto, dup TARGET + \ Structural Conditionals 12dec92py >TARGET @@ -1640,19 +1847,37 @@ Cond: ENDCASE restrict? compile drop 0 \ Structural Conditionals 12dec92py -Cond: DO restrict? compile (do) T here H ;Cond -Cond: ?DO restrict? compile (?do) T (leave here H ;Cond -Cond: FOR restrict? compile (for) T here H ;Cond - ->CROSS -: loop] branchto, dup TARGET - -Cond: LOOP restrict? sys? compile (loop) loop] ;Cond -Cond: +LOOP restrict? sys? compile (+loop) loop] ;Cond -Cond: NEXT restrict? sys? compile (next) loop] ;Cond - -[THEN] +:noname \ ?? i think 0 is too much! jaw + 0 compile (do) + branchtomark, 2 to1 ; + IS do, ( -- target-addr ) + +\ :noname +\ compile 2dup compile = compile IF +\ compile 2drop compile ELSE +\ compile (do) branchtomark, 2 to1 ; +\ IS ?do, + +:noname + 0 compile (?do) ?domark, (leave) + branchtomark, 2 to1 ; + IS ?do, ( -- target-addr ) +:noname compile (for) branchtomark, ; + IS for, ( -- target-addr ) +:noname 1to compile (loop) loop] compile unloop skiploop] ; + IS loop, ( target-addr -- ) +:noname 1to compile (+loop) loop] compile unloop skiploop] ; + IS +loop, ( target-addr -- ) +:noname compile (next) loop] compile unloop ; + IS next, ( target-addr -- ) + +Cond: DO restrict? do, ;Cond +Cond: ?DO restrict? ?do, ;Cond +Cond: FOR restrict? for, ;Cond + +Cond: LOOP restrict? sys? loop, ;Cond +Cond: +LOOP restrict? sys? +loop, ;Cond +Cond: NEXT restrict? sys? next, ;Cond \ String words 23feb93py @@ -1663,7 +1888,7 @@ Cond: S" restrict? compile (S") Cond: ABORT" restrict? compile (ABORT") T ," H ;Cond Cond: IS T ' >body H compile ALiteral compile ! ;Cond -: IS T ' >body ! H ; +: IS T >address ' >body ! H ; Cond: TO T ' >body H compile ALiteral compile ! ;Cond : TO T ' >body ! H ; @@ -1694,21 +1919,70 @@ Cond: compile ( -- ) restrict? \ name 0> IF gexecute ELSE dup >magic @ = IF gexecute - ELSE compile (compile) gexecute THEN THEN ;Cond + ELSE compile (compile) addr, THEN THEN ;Cond Cond: postpone ( -- ) restrict? \ name bl word gfind dup 0= ABORT" CROSS: Can't compile" 0> IF gexecute ELSE dup >magic @ = IF gexecute - ELSE compile (compile) gexecute THEN THEN ;Cond - + ELSE compile (compile) addr, THEN THEN ;Cond + +\ \ minimal definitions + >MINIMAL also minimal \ Usefull words 13feb93py : KB 400 * ; +\ \ [IF] [ELSE] [THEN] ... 14sep97jaw + +\ it is useful to define our own structures and not to rely +\ on the words in the compiler +\ The words in the compiler might be defined with vocabularies +\ this doesn't work with our self-made compile-loop + +Create parsed 20 chars allot \ store word we parsed + +: upcase + parsed count bounds + ?DO I c@ toupper I c! LOOP ; + +: [ELSE] + 1 BEGIN + BEGIN bl word count dup WHILE + comment? parsed place upcase parsed count + 2dup s" [IF]" compare 0= >r + 2dup s" [IFUNDEF]" compare 0= >r + 2dup s" [IFDEF]" compare 0= r> or r> or + IF 2drop 1+ + ELSE 2dup s" [ELSE]" compare 0= + IF 2drop 1- dup + IF 1+ + THEN + ELSE + 2dup s" [ENDIF]" compare 0= >r + s" [THEN]" compare 0= r> or + IF 1- THEN + THEN + THEN + ?dup 0= ?EXIT + REPEAT + 2drop refill 0= + UNTIL drop ; immediate + +: [THEN] ( -- ) ; immediate + +: [ENDIF] ( -- ) ; immediate + +: [IF] ( flag -- ) + 0= IF postpone [ELSE] THEN ; immediate + +Cond: [IF] postpone [IF] ;Cond +Cond: [THEN] postpone [THEN] ;Cond +Cond: [ELSE] postpone [ELSE] ;Cond + \ define new [IFDEF] and [IFUNDEF] 20may93jaw : defined? defined? ; @@ -1727,6 +2001,10 @@ also minimal : [IFUNDEF] defined? 0= postpone [IF] ; +Cond: [IFDEF] postpone [IFDEF] ;Cond + +Cond: [IFUNDEF] postpone [IFUNDEF] ;Cond + \ C: \- \+ Conditional Compiling 09jun93jaw : C: >in @ defined? 0= @@ -1760,24 +2038,23 @@ Cond: \D \D ;Cond \G defines ghost for words that we want to be compiled BEGIN >in @ bl word c@ WHILE >in ! ghost drop REPEAT drop ; -: [IF] postpone [IF] ; -: [THEN] postpone [THEN] ; -: [ELSE] postpone [ELSE] ; - -Cond: [IF] [IF] ;Cond -Cond: [IFDEF] [IFDEF] ;Cond -Cond: [IFUNDEF] [IFUNDEF] ;Cond -Cond: [THEN] [THEN] ;Cond -Cond: [ELSE] [ELSE] ;Cond - previous \ save-cross 17mar93py >CROSS -Create magic s" Gforth10" here over allot swap move +Create magic s" Gforth2x" here over allot swap move -char 1 bigendian + tcell + magic 7 + c! +bigendian 1+ \ strangely, in magic big=0, little=1 +tcell 1 = 0 and or +tcell 2 = 2 and or +tcell 4 = 4 and or +tcell 8 = 6 and or +tchar 1 = $00 and or +tchar 2 = $28 and or +tchar 4 = $50 and or +tchar 8 = $78 and or +magic 7 + c! : save-cross ( "image-name" "binary-name" -- ) bl parse ." Saving to " 2dup type cr @@ -1806,7 +2083,7 @@ char 1 bigendian + tcell + magic 7 + c! : save-region ( addr len -- ) bl parse w/o bin create-file throw >r - swap image @ + swap r@ write-file throw + swap >image swap r@ write-file throw r> close-file throw ; \ words that should be in minimal @@ -1818,6 +2095,10 @@ also minimal bigendian Constant bigendian : here there ; +: equ constant ; +: mark there constant ; + +\ compiler directives : >ram >ram ; : >rom >rom ; : >auto >auto ; @@ -1825,7 +2106,8 @@ bigendian Constant bigendian : tempdp> tempdp> ; : const constflag on ; : warnings name 3 = 0= twarnings ! drop ; - +: | ; +\ : | NoHeaderFlag on ; \ This is broken (damages the last word) : save-cross save-cross ; : save-region save-region ;