[gforth] / gforth / kernel / comp.fs  

gforth: gforth/kernel/comp.fs

Diff for /gforth/kernel/comp.fs between version 1.24 and 1.64

version 1.24, Thu Aug 10 20:46:26 2000 UTC version 1.64, Thu Aug 26 15:50:44 2004 UTC
Line 1 
Line 1 
 \ compiler definitions                                          14sep97jaw  \ compiler definitions                                          14sep97jaw
   
 \ Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc.  \ Copyright (C) 1995,1996,1997,1998,2000,2003 Free Software Foundation, Inc.
   
 \ This file is part of Gforth.  \ This file is part of Gforth.
   
Line 16 
Line 16 
   
 \ You should have received a copy of the GNU General Public License  \ You should have received a copy of the GNU General Public License
 \ along with this program; if not, write to the Free Software  \ along with this program; if not, write to the Free Software
 \ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.  \ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
   
 \ \ Revisions-Log  \ \ Revisions-Log
   
Line 107 
Line 107 
     \G puts down string as cstring      \G puts down string as cstring
     dup c, here swap chars dup allot move ;      dup c, here swap chars dup allot move ;
   
   : longstring, ( c-addr u -- ) \ gforth
       \G puts down string as longcstring
       dup , here swap chars dup allot move ;
   
 : 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
     string, cfalign      longstring, cfalign
     alias-mask lastflags cset ;      alias-mask lastflags cset ;
   
 : input-stream-header ( "name" -- )  : input-stream-header ( "name" -- )
Line 124 
Line 129 
   
 ' input-stream-header IS (header)  ' input-stream-header IS (header)
   
 \ !! make that a 2variable  2variable nextname-string
 create nextname-buffer 32 chars allot  
   
   has? OS [IF]
 : nextname-header ( -- )  : nextname-header ( -- )
     nextname-buffer count header,      nextname-string 2@ header,
       nextname-string free-mem-var
     input-stream ;      input-stream ;
   [THEN]
   
 \ the next name is given in the string  \ the next name is given in the string
   
   has? OS [IF]
 : nextname ( c-addr u -- ) \ gforth  : nextname ( c-addr u -- ) \ gforth
     \g The next defined word will have the name @var{c-addr u}; the      \g The next defined word will have the name @var{c-addr u}; the
     \g defining word will leave the input stream alone.      \g defining word will leave the input stream alone.
     name-too-long?      name-too-long?
     nextname-buffer c! ( c-addr )      nextname-string free-mem-var
     nextname-buffer count move      save-mem nextname-string 2!
     ['] nextname-header IS (header) ;      ['] nextname-header IS (header) ;
   [THEN]
   
 : noname-header ( -- )  : noname-header ( -- )
     0 last ! cfalign      0 last ! cfalign
Line 148 
Line 157 
 : noname ( -- ) \ gforth  : noname ( -- ) \ gforth
     \g The next defined word will be anonymous. The defining word will      \g The next defined word will be anonymous. The defining word will
     \g leave the input stream alone. The xt of the defined word will      \g leave the input stream alone. The xt of the defined word will
     \g be given by @code{lastxt}.      \g be given by @code{latestxt}.
     ['] noname-header IS (header) ;      ['] noname-header IS (header) ;
   
 : lastxt ( -- xt ) \ gforth  : latestxt ( -- xt ) \ gforth
     \G @i{xt} is the execution token of the last word defined.      \G @i{xt} is the execution token of the last word defined.
     \ The main purpose of this word is to get the xt of words defined using noname      \ The main purpose of this word is to get the xt of words defined using noname
     lastcfa @ ;      lastcfa @ ;
   
   ' latestxt alias lastxt \ gforth-obsolete
   \G old name for @code{latestxt}.
   
   : latest ( -- nt ) \ gforth
   \G @var{nt} is the name token of the last word defined; it is 0 if the
   \G last word has no name.
       last @ ;
   
 \ \ literals                                                    17dec92py  \ \ literals                                                    17dec92py
   
 : Literal  ( compilation n -- ; run-time -- n ) \ core  : Literal  ( compilation n -- ; run-time -- n ) \ core
     \G Compile appropriate code such that, at run-time, @i{n} is placed      \G Compilation semantics: compile the run-time semantics.@*
     \G on the stack. Interpretation semantics are undefined.      \G Run-time Semantics: push @i{n}.@*
       \G Interpretation semantics: undefined.
 [ [IFDEF] lit, ]  [ [IFDEF] lit, ]
     lit,      lit,
 [ [ELSE] ]  [ [ELSE] ]
Line 194 
Line 212 
     0 A, 0 ,  code-address! ;      0 A, 0 ,  code-address! ;
   
 [IFUNDEF] compile,  [IFUNDEF] compile,
 : compile, ( xt -- )    \ core-ext      compile-comma  defer compile, ( xt -- )        \ core-ext      compile-comma
     \G  Compile the word represented by the execution token, @i{xt},  \G  Compile the word represented by the execution token @i{xt}
     \G  into the current definition.      \G  into the current definition.
     A, ;  
   ' , is compile,
   [THEN]
   
   defer basic-block-end ( -- )
   
   :noname ( -- )
       0 compile-prim1 ;
   is basic-block-end
   
   has? peephole [IF]
   
   \ dynamic only
   : peephole-compile, ( xt -- )
       \ compile xt, appending its code to the current dynamic superinstruction
       here swap , compile-prim1 ;
   
   : compile-to-prims, ( xt -- )
       \G compile xt to use primitives (and their peephole optimization)
       \G instead of ","-ing the xt.
       \ !! all POSTPONEs here postpone primitives; this can be optimized
       dup >does-code if
           POSTPONE does-exec , EXIT
           \ dup >body POSTPONE literal POSTPONE call >does-code , EXIT
       then
       dup >code-address CASE
           docon:   OF >body POSTPONE lit@ , EXIT ENDOF
           \ docon:   OF >body POSTPONE literal POSTPONE @ EXIT ENDOF
           \ docon is also used by VALUEs, so don't @ at compile time
           docol:   OF >body POSTPONE call , EXIT ENDOF
           dovar:   OF >body POSTPONE literal EXIT ENDOF
           douser:  OF >body @ POSTPONE useraddr , EXIT ENDOF
           dodefer: OF >body POSTPONE lit-perform , EXIT ENDOF
           dofield: OF >body @ POSTPONE lit+ , 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
       peephole-compile, ;
   
   ' compile-to-prims, IS compile,
   [ELSE]
   ' , is compile,
 [THEN]  [THEN]
   
 : !does    ( addr -- ) \ gforth store-does  : !does    ( addr -- ) \ gforth store-does
     lastxt does-code! ;      latestxt does-code! ;
   
 : (does>)  ( R: addr -- )  : (does>)  ( R: addr -- )
     r> cfaligned /does-handler + !does ;      r> cfaligned /does-handler + !does ; \ !! no gforth-native
   
   : (does>1)  ( addr r:retaddr -- )
       rdrop cfaligned /does-handler + !does ; \ !! no tail-call optimization
   
   : (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 241 
Line 307 
     COMP' swap POSTPONE Aliteral POSTPONE ALiteral ; immediate restrict      COMP' swap POSTPONE Aliteral POSTPONE ALiteral ; immediate restrict
   
 : postpone, ( w xt -- ) \ gforth        postpone-comma  : postpone, ( w xt -- ) \ gforth        postpone-comma
     \g Compile the compilation semantics represented by @i{w xt}.      \g Compile the compilation semantics represented by the
       \g compilation token @i{w xt}.
     dup ['] execute =      dup ['] execute =
     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
     \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
   
 : recurse ( compilation -- ; run-time ?? -- ?? ) \ core  : recurse ( compilation -- ; run-time ?? -- ?? ) \ core
     \g Call the current definition.      \g Call the current definition.
     lastxt compile, ; immediate restrict      latestxt compile, ; immediate restrict
   
 \ \ compiler loop  \ \ compiler loop
   
Line 295 
Line 357 
   
 \ \ 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  : ," ( "string"<"> -- )
       [char] " parse s, ;
 : abort" ( compilation 'ccc"' -- ; run-time f -- ) \ core,exception-ext abort-quote  
     \G If any bit of @i{f} is non-zero, perform the function of @code{-2 throw},  
     \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
   
 : cset ( bmask c-addr -- )  : cset ( bmask c-addr -- )
     tuck c@ or swap c! ;      tuck @ or swap ! ;
   
 : creset ( bmask c-addr -- )  : creset ( bmask c-addr -- )
     tuck c@ swap invert and swap c! ;      tuck @ swap invert and swap ! ;
   
 : ctoggle ( bmask c-addr -- )  : ctoggle ( bmask c-addr -- )
     tuck c@ xor swap c! ;      tuck @ xor swap ! ;
   
 : lastflags ( -- c-addr )  : lastflags ( -- c-addr )
     \ the address of the flags byte in the last header      \ the address of the flags byte in the last header
     \ aborts if the last defined word was headerless      \ aborts if the last defined word was headerless
     last @ dup 0= abort" last word was headerless" cell+ ;      latest dup 0= abort" last word was headerless" cell+ ;
   
 : immediate ( -- ) \ core  : immediate ( -- ) \ core
     \G Make the compilation semantics of a word be to @code{execute}      \G Make the compilation semantics of a word be to @code{execute}
Line 403 
Line 457 
 : Value ( w "name" -- ) \ core-ext  : Value ( w "name" -- ) \ core-ext
     (Constant) , ;      (Constant) , ;
   
   : AValue ( w "name" -- ) \ core-ext
       (Constant) A, ;
   
 : 2Constant ( w1 w2 "name" -- ) \ double two-constant  : 2Constant ( w1 w2 "name" -- ) \ double two-constant
     Create ( w1 w2 "name" -- )      Create ( w1 w2 "name" -- )
         2,          2,
Line 414 
Line 471 
 [ELSE]  [ELSE]
     : (Field)  Create DOES> @ + ;      : (Field)  Create DOES> @ + ;
 [THEN]  [THEN]
   
   \ \ interpret/compile:
   
   struct
       >body
       cell% field interpret/compile-int
       cell% field interpret/compile-comp
   end-struct interpret/compile-struct
   
   : interpret/compile: ( interp-xt comp-xt "name" -- ) \ gforth
       Create immediate swap A, A,
   DOES>
       abort" executed primary cfa of an interpret/compile: word" ;
   \    state @ IF  cell+  THEN  perform ;
   
 \ IS Defer What's Defers TO                            24feb93py  \ IS Defer What's Defers TO                            24feb93py
   
 doer? :dodefer [IF]  doer? :dodefer [IF]
Line 431 
Line 503 
   
 [THEN]  [THEN]
   
 : Defers ( "name" -- ) \ gforth  : Defers ( compilation "name" -- ; run-time ... -- ... ) \ gforth
       \G Compiles the present contents of the deferred word @i{name}
       \G into the current definition.  I.e., this produces static
       \G binding as if @i{name} was not deferred.
     ' >body @ compile, ; immediate      ' >body @ compile, ; immediate
   
 :noname  :noname
Line 440 
Line 515 
 :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
   
Line 464 
Line 540 
   
 :noname    ' >body @ ;  :noname    ' >body @ ;
 :noname    ' >body postpone ALiteral postpone @ ;  :noname    ' >body postpone ALiteral postpone @ ;
 interpret/compile: What's ( "name" -- addr ) \ gforth  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:  
   
 struct  
     >body  
     cell% field interpret/compile-int  
     cell% field interpret/compile-comp  
 end-struct interpret/compile-struct  
   
 : interpret/compile: ( interp-xt comp-xt "name" -- ) \ gforth  
     Create immediate swap A, A,  
 DOES>  
     abort" executed primary cfa of an interpret/compile: word" ;  
 \    state @ IF  cell+  THEN  perform ;  
   
 : interpret/compile? ( xt -- flag )  : interpret/compile? ( xt -- flag )
     >does-code ['] DOES> >does-code = ;      >does-code ['] DOES> >does-code = ;
Line 494 
Line 557 
 [IFDEF] docol,  [IFDEF] docol,
 : (:noname) ( -- colon-sys )  : (:noname) ( -- colon-sys )
     \ common factor of : and :noname      \ common factor of : and :noname
     docol, ]comp defstart ] :-hook ;      docol, ]comp
 [ELSE]  [ELSE]
 : (:noname) ( -- colon-sys )  : (:noname) ( -- colon-sys )
     \ common factor of : and :noname      \ common factor of : and :noname
     docol: cfa, defstart ] :-hook ;      docol: cfa,
 [THEN]  [THEN]
       defstart ] :-hook ;
   
 : : ( "name" -- colon-sys ) \ core      colon  : : ( "name" -- colon-sys ) \ core      colon
     Header (:noname) ;      Header (:noname) ;
Line 513 
Line 577 
     ;-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 postpone exit reveal postpone [ ; immediate restrict      ;-hook ?struc [compile] exit
       [ has? peephole [IF] ] finish-code [ [THEN] ]
       reveal postpone [ ; immediate restrict
 [THEN]  [THEN]
   
 \ \ Search list handling: reveal words, recursive               23feb93py  \ \ Search list handling: reveal words, recursive               23feb93py
   
 : last?   ( -- false / nfa nfa )  : last?   ( -- false / nfa nfa )
     last @ ?dup ;      latest ?dup ;
   
 : (reveal) ( nt wid -- )  : (reveal) ( nt wid -- )
     wordlist-id dup >r      wordlist-id dup >r
Line 537 
Line 603 
     >r 2dup 2dup r> (search-wordlist) warnings @ and ?dup if      >r 2dup 2dup r> (search-wordlist) warnings @ and ?dup if
         >stderr          >stderr
         ." redefined " name>string 2dup type          ." redefined " name>string 2dup type
         compare 0<> if          str= 0= if
             ."  with " type              ."  with " type
         else          else
             2drop              2drop

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

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help