1: \ TOOLSEXT.FS [IF] [ELSE] [THEN] and more 20may93jaw
2:
3: \ This here is fully ans compatible
4: \ May be cross-compiled
5:
6: \ ( \ added 09jun93jaw
7:
8: \ very close to dpANS5
9:
10: decimal
11:
12: CREATE Opennest 7 chars allot
13: CREATE Closenest 7 chars allot
14:
15: : SKIPNEST
16: 1 BEGIN
17: BEGIN name count dup WHILE
18: 2dup Opennest count compare 0=
19: IF 2drop 1+
20: ELSE Closenest count compare 0= IF 1- THEN
21: THEN
22: ?dup 0= ?EXIT
23: REPEAT
24: 2drop refill 0=
25: UNTIL drop ;
26:
27: \ : ( s" (" Opennest place
28: \ s" )" Closenest place
29: \ SKIPNEST ; immediate
30:
31: : comment? ( c-addr u -- c-addr u )
32: 2dup s" (" compare 0=
33: IF postpone (
34: ELSE 2dup s" \" compare 0= IF postpone \ THEN
35: THEN ;
36:
37: : [ELSE]
38: 1 BEGIN
39: BEGIN name count dup WHILE
40: comment?
41: 2dup s" [IF]" compare 0=
42: IF 2drop 1+
43: ELSE 2dup s" [ELSE]" compare 0=
44: IF 2drop 1- dup IF 1+ THEN
45: ELSE s" [THEN]" compare 0= IF 1- THEN
46: THEN
47: THEN
48: ?dup 0= ?EXIT
49: REPEAT
50: 2drop refill 0=
51: UNTIL drop ; immediate
52:
53: : [THEN] ( -- ) ; immediate
54:
55: : [IF] ( flag -- )
56: 0= IF postpone [ELSE] THEN ; immediate
57:
58: \ [IFUNDEF] [IFDEF] 9may93jaw
59:
60: : [IFUNDEF]
61: name find nip 0= postpone [IF] ; immediate
62: : [IFDEF]
63: name find nip 0<> postpone [IF] ; immediate
64:
65:
66: \ [IF]? 9jun93jaw
67:
68: \ same as comment? but skips [IF] .... [THEN]
69:
70: : [if]? ( c-addr u -- c-addr u )
71: 2dup s" [IF]" compare 0= >r
72: 2dup s" [ELSE]" compare 0= >r
73: 2dup s" [IFUNDEF]" compare 0= >r
74: 2dup s" [IFDEF]" compare 0= r> or r> or r> or
75: IF s" [IF]" Opennest place
76: s" [THEN]" Closenest place
77: SKIPNEST THEN ;
78:
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>