1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
|
\ Return-Stack Depth -- well, "depth" is not exactly it;
\ we're testing detection of imbalance between >R and R> and uses of R@
\ in between.
\ From the ANSI Forth Spec:
\ 3.2.3.3 Return stack
\ . . . . . .
\ A program may use the return stack for temporary storage during the
\ execution of a definition subject to the following restrictions:
\ A program shall not access values on the return stack (using R@,
\ R>, 2R@ or 2R>) that it did not place there using >R or 2>R;
\ A program shall not access from within a do-loop values placed
\ on the return stack before the loop was entered;
\ All values placed on the return stack within a do-loop shall
\ be removed before I, J, LOOP, +LOOP, UNLOOP, or LEAVE is
\ executed;
\ All values placed on the return stack within a definition
\ shall be removed before the definition is terminated
\ or before EXIT is executed.
\ Updated Tue, 18 Jul 2006 at 16:09 PDT by David L. Paktor
[flag] Lower-Case-Token-Names
fcode-version2
headers
\ First, a few primal errors...
." Primal errors" cr
d# 127 h# 127 dup r> swap r@ -rot >r swap
3 0 do r@ loop
3 0 do r> loop
3 0 do i >r loop
hex
create cold-stone 1c c, ec c, 9e c, a3 c, c0 c, 6e c,
\ Then some legit usages
: legit_one
dup >r
3 0 do i
cold-stone over ca+ c@ >r
3 + cold-stone swap ca+ c@ r>
loop
r>
;
\ Now a tricky one:
: tricky_one
dup >r
over if ." Showing " r> u.
else r> drop ." Don't show"
then
;
: another_one ( old new -- false | new' true )
>r 0= if r> drop false exit then
dup * r@ / r> + true
;
." Now we start getting bad." cr
\ The one that started me down this path...
0 instance value _str
0 instance value _len
0 instance value _num
: PARSE-INTS ( addr len num -- n1 .. nn )
to _num
to _len
to _str
_num 0 ?do
_len if
_str _len [char] , left-parse-string 2swap to _len to _str
$number if 0 then
else
0
then
>r loop
_num 0 ?do r> loop
;
. " If this doesn't scare you, it should:" cr
: scattered-errors
0 >r
_num 0 ?do
_str _len [char] , left-parse-string
2swap to _len to _str
$number if 0 else r@ 1+ swap >r then
>r i u.
loop
r@ 0 ?do r> i roll loop
;
." Now, be very afraid..." cr
0 instance value where-from
: frayed-knot
where-from 0= if r@ to where-from then
r> drop where-from if exit then
." What have I done?" cr
;
: krellboyn
where-from ?dup if >r 0 to where-from then
where-from if exit then
." I didn't mean it!" cr
;
fcode-end
|
