Diff for /gforth/cross.fs between versions 1.121 and 1.122

version 1.121, 2002/03/19 18:07:55 version 1.122, 2002/03/20 11:28:26
Line 1528  bigendian Line 1528  bigendian
   2drop 0 ;    2drop 0 ;
   
 : taddr>region-abort ( taddr -- region | 0 )  : taddr>region-abort ( taddr -- region | 0 )
   \G Same as taddr>region but aborts if taddr is not
   \G a valid address in the target address space
   dup taddr>region dup 0=     dup taddr>region dup 0= 
   IF    drop cr ." Wrong address: " .addr    IF    drop cr ." Wrong address: " .addr
         -1 ABORT" Address out of range!"          -1 ABORT" Address out of range!"
Line 1830  Defer resolve-warning Line 1832  Defer resolve-warning
   
 0 Value resolved  0 Value resolved
   
 : resolve  ( ghost tcfa -- )  : resolve-forward-references ( ghost resolve-list -- )
 \G resolve referencies to ghost with tcfa      \ loop through forward referencies
       comp-state @ >r Resolving comp-state !
       over >link @ resolve-loop 
       r> comp-state !
   
       ['] noop IS resolve-warning ;
   
   
   : (resolve) ( ghost tcfa -- ghost resolve-list )
       \ check for a valid address, it is a primitive reference
       \ otherwise
     dup taddr>region 0<> IF      dup taddr>region 0<> IF
         \ define this address in the region address type table
       2dup (>regiontype) define-addr-struct addr-xt-ghost         2dup (>regiontype) define-addr-struct addr-xt-ghost 
   
       \ we define new address only if empty        \ we define new address only if empty
       \ this is for not to take over the alias ghost        \ this is for not to take over the alias ghost
       \ (different ghost, but identical xt)        \ (different ghost, but identical xt)
       \ but the very first that really defines it        \ but the very first that really defines it
       dup @ 0= IF ! ELSE 2drop THEN        dup @ 0= IF ! ELSE 2drop THEN
     THEN      THEN
       swap >r
     \ is ghost resolved?, second resolve means another   
     \ definition with the same name  
     over undefined? 0= IF  exists EXIT THEN  
     \ get linked-list  
     swap >r r@ >link @ swap \ ( list tcfa R: ghost )  
     \ mark ghost as resolved  
     dup r@ >link ! <res> r@ >magic !  
     r@ to resolved      r@ to resolved
   
 \    r@ >comp @ ['] is-forward =  \    r@ >comp @ ['] is-forward =
Line 1858  Defer resolve-warning Line 1863  Defer resolve-warning
     \ if this is not right something must be set before      \ if this is not right something must be set before
     \ calling resolve      \ calling resolve
     r@ >comp @ ['] is-forward = IF      r@ >comp @ ['] is-forward = IF
         ['] colon-resolved r@ >comp !         ['] colon-resolved r@ >comp !
     THEN     THEN
     \ loop through forward referencies      r@ >link @ swap \ ( list tcfa R: ghost )
     r> -rot       \ mark ghost as resolved
     comp-state @ >r Resolving comp-state !      r@ >link ! <res> r@ >magic !
     resolve-loop       r> swap ;
     r> comp-state !  
   
     ['] noop IS resolve-warning   : resolve  ( ghost tcfa -- )
   ;  \G resolve referencies to ghost with tcfa
       \ is ghost resolved?, second resolve means another 
       \ definition with the same name
       over undefined? 0= IF  exists EXIT THEN
       (resolve)
       ( ghost resolve-list )
       resolve-forward-references ;
   
   : resolve-noforwards ( ghost tcfa -- )
   \G Same as resolve but complain if there are any
   \G forward references on this ghost
      \ is ghost resolved?, second resolve means another 
      \ definition with the same name
      over undefined? 0= IF  exists EXIT THEN
      (resolve)
      IF cr ." No forward references allowed on: " .ghost cr
         -1 ABORT" Illegal forward reference"
      THEN
      drop ;
   
 \ gexecute ghost,                                      01nov92py  \ gexecute ghost,                                      01nov92py
   
Line 2188  Defer setup-prim-semantics Line 2210  Defer setup-prim-semantics
   
 : mapprim:   ( "forthname" "asmlabel" -- )   : mapprim:   ( "forthname" "asmlabel" -- ) 
   -1 aprim-nr +! aprim-nr @    -1 aprim-nr +! aprim-nr @
   Ghost tuck swap resolve <do:> swap tuck >magic !    Ghost tuck swap resolve-noforwards <do:> swap tuck >magic !
   asmprimname, ;    asmprimname, ;
   
 : Doer:   ( cfa -- ) \ name  : Doer:   ( cfa -- ) \ name
Line 2198  Defer setup-prim-semantics Line 2220  Defer setup-prim-semantics
       .sourcepos ." needs doer: " >in @ bl word count type >in ! cr        .sourcepos ." needs doer: " >in @ bl word count type >in ! cr
   THEN    THEN
   Ghost    Ghost
   tuck swap resolve <do:> swap >magic ! ;    tuck swap resolve-noforwards <do:> swap >magic ! ;
   
 Variable prim#  Variable prim#
 : first-primitive ( n -- )  prim# ! ;  : first-primitive ( n -- )  prim# ! ;
Line 2211  Variable prim# Line 2233  Variable prim#
   prim# @ (THeader ( S xt ghost )    prim# @ (THeader ( S xt ghost )
   ['] prim-resolved over >comp !    ['] prim-resolved over >comp !
   dup >ghost-flags <primitive> set-flag    dup >ghost-flags <primitive> set-flag
   over resolve T A, H alias-mask flag!    over resolve-noforwards T A, H alias-mask flag!
   -1 prim# +! ;    -1 prim# +! ;
 >CROSS  >CROSS
   
Line 2333  Defer (end-code) Line 2355  Defer (end-code)
   defempty?    defempty?
   (THeader ( ghost )    (THeader ( ghost )
   ['] prim-resolved over >comp !    ['] prim-resolved over >comp !
   there resolve    there resolve-noforwards
       
   [ T e? prims H 0= [IF] T e? ITC H [ELSE] true [THEN] ] [IF]    [ T e? prims H 0= [IF] T e? ITC H [ELSE] true [THEN] ] [IF]
   doprim,     doprim, 
Line 2345  Defer (end-code) Line 2367  Defer (end-code)
 : Code:  : Code:
   defempty?    defempty?
     Ghost >r       Ghost >r 
     r@ there ca>native resolve        r@ there ca>native resolve-noforwards
     <do:> r@ >magic !      <do:> r@ >magic !
     r> drop      r> drop
     depth (code) ;      depth (code) ;
Line 3533  previous Line 3555  previous
 : rot rot ;  : rot rot ;
 : drop drop ;  : drop drop ;
 : =   = ;  : =   = ;
   : <>  <> ;
 : 0=   0= ;  : 0=   0= ;
 : lshift lshift ;  : lshift lshift ;
 : 2/ 2/ ;  : 2/ 2/ ;
Line 3587  previous Line 3610  previous
 \ : words       also ghosts   \ : words       also ghosts 
 \                words previous ;  \                words previous ;
 : .s            .s ;  : .s            .s ;
   : depth         depth ;
 : bye           bye ;  : bye           bye ;
   
 \ dummy  \ dummy

Removed from v.1.121  
changed lines
  Added in v.1.122


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