Diff for /gforth/cross.fs between versions 1.83 and 1.92

version 1.83, 1999/12/31 21:39:59 version 1.92, 2001/02/04 22:37:12
Line 1 Line 1
 \ CROSS.FS     The Cross-Compiler                      06oct92py  \ CROSS.FS     The Cross-Compiler                      06oct92py
 \ Idea and implementation: Bernd Paysan (py)  \ 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.  \ This file is part of Gforth.
   
Line 17 Line 17
   
 \ You should have received a copy of the GNU General Public License  \ You should have received a copy of the GNU General Public License
 \ along with this program; if not, write to the Free Software  \ 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   0 
 [IF]  [IF]
Line 474  Create tfile 0 c, 255 chars allot Line 474  Create tfile 0 c, 255 chars allot
     THEN ;      THEN ;
   
 : compact.. ( adr len -- adr2 len2 )  : compact.. ( adr len -- adr2 len2 )
 \ deletes phrases like "xy/.." out of our directory name 2dec97jaw      \ deletes phrases like "xy/.." out of our directory name 2dec97jaw
   over >r -1 >r      over swap
   BEGIN dup WHILE      BEGIN  dup  WHILE
         over c@ pathsep?           dup >r '/ scan 2dup 4 min s" /../" compare 0=
         IF      r@ -1 =          IF
                 IF      r> drop dup >r              dup r> - >r 4 /string over r> + 4 -
                 ELSE    2dup 1 /string               swap 2dup + >r move dup r> over -
                         3 min s" ../" compare          ELSE
                         0=              rdrop dup 1 min /string
                         IF      r@ over - ( diff )          THEN
                                 2 pick swap - ( dest-adr )      REPEAT  drop over - ;
                                 >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 - ;  
   
 : reworkdir ( -- )  : reworkdir ( -- )
   remove~+    remove~+
Line 812  false DefaultValue dcomps Line 802  false DefaultValue dcomps
 false DefaultValue hash  false DefaultValue hash
 false DefaultValue xconds  false DefaultValue xconds
 false DefaultValue header  false DefaultValue header
   false DefaultValue backtrace
   false DefaultValue new-input
 [THEN]  [THEN]
   
 true DefaultValue interpreter  true DefaultValue interpreter
Line 1180  CREATE Bittable 80 c, 40 c, 20 c, 10 c, Line 1172  CREATE Bittable 80 c, 40 c, 20 c, 10 c,
 : +bit ( addr n -- )  >bit over c@ or swap c! ;  : +bit ( addr n -- )  >bit over c@ or swap c! ;
 : -bit ( addr n -- )  >bit invert over c@ and swap c! ;  : -bit ( addr n -- )  >bit invert over c@ and swap c! ;
   
 : (relon) ( taddr -- )  bit$ @ swap cell/ +bit ;  : (relon) ( taddr -- )  
 : (reloff) ( taddr -- ) bit$ @ swap cell/ -bit ;    [ [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 @ + ;  : (>image) ( taddr -- absaddr ) image @ + ;
   
Line 1514  variable ResolveFlag Line 1517  variable ResolveFlag
 >CROSS  >CROSS
 \ Header states                                        12dec92py  \ Header states                                        12dec92py
   
 : 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  VARIABLE ^imm
   
   \ !! should be target wordsize specific
   $80 constant alias-mask
   $40 constant immediate-mask
   $20 constant restrict-mask
   
 >TARGET  >TARGET
 : immediate     40 flag!  : immediate     immediate-mask flag!
                 ^imm @ @ dup <imm> = IF  drop  EXIT  THEN                  ^imm @ @ dup <imm> = IF  drop  EXIT  THEN
                 <res> <> ABORT" CROSS: Cannot immediate a unresolved word"                  <res> <> ABORT" CROSS: Cannot immediate a unresolved word"
                 <imm> ^imm @ ! ;                  <imm> ^imm @ ! ;
 : restrict      20 flag! ;  : restrict      restrict-mask flag! ;
   
 : isdoer          : isdoer        
 \G define a forth word as doer, this makes obviously only sence on  \G define a forth word as doer, this makes obviously only sence on
Line 1535  VARIABLE ^imm Line 1544  VARIABLE ^imm
   
 >TARGET  >TARGET
 : string,  ( addr count -- )  : string,  ( addr count -- )
   dup T c, H bounds  ?DO  I c@ T c, H  LOOP ;       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 ) ;  : view,   ( -- ) ( dummy ) ;
 >CROSS  >CROSS
   
Line 1651  NoHeaderFlag off Line 1662  NoHeaderFlag off
     base @ >r hex       base @ >r hex 
     0 swap <# 0 ?DO # LOOP #> type       0 swap <# 0 ?DO # LOOP #> type 
     r> base ! ;      r> base ! ;
 : .sym  
   : .sym ( adr len -- )
   \G escapes / and \ to produce sed output
   bounds     bounds 
   DO I c@ dup    DO I c@ dup
         CASE    [char] / OF drop ." \/" ENDOF          CASE    [char] / OF drop ." \/" ENDOF
Line 1674  NoHeaderFlag off Line 1687  NoHeaderFlag off
         >in @ T name, H >in !          >in @ T name, H >in !
     THEN      THEN
     T cfalign here H tlastcfa !      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 !  \    >in @ cr ." sym:s/CFA=" there 4 0.r ." /"  bl word count .sym ." /g" cr >in !
     ghost      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 Last-Header-Ghost !
     dup >magic ^imm !     \ a pointer for immediate      dup >magic ^imm !     \ a pointer for immediate
     Already @      Already @
     IF  dup >end tdoes !      IF  dup >end tdoes !
     ELSE 0 tdoes !      ELSE 0 tdoes !
     THEN      THEN
     80 flag!      alias-mask flag!
     cross-doc-entry cross-tag-entry ;      cross-doc-entry cross-tag-entry ;
   
 VARIABLE ;Resolve 1 cells allot  VARIABLE ;Resolve 1 cells allot
Line 1700  VARIABLE ;Resolve 1 cells allot Line 1719  VARIABLE ;Resolve 1 cells allot
     IF      IF
         .sourcepos ." needs prim: " >in @ bl word count type >in ! cr          .sourcepos ." needs prim: " >in @ bl word count type >in ! cr
     THEN      THEN
     (THeader over resolve T A, H 80 flag! ;      (THeader over resolve T A, H alias-mask flag! ;
 : Alias:   ( cfa -- ) \ name  : Alias:   ( cfa -- ) \ name
     >in @ skip? IF  2drop  EXIT  THEN  >in !      >in @ skip? IF  2drop  EXIT  THEN  >in !
     dup 0< s" prims" T $has? H 0= and      dup 0< s" prims" T $has? H 0= and
Line 1797  Cond: [']  T ' H alit, ;Cond Line 1816  Cond: [']  T ' H alit, ;Cond
 : (lit,) ( n -- )   compile lit T  ,  H ;       ' (lit,) IS lit,  : (lit,) ( n -- )   compile lit T  ,  H ;       ' (lit,) IS lit,
   
 \ if we dont produce relocatable code alit, defaults to lit, jaw  \ 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]  [IF]
 : (alit,) ( n -- )  compile lit T  a, H ;       ' (alit,) IS alit,  : (alit,) ( n -- )  compile lit T  a, H ;       ' (alit,) IS alit,
 [ELSE]  [ELSE]
Line 2022  Cond: DOES> restrict? Line 2043  Cond: DOES> restrict?
   create-forward-warn    create-forward-warn
   IF ['] reswarn-forward IS resolve-warning THEN    IF ['] reswarn-forward IS resolve-warning THEN
   \ make Alias    \ make Alias
   (THeader there 0 T a, H 80 flag! ( S executed-ghost new-ghost )    (THeader there 0 T a, H alias-mask flag! ( S executed-ghost new-ghost )
   \ store  poiter to code-field    \ store  poiter to code-field
   switchram T cfalign H    switchram T cfalign H
   there swap T ! H    there swap T ! H
Line 2191  Builder Field Line 2212  Builder Field
 : cell% ( n -- size align )  : cell% ( n -- size align )
     T 1 cells H dup ;      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  \ structural conditionals                              17dec92py
   
 >CROSS  >CROSS

Removed from v.1.83  
changed lines
  Added in v.1.92


FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>