[gforth] / gforth / kernel / comp.fs  

gforth: gforth/kernel/comp.fs

Diff for /gforth/kernel/comp.fs between version 1.59 and 1.67

version 1.59, Sun Oct 5 15:01:17 2003 UTC version 1.67, Sun Nov 28 20:20:38 2004 UTC
Line 221 
Line 221 
   
 defer basic-block-end ( -- )  defer basic-block-end ( -- )
   
 ' noop is basic-block-end  :noname ( -- )
       0 compile-prim1 ;
   is basic-block-end
   
 has? peephole [IF]  has? peephole [IF]
   
Line 235 
Line 237 
     \G instead of ","-ing the xt.      \G instead of ","-ing the xt.
     \ !! all POSTPONEs here postpone primitives; this can be optimized      \ !! all POSTPONEs here postpone primitives; this can be optimized
     dup >does-code if      dup >does-code if
         POSTPONE does-exec , EXIT          ['] does-exec peephole-compile, , EXIT
         \ dup >body POSTPONE literal POSTPONE call >does-code , EXIT          \ dup >body POSTPONE literal ['] call peephole-compile, >does-code , EXIT
     then      then
     dup >code-address CASE      dup >code-address CASE
         docon:   OF >body POSTPONE lit@ , EXIT ENDOF          docon:   OF >body ['] lit@ peephole-compile, , EXIT ENDOF
         \ docon:   OF >body POSTPONE literal POSTPONE @ EXIT ENDOF          \ docon:   OF >body POSTPONE literal ['] @ peephole-compile, EXIT ENDOF
         \ docon is also used by VALUEs, so don't @ at compile time          \ docon is also used by VALUEs, so don't @ at compile time
         docol:   OF >body POSTPONE call , EXIT ENDOF          docol:   OF >body ['] call peephole-compile, , EXIT ENDOF
         dovar:   OF >body POSTPONE literal EXIT ENDOF          dovar:   OF >body ['] lit peephole-compile, , EXIT ENDOF
         douser:  OF >body @ POSTPONE useraddr , EXIT ENDOF          douser:  OF >body @ ['] useraddr peephole-compile, , EXIT ENDOF
         dodefer: OF >body POSTPONE lit-perform , EXIT ENDOF          dodefer: OF >body ['] lit-perform peephole-compile, , EXIT ENDOF
         dofield: OF >body @ POSTPONE lit+ , EXIT ENDOF          dofield: OF >body @ ['] lit+ peephole-compile, , EXIT ENDOF
         \ dofield: OF >body @ POSTPONE literal POSTPONE + EXIT ENDOF          \ dofield: OF >body @ POSTPONE literal ['] + peephole-compile, EXIT ENDOF
         \ code words and ;code-defined words (code words could be optimized):          \ code words and ;code-defined words (code words could be optimized):
         dup in-dictionary? IF drop POSTPONE literal POSTPONE execute EXIT THEN          dup in-dictionary? IF drop POSTPONE literal ['] execute peephole-compile, EXIT THEN
     ENDCASE      ENDCASE
     peephole-compile, ;      peephole-compile, ;
   
Line 261 
Line 263 
 : !does    ( addr -- ) \ gforth store-does  : !does    ( addr -- ) \ gforth store-does
     latestxt does-code! ;      latestxt does-code! ;
   
   \ !! unused, but ifdefed/gosted in some places
 : (does>)  ( R: addr -- )  : (does>)  ( R: addr -- )
     r> cfaligned /does-handler + !does ;      r> cfaligned /does-handler + !does ; \ !! no gforth-native
   
   : (does>2)  ( addr -- )
       cfaligned /does-handler + !does ;
   
 : dodoes,  ( -- )  : dodoes,  ( -- )
   cfalign here /does-handler allot does-handler! ;    cfalign here /does-handler allot does-handler! ;
   
 : (compile) ( -- ) \ gforth  : (compile) ( -- ) \ gforth-obsolete: dummy
     r> dup cell+ >r @ compile, ;      true abort" (compile) doesn't work, use POSTPONE instead" ;
   
 \ \ ticks  \ \ ticks
   
Line 305 
Line 311 
     if      if
         drop compile,          drop compile,
     else      else
         dup ['] compile, =  
         if  
             drop POSTPONE (compile) a,  
         else  
             swap POSTPONE aliteral compile,              swap POSTPONE aliteral compile,
         then  
     then ;      then ;
   
 : POSTPONE ( "name" -- ) \ core  : POSTPONE ( "name" -- ) \ core
Line 485 
Line 486 
   
 \ IS Defer What's Defers TO                            24feb93py  \ IS Defer What's Defers TO                            24feb93py
   
   : defer-default ( -- ) \ gforth
       \ might change into a THROW in the future
       ; \ >stderr ." uninitialized deferred word" ;
   
 doer? :dodefer [IF]  doer? :dodefer [IF]
   
 : Defer ( "name" -- ) \ gforth  : Defer ( "name" -- ) \ gforth
     \ !! shouldn't it be initialized with abort or something similar?  \G Define a deferred word @i{name}; its execution semantics can be
   \G set with @code{defer!} or @code{is} (and they have to, before first
   \G executing @i{name}.
     Header Reveal dodefer: cfa,      Header Reveal dodefer: cfa,
     ['] noop A, ;      ['] defer-default A, ;
   
 [ELSE]  [ELSE]
   
 : Defer ( "name" -- ) \ gforth  : Defer ( "name" -- ) \ gforth
     Create ['] noop A,      Create ['] defer-default A,
 DOES> @ execute ;  DOES> @ execute ;
   
 [THEN]  [THEN]
   
   : defer@ ( xt-deferred -- xt ) \ gforth defer-fetch
   \G @i{xt} represents the word currently associated with the deferred
   \G word @i{xt-deferred}.
       >body @ ;
   
 : Defers ( compilation "name" -- ; run-time ... -- ... ) \ gforth  : Defers ( compilation "name" -- ; run-time ... -- ... ) \ gforth
     \G Compiles the present contents of the deferred word @i{name}      \G Compiles the present contents of the deferred word @i{name}
     \G into the current definition.  I.e., this produces static      \G into the current definition.  I.e., this produces static
     \G binding as if @i{name} was not deferred.      \G binding as if @i{name} was not deferred.
     ' >body @ compile, ; immediate      ' defer@ compile, ; immediate
   
 :noname  :noname
     dodoes, here !does ]      dodoes, here !does ]
Line 512 
Line 524 
 :noname  :noname
     ;-hook ?struc      ;-hook ?struc
     [ has? xconds [IF] ] exit-like [ [THEN] ]      [ has? xconds [IF] ] exit-like [ [THEN] ]
     postpone (does>) dodoes,      here 5 cells + postpone aliteral postpone (does>2) [compile] exit
       finish-code dodoes,
     defstart :-hook ;      defstart :-hook ;
 interpret/compile: DOES>  ( compilation colon-sys1 -- colon-sys2 ; run-time nest-sys -- ) \ core        does  interpret/compile: DOES>  ( compilation colon-sys1 -- colon-sys2 ; run-time nest-sys -- ) \ core        does
   
   : defer! ( xt xt-deferred -- )
   \G Changes the @code{defer}red word @var{xt-deferred} to execute @var{xt}.
       >body ! ;
   
 : <IS> ( "name" xt -- ) \ gforth  : <IS> ( "name" xt -- ) \ gforth
     \g Changes the @code{defer}red word @var{name} to execute @var{xt}.      \g Changes the @code{defer}red word @var{name} to execute @var{xt}.
     ' >body ! ;      ' defer! ;
   
 : [IS] ( compilation "name" -- ; run-time xt -- ) \ gforth bracket-is  : [IS] ( compilation "name" -- ; run-time xt -- ) \ gforth bracket-is
     \g At run-time, changes the @code{defer}red word @var{name} to      \g At run-time, changes the @code{defer}red word @var{name} to
     \g execute @var{xt}.      \g execute @var{xt}.
     ' >body postpone ALiteral postpone ! ; immediate restrict      ' postpone ALiteral postpone defer! ; immediate restrict
   
 ' <IS>  ' <IS>
 ' [IS]  ' [IS]
 interpret/compile: IS ( xt "name" -- ) \ gforth  interpret/compile: IS ( compilation/interpretation "name-deferred" -- ; run-time xt -- ) \ gforth
 \G A combined word made up from @code{<IS>} and @code{[IS]}.  \G Changes the @code{defer}red word @var{name} to execute @var{xt}.
   \G Its compilation semantics parses at compile time.
   
 ' <IS>  ' <IS>
 ' [IS]  ' [IS]
 interpret/compile: TO ( w "name" -- ) \ core-ext  interpret/compile: TO ( w "name" -- ) \ core-ext
   
 :noname    ' >body @ ;  
 :noname    ' >body postpone ALiteral postpone @ ;  
 interpret/compile: What's ( interpretation "name" -- xt; compilation "name" -- ; run-time -- xt ) \ gforth  
 \G @i{Xt} is the XT that is currently assigned to @i{name}.  
   
 : interpret/compile? ( xt -- flag )  : interpret/compile? ( xt -- flag )
     >does-code ['] DOES> >does-code = ;      >does-code ['] DOES> >does-code = ;
   

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

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help