--- gforth/cross.fs 1999/08/29 21:44:45 1.81 +++ 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~+ @@ -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 @@ -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 @@ -1514,7 +1515,9 @@ variable ResolveFlag >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 @@ -1536,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 @@ -1651,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 @@ -1674,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 @ @@ -1797,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] @@ -2191,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 @@ -2383,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 @@ -2560,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)