Annotation of gforth/conditionals.fs, revision 1.3
1.1 pazsan 1: \ Structural Conditionals 12dec92py
2:
1.3 ! pazsan 3: \ Copyright (C) 1995 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., 675 Mass Ave, Cambridge, MA 02139, USA.
! 20:
1.1 pazsan 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: 0 constant defstart
52: 1 constant live-orig
53: 2 constant dead-orig
54: 3 constant dest \ the loopback branch is always assumed live
55: 4 constant do-dest
56: 5 constant scopestart
57:
58: : def? ( n -- )
59: defstart <> abort" unstructured " ;
60:
61: : orig? ( n -- )
62: dup live-orig <> swap dead-orig <> and abort" expected orig " ;
63:
64: : dest? ( n -- )
65: dest <> abort" expected dest " ;
66:
67: : do-dest? ( n -- )
68: do-dest <> abort" expected do-dest " ;
69:
70: : scope? ( n -- )
71: scopestart <> abort" expected scope " ;
72:
73: : non-orig? ( n -- )
74: dest scopestart 1+ within 0= abort" expected dest, do-dest or scope" ;
75:
76: : cs-item? ( n -- )
77: live-orig scopestart 1+ within 0= abort" expected control flow stack item" ;
78:
79: 3 constant cs-item-size
80:
81: : CS-PICK ( ... u -- ... destu ) \ tools-ext
82: 1+ cs-item-size * 1- >r
83: r@ pick r@ pick r@ pick
84: rdrop
85: dup non-orig? ;
86:
87: : CS-ROLL ( destu/origu .. dest0/orig0 u -- .. dest0/orig0 destu/origu ) \ tools-ext
88: 1+ cs-item-size * 1- >r
89: r@ roll r@ roll r@ roll
90: rdrop
91: dup cs-item? ;
92:
93: : cs-push-part ( -- list addr )
94: locals-list @ here ;
95:
96: : cs-push-orig ( -- orig )
97: cs-push-part dead-code @
98: if
99: dead-orig
100: else
101: live-orig
102: then ;
103:
104: \ Structural Conditionals 12dec92py
105:
106: : ?struc ( flag -- ) abort" unstructured " ;
107: : sys? ( sys -- ) dup 0= ?struc ;
108: : >mark ( -- orig )
109: cs-push-orig 0 , ;
110: : >resolve ( addr -- ) here over - swap ! ;
111: : <resolve ( addr -- ) here - , ;
112:
113: : BUT
114: 1 cs-roll ; immediate restrict
115: : YET
116: 0 cs-pick ; immediate restrict
117:
118: \ Structural Conditionals 12dec92py
119:
120: : AHEAD ( compilation -- orig ; run-time -- ) \ tools-ext
121: POSTPONE branch >mark POSTPONE unreachable ; immediate restrict
122:
123: : IF ( compilation -- orig ; run-time f -- ) \ core
124: POSTPONE ?branch >mark ; immediate restrict
125:
126: : ?DUP-IF ( compilation -- orig ; run-time n -- n| ) \ gforth question-dupe-if
127: \G This is the preferred alternative to the idiom "?DUP IF", since it can be
128: \G better handled by tools like stack checkers. Besides, it's faster.
129: POSTPONE ?dup-?branch >mark ; immediate restrict
130:
131: : ?DUP-0=-IF ( compilation -- orig ; run-time n -- n| ) \ gforth question-dupe-zero-equals-if
132: POSTPONE ?dup-0=-?branch >mark ; immediate restrict
133:
1.2 anton 134: Defer then-like ( orig -- )
135: : cs>addr ( orig/dest -- ) drop >resolve drop ;
1.1 pazsan 136: ' cs>addr IS then-like
137:
138: : THEN ( compilation orig -- ; run-time -- ) \ core
1.2 anton 139: dup orig? then-like ; immediate restrict
1.1 pazsan 140:
141: ' THEN alias ENDIF ( compilation orig -- ; run-time -- ) \ gforth
142: immediate restrict
143: \ Same as "THEN". This is what you use if your program will be seen by
144: \ people who have not been brought up with Forth (or who have been
145: \ brought up with fig-Forth).
146:
147: : ELSE ( compilation orig1 -- orig2 ; run-time f -- ) \ core
148: POSTPONE ahead
149: 1 cs-roll
150: POSTPONE then ; immediate restrict
151:
152: Defer begin-like ( -- )
153: ' noop IS begin-like
154:
155: : BEGIN ( compilation -- dest ; run-time -- ) \ core
156: begin-like cs-push-part dest ; immediate restrict
157:
158: Defer again-like ( dest -- addr )
159: ' nip IS again-like
160:
161: : AGAIN ( compilation dest -- ; run-time -- ) \ core-ext
162: dest? again-like POSTPONE branch <resolve ; immediate restrict
163:
164: Defer until-like
165: : until, ( list addr xt1 xt2 -- ) drop compile, <resolve drop ;
166: ' until, IS until-like
167:
168: : UNTIL ( compilation dest -- ; run-time f -- ) \ core
169: dest? ['] ?branch ['] ?branch-lp+!# until-like ; immediate restrict
170:
171: : WHILE ( compilation dest -- orig dest ; run-time f -- ) \ core
172: POSTPONE if
173: 1 cs-roll ; immediate restrict
174:
175: : REPEAT ( compilation orig dest -- ; run-time -- ) \ core
176: POSTPONE again
177: POSTPONE then ; immediate restrict
178:
179: \ counted loops
180:
181: \ leave poses a little problem here
182: \ we have to store more than just the address of the branch, so the
183: \ traditional linked list approach is no longer viable.
184: \ This is solved by storing the information about the leavings in a
185: \ special stack.
186:
187: \ !! remove the fixed size limit. 'Tis not hard.
188: 20 constant leave-stack-size
189: create leave-stack 60 cells allot
190: Avariable leave-sp leave-stack 3 cells + leave-sp !
191:
192: : clear-leave-stack ( -- )
193: leave-stack leave-sp ! ;
194:
195: \ : leave-empty? ( -- f )
196: \ leave-sp @ leave-stack = ;
197:
198: : >leave ( orig -- )
199: \ push on leave-stack
200: leave-sp @
201: dup [ leave-stack 60 cells + ] Aliteral
202: >= abort" leave-stack full"
203: tuck ! cell+
204: tuck ! cell+
205: tuck ! cell+
206: leave-sp ! ;
207:
208: : leave> ( -- orig )
209: \ pop from leave-stack
210: leave-sp @
211: dup leave-stack <= IF
212: drop 0 0 0 EXIT THEN
213: cell - dup @ swap
214: cell - dup @ swap
215: cell - dup @ swap
216: leave-sp ! ;
217:
218: : DONE ( compilation orig -- ; run-time -- ) \ gforth
219: \ !! the original done had ( addr -- )
220: drop >r drop
221: begin
222: leave>
223: over r@ u>=
224: while
225: POSTPONE then
226: repeat
227: >leave rdrop ; immediate restrict
228:
229: : LEAVE ( compilation -- ; run-time loop-sys -- ) \ core
230: POSTPONE ahead
231: >leave ; immediate restrict
232:
233: : ?LEAVE ( compilation -- ; run-time f | f loop-sys -- ) \ gforth question-leave
234: POSTPONE 0= POSTPONE if
235: >leave ; immediate restrict
236:
237: : DO ( compilation -- do-sys ; run-time w1 w2 -- loop-sys ) \ core
238: POSTPONE (do)
239: POSTPONE begin drop do-dest
240: ( 0 0 0 >leave ) ; immediate restrict
241:
242: : ?do-like ( -- do-sys )
243: ( 0 0 0 >leave )
244: >mark >leave
245: POSTPONE begin drop do-dest ;
246:
247: : ?DO ( compilation -- do-sys ; run-time w1 w2 -- | loop-sys ) \ core-ext question-do
248: POSTPONE (?do) ?do-like ; immediate restrict
249:
250: : +DO ( compilation -- do-sys ; run-time n1 n2 -- | loop-sys ) \ gforth plus-do
251: POSTPONE (+do) ?do-like ; immediate restrict
252:
253: : U+DO ( compilation -- do-sys ; run-time u1 u2 -- | loop-sys ) \ gforth u-plus-do
254: POSTPONE (u+do) ?do-like ; immediate restrict
255:
256: : -DO ( compilation -- do-sys ; run-time n1 n2 -- | loop-sys ) \ gforth minus-do
257: POSTPONE (-do) ?do-like ; immediate restrict
258:
259: : U-DO ( compilation -- do-sys ; run-time u1 u2 -- | loop-sys ) \ gforth u-minus-do
260: POSTPONE (u-do) ?do-like ; immediate restrict
261:
262: : FOR ( compilation -- do-sys ; run-time u -- loop-sys ) \ gforth
263: POSTPONE (for)
264: POSTPONE begin drop do-dest
265: ( 0 0 0 >leave ) ; immediate restrict
266:
267: \ LOOP etc. are just like UNTIL
268:
269: : loop-like ( do-sys xt1 xt2 -- )
270: >r >r 0 cs-pick swap cell - swap 1 cs-roll r> r> rot do-dest?
271: until-like POSTPONE done POSTPONE unloop ;
272:
273: : LOOP ( compilation do-sys -- ; run-time loop-sys1 -- | loop-sys2 ) \ core
274: ['] (loop) ['] (loop)-lp+!# loop-like ; immediate restrict
275:
276: : +LOOP ( compilation do-sys -- ; run-time loop-sys1 n -- | loop-sys2 ) \ core plus-loop
277: ['] (+loop) ['] (+loop)-lp+!# loop-like ; immediate restrict
278:
279: \ !! should the compiler warn about +DO..-LOOP?
280: : -LOOP ( compilation do-sys -- ; run-time loop-sys1 u -- | loop-sys2 ) \ gforth minus-loop
281: ['] (-loop) ['] (-loop)-lp+!# loop-like ; immediate restrict
282:
283: \ A symmetric version of "+LOOP". I.e., "-high -low ?DO -inc S+LOOP"
284: \ will iterate as often as "high low ?DO inc S+LOOP". For positive
285: \ increments it behaves like "+LOOP". Use S+LOOP instead of +LOOP for
286: \ negative increments.
287: : S+LOOP ( compilation do-sys -- ; run-time loop-sys1 n -- | loop-sys2 ) \ gforth s-plus-loop
288: ['] (s+loop) ['] (s+loop)-lp+!# loop-like ; immediate restrict
289:
290: : NEXT ( compilation do-sys -- ; run-time loop-sys1 -- | loop-sys2 ) \ gforth
291: ['] (next) ['] (next)-lp+!# loop-like ; immediate restrict
292:
293: \ Structural Conditionals 12dec92py
294:
295: Defer exit-like ( -- )
296: ' noop IS exit-like
297:
298: : EXIT ( compilation -- ; run-time nest-sys -- ) \ core
299: exit-like
300: POSTPONE ;s
301: POSTPONE unreachable ; immediate restrict
302:
303: : ?EXIT ( -- ) ( compilation -- ; run-time nest-sys f -- | nest-sys ) \ gforth
304: POSTPONE if POSTPONE exit POSTPONE then ; immediate restrict
305:
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