1: \ test gforth locals
2:
3: \ Copyright (C) 1995,1996,1997,2000,2003 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:
22: require glocals.fs
23: require debugs.fs
24:
25: : localsinfo \ !! only debugging
26: ." stack: " .s ." locals-size: " locals-size ? ." locals-list"
27: also locals words previous cr ;
28:
29: ." before foo" cr
30: : foo
31: { c: a b c: c d: d }
32: a .
33: b .
34: d type
35: c . cr
36: ;
37:
38: ." before" .s cr
39: lp@ . cr
40: 1 2 3 s" xxx" foo
41: lp@ . cr
42: ." after" .s cr
43:
44:
45: ." xxx" cr
46: .s cr
47: depth . cr
48:
49:
50: ." testing part 2" cr
51:
52: : xxxx
53: [ ." starting xxxx" .s cr ]
54: { f } f
55: if
56: { a b }
57: b a
58: [ ." before else" .s cr ]
59: else
60: [ ." after else" .s cr ]
61: { c d }
62: c d
63: then
64: [ ." locals-size after then:" locals-size @ . cr ]
65: ~~ f ~~ drop
66: [ ." ending xxxx" .s cr ]
67: ;
68:
69: 2 3 1 xxxx . . cr
70: 2 3 0 xxxx . . cr
71: cr cr cr
72:
73: : xxx3
74: begin
75: { a }
76: until
77: a
78: ;
79: ." after xxx3" .s cr cr cr
80:
81: : xxx2
82: [ ." start of xxx2" .s cr ]
83: begin
84: [ ." after begin" .s cr ]
85: { a }
86: [ ." after { a }" .s cr ]
87: 1 while
88: [ ." after while" .s cr ]
89: { b }
90: a b
91: [ ." after a" .s cr ]
92: repeat
93: [ ." after repeat" .s cr
94: also locals words previous cr
95: ]
96: a
97: [ ." end of xxx2" .s cr ]
98: ;
99:
100: : xxx4
101: [ ." before if" localsinfo ]
102: if
103: [ ." after if" localsinfo ]
104: { a }
105: [ ." before begin" localsinfo ]
106: begin
107: [ ." after begin" localsinfo ]
108: [ 1 cs-roll ]
109: [ ." before then" localsinfo ]
110: then
111: { b }
112: until
113: [ ." after until" localsinfo ]
114: ;
115:
116: : xxx5
117: { a }
118: a drop
119: ahead
120: assume-live
121: begin
122: [ ." after begin" localsinfo ]
123: a drop
124: [ 1 cs-roll ]
125: then
126: [ ." after then" localsinfo ]
127: until
128: [ ." after until" localsinfo ]
129: ;
130:
131: ." xxx6 coming up" cr
132: : xxx6
133: [ ." starting xxx6" localsinfo ]
134: if
135: { x }
136: else
137: [ ." after else" localsinfo ]
138: ahead
139: begin
140: [ ." after begin" localsinfo ]
141: [ 2 CS-ROLL ] then
142: [ ." after then" localsinfo ]
143: until
144: then
145: [ ." ending xxx6" localsinfo ]
146: ;
147:
148: ." xxx7 coming up" cr
149: : xxx7
150: { b }
151: do
152: { a }
153: [ ." before loop" localsinfo ]
154: loop
155: [ ." after loop" localsinfo ]
156: ;
157:
158: ." xxx8 coming up" cr
159:
160: : xxx8
161: { b }
162: ?do
163: { a }
164: [ ." before loop" localsinfo ]
165: loop
166: [ ." after loop" localsinfo ]
167: ;
168:
169: ." xxx9 coming up" cr
170: : xxx9
171: { b }
172: do
173: { c }
174: [ ." before ?leave" leave-sp ? leave-stack . cr ]
175: ?leave
176: [ ." after ?leave" leave-sp ? cr ]
177: { a }
178: [ ." before loop" localsinfo ]
179: loop
180: [ ." after loop" localsinfo ]
181: ;
182:
183: ." strcmp coming up" cr
184: : strcmp { addr1 u1 addr2 u2 -- n }
185: addr1 addr2 u1 u2 min 0 ?do
186: { s1 s2 }
187: s1 c@ s2 c@ - ?dup if
188: unloop exit
189: then
190: s1 char+ s2 char+
191: loop
192: 2drop
193: u1 u2 - ;
194:
195: : teststrcmp
196: ." lp@:" lp@ . cr
197: s" xxx" s" yyy" strcmp . cr
198: ." lp@:" lp@ . cr
199: s" xxx" s" xxx" strcmp . cr
200: ." lp@:" lp@ . cr
201: s" xxx" s" xxxx" strcmp . cr
202: ." lp@:" lp@ . cr
203: s" xxx3" s" xxx2" strcmp . cr
204: ." lp@:" lp@ . cr
205: s" " s" " strcmp . cr
206: ." lp@:" lp@ . cr
207: ." lp@:" lp@ . cr
208: ." stack:" .s cr
209: ;
210:
211: : findchar { c addr u -- i }
212: addr u 0 ?do
213: { p }
214: p c@ c = if
215: p leave
216: then
217: p char+
218: loop
219: addr - ;
220:
221:
222: : testfindchar
223: ." findcahr " cr
224: ." lp@:" lp@ . cr
225: [char] a s" xxx" findchar . cr
226: ." lp@:" lp@ . cr
227: [char] a s" " findchar . cr
228: ." lp@:" lp@ . cr
229: [char] a s" wam" findchar . cr
230: ." lp@:" lp@ . cr
231: [char] a s" wma" findchar . cr
232: ." lp@:" lp@ . cr
233: [char] a s" awam" findchar . cr
234: ." lp@:" lp@ . cr
235: ." stack:" .s cr
236: ;
237:
238:
239:
240: ." stack:" .s cr
241: teststrcmp
242: testfindchar
243: ." hey you" cr
244:
245: : xxx10
246: [ ." before if" localsinfo ]
247: if
248: [ ." after if" localsinfo ]
249: scope
250: [ ." after scope" localsinfo ]
251: { a }
252: [ ." before endscope" localsinfo ]
253: endscope
254: [ ." before begin" localsinfo ]
255: begin
256: [ ." after begin" localsinfo ]
257: [ 1 cs-roll ]
258: [ ." before then" localsinfo ]
259: then
260: { b }
261: until
262: [ ." after until" localsinfo ]
263: ;
264:
265: : xxx11
266: if
267: { a }
268: exit
269: [ ." after xexit" localsinfo ]
270: else
271: { b }
272: [ ." before xthen" localsinfo ]
273: then
274: [ ." after xthen" localsinfo ]
275: ;
276:
277: ." strcmp1 coming up" cr
278: : strcmp1 { addr1 u1 addr2 u2 -- n }
279: u1 u2 min 0 ?do
280: addr1 c@ addr2 c@ - ?dup if
281: unloop exit
282: then
283: addr1 char+ TO addr1
284: addr2 char+ TO addr2
285: loop
286: u1 u2 - ;
287:
288: : teststrcmp1
289: ." lp@:" lp@ . cr
290: s" xxx" s" yyy" strcmp1 . cr
291: ." lp@:" lp@ . cr
292: s" xxx" s" xxx" strcmp1 . cr
293: ." lp@:" lp@ . cr
294: s" xxx" s" xxxx" strcmp1 . cr
295: ." lp@:" lp@ . cr
296: s" xxx3" s" xxx2" strcmp1 . cr
297: ." lp@:" lp@ . cr
298: s" " s" " strcmp1 . cr
299: ." lp@:" lp@ . cr
300: ." lp@:" lp@ . cr
301: ." stack:" .s cr
302: ;
303: teststrcmp1
304:
305: ." testing the abominable locals-ext wordset" cr
306: : puke locals| this read you can |
307: you read this can ;
308:
309: 1 2 3 4 puke . . . . cr
310:
311: \ just some other stuff
312:
313: : life1 { b0 b1 b23 old -- new }
314: b23 invert old b1 b0 xor and old invert b1 and b0 and or and ;
315:
316: : life2 { b0 b1 b23 old -- new }
317: b0 b1 or old b0 xor b1 xor b23 or invert and ;
318:
319: $5555 $3333 $0f0f $00ff life1 .
320: $5555 $3333 $0f0f $00ff life2 .
321: .s
322: cr
323:
324: : test
325: 1 { a } ." after }" cr
326: 2 { b -- } ." after --" cr
327: ;
328: test
329: .s cr
330:
331: bye
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>