[gforth] / gforth / kernel / comp.fs  

gforth: gforth/kernel/comp.fs

Diff for /gforth/kernel/comp.fs between version 1.68 and 1.96

version 1.68, Sun Nov 28 20:35:06 2004 UTC version 1.96, Sat Sep 5 17:38:37 2009 UTC
Line 1 
Line 1 
 \ compiler definitions                                          14sep97jaw  \ compiler definitions                                          14sep97jaw
   
 \ Copyright (C) 1995,1996,1997,1998,2000,2003 Free Software Foundation, Inc.  \ Copyright (C) 1995,1996,1997,1998,2000,2003,2004,2005,2006,2007,2008 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., 59 Temple Place, Suite 330, Boston, MA 02111, 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  : longstring, ( c-addr u -- ) \ gforth
     \G puts down string as longcstring      \G puts down string as longcstring
     dup , here swap chars dup allot move ;      dup , here swap chars dup allot move ;
   
   variable next-prelude
   
   : prelude, ( -- )
       next-prelude @ if
           align next-prelude @ ,
       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 !      dup max-name-length @ max max-name-length !
       prelude,
     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
     longstring, 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 185 
Line 208 
     postpone lit ,      postpone lit ,
 [ [THEN] ] ; immediate restrict  [ [THEN] ] ; immediate restrict
   
   : 2Literal ( compilation w1 w2 -- ; run-time  -- w1 w2 ) \ double two-literal
       \G Compile appropriate code such that, at run-time, @i{w1 w2} are
       \G placed on the stack. Interpretation semantics are undefined.
       swap postpone Literal  postpone Literal ; immediate restrict
   
 : ALiteral ( compilation addr -- ; run-time -- addr ) \ gforth  : ALiteral ( compilation addr -- ; run-time -- addr ) \ gforth
 [ [IFDEF] alit, ]  [ [IFDEF] alit, ]
     alit,      alit,
Line 192 
Line 220 
     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 209 
Line 240 
 : 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,
 defer compile, ( xt -- )        \ core-ext      compile-comma  defer compile, ( xt -- )        \ core-ext      compile-comma
Line 219 
Line 251 
 ' , is compile,  ' , is compile,
 [THEN]  [THEN]
   
   has? ec 0= [IF]
 defer basic-block-end ( -- )  defer basic-block-end ( -- )
   
 :noname ( -- )  :noname ( -- )
     0 compile-prim1 ;      0 compile-prim1 ;
 is basic-block-end  is basic-block-end
   [THEN]
   
 has? peephole [IF]  has? peephole [IF]
   
Line 241 
Line 275 
         \ dup >body POSTPONE literal ['] call peephole-compile, >does-code , EXIT          \ dup >body POSTPONE literal ['] call peephole-compile, >does-code , EXIT
     then      then
     dup >code-address CASE      dup >code-address CASE
         docon:   OF >body ['] lit@ peephole-compile, , EXIT ENDOF          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:   OF >body POSTPONE literal ['] @ peephole-compile, EXIT ENDOF
         \ docon is also used by VALUEs, so don't @ at compile time          \ docon is also used by VALUEs, so don't @ at compile time
         docol:   OF >body ['] call peephole-compile, , EXIT ENDOF          docol:   OF >body ['] call peephole-compile, , EXIT ENDOF
Line 278 
Line 313 
   
 \ \ 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 326 
Line 361 
   
 \ \ compiler loop  \ \ compiler loop
   
 : compiler ( c-addr u -- )  : compiler1 ( c-addr u -- ... xt )
     2dup find-name dup      2dup find-name-run-prelude 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
   
 : S, ( addr u -- )  : S, ( addr u -- )
     \ allot string as counted string      \ allot string as counted string
     here over char+ allot  place align ;  [ has? flash [IF] ]
       dup c, bounds ?DO  I c@ c,  LOOP
   [ [ELSE] ]
       here over char+ allot  place align
   [ [THEN] ] ;
   
 : mem, ( addr u -- )  : mem, ( addr u -- )
     \ allot the memory block HERE (do alignment yourself)      \ allot the memory block HERE (do alignment yourself)
     here over allot swap move ;  [ has? flash [IF] ]
       bounds ?DO  I c@ c,  LOOP
   [ [ELSE] ]
       here over allot swap move
   [ [THEN] ] ;
   
 : ," ( "string"<"> -- )  : ," ( "string"<"> -- )
     [char] " parse s, ;      [char] " parse s, ;
   
 \ \ Header states                                               23feb93py  \ \ Header states                                               23feb93py
   
   \ problematic only for big endian machines
   
   has? f83headerstring [IF]
   : cset ( bmask c-addr -- )
       tuck c@ or swap c! ;
   
   : creset ( bmask c-addr -- )
       tuck c@ swap invert and swap c! ;
   
   : ctoggle ( bmask c-addr -- )
       tuck c@ xor swap c! ;
   [ELSE]
 : cset ( bmask c-addr -- )  : cset ( bmask c-addr -- )
     tuck @ or swap ! ;      tuck @ or swap ! ;
   
Line 376 
Line 432 
   
 : ctoggle ( bmask c-addr -- )  : ctoggle ( bmask c-addr -- )
     tuck @ xor swap ! ;      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
Line 385 
Line 442 
 : 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 411 
Line 468 
     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 418 
Line 487 
     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 436 
Line 507 
   
 : AUser User ;  : AUser User ;
 [THEN]  [THEN]
   [THEN]
   
 doer? :docon [IF]  doer? :docon [IF]
     : (Constant)  Header reveal docon: cfa, ;      : (Constant)  Header reveal docon: cfa, ;
Line 443 
Line 515 
     : (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 452 
Line 534 
 : 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  : AValue ( w "name" -- ) \ core-ext
     (Constant) A, ;      (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 487 
Line 577 
 \ IS Defer What's Defers TO                            24feb93py  \ IS Defer What's Defers TO                            24feb93py
   
 defer defer-default ( -- )  defer defer-default ( -- )
 ' noop is defer-default  ' abort is defer-default
 \ default action for deferred words, might THROW in the future  \ default action for deferred words (overridden by a warning later)
   
 doer? :dodefer [IF]  doer? :dodefer [IF]
   
Line 497 
Line 587 
 \G set with @code{defer!} or @code{is} (and they have to, before first  \G set with @code{defer!} or @code{is} (and they have to, before first
 \G executing @i{name}.  \G executing @i{name}.
     Header Reveal dodefer: cfa,      Header Reveal dodefer: cfa,
     ['] defer-default 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 ['] defer-default A,      Create ['] defer-default A,
 DOES> @ execute ;  DOES> @ execute ;
       [THEN]
 [THEN]  [THEN]
   
 : defer@ ( xt-deferred -- xt ) \ gforth defer-fetch  : defer@ ( xt-deferred -- xt ) \ gforth defer-fetch
 \G @i{xt} represents the word currently associated with the deferred  \G @i{xt} represents the word currently associated with the deferred
 \G word @i{xt-deferred}.  \G word @i{xt-deferred}.
     >body @ ;      >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}
Line 524 
Line 622 
 :noname  :noname
     ;-hook ?struc      ;-hook ?struc
     [ has? xconds [IF] ] exit-like [ [THEN] ]      [ has? xconds [IF] ] exit-like [ [THEN] ]
     here 5 cells + postpone aliteral postpone (does>2) [compile] exit      here [ has? peephole [IF] ] 5 [ [ELSE] ] 4 [ [THEN] ] cells +
     finish-code dodoes,      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 -- )  : defer! ( xt xt-deferred -- ) \ gforth  defer-store
 \G Changes the @code{defer}red word @var{xt-deferred} to execute @var{xt}.  \G Changes the @code{defer}red word @var{xt-deferred} to execute @var{xt}.
     >body ! ;      >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}.
Line 596 
Line 695 
 : last?   ( -- false / nfa nfa )  : last?   ( -- false / nfa nfa )
     latest ?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 604 
Line 719 
 \ 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
Line 636 
Line 748 
   
 : 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.68  
changed lines
  Added in v.1.96
CVS Admin

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help