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