1: \ Structural Conditionals, loops no extra (?do) 10May99jaw
2:
3: \ Copyright (C) 1995-1997,1999,2000,2003,2007 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 3
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, see http://www.gnu.org/licenses/.
19:
20: [IFDEF] (?do)
21: cr ." Warning: (?do) is defined, use cloop.fs"
22: [THEN]
23:
24: Variable tleavings 0 tleavings !
25:
26: : DONE ( addr -- )
27: tleavings @
28: BEGIN dup
29: WHILE >r dup r@ cell+ @ \ address of branch
30: u> 0= \ lower than DO?
31: WHILE r@ 2 cells + @ \ branch token
32: branchtoresolve,
33: r@ @ r> free throw
34: REPEAT drop r>
35: THEN
36: tleavings ! drop ; immediate restrict
37:
38: : (leave ( branchtoken -- )
39: 3 cells allocate throw >r
40: here r@ cell+ !
41: r@ 2 cells + !
42: tleavings @ r@ !
43: r> tleavings ! ;
44:
45: : LEAVE branchmark, (leave ; immediate restrict
46: : ?LEAVE compile 0= ?branchmark, (leave ; immediate restrict
47:
48: \ Structural Conditionals 12dec92py
49:
50: \ !!JW ToDo : Move to general tools section
51:
52: : to1 ( x1 x2 xn n -- addr )
53: \G packs n stack elements in a allocated memory region
54: dup dup 1+ cells allocate throw dup >r swap 1+ 0 DO tuck ! cell+ LOOP drop r> ;
55: : 1to ( addr -- x1 x2 xn )
56: \G unpacks the elements saved by to1
57: dup @ swap over cells + swap 0 DO dup @ swap 1 cells - LOOP free throw ;
58:
59: : loop] branchto, dup <resolve 1 cells - compile DONE ;
60:
61: : skiploop] ?dup IF compile THEN THEN ;
62:
63: : DO 0 compile (do) branchtomark, 2 to1 ; immediate restrict
64:
65: : ?DO compile 2dup compile = compile IF
66: compile 2drop compile ELSE
67: compile (do) branchtomark, 2 to1 ; immediate restrict
68:
69: : FOR compile (for) branchtomark, ; immediate restrict
70:
71: : LOOP sys? 1to compile (loop) loop] compile unloop skiploop] ;
72: immediate restrict
73: : +LOOP sys? 1to compile (+loop) loop] compile unloop skiploop] ;
74: immediate restrict
75: : NEXT sys? compile (next) loop] compile unloop ;
76: immediate restrict
77: : EXIT compile ;s ; immediate restrict
78: : ?EXIT postpone IF postpone EXIT postpone THEN ; immediate restrict
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>