[gforth] / gforth / kernel / comp.fs  

gforth: gforth/kernel/comp.fs

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

version 1.17, Sun May 16 17:13:25 1999 UTC version 1.59, Sun Oct 5 15:01:17 2003 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 35 
Line 35 
 \ we default to this version if we have nothing else 05May99jaw  \ we default to this version if we have nothing else 05May99jaw
 [IFUNDEF] allot  [IFUNDEF] allot
 : allot ( n -- ) \ core  : allot ( n -- ) \ core
     \G Reserve or release @i{n} address units of data space without      \G Reserve @i{n} address units of data space without
     \G initialization; @i{n} is a signed number.  In ANS Forth you can      \G initialization. @i{n} is a signed number, passing a negative
     \G only deallocate memory from the current contiguous region in      \G @i{n} releases memory.  In ANS Forth you can only deallocate
     \G this way.  In Gforth you can deallocate anything in this way      \G memory from the current contiguous region in this way.  In
     \G but named words.  The system does not check this restriction.      \G Gforth you can deallocate anything in this way but named words.
       \G The system does not check this restriction.
     here +      here +
     dup 1- usable-dictionary-end forthstart within -8 and throw      dup 1- usable-dictionary-end forthstart within -8 and throw
     dp ! ;      dp ! ;
 [THEN]  [THEN]
   
 : c,    ( c -- ) \ core  : c,    ( c -- ) \ core c-comma
     \G Reserve data space for one char and store @i{c} in the space.      \G Reserve data space for one char and store @i{c} in the space.
     here 1 chars allot c! ;      here 1 chars allot c! ;
   
 : ,     ( w -- ) \ core  : ,     ( w -- ) \ core comma
     \G Reserve data space for one cell and store @i{w} in the space.      \G Reserve data space for one cell and store @i{w} in the space.
     here cell allot  ! ;      here cell allot  ! ;
   
 : 2,    ( w1 w2 -- ) \ gforth  : 2,    ( w1 w2 -- ) \ gforth
     \G Reserve data space for two cells and store the double @i{w1      \G Reserve data space for two cells and store the double @i{w1
     \G w2} in the space.      \G w2} there, @i{w2} first (lower address).
     here 2 cells allot 2! ;      here 2 cells allot 2! ;
   
 \ : aligned ( addr -- addr' ) \ core  \ : aligned ( addr -- addr' ) \ core
Line 65 
Line 66 
     \G If the data-space pointer is not aligned, reserve enough space to align it.      \G If the data-space pointer is not aligned, reserve enough space to align it.
     here dup aligned swap ?DO  bl c,  LOOP ;      here dup aligned swap ?DO  bl c,  LOOP ;
   
 \ : faligned ( addr -- f-addr ) \ float  \ : faligned ( addr -- f-addr ) \ float f-aligned
 \     [ 1 floats 1- ] Literal + [ -1 floats ] Literal and ;  \     [ 1 floats 1- ] Literal + [ -1 floats ] Literal and ;
   
 : falign ( -- ) \ float  : falign ( -- ) \ float f-align
     \G If the data-space pointer is not float-aligned, reserve      \G If the data-space pointer is not float-aligned, reserve
     \G enough space to align it.      \G enough space to align it.
     here dup faligned swap      here dup faligned swap
Line 77 
Line 78 
     LOOP ;      LOOP ;
   
 : maxalign ( -- ) \ gforth  : maxalign ( -- ) \ gforth
       \G Align data-space pointer for all alignment requirements.
     here dup maxaligned swap      here dup maxaligned swap
     ?DO      ?DO
         bl c,          bl c,
Line 84 
Line 86 
   
 \ the code field is aligned if its body is maxaligned  \ the code field is aligned if its body is maxaligned
 ' maxalign Alias cfalign ( -- ) \ gforth  ' maxalign Alias cfalign ( -- ) \ gforth
   \G Align data-space pointer for code field requirements (i.e., such
   \G that the corresponding body is maxaligned).
   
 ' , alias A, ( addr -- ) \ gforth  ' , alias A, ( addr -- ) \ gforth
   
Line 103 
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 120 
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 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
     input-stream ;      input-stream ;
   
 : noname ( -- ) \ gforth  : noname ( -- ) \ gforth
 \ the next defined word remains anonymous. The xt of that word is given by lastxt      \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 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 186 
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 ( -- )
   
   ' noop 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 ;
Line 204 
Line 270 
 : (compile) ( -- ) \ gforth  : (compile) ( -- ) \ gforth
     r> dup cell+ >r @ compile, ;      r> dup cell+ >r @ compile, ;
   
 : postpone, ( w xt -- ) \ gforth        postpone-comma  
     \g Compile the compilation semantics represented by @i{w xt}.  
     dup ['] execute =  
     if  
         drop compile,  
     else  
         dup ['] compile, =  
         if  
             drop POSTPONE (compile) a,  
         else  
             swap POSTPONE aliteral compile,  
         then  
     then ;  
   
 : POSTPONE ( "name" -- ) \ core  
     \g Compiles the compilation semantics of @i{name}.  
     COMP' postpone, ; immediate restrict  
   
 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 ;  
   
 \ \ ticks  \ \ ticks
   
 : name>comp ( nt -- w xt ) \ gforth  : name>comp ( nt -- w xt ) \ gforth
Line 262 
Line 298 
     \g Compilation token @i{w xt} represents @i{name}'s compilation semantics.      \g Compilation token @i{w xt} represents @i{name}'s compilation semantics.
     COMP' swap POSTPONE Aliteral POSTPONE ALiteral ; immediate restrict      COMP' swap POSTPONE Aliteral POSTPONE ALiteral ; immediate restrict
   
   : postpone, ( w xt -- ) \ gforth        postpone-comma
       \g Compile the compilation semantics represented by the
       \g compilation token @i{w xt}.
       dup ['] execute =
       if
           drop compile,
       else
           dup ['] compile, =
           if
               drop POSTPONE (compile) a,
           else
               swap POSTPONE aliteral compile,
           then
       then ;
   
   : POSTPONE ( "name" -- ) \ core
       \g Compiles the compilation semantics of @i{name}.
       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 299 
Line 354 
   
 \ \ 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 342 
Line 389 
 : restrict ( -- ) \ gforth  : restrict ( -- ) \ gforth
     \G A synonym for @code{compile-only}      \G A synonym for @code{compile-only}
     restrict-mask lastflags cset ;      restrict-mask lastflags cset ;
   
 ' restrict alias compile-only ( -- ) \ gforth  ' restrict alias compile-only ( -- ) \ gforth
 \G Remove the interpretation semantics of a word.  \G Remove the interpretation semantics of a word.
   
Line 368 
Line 416 
 : AVariable ( "name" -- ) \ gforth  : AVariable ( "name" -- ) \ gforth
     Create 0 A, ;      Create 0 A, ;
   
 : 2Variable ( "name" -- ) \ double  : 2Variable ( "name" -- ) \ double two-variable
     create 0 , 0 , ;      create 0 , 0 , ;
   
 : uallot ( n -- )  udp @ swap udp +! ;  : uallot ( n -- ) \ gforth
       udp @ swap udp +! ;
   
 doer? :douser [IF]  doer? :douser [IF]
   
Line 405 
Line 454 
 : Value ( w "name" -- ) \ core-ext  : Value ( w "name" -- ) \ core-ext
     (Constant) , ;      (Constant) , ;
   
 : 2Constant ( w1 w2 "name" -- ) \ double  : AValue ( w "name" -- ) \ core-ext
       (Constant) A, ;
   
   : 2Constant ( w1 w2 "name" -- ) \ double two-constant
     Create ( w1 w2 "name" -- )      Create ( w1 w2 "name" -- )
         2,          2,
     DOES> ( -- w1 w2 )      DOES> ( -- w1 w2 )
Line 416 
Line 468 
 [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 424 
Line 491 
     \ !! shouldn't it be initialized with abort or something similar?      \ !! shouldn't it be initialized with abort or something similar?
     Header Reveal dodefer: cfa,      Header Reveal dodefer: cfa,
     ['] noop A, ;      ['] noop A, ;
   
 [ELSE]  [ELSE]
   
 : Defer ( "name" -- ) \ gforth  : Defer ( "name" -- ) \ gforth
     Create ['] noop A,      Create ['] noop A,
 DOES> @ execute ;  DOES> @ execute ;
   
 [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
       dodoes, here !does ]
       defstart :-hook ;
   :noname
       ;-hook ?struc
       [ has? xconds [IF] ] exit-like [ [THEN] ]
       postpone (does>) dodoes,
       defstart :-hook ;
   interpret/compile: DOES>  ( compilation colon-sys1 -- colon-sys2 ; run-time nest-sys -- ) \ core        does
   
   : <IS> ( "name" xt -- ) \ gforth
       \g Changes the @code{defer}red word @var{name} to execute @var{xt}.
       ' >body ! ;
   
   : [IS] ( compilation "name" -- ; run-time xt -- ) \ gforth bracket-is
       \g At run-time, changes the @code{defer}red word @var{name} to
       \g execute @var{xt}.
       ' >body postpone ALiteral postpone ! ; immediate restrict
   
   ' <IS>
   ' [IS]
   interpret/compile: IS ( xt "name" -- ) \ gforth
   \G A combined word made up from @code{<IS>} and @code{[IS]}.
   
   ' <IS>
   ' [IS]
   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 )
       >does-code ['] DOES> >does-code = ;
   
 \ \ : ;                                                         24feb93py  \ \ : ;                                                         24feb93py
   
 defer :-hook ( sys1 -- sys2 )  defer :-hook ( sys1 -- sys2 )
Line 445 
Line 553 
 [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 464 
Line 573 
     ;-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 488 
Line 599 
     >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.17  
changed lines
  Added in v.1.59
CVS Admin

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help