Annotation of gforth/kernel/cond.fs, revision 1.27

1.1       anton       1: \ Structural Conditionals                              12dec92py
                      2: 
1.26      anton       3: \ Copyright (C) 1995,1996,1997,2000,2003,2004,2007,2010,2011 Free Software Foundation, Inc.
1.1       anton       4: 
                      5: \ This file is part of Gforth.
                      6: 
                      7: \ Gforth is free software; you can redistribute it and/or
                      8: \ modify it under the terms of the GNU General Public License
1.22      anton       9: \ as published by the Free Software Foundation, either version 3
1.1       anton      10: \ of the License, or (at your option) any later version.
                     11: 
                     12: \ This program is distributed in the hope that it will be useful,
                     13: \ but WITHOUT ANY WARRANTY; without even the implied warranty of
                     14: \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
                     15: \ GNU General Public License for more details.
                     16: 
                     17: \ You should have received a copy of the GNU General Public License
1.22      anton      18: \ along with this program. If not, see http://www.gnu.org/licenses/.
1.1       anton      19: 
                     20: here 0 , \ just a dummy, the real value of locals-list is patched into it in glocals.fs
                     21: AConstant locals-list \ acts like a variable that contains
                     22:                      \ a linear list of locals names
                     23: 
                     24: 
                     25: variable dead-code \ true if normal code at "here" would be dead
                     26: variable backedge-locals
                     27:     \ contains the locals list that BEGIN will assume to be live on
                     28:     \ the back edge if the BEGIN is unreachable from above. Set by
                     29:     \ ASSUME-LIVE, reset by UNREACHABLE.
                     30: 
                     31: : UNREACHABLE ( -- ) \ gforth
                     32:     \ declares the current point of execution as unreachable
                     33:     dead-code on
                     34:     0 backedge-locals ! ; immediate
                     35: 
                     36: : ASSUME-LIVE ( orig -- orig ) \ gforth
                     37:     \ used immediatly before a BEGIN that is not reachable from
                     38:     \ above.  causes the BEGIN to assume that the same locals are live
                     39:     \ as at the orig point
                     40:     dup orig?
                     41:     2 pick backedge-locals ! ; immediate
                     42:     
                     43: \ Control Flow Stack
                     44: \ orig, etc. have the following structure:
                     45: \ type ( defstart, live-orig, dead-orig, dest, do-dest, scopestart) ( TOS )
                     46: \ address (of the branch or the instruction to be branched to) (second)
                     47: \ locals-list (valid at address) (third)
                     48: 
                     49: \ types
1.6       jwilke     50: [IFUNDEF] defstart 
                     51: 0 constant defstart    \ usally defined in comp.fs
                     52: [THEN]
1.1       anton      53: 1 constant live-orig
                     54: 2 constant dead-orig
                     55: 3 constant dest \ the loopback branch is always assumed live
                     56: 4 constant do-dest
                     57: 5 constant scopestart
                     58: 
                     59: : def? ( n -- )
                     60:     defstart <> abort" unstructured " ;
                     61: 
                     62: : orig? ( n -- )
                     63:  dup live-orig <> swap dead-orig <> and abort" expected orig " ;
                     64: 
                     65: : dest? ( n -- )
                     66:  dest <> abort" expected dest " ;
                     67: 
                     68: : do-dest? ( n -- )
                     69:  do-dest <> abort" expected do-dest " ;
                     70: 
                     71: : scope? ( n -- )
                     72:  scopestart <> abort" expected scope " ;
                     73: 
                     74: : non-orig? ( n -- )
                     75:  dest scopestart 1+ within 0= abort" expected dest, do-dest or scope" ;
                     76: 
                     77: : cs-item? ( n -- )
                     78:  live-orig scopestart 1+ within 0= abort" expected control flow stack item" ;
                     79: 
                     80: 3 constant cs-item-size
                     81: 
1.7       crook      82: : CS-PICK ( ... u -- ... destu ) \ tools-ext c-s-pick
1.1       anton      83:  1+ cs-item-size * 1- >r
                     84:  r@ pick  r@ pick  r@ pick
                     85:  rdrop
                     86:  dup non-orig? ;
                     87: 
1.7       crook      88: : CS-ROLL ( destu/origu .. dest0/orig0 u -- .. dest0/orig0 destu/origu ) \ tools-ext c-s-roll
1.1       anton      89:  1+ cs-item-size * 1- >r
                     90:  r@ roll r@ roll r@ roll
                     91:  rdrop
                     92:  dup cs-item? ; 
                     93: 
1.25      anton      94: : CS-DROP ( dest -- ) \ gforth
                     95:     dest? 2drop ;
                     96: 
1.1       anton      97: : cs-push-part ( -- list addr )
1.3       pazsan     98:  locals-list @ here ;
1.1       anton      99: 
                    100: : cs-push-orig ( -- orig )
                    101:  cs-push-part dead-code @
                    102:  if
                    103:    dead-orig
                    104:  else
                    105:    live-orig
                    106:  then ;   
                    107: 
                    108: \ Structural Conditionals                              12dec92py
                    109: 
1.18      anton     110: defer other-control-flow ( -- )
                    111: \ hook for control-flow stuff that's not handled by begin-like etc.
                    112: 
1.1       anton     113: : ?struc      ( flag -- )       abort" unstructured " ;
                    114: : sys?        ( sys -- )        dup 0= ?struc ;
                    115: : >mark ( -- orig )
1.18      anton     116:  cs-push-orig 0 , other-control-flow ;
1.11      anton     117: : >resolve    ( addr -- )
1.13      anton     118:     here swap !
1.12      anton     119:     basic-block-end ;
1.13      anton     120: : <resolve    ( addr -- )        , ;
1.1       anton     121: 
                    122: : BUT
                    123:     1 cs-roll ;                      immediate restrict
                    124: : YET
                    125:     0 cs-pick ;                       immediate restrict
                    126: 
                    127: \ Structural Conditionals                              12dec92py
                    128: 
                    129: : AHEAD ( compilation -- orig ; run-time -- ) \ tools-ext
1.14      pazsan    130:     POSTPONE branch  >mark  POSTPONE unreachable ; immediate restrict
1.1       anton     131: 
                    132: : IF ( compilation -- orig ; run-time f -- ) \ core
1.14      pazsan    133:  POSTPONE ?branch >mark ; immediate restrict
1.1       anton     134: 
                    135: : ?DUP-IF ( compilation -- orig ; run-time n -- n| ) \ gforth  question-dupe-if
1.5       crook     136: \G This is the preferred alternative to the idiom "@code{?DUP IF}", since it can be
1.1       anton     137: \G better handled by tools like stack checkers. Besides, it's faster.
1.14      pazsan    138:     POSTPONE ?dup-?branch >mark ;       immediate restrict
1.1       anton     139: 
                    140: : ?DUP-0=-IF ( compilation -- orig ; run-time n -- n| ) \ gforth       question-dupe-zero-equals-if
1.14      pazsan    141:     POSTPONE ?dup-0=-?branch >mark ;       immediate restrict
1.1       anton     142: 
                    143: Defer then-like ( orig -- )
                    144: : cs>addr ( orig/dest -- )  drop >resolve drop ;
                    145: ' cs>addr IS then-like
                    146: 
                    147: : THEN ( compilation orig -- ; run-time -- ) \ core
                    148:     dup orig?  then-like ; immediate restrict
                    149: 
                    150: ' THEN alias ENDIF ( compilation orig -- ; run-time -- ) \ gforth
                    151: immediate restrict
                    152: \ Same as "THEN". This is what you use if your program will be seen by
                    153: \ people who have not been brought up with Forth (or who have been
                    154: \ brought up with fig-Forth).
                    155: 
1.20      anton     156: : ELSE ( compilation orig1 -- orig2 ; run-time -- ) \ core
1.1       anton     157:     POSTPONE ahead
                    158:     1 cs-roll
                    159:     POSTPONE then ; immediate restrict
                    160: 
                    161: Defer begin-like ( -- )
                    162: ' noop IS begin-like
                    163: 
                    164: : BEGIN ( compilation -- dest ; run-time -- ) \ core
1.11      anton     165:     begin-like cs-push-part dest
1.12      anton     166:     basic-block-end ; immediate restrict
1.1       anton     167: 
                    168: Defer again-like ( dest -- addr )
                    169: ' nip IS again-like
                    170: 
                    171: : AGAIN ( compilation dest -- ; run-time -- ) \ core-ext
1.14      pazsan    172:     dest? again-like  POSTPONE branch  <resolve ; immediate restrict
1.1       anton     173: 
1.8       anton     174: Defer until-like ( list addr xt1 xt2 -- )
                    175: :noname ( list addr xt1 xt2 -- )
                    176:     drop compile, <resolve drop ;
                    177: IS until-like
1.1       anton     178: 
                    179: : UNTIL ( compilation dest -- ; run-time f -- ) \ core
1.14      pazsan    180:     dest? ['] ?branch ['] ?branch-lp+!# until-like ; immediate restrict
1.1       anton     181: 
                    182: : WHILE ( compilation dest -- orig dest ; run-time f -- ) \ core
                    183:     POSTPONE if
                    184:     1 cs-roll ; immediate restrict
                    185: 
                    186: : REPEAT ( compilation orig dest -- ; run-time -- ) \ core
                    187:     POSTPONE again
                    188:     POSTPONE then ; immediate restrict
                    189: 
1.27    ! pazsan    190: \ not clear if this should really go into Gforth's kernel...
        !           191: 
        !           192: : CONTINUE ( dest-sys j*sys -- dest-sys j*sys ) \ gforth
        !           193:     \g jump to the next outer BEGIN
        !           194:     depth 0 ?DO  I pick dest = IF
        !           195:            I cs-item-size / cs-pick postpone AGAIN
        !           196:            LEAVE  THEN
        !           197:     cs-item-size +LOOP
        !           198:     true abort" no BEGIN found" ; immediate compile-only
        !           199: 
1.1       anton     200: \ counted loops
                    201: 
                    202: \ leave poses a little problem here
                    203: \ we have to store more than just the address of the branch, so the
                    204: \ traditional linked list approach is no longer viable.
                    205: \ This is solved by storing the information about the leavings in a
                    206: \ special stack.
                    207: 
                    208: \ !! remove the fixed size limit. 'Tis not hard.
                    209: 20 constant leave-stack-size
                    210: create leave-stack  60 cells allot
                    211: Avariable leave-sp  leave-stack 3 cells + leave-sp !
                    212: 
                    213: : clear-leave-stack ( -- )
                    214:     leave-stack leave-sp ! ;
                    215: 
                    216: \ : leave-empty? ( -- f )
                    217: \  leave-sp @ leave-stack = ;
                    218: 
                    219: : >leave ( orig -- )
                    220:     \ push on leave-stack
                    221:     leave-sp @
                    222:     dup [ leave-stack 60 cells + ] Aliteral
                    223:     >= abort" leave-stack full"
                    224:     tuck ! cell+
                    225:     tuck ! cell+
                    226:     tuck ! cell+
                    227:     leave-sp ! ;
                    228: 
                    229: : leave> ( -- orig )
                    230:     \ pop from leave-stack
                    231:     leave-sp @
                    232:     dup leave-stack <= IF
                    233:        drop 0 0 0  EXIT  THEN
                    234:     cell - dup @ swap
                    235:     cell - dup @ swap
                    236:     cell - dup @ swap
                    237:     leave-sp ! ;
                    238: 
                    239: : DONE ( compilation orig -- ; run-time -- ) \ gforth
1.23      pazsan    240:     \g resolves all LEAVEs up to the compilaton orig (from a BEGIN)
1.1       anton     241:     drop >r drop
                    242:     begin
                    243:        leave>
                    244:        over r@ u>=
                    245:     while
                    246:        POSTPONE then
                    247:     repeat
                    248:     >leave rdrop ; immediate restrict
                    249: 
                    250: : LEAVE ( compilation -- ; run-time loop-sys -- ) \ core
                    251:     POSTPONE ahead
                    252:     >leave ; immediate restrict
                    253: 
                    254: : ?LEAVE ( compilation -- ; run-time f | f loop-sys -- ) \ gforth      question-leave
                    255:     POSTPONE 0= POSTPONE if
                    256:     >leave ; immediate restrict
                    257: 
                    258: : DO ( compilation -- do-sys ; run-time w1 w2 -- loop-sys ) \ core
                    259:     POSTPONE (do)
                    260:     POSTPONE begin drop do-dest
                    261:     ( 0 0 0 >leave ) ; immediate restrict
                    262: 
                    263: : ?do-like ( -- do-sys )
                    264:     ( 0 0 0 >leave )
                    265:     >mark >leave
                    266:     POSTPONE begin drop do-dest ;
                    267: 
                    268: : ?DO ( compilation -- do-sys ; run-time w1 w2 -- | loop-sys ) \ core-ext      question-do
1.14      pazsan    269:     POSTPONE (?do) ?do-like ; immediate restrict
1.1       anton     270: 
                    271: : +DO ( compilation -- do-sys ; run-time n1 n2 -- | loop-sys ) \ gforth        plus-do
1.14      pazsan    272:     POSTPONE (+do) ?do-like ; immediate restrict
1.1       anton     273: 
                    274: : U+DO ( compilation -- do-sys ; run-time u1 u2 -- | loop-sys )        \ gforth        u-plus-do
1.14      pazsan    275:     POSTPONE (u+do) ?do-like ; immediate restrict
1.1       anton     276: 
                    277: : -DO ( compilation -- do-sys ; run-time n1 n2 -- | loop-sys ) \ gforth        minus-do
1.14      pazsan    278:     POSTPONE (-do) ?do-like ; immediate restrict
1.1       anton     279: 
                    280: : U-DO ( compilation -- do-sys ; run-time u1 u2 -- | loop-sys )        \ gforth        u-minus-do
1.14      pazsan    281:     POSTPONE (u-do) ?do-like ; immediate restrict
1.1       anton     282: 
                    283: : FOR ( compilation -- do-sys ; run-time u -- loop-sys )       \ gforth
                    284:     POSTPONE (for)
                    285:     POSTPONE begin drop do-dest
                    286:     ( 0 0 0 >leave ) ; immediate restrict
                    287: 
                    288: \ LOOP etc. are just like UNTIL
                    289: 
                    290: : loop-like ( do-sys xt1 xt2 -- )
                    291:     >r >r 0 cs-pick swap cell - swap 1 cs-roll r> r> rot do-dest?
                    292:     until-like  POSTPONE done  POSTPONE unloop ;
                    293: 
                    294: : LOOP ( compilation do-sys -- ; run-time loop-sys1 -- | loop-sys2 )   \ core
1.14      pazsan    295:  ['] (loop) ['] (loop)-lp+!# loop-like ; immediate restrict
1.1       anton     296: 
                    297: : +LOOP ( compilation do-sys -- ; run-time loop-sys1 n -- | loop-sys2 )        \ core  plus-loop
1.14      pazsan    298:  ['] (+loop) ['] (+loop)-lp+!# loop-like ; immediate restrict
1.1       anton     299: 
                    300: \ !! should the compiler warn about +DO..-LOOP?
                    301: : -LOOP ( compilation do-sys -- ; run-time loop-sys1 u -- | loop-sys2 )        \ gforth        minus-loop
1.14      pazsan    302:  ['] (-loop) ['] (-loop)-lp+!# loop-like ; immediate restrict
1.1       anton     303: 
                    304: \ A symmetric version of "+LOOP". I.e., "-high -low ?DO -inc S+LOOP"
                    305: \ will iterate as often as "high low ?DO inc S+LOOP". For positive
                    306: \ increments it behaves like "+LOOP". Use S+LOOP instead of +LOOP for
                    307: \ negative increments.
                    308: : S+LOOP ( compilation do-sys -- ; run-time loop-sys1 n -- | loop-sys2 )       \ gforth        s-plus-loop
1.14      pazsan    309:  ['] (s+loop) ['] (s+loop)-lp+!# loop-like ; immediate restrict
1.1       anton     310: 
                    311: : NEXT ( compilation do-sys -- ; run-time loop-sys1 -- | loop-sys2 ) \ gforth
1.14      pazsan    312:  ['] (next) ['] (next)-lp+!# loop-like ; immediate restrict
1.1       anton     313: 
                    314: \ Structural Conditionals                              12dec92py
                    315: 
                    316: Defer exit-like ( -- )
                    317: ' noop IS exit-like
                    318: 
                    319: : EXIT ( compilation -- ; run-time nest-sys -- ) \ core
1.12      anton     320: \G Return to the calling definition; usually used as a way of
                    321: \G forcing an early return from a definition. Before
                    322: \G @code{EXIT}ing you must clean up the return stack and
                    323: \G @code{UNLOOP} any outstanding @code{?DO}...@code{LOOP}s.
1.1       anton     324:     exit-like
                    325:     POSTPONE ;s
1.12      anton     326:     basic-block-end
1.1       anton     327:     POSTPONE unreachable ; immediate restrict
                    328: 
                    329: : ?EXIT ( -- ) ( compilation -- ; run-time nest-sys f -- | nest-sys ) \ gforth
                    330:      POSTPONE if POSTPONE exit POSTPONE then ; immediate restrict
                    331: 

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