[gforth] / gforth / kernel / comp.fs  

gforth: gforth/kernel/comp.fs

Diff for /gforth/kernel/comp.fs between version 1.8 and 1.103

version 1.8, Wed Feb 3 00:10:24 1999 UTC version 1.103, Sun Apr 25 18:27:10 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 24 
Line 23 
   
 \ \ here allot , c, A,                                          17dec92py  \ \ here allot , c, A,                                          17dec92py
   
   [IFUNDEF] allot
   [IFUNDEF] forthstart
 : allot ( n -- ) \ core  : allot ( n -- ) \ core
     dup unused u> -8 and throw      dup unused u> -8 and throw
     dp +! ;      dp +! ;
   [THEN]
   [THEN]
   
 : c,    ( c -- ) \ core  \ we default to this version if we have nothing else 05May99jaw
     here 1 chars allot c! ;  [IFUNDEF] allot
   : allot ( n -- ) \ core
       \G Reserve @i{n} address units of data space without
       \G initialization. @i{n} is a signed number, passing a negative
       \G @i{n} releases memory.  In ANS Forth you can only deallocate
       \G memory from the current contiguous region in this way.  In
       \G Gforth you can deallocate anything in this way but named words.
       \G The system does not check this restriction.
       here +
       dup 1- usable-dictionary-end forthstart within -8 and throw
       dp ! ;
   [THEN]
   
 : ,     ( x -- ) \ core  : c,    ( c -- ) \ core c-comma
     here cell allot  ! ;      \G Reserve data space for one char and store @i{c} in the space.
       here 1 chars allot [ has? flash [IF] ] flashc! [ [ELSE] ] c! [ [THEN] ] ;
   
   : ,     ( w -- ) \ core comma
       \G Reserve data space for one cell and store @i{w} in the space.
       here cell allot [ has? flash [IF] ] flash! [ [ELSE] ] ! [ [THEN] ] ;
   
 : 2,    ( w1 w2 -- ) \ gforth  : 2,    ( w1 w2 -- ) \ gforth
     here 2 cells allot 2! ;      \G Reserve data space for two cells and store the double @i{w1
       \G w2} there, @i{w2} first (lower address).
       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 ;
   
 : align ( -- ) \ core  : align ( -- ) \ core
       \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 enough space to align it.
     here dup faligned swap      here dup faligned swap
     ?DO      ?DO
         bl c,          bl c,
     LOOP ;      LOOP ;
   
 : maxalign ( -- ) \ float  : 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 60 
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 77 
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 96 
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 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
 \ 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      \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
     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, 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}.@*
     postpone lit  , ; immediate restrict      \G Interpretation semantics: undefined.
   [ [IFDEF] lit, ]
       lit,
   [ [ELSE] ]
       postpone lit ,
   [ [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
     postpone lit A, ; immediate restrict  [ [IFDEF] alit, ]
       alit,
   [ [ELSE] ]
       postpone lit A,
   [ [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 ccc and return c, the      \G Skip leading spaces. Parse the string @i{ccc} and return @i{c}, the
     \G display code representing the first character of 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 ccc. Run-time:      \G Compilation: skip leading spaces. Parse the string
     \G return c, the display code representing the first character of ccc.      \G @i{ccc}. Run-time: return @i{c}, the display code
     \G Interpretation semantics for this word are undefined.      \G representing the first character of @i{ccc}.  Interpretation
       \G semantics for this word are undefined.
     char postpone Literal ; immediate restrict      char postpone Literal ; immediate restrict
   
 \ \ threading                                                   17mar93py  \ \ threading                                                   17mar93py
Line 149 
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! ;
   
 : compile, ( xt -- )    \ core-ext      compile-comma  [IFUNDEF] compile,
     \G  Blah, blah.  defer compile, ( xt -- )        \ core-ext      compile-comma
     A, ;  \G  Compile the word represented by the execution token @i{xt}
   \G  into the current definition.
   
 : !does    ( addr -- ) \ gforth store-does  ' , is compile,
     lastxt does-code! ;  [THEN]
   
 : (does>)  ( R: addr -- )  has? ec 0= [IF]
     r> cfaligned /does-handler + !does ;  defer basic-block-end ( -- )
   
 : dodoes,  ( -- )  :noname ( -- )
   cfalign here /does-handler allot does-handler! ;      0 compile-prim1 ;
   is basic-block-end
   [THEN]
   
 : (compile) ( -- ) \ gforth  has? primcentric [IF]
     r> dup cell+ >r @ compile, ;      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]
   
 : postpone, ( w xt -- ) \ gforth        postpone-comma  : compile-to-prims, ( xt -- )
     \g Compiles the compilation semantics represented by @var{w xt}.      \G compile xt to use primitives (and their peephole optimization)
     dup ['] execute =      \G instead of ","-ing the xt.
     if      \ !! all POSTPONEs here postpone primitives; this can be optimized
         drop compile,      dup >does-code if
     else          ['] does-exec peephole-compile, , EXIT
         dup ['] compile, =          \ dup >body POSTPONE literal ['] call peephole-compile, >does-code , EXIT
         if  
             drop POSTPONE (compile) compile,  
         else  
             swap POSTPONE aliteral compile,  
         then          then
     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
           doabicode: OF >body ['] abi-call peephole-compile, , EXIT ENDOF
           do;abicode: OF ['] ;abi-code-exec peephole-compile, , EXIT ENDOF
           \ code words and ;code-defined words (code words could be optimized):
           dup in-dictionary? IF ['] ;code-exec peephole-compile, , EXIT THEN
           \ dup in-dictionary? IF drop POSTPONE literal ['] execute peephole-compile, EXIT THEN
       ENDCASE
       peephole-compile, ;
   
 : POSTPONE ( "name" -- ) \ core  ' compile-to-prims, IS compile,
     \g Compiles the compilation semantics of @var{name}.  [ELSE]
     COMP' postpone, ; immediate restrict  ' , is compile,
   [THEN]
   
 struct  : !does    ( addr -- ) \ gforth store-does
     >body      latestxt does-code! ;
     cell% field interpret/compile-int  
     cell% field interpret/compile-comp  
 end-struct interpret/compile-struct  
   
 : interpret/compile: ( interp-xt comp-xt "name" -- ) \ gforth  \ : (does>)  ( R: addr -- )
     Create immediate swap A, A,  \     r> cfaligned /does-handler + !does ; \ !! no gforth-native
 DOES>  
     abort" executed primary cfa of an interpret/compile: word" ;  \ \ !! unused, but ifdefed/gosted in some places
 \    state @ IF  cell+  THEN  perform ;  \ : (does>2)  ( addr -- )
   \     cfaligned /does-handler + !does ;
   
   : (compile) ( -- ) \ gforth-obsolete: dummy
       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 @var{w xt} is the compilation token for the word @var{nt}.      \G @i{w xt} is the compilation token for the word @i{nt}.
     (name>comp)      (name>comp)
     1 = if      1 = if
         ['] execute          ['] execute
Line 212 
Line 331 
     (') postpone ALiteral ; immediate restrict      (') postpone ALiteral ; immediate restrict
   
 : [']  ( compilation. "name" -- ; run-time. -- xt ) \ core      bracket-tick  : [']  ( compilation. "name" -- ; run-time. -- xt ) \ core      bracket-tick
     \g @var{xt} represents @var{name}'s interpretation      \g @i{xt} represents @i{name}'s interpretation
     \g semantics. Performs @code{-14 throw} if the word has no      \g semantics. Perform @code{-14 throw} if the word has no
     \g interpretation semantics.      \g interpretation semantics.
     ' postpone ALiteral ; immediate restrict      ' postpone ALiteral ; immediate restrict
   
 : COMP'    ( "name" -- w xt ) \ gforth  comp-tick  : COMP'    ( "name" -- w xt ) \ gforth  comp-tick
     \g @var{w xt} represents @var{name}'s compilation semantics.      \g Compilation token @i{w xt} represents @i{name}'s compilation semantics.
     (') name>comp ;      (') name>comp ;
   
 : [COMP']  ( compilation "name" -- ; run-time -- w xt ) \ gforth bracket-comp-tick  : [COMP']  ( compilation "name" -- ; run-time -- w xt ) \ gforth bracket-comp-tick
     \g @var{w xt} represents @var{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
           swap POSTPONE aliteral compile,
       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 calls 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 c-addr1, u into  [ [ELSE] ]
     \G the current definition. Run-time: return c-addr2 u describing      here over char+ allot  place align
     \G the address and length of the string.  [ [THEN] ] ;
     postpone (S") here over char+ allot  place align ;  
                                              immediate restrict  : mem, ( addr u -- )
       \ allot the memory block HERE (do alignment yourself)
 \ \ abort"                                                      22feb93py  [ 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"<"> -- )
     postpone (abort") ," ;        immediate restrict      [char] " parse s, ;
   
 \ \ 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 287 
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
     immediate-mask lastflags cset ;      \G Make the compilation semantics of a word be to @code{execute}
       \G the execution semantics.
       immediate-mask lastflags [ has? rom [IF] ] creset [ [ELSE] ] cset [ [THEN] ] ;
   
 : restrict ( -- ) \ gforth  : restrict ( -- ) \ gforth
     restrict-mask lastflags cset ;      \G A synonym for @code{compile-only}
       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.
   
 \ \ Create Variable User Constant                               17mar93py  \ \ Create Variable User Constant                               17mar93py
   
 : Alias    ( cfa "name" -- ) \ gforth  : Alias    ( xt "name" -- ) \ gforth
     Header reveal      Header reveal
     alias-mask lastflags creset      alias-mask lastflags creset
     dup A, lastcfa ! ;      dup A, lastcfa ! ;
Line 317 
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 , ;
   
 : 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 , ;
   [THEN]
   
 : uallot ( n -- )  udp @ swap udp +! ;  has? no-userspace 0= [IF]
   : uallot ( n -- ) \ gforth
       udp @ swap udp +! ;
   
 doer? :douser [IF]  doer? :douser [IF]
   
Line 341 
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 348 
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 Defines constant @var{name}      \G Define a constant @i{name} with value @i{w}.
     \G      \G
     \G @var{name} execution: @var{-- w}      \G @i{name} execution: @i{-- w}
     (Constant) , ;      (Constant) , ;
   
 : 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  : 2Constant ( w1 w2 "name" -- ) \ double two-constant
     Create ( w1 w2 "name" -- )      Create ( w1 w2 "name" -- )
         2,          2,
     DOES> ( -- w1 w2 )      DOES> ( -- w1 w2 )
Line 371 
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]
   
 : Defers ( "name" -- ) \ gforth  : defer@ ( xt-deferred -- xt ) \ gforth defer-fetch
     ' >body @ compile, ; immediate  \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
       \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.
       ' defer@ compile, ; immediate
   
   : does>-like ( xt -- )
       \ xt ( addr -- ) is !does or !;abi-code etc, addr is the address
       \ that should be stored right after the code address.
       >r ;-hook ?struc
       [ has? xconds [IF] ] exit-like [ [THEN] ]
       here [ has? peephole [IF] ] 5 [ [ELSE] ] 4 [ [THEN] ] cells +
       postpone aliteral r> compile, [compile] exit
       [ has? peephole [IF] ] finish-code [ [THEN] ]
       defstart ;
   
   :noname
       here !does ]
       defstart :-hook ;
   :noname
       ['] !does does>-like :-hook ;
   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
       \g Changes the @code{defer}red word @var{name} to execute @var{xt}.
       ' defer! ;
   
   : [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}.
       ' postpone ALiteral postpone defer! ; immediate restrict
   
   ' <IS>
   ' [IS]
   interpret/compile: IS ( compilation/interpretation "name-deferred" -- ; run-time xt -- ) \ gforth
   \G Changes the @code{defer}red word @var{name} to execute @var{xt}.
   \G Its compilation semantics parses at compile time.
   
   ' <IS>
   ' [IS]
   interpret/compile: TO ( w "name" -- ) \ core-ext
   
   : interpret/compile? ( xt -- flag )
       >does-code ['] DOES> >does-code = ;
   
 \ \ : ;                                                         24feb93py  \ \ : ;                                                         24feb93py
   
Line 395 
Line 670 
   
 defer ;-hook ( sys2 -- sys1 )  defer ;-hook ( sys2 -- sys1 )
   
   0 Constant defstart
   
   [IFDEF] docol,
 : (:noname) ( -- colon-sys )  : (:noname) ( -- colon-sys )
     \ common factor of : and :noname      \ common factor of : and :noname
     docol: cfa, defstart ] :-hook ;      docol, ]comp
   [ELSE]
   : (:noname) ( -- colon-sys )
       \ common factor of : and :noname
       docol: cfa,
   [THEN]
       defstart ] :-hook ;
   
 : : ( "name" -- colon-sys ) \ core      colon  : : ( "name" -- colon-sys ) \ core      colon
     Header (:noname) ;      Header (:noname) ;
Line 406 
Line 690 
     0 last !      0 last !
     cfalign here (:noname) ;      cfalign here (:noname) ;
   
   [IFDEF] fini,
 : ; ( 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 fini, comp[ reveal postpone [ ; immediate restrict
   [ELSE]
   : ; ( compilation colon-sys -- ; run-time nest-sys ) \ core     semicolon
       ;-hook ?struc [compile] exit
       [ has? peephole [IF] ] finish-code [ [THEN] ]
       reveal postpone [ ; immediate restrict
   [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 422 
Line 729 
 \ 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 454 
Line 758 
   
 : 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 makes the current definition visible, enabling it to call itself  \g Make the current definition visible, enabling it to call itself
 \g recursively.  \g recursively.
         immediate restrict          immediate restrict

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

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help