[BACK]Return to kernel.fs CVS log [TXT] [DIR] Up to [gforth] / gforth

Diff for /gforth/Attic/kernel.fs between versions 1.10 and 1.11

version 1.10, 1997/01/04 16:32:30 version 1.11, 1997/01/29 21:32:36
Line 488  hex Line 488  hex
 \ ?stack                                               23feb93py  \ ?stack                                               23feb93py
   
 : ?stack ( ?? -- ?? ) \ gforth  : ?stack ( ?? -- ?? ) \ gforth
     sp@ s0 @ > IF    -4 throw  THEN      sp@ s0 @ u> IF    -4 throw  THEN
     fp@ f0 @ > IF  -&45 throw  THEN  ;      fp@ f0 @ u> IF  -&45 throw  THEN  ;
 \ ?stack should be code -- it touches an empty stack!  \ ?stack should be code -- it touches an empty stack!
   
 \ interpret                                            10mar92py  \ interpret                                            10mar92py
Line 561  Defer interpreter-notfound ( c-addr coun Line 561  Defer interpreter-notfound ( c-addr coun
 : ] ( -- ) \ core       right-bracket  : ] ( -- ) \ core       right-bracket
     ['] compiler     IS parser state on  ;      ['] compiler     IS parser state on  ;
   
 here 0 , \ just a dummy, the real value of locals-list is patched into it in glocals.fs  
 AConstant locals-list \ acts like a variable that contains  
                       \ a linear list of locals names  
   
   
 variable dead-code \ true if normal code at "here" would be dead  
 variable backedge-locals  
     \ contains the locals list that BEGIN will assume to be live on  
     \ the back edge if the BEGIN is unreachable from above. Set by  
     \ ASSUME-LIVE, reset by UNREACHABLE.  
   
 : UNREACHABLE ( -- ) \ gforth  
     \ declares the current point of execution as unreachable  
     dead-code on  
     0 backedge-locals ! ; immediate  
   
 : ASSUME-LIVE ( orig -- orig ) \ gforth  
     \ used immediatly before a BEGIN that is not reachable from  
     \ above.  causes the BEGIN to assume that the same locals are live  
     \ as at the orig point  
     dup orig?  
     2 pick backedge-locals ! ; immediate  
       
 \ Control Flow Stack  
 \ orig, etc. have the following structure:  
 \ type ( defstart, live-orig, dead-orig, dest, do-dest, scopestart) ( TOS )  
 \ address (of the branch or the instruction to be branched to) (second)  
 \ locals-list (valid at address) (third)  
   
 \ types  
 0 constant defstart  
 1 constant live-orig  
 2 constant dead-orig  
 3 constant dest \ the loopback branch is always assumed live  
 4 constant do-dest  
 5 constant scopestart  
   
 : def? ( n -- )  
     defstart <> abort" unstructured " ;  
   
 : orig? ( n -- )  
  dup live-orig <> swap dead-orig <> and abort" expected orig " ;  
   
 : dest? ( n -- )  
  dest <> abort" expected dest " ;  
   
 : do-dest? ( n -- )  
  do-dest <> abort" expected do-dest " ;  
   
 : scope? ( n -- )  
  scopestart <> abort" expected scope " ;  
   
 : non-orig? ( n -- )  
  dest scopestart 1+ within 0= abort" expected dest, do-dest or scope" ;  
   
 : cs-item? ( n -- )  
  live-orig scopestart 1+ within 0= abort" expected control flow stack item" ;  
   
 3 constant cs-item-size  
   
 : CS-PICK ( ... u -- ... destu ) \ tools-ext  
  1+ cs-item-size * 1- >r  
  r@ pick  r@ pick  r@ pick  
  rdrop  
  dup non-orig? ;  
   
 : CS-ROLL ( destu/origu .. dest0/orig0 u -- .. dest0/orig0 destu/origu ) \ tools-ext  
  1+ cs-item-size * 1- >r  
  r@ roll r@ roll r@ roll  
  rdrop  
  dup cs-item? ;   
   
 : cs-push-part ( -- list addr )  
  locals-list @ here ;  
   
 : cs-push-orig ( -- orig )  
  cs-push-part dead-code @  
  if  
    dead-orig  
  else  
    live-orig  
  then ;     
   
 \ Structural Conditionals                              12dec92py  
   
 : ?struc      ( flag -- )       abort" unstructured " ;  
 : sys?        ( sys -- )        dup 0= ?struc ;  
 : >mark ( -- orig )  
  cs-push-orig 0 , ;  
 : >resolve    ( addr -- )        here over - swap ! ;  
 : <resolve    ( addr -- )        here - , ;  
   
 : BUT  
     1 cs-roll ;                      immediate restrict  
 : YET  
     0 cs-pick ;                       immediate restrict  
   
 \ Structural Conditionals                              12dec92py  
   
 : AHEAD ( compilation -- orig ; run-time -- ) \ tools-ext  
     POSTPONE branch  >mark  POSTPONE unreachable ; immediate restrict  
   
 : IF ( compilation -- orig ; run-time f -- ) \ core  
  POSTPONE ?branch >mark ; immediate restrict  
   
 : ?DUP-IF ( compilation -- orig ; run-time n -- n| ) \ gforth   question-dupe-if  
 \G This is the preferred alternative to the idiom "?DUP IF", since it can be  
 \G better handled by tools like stack checkers. Besides, it's faster.  
     POSTPONE ?dup-?branch >mark ;       immediate restrict  
   
 : ?DUP-0=-IF ( compilation -- orig ; run-time n -- n| ) \ gforth        question-dupe-zero-equals-if  
     POSTPONE ?dup-0=-?branch >mark ;       immediate restrict  
   
 Defer then-like ( orig -- addr )  
 : cs>addr ( orig/dest -- addr )  drop nip ;  
 ' cs>addr IS then-like  
   
 : THEN ( compilation orig -- ; run-time -- ) \ core  
     dup orig?  then-like  >resolve ; immediate restrict  
   
 ' THEN alias ENDIF ( compilation orig -- ; run-time -- ) \ gforth  
 immediate restrict  
 \ Same as "THEN". This is what you use if your program will be seen by  
 \ people who have not been brought up with Forth (or who have been  
 \ brought up with fig-Forth).  
   
 : ELSE ( compilation orig1 -- orig2 ; run-time f -- ) \ core  
     POSTPONE ahead  
     1 cs-roll  
     POSTPONE then ; immediate restrict  
   
 Defer begin-like ( -- )  
 ' noop IS begin-like  
   
 : BEGIN ( compilation -- dest ; run-time -- ) \ core  
     begin-like cs-push-part dest ; immediate restrict  
   
 Defer again-like ( dest -- addr )  
 ' nip IS again-like  
   
 : AGAIN ( compilation dest -- ; run-time -- ) \ core-ext  
     dest? again-like  POSTPONE branch  <resolve ; immediate restrict  
   
 Defer until-like  
 : until, ( list addr xt1 xt2 -- )  drop compile, <resolve drop ;  
 ' until, IS until-like  
   
 : UNTIL ( compilation dest -- ; run-time f -- ) \ core  
     dest? ['] ?branch ['] ?branch-lp+!# until-like ; immediate restrict  
   
 : WHILE ( compilation dest -- orig dest ; run-time f -- ) \ core  
     POSTPONE if  
     1 cs-roll ; immediate restrict  
   
 : REPEAT ( compilation orig dest -- ; run-time -- ) \ core  
     POSTPONE again  
     POSTPONE then ; immediate restrict  
   
 \ counted loops  
   
 \ leave poses a little problem here  
 \ we have to store more than just the address of the branch, so the  
 \ traditional linked list approach is no longer viable.  
 \ This is solved by storing the information about the leavings in a  
 \ special stack.  
   
 \ !! remove the fixed size limit. 'Tis not hard.  
 20 constant leave-stack-size  
 create leave-stack  60 cells allot  
 Avariable leave-sp  leave-stack 3 cells + leave-sp !  
   
 : clear-leave-stack ( -- )  
     leave-stack leave-sp ! ;  
   
 \ : leave-empty? ( -- f )  
 \  leave-sp @ leave-stack = ;  
   
 : >leave ( orig -- )  
     \ push on leave-stack  
     leave-sp @  
     dup [ leave-stack 60 cells + ] Aliteral  
     >= abort" leave-stack full"  
     tuck ! cell+  
     tuck ! cell+  
     tuck ! cell+  
     leave-sp ! ;  
   
 : leave> ( -- orig )  
     \ pop from leave-stack  
     leave-sp @  
     dup leave-stack <= IF  
        drop 0 0 0  EXIT  THEN  
     cell - dup @ swap  
     cell - dup @ swap  
     cell - dup @ swap  
     leave-sp ! ;  
   
 : DONE ( compilation orig -- ; run-time -- ) \ gforth  
     \ !! the original done had ( addr -- )  
     drop >r drop  
     begin  
         leave>  
         over r@ u>=  
     while  
         POSTPONE then  
     repeat  
     >leave rdrop ; immediate restrict  
   
 : LEAVE ( compilation -- ; run-time loop-sys -- ) \ core  
     POSTPONE ahead  
     >leave ; immediate restrict  
   
 : ?LEAVE ( compilation -- ; run-time f | f loop-sys -- ) \ gforth       question-leave  
     POSTPONE 0= POSTPONE if  
     >leave ; immediate restrict  
   
 : DO ( compilation -- do-sys ; run-time w1 w2 -- loop-sys ) \ core  
     POSTPONE (do)  
     POSTPONE begin drop do-dest  
     ( 0 0 0 >leave ) ; immediate restrict  
   
 : ?do-like ( -- do-sys )  
     ( 0 0 0 >leave )  
     >mark >leave  
     POSTPONE begin drop do-dest ;  
   
 : ?DO ( compilation -- do-sys ; run-time w1 w2 -- | loop-sys )  \ core-ext      question-do  
     POSTPONE (?do) ?do-like ; immediate restrict  
   
 : +DO ( compilation -- do-sys ; run-time n1 n2 -- | loop-sys )  \ gforth        plus-do  
     POSTPONE (+do) ?do-like ; immediate restrict  
   
 : U+DO ( compilation -- do-sys ; run-time u1 u2 -- | loop-sys ) \ gforth        u-plus-do  
     POSTPONE (u+do) ?do-like ; immediate restrict  
   
 : -DO ( compilation -- do-sys ; run-time n1 n2 -- | loop-sys )  \ gforth        minus-do  
     POSTPONE (-do) ?do-like ; immediate restrict  
   
 : U-DO ( compilation -- do-sys ; run-time u1 u2 -- | loop-sys ) \ gforth        u-minus-do  
     POSTPONE (u-do) ?do-like ; immediate restrict  
   
 : FOR ( compilation -- do-sys ; run-time u -- loop-sys )        \ gforth  
     POSTPONE (for)  
     POSTPONE begin drop do-dest  
     ( 0 0 0 >leave ) ; immediate restrict  
   
 \ LOOP etc. are just like UNTIL  
   
 : loop-like ( do-sys xt1 xt2 -- )  
     >r >r 0 cs-pick swap cell - swap 1 cs-roll r> r> rot do-dest?  
     until-like  POSTPONE done  POSTPONE unloop ;  
   
 : LOOP ( compilation do-sys -- ; run-time loop-sys1 -- | loop-sys2 )    \ core  
  ['] (loop) ['] (loop)-lp+!# loop-like ; immediate restrict  
   
 : +LOOP ( compilation do-sys -- ; run-time loop-sys1 n -- | loop-sys2 ) \ core  plus-loop  
  ['] (+loop) ['] (+loop)-lp+!# loop-like ; immediate restrict  
   
 \ !! should the compiler warn about +DO..-LOOP?  
 : -LOOP ( compilation do-sys -- ; run-time loop-sys1 u -- | loop-sys2 ) \ gforth        minus-loop  
  ['] (-loop) ['] (-loop)-lp+!# loop-like ; immediate restrict  
   
 \ 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  
 \ increments it behaves like "+LOOP". Use S+LOOP instead of +LOOP for  
 \ negative increments.  
 : S+LOOP ( compilation do-sys -- ; run-time loop-sys1 n -- | loop-sys2 )        \ gforth        s-plus-loop  
  ['] (s+loop) ['] (s+loop)-lp+!# loop-like ; immediate restrict  
   
 : NEXT ( compilation do-sys -- ; run-time loop-sys1 -- | loop-sys2 ) \ gforth  
  ['] (next) ['] (next)-lp+!# loop-like ; immediate restrict  
   
 \ Structural Conditionals                              12dec92py  
   
 Defer exit-like ( -- )  
 ' noop IS exit-like  
   
 : EXIT ( compilation -- ; run-time nest-sys -- ) \ core  
     exit-like  
     POSTPONE ;s  
     POSTPONE unreachable ; immediate restrict  
   
 : ?EXIT ( -- ) ( compilation -- ; run-time nest-sys f -- | nest-sys ) \ gforth  
      POSTPONE if POSTPONE exit POSTPONE then ; immediate restrict  
   
 \ Strings                                              22feb93py  \ Strings                                              22feb93py
   
 : ," ( "string"<"> -- ) [char] " parse  : ," ( "string"<"> -- ) [char] " parse
Removed from v.1.10  
changed lines
  Added in v.1.11

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