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