[gforth] / gforth / kernel / comp.fs  

gforth: gforth/kernel/comp.fs

Diff for /gforth/kernel/comp.fs between version 1.27 and 1.99

version 1.27, Sat Aug 26 13:29:48 2000 UTC version 1.99, Fri Jan 8 18:54:34 2010 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,2004,2005,2006,2007,2008,2009 Free Software Foundation, Inc.
   
 \ This file is part of Gforth.  \ This file is part of Gforth.
   
 \ Gforth is free software; you can redistribute it and/or  \ Gforth is free software; you can redistribute it and/or
 \ modify it under the terms of the GNU General Public License  \ modify it under the terms of the GNU General Public License
 \ as published by the Free Software Foundation; either version 2  \ as published by the Free Software Foundation, either version 3
 \ of the License, or (at your option) any later version.  \ of the License, or (at your option) any later version.
   
 \ This program is distributed in the hope that it will be useful,  \ This program is distributed in the hope that it will be useful,
Line 15 
Line 15 
 \ GNU General Public License for more details.  \ GNU General Public License for more details.
   
 \ 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, see http://www.gnu.org/licenses/.
 \ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.  
   
 \ \ Revisions-Log  \ \ Revisions-Log
   
Line 48 
Line 47 
   
 : c,    ( c -- ) \ core c-comma  : 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 [ has? flash [IF] ] flashc! [ [ELSE] ] c! [ [THEN] ] ;
   
 : ,     ( w -- ) \ core comma  : ,     ( 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 [ has? flash [IF] ] flash! [ [ELSE] ] ! [ [THEN] ] ;
   
 : 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} there, @i{w2} first (lower address).      \G w2} there, @i{w2} first (lower address).
     here 2 cells allot 2! ;      here 2 cells allot  [ has? flash [IF] ] tuck flash! cell+ flash!
           [ [ELSE] ] 2! [ [THEN] ] ;
   
 \ : aligned ( addr -- addr' ) \ core  \ : aligned ( addr -- addr' ) \ core
 \     [ cell 1- ] Literal + [ -1 cells ] Literal and ;  \     [ cell 1- ] Literal + [ -1 cells ] Literal and ;
Line 105 
Line 105 
   
 : string, ( c-addr u -- ) \ gforth  : string, ( c-addr u -- ) \ gforth
     \G puts down string as cstring      \G puts down string as cstring
     dup c, here swap chars dup allot move ;      dup [ has? rom [IF] ] $E0 [ [ELSE] ] alias-mask [ [THEN] ] or c,
   [ has? flash [IF] ]
       bounds ?DO  I c@ c,  LOOP
   [ [ELSE] ]
       here swap chars dup allot move
   [ [THEN] ] ;
   
   : longstring, ( c-addr u -- ) \ gforth
       \G puts down string as longcstring
       dup , here swap chars dup allot move ;
   
   [IFDEF] prelude-mask
   variable next-prelude
   
   : prelude, ( -- )
       next-prelude @ if
           align next-prelude @ ,
       then ;
   [THEN]
   
 : header, ( c-addr u -- ) \ gforth  : header, ( c-addr u -- ) \ gforth
     name-too-long?      name-too-long?
       dup max-name-length @ max max-name-length !
       [ [IFDEF] prelude-mask ] prelude, [ [THEN] ]
     align here last !      align here last !
   [ has? ec [IF] ]
       -1 A,
   [ [ELSE] ]
     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  [ [THEN] ]
     alias-mask lastflags cset ;  [ has? f83headerstring [IF] ]
           string,
   [ [ELSE] ]
           longstring, alias-mask lastflags cset
           next-prelude @ 0<> prelude-mask and lastflags cset
           next-prelude off
   [ [THEN] ]
       cfalign ;
   
 : input-stream-header ( "name" -- )  : input-stream-header ( "name" -- )
     name name-too-short? header, ;      parse-name name-too-short? header, ;
   
 : input-stream ( -- )  \ general  : input-stream ( -- )  \ general
     \G switches back to getting the name from the input stream ;      \G switches back to getting the name from the input stream ;
Line 124 
Line 154 
   
 ' 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 182 
 : 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
Line 168 
Line 210 
     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 175 
Line 222 
     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@ ;      parse-name 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 192 
Line 242 
 : cfa,     ( code-address -- )  \ gforth        cfa-comma  : cfa,     ( code-address -- )  \ gforth        cfa-comma
     here      here
     dup lastcfa !      dup lastcfa !
     0 A, 0 ,  code-address! ;      [ has? rom [IF] ] 2 cells allot [ [ELSE] ] 0 A, 0 , [ [THEN] ]
       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]
   
   has? ec 0= [IF]
   defer basic-block-end ( -- )
   
   :noname ( -- )
       0 compile-prim1 ;
   is basic-block-end
   [THEN]
   
   has? primcentric [IF]
       has? peephole [IF]
           \ dynamic only
           : peephole-compile, ( xt -- )
               \ compile xt, appending its code to the current dynamic superinstruction
               here swap , compile-prim1 ;
       [ELSE]
           : peephole-compile, ( xt -- addr ) @ , ;
       [THEN]
   
   : 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
           ['] does-exec peephole-compile, , EXIT
           \ dup >body POSTPONE literal ['] call peephole-compile, >does-code , EXIT
       then
       dup >code-address CASE
           dovalue: OF >body ['] lit@ peephole-compile, , EXIT ENDOF
           docon:   OF >body @ ['] lit peephole-compile, , EXIT ENDOF
           \ docon:   OF >body POSTPONE literal ['] @ peephole-compile, EXIT ENDOF
           \ docon is also used by VALUEs, so don't @ at compile time
           docol:   OF >body ['] call peephole-compile, , EXIT ENDOF
           dovar:   OF >body ['] lit peephole-compile, , EXIT ENDOF
           douser:  OF >body @ ['] useraddr peephole-compile, , EXIT ENDOF
           dodefer: OF >body ['] lit-perform peephole-compile, , EXIT ENDOF
           dofield: OF >body @ ['] lit+ peephole-compile, , EXIT ENDOF
           \ dofield: OF >body @ POSTPONE literal ['] + peephole-compile, EXIT ENDOF
           \ code words and ;code-defined words (code words could be optimized):
           dup in-dictionary? IF drop POSTPONE literal ['] execute peephole-compile, 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! ;
   
   \ !! 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
   
 : name>comp ( nt -- w xt ) \ gforth  : name>comp ( nt -- w xt ) \ gforth name-to-comp
     \G @i{w xt} is the compilation token for the word @i{nt}.      \G @i{w xt} is the compilation token for the word @i{nt}.
     (name>comp)      (name>comp)
     1 = if      1 = if
Line 248 
Line 351 
     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
   
 : compiler ( c-addr u -- )  : compiler1 ( c-addr u -- ... xt )
     2dup find-name dup      2dup find-name [ [IFDEF] prelude-mask ] run-prelude [ [THEN] ] 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
   
 : ," ( "string"<"> -- ) [char] " parse  : S, ( addr u -- )
   here over char+ allot  place align ;      \ allot string as counted string
   [ has? flash [IF] ]
 : SLiteral ( Compilation c-addr1 u ; run-time -- c-addr2 u ) \ string      dup c, bounds ?DO  I c@ c,  LOOP
     \G Compilation: compile the string specified by @i{c-addr1},  [ [ELSE] ]
     \G @i{u} into the current definition. Run-time: return      here over char+ allot  place align
     \G @i{c-addr2 u} describing the address and length of the  [ [THEN] ] ;
     \G string.  
     postpone (S") here over char+ allot  place align ;  
                                              immediate restrict  
   
 \ \ abort"                                                      22feb93py  : mem, ( addr u -- )
       \ allot the memory block HERE (do alignment yourself)
   [ has? flash [IF] ]
       bounds ?DO  I c@ c,  LOOP
   [ [ELSE] ]
       here over allot swap move
   [ [THEN] ] ;
   
 : 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
   
   \ problematic only for big endian machines
   
   has? f83headerstring [IF]
 : cset ( bmask c-addr -- )  : cset ( bmask c-addr -- )
     tuck c@ or swap c! ;      tuck c@ or swap c! ;
   
Line 326 
Line 428 
   
 : ctoggle ( bmask c-addr -- )  : ctoggle ( bmask c-addr -- )
     tuck c@ xor swap c! ;      tuck c@ xor swap c! ;
   [ELSE]
   : cset ( bmask c-addr -- )
       tuck @ or swap ! ;
   
   : creset ( bmask c-addr -- )
       tuck @ swap invert and swap ! ;
   
   : ctoggle ( bmask c-addr -- )
       tuck @ xor swap ! ;
   [THEN]
   
 : 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}
     \G the execution semantics.      \G the execution semantics.
     immediate-mask lastflags cset ;      immediate-mask lastflags [ has? rom [IF] ] creset [ [ELSE] ] cset [ [THEN] ] ;
   
 : 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 [ has? rom [IF] ] creset [ [ELSE] ] cset [ [THEN] ] ;
   
 ' 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 361 
Line 473 
     Header reveal here lastcfa ! 0 A, 0 , DOES> ;      Header reveal here lastcfa ! 0 A, 0 , DOES> ;
 [THEN]  [THEN]
   
   has? flash [IF]
       : (variable) dpp @ normal-dp = IF  Create dpp @
           ELSE  normal-dp @ Constant dpp @ ram  THEN ;
   : Variable ( "name" -- ) \ core
       (Variable) 0 , dpp ! ;
   
   : AVariable ( "name" -- ) \ gforth
       (Variable) 0 A, dpp ! ;
   
   : 2Variable ( "name" -- ) \ double two-variable
       (Variable) 0 , 0 , dpp ! ;
   [ELSE]
 : Variable ( "name" -- ) \ core  : Variable ( "name" -- ) \ core
     Create 0 , ;      Create 0 , ;
   
Line 368 
Line 492 
     Create 0 A, ;      Create 0 A, ;
   
 : 2Variable ( "name" -- ) \ double two-variable  : 2Variable ( "name" -- ) \ double two-variable
     create 0 , 0 , ;      Create 0 , 0 , ;
   [THEN]
   
   has? no-userspace 0= [IF]
 : uallot ( n -- ) \ gforth  : uallot ( n -- ) \ gforth
     udp @ swap udp +! ;      udp @ swap udp +! ;
   
Line 386 
Line 512 
   
 : AUser User ;  : AUser User ;
 [THEN]  [THEN]
   [THEN]
   
 doer? :docon [IF]  doer? :docon [IF]
     : (Constant)  Header reveal docon: cfa, ;      : (Constant)  Header reveal docon: cfa, ;
Line 393 
Line 520 
     : (Constant)  Create DOES> @ ;      : (Constant)  Create DOES> @ ;
 [THEN]  [THEN]
   
   doer? :dovalue [IF]
       : (Value)  Header reveal dovalue: cfa, ;
   [ELSE]
       has? rom [IF]
           : (Value)  Create DOES> @ @ ;
       [ELSE]
           : (Value)  Create DOES> @ ;
       [THEN]
   [THEN]
   
 : Constant ( w "name" -- ) \ core  : Constant ( w "name" -- ) \ core
     \G Define a constant @i{name} with value @i{w}.      \G Define a constant @i{name} with value @i{w}.
     \G      \G
Line 402 
Line 539 
 : AConstant ( addr "name" -- ) \ gforth  : AConstant ( addr "name" -- ) \ gforth
     (Constant) A, ;      (Constant) A, ;
   
   has? flash [IF]
 : Value ( w "name" -- ) \ core-ext  : Value ( w "name" -- ) \ core-ext
     (Constant) , ;      (Value) dpp @ >r here cell allot >r
       ram here >r , r> r> flash! r> dpp ! ;
   
   ' Value alias AValue
   [ELSE]
   : Value ( w "name" -- ) \ core-ext
       (Value) , ;
   
   : AValue ( w "name" -- ) \ core-ext
       (Value) A, ;
   [THEN]
   
 : 2Constant ( w1 w2 "name" -- ) \ double two-constant  : 2Constant ( w1 w2 "name" -- ) \ double two-constant
     Create ( w1 w2 "name" -- )      Create ( w1 w2 "name" -- )
Line 416 
Line 564 
 [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
   
   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, ;      [ has? rom [IF] ] here >r cell allot
       dpp @ ram here r> flash! ['] defer-default A, dpp !
       [ [ELSE] ] ['] defer-default A, [ [THEN] ] ;
   
 [ELSE]  [ELSE]
   
       has? rom [IF]
           : Defer ( "name" -- ) \ gforth
               Create here >r cell allot
               dpp @ ram here r> flash! ['] defer-default A, dpp !
             DOES> @ @ execute ;
       [ELSE]
 : Defer ( "name" -- ) \ gforth  : Defer ( "name" -- ) \ gforth
     Create ['] noop A,              Create ['] defer-default A,
 DOES> @ execute ;  DOES> @ execute ;
       [THEN]
 [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 @ [ has? rom [IF] ] @ [ [THEN] ] ;
   
 : 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 445 
Line 627 
 :noname  :noname
     ;-hook ?struc      ;-hook ?struc
     [ has? xconds [IF] ] exit-like [ [THEN] ]      [ has? xconds [IF] ] exit-like [ [THEN] ]
     postpone (does>) dodoes,      here [ has? peephole [IF] ] 5 [ [ELSE] ] 4 [ [THEN] ] cells +
       postpone aliteral postpone (does>2) [compile] exit
       [ has? peephole [IF] ] finish-code [ [THEN] ] 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 [ has? rom [IF] ] @ [ [THEN] ] ! ;
   
 : <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:  
   
 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 500 
Line 670 
 [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 519 
Line 690 
     ;-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 ;
   
   Variable warnings ( -- addr ) \ gforth
   G -1 warnings T !
   
   has? ec [IF]
   : reveal ( -- ) \ gforth
       last?
       if \ the last word has a header
           dup ( name>link ) @ -1 =
           if \ it is still hidden
               forth-wordlist dup >r @ over
               [ has? flash [IF] ] flash! [ [ELSE] ] ! [  [THEN] ] r> !
           else
               drop
           then
       then ;
   [ELSE]
 : (reveal) ( nt wid -- )  : (reveal) ( nt wid -- )
     wordlist-id dup >r      wordlist-id dup >r
     @ over ( name>link ) !      @ over ( name>link ) !
Line 535 
Line 724 
 \ make entry in wordlist-map  \ make entry in wordlist-map
 ' (reveal) f83search reveal-method !  ' (reveal) f83search reveal-method !
   
 Variable warnings ( -- addr ) \ gforth  
 G -1 warnings T !  
   
 : check-shadow  ( addr count wid -- )  : check-shadow  ( addr count wid -- )
     \G prints a warning if the string is already present in the wordlist      \G prints a warning if the string is already present in the wordlist
     >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
Line 567 
Line 753 
   
 : rehash  ( wid -- )  : rehash  ( wid -- )
     dup wordlist-map @ rehash-method perform ;      dup wordlist-map @ rehash-method perform ;
   [THEN]
   
 ' reveal alias recursive ( compilation -- ; run-time -- ) \ gforth  ' reveal alias recursive ( compilation -- ; run-time -- ) \ gforth
 \g Make the current definition visible, enabling it to call itself  \g Make the current definition visible, enabling it to call itself

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

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help