[gforth] / gforth / kernel / comp.fs  

gforth: gforth/kernel/comp.fs

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

version 1.17, Sun May 16 17:13:25 1999 UTC version 1.27, Sat Aug 26 13:29:48 2000 UTC
Line 35 
Line 35 
 \ we default to this version if we have nothing else 05May99jaw  \ we default to this version if we have nothing else 05May99jaw
 [IFUNDEF] allot  [IFUNDEF] allot
 : allot ( n -- ) \ core  : 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 +      here +
     dup 1- usable-dictionary-end forthstart within -8 and throw      dup 1- usable-dictionary-end forthstart within -8 and throw
     dp ! ;      dp ! ;
 [THEN]  [THEN]
   
 : c,    ( c -- ) \ core  : 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 c! ;
   
 : ,     ( w -- ) \ core  : ,     ( 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  ! ;
   
 : 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} in the space.      \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
Line 65 
Line 66 
     \G If the data-space pointer is not aligned, reserve enough space to align it.      \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 If the data-space pointer is not float-aligned, reserve
     \G enough space to align it.      \G enough space to align it.
     here dup faligned swap      here dup faligned swap
Line 77 
Line 78 
     LOOP ;      LOOP ;
   
 : maxalign ( -- ) \ gforth  : 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 84 
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 130 
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 140 
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
Line 151 
Line 159 
 \ \ 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, @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, ]  [ [IFDEF] lit, ]
     lit,      lit,
 [ [ELSE] ]  [ [ELSE] ]
Line 187 
Line 196 
   
 [IFUNDEF] compile,  [IFUNDEF] compile,
 : compile, ( xt -- )    \ core-ext      compile-comma  : 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.      \G  into the current definition.
     A, ;      A, ;
 [THEN]  [THEN]
Line 204 
Line 213 
 : (compile) ( -- ) \ gforth  : (compile) ( -- ) \ gforth
     r> dup cell+ >r @ compile, ;      r> dup cell+ >r @ compile, ;
   
 : postpone, ( w xt -- ) \ gforth        postpone-comma  
     \g Compile the compilation semantics represented by @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  
   
 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
Line 262 
Line 241 
     \g Compilation token @i{w xt} represents @i{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
Line 342 
Line 340 
 : 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 cset ;
   
 ' 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 368 
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 405 
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 424 
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 )

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

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help