[gforth] / gforth / kernel / comp.fs  

gforth: gforth/kernel/comp.fs

Diff for /gforth/kernel/comp.fs between version 1.67 and 1.80

version 1.67, Sun Nov 28 20:20:38 2004 UTC version 1.80, Sun Feb 26 17:23:47 2006 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 Free Software Foundation, Inc.
   
 \ This file is part of Gforth.  \ This file is part of Gforth.
   
Line 117 
Line 117 
     align here last !      align here last !
     current @ 1 or A,   \ link field; before revealing, it contains the      current @ 1 or A,   \ link field; before revealing, it contains the
                         \ tagged reveal-into wordlist                          \ tagged reveal-into wordlist
     longstring, cfalign  [ has? f83headerstring [IF] ]
     alias-mask lastflags cset ;          string,
   [ [ELSE] ]
           longstring,
   [ [THEN] ]
       cfalign alias-mask lastflags cset ;
   
 : 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 189 
     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 201 
     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@ ;      bl word count 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 219 
Line 231 
 ' , 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 326 
Line 340 
   
 \ \ compiler loop  \ \ compiler loop
   
 : compiler ( c-addr u -- )  : compiler1 ( c-addr u -- ... xt )
     2dup find-name dup      2dup find-name 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
   
Line 420 
Line 435 
 : 2Variable ( "name" -- ) \ double two-variable  : 2Variable ( "name" -- ) \ double two-variable
     create 0 , 0 , ;      create 0 , 0 , ;
   
   has? no-userspace 0= [IF]
 : uallot ( n -- ) \ gforth  : uallot ( n -- ) \ gforth
     udp @ swap udp +! ;      udp @ swap udp +! ;
   
Line 436 
Line 452 
   
 : 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 460 
     : (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 453 
Line 480 
     (Constant) A, ;      (Constant) A, ;
   
 : Value ( w "name" -- ) \ core-ext  : Value ( w "name" -- ) \ core-ext
     (Constant) , ;      (Value) , ;
   
 : AValue ( w "name" -- ) \ core-ext  : AValue ( w "name" -- ) \ core-ext
     (Constant) A, ;      (Value) A, ;
   
 : 2Constant ( w1 w2 "name" -- ) \ double two-constant  : 2Constant ( w1 w2 "name" -- ) \ double two-constant
     Create ( w1 w2 "name" -- )      Create ( w1 w2 "name" -- )
Line 486 
Line 513 
   
 \ IS Defer What's Defers TO                            24feb93py  \ IS Defer What's Defers TO                            24feb93py
   
 : defer-default ( -- ) \ gforth  defer defer-default ( -- )
     \ might change into a THROW in the future  ' abort is defer-default
     ; \ >stderr ." uninitialized deferred word" ;  \ default action for deferred words (overridden by a warning later)
   
 doer? :dodefer [IF]  doer? :dodefer [IF]
   
Line 501 
Line 528 
   
 [ELSE]  [ELSE]
   
       has? rom [IF]
           : Defer ( "name" -- ) \ gforth
               Create ['] defer-default A,
             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
Line 525 
Line 557 
     ;-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 5 cells + postpone aliteral postpone (does>2) [compile] exit
     finish-code dodoes,      [ 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 ! ;
   
Line 596 
Line 628 
 : last?   ( -- false / nfa nfa )  : last?   ( -- false / nfa nfa )
     latest ?dup ;      latest ?dup ;
   
   has? ec 0= [IF]
 : (reveal) ( nt wid -- )  : (reveal) ( nt wid -- )
     wordlist-id dup >r      wordlist-id dup >r
     @ over ( name>link ) !      @ over ( name>link ) !
Line 603 
Line 636 
   
 \ make entry in wordlist-map  \ make entry in wordlist-map
 ' (reveal) f83search reveal-method !  ' (reveal) f83search reveal-method !
   [ELSE]
   : (reveal) ( nt wid -- )
       dup >r @ over ! r> ! ;
   [THEN]
   
 Variable warnings ( -- addr ) \ gforth  Variable warnings ( -- addr ) \ gforth
 G -1 warnings T !  G -1 warnings T !
Line 628 
Line 665 
         if \ it is still hidden          if \ it is still hidden
             dup ( name>link ) @ 1 xor           ( nt wid )              dup ( name>link ) @ 1 xor           ( nt wid )
             2dup >r name>string r> check-shadow ( nt wid )              2dup >r name>string r> check-shadow ( nt wid )
               [ has? ec [IF] ]
                   (reveal)
               [ [ELSE] ]
             dup wordlist-map @ reveal-method perform              dup wordlist-map @ reveal-method perform
               [ [THEN] ]
         else          else
             drop              drop
         then          then
     then ;      then ;
   
   has? EC 0= [IF]
 : 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.67  
changed lines
  Added in v.1.80
CVS Admin

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help