[gforth] / gforth / kernel / comp.fs  

gforth: gforth/kernel/comp.fs

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

version 1.78, Sat Feb 25 18:28:12 2006 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,2000,2003,2004,2005 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., 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 ;
   
   [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 !      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
   [ [THEN] ]
 [ has? f83headerstring [IF] ]  [ has? f83headerstring [IF] ]
         string,          string,
 [ [ELSE] ]  [ [ELSE] ]
         longstring, cfalign          longstring, alias-mask lastflags cset
           next-prelude @ 0<> prelude-mask and lastflags cset
           next-prelude off
 [ [THEN] ]  [ [THEN] ]
     alias-mask lastflags cset ;      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 207 
Line 228 
 : 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 count char@ 2drop ;      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 221 
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,
 defer compile, ( xt -- )        \ core-ext      compile-comma  defer compile, ( xt -- )        \ core-ext      compile-comma
Line 231 
Line 253 
 ' , 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? primcentric [IF]
 has? peephole [IF]  has? peephole [IF]
   
 \ dynamic only  \ dynamic only
 : peephole-compile, ( xt -- )  : peephole-compile, ( xt -- )
     \ compile xt, appending its code to the current dynamic superinstruction      \ compile xt, appending its code to the current dynamic superinstruction
     here swap , compile-prim1 ;      here swap , compile-prim1 ;
       [ELSE]
           : peephole-compile, ( xt -- addr ) @ , ;
       [THEN]
   
 : compile-to-prims, ( xt -- )  : compile-to-prims, ( xt -- )
     \G compile xt to use primitives (and their peephole optimization)      \G compile xt to use primitives (and their peephole optimization)
Line 253 
Line 280 
         \ 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 290 
Line 318 
   
 \ \ 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 339 
Line 367 
 \ \ compiler loop  \ \ compiler loop
   
 : compiler1 ( c-addr u -- ... xt )  : 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          nip nip name>comp
     else      else
Line 370 
Line 398 
   
 : 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 389 
Line 437 
   
 : 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 398 
Line 447 
 : 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 424 
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 431 
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]  has? no-userspace 0= [IF]
 : uallot ( n -- ) \ gforth  : uallot ( n -- ) \ gforth
Line 477 
Line 539 
 : AConstant ( addr "name" -- ) \ gforth  : AConstant ( addr "name" -- ) \ gforth
     (Constant) A, ;      (Constant) A, ;
   
   has? flash [IF]
   : Value ( w "name" -- ) \ core-ext
       (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 ( w "name" -- ) \ core-ext
     (Value) , ;      (Value) , ;
   
 : AValue ( w "name" -- ) \ core-ext  : AValue ( w "name" -- ) \ core-ext
     (Value) 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 522 
Line 592 
 \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]      has? rom [IF]
         : Defer ( "name" -- ) \ gforth          : Defer ( "name" -- ) \ gforth
             Create ['] defer-default A,              Create here >r cell allot
               dpp @ ram here r> flash! ['] defer-default A, dpp !
           DOES> @ @ execute ;            DOES> @ @ execute ;
     [ELSE]      [ELSE]
         : Defer ( "name" -- ) \ gforth          : Defer ( "name" -- ) \ gforth
Line 540 
Line 613 
 : 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 554 
Line 627 
 :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 -- ) \ gforth  defer-store  : 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 626 
Line 700 
 : 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 634 
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
Line 666 
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.78  
changed lines
  Added in v.1.99
CVS Admin

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help