gforth/conditionals.fs - view

File: [gforth] / gforth / Attic / conditionals.fs
Revision 1.2: download - view: text, annotated - select for diffs
Tue Mar 4 17:49:47 1997 UTC (26 years, 6 months ago) by anton
Branches: MAIN
CVS tags: HEAD

added double indirect threaded version and making of fully relocatable images.
added gforth-makeimage script for making fully relocatable images.
removed locals bug in if else endif constructs.
added mmap support for machines without MAP_ANON
removed command-line options -c and -o
moved definition of DOES_HANDLER_SIZE from machine.h to forth.h.
added hpux FLUSH_ICACHE in m68k.h
made source words print decimal

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 -- ) 117: : cs>addr ( orig/dest -- ) drop >resolve drop ; 118: ' cs>addr IS then-like 119: 120: : THEN ( compilation orig -- ; run-time -- ) \ core 121: dup orig? then-like ; 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: