[BACK]Return to cross.fs CVS log [TXT] [DIR] Up to [gforth] / gforth

Diff for /gforth/cross.fs between versions 1.128 and 1.130

version 1.128, 2002/09/14 08:20:18 version 1.130, 2002/12/14 17:34:12
Line 1174  false DefaultValue header Line 1174  false DefaultValue header
 false DefaultValue backtrace  false DefaultValue backtrace
 false DefaultValue new-input  false DefaultValue new-input
 false DefaultValue peephole  false DefaultValue peephole
   false DefaultValue abranch
   true  DefaultValue control-rack
 [THEN]  [THEN]
   
 true DefaultValue interpreter  true DefaultValue interpreter
Line 1702  Ghost (loop)    Ghost (+loop) Line 1704  Ghost (loop)    Ghost (+loop)
 Ghost (next)                                    drop  Ghost (next)                                    drop
 Ghost (does>)   Ghost (compile)                 2drop  Ghost (does>)   Ghost (compile)                 2drop
 Ghost (.")      Ghost (S")      Ghost (ABORT")  2drop drop  Ghost (.")      Ghost (S")      Ghost (ABORT")  2drop drop
 Ghost (C")                                      drop  Ghost (C")      Ghost c(abort") Ghost type      2drop drop
 Ghost '                                         drop  Ghost '                                         drop
   
 \ user ghosts  \ user ghosts
Line 1731  Ghost state drop Line 1733  Ghost state drop
   
 : ht-string,  ( addr count -- )  : ht-string,  ( addr count -- )
   dup there swap last-string 2!    dup there swap last-string 2!
   dup T c, H bounds  ?DO  I c@ T c, H  LOOP ;       dup T c, H bounds  ?DO  I c@ T c, H  LOOP ;
   : ht-mem, ( addr count )
       bounds ?DO  I c@  T c, H  LOOP ;
   
 >TARGET  >TARGET
   
Line 2927  compile: does-resolved ;compile Line 2931  compile: does-resolved ;compile
   
 : branchoffset ( src dest -- )  - tchar / ; \ ?? jaw  : branchoffset ( src dest -- )  - tchar / ; \ ?? jaw
   
 : >resolve    ( sys -- )          
         X here ( dup ." >" hex. ) over branchoffset swap X ! ;  
   
 : <resolve    ( sys -- )  
         X here ( dup ." <" hex. ) branchoffset X , ;  
   
 :noname compile branch X here branchoffset X , ;  :noname compile branch X here branchoffset X , ;
   IS branch, ( target-addr -- )    IS branch, ( target-addr -- )
 :noname compile ?branch X here branchoffset X , ;  :noname compile ?branch X here branchoffset X , ;
Line 2959  compile: does-resolved ;compile Line 2957  compile: does-resolved ;compile
   
 Variable tleavings 0 tleavings !  Variable tleavings 0 tleavings !
   
 : (done) ( addr -- )  : (done) ( do-addr -- )
   \G resolve branches of leave and ?leave and ?do
   \G do-addr is the address of the beginning of our
   \G loop so we can take care of nested loops
     tleavings @      tleavings @
     BEGIN  dup      BEGIN  dup
     WHILE      WHILE
Line 3009  Cond: ?LEAVE    ?leave, ;Cond Line 3010  Cond: ?LEAVE    ?leave, ;Cond
     0 DO  dup @ swap 1 cells -  LOOP      0 DO  dup @ swap 1 cells -  LOOP
     free throw ;      free throw ;
   
 : loop]     branchto, dup <resolve tcell - (done) ;  : loop] ( target-addr -- )
     branchto, 
     dup   X here branchoffset X , 
     tcell - (done) ;
   
 : skiploop] ?dup IF branchto, branchtoresolve, THEN ;  : skiploop] ?dup IF branchto, branchtoresolve, THEN ;
   
Line 3113  Cond: LOOP 1 ncontrols? loop, ;Cond Line 3117  Cond: LOOP 1 ncontrols? loop, ;Cond
 Cond: +LOOP     1 ncontrols? +loop, ;Cond  Cond: +LOOP     1 ncontrols? +loop, ;Cond
 Cond: NEXT      1 ncontrols? next, ;Cond  Cond: NEXT      1 ncontrols? next, ;Cond
   
   \ Absoulte branches                                     26sep02jaw
   
   \ This section defined different semantics for
   \ conditionals, using and compiling absolute branches
   
   X has? abranch [IF]
   
   Ghost abranch drop
   Ghost a?branch drop
   Ghost a(?do) drop
   Ghost a(do) drop
   Ghost a(next) drop
   Ghost a(+loop) drop
   Ghost a(loop) drop
   
   :noname compile abranch X a, ;             plugin-of branch,
   
   :noname compile a?branch X a, ;            plugin-of ?branch,
   
   :noname compile abranch T here 0  a, H ;   plugin-of branchmark,
   
   :noname compile a?branch T here 0 a, H ;   plugin-of ?branchmark,
   
   :noname 
     dup X @ ABORT" CROSS: branch already resolved"
     X here swap X a! ;                       plugin-of branchtoresolve,
   
   :noname 
     0 compile a(?do) ?domark, (leave)
     branchtomark, 2 to1 ;                    plugin-of ?do,
   
   : aloop] ( target-addr -- )
     branchto, 
     dup X a, 
     tcell - (done) ;
   
   :noname 
     1to compile a(loop) aloop] 
     compile unloop skiploop] ;               plugin-of loop,
   
   :noname 
     1to compile a(+loop) aloop]
     compile unloop skiploop] ;               plugin-of +loop,
   
   :noname
     compile a(next) aloop] compile unloop ;   plugin-of next,
   
   [THEN]
   
 \ String words                                         23feb93py  \ String words                                         23feb93py
   
 : ,"            [char] " parse ht-string, X align ;  : ,"            [char] " parse ht-string, X align ;
   
   X has? control-rack [IF]
 Cond: ."        compile (.")     T ," H ;Cond  Cond: ."        compile (.")     T ," H ;Cond
 Cond: S"        compile (S")     T ," H ;Cond  Cond: S"        compile (S")     T ," H ;Cond
 Cond: C"        compile (C")     T ," H ;Cond  Cond: C"        compile (C")     T ," H ;Cond
 Cond: ABORT"    compile (ABORT") T ," H ;Cond  Cond: ABORT"    compile (ABORT") T ," H ;Cond
   [ELSE]
   Cond: ."        '" parse tuck 2>r ahead, there 2r> ht-mem, X align
                   >r then, r> compile ALiteral compile Literal compile type ;Cond
   Cond: S"        '" parse tuck 2>r ahead, there 2r> ht-mem, X align
                   >r then, r> compile ALiteral compile Literal ;Cond
   Cond: C"        ahead, there [char] " parse ht-string, X align
                   >r then, r> compile ALiteral ;Cond
   Cond: ABORT"    if, ahead, there [char] " parse ht-string, X align
                   >r then, r> compile ALiteral compile c(abort") then, ;Cond
   [THEN]
   
 Cond: IS        T ' >body H compile ALiteral compile ! ;Cond  Cond: IS        T ' >body H compile ALiteral compile ! ;Cond
 : IS            T >address ' >body ! H ;  : IS            T >address ' >body ! H ;
Removed from v.1.128  
changed lines
  Added in v.1.130

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