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