Annotation of gforth/conditionals.fs, revision 1.2

1.1       pazsan      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: 
1.2     ! anton     116: Defer then-like ( orig -- )
        !           117: : cs>addr ( orig/dest -- )  drop >resolve drop ;
1.1       pazsan    118: ' cs>addr IS then-like
                    119: 
                    120: : THEN ( compilation orig -- ; run-time -- ) \ core
1.2     ! anton     121:     dup orig?  then-like ; immediate restrict
1.1       pazsan    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>