/
block-0002.fs
192 lines (155 loc) · 4.25 KB
/
block-0002.fs
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
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
\ UNIT tests
CR sys-info
last here
variable th th !
variable tl tl !
: forget-tests tl @ (last) ! th @ (here) ! ;
\ ---------------------------------------------- TESTS START HERE -----------------------------------------------------
: test 1 2 = if 255 drop else 254 drop then ;
cr last dict>xt @ here 1- .S dump cr
variable num-tests
variable passed
0 num-tests ! 0 passed !
: num-passed passed @ ;
: num-failed num-tests @ passed @ - ;
: test-results
num-passed . " tests passed, " CT
num-failed . " failed." CT CR ;
: passed? ( status -- )
IF
passed ++
ELSE
" ***Test #" CT num-tests @ . " FAILED***" CT CR
THEN ;
: next-test: num-tests ++ ;
\ ---------------------------------------------- TESTS START HERE -----------------------------------------------------
\ User stack tests ...
variable ms
decimal 20 ms stk-init
: >m ms >stk ;
: m> ms stk> ;
: m@ ms stk@ ;
: mdepth ms stk-depth ;
: mdrop ms stk> DROP ;
next-test: ( 1 ) 444 >m 555 >m mdepth 2 = passed?
next-test: ( 2 ) m> 555 = passed?
next-test: ( 3 ) m@ 444 = passed?
next-test: ( 4 ) m> 444 = passed?
next-test: ( 5 ) mdepth 0 = passed?
next-test: ( 6 ) 1 >m ms stk-reset mdepth 0 = passed?
1111 >m 2222 >m 3333 >m
next-test: ( 7 ) mdepth 3 = passed?
next-test: ( 8 ) mdrop mdepth 2 = passed?
next-test: ( 9 ) m@ 2222 = passed?
next-test: ( 10 ) mdepth 2 = passed?
\ String tests ...
here 100 +
str.empty
: doit >R str.catc str.len R> = passed? ;
next-test: ( 10 ) 60 1 doit
next-test: ( 11 ) 61 2 doit
next-test: ( 12 ) 62 3 doit
next-test: ( 13 ) 63 4 doit
next-test: ( 14 ) 64 5 doit
next-test: ( 15 ) 65 6 doit
next-test: ( 16 ) 66 7 doit
next-test: ( 17 ) 67 8 doit
next-test: ( 18 ) 68 9 doit
next-test: ( 19 ) 69 10 doit
str.empty
next-test: ( 20 ) 70 1 doit
next-test: ( 21 ) 71 2 doit
next-test: ( 22 ) 72 3 doit
next-test: ( 23 ) 73 4 doit
next-test: ( 24 ) 74 5 doit
next-test: ( 25 ) 75 6 doit
next-test: ( 26 ) 76 7 doit
next-test: ( 27 ) 77 8 doit
next-test: ( 28 ) 78 9 doit
next-test: ( 29 ) 79 10 doit
next-test: str.empty str.len 0 = passed? ( 30 )
DROP
\ ***************************************************
\ Parameter stack tests
: p= = passed? ;
: t1 3 >>p
next-test: p1 77 p= \ 31
next-test: p2 88 p= \ 32
next-test: p3 99 p= \ 33
3 p>> ;
: t2 3 >>p
77 88 99 t1
next-test: p1 44 p= \ 34
next-test: p2 55 p= \ 35
next-test: p3 66 p= \ 36
3 p>> ;
: t3 3 >>p
44 55 66 t2
next-test: p1 11 p= \ 37
next-test: p2 22 p= \ 38
next-test: p3 33 p= \ 39
3 p>> ;
11 22 33 t3
33 44 55 66 77 88 6 >>p
next-test: 123 p2! p2 123 p= \ 40
next-test: pdrop pdepth 5 p= \ 41
next-test: pclear pdepth 0 p= \ 42
\ ***************************************************
\ user stack tests
variable ts
5 ts stk-init
: >ts ts >stk ;
: ts> ts stk> ;
: ts@ ts> dup >ts ;
: ts-sz ts stk-sz ;
44 33 22 11 >ts >ts >ts >ts
next-test: ts stk-depth 4 p= \ 43
next-test: ts> 44 p= \ 44
next-test: ts> 33 p= \ 45
next-test: ts> 22 p= \ 46
next-test: ts> 11 p= \ 47
next-test: ts-sz 5 p= \ 48
\ ***************************************************
next-test: 0 pow-2 1 p= \ 50
next-test: 1 pow-2 2 p= \ 51
next-test: 5 pow-2 32 p= \ 52
next-test: 8 pow-2 256 p= \ 53
next-test: 10 pow-2 1024 p= \ 54
: MIL 1000 dup * * ;
next-test: 0 pow-10 1 p= \ 55
next-test: 3 pow-10 1000 p= \ 56
next-test: 8 pow-10 100 mil p= \ 57
next-test: 'd' $64 p= \ 58
next-test: #13 $0d p= \ 59
next-test: #31 $1F p= \ 60
next-test: %11 $03 p= \ 61
\ ***************************************************
\ wordsv
: countTo
" counting to " CT DUP . " ... " CT
1
BEGIN
2DUP <
IF
2DROP LEAVE
THEN
1+
AGAIN ;
: countTo-FAST
" counting to " CT DUP . " ... " CT
BEGIN
1-
DUP
WHILE
DROP ;
: bench1 start-timer swap countTo elapsed ;
: bench2 start-timer swap countTo-FAST elapsed ;
: do-benches
cr " bench #1 " ct dup bench1
cr " bench #2 " ct bench2 ;
cr " Running benchmarks ... " ct 500 MIL do-benches cr
10 .lastx
CR test-results
\ ---------------------------------------------- TESTS END HERE -----------------------------------------------------
forget-tests
CR sys-info