[gforth] / gforth / kernel / comp.fs  

gforth: gforth/kernel/comp.fs

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

version 1.8, Wed Feb 3 00:10:24 1999 UTC version 1.27, Sat Aug 26 13:29:48 2000 UTC
Line 24 
Line 24 
   
 \ \ 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]
   
   \ we default to this version if we have nothing else 05May99jaw
   [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]
   
 : 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 c! ;
   
 : ,     ( x -- ) \ core  : ,     ( w -- ) \ core comma
       \G Reserve data space for one cell and store @i{w} in the space.
     here cell allot  ! ;      here cell allot  ! ;
   
 : 2,    ( w1 w2 -- ) \ gforth  : 2,    ( w1 w2 -- ) \ gforth
       \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 2! ;      here 2 cells allot 2! ;
   
 \ : 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 106 
Line 134 
 \ the next name is given in the string  \ the next name is given in the string
   
 : 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-buffer c! ( c-addr )
     nextname-buffer count move      nextname-buffer count move
Line 116 
Line 146 
     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{lastxt}.
     ['] noname-header IS (header) ;      ['] noname-header IS (header) ;
   
 : lastxt ( -- xt ) \ gforth  : lastxt ( -- 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 @ ;
   
 \ \ 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
   
 : 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
   
 : 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@ ;      bl word char+ c@ ;
   
 : [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 151 
Line 194 
     dup lastcfa !      dup lastcfa !
     0 A, 0 ,  code-address! ;      0 A, 0 ,  code-address! ;
   
   [IFUNDEF] compile,
 : compile, ( xt -- )    \ core-ext      compile-comma  : compile, ( xt -- )    \ core-ext      compile-comma
     \G  Blah, blah.      \G  Compile the word represented by the execution token @i{xt}
       \G  into the current definition.
     A, ;      A, ;
   [THEN]
   
 : !does    ( addr -- ) \ gforth store-does  : !does    ( addr -- ) \ gforth store-does
     lastxt does-code! ;      lastxt does-code! ;
Line 167 
Line 213 
 : (compile) ( -- ) \ gforth  : (compile) ( -- ) \ gforth
     r> dup cell+ >r @ compile, ;      r> dup cell+ >r @ compile, ;
   
 : postpone, ( w xt -- ) \ gforth        postpone-comma  
     \g Compiles the compilation semantics represented by @var{w xt}.  
     dup ['] execute =  
     if  
         drop compile,  
     else  
         dup ['] compile, =  
         if  
             drop POSTPONE (compile) compile,  
         else  
             swap POSTPONE aliteral compile,  
         then  
     then ;  
   
 : POSTPONE ( "name" -- ) \ core  
     \g Compiles the compilation semantics of @var{name}.  
     COMP' postpone, ; immediate restrict  
   
 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 ;  
   
 \ \ ticks  \ \ ticks
   
 : name>comp ( nt -- w xt ) \ gforth  : name>comp ( nt -- w xt ) \ gforth
     \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 228 
     (') 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
           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
   
 \ \ 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      lastxt compile, ; immediate restrict
   
 \ \ compiler loop  \ \ compiler loop
Line 266 
Line 301 
   here over char+ allot  place align ;    here over char+ allot  place align ;
   
 : SLiteral ( Compilation c-addr1 u ; run-time -- c-addr2 u ) \ string  : SLiteral ( Compilation c-addr1 u ; run-time -- c-addr2 u ) \ string
     \G Compilation: compile the string specified by c-addr1, u into      \G Compilation: compile the string specified by @i{c-addr1},
     \G the current definition. Run-time: return c-addr2 u describing      \G @i{u} into the current definition. Run-time: return
     \G the address and length of the string.      \G @i{c-addr2 u} describing the address and length of the
       \G string.
     postpone (S") here over char+ allot  place align ;      postpone (S") here over char+ allot  place align ;
                                              immediate restrict                                               immediate restrict
   
 \ \ abort"                                                      22feb93py  \ \ abort"                                                      22feb93py
   
 : abort" ( compilation 'ccc"' -- ; run-time f -- ) \ core,exception-ext abort-quote  : abort" ( compilation 'ccc"' -- ; run-time f -- ) \ core,exception-ext abort-quote
       \G If any bit of @i{f} is non-zero, perform the function of @code{-2 throw},
       \G displaying the string @i{ccc} if there is no exception frame on the
       \G exception stack.
     postpone (abort") ," ;        immediate restrict      postpone (abort") ," ;        immediate restrict
   
 \ \ Header states                                               23feb93py  \ \ Header states                                               23feb93py
Line 294 
Line 333 
     last @ dup 0= abort" last word was headerless" cell+ ;      last @ dup 0= abort" last word was headerless" cell+ ;
   
 : immediate ( -- ) \ core  : 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 cset ;
   
 : restrict ( -- ) \ gforth  : restrict ( -- ) \ gforth
       \G A synonym for @code{compile-only}
     restrict-mask lastflags cset ;      restrict-mask lastflags cset ;
   
 ' 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 323 
Line 367 
 : 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 , ;
   
 : uallot ( n -- )  udp @ swap udp +! ;  : uallot ( n -- ) \ gforth
       udp @ swap udp +! ;
   
 doer? :douser [IF]  doer? :douser [IF]
   
Line 349 
Line 394 
 [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
Line 360 
Line 405 
 : Value ( w "name" -- ) \ core-ext  : Value ( w "name" -- ) \ core-ext
     (Constant) , ;      (Constant) , ;
   
 : 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 379 
Line 424 
     \ !! shouldn't it be initialized with abort or something similar?      \ !! shouldn't it be initialized with abort or something similar?
     Header Reveal dodefer: cfa,      Header Reveal dodefer: cfa,
     ['] noop A, ;      ['] noop A, ;
   
 [ELSE]  [ELSE]
   
 : Defer ( "name" -- ) \ gforth  : Defer ( "name" -- ) \ gforth
     Create ['] noop A,      Create ['] noop A,
 DOES> @ execute ;  DOES> @ execute ;
   
 [THEN]  [THEN]
   
 : Defers ( "name" -- ) \ gforth  : 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.
     ' >body @ compile, ; immediate      ' >body @ compile, ; immediate
   
   :noname
       dodoes, here !does ]
       defstart :-hook ;
   :noname
       ;-hook ?struc
       [ has? xconds [IF] ] exit-like [ [THEN] ]
       postpone (does>) dodoes,
       defstart :-hook ;
   interpret/compile: DOES>  ( compilation colon-sys1 -- colon-sys2 ; run-time nest-sys -- ) \ core        does
   
   : <IS> ( "name" xt -- ) \ gforth
       \g Changes the @code{defer}red word @var{name} to execute @var{xt}.
       ' >body ! ;
   
   : [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
   
   ' <IS>
   ' [IS]
   interpret/compile: IS ( xt "name" -- ) \ gforth
   \G A combined word made up from @code{<IS>} and @code{[IS]}.
   
   ' <IS>
   ' [IS]
   interpret/compile: TO ( w "name" -- ) \ core-ext
   
   :noname    ' >body @ ;
   :noname    ' >body postpone ALiteral postpone @ ;
   interpret/compile: What's ( interpretation "name" -- xt; compilation "name" -- ; run-time -- xt ) \ gforth
   \G @i{Xt} is the XT that is currently assigned to @i{name}.
   
   \ \ 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 = ;
   
 \ \ : ;                                                         24feb93py  \ \ : ;                                                         24feb93py
   
 defer :-hook ( sys1 -- sys2 )  defer :-hook ( sys1 -- sys2 )
   
 defer ;-hook ( sys2 -- sys1 )  defer ;-hook ( sys2 -- sys1 )
   
   0 Constant defstart
   
   [IFDEF] docol,
   : (:noname) ( -- colon-sys )
       \ common factor of : and :noname
       docol, ]comp defstart ] :-hook ;
   [ELSE]
 : (:noname) ( -- colon-sys )  : (:noname) ( -- colon-sys )
     \ common factor of : and :noname      \ common factor of : and :noname
     docol: cfa, defstart ] :-hook ;      docol: cfa, defstart ] :-hook ;
   [THEN]
   
 : : ( "name" -- colon-sys ) \ core      colon  : : ( "name" -- colon-sys ) \ core      colon
     Header (:noname) ;      Header (:noname) ;
Line 406 
Line 514 
     0 last !      0 last !
     cfalign here (:noname) ;      cfalign here (:noname) ;
   
   [IFDEF] fini,
   : ; ( compilation colon-sys -- ; run-time nest-sys ) \ core   semicolon
       ;-hook ?struc fini, comp[ reveal postpone [ ; immediate restrict
   [ELSE]
 : ; ( 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 postpone exit reveal postpone [ ; immediate restrict
   [THEN]
   
 \ \ Search list handling: reveal words, recursive               23feb93py  \ \ Search list handling: reveal words, recursive               23feb93py
   
Line 456 
Line 569 
     dup wordlist-map @ rehash-method perform ;      dup wordlist-map @ rehash-method perform ;
   
 ' 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.27
CVS Admin

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help