Annotation of gforth/kernel/cond.fs, revision 1.30
1.1 anton 1: \ Structural Conditionals 12dec92py
2:
1.30 ! anton 3: \ Copyright (C) 1995,1996,1997,2000,2003,2004,2007,2010,2011,2012 Free Software Foundation, Inc.
1.1 anton 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
1.22 anton 9: \ as published by the Free Software Foundation, either version 3
1.1 anton 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
1.22 anton 18: \ along with this program. If not, see http://www.gnu.org/licenses/.
1.1 anton 19:
20: here 0 , \ just a dummy, the real value of locals-list is patched into it in glocals.fs
21: AConstant locals-list \ acts like a variable that contains
22: \ a linear list of locals names
23:
24:
25: variable dead-code \ true if normal code at "here" would be dead
26: variable backedge-locals
27: \ contains the locals list that BEGIN will assume to be live on
28: \ the back edge if the BEGIN is unreachable from above. Set by
29: \ ASSUME-LIVE, reset by UNREACHABLE.
30:
31: : UNREACHABLE ( -- ) \ gforth
32: \ declares the current point of execution as unreachable
33: dead-code on
34: 0 backedge-locals ! ; immediate
35:
36: : ASSUME-LIVE ( orig -- orig ) \ gforth
37: \ used immediatly before a BEGIN that is not reachable from
38: \ above. causes the BEGIN to assume that the same locals are live
39: \ as at the orig point
40: dup orig?
41: 2 pick backedge-locals ! ; immediate
42:
43: \ Control Flow Stack
44: \ orig, etc. have the following structure:
45: \ type ( defstart, live-orig, dead-orig, dest, do-dest, scopestart) ( TOS )
46: \ address (of the branch or the instruction to be branched to) (second)
47: \ locals-list (valid at address) (third)
48:
49: \ types
1.6 jwilke 50: [IFUNDEF] defstart
51: 0 constant defstart \ usally defined in comp.fs
52: [THEN]
1.1 anton 53: 1 constant live-orig
54: 2 constant dead-orig
55: 3 constant dest \ the loopback branch is always assumed live
56: 4 constant do-dest
57: 5 constant scopestart
58:
59: : def? ( n -- )
60: defstart <> abort" unstructured " ;
61:
62: : orig? ( n -- )
63: dup live-orig <> swap dead-orig <> and abort" expected orig " ;
64:
65: : dest? ( n -- )
66: dest <> abort" expected dest " ;
67:
68: : do-dest? ( n -- )
69: do-dest <> abort" expected do-dest " ;
70:
71: : scope? ( n -- )
72: scopestart <> abort" expected scope " ;
73:
74: : non-orig? ( n -- )
75: dest scopestart 1+ within 0= abort" expected dest, do-dest or scope" ;
76:
77: : cs-item? ( n -- )
78: live-orig scopestart 1+ within 0= abort" expected control flow stack item" ;
79:
80: 3 constant cs-item-size
81:
1.7 crook 82: : CS-PICK ( ... u -- ... destu ) \ tools-ext c-s-pick
1.1 anton 83: 1+ cs-item-size * 1- >r
84: r@ pick r@ pick r@ pick
85: rdrop
86: dup non-orig? ;
87:
1.7 crook 88: : CS-ROLL ( destu/origu .. dest0/orig0 u -- .. dest0/orig0 destu/origu ) \ tools-ext c-s-roll
1.1 anton 89: 1+ cs-item-size * 1- >r
90: r@ roll r@ roll r@ roll
91: rdrop
92: dup cs-item? ;
93:
1.25 anton 94: : CS-DROP ( dest -- ) \ gforth
95: dest? 2drop ;
96:
1.1 anton 97: : cs-push-part ( -- list addr )
1.3 pazsan 98: locals-list @ here ;
1.1 anton 99:
100: : cs-push-orig ( -- orig )
101: cs-push-part dead-code @
102: if
103: dead-orig
104: else
105: live-orig
106: then ;
107:
108: \ Structural Conditionals 12dec92py
109:
1.18 anton 110: defer other-control-flow ( -- )
111: \ hook for control-flow stuff that's not handled by begin-like etc.
112:
1.1 anton 113: : ?struc ( flag -- ) abort" unstructured " ;
114: : sys? ( sys -- ) dup 0= ?struc ;
115: : >mark ( -- orig )
1.18 anton 116: cs-push-orig 0 , other-control-flow ;
1.11 anton 117: : >resolve ( addr -- )
1.13 anton 118: here swap !
1.12 anton 119: basic-block-end ;
1.13 anton 120: : <resolve ( addr -- ) , ;
1.1 anton 121:
122: : BUT
123: 1 cs-roll ; immediate restrict
124: : YET
125: 0 cs-pick ; immediate restrict
126:
127: \ Structural Conditionals 12dec92py
128:
129: : AHEAD ( compilation -- orig ; run-time -- ) \ tools-ext
1.14 pazsan 130: POSTPONE branch >mark POSTPONE unreachable ; immediate restrict
1.1 anton 131:
132: : IF ( compilation -- orig ; run-time f -- ) \ core
1.14 pazsan 133: POSTPONE ?branch >mark ; immediate restrict
1.1 anton 134:
135: : ?DUP-IF ( compilation -- orig ; run-time n -- n| ) \ gforth question-dupe-if
1.5 crook 136: \G This is the preferred alternative to the idiom "@code{?DUP IF}", since it can be
1.1 anton 137: \G better handled by tools like stack checkers. Besides, it's faster.
1.14 pazsan 138: POSTPONE ?dup-?branch >mark ; immediate restrict
1.1 anton 139:
140: : ?DUP-0=-IF ( compilation -- orig ; run-time n -- n| ) \ gforth question-dupe-zero-equals-if
1.14 pazsan 141: POSTPONE ?dup-0=-?branch >mark ; immediate restrict
1.1 anton 142:
143: Defer then-like ( orig -- )
144: : cs>addr ( orig/dest -- ) drop >resolve drop ;
145: ' cs>addr IS then-like
146:
147: : THEN ( compilation orig -- ; run-time -- ) \ core
148: dup orig? then-like ; immediate restrict
149:
150: ' THEN alias ENDIF ( compilation orig -- ; run-time -- ) \ gforth
151: immediate restrict
152: \ Same as "THEN". This is what you use if your program will be seen by
153: \ people who have not been brought up with Forth (or who have been
154: \ brought up with fig-Forth).
155:
1.20 anton 156: : ELSE ( compilation orig1 -- orig2 ; run-time -- ) \ core
1.1 anton 157: POSTPONE ahead
158: 1 cs-roll
159: POSTPONE then ; immediate restrict
160:
161: Defer begin-like ( -- )
162: ' noop IS begin-like
163:
164: : BEGIN ( compilation -- dest ; run-time -- ) \ core
1.11 anton 165: begin-like cs-push-part dest
1.12 anton 166: basic-block-end ; immediate restrict
1.1 anton 167:
168: Defer again-like ( dest -- addr )
169: ' nip IS again-like
170:
171: : AGAIN ( compilation dest -- ; run-time -- ) \ core-ext
1.14 pazsan 172: dest? again-like POSTPONE branch <resolve ; immediate restrict
1.1 anton 173:
1.8 anton 174: Defer until-like ( list addr xt1 xt2 -- )
175: :noname ( list addr xt1 xt2 -- )
176: drop compile, <resolve drop ;
177: IS until-like
1.1 anton 178:
179: : UNTIL ( compilation dest -- ; run-time f -- ) \ core
1.14 pazsan 180: dest? ['] ?branch ['] ?branch-lp+!# until-like ; immediate restrict
1.1 anton 181:
182: : WHILE ( compilation dest -- orig dest ; run-time f -- ) \ core
183: POSTPONE if
184: 1 cs-roll ; immediate restrict
185:
186: : REPEAT ( compilation orig dest -- ; run-time -- ) \ core
187: POSTPONE again
188: POSTPONE then ; immediate restrict
189:
1.27 pazsan 190: \ not clear if this should really go into Gforth's kernel...
191:
192: : CONTINUE ( dest-sys j*sys -- dest-sys j*sys ) \ gforth
193: \g jump to the next outer BEGIN
194: depth 0 ?DO I pick dest = IF
195: I cs-item-size / cs-pick postpone AGAIN
1.28 pazsan 196: UNLOOP EXIT THEN
1.27 pazsan 197: cs-item-size +LOOP
1.29 pazsan 198: true abort" no BEGIN found" ; immediate restrict
1.27 pazsan 199:
1.1 anton 200: \ counted loops
201:
202: \ leave poses a little problem here
203: \ we have to store more than just the address of the branch, so the
204: \ traditional linked list approach is no longer viable.
205: \ This is solved by storing the information about the leavings in a
206: \ special stack.
207:
208: \ !! remove the fixed size limit. 'Tis not hard.
209: 20 constant leave-stack-size
210: create leave-stack 60 cells allot
211: Avariable leave-sp leave-stack 3 cells + leave-sp !
212:
213: : clear-leave-stack ( -- )
214: leave-stack leave-sp ! ;
215:
216: \ : leave-empty? ( -- f )
217: \ leave-sp @ leave-stack = ;
218:
219: : >leave ( orig -- )
220: \ push on leave-stack
221: leave-sp @
222: dup [ leave-stack 60 cells + ] Aliteral
223: >= abort" leave-stack full"
224: tuck ! cell+
225: tuck ! cell+
226: tuck ! cell+
227: leave-sp ! ;
228:
229: : leave> ( -- orig )
230: \ pop from leave-stack
231: leave-sp @
232: dup leave-stack <= IF
233: drop 0 0 0 EXIT THEN
234: cell - dup @ swap
235: cell - dup @ swap
236: cell - dup @ swap
237: leave-sp ! ;
238:
239: : DONE ( compilation orig -- ; run-time -- ) \ gforth
1.23 pazsan 240: \g resolves all LEAVEs up to the compilaton orig (from a BEGIN)
1.1 anton 241: drop >r drop
242: begin
243: leave>
244: over r@ u>=
245: while
246: POSTPONE then
247: repeat
248: >leave rdrop ; immediate restrict
249:
250: : LEAVE ( compilation -- ; run-time loop-sys -- ) \ core
251: POSTPONE ahead
252: >leave ; immediate restrict
253:
254: : ?LEAVE ( compilation -- ; run-time f | f loop-sys -- ) \ gforth question-leave
255: POSTPONE 0= POSTPONE if
256: >leave ; immediate restrict
257:
258: : DO ( compilation -- do-sys ; run-time w1 w2 -- loop-sys ) \ core
259: POSTPONE (do)
260: POSTPONE begin drop do-dest
261: ( 0 0 0 >leave ) ; immediate restrict
262:
263: : ?do-like ( -- do-sys )
264: ( 0 0 0 >leave )
265: >mark >leave
266: POSTPONE begin drop do-dest ;
267:
268: : ?DO ( compilation -- do-sys ; run-time w1 w2 -- | loop-sys ) \ core-ext question-do
1.14 pazsan 269: POSTPONE (?do) ?do-like ; immediate restrict
1.1 anton 270:
271: : +DO ( compilation -- do-sys ; run-time n1 n2 -- | loop-sys ) \ gforth plus-do
1.14 pazsan 272: POSTPONE (+do) ?do-like ; immediate restrict
1.1 anton 273:
274: : U+DO ( compilation -- do-sys ; run-time u1 u2 -- | loop-sys ) \ gforth u-plus-do
1.14 pazsan 275: POSTPONE (u+do) ?do-like ; immediate restrict
1.1 anton 276:
277: : -DO ( compilation -- do-sys ; run-time n1 n2 -- | loop-sys ) \ gforth minus-do
1.14 pazsan 278: POSTPONE (-do) ?do-like ; immediate restrict
1.1 anton 279:
280: : U-DO ( compilation -- do-sys ; run-time u1 u2 -- | loop-sys ) \ gforth u-minus-do
1.14 pazsan 281: POSTPONE (u-do) ?do-like ; immediate restrict
1.1 anton 282:
283: : FOR ( compilation -- do-sys ; run-time u -- loop-sys ) \ gforth
284: POSTPONE (for)
285: POSTPONE begin drop do-dest
286: ( 0 0 0 >leave ) ; immediate restrict
287:
288: \ LOOP etc. are just like UNTIL
289:
290: : loop-like ( do-sys xt1 xt2 -- )
291: >r >r 0 cs-pick swap cell - swap 1 cs-roll r> r> rot do-dest?
292: until-like POSTPONE done POSTPONE unloop ;
293:
294: : LOOP ( compilation do-sys -- ; run-time loop-sys1 -- | loop-sys2 ) \ core
1.14 pazsan 295: ['] (loop) ['] (loop)-lp+!# loop-like ; immediate restrict
1.1 anton 296:
297: : +LOOP ( compilation do-sys -- ; run-time loop-sys1 n -- | loop-sys2 ) \ core plus-loop
1.14 pazsan 298: ['] (+loop) ['] (+loop)-lp+!# loop-like ; immediate restrict
1.1 anton 299:
300: \ !! should the compiler warn about +DO..-LOOP?
301: : -LOOP ( compilation do-sys -- ; run-time loop-sys1 u -- | loop-sys2 ) \ gforth minus-loop
1.14 pazsan 302: ['] (-loop) ['] (-loop)-lp+!# loop-like ; immediate restrict
1.1 anton 303:
304: \ A symmetric version of "+LOOP". I.e., "-high -low ?DO -inc S+LOOP"
305: \ will iterate as often as "high low ?DO inc S+LOOP". For positive
306: \ increments it behaves like "+LOOP". Use S+LOOP instead of +LOOP for
307: \ negative increments.
308: : S+LOOP ( compilation do-sys -- ; run-time loop-sys1 n -- | loop-sys2 ) \ gforth s-plus-loop
1.14 pazsan 309: ['] (s+loop) ['] (s+loop)-lp+!# loop-like ; immediate restrict
1.1 anton 310:
311: : NEXT ( compilation do-sys -- ; run-time loop-sys1 -- | loop-sys2 ) \ gforth
1.14 pazsan 312: ['] (next) ['] (next)-lp+!# loop-like ; immediate restrict
1.1 anton 313:
314: \ Structural Conditionals 12dec92py
315:
316: Defer exit-like ( -- )
317: ' noop IS exit-like
318:
319: : EXIT ( compilation -- ; run-time nest-sys -- ) \ core
1.12 anton 320: \G Return to the calling definition; usually used as a way of
321: \G forcing an early return from a definition. Before
322: \G @code{EXIT}ing you must clean up the return stack and
323: \G @code{UNLOOP} any outstanding @code{?DO}...@code{LOOP}s.
1.1 anton 324: exit-like
325: POSTPONE ;s
1.12 anton 326: basic-block-end
1.1 anton 327: POSTPONE unreachable ; immediate restrict
328:
329: : ?EXIT ( -- ) ( compilation -- ; run-time nest-sys f -- | nest-sys ) \ gforth
330: POSTPONE if POSTPONE exit POSTPONE then ; immediate restrict
331:
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