[gforth] / gforth / kernel / comp.fs  

gforth: gforth/kernel/comp.fs

Diff for /gforth/kernel/comp.fs between version 1.13 and 1.17

version 1.13, Fri Apr 16 22:19:54 1999 UTC version 1.17, Sun May 16 17:13:25 1999 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
     \G Reserve or release @var{n} address units of data space; @var{n}      dup unused u> -8 and throw
     \G is a signed number. There are restrictions on releasing data      dp +! ;
     \G space.  [THEN]
   [THEN]
   
   \ 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 initialization; @i{n} is a signed number.  In ANS Forth you can
       \G only deallocate memory from the current contiguous region in
       \G this way.  In Gforth you can deallocate anything in this way
       \G but named words.  The system does not check this restriction.
     here +      here +
     dup 1- usable-dictionary-end forthstart within -8 and throw      dup 1- usable-dictionary-end forthstart within -8 and throw
     dp ! ;      dp ! ;
   [THEN]
   
 : c,    ( c -- ) \ core  : c,    ( c -- ) \ core
     \G Reserve data space for one char and store @var{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 c! ;
   
 : ,     ( w -- ) \ core  : ,     ( w -- ) \ core
     \G Reserve data space for one cell and store @var{w} in the space.      \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 @var{w1      \G Reserve data space for two cells and store the double @i{w1
     \G w2} in the space.      \G w2} in the space.
     here 2 cells allot 2! ;      here 2 cells allot 2! ;
   
Line 49 
Line 62 
 \     [ 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
 \     [ 1 floats 1- ] Literal + [ -1 floats ] Literal and ;  \     [ 1 floats 1- ] Literal + [ -1 floats ] Literal and ;
   
 : falign ( -- ) \ float  : falign ( -- ) \ float
       \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,
Line 128 
Line 144 
     ['] noname-header IS (header) ;      ['] noname-header IS (header) ;
   
 : lastxt ( -- xt ) \ gforth  : lastxt ( -- xt ) \ gforth
     \G @var{xt} is the execution token of the last word defined.      \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      \ 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, @var{n} is placed      \G Compile appropriate code such that, at run-time, @i{n} is placed
     \G on the stack. Interpretation semantics are undefined.      \G on the stack. Interpretation semantics are undefined.
     postpone lit  , ; immediate restrict  [ [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 @var{ccc} and return @var{c}, the      \G Skip leading spaces. Parse the string @i{ccc} and return @i{c}, the
     \G display code representing the first character of @var{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      \G Compilation: skip leading spaces. Parse the string
     \G @var{ccc}. Run-time: return @var{c}, the display code      \G @i{ccc}. Run-time: return @i{c}, the display code
     \G representing the first character of @var{ccc}.  Interpretation      \G representing the first character of @i{ccc}.  Interpretation
     \G semantics for this word are undefined.      \G semantics for this word are undefined.
     char postpone Literal ; immediate restrict      char postpone Literal ; immediate restrict
   
Line 161 
Line 185 
     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  Compile the word represented by the execution token, @var{xt}.      \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 178 
Line 205 
     r> dup cell+ >r @ compile, ;      r> dup cell+ >r @ compile, ;
   
 : postpone, ( w xt -- ) \ gforth        postpone-comma  : postpone, ( w xt -- ) \ gforth        postpone-comma
     \g Compile the compilation semantics represented by @var{w xt}.      \g Compile the compilation semantics represented by @i{w xt}.
     dup ['] execute =      dup ['] execute =
     if      if
         drop compile,          drop compile,
     else      else
         dup ['] compile, =          dup ['] compile, =
         if          if
             drop POSTPONE (compile) compile,              drop POSTPONE (compile) a,
         else          else
             swap POSTPONE aliteral compile,              swap POSTPONE aliteral compile,
         then          then
     then ;      then ;
   
 : POSTPONE ( "name" -- ) \ core  : POSTPONE ( "name" -- ) \ core
     \g Compiles the compilation semantics of @var{name}.      \g Compiles the compilation semantics of @i{name}.
     COMP' postpone, ; immediate restrict      COMP' postpone, ; immediate restrict
   
 struct  struct
Line 210 
Line 237 
 \ \ 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 222 
Line 249 
     (') 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
   
 \ \ recurse                                                     17may93jaw  \ \ recurse                                                     17may93jaw
Line 276 
Line 303 
   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 @var{c-addr1},      \G Compilation: compile the string specified by @i{c-addr1},
     \G @var{u} into the current definition. Run-time: return      \G @i{u} into the current definition. Run-time: return
     \G @var{c-addr2 u} describing the address and length of the      \G @i{c-addr2 u} describing the address and length of the
     \G string.      \G string.
     postpone (S") here over char+ allot  place align ;      postpone (S") here over char+ allot  place align ;
                                              immediate restrict                                               immediate restrict
Line 286 
Line 313 
 \ \ 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 @var{f} is non-zero, perform the function of @code{-2 throw},      \G If any bit of @i{f} is non-zero, perform the function of @code{-2 throw},
     \G displaying the string @var{ccc} if there is no exception frame on the      \G displaying the string @i{ccc} if there is no exception frame on the
     \G exception stack.      \G exception stack.
     postpone (abort") ," ;        immediate restrict      postpone (abort") ," ;        immediate restrict
   
Line 320 
Line 347 
   
 \ \ 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 367 
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 413 
Line 440 
   
 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 424 
Line 459 
     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
   

Generate output suitable for use with a patch program
Legend:
Removed from v.1.13  
changed lines
  Added in v.1.17
CVS Admin

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help