Diff for /gforth/cross.fs between versions 1.10 and 1.11

version 1.10, 1994/08/25 15:25:20 version 1.11, 1994/09/02 15:23:33
Line 220  Variable atonce atonce off Line 220  Variable atonce atonce off
 : >magic ; : >link cell+ ; : >exec cell+ cell+ ;  : >magic ; : >link cell+ ; : >exec cell+ cell+ ;
 : >end 3 cells + ;  : >end 3 cells + ;
   
   Variable last-ghost
 : Make-Ghost ( "name" -- ghost )  : Make-Ghost ( "name" -- ghost )
   >in @ GhostName swap >in !    >in @ GhostName swap >in !
   <T Create atonce @ IF immediate atonce off THEN    <T Create atonce @ IF immediate atonce off THEN
   here tuck swap ! ghostheader T>    here tuck swap ! ghostheader T>
   DOES>  >exec @ execute ;    DOES> dup last-ghost ! >exec @ execute ;
   
 \ ghost words                                          14oct92py  \ ghost words                                          14oct92py
 \                                          changed:    10may93py/jaw  \                                          changed:    10may93py/jaw
Line 298  variable ResolveFlag Line 299  variable ResolveFlag
   WHILE dup ?resolved    WHILE dup ?resolved
   REPEAT drop ResolveFlag @    REPEAT drop ResolveFlag @
   IF    IF
       1 (bye)        abort" Unresolved words!"
   ELSE    ELSE
       ." Nothing!"        ." Nothing!"
   THEN    THEN
Line 350  VARIABLE CreateFlag CreateFlag off Line 351  VARIABLE CreateFlag CreateFlag off
   
 VARIABLE ;Resolve 1 cells allot  VARIABLE ;Resolve 1 cells allot
   
 : Theader  ( "name" -- )     (THeader there resolve 0 ;Resolve ! ;  : Theader  ( "name" -- ghost )
     (THeader dup there resolve 0 ;Resolve ! ;
   
 >TARGET  >TARGET
 : Alias    ( cfa -- ) \ name  : Alias    ( cfa -- ) \ name
Line 487  Cond: DOES> restrict? Line 489  Cond: DOES> restrict?
   >in @ alias2 swap dup >in ! >r >r    >in @ alias2 swap dup >in ! >r >r
   Make-Ghost rot swap >exec ! ,    Make-Ghost rot swap >exec ! ,
   r> r> >in !    r> r> >in !
   also ghosts ' previous swap !    also ghosts ' previous swap ! ;
   DOES> dup >exec @ execute ;  \  DOES>  dup >exec @ execute ;
   
 : gdoes,  ( ghost -- )  >end @ dup >magic @ <fwd> <>  : gdoes,  ( ghost -- )  >end @ dup >magic @ <fwd> <>
   IF dup >link @ dup 0< IF T A, 0 , H drop EXIT THEN drop THEN    IF dup >link @ dup 0< IF T A, 0 , H drop EXIT THEN drop THEN
   :dodoes T A, H gexecute T here H cell - reloff ;    :dodoes T A, H gexecute T here H cell - reloff ;
   
 : TCreate ( ghost -- )  : TCreate ( -- )
     last-ghost @
   CreateFlag on    CreateFlag on
   Theader dup gdoes,    Theader >r dup gdoes,
   >end @ >exec @ execute ;    >end @ >exec @ r> >exec ! ;
   
 : Build:  ( -- [xt] [colon-sys] )  : Build:  ( -- [xt] [colon-sys] )
   :noname  postpone TCreate ;    :noname  postpone TCreate ;
   
 : gdoes>  ( ghost -- addr flag )  : gdoes>  ( ghost -- addr flag )
     last-ghost @
   state @ IF  gexecute true EXIT  THEN    state @ IF  gexecute true EXIT  THEN
   cell+ @ T >body H false ;    cell+ @ T >body H false ;
   
 \ DO: ;DO                                               11may93jaw  \ DO: ;DO                                               11may93jaw
 \ changed to ?EXIT                                      10may93jaw  \ changed to ?EXIT                                      10may93jaw
   
 : (does>)        postpone does> ; immediate \ second level does>  
   
 : DO:     ( -- addr [xt] [colon-sys] )  : DO:     ( -- addr [xt] [colon-sys] )
   here ghostheader    here ghostheader
   :noname    :noname postpone gdoes> postpone ?EXIT ;
   postpone (does>) postpone gdoes> postpone ?EXIT ;  
   
 : ;DO ( addr [xt] [colon-sys] -- )  : ;DO ( addr [xt] [colon-sys] -- )
   postpone ;    ( S addr xt )    postpone ;    ( S addr xt )
Line 745  endian Constant endian Line 746  endian Constant endian
   
 : + + ;         : 1- 1- ;  : + + ;         : 1- 1- ;
 : - - ;         : 2* 2* ;  : - - ;         : 2* 2* ;
   : * * ;         : / / ;
 : dup dup ;     : over over ;  : dup dup ;     : over over ;
 : swap swap ;   : rot rot ;  : swap swap ;   : rot rot ;
   

Removed from v.1.10  
changed lines
  Added in v.1.11


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