Return to cond.fs CVS log

Up to [gforth] / gforth / kernel

Moved defstart.

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