File:  [gforth] / gforth / Attic / conditionals.fs
Revision 1.1: download - view: text, annotated - select for diffs
Wed Jan 29 21:39:10 1997 UTC (27 years, 2 months ago) by pazsan
Branches: MAIN
CVS tags: HEAD
Kernel conditonals

    1: \ Structural Conditionals                              12dec92py
    2: 
    3: here 0 , \ just a dummy, the real value of locals-list is patched into it in glocals.fs
    4: AConstant locals-list \ acts like a variable that contains
    5: 		      \ a linear list of locals names
    6: 
    7: 
    8: variable dead-code \ true if normal code at "here" would be dead
    9: variable backedge-locals
   10:     \ contains the locals list that BEGIN will assume to be live on
   11:     \ the back edge if the BEGIN is unreachable from above. Set by
   12:     \ ASSUME-LIVE, reset by UNREACHABLE.
   13: 
   14: : UNREACHABLE ( -- ) \ gforth
   15:     \ declares the current point of execution as unreachable
   16:     dead-code on
   17:     0 backedge-locals ! ; immediate
   18: 
   19: : ASSUME-LIVE ( orig -- orig ) \ gforth
   20:     \ used immediatly before a BEGIN that is not reachable from
   21:     \ above.  causes the BEGIN to assume that the same locals are live
   22:     \ as at the orig point
   23:     dup orig?
   24:     2 pick backedge-locals ! ; immediate
   25:     
   26: \ Control Flow Stack
   27: \ orig, etc. have the following structure:
   28: \ type ( defstart, live-orig, dead-orig, dest, do-dest, scopestart) ( TOS )
   29: \ address (of the branch or the instruction to be branched to) (second)
   30: \ locals-list (valid at address) (third)
   31: 
   32: \ types
   33: 0 constant defstart
   34: 1 constant live-orig
   35: 2 constant dead-orig
   36: 3 constant dest \ the loopback branch is always assumed live
   37: 4 constant do-dest
   38: 5 constant scopestart
   39: 
   40: : def? ( n -- )
   41:     defstart <> abort" unstructured " ;
   42: 
   43: : orig? ( n -- )
   44:  dup live-orig <> swap dead-orig <> and abort" expected orig " ;
   45: 
   46: : dest? ( n -- )
   47:  dest <> abort" expected dest " ;
   48: 
   49: : do-dest? ( n -- )
   50:  do-dest <> abort" expected do-dest " ;
   51: 
   52: : scope? ( n -- )
   53:  scopestart <> abort" expected scope " ;
   54: 
   55: : non-orig? ( n -- )
   56:  dest scopestart 1+ within 0= abort" expected dest, do-dest or scope" ;
   57: 
   58: : cs-item? ( n -- )
   59:  live-orig scopestart 1+ within 0= abort" expected control flow stack item" ;
   60: 
   61: 3 constant cs-item-size
   62: 
   63: : CS-PICK ( ... u -- ... destu ) \ tools-ext
   64:  1+ cs-item-size * 1- >r
   65:  r@ pick  r@ pick  r@ pick
   66:  rdrop
   67:  dup non-orig? ;
   68: 
   69: : CS-ROLL ( destu/origu .. dest0/orig0 u -- .. dest0/orig0 destu/origu ) \ tools-ext
   70:  1+ cs-item-size * 1- >r
   71:  r@ roll r@ roll r@ roll
   72:  rdrop
   73:  dup cs-item? ; 
   74: 
   75: : cs-push-part ( -- list addr )
   76:  locals-list @ here ;
   77: 
   78: : cs-push-orig ( -- orig )
   79:  cs-push-part dead-code @
   80:  if
   81:    dead-orig
   82:  else
   83:    live-orig
   84:  then ;   
   85: 
   86: \ Structural Conditionals                              12dec92py
   87: 
   88: : ?struc      ( flag -- )       abort" unstructured " ;
   89: : sys?        ( sys -- )        dup 0= ?struc ;
   90: : >mark ( -- orig )
   91:  cs-push-orig 0 , ;
   92: : >resolve    ( addr -- )        here over - swap ! ;
   93: : <resolve    ( addr -- )        here - , ;
   94: 
   95: : BUT
   96:     1 cs-roll ;                      immediate restrict
   97: : YET
   98:     0 cs-pick ;                       immediate restrict
   99: 
  100: \ Structural Conditionals                              12dec92py
  101: 
  102: : AHEAD ( compilation -- orig ; run-time -- ) \ tools-ext
  103:     POSTPONE branch  >mark  POSTPONE unreachable ; immediate restrict
  104: 
  105: : IF ( compilation -- orig ; run-time f -- ) \ core
  106:  POSTPONE ?branch >mark ; immediate restrict
  107: 
  108: : ?DUP-IF ( compilation -- orig ; run-time n -- n| ) \ gforth	question-dupe-if
  109: \G This is the preferred alternative to the idiom "?DUP IF", since it can be
  110: \G better handled by tools like stack checkers. Besides, it's faster.
  111:     POSTPONE ?dup-?branch >mark ;       immediate restrict
  112: 
  113: : ?DUP-0=-IF ( compilation -- orig ; run-time n -- n| ) \ gforth	question-dupe-zero-equals-if
  114:     POSTPONE ?dup-0=-?branch >mark ;       immediate restrict
  115: 
  116: Defer then-like ( orig -- addr )
  117: : cs>addr ( orig/dest -- addr )  drop nip ;
  118: ' cs>addr IS then-like
  119: 
  120: : THEN ( compilation orig -- ; run-time -- ) \ core
  121:     dup orig?  then-like  >resolve ; immediate restrict
  122: 
  123: ' THEN alias ENDIF ( compilation orig -- ; run-time -- ) \ gforth
  124: immediate restrict
  125: \ Same as "THEN". This is what you use if your program will be seen by
  126: \ people who have not been brought up with Forth (or who have been
  127: \ brought up with fig-Forth).
  128: 
  129: : ELSE ( compilation orig1 -- orig2 ; run-time f -- ) \ core
  130:     POSTPONE ahead
  131:     1 cs-roll
  132:     POSTPONE then ; immediate restrict
  133: 
  134: Defer begin-like ( -- )
  135: ' noop IS begin-like
  136: 
  137: : BEGIN ( compilation -- dest ; run-time -- ) \ core
  138:     begin-like cs-push-part dest ; immediate restrict
  139: 
  140: Defer again-like ( dest -- addr )
  141: ' nip IS again-like
  142: 
  143: : AGAIN ( compilation dest -- ; run-time -- ) \ core-ext
  144:     dest? again-like  POSTPONE branch  <resolve ; immediate restrict
  145: 
  146: Defer until-like
  147: : until, ( list addr xt1 xt2 -- )  drop compile, <resolve drop ;
  148: ' until, IS until-like
  149: 
  150: : UNTIL ( compilation dest -- ; run-time f -- ) \ core
  151:     dest? ['] ?branch ['] ?branch-lp+!# until-like ; immediate restrict
  152: 
  153: : WHILE ( compilation dest -- orig dest ; run-time f -- ) \ core
  154:     POSTPONE if
  155:     1 cs-roll ; immediate restrict
  156: 
  157: : REPEAT ( compilation orig dest -- ; run-time -- ) \ core
  158:     POSTPONE again
  159:     POSTPONE then ; immediate restrict
  160: 
  161: \ counted loops
  162: 
  163: \ leave poses a little problem here
  164: \ we have to store more than just the address of the branch, so the
  165: \ traditional linked list approach is no longer viable.
  166: \ This is solved by storing the information about the leavings in a
  167: \ special stack.
  168: 
  169: \ !! remove the fixed size limit. 'Tis not hard.
  170: 20 constant leave-stack-size
  171: create leave-stack  60 cells allot
  172: Avariable leave-sp  leave-stack 3 cells + leave-sp !
  173: 
  174: : clear-leave-stack ( -- )
  175:     leave-stack leave-sp ! ;
  176: 
  177: \ : leave-empty? ( -- f )
  178: \  leave-sp @ leave-stack = ;
  179: 
  180: : >leave ( orig -- )
  181:     \ push on leave-stack
  182:     leave-sp @
  183:     dup [ leave-stack 60 cells + ] Aliteral
  184:     >= abort" leave-stack full"
  185:     tuck ! cell+
  186:     tuck ! cell+
  187:     tuck ! cell+
  188:     leave-sp ! ;
  189: 
  190: : leave> ( -- orig )
  191:     \ pop from leave-stack
  192:     leave-sp @
  193:     dup leave-stack <= IF
  194:        drop 0 0 0  EXIT  THEN
  195:     cell - dup @ swap
  196:     cell - dup @ swap
  197:     cell - dup @ swap
  198:     leave-sp ! ;
  199: 
  200: : DONE ( compilation orig -- ; run-time -- ) \ gforth
  201:     \ !! the original done had ( addr -- )
  202:     drop >r drop
  203:     begin
  204: 	leave>
  205: 	over r@ u>=
  206:     while
  207: 	POSTPONE then
  208:     repeat
  209:     >leave rdrop ; immediate restrict
  210: 
  211: : LEAVE ( compilation -- ; run-time loop-sys -- ) \ core
  212:     POSTPONE ahead
  213:     >leave ; immediate restrict
  214: 
  215: : ?LEAVE ( compilation -- ; run-time f | f loop-sys -- ) \ gforth	question-leave
  216:     POSTPONE 0= POSTPONE if
  217:     >leave ; immediate restrict
  218: 
  219: : DO ( compilation -- do-sys ; run-time w1 w2 -- loop-sys ) \ core
  220:     POSTPONE (do)
  221:     POSTPONE begin drop do-dest
  222:     ( 0 0 0 >leave ) ; immediate restrict
  223: 
  224: : ?do-like ( -- do-sys )
  225:     ( 0 0 0 >leave )
  226:     >mark >leave
  227:     POSTPONE begin drop do-dest ;
  228: 
  229: : ?DO ( compilation -- do-sys ; run-time w1 w2 -- | loop-sys )	\ core-ext	question-do
  230:     POSTPONE (?do) ?do-like ; immediate restrict
  231: 
  232: : +DO ( compilation -- do-sys ; run-time n1 n2 -- | loop-sys )	\ gforth	plus-do
  233:     POSTPONE (+do) ?do-like ; immediate restrict
  234: 
  235: : U+DO ( compilation -- do-sys ; run-time u1 u2 -- | loop-sys )	\ gforth	u-plus-do
  236:     POSTPONE (u+do) ?do-like ; immediate restrict
  237: 
  238: : -DO ( compilation -- do-sys ; run-time n1 n2 -- | loop-sys )	\ gforth	minus-do
  239:     POSTPONE (-do) ?do-like ; immediate restrict
  240: 
  241: : U-DO ( compilation -- do-sys ; run-time u1 u2 -- | loop-sys )	\ gforth	u-minus-do
  242:     POSTPONE (u-do) ?do-like ; immediate restrict
  243: 
  244: : FOR ( compilation -- do-sys ; run-time u -- loop-sys )	\ gforth
  245:     POSTPONE (for)
  246:     POSTPONE begin drop do-dest
  247:     ( 0 0 0 >leave ) ; immediate restrict
  248: 
  249: \ LOOP etc. are just like UNTIL
  250: 
  251: : loop-like ( do-sys xt1 xt2 -- )
  252:     >r >r 0 cs-pick swap cell - swap 1 cs-roll r> r> rot do-dest?
  253:     until-like  POSTPONE done  POSTPONE unloop ;
  254: 
  255: : LOOP ( compilation do-sys -- ; run-time loop-sys1 -- | loop-sys2 )	\ core
  256:  ['] (loop) ['] (loop)-lp+!# loop-like ; immediate restrict
  257: 
  258: : +LOOP ( compilation do-sys -- ; run-time loop-sys1 n -- | loop-sys2 )	\ core	plus-loop
  259:  ['] (+loop) ['] (+loop)-lp+!# loop-like ; immediate restrict
  260: 
  261: \ !! should the compiler warn about +DO..-LOOP?
  262: : -LOOP ( compilation do-sys -- ; run-time loop-sys1 u -- | loop-sys2 )	\ gforth	minus-loop
  263:  ['] (-loop) ['] (-loop)-lp+!# loop-like ; immediate restrict
  264: 
  265: \ A symmetric version of "+LOOP". I.e., "-high -low ?DO -inc S+LOOP"
  266: \ will iterate as often as "high low ?DO inc S+LOOP". For positive
  267: \ increments it behaves like "+LOOP". Use S+LOOP instead of +LOOP for
  268: \ negative increments.
  269: : S+LOOP ( compilation do-sys -- ; run-time loop-sys1 n -- | loop-sys2 )	\ gforth	s-plus-loop
  270:  ['] (s+loop) ['] (s+loop)-lp+!# loop-like ; immediate restrict
  271: 
  272: : NEXT ( compilation do-sys -- ; run-time loop-sys1 -- | loop-sys2 ) \ gforth
  273:  ['] (next) ['] (next)-lp+!# loop-like ; immediate restrict
  274: 
  275: \ Structural Conditionals                              12dec92py
  276: 
  277: Defer exit-like ( -- )
  278: ' noop IS exit-like
  279: 
  280: : EXIT ( compilation -- ; run-time nest-sys -- ) \ core
  281:     exit-like
  282:     POSTPONE ;s
  283:     POSTPONE unreachable ; immediate restrict
  284: 
  285: : ?EXIT ( -- ) ( compilation -- ; run-time nest-sys f -- | nest-sys ) \ gforth
  286:      POSTPONE if POSTPONE exit POSTPONE then ; immediate restrict
  287: 

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