Powered by ViewCVS 1.0-dev
| 1 : | anton | 1.1 | \ Structural Conditionals 12dec92py |
| 2 : | |||
| 3 : | anton | 1.9 | \ Copyright (C) 1995,1996,1997,2000 Free Software Foundation, Inc. |
| 4 : | anton | 1.1 | |
| 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 : | anton | 1.10 | \ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA. |
| 20 : | anton | 1.1 | |
| 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 : | jwilke | 1.6 | [IFUNDEF] defstart |
| 52 : | 0 constant defstart \ usally defined in comp.fs | ||
| 53 : | [THEN] | ||
| 54 : | anton | 1.1 | 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 : | crook | 1.7 | : CS-PICK ( ... u -- ... destu ) \ tools-ext c-s-pick |
| 84 : | anton | 1.1 | 1+ cs-item-size * 1- >r |
| 85 : | r@ pick r@ pick r@ pick | ||
| 86 : | rdrop | ||
| 87 : | dup non-orig? ; | ||
| 88 : | |||
| 89 : | crook | 1.7 | : CS-ROLL ( destu/origu .. dest0/orig0 u -- .. dest0/orig0 destu/origu ) \ tools-ext c-s-roll |
| 90 : | anton | 1.1 | 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 : | pazsan | 1.3 | locals-list @ here ; |
| 97 : | anton | 1.1 | |
| 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 : | anton | 1.11 | : >resolve ( addr -- ) |
| 113 : | here over - swap ! | ||
| 114 : | 0 last-compiled ! ; | ||
| 115 : | anton | 1.1 | : <resolve ( addr -- ) here - , ; |
| 116 : | |||
| 117 : | : BUT | ||
| 118 : | 1 cs-roll ; immediate restrict | ||
| 119 : | : YET | ||
| 120 : | 0 cs-pick ; immediate restrict | ||
| 121 : | |||
| 122 : | \ Structural Conditionals 12dec92py | ||
| 123 : | |||
| 124 : | : AHEAD ( compilation -- orig ; run-time -- ) \ tools-ext | ||
| 125 : | POSTPONE branch >mark POSTPONE unreachable ; immediate restrict | ||
| 126 : | |||
| 127 : | : IF ( compilation -- orig ; run-time f -- ) \ core | ||
| 128 : | POSTPONE ?branch >mark ; immediate restrict | ||
| 129 : | |||
| 130 : | : ?DUP-IF ( compilation -- orig ; run-time n -- n| ) \ gforth question-dupe-if | ||
| 131 : | crook | 1.5 | \G This is the preferred alternative to the idiom "@code{?DUP IF}", since it can be |
| 132 : | anton | 1.1 | \G better handled by tools like stack checkers. Besides, it's faster. |
| 133 : | POSTPONE ?dup-?branch >mark ; immediate restrict | ||
| 134 : | |||
| 135 : | : ?DUP-0=-IF ( compilation -- orig ; run-time n -- n| ) \ gforth question-dupe-zero-equals-if | ||
| 136 : | POSTPONE ?dup-0=-?branch >mark ; immediate restrict | ||
| 137 : | |||
| 138 : | Defer then-like ( orig -- ) | ||
| 139 : | : cs>addr ( orig/dest -- ) drop >resolve drop ; | ||
| 140 : | ' cs>addr IS then-like | ||
| 141 : | |||
| 142 : | : THEN ( compilation orig -- ; run-time -- ) \ core | ||
| 143 : | dup orig? then-like ; immediate restrict | ||
| 144 : | |||
| 145 : | ' THEN alias ENDIF ( compilation orig -- ; run-time -- ) \ gforth | ||
| 146 : | immediate restrict | ||
| 147 : | \ Same as "THEN". This is what you use if your program will be seen by | ||
| 148 : | \ people who have not been brought up with Forth (or who have been | ||
| 149 : | \ brought up with fig-Forth). | ||
| 150 : | |||
| 151 : | : ELSE ( compilation orig1 -- orig2 ; run-time f -- ) \ core | ||
| 152 : | POSTPONE ahead | ||
| 153 : | 1 cs-roll | ||
| 154 : | POSTPONE then ; immediate restrict | ||
| 155 : | |||
| 156 : | Defer begin-like ( -- ) | ||
| 157 : | ' noop IS begin-like | ||
| 158 : | |||
| 159 : | : BEGIN ( compilation -- dest ; run-time -- ) \ core | ||
| 160 : | anton | 1.11 | begin-like cs-push-part dest |
| 161 : | 0 last-compiled ! ; immediate restrict | ||
| 162 : | anton | 1.1 | |
| 163 : | Defer again-like ( dest -- addr ) | ||
| 164 : | ' nip IS again-like | ||
| 165 : | |||
| 166 : | : AGAIN ( compilation dest -- ; run-time -- ) \ core-ext | ||
| 167 : | dest? again-like POSTPONE branch <resolve ; immediate restrict | ||
| 168 : | |||
| 169 : | anton | 1.8 | Defer until-like ( list addr xt1 xt2 -- ) |
| 170 : | :noname ( list addr xt1 xt2 -- ) | ||
| 171 : | drop compile, <resolve drop ; | ||
| 172 : | IS until-like | ||
| 173 : | anton | 1.1 | |
| 174 : | : UNTIL ( compilation dest -- ; run-time f -- ) \ core | ||
| 175 : | dest? ['] ?branch ['] ?branch-lp+!# until-like ; immediate restrict | ||
| 176 : | |||
| 177 : | : WHILE ( compilation dest -- orig dest ; run-time f -- ) \ core | ||
| 178 : | POSTPONE if | ||
| 179 : | 1 cs-roll ; immediate restrict | ||
| 180 : | |||
| 181 : | : REPEAT ( compilation orig dest -- ; run-time -- ) \ core | ||
| 182 : | POSTPONE again | ||
| 183 : | POSTPONE then ; immediate restrict | ||
| 184 : | |||
| 185 : | \ counted loops | ||
| 186 : | |||
| 187 : | \ leave poses a little problem here | ||
| 188 : | \ we have to store more than just the address of the branch, so the | ||
| 189 : | \ traditional linked list approach is no longer viable. | ||
| 190 : | \ This is solved by storing the information about the leavings in a | ||
| 191 : | \ special stack. | ||
| 192 : | |||
| 193 : | \ !! remove the fixed size limit. 'Tis not hard. | ||
| 194 : | 20 constant leave-stack-size | ||
| 195 : | create leave-stack 60 cells allot | ||
| 196 : | Avariable leave-sp leave-stack 3 cells + leave-sp ! | ||
| 197 : | |||
| 198 : | : clear-leave-stack ( -- ) | ||
| 199 : | leave-stack leave-sp ! ; | ||
| 200 : | |||
| 201 : | \ : leave-empty? ( -- f ) | ||
| 202 : | \ leave-sp @ leave-stack = ; | ||
| 203 : | |||
| 204 : | : >leave ( orig -- ) | ||
| 205 : | \ push on leave-stack | ||
| 206 : | leave-sp @ | ||
| 207 : | dup [ leave-stack 60 cells + ] Aliteral | ||
| 208 : | >= abort" leave-stack full" | ||
| 209 : | tuck ! cell+ | ||
| 210 : | tuck ! cell+ | ||
| 211 : | tuck ! cell+ | ||
| 212 : | leave-sp ! ; | ||
| 213 : | |||
| 214 : | : leave> ( -- orig ) | ||
| 215 : | \ pop from leave-stack | ||
| 216 : | leave-sp @ | ||
| 217 : | dup leave-stack <= IF | ||
| 218 : | drop 0 0 0 EXIT THEN | ||
| 219 : | cell - dup @ swap | ||
| 220 : | cell - dup @ swap | ||
| 221 : | cell - dup @ swap | ||
| 222 : | leave-sp ! ; | ||
| 223 : | |||
| 224 : | : DONE ( compilation orig -- ; run-time -- ) \ gforth | ||
| 225 : | \ !! the original done had ( addr -- ) | ||
| 226 : | drop >r drop | ||
| 227 : | begin | ||
| 228 : | leave> | ||
| 229 : | over r@ u>= | ||
| 230 : | while | ||
| 231 : | POSTPONE then | ||
| 232 : | repeat | ||
| 233 : | >leave rdrop ; immediate restrict | ||
| 234 : | |||
| 235 : | : LEAVE ( compilation -- ; run-time loop-sys -- ) \ core | ||
| 236 : | POSTPONE ahead | ||
| 237 : | >leave ; immediate restrict | ||
| 238 : | |||
| 239 : | : ?LEAVE ( compilation -- ; run-time f | f loop-sys -- ) \ gforth question-leave | ||
| 240 : | POSTPONE 0= POSTPONE if | ||
| 241 : | >leave ; immediate restrict | ||
| 242 : | |||
| 243 : | : DO ( compilation -- do-sys ; run-time w1 w2 -- loop-sys ) \ core | ||
| 244 : | POSTPONE (do) | ||
| 245 : | POSTPONE begin drop do-dest | ||
| 246 : | ( 0 0 0 >leave ) ; immediate restrict | ||
| 247 : | |||
| 248 : | : ?do-like ( -- do-sys ) | ||
| 249 : | ( 0 0 0 >leave ) | ||
| 250 : | >mark >leave | ||
| 251 : | POSTPONE begin drop do-dest ; | ||
| 252 : | |||
| 253 : | : ?DO ( compilation -- do-sys ; run-time w1 w2 -- | loop-sys ) \ core-ext question-do | ||
| 254 : | POSTPONE (?do) ?do-like ; immediate restrict | ||
| 255 : | |||
| 256 : | : +DO ( compilation -- do-sys ; run-time n1 n2 -- | loop-sys ) \ gforth plus-do | ||
| 257 : | POSTPONE (+do) ?do-like ; immediate restrict | ||
| 258 : | |||
| 259 : | : U+DO ( compilation -- do-sys ; run-time u1 u2 -- | loop-sys ) \ gforth u-plus-do | ||
| 260 : | POSTPONE (u+do) ?do-like ; immediate restrict | ||
| 261 : | |||
| 262 : | : -DO ( compilation -- do-sys ; run-time n1 n2 -- | loop-sys ) \ gforth minus-do | ||
| 263 : | POSTPONE (-do) ?do-like ; immediate restrict | ||
| 264 : | |||
| 265 : | : U-DO ( compilation -- do-sys ; run-time u1 u2 -- | loop-sys ) \ gforth u-minus-do | ||
| 266 : | POSTPONE (u-do) ?do-like ; immediate restrict | ||
| 267 : | |||
| 268 : | : FOR ( compilation -- do-sys ; run-time u -- loop-sys ) \ gforth | ||
| 269 : | POSTPONE (for) | ||
| 270 : | POSTPONE begin drop do-dest | ||
| 271 : | ( 0 0 0 >leave ) ; immediate restrict | ||
| 272 : | |||
| 273 : | \ LOOP etc. are just like UNTIL | ||
| 274 : | |||
| 275 : | : loop-like ( do-sys xt1 xt2 -- ) | ||
| 276 : | >r >r 0 cs-pick swap cell - swap 1 cs-roll r> r> rot do-dest? | ||
| 277 : | until-like POSTPONE done POSTPONE unloop ; | ||
| 278 : | |||
| 279 : | : LOOP ( compilation do-sys -- ; run-time loop-sys1 -- | loop-sys2 ) \ core | ||
| 280 : | ['] (loop) ['] (loop)-lp+!# loop-like ; immediate restrict | ||
| 281 : | |||
| 282 : | : +LOOP ( compilation do-sys -- ; run-time loop-sys1 n -- | loop-sys2 ) \ core plus-loop | ||
| 283 : | ['] (+loop) ['] (+loop)-lp+!# loop-like ; immediate restrict | ||
| 284 : | |||
| 285 : | \ !! should the compiler warn about +DO..-LOOP? | ||
| 286 : | : -LOOP ( compilation do-sys -- ; run-time loop-sys1 u -- | loop-sys2 ) \ gforth minus-loop | ||
| 287 : | ['] (-loop) ['] (-loop)-lp+!# loop-like ; immediate restrict | ||
| 288 : | |||
| 289 : | \ A symmetric version of "+LOOP". I.e., "-high -low ?DO -inc S+LOOP" | ||
| 290 : | \ will iterate as often as "high low ?DO inc S+LOOP". For positive | ||
| 291 : | \ increments it behaves like "+LOOP". Use S+LOOP instead of +LOOP for | ||
| 292 : | \ negative increments. | ||
| 293 : | : S+LOOP ( compilation do-sys -- ; run-time loop-sys1 n -- | loop-sys2 ) \ gforth s-plus-loop | ||
| 294 : | ['] (s+loop) ['] (s+loop)-lp+!# loop-like ; immediate restrict | ||
| 295 : | |||
| 296 : | : NEXT ( compilation do-sys -- ; run-time loop-sys1 -- | loop-sys2 ) \ gforth | ||
| 297 : | ['] (next) ['] (next)-lp+!# loop-like ; immediate restrict | ||
| 298 : | |||
| 299 : | \ Structural Conditionals 12dec92py | ||
| 300 : | |||
| 301 : | Defer exit-like ( -- ) | ||
| 302 : | ' noop IS exit-like | ||
| 303 : | |||
| 304 : | : EXIT ( compilation -- ; run-time nest-sys -- ) \ core | ||
| 305 : | crook | 1.5 | \G Return to the calling definition; usually used as a way of |
| 306 : | \G forcing an early return from a definition. Before | ||
| 307 : | \G @code{EXIT}ing you must clean up the return stack and | ||
| 308 : | \G @code{UNLOOP} any outstanding @code{?DO}...@code{LOOP}s. | ||
| 309 : | anton | 1.1 | exit-like |
| 310 : | POSTPONE ;s | ||
| 311 : | POSTPONE unreachable ; immediate restrict | ||
| 312 : | |||
| 313 : | : ?EXIT ( -- ) ( compilation -- ; run-time nest-sys f -- | nest-sys ) \ gforth | ||
| 314 : | POSTPONE if POSTPONE exit POSTPONE then ; immediate restrict | ||
| 315 : |
|
CVS Admin Powered by ViewCVS 1.0-dev |
ViewCVS and CVS Help |