[gforth] / gforth / cross.fs  

gforth: gforth/cross.fs

Diff for /gforth/cross.fs between version 1.52 and 1.53

version 1.52, Sun Aug 31 19:31:28 1997 UTC version 1.53, Sat Sep 13 12:04:55 1997 UTC
Line 128 
Line 128 
   
 previous >CROSS  previous >CROSS
   
   : .dec
     base @ decimal swap . base ! ;
   
 : .sourcepos  : .sourcepos
   cr sourcefilename type ." :"    cr sourcefilename type ." :"
   base @ decimal sourceline# . base ! ;    sourceline# .dec ;
   
 : warnhead  : warnhead
 \G display error-message head  \G display error-message head
Line 274 
Line 277 
   
 : e? name T environment? H 0= ABORT" environment variable not defined!" ;  : e? name T environment? H 0= ABORT" environment variable not defined!" ;
   
 : has? name T environment? H IF ELSE false THEN ;  : has?  name 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"
           THEN ;
   
 : $has? T environment? H IF ELSE false THEN ;  : $has? T environment? H IF ELSE false THEN ;
   
 >ENVIRON  >ENVIRON
 true Value cross  false SetValue ionly
   true  SetValue cross
 >TARGET  >TARGET
   
 mach-file count included hex  mach-file count included hex
   
 >TARGET  >ENVIRON
   
 [IFUNDEF] has-interpreter true Value has-interpreter [THEN]  s" interpreter" T environment? H 0= ?dup nip [IF] true Value interpreter [THEN]
 [IFUNDEF] itc true Value itc [THEN]  s" ITC" T environment? H 0= ?dup nip [IF] true SetValue ITC [THEN]
 [IFUNDEF] has-rom false Value has-rom [THEN]  s" rom" T environment? H 0= ?dup nip [IF] false Value rom [THEN]
   
   >TARGET
   s" relocate" T environment? H
   [IF]    SetValue NIL
   [ELSE]  >ENVIRON T NIL H SetValue relocate
   [THEN]
   
 >CROSS  >CROSS
   
Line 406 
Line 421 
         ." End: " r@ 1 cells + @ + .addr space          ." End: " r@ 1 cells + @ + .addr space
         ." DP: " r> 2 cells + @ .addr          ." DP: " r> 2 cells + @ .addr
   REPEAT drop    REPEAT drop
   s" rom" $has? 0= ?EXIT    s" rom" T $has? H 0= ?EXIT
   cr ." Mirrored:"    cr ." Mirrored:"
   mirrored-link @    mirrored-link @
   BEGIN dup    BEGIN dup
Line 422 
Line 437 
 0 0 region dictionary  0 0 region dictionary
 \ rom area for the compiler  \ rom area for the compiler
   
 has? rom  T has? rom H
 [IF]  [IF]
 0 0 region ram-dictionary mirrored  0 0 region ram-dictionary mirrored
 \ ram area for the compiler  \ ram area for the compiler
Line 440 
Line 455 
   
   
 : setup-target ( -- )   \G initialize targets memory space  : setup-target ( -- )   \G initialize targets memory space
   s" rom" $has?    s" rom" T $has? H
   IF  \ check for ram and rom...    IF  \ check for ram and rom...
       address-space area nip        address-space area nip
       ram-dictionary area nip        ram-dictionary area nip
Line 493 
Line 508 
 variable constflag constflag off  variable constflag constflag off
   
 : (switchram)  : (switchram)
   fixed @ ?EXIT has-rom 0= ?EXIT    fixed @ ?EXIT s" rom" T $has? H 0= ?EXIT
   ram-dictionary >rdp to tdp ;    ram-dictionary >rdp to tdp ;
   
 : switchram  : switchram
Line 674 
Line 689 
 : compile, colon, ;  : compile, colon, ;
 >CROSS  >CROSS
   
   \ file loading
   
   Variable filelist 0 filelist !
   0 Value  loadfile
   
   0 [IF] \ !! JAW WIP
   
   : add-included-file ( adr len -- )
           dup 2 cells + allocate throw >r
           r@ 1 cells + dup TO loadfile place
           filelist @ r@ !
           r> filelist ! ;
   
   : included? ( c-addr u -- f )
           filelist
           BEGIN   @ dup
           WHILE   >r r@ 1 cells + count compare 0=
                   IF rdrop 2drop true EXIT THEN
                   r>
           REPEAT
           2drop drop false ;
   
   : included
           cr ." Including: " 2dup type ." ..."
           2dup add-included-file included ;
   
   : include bl word count included ;
   
   : require bl word count included ;
   
   [THEN]
   
 \ resolve structure  \ resolve structure
   
Line 682 
Line 727 
 : >tag cell+ ;          \ indecates type of reference: 0: call, 1: address  : >tag cell+ ;          \ indecates type of reference: 0: call, 1: address
 : >taddr cell+ cell+ ;  : >taddr cell+ cell+ ;
 : >ghost 3 cells + ;  : >ghost 3 cells + ;
   : >file 4 cells + ;
   : >line 5 cells + ;
   
 : refered ( ghost tag -- )  : refered ( ghost tag -- )
   \G creates a resolve structure
   swap >r here r@ >link @ , r@ >link ! ( tag ) ,    swap >r here r@ >link @ , r@ >link ! ( tag ) ,
   T here aligned H , r> drop  last-header-ghost @ , ;    T here aligned H , r> drop  last-header-ghost @ ,
     loadfile , sourceline# ,
     ;
   
 Defer resolve-warning  Defer resolve-warning
   
Line 768 
Line 818 
 : ?touched ( ghost -- flag ) dup forward? swap >link @  : ?touched ( ghost -- flag ) dup forward? swap >link @
                                0 <> and ;                                 0 <> and ;
   
   : .forwarddefs ( ghost -- )
           ."  appeared in:"
           >link
           BEGIN   @ dup
           WHILE   cr 5 spaces
                   dup >ghost @ >ghostname type
                   ."  file " dup >file @ ?dup IF count type ELSE ." CON" THEN
                   ."  line " dup >line @ .dec
           REPEAT
           drop ;
   
 : ?resolved  ( ghostname -- )  : ?resolved  ( ghostname -- )
   dup cell+ @ ?touched    dup cell+ @ ?touched
   IF  cell+ cell+ count cr type ResolveFlag on ELSE drop THEN ;    IF    dup
           cell+ cell+ count cr type ResolveFlag on
           cell+ @ .forwarddefs
     ELSE  drop
     THEN ;
   
 >MINIMAL  >MINIMAL
 : .unresolved  ( -- )  : .unresolved  ( -- )
Line 789 
Line 854 
 : .stats  : .stats
   base @ >r decimal    base @ >r decimal
   cr ." named Headers: " headers-named @ .    cr ." named Headers: " headers-named @ .
 \  cr ." MaxRam*" ramdp @ .  
 \  cr ." MaxRom*" romdp @ .  
   r> base ! ;    r> base ! ;
   
 >CROSS  >CROSS
Line 958 
Line 1021 
 >TARGET  >TARGET
 : Alias    ( cfa -- ) \ name  : Alias    ( cfa -- ) \ name
     >in @ skip? IF  2drop  EXIT  THEN  >in !      >in @ skip? IF  2drop  EXIT  THEN  >in !
     dup 0< has-prims 0= and      dup 0< s" prims" T $has? H 0= and
     IF      IF
         ." 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 80 flag! ;
 : Alias:   ( cfa -- ) \ name  : Alias:   ( cfa -- ) \ name
     >in @ skip? IF  2drop  EXIT  THEN  >in !      >in @ skip? IF  2drop  EXIT  THEN  >in !
     dup 0< has-prims 0= and      dup 0< s" prims" T $has? H 0= and
     IF      IF
         ." needs doer: " >in @ bl word count type >in ! cr          .sourcepos ." needs doer: " >in @ bl word count type >in ! cr
     THEN      THEN
     ghost tuck swap resolve <do:> swap >magic ! ;      ghost tuck swap resolve <do:> swap >magic ! ;
 >CROSS  >CROSS
Line 1066 
Line 1129 
 : Code  : Code
   defempty?    defempty?
   (THeader there resolve    (THeader there resolve
   [ has-prims 0= [IF] ITC [ELSE] true [THEN] ] [IF]    [ T e? prims H 0= [IF] T e? ITC H [ELSE] true [THEN] ] [IF]
   doprim,    doprim,
   [THEN]    [THEN]
   depth (code) ;    depth (code) ;
Line 1268 
Line 1331 
   
 : BuildSmart:  ( -- [xt] [colon-sys] )  : BuildSmart:  ( -- [xt] [colon-sys] )
   :noname    :noname
   [ has-rom [IF] ]    [ T has? rom H [IF] ]
   postpone RTCreate    postpone RTCreate
   [ [ELSE] ]    [ [ELSE] ]
   postpone TCreate    postpone TCreate
Line 1320 
Line 1383 
 by: :dovar ( ghost -- addr ) ;DO  by: :dovar ( ghost -- addr ) ;DO
 Builder Create  Builder Create
   
 has-rom [IF]  T has? rom H [IF]
 Build: ( n -- ) T here 0 , H switchram T align here swap ! 0 , H ( switchrom ) ;  Build: ( n -- ) T here 0 , H switchram T align here swap ! 0 , H ( switchrom ) ;
 by (Constant)  by (Constant)
 Builder Variable  Builder Variable
Line 1330 
Line 1393 
 Builder Variable  Builder Variable
 [THEN]  [THEN]
   
 has-rom [IF]  T has? rom H [IF]
 Build: ( n -- ) T here 0 , H switchram T align here swap ! 0 , H ( switchrom ) ;  Build: ( n -- ) T here 0 , H switchram T align here swap ! 0 , H ( switchrom ) ;
 by (Constant)  by (Constant)
 Builder AVariable  Builder AVariable
Line 1504 
Line 1567 
 Cond: BUT       restrict? sys? swap ;Cond  Cond: BUT       restrict? sys? swap ;Cond
 Cond: YET       restrict? sys? dup ;Cond  Cond: YET       restrict? sys? dup ;Cond
   
   1 [IF]
 >CROSS  >CROSS
 Variable tleavings  Variable tleavings
 >TARGET  >TARGET
Line 1519 
Line 1583 
 Cond: LEAVE     restrict? compile branch (leave ;Cond  Cond: LEAVE     restrict? compile branch (leave ;Cond
 Cond: ?LEAVE    restrict? compile 0=  compile ?branch (leave  ;Cond  Cond: ?LEAVE    restrict? compile 0=  compile ?branch (leave  ;Cond
   
   [ELSE]
       \ !! This is WIP
       \ The problem is (?DO)!
       \ perhaps we need a plug-in for (?DO)
   
   >CROSS
   Variable tleavings 0 tleavings !
   >TARGET
   
   Cond: DONE   ( addr -- )
         restrict? tleavings @
         BEGIN  dup
         WHILE  >r dup r@ cell+ @ \ address of branch
                u> 0=         \ lower than DO?
         WHILE  r@ 2 cells + @ \ branch token
                branchtoresolve,
                r@ @ r> free throw
         REPEAT drop r>
         THEN
         tleavings ! drop ;Cond
   
   >CROSS
   : (leave ( branchtoken -- )
       3 cells allocate throw >r
       T here H r@ cell+ !
       r@ 2 cells + !
       tleavings @ r@ !
       r> tleavings ! ;
   >TARGET
   
   Cond: LEAVE     restrict? branchmark, (leave ;Cond
   Cond: ?LEAVE    restrict? compile 0=  ?branchmark, (leave  ;Cond
   
   [THEN]
   
 \ Structural Conditionals                              12dec92py  \ Structural Conditionals                              12dec92py
   
   >TARGET
 Cond: AHEAD     restrict? branchmark, ;Cond  Cond: AHEAD     restrict? branchmark, ;Cond
 Cond: IF        restrict? ?branchmark, ;Cond  Cond: IF        restrict? ?branchmark, ;Cond
 Cond: THEN      restrict? sys? branchto, branchtoresolve, ;Cond  Cond: THEN      restrict? sys? branchto, branchtoresolve, ;Cond
Line 1545 
Line 1645 
 Cond: FOR       restrict? compile (for)  T here H ;Cond  Cond: FOR       restrict? compile (for)  T here H ;Cond
   
 >CROSS  >CROSS
 : loop]   dup <resolve tcell - compile DONE compile unloop ;  : loop]   branchto, dup <resolve tcell - compile DONE compile unloop ;
 >TARGET  >TARGET
   
 Cond: LOOP      restrict? sys? compile (loop)  loop] ;Cond  Cond: LOOP      restrict? sys? compile (loop)  loop] ;Cond

Generate output suitable for use with a patch program
Legend:
Removed from v.1.52  
changed lines
  Added in v.1.53
CVS Admin

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help