Diff for /gforth/kernel/comp.fs between versions 1.109 and 1.110

version 1.109, 2011/10/06 20:04:35 version 1.110, 2011/10/14 13:40:34
Line 47 Line 47
   
 : c,    ( c -- ) \ core c-comma  : 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 [ has? flash [IF] ] flashc! [ [ELSE] ] c! [ [THEN] ] ;      here 1 chars allot c! ;
   
 : ,     ( w -- ) \ core comma  : ,     ( 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 [ has? flash [IF] ] flash! [ [ELSE] ] ! [ [THEN] ] ;      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} there, @i{w2} first (lower address).      \G w2} there, @i{w2} first (lower address).
     here 2 cells allot  [ has? flash [IF] ] tuck flash! cell+ flash!      here 2 cells allot 2! ;
         [ [ELSE] ] 2! [ [THEN] ] ;  
   
 \ : aligned ( addr -- addr' ) \ core  \ : aligned ( addr -- addr' ) \ core
 \     [ cell 1- ] Literal + [ -1 cells ] Literal and ;  \     [ cell 1- ] Literal + [ -1 cells ] Literal and ;
Line 69 Line 68
 \ : faligned ( addr -- f-addr ) \ float f-aligned  \ : faligned ( addr -- f-addr ) \ float f-aligned
 \     [ 1 floats 1- ] Literal + [ -1 floats ] Literal and ;   \     [ 1 floats 1- ] Literal + [ -1 floats ] Literal and ; 
   
 has? ec 0= [IF]  
 : falign ( -- ) \ float f-align  : 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.
Line 77  has? ec 0= [IF] Line 75  has? ec 0= [IF]
     ?DO      ?DO
         bl c,          bl c,
     LOOP ;      LOOP ;
 [THEN]  
   
 : maxalign ( -- ) \ gforth  : maxalign ( -- ) \ gforth
     \G Align data-space pointer for all alignment requirements.      \G Align data-space pointer for all alignment requirements.
Line 103  has? ec 0= [IF] Line 100  has? ec 0= [IF]
   
 : string, ( c-addr u -- ) \ gforth  : string, ( c-addr u -- ) \ gforth
     \G puts down string as cstring      \G puts down string as cstring
     dup [ has? rom [IF] ] $E0 [ [ELSE] ] alias-mask [ [THEN] ] or c,      dup alias-mask or c,
 [ has? flash [IF] ]      here swap chars dup allot move ;
     bounds ?DO  I c@ c,  LOOP  
 [ [ELSE] ]  
     here swap chars dup allot move  
 [ [THEN] ] ;  
   
 : longstring, ( c-addr u -- ) \ gforth  : longstring, ( c-addr u -- ) \ gforth
     \G puts down string as longcstring      \G puts down string as longcstring
Line 128  variable next-prelude Line 121  variable next-prelude
     dup max-name-length @ max max-name-length !      dup max-name-length @ max max-name-length !
     [ [IFDEF] prelude-mask ] prelude, [ [THEN] ]      [ [IFDEF] prelude-mask ] prelude, [ [THEN] ]
     align here last !      align here last !
 [ has? ec [IF] ]  
     -1 A,  
 [ [ELSE] ]  
     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
 [ [THEN] ]      longstring, alias-mask lastflags cset
 [ has? f83headerstring [IF] ]      next-prelude @ 0<> prelude-mask and lastflags cset
         string,      next-prelude off
 [ [ELSE] ]  
         longstring, alias-mask lastflags cset  
         next-prelude @ 0<> prelude-mask and lastflags cset  
         next-prelude off  
 [ [THEN] ]  
     cfalign ;      cfalign ;
   
 has? ec [IF]  
 : header ( "name" -- )  
     parse-name name-too-short? header, ;  
 [ELSE]  
 defer (header)  defer (header)
 defer header ( -- ) \ gforth  defer header ( -- ) \ gforth
 ' (header) IS header  ' (header) IS header
Line 186  defer header ( -- ) \ gforth Line 167  defer header ( -- ) \ gforth
     \g leave the input stream alone. The xt of the defined word will      \g leave the input stream alone. The xt of the defined word will
     \g be given by @code{latestxt}.      \g be given by @code{latestxt}.
     ['] noname-header IS (header) ;      ['] noname-header IS (header) ;
 [THEN]  
   
 : latestxt ( -- xt ) \ gforth  : latestxt ( -- xt ) \ gforth
     \G @i{xt} is the execution token of the last word defined.      \G @i{xt} is the execution token of the last word defined.
Line 207  defer header ( -- ) \ gforth Line 187  defer header ( -- ) \ gforth
     \G Compilation semantics: compile the run-time semantics.@*      \G Compilation semantics: compile the run-time semantics.@*
     \G Run-time Semantics: push @i{n}.@*      \G Run-time Semantics: push @i{n}.@*
     \G Interpretation semantics: undefined.      \G Interpretation semantics: undefined.
 [ [IFDEF] lit, ]      postpone lit , ; immediate restrict
     lit,  
 [ [ELSE] ]  
     postpone lit ,  
 [ [THEN] ] ; immediate restrict  
   
 : 2Literal ( compilation w1 w2 -- ; run-time  -- w1 w2 ) \ double two-literal  : 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 Compile appropriate code such that, at run-time, @i{w1 w2} are
Line 219  defer header ( -- ) \ gforth Line 195  defer header ( -- ) \ gforth
     swap postpone Literal  postpone Literal ; immediate restrict      swap postpone Literal  postpone Literal ; immediate restrict
   
 : ALiteral ( compilation addr -- ; run-time -- addr ) \ gforth  : ALiteral ( compilation addr -- ; run-time -- addr ) \ gforth
 [ [IFDEF] alit, ]      postpone lit A, ; immediate restrict
     alit,  
 [ [ELSE] ]  
     postpone lit A,   
 [ [THEN] ] ; immediate restrict  
   
 Defer char@ ( addr u -- char addr' u' )  Defer char@ ( addr u -- char addr' u' )
 :noname  over c@ -rot 1 /string ; IS char@  :noname  over c@ -rot 1 /string ; IS char@
Line 245  Defer char@ ( addr u -- char addr' u' ) Line 217  Defer char@ ( addr u -- char addr' u' )
 : cfa,     ( code-address -- )  \ gforth        cfa-comma  : cfa,     ( code-address -- )  \ gforth        cfa-comma
     here      here
     dup lastcfa !      dup lastcfa !
     [ has? rom [IF] ] 2 cells allot [ [ELSE] ] 0 A, 0 , [ [THEN] ]      0 A, 0 ,
     code-address! ;      code-address! ;
   
 [IFUNDEF] compile,  [IFUNDEF] compile,
Line 256  defer compile, ( xt -- ) \ core-ext comp Line 228  defer compile, ( xt -- ) \ core-ext comp
 ' , 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? primcentric [IF]  has? primcentric [IF]
     has? peephole [IF]      has? peephole [IF]
Line 316  has? primcentric [IF] Line 286  has? primcentric [IF]
 : !does    ( addr -- ) \ gforth store-does  : !does    ( addr -- ) \ gforth store-does
     latestxt does-code! ;      latestxt does-code! ;
   
 \ : (does>)  ( R: addr -- )  
 \     r> cfaligned /does-handler + !does ; \ !! no gforth-native  
   
 \ \ !! unused, but ifdefed/gosted in some places  
 \ : (does>2)  ( addr -- )  
 \     cfaligned /does-handler + !does ;  
   
 : (compile) ( -- ) \ gforth-obsolete: dummy  : (compile) ( -- ) \ gforth-obsolete: dummy
     true abort" (compile) doesn't work, use POSTPONE instead" ;      true abort" (compile) doesn't work, use POSTPONE instead" ;
   
Line 414  has? recognizer 0= [IF] Line 377  has? recognizer 0= [IF]
   
 : S, ( addr u -- )  : S, ( addr u -- )
     \ allot string as counted string      \ allot string as counted string
 [ has? flash [IF] ]      here over char+ allot  place align ;
     dup c, bounds ?DO  I c@ c,  LOOP  
 [ [ELSE] ]  
     here over char+ allot  place align  
 [ [THEN] ] ;  
   
 : mem, ( addr u -- )  : mem, ( addr u -- )
     \ allot the memory block HERE (do alignment yourself)      \ allot the memory block HERE (do alignment yourself)
 [ has? flash [IF] ]      here over allot swap move ;
     bounds ?DO  I c@ c,  LOOP  
 [ [ELSE] ]  
     here over allot swap move  
 [ [THEN] ] ;  
   
 : ," ( "string"<"> -- )  : ," ( "string"<"> -- )
     [char] " parse s, ;      [char] " parse s, ;
Line 435  has? recognizer 0= [IF] Line 390  has? recognizer 0= [IF]
   
 \ problematic only for big endian machines  \ problematic only for big endian machines
   
 has? f83headerstring [IF]  
 : cset ( bmask c-addr -- )  
     tuck c@ or swap c! ;   
   
 : creset ( bmask c-addr -- )  
     tuck c@ swap invert and swap c! ;   
   
 : ctoggle ( bmask c-addr -- )  
     tuck c@ xor swap c! ;   
 [ELSE]  
 : cset ( bmask c-addr -- )  : cset ( bmask c-addr -- )
     tuck @ or swap ! ;       tuck @ or swap ! ; 
   
Line 453  has? f83headerstring [IF] Line 398  has? f83headerstring [IF]
   
 : ctoggle ( bmask c-addr -- )  : ctoggle ( bmask c-addr -- )
     tuck @ xor swap ! ;       tuck @ xor swap ! ; 
 [THEN]  
   
 : lastflags ( -- c-addr )  : lastflags ( -- c-addr )
     \ the address of the flags byte in the last header      \ the address of the flags byte in the last header
Line 463  has? f83headerstring [IF] Line 407  has? f83headerstring [IF]
 : immediate ( -- ) \ core  : immediate ( -- ) \ core
     \G Make the compilation semantics of a word be to @code{execute}      \G Make the compilation semantics of a word be to @code{execute}
     \G the execution semantics.      \G the execution semantics.
     immediate-mask lastflags [ has? rom [IF] ] creset [ [ELSE] ] cset [ [THEN] ] ;      immediate-mask lastflags cset ;
   
 : restrict ( -- ) \ gforth  : restrict ( -- ) \ gforth
     \G A synonym for @code{compile-only}      \G A synonym for @code{compile-only}
     restrict-mask lastflags [ has? rom [IF] ] creset [ [ELSE] ] cset [ [THEN] ] ;      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 479  has? f83headerstring [IF] Line 423  has? f83headerstring [IF]
     alias-mask lastflags creset      alias-mask lastflags creset
     dup A, lastcfa ! ;      dup A, lastcfa ! ;
   
 doer? :dovar [IF]  
   
 : Create ( "name" -- ) \ core  : Create ( "name" -- ) \ core
     Header reveal dovar: cfa, ;      Header reveal dovar: cfa, ;
 [ELSE]  
   
 : Create ( "name" -- ) \ core  
     Header reveal here lastcfa ! 0 A, 0 , DOES> ;  
 [THEN]  
   
 : buffer: ( u "name" -- ) \ core ext  : buffer: ( u "name" -- ) \ core ext
     Create allot ;      Create allot ;
   
 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  : Variable ( "name" -- ) \ core
     Create 0 , ;      Create 0 , ;
   
Line 512  has? flash [IF] Line 437  has? flash [IF]
   
 : 2Variable ( "name" -- ) \ double two-variable  : 2Variable ( "name" -- ) \ double two-variable
     Create 0 , 0 , ;      Create 0 , 0 , ;
 [THEN]  
   
 has? no-userspace 0= [IF]  
 : uallot ( n -- ) \ gforth  : uallot ( n -- ) \ gforth
     udp @ swap udp +! ;      udp @ swap udp +! ;
   
 doer? :douser [IF]  
   
 : User ( "name" -- ) \ gforth  : User ( "name" -- ) \ gforth
     Header reveal douser: cfa, cell uallot , ;      Header reveal douser: cfa, cell uallot , ;
   
 : AUser ( "name" -- ) \ gforth  : AUser ( "name" -- ) \ gforth
     User ;      User ;
 [ELSE]  
   
 : User Create cell uallot , DOES> @ up @ + ;  
   
 : AUser User ;  : (Constant)  Header reveal docon: cfa, ;
 [THEN]  
 [THEN]  
   
 doer? :docon [IF]  : (Value)  Header reveal dovalue: cfa, ;
     : (Constant)  Header reveal docon: cfa, ;  
 [ELSE]  
     : (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  : Constant ( w "name" -- ) \ core
     \G Define a constant @i{name} with value @i{w}.      \G Define a constant @i{name} with value @i{w}.
Line 558  doer? :dovalue [IF] Line 460  doer? :dovalue [IF]
 : AConstant ( addr "name" -- ) \ gforth  : AConstant ( addr "name" -- ) \ gforth
     (Constant) A, ;      (Constant) A, ;
   
 has? flash [IF]  
 : Value ( w "name" -- ) \ core-ext  
     (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 ( w "name" -- ) \ core-ext
     (Value) , ;      (Value) , ;
   
 : AValue ( w "name" -- ) \ core-ext  : AValue ( w "name" -- ) \ core-ext
     (Value) A, ;      (Value) A, ;
 [THEN]  
   
 : 2Constant ( w1 w2 "name" -- ) \ double two-constant  : 2Constant ( w1 w2 "name" -- ) \ double two-constant
     Create ( w1 w2 "name" -- )      Create ( w1 w2 "name" -- )
         2,          2,
     DOES> ( -- w1 w2 )      DOES> ( -- w1 w2 )
         2@ ;          2@ ;
       
 doer? :dofield [IF]  : (Field)  Header reveal dofield: cfa, ;
     : (Field)  Header reveal dofield: cfa, ;  
 [ELSE]  
     : (Field)  Create DOES> @ + ;  
 [THEN]  
   
 \ \ interpret/compile:  \ \ interpret/compile:
   
Line 604  defer defer-default ( -- ) Line 494  defer defer-default ( -- )
 ' abort is defer-default  ' abort is defer-default
 \ default action for deferred words (overridden by a warning later)  \ default action for deferred words (overridden by a warning later)
           
 doer? :dodefer [IF]  
   
 : Defer ( "name" -- ) \ gforth  : Defer ( "name" -- ) \ gforth
 \G Define a deferred word @i{name}; its execution semantics can be  \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 set with @code{defer!} or @code{is} (and they have to, before first
 \G executing @i{name}.  \G executing @i{name}.
     Header Reveal dodefer: cfa,      Header Reveal dodefer: cfa,
     [ has? rom [IF] ] here >r cell allot      ['] defer-default A, ;
     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 ['] defer-default A,  
           DOES> @ execute ;  
     [THEN]  
 [THEN]  
   
 : defer@ ( xt-deferred -- xt ) \ gforth defer-fetch  : defer@ ( xt-deferred -- xt ) \ gforth defer-fetch
 \G @i{xt} represents the word currently associated with the deferred  \G @i{xt} represents the word currently associated with the deferred
 \G word @i{xt-deferred}.  \G word @i{xt-deferred}.
     >body @ [ has? rom [IF] ] @ [ [THEN] ] ;      >body @ ;
   
 : Defers ( compilation "name" -- ; run-time ... -- ... ) \ gforth  : Defers ( compilation "name" -- ; run-time ... -- ... ) \ gforth
     \G Compiles the present contents of the deferred word @i{name}      \G Compiles the present contents of the deferred word @i{name}
Line 644  doer? :dodefer [IF] Line 516  doer? :dodefer [IF]
     \ xt ( addr -- ) is !does or !;abi-code etc, addr is the address      \ xt ( addr -- ) is !does or !;abi-code etc, addr is the address
     \ that should be stored right after the code address.      \ that should be stored right after the code address.
     >r ;-hook ?struc      >r ;-hook ?struc
     [ has? xconds [IF] ] exit-like [ [THEN] ]      exit-like
     here [ has? peephole [IF] ] 5 [ [ELSE] ] 4 [ [THEN] ] cells +      here [ has? peephole [IF] ] 5 [ [ELSE] ] 4 [ [THEN] ] cells +
     postpone aliteral r> compile, [compile] exit      postpone aliteral r> compile, [compile] exit
     [ has? peephole [IF] ] finish-code [ [THEN] ]      [ has? peephole [IF] ] finish-code [ [THEN] ]
Line 659  interpret/compile: DOES>  ( compilation Line 531  interpret/compile: DOES>  ( compilation
   
 : defer! ( xt xt-deferred -- ) \ gforth  defer-store  : 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 [ has? rom [IF] ] @ [ [THEN] ] ! ;      >body ! ;
           
 : <IS> ( "name" xt -- ) \ gforth  : <IS> ( "name" xt -- ) \ gforth
     \g Changes the @code{defer}red word @var{name} to execute @var{xt}.      \g Changes the @code{defer}red word @var{name} to execute @var{xt}.
Line 691  defer ;-hook ( sys2 -- sys1 ) Line 563  defer ;-hook ( sys2 -- sys1 )
   
 0 Constant defstart  0 Constant defstart
   
 [IFDEF] docol,  
 : (:noname) ( -- colon-sys )  
     \ common factor of : and :noname  
     docol, ]comp  
 [ELSE]  
 : (:noname) ( -- colon-sys )  : (:noname) ( -- colon-sys )
     \ common factor of : and :noname      \ common factor of : and :noname
     docol: cfa,      docol: cfa,
 [THEN]  
     defstart ] :-hook ;      defstart ] :-hook ;
   
 : : ( "name" -- colon-sys ) \ core      colon  : : ( "name" -- colon-sys ) \ core      colon
Line 709  defer ;-hook ( sys2 -- sys1 ) Line 575  defer ;-hook ( sys2 -- sys1 )
     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 [compile] exit      ;-hook ?struc [compile] exit
     [ has? peephole [IF] ] finish-code [ [THEN] ]      [ has? peephole [IF] ] finish-code [ [THEN] ]
     reveal postpone [ ; immediate restrict      reveal postpone [ ; immediate restrict
 [THEN]  
   
 \ \ Search list handling: reveal words, recursive               23feb93py  \ \ Search list handling: reveal words, recursive               23feb93py
   
Line 727  defer ;-hook ( sys2 -- sys1 ) Line 588  defer ;-hook ( sys2 -- sys1 )
 Variable warnings ( -- addr ) \ gforth  Variable warnings ( -- addr ) \ gforth
 G -1 warnings T !  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 -- )  : (reveal) ( nt wid -- )
     wordlist-id dup >r      wordlist-id dup >r
     @ over ( name>link ) !       @ over ( name>link ) ! 
Line 777  has? ec [IF] Line 625  has? ec [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

Removed from v.1.109  
changed lines
  Added in v.1.110


FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>