File:  [gforth] / gforth / kernel / cond.fs
Revision 1.30: download - view: text, annotated - select for diffs
Mon Dec 31 15:25:19 2012 UTC (9 years, 11 months ago) by anton
Branches: MAIN
CVS tags: HEAD
updated copyright year

    1: \ Structural Conditionals                              12dec92py
    2: 
    3: \ Copyright (C) 1995,1996,1997,2000,2003,2004,2007,2010,2011,2012 Free Software Foundation, Inc.
    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
    9: \ as published by the Free Software Foundation, either version 3
   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
   18: \ along with this program. If not, see http://www.gnu.org/licenses/.
   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
   50: [IFUNDEF] defstart 
   51: 0 constant defstart	\ usally defined in comp.fs
   52: [THEN]
   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: 
   82: : CS-PICK ( ... u -- ... destu ) \ tools-ext c-s-pick
   83:  1+ cs-item-size * 1- >r
   84:  r@ pick  r@ pick  r@ pick
   85:  rdrop
   86:  dup non-orig? ;
   87: 
   88: : CS-ROLL ( destu/origu .. dest0/orig0 u -- .. dest0/orig0 destu/origu ) \ tools-ext c-s-roll
   89:  1+ cs-item-size * 1- >r
   90:  r@ roll r@ roll r@ roll
   91:  rdrop
   92:  dup cs-item? ; 
   93: 
   94: : CS-DROP ( dest -- ) \ gforth
   95:     dest? 2drop ;
   96: 
   97: : cs-push-part ( -- list addr )
   98:  locals-list @ here ;
   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: 
  110: defer other-control-flow ( -- )
  111: \ hook for control-flow stuff that's not handled by begin-like etc.
  112: 
  113: : ?struc      ( flag -- )       abort" unstructured " ;
  114: : sys?        ( sys -- )        dup 0= ?struc ;
  115: : >mark ( -- orig )
  116:  cs-push-orig 0 , other-control-flow ;
  117: : >resolve    ( addr -- )
  118:     here swap !
  119:     basic-block-end ;
  120: : <resolve    ( addr -- )        , ;
  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
  130:     POSTPONE branch  >mark  POSTPONE unreachable ; immediate restrict
  131: 
  132: : IF ( compilation -- orig ; run-time f -- ) \ core
  133:  POSTPONE ?branch >mark ; immediate restrict
  134: 
  135: : ?DUP-IF ( compilation -- orig ; run-time n -- n| ) \ gforth	question-dupe-if
  136: \G This is the preferred alternative to the idiom "@code{?DUP IF}", since it can be
  137: \G better handled by tools like stack checkers. Besides, it's faster.
  138:     POSTPONE ?dup-?branch >mark ;       immediate restrict
  139: 
  140: : ?DUP-0=-IF ( compilation -- orig ; run-time n -- n| ) \ gforth	question-dupe-zero-equals-if
  141:     POSTPONE ?dup-0=-?branch >mark ;       immediate restrict
  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: 
  156: : ELSE ( compilation orig1 -- orig2 ; run-time -- ) \ core
  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
  165:     begin-like cs-push-part dest
  166:     basic-block-end ; immediate restrict
  167: 
  168: Defer again-like ( dest -- addr )
  169: ' nip IS again-like
  170: 
  171: : AGAIN ( compilation dest -- ; run-time -- ) \ core-ext
  172:     dest? again-like  POSTPONE branch  <resolve ; immediate restrict
  173: 
  174: Defer until-like ( list addr xt1 xt2 -- )
  175: :noname ( list addr xt1 xt2 -- )
  176:     drop compile, <resolve drop ;
  177: IS until-like
  178: 
  179: : UNTIL ( compilation dest -- ; run-time f -- ) \ core
  180:     dest? ['] ?branch ['] ?branch-lp+!# until-like ; immediate restrict
  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: 
  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: 	    UNLOOP  EXIT  THEN
  197:     cs-item-size +LOOP
  198:     true abort" no BEGIN found" ; immediate restrict
  199: 
  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
  240:     \g resolves all LEAVEs up to the compilaton orig (from a BEGIN)
  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
  269:     POSTPONE (?do) ?do-like ; immediate restrict
  270: 
  271: : +DO ( compilation -- do-sys ; run-time n1 n2 -- | loop-sys )	\ gforth	plus-do
  272:     POSTPONE (+do) ?do-like ; immediate restrict
  273: 
  274: : U+DO ( compilation -- do-sys ; run-time u1 u2 -- | loop-sys )	\ gforth	u-plus-do
  275:     POSTPONE (u+do) ?do-like ; immediate restrict
  276: 
  277: : -DO ( compilation -- do-sys ; run-time n1 n2 -- | loop-sys )	\ gforth	minus-do
  278:     POSTPONE (-do) ?do-like ; immediate restrict
  279: 
  280: : U-DO ( compilation -- do-sys ; run-time u1 u2 -- | loop-sys )	\ gforth	u-minus-do
  281:     POSTPONE (u-do) ?do-like ; immediate restrict
  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
  295:  ['] (loop) ['] (loop)-lp+!# loop-like ; immediate restrict
  296: 
  297: : +LOOP ( compilation do-sys -- ; run-time loop-sys1 n -- | loop-sys2 )	\ core	plus-loop
  298:  ['] (+loop) ['] (+loop)-lp+!# loop-like ; immediate restrict
  299: 
  300: \ !! should the compiler warn about +DO..-LOOP?
  301: : -LOOP ( compilation do-sys -- ; run-time loop-sys1 u -- | loop-sys2 )	\ gforth	minus-loop
  302:  ['] (-loop) ['] (-loop)-lp+!# loop-like ; immediate restrict
  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
  309:  ['] (s+loop) ['] (s+loop)-lp+!# loop-like ; immediate restrict
  310: 
  311: : NEXT ( compilation do-sys -- ; run-time loop-sys1 -- | loop-sys2 ) \ gforth
  312:  ['] (next) ['] (next)-lp+!# loop-like ; immediate restrict
  313: 
  314: \ Structural Conditionals                              12dec92py
  315: 
  316: Defer exit-like ( -- )
  317: ' noop IS exit-like
  318: 
  319: : EXIT ( compilation -- ; run-time nest-sys -- ) \ core
  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.
  324:     exit-like
  325:     POSTPONE ;s
  326:     basic-block-end
  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>