--- gforth/cross.fs 1999/01/10 22:00:22 1.65 +++ gforth/cross.fs 1999/05/17 13:12:25 1.76 @@ -1,7 +1,7 @@ \ CROSS.FS The Cross-Compiler 06oct92py \ Idea and implementation: Bernd Paysan (py) -\ Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc. +\ Copyright (C) 1995,1996,1997,1998,1999 Free Software Foundation, Inc. \ This file is part of Gforth. @@ -19,32 +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 -\ environmental query support 01sep97jaw -\ added own [IF] ... [ELSE] ... [THEN] 14sep97jaw -\ extra resolver for doers 20sep97jaw -\ added killref for DOES> 20sep97jaw +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 !! @@ -67,9 +52,14 @@ Warnings off \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 ['] to execute 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 + ELSE Value THEN ; : DefaultValue ( n -- ) \G Same behaviour as "Value" if the is not defined @@ -128,9 +118,6 @@ also forth definitions \ these values m false DefaultValue stack-warn \ check on empty stack at any definition false DefaultValue create-forward-warn \ warn on forward declaration of created words -[IFUNDEF] DebugMaskSrouce Variable DebugMaskSource 0 DebugMaskSource ! [THEN] -[IFUNDEF] DebugMaskCross Variable DebugMaskCross 0 DebugMaskCross ! [THEN] - previous >CROSS : .dec @@ -153,7 +140,46 @@ stack-warn [IF] : defempty? ; immediate [THEN] +\ debugging + +0 [IF] +This implements debugflags for the cross compiler and the compiled +images. It works identical to the has-flags in the environment. +The debugflags are defined in a vocabluary. If the word exists and +its value is true, the flag is switched on. + +[THEN] + +Vocabulary debugflags \ debug flags for cross +also debugflags get-order over +Constant debugflags-wl +set-order previous + +: DebugFlag + get-current >r debugflags-wl set-current + SetValue + r> set-current ; + +: Debug? ( adr u -- flag ) +\G return true if debug flag is defined or switched on + debugflags-wl search-wordlist + IF EXECUTE + ELSE false THEN ; + +: D? ( -- flag ) +\G return true if debug flag is defined or switched on +\G while compiling we do not return the current value but + bl word count debug? ; + +: [d?] +\G compile the value-xt so the debug flag can be switched +\G the flag must exist! + bl word count debugflags-wl search-wordlist + IF compile, + ELSE -1 ABORT" unknown debug flag" + \ POSTPONE false + THEN ; immediate \ \ GhostNames Ghosts 9may93jaw @@ -181,13 +207,14 @@ VARIABLE VocTemp hex 4711 Constant 4712 Constant 4713 Constant 4714 Constant +4715 Constant \ iForth makes only immediate directly after create \ make atonce trick! ? Variable atonce atonce off -: NoExec true ABORT" CROSS: Don't execute ghost" ; +: NoExec true ABORT" CROSS: Don't execute ghost, or immediate target word" ; : GhostHeader , 0 , ['] NoExec , ; @@ -232,7 +259,7 @@ VARIABLE Already : ghost ( "name" -- ghost ) Already off - >in @ bl word gfind IF Already on nip EXIT THEN + >in @ bl word gfind IF atonce off Already on nip EXIT THEN drop >in ! Make-Ghost ; : >ghostname ( ghost -- adr len ) @@ -250,6 +277,9 @@ VARIABLE Already : forward? ( ghost -- flag ) >magic @ = ; +: undefined? ( ghost -- flag ) + >magic @ dup = swap = or ; + \ Predefined ghosts 12dec92py ghost 0= drop @@ -282,17 +312,16 @@ 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 - false true ABORT" arg" + false \ debug true ABORT" arg" THEN ; : $has? T environment? H IF ELSE false THEN ; @@ -325,6 +354,7 @@ false DefaultValue header true DefaultValue interpreter true DefaultValue ITC false DefaultValue rom +true DefaultValue standardthreading >TARGET s" relocate" T environment? H @@ -336,17 +366,43 @@ s" relocate" T environment? H \ \ Create additional parameters 19jan95py -1 8 lshift Constant maxbyte +\ 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 -bits/byte 8 / Constant tchar -float Constant tfloat -1 bits/byte lshift Constant tmaxbyte +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 @@ -361,31 +417,12 @@ Variable bit$ Variable headers-named 0 headers-named ! Variable user-vars 0 user-vars ! -\ Memory initialisation 05dec92py +: target>bitmask-size ( u1 -- u2 ) + 1- tcell>bit rshift 1+ ; -[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 - -: makekernel ( targetsize -- targetsize ) - bit$ over 1- tcell>bit rshift 1+ initmem - image over initmem ; - ->MINIMAL -: makekernel makekernel ; - - ->CROSS +: allocatetarget ( size --- adr ) + dup allocate ABORT" CROSS: No memory for target" + swap over swap erase ; \ \ memregion.fs @@ -396,6 +433,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 ; @@ -409,27 +450,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 @@ -443,18 +485,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 ; @@ -486,10 +529,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 @@ -498,9 +541,36 @@ T has? rom H ELSE dictionary area THEN - dup 0= + nip 0= ABORT" CROSS: define at least address-space or dictionary!!" - + makekernel drop ; + + \ 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 @@ -536,16 +606,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 ! ; @@ -561,7 +635,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 @@ -575,8 +649,8 @@ variable constflag constflag off : cell+ tcell + ; : cells tcell<< lshift ; -: chars ; -: char+ 1 + ; +: chars tchar * ; +: char+ tchar + ; : floats tfloat * ; >CROSS @@ -608,7 +682,32 @@ bigendian 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, @@ -617,8 +716,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 @@ -636,9 +754,6 @@ 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 Sc@ ; @@ -653,11 +768,11 @@ CREATE Bittable 80 c, 40 c, 20 c, 10 c, : allot ( n -- ) tdp +! ; : , ( w -- ) T here H tcell T allot ! H T here drop H ; : c, ( char -- ) T here tchar allot c! H ; -: align ( -- ) T here H align+ 0 ?DO bl T c, H LOOP ; +: align ( -- ) T here H align+ 0 ?DO bl T c, tchar H +LOOP ; : cfalign ( -- ) T here H cfalign+ 0 ?DO bl T c, tchar H +LOOP ; -: >address dup 0>= IF tchar / THEN ; +: >address dup 0>= IF tbyte / THEN ; \ ?? jaw : A! swap >address swap dup relon T ! H ; : A, ( w -- ) >address T here H relon T , H ; @@ -669,8 +784,10 @@ CREATE Bittable 80 c, 40 c, 20 c, 10 c, ?DO dup T c@ H I T c! H 1+ tchar +LOOP drop ; +\ \ Load Assembler + >TARGET -H also Forth definitions \ ." asm: " order +H also Forth definitions : X also target bl word find IF state @ IF compile, @@ -766,8 +883,9 @@ DEFER comp[ \ ends compilation : >fl-name 2 cells + ; Variable filelist 0 filelist ! +Create NoFile ," #load-file#" 0 Value filemem -: loadfile filemem >fl-name ; +: loadfile FileMem ?dup IF >fl-name ELSE NoFile THEN ; 1 [IF] \ !! JAW WIP @@ -787,8 +905,11 @@ Variable filelist 0 filelist ! REPEAT 2drop drop false ; +false DebugFlag showincludedfiles + : included -\ cr ." Including: " 2dup type ." ..." + [d?] showincludedfiles + IF cr ." Including: " 2dup type ." ..." THEN FileMem >r 2dup add-included-file included r> to FileMem ; @@ -891,7 +1012,7 @@ Exists-Warnings on \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 + over undefined? 0= IF exists EXIT THEN \ get linked-list swap >r r@ >link @ swap \ ( list tcfa R: ghost ) \ mark ghost as resolved @@ -1068,7 +1189,18 @@ Create tag-bof 1 c, 0C c, Defer skip? ' false IS skip? +: skipdef ( -- ) +\G skip definition of an undefined word in undef-words mode + ghost dup forward? + IF >magic swap ! + ELSE drop THEN ; + : defined? ( -- flag ) \ name + ghost undefined? 0= ; + +: defined2? ( -- flag ) \ name +\G return true for anything else than forward, even for +\G that's what we want ghost forward? 0= ; : needed? ( -- flag ) \ name @@ -1077,7 +1209,7 @@ Defer skip? ' false IS skip? \G a forward reference exists \G so the definition is not skipped! bl word gfind - IF dup forward? + IF dup undefined? nip 0= ELSE drop true THEN ; @@ -1126,8 +1258,12 @@ NoHeaderFlag off \ Symbol table \ >in @ cr ." sym:s/CFA=" there 4 0.r ." /" bl word count .sym ." /g" cr >in ! CreateFlag @ - IF + IF \ for a created word we need also a definition in target + \ to execute the created word while compile time + \ dont mind if a alias is defined twice + Warnings @ >r Warnings off >in @ alias2 swap >in ! \ create alias in target + r> Warnings ! >in @ ghost swap >in ! swap also ghosts ' previous swap ! \ tick ghost and store in alias CreateFlag off @@ -1210,7 +1346,7 @@ Comment ( Comment \ THEN ; immediate : ghost>cfa - dup forward? ABORT" CROSS: forward " >link @ ; + dup undefined? ABORT" CROSS: forward " >link @ ; >TARGET @@ -1252,7 +1388,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, @@ -1438,7 +1580,7 @@ Cond: DOES> restrict? : gdoes, ( ghost -- ) \ makes the codefield for a word that is built - >end @ dup forward? 0= + >end @ dup undefined? 0= IF dup >magic @ = IF doer, @@ -1639,7 +1781,7 @@ Builder Field : sys? ( sys -- sys ) dup 0= ?struc ; : >mark ( -- sys ) T here ( dup ." M" hex. ) 0 , H ; -: branchoffset ( src dest -- ) - tchar / ; +: branchoffset ( src dest -- ) - tchar / ; \ ?? jaw : >resolve ( sys -- ) T here ( dup ." >" hex. ) over branchoffset swap ! H ; @@ -1763,7 +1905,7 @@ Cond: ENDCASE restrict? compile drop 0 \ Structural Conditionals 12dec92py -:noname +:noname \ ?? i think 0 is too much! jaw 0 compile (do) branchtomark, 2 to1 ; IS do, ( -- target-addr ) @@ -1804,7 +1946,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 ; @@ -1935,8 +2077,10 @@ Cond: [IFUNDEF] postpone [IFUNDEF] ;Cond also minimal -\G doesn't skip line when bit is set in debugmask -: \D name evaluate debugmasksource @ and 0= IF postpone \ THEN ; +: d? d? ; + +\G doesn't skip line when debug switch is on +: \D D? 0= IF postpone \ THEN ; \G interprets the line if word is not defined : \- defined? IF postpone \ THEN ; @@ -1999,7 +2143,7 @@ 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 @@ -2011,6 +2155,8 @@ also minimal bigendian Constant bigendian : here there ; +: equ constant ; +: mark there constant ; \ compiler directives : >ram >ram ; @@ -2058,7 +2204,8 @@ previous : all-words ['] false IS skip? ; : needed-words ['] needed? IS skip? ; -: undef-words ['] defined? IS skip? ; +: undef-words ['] defined2? IS skip? ; +: skipdef skipdef ; : \ postpone \ ; immediate : \G T-\G ; immediate @@ -2104,7 +2251,7 @@ minimal \ these ones are pefered: : lock turnkey ; -: unlock forth also cross ; +: unlock previous forth also cross ; : [[ also unlock ; : ]] previous previous ;