gforth: gforth/kernel/comp.fs

Diff for /gforth/kernel/comp.fs between version 1.20 and 1.100

-version 1.20, Fri May 21 20:35:38 1999 UTC
+version 1.100, Mon Apr  5 22:17:56 2010 UTC
  Line 1
  Line 1
  Line 1
  \ 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.
  \ Gforth is free software; you can redistribute it and/or
  \ 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.
  \ This program is distributed in the hope that it will be useful,
  Line 15
  Line 15
  Line 15
  \ GNU General Public License for more details.
  \ 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
- Line 35
+ Line 34
  Line 35
  Line 34
  \ we default to this version if we have nothing else 05May99jaw
  [IFUNDEF] allot
  : allot ( n -- ) \ core
-     \G Reserve or release @i{n} address units of data space without
+     \G Reserve @i{n} address units of data space without
-     \G initialization; @i{n} is a signed number.  In ANS Forth you can
+     \G initialization. @i{n} is a signed number, passing a negative
-     \G only deallocate memory from the current contiguous region in
+     \G @i{n} releases memory.  In ANS Forth you can only deallocate
-     \G this way.  In Gforth you can deallocate anything in this way
+     \G memory from the current contiguous region in this way.  In
-     \G but named words.  The system does not check this restriction.
+     \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]
- : c,    ( c -- ) \ core
+ : c,    ( c -- ) \ core c-comma
      \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
+ : ,     ( w -- ) \ core comma
      \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
      \G Reserve data space for two cells and store the double @i{w1
-     \G w2} in the space.
+     \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
  \     [ cell 1- ] Literal + [ -1 cells ] Literal and ;
- Line 65
+ Line 66
  Line 65
  Line 66
      \G If the data-space pointer is not aligned, reserve enough space to align it.
      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 ;
- : 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
- Line 77
+ Line 78
  Line 77
  Line 78
      LOOP ;
  : maxalign ( -- ) \ gforth
+     \G Align data-space pointer for all alignment requirements.
      here dup maxaligned swap
      ?DO
          bl c,
- Line 84
+ Line 86
  Line 84
  Line 86
  \ the code field is aligned if its body is maxaligned
  ' 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
- Line 101
+ Line 105
  Line 101
  Line 105
  : string, ( c-addr u -- ) \ gforth
      \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
      name-too-long?
+     dup max-name-length @ max max-name-length !
+     [ [IFDEF] prelude-mask ] prelude, [ [THEN] ]
      align here last !
+ [ has? ec [IF] ]
+     -1 A,
+ [ [ELSE] ]
      current @ 1 or A,   \ link field; before revealing, it contains the
                          \ 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" -- )
-     name name-too-short? header, ;
+     parse-name name-too-short? header, ;
  : input-stream ( -- )  \ general
      \G switches back to getting the name from the input stream ;
- Line 120
+ Line 154
  Line 120
  Line 154
  ' input-stream-header IS (header)
- \ !! make that a 2variable
+variable nextname-string
- create nextname-buffer 32 chars allot
+ has? OS [IF]
  : nextname-header ( -- )
-     nextname-buffer count header,
+     nextname-string 2@ header,
+     nextname-string free-mem-var
      input-stream ;
+ [THEN]
  \ the next name is given in the string
+ has? OS [IF]
  : 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?
-     nextname-buffer c! ( c-addr )
+     nextname-string free-mem-var
-     nextname-buffer count move
+     save-mem nextname-string 2!
      ['] nextname-header IS (header) ;
+ [THEN]
  : noname-header ( -- )
 last ! cfalign
- Line 144
+ Line 182
  Line 144
  Line 182
  : noname ( -- ) \ gforth
      \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{lastxt}.
+     \g be given by @code{latestxt}.
      ['] noname-header IS (header) ;
- : lastxt ( -- xt ) \ gforth
+ : latestxt ( -- xt ) \ gforth
      \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 @ ;
+ ' 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
  : Literal  ( compilation n -- ; run-time -- n ) \ core
-     \G Compile appropriate code such that, at run-time, @i{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}.@*
+     \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
  [ [IFDEF] alit, ]
      alit,
- Line 170
+ Line 222
  Line 170
  Line 222
      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
      \G Skip leading spaces. Parse the string @i{ccc} and return @i{c}, the
      \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
      \G Compilation: skip leading spaces. Parse the string
- Line 187
+ Line 242
  Line 187
  Line 242
  : cfa,     ( code-address -- )  \ gforth        cfa-comma
      here
      dup lastcfa !
-A, 0 ,  code-address! ;
+     [ has? rom [IF] ] 2 cells allot [ [ELSE] ] 0 A, 0 , [ [THEN] ]
+     code-address! ;
  [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.
-     A, ;
+ ' , is compile,
+ [THEN]
+ has? ec 0= [IF]
+ defer basic-block-end ( -- )
+ :noname ( -- )
+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
+         doabicode: OF >body ['] abi-call 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]
  : !does    ( addr -- ) \ gforth store-does
-     lastxt does-code! ;
+     latestxt does-code! ;
+ \ !! unused, but ifdefed/gosted in some places
  : (does>)  ( R: addr -- )
-     r> cfaligned /does-handler + !does ;
+     r> cfaligned /does-handler + !does ; \ !! no gforth-native
+ : (does>2)  ( addr -- )
+     cfaligned /does-handler + !does ;
  : dodoes,  ( -- )
    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
- : 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}.
      (name>comp)
 = if
- Line 237
+ Line 346
  Line 237
  Line 346
      COMP' swap POSTPONE Aliteral POSTPONE ALiteral ; immediate restrict
  : postpone, ( w xt -- ) \ gforth        postpone-comma
-     \g Compile the compilation semantics represented by @i{w xt}.
+     \g Compile the compilation semantics represented by the
+     \g compilation token @i{w xt}.
      dup ['] execute =
      if
          drop compile,
      else
-         dup ['] compile, =
-         if
-             drop POSTPONE (compile) a,
-         else
              swap POSTPONE aliteral compile,
-         then
      then ;
  : POSTPONE ( "name" -- ) \ core
      \g Compiles the compilation semantics of @i{name}.
-     COMP' postpone, ; immediate restrict
+     COMP' postpone, ; immediate
  \ \ recurse                                                     17may93jaw
  : recurse ( compilation -- ; run-time ?? -- ?? ) \ core
      \g Call the current definition.
-     lastxt compile, ; immediate restrict
+     latestxt compile, ; immediate restrict
  \ \ compiler loop
- : compiler ( c-addr u -- )
+ : compiler1 ( c-addr u -- ... xt )
-dup find-name dup
+dup find-name [ [IFDEF] prelude-mask ] run-prelude [ [THEN] ] dup
      if ( c-addr u nt )
-         nip nip name>comp execute
+         nip nip name>comp
      else
          drop
-dup snumber? dup
+dup 2>r snumber? dup
          IF
 >
              IF
-                 swap postpone Literal
+                 ['] 2literal
+             ELSE
+                 ['] literal
              THEN
-             postpone Literal
+rdrop
-drop
          ELSE
-             drop compiler-notfound
+             drop 2r> compiler-notfound1
          THEN
      then ;
  : [ ( -- ) \ core       left-bracket
      \G Enter interpretation state. Immediate word.
-     ['] interpreter  IS parser state off ; immediate
+     ['] interpreter1  IS parser1 state off ; immediate
  : ] ( -- ) \ core       right-bracket
      \G Enter compilation state.
-     ['] compiler     IS parser state on  ;
+     ['] compiler1     IS parser1 state on  ;
  \ \ 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
+ \ problematic only for big endian machines
+ has? f83headerstring [IF]
  : cset ( bmask c-addr -- )
      tuck c@ or swap c! ;
- Line 320
+ Line 429
  Line 320
  Line 429
  : ctoggle ( bmask c-addr -- )
      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 )
      \ the address of the flags byte in the last header
      \ 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
      \G Make the compilation semantics of a word be to @code{execute}
      \G the execution semantics.
-     immediate-mask lastflags cset ;
+     immediate-mask lastflags [ has? rom [IF] ] creset [ [ELSE] ] cset [ [THEN] ] ;
  : restrict ( -- ) \ gforth
      \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
  \G Remove the interpretation semantics of a word.
- Line 355
+ Line 474
  Line 355
  Line 474
      Header reveal here lastcfa ! 0 A, 0 , DOES> ;
  [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
      Create 0 , ;
  : AVariable ( "name" -- ) \ gforth
      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]
- Line 379
+ Line 513
  Line 379
  Line 513
  : AUser User ;
  [THEN]
+ [THEN]
  doer? :docon [IF]
      : (Constant)  Header reveal docon: cfa, ;
- Line 386
+ Line 521
  Line 386
  Line 521
      : (Constant)  Create DOES> @ ;
  [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
      \G Define a constant @i{name} with value @i{w}.
      \G
- Line 395
+ Line 540
  Line 395
  Line 540
  : AConstant ( addr "name" -- ) \ gforth
      (Constant) A, ;
+ has? flash [IF]
  : 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" -- )
 ,
      DOES> ( -- w1 w2 )
- Line 409
+ Line 565
  Line 409
  Line 565
  [ELSE]
      : (Field)  Create DOES> @ + ;
  [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
+ defer defer-default ( -- )
+ ' abort is defer-default
+ \ default action for deferred words (overridden by a warning later)
  doer? :dodefer [IF]
  : 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,
-     ['] noop A, ;
+     [ has? rom [IF] ] here >r cell allot
+     dpp @ ram here r> flash! ['] defer-default A, dpp !
+     [ [ELSE] ] ['] defer-default A, [ [THEN] ] ;
  [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
-     Create ['] noop A,
+             Create ['] defer-default A,
  DOES> @ execute ;
+     [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
  :noname
      dodoes, here !does ]
- Line 435
+ Line 628
  Line 435
  Line 628
  :noname
      ;-hook ?struc
      [ 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 ;
  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}.
-     ' >body ! ;
+     ' 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}.
-     ' >body postpone ALiteral postpone ! ; immediate restrict
+     ' postpone ALiteral postpone defer! ; immediate restrict
  ' <IS>
  ' [IS]
- interpret/compile: IS ( xt "name" -- ) \ gforth
+ 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
- :noname    ' >body @ ;
- :noname    ' >body postpone ALiteral postpone @ ;
- interpret/compile: What's ( "name" -- addr ) \ gforth
- \ \ 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 )
      >does-code ['] DOES> >does-code = ;
- Line 488
+ Line 671
  Line 488
  Line 671
  [IFDEF] docol,
  : (:noname) ( -- colon-sys )
      \ common factor of : and :noname
-     docol, ]comp defstart ] :-hook ;
+     docol, ]comp
  [ELSE]
  : (:noname) ( -- colon-sys )
      \ common factor of : and :noname
-     docol: cfa, defstart ] :-hook ;
+     docol: cfa,
  [THEN]
+     defstart ] :-hook ;
  : : ( "name" -- colon-sys ) \ core      colon
      Header (:noname) ;
- Line 507
+ Line 691
  Line 507
  Line 691
      ;-hook ?struc fini, comp[ reveal postpone [ ; immediate restrict
  [ELSE]
  : ; ( 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]
  \ \ Search list handling: reveal words, recursive               23feb93py
  : 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 -- )
      wordlist-id dup >r
      @ over ( name>link ) !
- Line 523
+ Line 725
  Line 523
  Line 725
  \ make entry in wordlist-map
  ' (reveal) f83search reveal-method !
- Variable warnings ( -- addr ) \ gforth
- G -1 warnings T !
  : check-shadow  ( addr count wid -- )
      \G prints a warning if the string is already present in the wordlist
      >r 2dup 2dup r> (search-wordlist) warnings @ and ?dup if
          >stderr
          ." redefined " name>string 2dup type
-         compare 0<> if
+         str= 0= if
              ."  with " type
          else
 drop
- Line 555
+ Line 754
  Line 555
  Line 754
  : rehash  ( wid -- )
      dup wordlist-map @ rehash-method perform ;
+ [THEN]
  ' reveal alias recursive ( compilation -- ; run-time -- ) \ gforth
  \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.20
 


changed lines


 
Added in v.1.100
 Legend:



Removed from v.1.20
 


changed lines


 
Added in v.1.100
-Removed from v.1.20
+Added in v.1.100

CVS Admin

gforth: gforth/kernel/comp.fs

Diff for /gforth/kernel/comp.fs between version 1.20 and 1.100

ViewCVS and CVS Help