[gforth] / gforth / Attic / kernal.fs  

gforth: gforth/Attic/kernal.fs

Diff for /gforth/Attic/kernal.fs between version 1.8 and 1.9

version 1.8, Fri Jun 17 12:35:07 1994 UTC version 1.9, Thu Jul 7 14:59:23 1994 UTC
Line 79 
Line 79 
 \ name> found                                          17dec92py  \ name> found                                          17dec92py
   
 : (name>)  ( nfa -- cfa )    count  $1F and  +  aligned ;  : (name>)  ( nfa -- cfa )    count  $1F and  +  aligned ;
 : name>    ( nfa -- cfa )  : name>    ( nfa -- cfa )    cell+
   dup  (name>) swap  c@ $80 and 0= IF  @ THEN ;    dup  (name>) swap  c@ $80 and 0= IF  @ THEN ;
   
 : found ( nfa -- cfa n )  cell+  : found ( nfa -- cfa n )  cell+
   dup c@ >r  (name>) r@ $80 and  0= IF  @       THEN    dup c@ >r  (name>) r@ $80 and  0= IF  @       THEN
 \                  -1 r@ $40 and     IF  1-      THEN                    -1 r@ $40 and     IF  1-      THEN
                   -1 r> $20 and     IF  negate  THEN  ;                       r> $20 and     IF  negate  THEN  ;
   
 \ (find)                                               17dec92py  \ (find)                                               17dec92py
   
Line 590 
Line 590 
 \ we have to store more than just the address of the branch, so the  \ we have to store more than just the address of the branch, so the
 \ traditional linked list approach is no longer viable.  \ traditional linked list approach is no longer viable.
 \ This is solved by storing the information about the leavings in a  \ This is solved by storing the information about the leavings in a
 \ special stack. The leavings of different DO-LOOPs are separated  \ special stack.
 \ by a 0 entry  
   
 \ !! remove the fixed size limit. 'Tis not hard.  \ !! remove the fixed size limit. 'Tis not hard.
 20 constant leave-stack-size  20 constant leave-stack-size
 create leave-stack 60 cells allot  create leave-stack 60 cells allot
 Avariable leave-sp  leave-stack leave-sp !  Avariable leave-sp  leave-stack 3 cells + leave-sp !
   
 : clear-leave-stack ( -- )  : clear-leave-stack ( -- )
     leave-stack leave-sp ! ;      leave-stack leave-sp ! ;
Line 617 
Line 616 
 : leave> ( -- orig )  : leave> ( -- orig )
     \ pop from leave-stack      \ pop from leave-stack
     leave-sp @      leave-sp @
     dup leave-stack <= abort" leave-stack empty"      dup leave-stack <= IF
          drop 0 0 0  EXIT  THEN
     cell - dup @ swap      cell - dup @ swap
     cell - dup @ swap      cell - dup @ swap
     cell - dup @ swap      cell - dup @ swap
     leave-sp ! ;      leave-sp ! ;
   
 : done ( -- )  : DONE ( orig -- )  drop >r drop
     \ !! the original done had ( addr -- )      \ !! the original done had ( addr -- )
     begin      begin
         leave>          leave>
         dup          over r@ u>=
     while      while
         POSTPONE then          POSTPONE then
     repeat      repeat
     2drop drop ; immediate      >leave rdrop ; immediate restrict
   
 : LEAVE ( -- )  : LEAVE ( -- )
     POSTPONE ahead      POSTPONE ahead
     >leave ; immediate      >leave ; immediate restrict
   
 : ?LEAVE ( -- )  : ?LEAVE ( -- )
     POSTPONE 0= POSTPONE if      POSTPONE 0= POSTPONE if
     >leave ; immediate      >leave ; immediate restrict
   
 : DO ( -- do-sys )  : DO ( -- do-sys )
     POSTPONE (do)      POSTPONE (do)
     POSTPONE begin drop do-dest      POSTPONE begin drop do-dest
     0 0 0 >leave ; immediate      ( 0 0 0 >leave ) ; immediate restrict
   
 : ?DO ( -- do-sys )  : ?DO ( -- do-sys )
     0 0 0 >leave      ( 0 0 0 >leave )
     POSTPONE (?do)      POSTPONE (?do)
     >mark >leave      >mark >leave
     POSTPONE begin drop do-dest ; immediate      POSTPONE begin drop do-dest ; immediate restrict
   
 : FOR ( -- do-sys )  : FOR ( -- do-sys )
     POSTPONE (for)      POSTPONE (for)
     POSTPONE begin drop do-dest      POSTPONE begin drop do-dest
     0 0 0 >leave ; immediate      ( 0 0 0 >leave ) ; immediate restrict
   
 \ LOOP etc. are just like UNTIL  \ LOOP etc. are just like UNTIL
   
 : loop-like ( do-sys xt1 xt2 -- )  : loop-like ( do-sys xt1 xt2 -- )
     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 -- )
  ['] (loop) ['] (loop)-lp+!# loop-like ; immediate   ['] (loop) ['] (loop)-lp+!# loop-like ; immediate restrict
   
 : +LOOP ( do-sys -- )  : +LOOP ( do-sys -- )
  ['] (+loop) ['] (+loop)-lp+!# loop-like ; immediate   ['] (+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 -- )
  ['] (s+loop) ['] (s+loop)-lp+!# loop-like ; immediate   ['] (s+loop) ['] (s+loop)-lp+!# loop-like ; immediate restrict
   
 : NEXT ( do-sys -- )  : NEXT ( do-sys -- )
  ['] (next) ['] (next)-lp+!# loop-like ; immediate   ['] (next) ['] (next)-lp+!# loop-like ; immediate restrict
   
 \ Structural Conditionals                              12dec92py  \ Structural Conditionals                              12dec92py
   
Line 717 
Line 717 
   
 : flag! ( 8b -- )   last @ cell+ tuck c@ xor swap c! ;  : flag! ( 8b -- )   last @ cell+ tuck c@ xor swap c! ;
 : immediate     $20 flag! ;  : immediate     $20 flag! ;
 \ : restrict      $40 flag! ;  : restrict      $40 flag! ;
 ' noop alias restrict  \ ' noop alias restrict
   
 \ Header                                               23feb93py  \ Header                                               23feb93py
   
Line 777 
Line 777 
 : name>string ( nfa -- addr count )  : name>string ( nfa -- addr count )
  cell+ count $1F and ;   cell+ count $1F and ;
   
 Create ???  ," ???"  Create ???  0 , 3 c, char ? c, char ? c, char ? c,
 : >name ( cfa -- nfa )  : >name ( cfa -- nfa )
  $21 cell do   $21 cell do
    dup i - count $9F and + aligned over $80 + = if     dup i - count $9F and + aligned over $80 + = if
Line 1001 
Line 1001 
 DEFER type      \ defer type for a output buffer or fast  DEFER type      \ defer type for a output buffer or fast
                 \ screen write                  \ screen write
   
 : (type) ( addr len -- )  \ : (type) ( addr len -- )
   bounds ?DO  I c@ emit  LOOP ;  \   bounds ?DO  I c@ emit  LOOP ;
   
 ' (TYPE) IS Type  ' (TYPE) IS Type
   
 \ DEFER Emit  DEFER Emit
   
 \ ' (Emit) IS Emit  ' (Emit) IS Emit
   
 \ : form  ( -- rows cols )  &24 &80 ;  \ : form  ( -- rows cols )  &24 &80 ;
 \ form should be implemented using TERMCAPS or CURSES  \ form should be implemented using TERMCAPS or CURSES
Line 1087 
Line 1087 
   
 \ RECURSE                                               17may93jaw  \ RECURSE                                               17may93jaw
   
 : recurse  last @ cell+ name> a, ; immediate restrict  : recurse  last @ ( cell+ ) name> a, ; immediate restrict
 \ !! does not work with anonymous words; use lastxt compile,  \ !! does not work with anonymous words; use lastxt compile,
   
 \ */MOD */                                              17may93jaw  \ */MOD */                                              17may93jaw

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

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help