--- gforth/cross.fs 1999/05/18 14:38:49 1.78 +++ gforth/cross.fs 2001/09/04 11:09:59 1.102 @@ -1,7 +1,7 @@ \ CROSS.FS The Cross-Compiler 06oct92py \ Idea and implementation: Bernd Paysan (py) -\ Copyright (C) 1995,1996,1997,1998,1999 Free Software Foundation, Inc. +\ Copyright (C) 1995,1996,1997,1998,1999,2000 Free Software Foundation, Inc. \ This file is part of Gforth. @@ -17,7 +17,7 @@ \ You should have received a copy of the GNU General Public License \ along with this program; if not, write to the Free Software -\ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +\ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA. 0 [IF] @@ -474,27 +474,17 @@ Create tfile 0 c, 255 chars allot THEN ; : compact.. ( adr len -- adr2 len2 ) -\ deletes phrases like "xy/.." out of our directory name 2dec97jaw - over >r -1 >r - BEGIN dup WHILE - over c@ pathsep? - IF r@ -1 = - IF r> drop dup >r - ELSE 2dup 1 /string - 3 min s" ../" compare - 0= - IF r@ over - ( diff ) - 2 pick swap - ( dest-adr ) - >r 3 /string r> swap 2dup >r >r - move r> r> - ELSE r> drop dup >r - THEN - THEN - THEN - 1 /string - REPEAT - r> drop - drop r> tuck - ; + \ deletes phrases like "xy/.." out of our directory name 2dec97jaw + over swap + BEGIN dup WHILE + dup >r '/ scan 2dup 4 min s" /../" compare 0= + IF + dup r> - >r 4 /string over r> + 4 - + swap 2dup + >r move dup r> over - + ELSE + rdrop dup 1 min /string + THEN + REPEAT drop over - ; : reworkdir ( -- ) remove~+ @@ -646,7 +636,7 @@ VARIABLE GhostNames 0 GhostNames ! : GhostName ( -- addr ) - here GhostNames @ , GhostNames ! here 0 , + align here GhostNames @ , GhostNames ! here 0 , bl word count \ 2dup type space string, \ !! cfalign ? @@ -787,7 +777,7 @@ VARIABLE env-current \ save information >ENVIRON get-order get-current swap 1+ set-order true SetValue compiler -true SetValue cross +true SetValue cross true SetValue standard-threading >TARGET previous @@ -864,7 +854,7 @@ float Constant tfloat bits/byte Constant tbits/byte [THEN] H -tbits/byte bits/byte / Constant tbyte +tbits/char bits/byte / Constant tbyte \ Variables 06oct92py @@ -927,7 +917,7 @@ Variable mirrored-link \ linked dup >rstart @ swap >rdp @ over - ; : area ( region -- startaddr totallen ) \G returns the total area - dup >rstart swap >rlen @ ; + dup >rstart @ swap >rlen @ ; : mirrored \G mark a region as mirrored mirrored-link @@ -1180,8 +1170,19 @@ CREATE Bittable 80 c, 40 c, 20 c, 10 c, : +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 -- ) + [ [IFDEF] fd-relocation-table ] + s" +" fd-relocation-table write-file throw + dup s>d <# #s #> fd-relocation-table write-line throw + [ [THEN] ] + bit$ @ swap cell/ +bit ; + +: (reloff) ( taddr -- ) + [ [IFDEF] fd-relocation-table ] + s" -" fd-relocation-table write-file throw + dup s>d <# #s #> fd-relocation-table write-line throw + [ [THEN] ] + bit$ @ swap cell/ -bit ; : (>image) ( taddr -- absaddr ) image @ + ; @@ -1222,7 +1223,7 @@ T has? relocate H : 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 ; +: 2! ( x1 x2 taddr -- ) T tuck ! cell+ ! H ; \ Target compilation primitives 06oct92py \ included A! 16may93jaw @@ -1489,7 +1490,6 @@ variable ResolveFlag ELSE drop THEN ; ->MINIMAL : .unresolved ( -- ) ResolveFlag off cr ." Unresolved: " Ghostnames @@ -1508,10 +1508,16 @@ variable ResolveFlag cr ." named Headers: " headers-named @ . r> base ! ; +>MINIMAL + +: .unresolved .unresolved ; + >CROSS \ Header states 12dec92py -: flag! ( 8b -- ) tlast @ dup >r T c@ xor r> c! H ; +\ : flag! ( 8b -- ) tlast @ dup >r T c@ xor r> c! H ; +bigendian [IF] 0 [ELSE] tcell 1- [THEN] Constant flag+ +: flag! ( w -- ) tlast @ flag+ + dup >r T c@ xor r> c! H ; VARIABLE ^imm @@ -1533,7 +1539,11 @@ VARIABLE ^imm >TARGET : string, ( addr count -- ) dup T c, H bounds ?DO I c@ T c, H LOOP ; -: name, ( "name" -- ) bl word count T string, cfalign H ; + +: lstring, ( addr count -- ) + dup T , H bounds ?DO I c@ T c, H LOOP ; + +: name, ( "name" -- ) bl word count T lstring, cfalign H ; : view, ( -- ) ( dummy ) ; >CROSS @@ -1604,7 +1614,8 @@ Create tag-bof 1 c, 0C c, Defer skip? ' false IS skip? : skipdef ( -- ) -\G skip definition of an undefined word in undef-words mode +\G skip definition of an undefined word in undef-words and +\G all-words mode ghost dup forward? IF >magic swap ! ELSE drop THEN ; @@ -1617,6 +1628,10 @@ Defer skip? ' false IS skip? \G that's what we want ghost forward? 0= ; +: forced? ( -- flag ) \ name +\G return ture if it is a foreced skip with defskip + ghost >magic @ = ; + : needed? ( -- flag ) \ name \G returns a false flag when \G a word is not defined @@ -1643,7 +1658,9 @@ NoHeaderFlag off base @ >r hex 0 swap <# 0 ?DO # LOOP #> type r> base ! ; -: .sym + +: .sym ( adr len -- ) +\G escapes / and \ to produce sed output bounds DO I c@ dup CASE [char] / OF drop ." \/" ENDOF @@ -1666,9 +1683,15 @@ NoHeaderFlag off >in @ T name, H >in ! THEN T cfalign here H tlastcfa ! - \ Symbol table + \ Old Symbol table sed-script \ >in @ cr ." sym:s/CFA=" there 4 0.r ." /" bl word count .sym ." /g" cr >in ! ghost + \ output symbol table to extra file + [ [IFDEF] fd-symbol-table ] + base @ hex there s>d <# 8 0 DO # LOOP #> fd-symbol-table write-file throw base ! + s" :" fd-symbol-table write-file throw + dup >ghostname fd-symbol-table write-line throw + [ [THEN] ] dup Last-Header-Ghost ! dup >magic ^imm ! \ a pointer for immediate Already @ @@ -1789,7 +1812,9 @@ Cond: ['] T ' H alit, ;Cond : (lit,) ( n -- ) compile lit T , H ; ' (lit,) IS lit, \ if we dont produce relocatable code alit, defaults to lit, jaw -has? relocate +\ this is just for convenience, so we don't have to define alit, +\ seperately for embedded systems.... +T has? relocate H [IF] : (alit,) ( n -- ) compile lit T a, H ; ' (alit,) IS alit, [ELSE] @@ -2183,6 +2208,17 @@ Builder Field : cell% ( n -- size align ) T 1 cells H dup ; + +Build: ( m v -- m' v ) dup T , cell+ H ; +DO: abort" Not in cross mode" ;DO +Builder input-method + +Build: ( m v size -- m v' ) over T , H + ; +DO: abort" Not in cross mode" ;DO +Builder input-var + + + \ structural conditionals 17dec92py >CROSS @@ -2347,7 +2383,7 @@ Cond: defers T ' >body @ compile, H ;Con \ LINKED ERR" ENV" 2ENV" 18may93jaw \ linked list primitive -: linked T here over @ A, swap ! H ; +: linked X here over X @ X A, swap X ! ; : chained T linked A, H ; : err" s" ErrLink linked" evaluate T , H @@ -2375,6 +2411,13 @@ Cond: postpone ( -- ) restrict? \ name ELSE dup >magic @ = IF gexecute ELSE compile (compile) addr, THEN THEN ;Cond + +Cond: [compile] ( -- ) restrict? \ name + bl word gfind dup 0= ABORT" CROSS: Can't compile" + 0> IF gexecute + ELSE dup >magic @ = + IF gexecute + ELSE compile (compile) addr, THEN THEN ;Cond \ save-cross 17mar93py @@ -2398,9 +2441,9 @@ magic 7 + c! bl parse ." Saving to " 2dup type cr w/o bin create-file throw >r TNIL IF - s" #! " r@ write-file throw - bl parse r@ write-file throw - s" -i" r@ write-file throw + s" #! " r@ write-file throw + bl parse r@ write-file throw + s" --image-file" r@ write-file throw #lf r@ emit-file throw r@ dup file-position throw drop 8 mod 8 swap ( file-id limit index ) ?do @@ -2552,6 +2595,10 @@ bigendian Constant bigendian : tempdp> tempdp> ; : const constflag on ; : warnings name 3 = 0= twarnings ! drop ; +: redefinitions-start twarnings off ; +: redefinitions-end twarnings on ; +: group 0 word drop ; + : | ; \ : | NoHeaderFlag on ; \ This is broken (damages the last word) @@ -2587,7 +2634,7 @@ previous : 2/ 2/ ; : . . ; -: all-words ['] false IS skip? ; +: all-words ['] forced? IS skip? ; : needed-words ['] needed? IS skip? ; : undef-words ['] defined2? IS skip? ; : skipdef skipdef ;