--- gforth/cross.fs 2003/08/18 19:29:14 1.141 +++ gforth/cross.fs 2007/03/25 21:30:59 1.162 @@ -1,7 +1,7 @@ \ CROSS.FS The Cross-Compiler 06oct92py \ Idea and implementation: Bernd Paysan (py) -\ Copyright (C) 1995,1996,1997,1998,1999,2000,2003 Free Software Foundation, Inc. +\ Copyright (C) 1995,1996,1997,1998,1999,2000,2003,2004,2005,2006 Free Software Foundation, Inc. \ This file is part of Gforth. @@ -447,7 +447,7 @@ sourcepath value fpath \G Make a complete new Forth search path; the path separator is |. fpath path= ; -: path>counted cell+ dup cell+ swap @ ; +: path>string cell+ dup cell+ swap @ ; : next-path ( adr len -- adr2 len2 ) 2dup 0 scan @@ -456,12 +456,12 @@ sourcepath value fpath r> - ; : previous-path ( path^ -- ) - dup path>counted + dup path>string BEGIN tuck dup WHILE repeat ; : .path ( path-addr -- ) \ gforth \G Display the contents of the search path @var{path-addr}. - path>counted + path>string BEGIN next-path dup WHILE type space REPEAT 2drop 2drop ; : .fpath ( -- ) \ gforth @@ -546,7 +546,7 @@ Create tfile 0 c, 255 chars allot IF rdrop ofile place open-ofile dup 0= IF >r ofile count r> THEN EXIT - ELSE r> path>counted + ELSE r> path>string BEGIN next-path dup WHILE 5 pick 5 pick check-path 0= IF >r 2drop 2drop r> ofile count 0 EXIT ELSE drop THEN @@ -1175,6 +1175,7 @@ false DefaultValue header false DefaultValue backtrace false DefaultValue new-input false DefaultValue peephole +false DefaultValue primcentric false DefaultValue abranch true DefaultValue f83headerstring true DefaultValue control-rack @@ -1184,6 +1185,7 @@ true DefaultValue gforthcross true DefaultValue interpreter true DefaultValue ITC false DefaultValue rom +false DefaultValue flash true DefaultValue standardthreading \ ANSForth environment stuff @@ -1722,7 +1724,8 @@ Ghost (do) Ghost (?do) Ghost (for) drop Ghost (loop) Ghost (+loop) 2drop Ghost (next) drop -Ghost (does>) Ghost (compile) 2drop +Ghost (does>) Ghost (does>1) Ghost (does>2) 2drop drop +Ghost compile, drop Ghost (.") Ghost (S") Ghost (ABORT") 2drop drop Ghost (C") Ghost c(abort") Ghost type 2drop drop Ghost ' drop @@ -1750,7 +1753,11 @@ Ghost state drop swap -rot bounds ?DO I c@ over X c! X char+ LOOP drop ; 2Variable last-string +X has? rom [IF] $60 [ELSE] $00 [THEN] Constant header-masks +: ht-header, ( addr count -- ) + dup there swap last-string 2! + dup header-masks or T c, H bounds ?DO I c@ T c, H LOOP ; : ht-string, ( addr count -- ) dup there swap last-string 2! dup T c, H bounds ?DO I c@ T c, H LOOP ; @@ -1761,7 +1768,7 @@ Ghost state drop : count dup X c@ swap X char+ swap ; -: on -1 -1 rot TD! ; +: on >r -1 -1 r> TD! ; : off T 0 swap ! H ; : tcmove ( source dest len -- ) @@ -1770,6 +1777,9 @@ Ghost state drop ?DO dup T c@ H I T c! H 1+ tchar +LOOP drop ; +: tcallot ( char size -- ) + 0 ?DO dup T c, H tchar +LOOP drop ; + : td, ( d -- ) \G Store a host value as one cell into the target there tcell X allot TD! ; @@ -2026,7 +2036,7 @@ variable ResolveFlag \ Header states 12dec92py \ : flag! ( 8b -- ) tlast @ dup >r T c@ xor r> c! H ; -bigendian [IF] 0 [ELSE] tcell 1- [THEN] Constant flag+ +X has? f83headerstring bigendian or [IF] 0 [ELSE] tcell 1- [THEN] Constant flag+ : flag! ( w -- ) tlast @ flag+ + dup >r T c@ xor r> c! H ; VARIABLE ^imm @@ -2056,7 +2066,7 @@ $20 constant restrict-mask >TARGET X has? f83headerstring [IF] -: name, ( "name" -- ) bl word count ht-string, X cfalign ; +: name, ( "name" -- ) bl word count ht-header, X cfalign ; [ELSE] : name, ( "name" -- ) bl word count ht-lstring, X cfalign ; [THEN] @@ -2204,7 +2214,7 @@ NoHeaderFlag off ENDCASE LOOP ; -Defer setup-execution-semantics +Defer setup-execution-semantics ' noop IS setup-execution-semantics 0 Value lastghost : (THeader ( "name" -- ghost ) @@ -2569,7 +2579,7 @@ Cond: MAXI (THeader (:) ; : :noname ( -- colon-sys ) - X cfalign there + switchrom X cfalign there \ define a nameless ghost here ghostheader dup last-header-ghost ! dup to lastghost (:) ; @@ -2614,9 +2624,9 @@ Cond: [ ( -- ) interpreting-state ;Cond r@ created >do:ghost ! r@ swap resolve r> tlastcfa @ >tempdp dodoes, tempdp> ; -Defer instant-interpret-does>-hook +Defer instant-interpret-does>-hook ' noop IS instant-interpret-does>-hook -T has? peephole H [IF] +T has? primcentric H [IF] : does-resolved ( ghost -- ) compile does-exec g>xt T a, H ; [ELSE] @@ -2631,8 +2641,9 @@ T has? peephole H [IF] >TARGET Cond: DOES> - compile (does>) doeshandler, - resolve-does>-part + T here H [ T has? primcentric H [IF] ] 5 [ [ELSE] ] 4 [ [THEN] ] T cells + H + alit, compile (does>2) compile ;s + doeshandler, resolve-does>-part ;Cond : DOES> @@ -2821,7 +2832,7 @@ by Create : u, ( n -- udp ) current-region >r user-region activate - X here swap X , tup@ - + X here swap X , tup@ - r> activate ; : au, ( n -- udp ) @@ -2862,9 +2873,22 @@ by User [THEN] +T has? rom H [IF] Builder (Value) Build: ( n -- ) ;Build -by: :docon ( target-body-addr -- n ) T @ H ;DO +by: :dovalue ( target-body-addr -- n ) T @ @ H ;DO + +Builder Value +Build: T here 0 A, H switchram T align here swap ! , H ;Build +by (Value) + +Builder AValue +Build: T here 0 A, H switchram T align here swap ! A, H ;Build +by (Value) +[ELSE] +Builder (Value) +Build: ( n -- ) ;Build +by: :dovalue ( target-body-addr -- n ) T @ H ;DO Builder Value BuildSmart: T , H ;Build @@ -2873,12 +2897,18 @@ by (Value) Builder AValue BuildSmart: T A, H ;Build by (Value) +[THEN] Defer texecute Builder Defer -BuildSmart: ( -- ) [T'] noop T A, H ;Build -by: :dodefer ( ghost -- ) X @ texecute ;DO +T has? rom H [IF] + Build: ( -- ) T here 0 A, H switchram T align here swap ! H [T'] noop T A, H ( switchrom ) ;Build + by: :dodefer ( ghost -- ) X @ X @ texecute ;DO +[ELSE] + BuildSmart: ( -- ) [T'] noop T A, H ;Build + by: :dodefer ( ghost -- ) X @ texecute ;DO +[THEN] Builder interpret/compile: Build: ( inter comp -- ) swap T A, A, H ;Build-immediate @@ -2931,7 +2961,7 @@ DO: abort" Not in cross mode" ;DO \ optimizer for cross -T has? peephole H [IF] +T has? primcentric H [IF] \ .( loading peephole optimization) cr @@ -3211,10 +3241,19 @@ Cond: ABORT" if, ahead, there [char] >r then, r> compile ALiteral compile c(abort") then, ;Cond [THEN] +X has? rom [IF] +Cond: IS T ' >body @ H compile ALiteral compile ! ;Cond +: IS T >address ' >body @ ! H ; +Cond: TO T ' >body @ H compile ALiteral compile ! ;Cond +: TO T ' >body @ ! H ; +Cond: CTO T ' >body H compile ALiteral compile ! ;Cond +: CTO T ' >body ! H ; +[ELSE] Cond: IS T ' >body H compile ALiteral compile ! ;Cond : IS T >address ' >body ! H ; Cond: TO T ' >body H compile ALiteral compile ! ;Cond : TO T ' >body ! H ; +[THEN] Cond: defers T ' >body @ compile, H ;Cond @@ -3247,7 +3286,7 @@ Cond: postpone ( -- ) \ name ABORT" CROSS: Can't postpone on forward declaration" dup >magic @ = IF (gexecute) - ELSE compile (compile) addr, THEN ;Cond + ELSE >link @ alit, compile compile, THEN ;Cond \ save-cross 17mar93py @@ -3268,6 +3307,7 @@ tchar 8 = 78 and or magic 7 + c! : save-cross ( "image-name" "binary-name" -- ) + .regions \ s" ec" X $has? IF .regions THEN bl parse ." Saving to " 2dup type cr w/o bin create-file throw >r s" header" X $has? IF @@ -3284,7 +3324,8 @@ magic 7 + c! ELSE bl parse 2drop THEN - dictionary >rmem @ there + >rom dictionary >rmem @ there + s" rom" X $has? IF dictionary >rstart @ - THEN r@ write-file throw \ write image s" relocate" X $has? IF dictionary >rbm @ there 1- tcell>bit rshift 1+ @@ -3692,6 +3733,8 @@ previous : 2/ 2/ ; : hex. base @ $10 base ! swap . base ! ; : invert invert ; +: linkstring ( addr u n addr -- ) + X here over X @ X , swap X ! X , ht-string, X align ; \ : . . ; : all-words ['] forced? IS skip? ;