[gforth] / gforth / kernel / comp.fs  

gforth: gforth/kernel/comp.fs

Diff for /gforth/kernel/comp.fs between version 1.62 and 1.74

version 1.62, Mon Nov 10 15:47:40 2003 UTC version 1.74, Sat Dec 31 15:46:14 2005 UTC
Line 1 
Line 1 
 \ compiler definitions                                          14sep97jaw  \ compiler definitions                                          14sep97jaw
   
 \ Copyright (C) 1995,1996,1997,1998,2000,2003 Free Software Foundation, Inc.  \ Copyright (C) 1995,1996,1997,1998,2000,2003,2004,2005 Free Software Foundation, Inc.
   
 \ This file is part of Gforth.  \ This file is part of Gforth.
   
Line 185 
Line 185 
     postpone lit ,      postpone lit ,
 [ [THEN] ] ; immediate restrict  [ [THEN] ] ; immediate restrict
   
   : 2Literal ( compilation w1 w2 -- ; run-time  -- w1 w2 ) \ double two-literal
       \G Compile appropriate code such that, at run-time, @i{w1 w2} are
       \G placed on the stack. Interpretation semantics are undefined.
       swap postpone Literal  postpone Literal ; immediate restrict
   
 : ALiteral ( compilation addr -- ; run-time -- addr ) \ gforth  : ALiteral ( compilation addr -- ; run-time -- addr ) \ gforth
 [ [IFDEF] alit, ]  [ [IFDEF] alit, ]
     alit,      alit,
Line 192 
Line 197 
     postpone lit A,      postpone lit A,
 [ [THEN] ] ; immediate restrict  [ [THEN] ] ; immediate restrict
   
   Defer char@ ( addr u -- char addr' u' )
   :noname  over c@ -rot 1 /string ; IS char@
   
 : char   ( '<spaces>ccc' -- c ) \ core  : char   ( '<spaces>ccc' -- c ) \ core
     \G Skip leading spaces. Parse the string @i{ccc} and return @i{c}, the      \G Skip leading spaces. Parse the string @i{ccc} and return @i{c}, the
     \G display code representing the first character of @i{ccc}.      \G display code representing the first character of @i{ccc}.
     bl word char+ c@ ;      bl word count char@ 2drop ;
   
 : [char] ( compilation '<spaces>ccc' -- ; run-time -- c ) \ core bracket-char  : [char] ( compilation '<spaces>ccc' -- ; run-time -- c ) \ core bracket-char
     \G Compilation: skip leading spaces. Parse the string      \G Compilation: skip leading spaces. Parse the string
Line 237 
Line 245 
     \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 263 
Line 271 
 : !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 ; \ !! no gforth-native      r> cfaligned /does-handler + !does ; \ !! no gforth-native
   
 : (does>1)  ( addr r:retaddr -- )  : (does>2)  ( addr -- )
     rdrop cfaligned /does-handler + !does ; \ !! no tail-call optimization      cfaligned /does-handler + !does ;
   
 : dodoes,  ( -- )  : dodoes,  ( -- )
   cfalign here /does-handler allot does-handler! ;    cfalign here /does-handler allot does-handler! ;
   
 : (compile) ( -- ) \ gforth-obsolete: dummy  : (compile) ( -- ) \ gforth-obsolete: dummy
     ( r> dup cell+ >r @ compile, ) ;      true abort" (compile) doesn't work, use POSTPONE instead" ;
   
 \ \ ticks  \ \ ticks
   
Line 325 
Line 334 
   
 \ \ compiler loop  \ \ compiler loop
   
 : compiler ( c-addr u -- )  : compiler1 ( c-addr u -- ... xt )
     2dup find-name dup      2dup find-name dup
     if ( c-addr u nt )      if ( c-addr u nt )
         nip nip name>comp execute          nip nip name>comp
     else      else
         drop          drop
         2dup snumber? dup          2dup 2>r snumber? dup
         IF          IF
             0>              0>
             IF              IF
                 swap postpone Literal                  ['] 2literal
               ELSE
                   ['] literal
             THEN              THEN
             postpone Literal              2rdrop
             2drop  
         ELSE          ELSE
             drop compiler-notfound              drop 2r> compiler-notfound1
         THEN          THEN
     then ;      then ;
   
 : [ ( -- ) \  core      left-bracket  : [ ( -- ) \  core      left-bracket
     \G Enter interpretation state. Immediate word.      \G Enter interpretation state. Immediate word.
     ['] interpreter  IS parser state off ; immediate      ['] interpreter1  IS parser1 state off ; immediate
   
 : ] ( -- ) \ core       right-bracket  : ] ( -- ) \ core       right-bracket
     \G Enter compilation state.      \G Enter compilation state.
     ['] compiler     IS parser state on  ;      ['] compiler1     IS parser1 state on  ;
   
 \ \ Strings                                                     22feb93py  \ \ Strings                                                     22feb93py
   
Line 485 
Line 495 
   
 \ IS Defer What's Defers TO                            24feb93py  \ IS Defer What's Defers TO                            24feb93py
   
   defer defer-default ( -- )
   ' abort is defer-default
   \ default action for deferred words (overridden by a warning later)
   
 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 533 
 :noname  :noname
     ;-hook ?struc      ;-hook ?struc
     [ has? xconds [IF] ] exit-like [ [THEN] ]      [ has? xconds [IF] ] exit-like [ [THEN] ]
     here 4 cells + postpone aliteral postpone (does>1) 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 -- ) \ gforth  defer-store
   \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.62  
changed lines
  Added in v.1.74
CVS Admin

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help