Annotation of gforth/kernel/cond.fs, revision 1.1
1.1 ! anton 1: \ Structural Conditionals 12dec92py
! 2:
! 3: \ Copyright (C) 1995-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: 0 constant defstart
! 52: 1 constant live-orig
! 53: 2 constant dead-orig
! 54: 3 constant dest \ the loopback branch is always assumed live
! 55: 4 constant do-dest
! 56: 5 constant scopestart
! 57:
! 58: : def? ( n -- )
! 59: defstart <> abort" unstructured " ;
! 60:
! 61: : orig? ( n -- )
! 62: dup live-orig <> swap dead-orig <> and abort" expected orig " ;
! 63:
! 64: : dest? ( n -- )
! 65: dest <> abort" expected dest " ;
! 66:
! 67: : do-dest? ( n -- )
! 68: do-dest <> abort" expected do-dest " ;
! 69:
! 70: : scope? ( n -- )
! 71: scopestart <> abort" expected scope " ;
! 72:
! 73: : non-orig? ( n -- )
! 74: dest scopestart 1+ within 0= abort" expected dest, do-dest or scope" ;
! 75:
! 76: : cs-item? ( n -- )
! 77: live-orig scopestart 1+ within 0= abort" expected control flow stack item" ;
! 78:
! 79: 3 constant cs-item-size
! 80:
! 81: : CS-PICK ( ... u -- ... destu ) \ tools-ext
! 82: 1+ cs-item-size * 1- >r
! 83: r@ pick r@ pick r@ pick
! 84: rdrop
! 85: dup non-orig? ;
! 86:
! 87: : CS-ROLL ( destu/origu .. dest0/orig0 u -- .. dest0/orig0 destu/origu ) \ tools-ext
! 88: 1+ cs-item-size * 1- >r
! 89: r@ roll r@ roll r@ roll
! 90: rdrop
! 91: dup cs-item? ;
! 92:
! 93: : cs-push-part ( -- list addr )
! 94: locals-list @ here ;
! 95:
! 96: : cs-push-orig ( -- orig )
! 97: cs-push-part dead-code @
! 98: if
! 99: dead-orig
! 100: else
! 101: live-orig
! 102: then ;
! 103:
! 104: \ Structural Conditionals 12dec92py
! 105:
! 106: : ?struc ( flag -- ) abort" unstructured " ;
! 107: : sys? ( sys -- ) dup 0= ?struc ;
! 108: : >mark ( -- orig )
! 109: cs-push-orig 0 , ;
! 110: : >resolve ( addr -- ) here over - swap ! ;
! 111: : <resolve ( addr -- ) here - , ;
! 112:
! 113: : BUT
! 114: 1 cs-roll ; immediate restrict
! 115: : YET
! 116: 0 cs-pick ; immediate restrict
! 117:
! 118: \ Structural Conditionals 12dec92py
! 119:
! 120: : AHEAD ( compilation -- orig ; run-time -- ) \ tools-ext
! 121: POSTPONE branch >mark POSTPONE unreachable ; immediate restrict
! 122:
! 123: : IF ( compilation -- orig ; run-time f -- ) \ core
! 124: POSTPONE ?branch >mark ; immediate restrict
! 125:
! 126: : ?DUP-IF ( compilation -- orig ; run-time n -- n| ) \ gforth question-dupe-if
! 127: \G This is the preferred alternative to the idiom "?DUP IF", since it can be
! 128: \G better handled by tools like stack checkers. Besides, it's faster.
! 129: POSTPONE ?dup-?branch >mark ; immediate restrict
! 130:
! 131: : ?DUP-0=-IF ( compilation -- orig ; run-time n -- n| ) \ gforth question-dupe-zero-equals-if
! 132: POSTPONE ?dup-0=-?branch >mark ; immediate restrict
! 133:
! 134: Defer then-like ( orig -- )
! 135: : cs>addr ( orig/dest -- ) drop >resolve drop ;
! 136: ' cs>addr IS then-like
! 137:
! 138: : THEN ( compilation orig -- ; run-time -- ) \ core
! 139: dup orig? then-like ; immediate restrict
! 140:
! 141: ' THEN alias ENDIF ( compilation orig -- ; run-time -- ) \ gforth
! 142: immediate restrict
! 143: \ Same as "THEN". This is what you use if your program will be seen by
! 144: \ people who have not been brought up with Forth (or who have been
! 145: \ brought up with fig-Forth).
! 146:
! 147: : ELSE ( compilation orig1 -- orig2 ; run-time f -- ) \ core
! 148: POSTPONE ahead
! 149: 1 cs-roll
! 150: POSTPONE then ; immediate restrict
! 151:
! 152: Defer begin-like ( -- )
! 153: ' noop IS begin-like
! 154:
! 155: : BEGIN ( compilation -- dest ; run-time -- ) \ core
! 156: begin-like cs-push-part dest ; immediate restrict
! 157:
! 158: Defer again-like ( dest -- addr )
! 159: ' nip IS again-like
! 160:
! 161: : AGAIN ( compilation dest -- ; run-time -- ) \ core-ext
! 162: dest? again-like POSTPONE branch <resolve ; immediate restrict
! 163:
! 164: Defer until-like
! 165: : until, ( list addr xt1 xt2 -- ) drop compile, <resolve drop ;
! 166: ' until, IS until-like
! 167:
! 168: : UNTIL ( compilation dest -- ; run-time f -- ) \ core
! 169: dest? ['] ?branch ['] ?branch-lp+!# until-like ; immediate restrict
! 170:
! 171: : WHILE ( compilation dest -- orig dest ; run-time f -- ) \ core
! 172: POSTPONE if
! 173: 1 cs-roll ; immediate restrict
! 174:
! 175: : REPEAT ( compilation orig dest -- ; run-time -- ) \ core
! 176: POSTPONE again
! 177: POSTPONE then ; immediate restrict
! 178:
! 179: \ counted loops
! 180:
! 181: \ leave poses a little problem here
! 182: \ we have to store more than just the address of the branch, so the
! 183: \ traditional linked list approach is no longer viable.
! 184: \ This is solved by storing the information about the leavings in a
! 185: \ special stack.
! 186:
! 187: \ !! remove the fixed size limit. 'Tis not hard.
! 188: 20 constant leave-stack-size
! 189: create leave-stack 60 cells allot
! 190: Avariable leave-sp leave-stack 3 cells + leave-sp !
! 191:
! 192: : clear-leave-stack ( -- )
! 193: leave-stack leave-sp ! ;
! 194:
! 195: \ : leave-empty? ( -- f )
! 196: \ leave-sp @ leave-stack = ;
! 197:
! 198: : >leave ( orig -- )
! 199: \ push on leave-stack
! 200: leave-sp @
! 201: dup [ leave-stack 60 cells + ] Aliteral
! 202: >= abort" leave-stack full"
! 203: tuck ! cell+
! 204: tuck ! cell+
! 205: tuck ! cell+
! 206: leave-sp ! ;
! 207:
! 208: : leave> ( -- orig )
! 209: \ pop from leave-stack
! 210: leave-sp @
! 211: dup leave-stack <= IF
! 212: drop 0 0 0 EXIT THEN
! 213: cell - dup @ swap
! 214: cell - dup @ swap
! 215: cell - dup @ swap
! 216: leave-sp ! ;
! 217:
! 218: : DONE ( compilation orig -- ; run-time -- ) \ gforth
! 219: \ !! the original done had ( addr -- )
! 220: drop >r drop
! 221: begin
! 222: leave>
! 223: over r@ u>=
! 224: while
! 225: POSTPONE then
! 226: repeat
! 227: >leave rdrop ; immediate restrict
! 228:
! 229: : LEAVE ( compilation -- ; run-time loop-sys -- ) \ core
! 230: POSTPONE ahead
! 231: >leave ; immediate restrict
! 232:
! 233: : ?LEAVE ( compilation -- ; run-time f | f loop-sys -- ) \ gforth question-leave
! 234: POSTPONE 0= POSTPONE if
! 235: >leave ; immediate restrict
! 236:
! 237: : DO ( compilation -- do-sys ; run-time w1 w2 -- loop-sys ) \ core
! 238: POSTPONE (do)
! 239: POSTPONE begin drop do-dest
! 240: ( 0 0 0 >leave ) ; immediate restrict
! 241:
! 242: : ?do-like ( -- do-sys )
! 243: ( 0 0 0 >leave )
! 244: >mark >leave
! 245: POSTPONE begin drop do-dest ;
! 246:
! 247: : ?DO ( compilation -- do-sys ; run-time w1 w2 -- | loop-sys ) \ core-ext question-do
! 248: POSTPONE (?do) ?do-like ; immediate restrict
! 249:
! 250: : +DO ( compilation -- do-sys ; run-time n1 n2 -- | loop-sys ) \ gforth plus-do
! 251: POSTPONE (+do) ?do-like ; immediate restrict
! 252:
! 253: : U+DO ( compilation -- do-sys ; run-time u1 u2 -- | loop-sys ) \ gforth u-plus-do
! 254: POSTPONE (u+do) ?do-like ; immediate restrict
! 255:
! 256: : -DO ( compilation -- do-sys ; run-time n1 n2 -- | loop-sys ) \ gforth minus-do
! 257: POSTPONE (-do) ?do-like ; immediate restrict
! 258:
! 259: : U-DO ( compilation -- do-sys ; run-time u1 u2 -- | loop-sys ) \ gforth u-minus-do
! 260: POSTPONE (u-do) ?do-like ; immediate restrict
! 261:
! 262: : FOR ( compilation -- do-sys ; run-time u -- loop-sys ) \ gforth
! 263: POSTPONE (for)
! 264: POSTPONE begin drop do-dest
! 265: ( 0 0 0 >leave ) ; immediate restrict
! 266:
! 267: \ LOOP etc. are just like UNTIL
! 268:
! 269: : loop-like ( do-sys xt1 xt2 -- )
! 270: >r >r 0 cs-pick swap cell - swap 1 cs-roll r> r> rot do-dest?
! 271: until-like POSTPONE done POSTPONE unloop ;
! 272:
! 273: : LOOP ( compilation do-sys -- ; run-time loop-sys1 -- | loop-sys2 ) \ core
! 274: ['] (loop) ['] (loop)-lp+!# loop-like ; immediate restrict
! 275:
! 276: : +LOOP ( compilation do-sys -- ; run-time loop-sys1 n -- | loop-sys2 ) \ core plus-loop
! 277: ['] (+loop) ['] (+loop)-lp+!# loop-like ; immediate restrict
! 278:
! 279: \ !! should the compiler warn about +DO..-LOOP?
! 280: : -LOOP ( compilation do-sys -- ; run-time loop-sys1 u -- | loop-sys2 ) \ gforth minus-loop
! 281: ['] (-loop) ['] (-loop)-lp+!# loop-like ; immediate restrict
! 282:
! 283: \ A symmetric version of "+LOOP". I.e., "-high -low ?DO -inc S+LOOP"
! 284: \ will iterate as often as "high low ?DO inc S+LOOP". For positive
! 285: \ increments it behaves like "+LOOP". Use S+LOOP instead of +LOOP for
! 286: \ negative increments.
! 287: : S+LOOP ( compilation do-sys -- ; run-time loop-sys1 n -- | loop-sys2 ) \ gforth s-plus-loop
! 288: ['] (s+loop) ['] (s+loop)-lp+!# loop-like ; immediate restrict
! 289:
! 290: : NEXT ( compilation do-sys -- ; run-time loop-sys1 -- | loop-sys2 ) \ gforth
! 291: ['] (next) ['] (next)-lp+!# loop-like ; immediate restrict
! 292:
! 293: \ Structural Conditionals 12dec92py
! 294:
! 295: Defer exit-like ( -- )
! 296: ' noop IS exit-like
! 297:
! 298: : EXIT ( compilation -- ; run-time nest-sys -- ) \ core
! 299: exit-like
! 300: POSTPONE ;s
! 301: POSTPONE unreachable ; immediate restrict
! 302:
! 303: : ?EXIT ( -- ) ( compilation -- ; run-time nest-sys f -- | nest-sys ) \ gforth
! 304: POSTPONE if POSTPONE exit POSTPONE then ; immediate restrict
! 305:
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to cond.fs CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [gforth] / gforth / kernel