Diff for /gforth/Attic/kernal.fs between versions 1.40 and 1.41

version 1.40, 1995/09/06 21:00:21 version 1.41, 1995/10/07 17:38:16
Line 31 Line 31
   
 HEX  HEX
   
   \ labels for some code addresses
   
   : docon: ( -- addr )    \ gforth
       \ the code address of a @code{CONSTANT}
       ['] bl >code-address ;
   
   : docol: ( -- addr )    \ gforth
       \ the code address of a colon definition
       ['] docon: >code-address ;
   
   : dovar: ( -- addr )    \ gforth
       \ the code address of a @code{CREATE}d word
       ['] udp >code-address ;
   
   : douser: ( -- addr )   \ gforth
       \ the code address of a @code{USER} variable
       ['] s0 >code-address ;
   
   : dodefer: ( -- addr )  \ gforth
       \ the code address of a @code{defer}ed word
       ['] source >code-address ;
   
   : dofield: ( -- addr )  \ gforth
       \ the code address of a @code{field}
       ['] reveal-method >code-address ;
   
 \ Bit string manipulation                              06oct92py  \ Bit string manipulation                              06oct92py
   
 Create bits  80 c, 40 c, 20 c, 10 c, 8 c, 4 c, 2 c, 1 c,  Create bits  80 c, 40 c, 20 c, 10 c, 8 c, 4 c, 2 c, 1 c,
Line 115  DOES> ( n -- )  + c@ ; Line 141  DOES> ( n -- )  + c@ ;
 \ input stream primitives                              23feb93py  \ input stream primitives                              23feb93py
   
 : tib   >tib @ ;  : tib   >tib @ ;
 Defer source  Defer source \ used by dodefer:, must be defer
 : (source) ( -- addr count ) tib #tib @ ;  : (source) ( -- addr count ) tib #tib @ ;
 ' (source) IS source  ' (source) IS source
   
Line 736  Avariable leave-sp  leave-stack 3 cells Line 762  Avariable leave-sp  leave-stack 3 cells
     POSTPONE begin drop do-dest      POSTPONE begin drop do-dest
     ( 0 0 0 >leave ) ; immediate restrict      ( 0 0 0 >leave ) ; immediate restrict
   
 : ?DO ( -- do-sys )  : ?do-like ( -- do-sys )
     ( 0 0 0 >leave )      ( 0 0 0 >leave )
     POSTPONE (?do)  
     >mark >leave      >mark >leave
     POSTPONE begin drop do-dest ; immediate restrict      POSTPONE begin drop do-dest ;
   
   : ?DO ( -- do-sys )     \ core-ext      question-do
       POSTPONE (?do) ?do-like ; immediate restrict
   
   : +DO ( -- do-sys )     \ gforth        plus-do
       POSTPONE (+do) ?do-like ; immediate restrict
   
   : U+DO ( -- do-sys )    \ gforth        u-plus-do
       POSTPONE (u+do) ?do-like ; immediate restrict
   
   : -DO ( -- do-sys )     \ gforth        minus-do
       POSTPONE (-do) ?do-like ; immediate restrict
   
   : U-DO ( -- do-sys )    \ gforth        u-minus-do
       POSTPONE (u-do) ?do-like ; immediate restrict
   
 : FOR ( -- do-sys )  : FOR ( -- do-sys )
     POSTPONE (for)      POSTPONE (for)
Line 753  Avariable leave-sp  leave-stack 3 cells Line 793  Avariable leave-sp  leave-stack 3 cells
     >r >r 0 cs-pick swap cell - swap 1 cs-roll r> r> rot do-dest?      >r >r 0 cs-pick swap cell - swap 1 cs-roll r> r> rot do-dest?
     until-like  POSTPONE done  POSTPONE unloop ;      until-like  POSTPONE done  POSTPONE unloop ;
   
 : LOOP ( do-sys -- )  : LOOP ( do-sys -- )    \ core
  ['] (loop) ['] (loop)-lp+!# loop-like ; immediate restrict   ['] (loop) ['] (loop)-lp+!# loop-like ; immediate restrict
   
 : +LOOP ( do-sys -- )  : +LOOP ( do-sys -- )   \ core  plus-loop
  ['] (+loop) ['] (+loop)-lp+!# loop-like ; immediate restrict   ['] (+loop) ['] (+loop)-lp+!# loop-like ; immediate restrict
   
   \ !! should the compiler warn about +DO..-LOOP?
   : -LOOP ( do-sys -- )   \ gforth        minus-loop
    ['] (-loop) ['] (-loop)-lp+!# loop-like ; immediate restrict
   
 \ A symmetric version of "+LOOP". I.e., "-high -low ?DO -inc S+LOOP"  \ A symmetric version of "+LOOP". I.e., "-high -low ?DO -inc S+LOOP"
 \ will iterate as often as "high low ?DO inc S+LOOP". For positive  \ will iterate as often as "high low ?DO inc S+LOOP". For positive
 \ increments it behaves like "+LOOP". Use S+LOOP instead of +LOOP for  \ increments it behaves like "+LOOP". Use S+LOOP instead of +LOOP for
 \ negative increments.  \ negative increments.
 : S+LOOP ( do-sys -- )  : S+LOOP ( do-sys -- )  \ gforth        s-plus-loop
  ['] (s+loop) ['] (s+loop)-lp+!# loop-like ; immediate restrict   ['] (s+loop) ['] (s+loop)-lp+!# loop-like ; immediate restrict
   
 : NEXT ( do-sys -- )  : NEXT ( do-sys -- )
Line 902  Create ???  0 , 3 c, char ? c, char ? c, Line 946  Create ???  0 , 3 c, char ? c, char ? c,
  cell +loop   cell +loop
  drop ??? ( wouldn't 0 be better? ) ;   drop ??? ( wouldn't 0 be better? ) ;
   
 \ indirect threading                                   17mar93py  \ threading                                   17mar93py
   
 : cfa,     ( code-address -- )  : cfa,     ( code-address -- )  \ gforth
     here lastcfa !      here
     here  0 A, 0 ,  code-address! ;      dup lastcfa !
 : compile, ( xt -- )            A, ;      0 A, 0 ,  code-address! ;
 : !does    ( addr -- )          lastcfa @ does-code! ;  : compile, ( xt -- ) \ core-ext
 : (;code)  ( R: addr -- )       r> /does-handler + !does ;      A, ;
   : !does    ( addr -- )          lastxt does-code! ;
   : (does>)  ( R: addr -- )       r> /does-handler + !does ;
 : dodoes,  ( -- )  : dodoes,  ( -- )
   here /does-handler allot does-handler! ;    here /does-handler allot does-handler! ;
   
 \ direct threading is implementation dependent  : Create    Header reveal dovar: cfa, ;
   
 : Create    Header reveal [ :dovar ] Literal cfa, ;  
   
 \ DOES>                                                17mar93py  \ DOES>                                                17mar93py
   
 : DOES>  ( compilation: -- )  : DOES>  ( compilation: -- ) \ core
     state @      state @
     IF      IF
         ;-hook postpone (;code) dodoes,          ;-hook postpone (does>) ?struc dodoes,
     ELSE      ELSE
         dodoes, here !does 0 ]          align dodoes, here !does ]
     THEN       THEN 
     :-hook ; immediate      defstart :-hook ; immediate
   
 \ Create Variable User Constant                        17mar93py  \ Create Variable User Constant                        17mar93py
   
Line 938  Create ???  0 , 3 c, char ? c, char ? c, Line 982  Create ???  0 , 3 c, char ? c, char ? c,
 : User      Variable ;  : User      Variable ;
 : AUser     AVariable ;  : AUser     AVariable ;
   
 : (Constant)  Header reveal [ :docon ] Literal cfa, ;  : (Constant)  Header reveal docon: cfa, ;
 : Constant  (Constant) , ;  : Constant  (Constant) , ;
 : AConstant (Constant) A, ;  : AConstant (Constant) A, ;
   
Line 952  Create ???  0 , 3 c, char ? c, char ? c, Line 996  Create ???  0 , 3 c, char ? c, char ? c,
   
 : Defer ( -- )  : Defer ( -- )
     \ !! shouldn't it be initialized with abort or something similar?      \ !! shouldn't it be initialized with abort or something similar?
     Header Reveal [ :dodefer ] Literal cfa,      Header Reveal dodefer: cfa,
     ['] noop A, ;      ['] noop A, ;
 \     Create ( -- )   \     Create ( -- ) 
 \       ['] noop A,  \       ['] noop A,
Line 978  Create ???  0 , 3 c, char ? c, char ? c, Line 1022  Create ???  0 , 3 c, char ? c, char ? c,
 defer :-hook ( sys1 -- sys2 )  defer :-hook ( sys1 -- sys2 )
 defer ;-hook ( sys2 -- sys1 )  defer ;-hook ( sys2 -- sys1 )
   
 : : ( -- colon-sys )  Header [ :docol ] Literal cfa, defstart ] :-hook ;  : : ( -- colon-sys )  Header docol: cfa, defstart ] :-hook ;
 : ; ( colon-sys -- )  ;-hook ?struc postpone exit reveal postpone [ ;  : ; ( colon-sys -- )  ;-hook ?struc postpone exit reveal postpone [ ;
   immediate restrict    immediate restrict
   
 : :noname ( -- xt colon-sys )  : :noname ( -- xt colon-sys )
     0 last !      0 last !
     here [ :docol ] Literal cfa, 0 ] :-hook ;      here docol: cfa, 0 ] :-hook ;
   
 \ Search list handling                                 23feb93py  \ Search list handling                                 23feb93py
   
Line 1008  AVariable current Line 1052  AVariable current
   
 struct  struct
   1 cells: field find-method   \ xt: ( c_addr u wid -- name-id )    1 cells: field find-method   \ xt: ( c_addr u wid -- name-id )
   1 cells: field reveal-method \ xt: ( -- )    1 cells: field reveal-method \ xt: ( -- ) \ used by dofield:, must be field
   1 cells: field rehash-method \ xt: ( wid -- )    1 cells: field rehash-method \ xt: ( wid -- )
 \   \ !! what else  \   \ !! what else
 end-struct wordlist-map-struct  end-struct wordlist-map-struct

Removed from v.1.40  
changed lines
  Added in v.1.41


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