Annotation of gforth/kernel/toolsext.fs, revision 1.6
1.6 ! anton 1: \ Copyright (C) 1995,1998 Free Software Foundation, Inc.
1.1 anton 2:
3: \ This file is part of Gforth.
4:
5: \ Gforth is free software; you can redistribute it and/or
6: \ modify it under the terms of the GNU General Public License
7: \ as published by the Free Software Foundation; either version 2
8: \ of the License, or (at your option) any later version.
9:
10: \ This program is distributed in the hope that it will be useful,
11: \ but WITHOUT ANY WARRANTY; without even the implied warranty of
12: \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13: \ GNU General Public License for more details.
14:
15: \ You should have received a copy of the GNU General Public License
16: \ along with this program; if not, write to the Free Software
17: \ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
18:
1.3 jwilke 19: Warnings off
1.1 anton 20:
21: Variable countif
22:
23: : dummy ; immediate
24: : >exec >r ; restrict ( :-)
25: : scanIF f83find dup 0= IF drop ['] dummy >name THEN ;
26:
1.2 jwilke 27: Create [struct]-search ' scanIF A, ' (reveal) A, ' drop A, ' drop A,
1.5 pazsan 28: Create [struct]-voc [struct]-search A,
29: NIL A, NIL A, NIL A,
1.1 anton 30:
31: : ?if countif @ 0<
32: IF [ [struct]-voc 3 cells + ] ALiteral @ lookup ! THEN ;
33:
34: UNLOCK Tlast @ TNIL Tlast ! LOCK
35: \ last @ 0 last !
36:
37: : [IF] 1 countif +! ?if ; immediate
38: : [THEN] -1 countif +! ?if ; immediate
39: : [ELSE] postpone [THEN] postpone [IF] ;
40: immediate
41: ' [IF] Alias [IFDEF] immediate
42: ' [IF] Alias [IFUNDEF] immediate
43: ' [THEN] Alias [ENDIF] immediate
44: ' [IF] Alias [BEGIN] immediate
45: ' [IF] Alias [WHILE] immediate
46: ' [THEN] Alias [UNTIL] immediate
47: ' [THEN] Alias [AGAIN] immediate
48: ' [IF] Alias [DO] immediate
49: ' [IF] Alias [?DO] immediate
50: ' [THEN] Alias [LOOP] immediate
51: ' [THEN] Alias [+LOOP] immediate
52: : [REPEAT] postpone [AGAIN] postpone [THEN] ;
53: immediate
54: ' ( Alias ( immediate
55: ' \ Alias \ immediate
56:
57: UNLOCK Tlast @ swap Tlast ! LOCK
58: \ last @ swap last !
1.5 pazsan 59: 1 cells - [struct]-voc cell+ !
1.1 anton 60:
61: \ Interpretative Structuren 30apr92py
62:
63: : defined bl word find nip 0<> ; immediate
64: : [IF] 0= IF countif off
65: lookup @ [ [struct]-voc 3 cells + ] ALiteral !
66: [struct]-voc lookup !
67: THEN ; immediate
68: : [IFDEF] postpone defined postpone [IF] ; immediate
69: : [IFUNDEF] postpone defined 0= postpone [IF] ; immediate
70: : [ELSE] 0 postpone [IF] ; immediate
71: : [THEN] ; immediate
72: : [ENDIF] ; immediate
73:
74: \ Structs for interpreter 28nov92py
75:
76: User (i)
77:
78: : [DO] ( start end -- ) >in @ -rot
79: DO I (i) ! dup >r >in ! interpret r> swap +LOOP drop ;
80: immediate
81: : [?DO] 2dup = IF 2drop postpone [ELSE] ELSE postpone [DO] THEN ;
82: immediate
83: : [+LOOP] ( n -- ) rdrop rdrop ; immediate
84: : [LOOP] ( -- ) 1 rdrop rdrop ; immediate
85: : [FOR] ( n -- ) 0 swap postpone [DO] ; immediate
86: : [NEXT] ( n -- ) -1 rdrop rdrop ; immediate
1.4 pazsan 87: :noname (i) @ ;
88: :noname (i) @ postpone Literal ;
89: interpret/compile: [I]
1.1 anton 90: : [BEGIN] >in @ >r BEGIN r@ >in ! interpret UNTIL rdrop ;
91: immediate
92: ' [+LOOP] Alias [UNTIL] immediate
93: : [REPEAT] ( -- ) false rdrop rdrop ; immediate
94: ' [REPEAT] Alias [AGAIN] immediate
95: : [WHILE] ( flag -- )
96: 0= IF postpone [ELSE] true rdrop rdrop 1 countif +! THEN ;
97: immediate
98:
1.3 jwilke 99: Warnings on
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>