[gforth] / gforth / kernel / comp.fs  

gforth: gforth/kernel/comp.fs

Diff for /gforth/kernel/comp.fs between version 1.43 and 1.53

version 1.43, Sat Sep 14 08:20:21 2002 UTC version 1.53, Thu Feb 6 20:42:26 2003 UTC
Line 113 
Line 113 
   
 : header, ( c-addr u -- ) \ gforth  : header, ( c-addr u -- ) \ gforth
     name-too-long?      name-too-long?
       dup max-name-length @ max max-name-length !
     align here last !      align here last !
     current @ 1 or A,   \ link field; before revealing, it contains the      current @ 1 or A,   \ link field; before revealing, it contains the
                         \ tagged reveal-into wordlist                          \ tagged reveal-into wordlist
Line 212 
Line 213 
   
 defer basic-block-end ( -- )  defer basic-block-end ( -- )
   
 : bb-end ( -- )  :noname ( -- )
     0 last-compiled ! ;      0 last-compiled ! ;
 ' bb-end is basic-block-end  is basic-block-end
   
 has? peephole [IF]  has? peephole [IF]
   
 \ dynamic only  \ dynamic only
 \  : peephole-compile, ( xt -- )  : peephole-compile, ( xt -- )
 \      \ compile xt, appending its code to the current dynamic superinstruction      \ compile xt, appending its code to the current dynamic superinstruction
 \      compile-prim , ;      here swap , compile-prim1 ;
   
 \ static only  \ static only
 \  : peephole-compile, ( xt -- )  \  : peephole-compile, ( xt -- )
Line 235 
Line 236 
 \      here last-compiled !  \      here last-compiled !
 \      dyn-compile, ;  \      dyn-compile, ;
   
 : dyn-compile! ( xt -- )  \ combine greedy static with dynamic
     \ compile xt, appending its code to the current dynamic superinstruction  \  : dyn-compile! ( xt -- )
     compile-prim last-compiled-here @ ! ;  \      \ compile xt, appending its code to the current dynamic superinstruction
   \      last-compiled-here @ tuck ! compile-prim1 ;
   
 :noname ( -- )  \  :noname ( -- )
     last-compiled @ if  \      last-compiled @ if
         last-compiled @ dyn-compile!  \       last-compiled @ dyn-compile!
         0 last-compiled !  \       0 last-compiled !
     then ;  \      then ;
 is basic-block-end  \  is basic-block-end
   
 : static-compile, ( xt -- )  \  : peephole-compile, ( xt -- )
     \ compile xt, possibly combining it with the previous compiled xt  \      \ compile xt, possibly combining it with the previous compiled xt
     \ into a superinstruction (static superinstructions)  \      \ into a superinstruction (static superinstructions)
     last-compiled @ ?dup if  \      last-compiled @ ?dup if
         over peeptable peephole-opt ?dup if ( xt comb-xt )  \       over peeptable peephole-opt ?dup if ( xt comb-xt )
             last-compiled ! drop EXIT  \           last-compiled ! drop EXIT
         then ( xt )  \       then ( xt )
         last-compiled @ dyn-compile!  \       last-compiled @ dyn-compile!
     then ( xt )  \      then ( xt )
     last-compiled !  \      last-compiled !
     here last-compiled-here ! 0 , ;  \      here last-compiled-here ! 0 , ;
   
 : compile-to-prims, ( xt -- )  : compile-to-prims, ( xt -- )
     \G compile xt to use primitives (and their peephole optimization)      \G compile xt to use primitives (and their peephole optimization)
Line 267 
Line 269 
         \ dup >body POSTPONE literal POSTPONE call >does-code , EXIT          \ dup >body POSTPONE literal POSTPONE call >does-code , EXIT
     then      then
     dup >code-address CASE      dup >code-address CASE
         \ docon:   OF >body POSTPONE lit@ , EXIT ENDOF          docon:   OF >body POSTPONE lit@ , EXIT ENDOF
         docon:   OF >body POSTPONE literal POSTPONE @ EXIT ENDOF          \ docon:   OF >body POSTPONE literal POSTPONE @ 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 POSTPONE call , EXIT ENDOF
         dovar:   OF >body POSTPONE literal EXIT ENDOF          dovar:   OF >body POSTPONE literal EXIT ENDOF
         douser:  OF >body @ POSTPONE useraddr , EXIT ENDOF          douser:  OF >body @ POSTPONE useraddr , EXIT ENDOF
         dodefer: OF >body POSTPONE lit-perform , EXIT ENDOF          dodefer: OF >body POSTPONE lit-perform , EXIT ENDOF
         \ dofield: OF >body @ POSTPONE lit+ , EXIT ENDOF          dofield: OF >body @ POSTPONE lit+ , EXIT ENDOF
         dofield: OF >body @ POSTPONE literal POSTPONE + EXIT ENDOF          \ dofield: OF >body @ POSTPONE literal POSTPONE + EXIT ENDOF
           \ code words and ;code-defined words (code words could be optimized):
           dup in-dictionary? IF drop POSTPONE literal POSTPONE execute EXIT THEN
     ENDCASE      ENDCASE
     static-compile, ;      peephole-compile, ;
   
 ' compile-to-prims, IS compile,  ' compile-to-prims, IS compile,
 [ELSE]  [ELSE]
Line 341 
Line 345 
   
 : POSTPONE ( "name" -- ) \ core  : POSTPONE ( "name" -- ) \ core
     \g Compiles the compilation semantics of @i{name}.      \g Compiles the compilation semantics of @i{name}.
     COMP' postpone, ; immediate restrict      COMP' postpone, ; immediate
   
 \ \ recurse                                                     17may93jaw  \ \ recurse                                                     17may93jaw
   
Line 380 
Line 384 
   
 \ \ Strings                                                     22feb93py  \ \ Strings                                                     22feb93py
   
 : ," ( "string"<"> -- ) [char] " parse  : S, ( addr u -- )
       \ allot string as counted string
   here over char+ allot  place align ;    here over char+ allot  place align ;
   
 : SLiteral ( Compilation c-addr1 u ; run-time -- c-addr2 u ) \ string  : mem, ( addr u -- )
     \G Compilation: compile the string specified by @i{c-addr1},      \ allot the memory block HERE (do alignment yourself)
     \G @i{u} into the current definition. Run-time: return      here over allot swap move ;
     \G @i{c-addr2 u} describing the address and length of the  
     \G string.  
     postpone (S") here over char+ allot  place align ;  
                                              immediate restrict  
   
 \ \ abort"                                                      22feb93py  
   
 : abort" ( compilation 'ccc"' -- ; run-time f -- ) \ core,exception-ext abort-quote  : ," ( "string"<"> -- )
     \G If any bit of @i{f} is non-zero, perform the function of @code{-2 throw},      [char] " parse s, ;
     \G displaying the string @i{ccc} if there is no exception frame on the  
     \G exception stack.  
     postpone (abort") ," ;        immediate restrict  
   
 \ \ Header states                                               23feb93py  \ \ Header states                                               23feb93py
   
Line 607 
Line 603 
     ;-hook ?struc fini, comp[ reveal postpone [ ; immediate restrict      ;-hook ?struc fini, comp[ reveal postpone [ ; immediate restrict
 [ELSE]  [ELSE]
 : ; ( compilation colon-sys -- ; run-time nest-sys ) \ core     semicolon  : ; ( compilation colon-sys -- ; run-time nest-sys ) \ core     semicolon
     ;-hook ?struc [compile] exit reveal postpone [ ; immediate restrict      ;-hook ?struc [compile] exit finish-code reveal postpone [ ; immediate restrict
 [THEN]  [THEN]
   
 \ \ Search list handling: reveal words, recursive               23feb93py  \ \ Search list handling: reveal words, recursive               23feb93py

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

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help