\ Structural Conditionals 12dec92py \ Copyright (C) 1995-2003 Free Software Foundation, Inc. \ This file is part of Gforth. \ Gforth is free software; you can redistribute it and/or \ modify it under the terms of the GNU General Public License \ as published by the Free Software Foundation; either version 2 \ of the License, or (at your option) any later version. \ This program is distributed in the hope that it will be useful, \ but WITHOUT ANY WARRANTY; without even the implied warranty of \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the \ GNU General Public License for more details. \ You should have received a copy of the GNU General Public License \ along with this program; if not, write to the Free Software \ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA. here 0 , \ just a dummy, the real value of locals-list is patched into it in glocals.fs AConstant locals-list \ acts like a variable that contains \ a linear list of locals names variable dead-code \ true if normal code at "here" would be dead variable backedge-locals \ contains the locals list that BEGIN will assume to be live on \ the back edge if the BEGIN is unreachable from above. Set by \ ASSUME-LIVE, reset by UNREACHABLE. : UNREACHABLE ( -- ) \ gforth \ declares the current point of execution as unreachable dead-code on 0 backedge-locals ! ; immediate : ASSUME-LIVE ( orig -- orig ) \ gforth \ used immediatly before a BEGIN that is not reachable from \ above. causes the BEGIN to assume that the same locals are live \ as at the orig point dup orig? 2 pick backedge-locals ! ; immediate \ Control Flow Stack \ orig, etc. have the following structure: \ type ( defstart, live-orig, dead-orig, dest, do-dest, scopestart) ( TOS ) \ address (of the branch or the instruction to be branched to) (second) \ locals-list (valid at address) (third) \ types [IFUNDEF] defstart 0 constant defstart \ usally defined in comp.fs [THEN] 1 constant live-orig 2 constant dead-orig 3 constant dest \ the loopback branch is always assumed live 4 constant do-dest 5 constant scopestart : def? ( n -- ) defstart <> abort" unstructured " ; : orig? ( n -- ) dup live-orig <> swap dead-orig <> and abort" expected orig " ; : dest? ( n -- ) dest <> abort" expected dest " ; : do-dest? ( n -- ) do-dest <> abort" expected do-dest " ; : scope? ( n -- ) scopestart <> abort" expected scope " ; : non-orig? ( n -- ) dest scopestart 1+ within 0= abort" expected dest, do-dest or scope" ; : cs-item? ( n -- ) live-orig scopestart 1+ within 0= abort" expected control flow stack item" ; 3 constant cs-item-size : CS-PICK ( ... u -- ... destu ) \ tools-ext c-s-pick 1+ cs-item-size * 1- >r r@ pick r@ pick r@ pick rdrop dup non-orig? ; : CS-ROLL ( destu/origu .. dest0/orig0 u -- .. dest0/orig0 destu/origu ) \ tools-ext c-s-roll 1+ cs-item-size * 1- >r r@ roll r@ roll r@ roll rdrop dup cs-item? ; : cs-push-part ( -- list addr ) locals-list @ here ; : cs-push-orig ( -- orig ) cs-push-part dead-code @ if dead-orig else live-orig then ; \ Structural Conditionals 12dec92py : ?struc ( flag -- ) abort" unstructured " ; : sys? ( sys -- ) dup 0= ?struc ; : >mark ( -- orig ) cs-push-orig 0 , ; : >resolve ( addr -- ) here swap ! basic-block-end ; : mark POSTPONE unreachable ; immediate restrict : IF ( compilation -- orig ; run-time f -- ) \ core POSTPONE ?branch >mark ; immediate restrict : ?DUP-IF ( compilation -- orig ; run-time n -- n| ) \ gforth question-dupe-if \G This is the preferred alternative to the idiom "@code{?DUP IF}", since it can be \G better handled by tools like stack checkers. Besides, it's faster. POSTPONE ?dup-?branch >mark ; immediate restrict : ?DUP-0=-IF ( compilation -- orig ; run-time n -- n| ) \ gforth question-dupe-zero-equals-if POSTPONE ?dup-0=-?branch >mark ; immediate restrict Defer then-like ( orig -- ) : cs>addr ( orig/dest -- ) drop >resolve drop ; ' cs>addr IS then-like : THEN ( compilation orig -- ; run-time -- ) \ core dup orig? then-like ; immediate restrict ' THEN alias ENDIF ( compilation orig -- ; run-time -- ) \ gforth immediate restrict \ Same as "THEN". This is what you use if your program will be seen by \ people who have not been brought up with Forth (or who have been \ brought up with fig-Forth). : ELSE ( compilation orig1 -- orig2 ; run-time f -- ) \ core POSTPONE ahead 1 cs-roll POSTPONE then ; immediate restrict Defer begin-like ( -- ) ' noop IS begin-like : BEGIN ( compilation -- dest ; run-time -- ) \ core begin-like cs-push-part dest basic-block-end ; immediate restrict Defer again-like ( dest -- addr ) ' nip IS again-like : AGAIN ( compilation dest -- ; run-time -- ) \ core-ext dest? again-like POSTPONE branch leave ( orig -- ) \ push on leave-stack leave-sp @ dup [ leave-stack 60 cells + ] Aliteral >= abort" leave-stack full" tuck ! cell+ tuck ! cell+ tuck ! cell+ leave-sp ! ; : leave> ( -- orig ) \ pop from leave-stack leave-sp @ dup leave-stack <= IF drop 0 0 0 EXIT THEN cell - dup @ swap cell - dup @ swap cell - dup @ swap leave-sp ! ; : DONE ( compilation orig -- ; run-time -- ) \ gforth \ !! the original done had ( addr -- ) drop >r drop begin leave> over r@ u>= while POSTPONE then repeat >leave rdrop ; immediate restrict : LEAVE ( compilation -- ; run-time loop-sys -- ) \ core POSTPONE ahead >leave ; immediate restrict : ?LEAVE ( compilation -- ; run-time f | f loop-sys -- ) \ gforth question-leave POSTPONE 0= POSTPONE if >leave ; immediate restrict : DO ( compilation -- do-sys ; run-time w1 w2 -- loop-sys ) \ core POSTPONE (do) POSTPONE begin drop do-dest ( 0 0 0 >leave ) ; immediate restrict : ?do-like ( -- do-sys ) ( 0 0 0 >leave ) >mark >leave POSTPONE begin drop do-dest ; : ?DO ( compilation -- do-sys ; run-time w1 w2 -- | loop-sys ) \ core-ext question-do POSTPONE (?do) ?do-like ; immediate restrict : +DO ( compilation -- do-sys ; run-time n1 n2 -- | loop-sys ) \ gforth plus-do POSTPONE (+do) ?do-like ; immediate restrict : U+DO ( compilation -- do-sys ; run-time u1 u2 -- | loop-sys ) \ gforth u-plus-do POSTPONE (u+do) ?do-like ; immediate restrict : -DO ( compilation -- do-sys ; run-time n1 n2 -- | loop-sys ) \ gforth minus-do POSTPONE (-do) ?do-like ; immediate restrict : U-DO ( compilation -- do-sys ; run-time u1 u2 -- | loop-sys ) \ gforth u-minus-do POSTPONE (u-do) ?do-like ; immediate restrict : FOR ( compilation -- do-sys ; run-time u -- loop-sys ) \ gforth POSTPONE (for) POSTPONE begin drop do-dest ( 0 0 0 >leave ) ; immediate restrict \ LOOP etc. are just like UNTIL : loop-like ( do-sys xt1 xt2 -- ) >r >r 0 cs-pick swap cell - swap 1 cs-roll r> r> rot do-dest? until-like POSTPONE done POSTPONE unloop ; : LOOP ( compilation do-sys -- ; run-time loop-sys1 -- | loop-sys2 ) \ core ['] (loop) ['] (loop)-lp+!# loop-like ; immediate restrict : +LOOP ( compilation do-sys -- ; run-time loop-sys1 n -- | loop-sys2 ) \ core plus-loop ['] (+loop) ['] (+loop)-lp+!# loop-like ; immediate restrict \ !! should the compiler warn about +DO..-LOOP? : -LOOP ( compilation do-sys -- ; run-time loop-sys1 u -- | loop-sys2 ) \ gforth minus-loop ['] (-loop) ['] (-loop)-lp+!# loop-like ; immediate restrict \ A symmetric version of "+LOOP". I.e., "-high -low ?DO -inc S+LOOP" \ will iterate as often as "high low ?DO inc S+LOOP". For positive \ increments it behaves like "+LOOP". Use S+LOOP instead of +LOOP for \ negative increments. : S+LOOP ( compilation do-sys -- ; run-time loop-sys1 n -- | loop-sys2 ) \ gforth s-plus-loop ['] (s+loop) ['] (s+loop)-lp+!# loop-like ; immediate restrict : NEXT ( compilation do-sys -- ; run-time loop-sys1 -- | loop-sys2 ) \ gforth ['] (next) ['] (next)-lp+!# loop-like ; immediate restrict \ Structural Conditionals 12dec92py Defer exit-like ( -- ) ' noop IS exit-like : EXIT ( compilation -- ; run-time nest-sys -- ) \ core \G Return to the calling definition; usually used as a way of \G forcing an early return from a definition. Before \G @code{EXIT}ing you must clean up the return stack and \G @code{UNLOOP} any outstanding @code{?DO}...@code{LOOP}s. exit-like POSTPONE ;s basic-block-end POSTPONE unreachable ; immediate restrict : ?EXIT ( -- ) ( compilation -- ; run-time nest-sys f -- | nest-sys ) \ gforth POSTPONE if POSTPONE exit POSTPONE then ; immediate restrict