Forgot your password?
Document Actions
TST: Various test programs for the LITTLE system software, principally the compiler.
TST: Various test programs for the LITTLE system software, principally the compiler.
1 .=member intro
2$
3$ !$&'()*+,-./0123456789:;<=>abcdefghijklmnopqrstuvwxyz^_
4$ the above line contains, in order of ascii codes, the 56
5$ characters of the little language, starting in column 7.
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$ this software is part of the little programming system.
31$ address queries and comments to
32$
33$ little project
34$ department of computer science
35$ new york university
36$ courant institute of mathematical sciences
37$ 251 mercer street
38$ new york, ny 10012
39$
40$ this file contains various test programs for the little
41$ system software, principally the compiler.
42$
43$ the principal authors of the little compiler are
44$ robert abes, edith deak, richard kenner, david shields
45$ and aaron stein.
46$
47$
dsa 1$ bint
dsa 2$ bootstrap test, prints integer
dsa 3$
dsa 4$ bstr
dsa 5$ bootstrap tset, prints string
dsa 6$
dsa 7$ bparm
dsa 8$ bootstrap test, prints 'n' numeric program parameter, 's'
dsa 9$ string program parameter
dsa 10$
dsa 11$ bcopy
dsa 12$ bootstrap test, does file copy with optional case folding.
dsa 13$ use to check that cases fold correctly (where appropriate).
dsa 14$
dsa 15$ berror
dsa 16$ bootstrap test, generates errors selected by program parameter.
dsa 17
48$
49$
50$ tcomp
51$ comprehensive (sic) test of the little compiler. includes
52$ most of the examples given in little guide.
53$
54$ tmac
55$ test of macro processor in scan phase (lex).
56$
57$ treal
58$ test of real arithmetic
59$
60$ tsynerr
61$ contains various syntactic errors to test error
62$ processing, principally that of the gen phase.
63$
64$ tcodgen
65$ contains various fragments to be examined to study
66$ correctness and quality of generated code.
67$
1 .=member mods
2 $ --- all corrections are to include self-description at mods.2 ---
dsa 18
dsa 19 $ dsa d. shields 18-dec-81
dsa 20 $
dsa 21 $ add several simple tests for bootstrap checkout.
dsa 22 $ decks affected - bint, bstr, bparm, bcopy, berror (all new)
dsa 23
3
4 $ (none) d. shields 20 jun 78
5 $
6 $ release initial version, show form of mods notice.
7 $ decks affected - all.
8
1 .=member bint
2$ simple little test program, just print an integer
3prog bint;
4put ,x :1,i ,skip;
5end;
1 .=member bstr
2$ bstr: simple little test program, just print a string
3prog bstr;
4put ,' hello world!' ,skip;
5end;
1 .=member bparm
2prog bparm;
3$ bparm: little test program
4+* ws = .ws. ** +* ps=.ps.** +* cs=.cs. **
5+* filenamelen = 20 **
6 .+s32 +* filenamelen = 64 **
7 .+s47 +* filenamelen = 64 **
8size n(ws);
9size s(.sds. filenamelen);
10size c(ws);
11call getipp(n,'n=0/1');
12put ,'n parameter (numeric) is ' :n,i ,skip;
13call getspp(s,'s=default/alternate');
14put ,'s parameter (string) is <' :s,a ,'>' ,skip;
15end;
1 .=member bcopy
2prog bcopy;
3$ bcopy: copy standard output to standard output according
4$ to parameter c:
5$ c=0 (default) straight copy
6$ c=1 fold to lower case
7$ c=2 fold to upper case
8+* ws = .ws. ** +* ps=.ps.** +* cs=.cs. **
9+* filenamelen = 20 **
10 .+s32 +* filenamelen = 64 **
11 .+s47 +* filenamelen = 64 **
12size c(ws);
13size line (.sds. 80);
14call getipp(c,'c=0/0');
15if c<0 ! c>2 then
16 put ,'usage: c=1 to fold lower, c=2 to fold upper',skip;
17 return;
18end if;
19call fold;
20end;
21subr fold;
22while 1;
23 get 1 ,skip :line,a(80);
24 if (filestat(1,end)) quit;
25 if c=1 then call stlc(line);
26 elseif c=2 then call stuc(line);
27 end if;
28 put 2 :line,a ,skip;
29end while;
30end subr;
1 .=member berror
2prog berror;
3$ berror: little test program of errors
4$ generate various tests of (intentional) program errors.
5$ test error handling. with program parameter e as follows:
6$ e=0 (default) print 'it works!'
7$ e=1 address exception.
8$ e=2 bad goto index
9$ e=3 bad file number
10$ e=4 bad file name
11+* ws = .ws. ** +* ps=.ps.** +* cs=.cs. **
12+* filenamelen = 20 **
13 .+s32 +* filenamelen = 64 **
14 .+s47 +* filenamelen = 64 **
15+* errmax = 4 **
16size e(.ws.);
17size a(.ws.),b(.ps.);
18size i(ws);
19
20call getipp(e,'e=0/1');
21if e=0 then
22 put, 'it works',skip;
23 return;
24end if;
25if e<1 ! e>errmax then
26 put ,'usage: e in 1..' :errmax,i ,skip;
27 return;
28end if;
29put ,'error test ' :e,i ,skip;
30go to l(e) in 1 to errmax;
31/l(1)/
32 put ,'generating address exception (large index).',skip;
33 size e2ara(ws); dims e2ara(10); size e2i(ps);
34 e2i=1000000;
35 a = e2ara(e2i);
36 $ should never reach here
37 put ,'exception not noted',skip;
38 return;
39/l(2)/ $ bad goto index
40 i = 3;
41 go to el(i) in 1 to 2;
42 /el(1)/
43 /el(2)/
44 put ,'error, test 3 fell through',skip;
45 return;
46 $ should not reach here.
47/l(3)/ $ bad file number
48 put ,'trying to open file with bad file number',skip;
49 i = 220;
50 file i title='',access=get;
51 return;
52/l(4)/ $ bad file name
53 put ,'bad file name !@#$' ,skip;
54 file 3 access=put,title='!@#$',linesize=80;
55 i = filestat(3,access);
56 put ,'filestat after file statement ' :i,i ,skip;
57 put ,'status reported in above line should be zero.' ,skip;
58$ put 3 ,'should not appear, bad file name' ,skip;
59 put 3 :i,i ,skip;
60end prog;
61subr usratp;
62 put ,'if see this, user supplied usratp loaded,'
63 ,' after fatal error',skip;
64end;
65
1 .=member tcomp
2 $ basic test program.
3 $ on s66, run with (mlev=2).
4 +* ws = .ws. ** +* ps = .ps. ** +* cs = .cs. **
5 +* iv(i) = (i) ** +* rv(i) = (i) **
6 +* iassert(a,b) = $ check that real a, b close.
7 assert iv(a) = iv(b); **
8 +* rassert(a,b) = $ check that real a, b close.
9 assert abs((a)-(b)) < 0.01; **
10 $ little test program, based on little guide.
11 prog main;
12 size i(ws);
13 /* variable naming conventions.
14 a - array
15 c - constant
16 e - expression
17 i - integer
18 n - name
19 r - real
20 v - variable
21 */
22
23 $ test comment scan.
24 i = 0;
25 i = 1; $ comment
26 i = i+1; /* comment */
27 i = /* comment */ i + 1; $ comment
28 /* comment i = i+1 */
29 /** double stars once caused trouble. **/
30 assert i=3;
31
32 $ test conditional assembly.
33 i = 0;
34 .+set son1
35 .+son1.
36 .+set son2 $ set within set.
37 ..son1
38 .-son2 assert 1=0;
39 .-son1 assert 1=0;
40 .+son3 assert 1=0;
41 .+son1.
42 i = i+1;
43 .-son1.
44 assert 1=0;
45 ..son1
46 .+son1.
47 .+son2.
48 i = i+1;
49 ..son2
50 ..son1
51
52 assert i=2;
53
54 $ test byte constants
55 assert 1b'0' = 0;
56 assert 1b'0 0' = 0;
57 assert 1b'0 1' = 1;
58 assert 2b'1' = 1;
59 assert 2b'23' = 1b'1011';
60 assert 3b'7' = 7;
61 assert 3b'20' = 16;
62 assert 3b'1 4 4' = 100;
63 assert 4b'a' = 10;
64 assert 4b'b' = 11;
65 assert 4b'c' = 12;
66 assert 4b'd' = 13;
67 assert 4b'e' = 14;
68 assert 4b'f' = 15;
69
70 $ test formation of integer constants.
71
72 assert +100 = 100;
73 assert 1 0 0 = 100;
74 assert 10 0 = 10 0;
75 assert -100 = (0-100);
76
77 $ test formation of floating point constants.
78 real piara; dims piara(6);
79 data piara = 3.1416, 3.14 16, +3.14 16e+0,
80 .31416e+0 1, 31.416e-1, 31416.0e-04;
81 do i = 1 to 6;
82 assert abs(piara(i)-3.1416) < 0.01;
83 end do;
84
85 $ test formation of character code and string constants.
86 assert 1ra = .ch. 2, 'ba';
87 assert .s. 2, 1, 'ab' .seq. 'b';
88 assert .s. 3, 0, 'abc' .seq. '';
89 assert .s. 2, 1, 'ab' .ne. 1rb; $ code is not string.
90 assert 'a''b' .seq. 3qa'b;
91 assert 1rb = 0r/b/;
92 assert 0q/ab'/ .seq. 'ab''';
93 assert 'little' .seq. 6qlittle;
94 assert 6qlittle .seq. 0q little ; $ blank delmits q const.
95
96 $ test .e. extractor.
97 size e1(100), e2(100), e3(100);
98 e1 = 0;
99 assert e1 = 0;
100 .e. 51, 1, e1 = 1;
101 assert .e. 50,2,e1 = 1b'10';
102 i = 0; assert .e. 60, i, e1 = 0;
103 e1 = 0;
104 .e. ws, 1, e1 = 1; .e. ws+1, 1, e1 = 1;
105 assert .e. ws-1, 3, e1 = 1b'110'; $ cross word boundary.
106
107 $ test .f. extractor.
108 size w1(ws), w2(ws), w3(ws);
109 w1 = 0;
110 w2 = 0; do i = 1 to ws; .f. i, 1, w2 = 1; end do; $ all ones
111 assert (.nb. w2) = ws;
112 i = 0; assert .f. 6, i, w2 = 0; $ zero length extract.
113 .f. 7, i, w2 = 0; assert (.nb. w2) = ws;
114 .f. 3, 2, w2 = 0;
115 .f. 3, 2, w2 = 0;
116 assert .f. 1, 6, w2 = 1b'110011';
117 i = 2;
118 .f. 4, i, w2 = 0;
119 assert .f. 1, 6, w2 = 1b'100011';
120 assert (.nb. w2) = ws-3;
121
122 $ test .s. character substring extraction
123 size sds1(.sds. 1), sds4(.sds. 4), sds8(.sds. 8);
124 size sdt1(.sds. 1), sdt4(.sds. 4), sdt8(.sds. 8);
125 sds1 = 'a'; assert .ch. 1, sds1 = 1ra;
126 sds1 = 'a'; sds4 = 'wxyz'; sds8 = '';
127 assert .ch. 1, sds1 = 1ra;
128 assert .s. 1,0, sds1 .seq. '';
129 assert .len. sds4 = 4;
130 assert .s. 2, 2, sds4 .seq. 'xy';
131 sdt8 = sds1 .cc. sds4; assert sdt8 .seq. 'awxyz';
132 .s. 2, 3, sdt8 = '1'; assert sdt8 .seq. 'a1 z';
133
134 $ test .ch. character extraction.
135 assert .ch. 3, sds4 = 1ry;
136
137 $ test bitstring operators.
138 assert (.not. 1b'10') = 1b'01';
139 assert (.not. 1b'0') = 1b'1';
140 assert (^ 1b'10') = 1b'01';
141 assert (^ 1b'0') = 1b'1';
142 assert (.n. 1b'10') = 1b'01';
143 assert (.n. 1b'0') = 1b'1';
144 assert (1b'1100' & 1b'1010') = 1b'1000';
145 assert (1b'1100' .and. 1b'1010') = 1b'1000';
146 assert (1b'1100' .a. 1b'1010') = 1b'1000';
147 assert (1b'1100' .exor. 1b'1010') = 1b'0110';
148 assert (1b'1100' ! 1b'1010') = 1b'1110';
149 assert (1b'1100' .or. 1b'1010') = 1b'1110';
150
151 assert (.fb. 1b'0') = 0;
152 assert (.fb. 1b'01') = 1;
153 assert (.fb. 1b'01') = 1;
154 assert (.fb. 4b'0f') = 4;
155
156 assert (.nb. 1b'0') = 0;
157 assert (.nb. 1b'0101') = 2;
158 assert (.nb. 1b'100') = 1;
159 assert (.nb. 1b'100') = 1;
160
161 assert 1=1;
162 assert 1 .eq. 1;
163 assert 1 ^= 0;
164 assert 1 .ne. 0;
165 assert 1 > 0;
166 assert 1 .gt. 0;
167 assert 1 >= 0;
168 assert 1 .ge. 0;
169 assert 0 < 1;
170 assert 0 .lt. 1;
171 assert 0 <= 1;
172 assert 0 .le. 1;
173
174 $ check .sds. operator to yield multiple of ws.
175 size l(ps); l = .sds. 0; assert l=ws;
176 do i = 1 to 100;
177 assert .sds. i >= l;
178 l = .sds. i;
179 assert mod(l,ws) = 0;
180 end do;
181
182 $ test .sne. and .seq. string comparisons
183 assert 'ab' .seq. (.s. 3, 2, 'xyab');
184 assert 'ab' .sne. '';
185 assert 'ab' .sne. 'ab ';
186 assert 'ab' .sne. 'xy';
187
188 $ concatenation has been tested as part of prior tests.
189
190 $ test .in. character instance operator.
191 assert ('' .in. 'a') = 0;
192 assert ('' .in. '') = 0;
193 assert ('a' .in. '') = 0;
194 assert ('ab' .in. 'wxyzabab') = 5;
195 assert ('setl' .in. 'little') = 0;
196 assert ('tl'.in. 'setl' = 'tl'.in.'little'-1);
197
198 $ test .pad. string padding operator.
199 assert (.len. ('a'.pad.6)) = 6;
200 assert ('little'.pad.10) .seq. 'little ';
201 assert ('little'.pad.3) .seq. 'lit';
202 assert ('abc'.pad.6 !! 'xy' .pad. 10) .seq.
203 'abc xy ';
204
205
206 $ test integer arithmetic.
207
208 iassert (iv(-15)/iv(4), -3);
209 iassert (iv(15)/iv(-4), -3)
210 iassert (iv(-13)/iv(-7), 1);
211 iassert (iv(13)/iv(-7), -1);
212 iassert (iv(-13)/iv(7), -1);
213 iassert (iv(-13)/iv(13), -1);
214 iassert (iv(13)/iv(13), 1);
215
216 +* modchk(a,b,c) = iassert (mod(iv(a),iv(b)), c); **
217 modchk(10, 3, 1);
218 modchk(11, 10, 1);
219 modchk(13, 7, 6);
220 modchk(13, -7, 6);
221 modchk(-13, 7, -6);
222 modchk(-13, -7, -6);
223 modchk(13, 13, 0);
224 modchk(13, -13, 0);
225 modchk(-13, 13, 0);
226 modchk(-13, -13, 0);
227 $ test standard mathematical functions.
228
229
230 rassert(abs(4.5), 4.5);
231 rassert (abs(-4.5), 4.5);
232 rassert (aint(0.5), 0.0);
233$ rassert (aint(1.1), 1.0);
234 rassert (aint(-3.2), -3.0);
235 +* e = 2.718281828 **
236 rassert(alog(e), 1.0);
237 rassert (alog(1.0), 0.0);
238 rassert (alog(10.0), 2.3026);
239
240 rassert (alog10(100.0), 2.0);
241 rassert (alog10(1 000 000.0), 6.0);
242
243 rassert (amod(4.5,2.1), 0.3);
244 rassert (amod(4.5, 1.0), 0.5);
245 rassert (amod(-3.2, 1.5), -0.2);
246
247 rassert (alog(exp(20.0)), 20.0);
248 rassert (atan(1.0), 0.7854)
249 rassert (atan(100.0), 1.5608);
250 rassert (atan(-100.0), -1.5608);
251
252 rassert (atan(2.5), atan2(5.0,2.0));
253 rassert (atan(-2.5), atan2(-5.0, 2.0));
254 rassert (atan(0.5), atan2(3.0, 6.0));
255
256 rassert (cos(1.0), 0.5406);
257 rassert (cos(0.0), 1.0000);
258 rassert (cos(100.0), 0.8623);
259 rassert (cos(-100.0), 0.86232);
260
261 rassert ((dim(4.5, 2.2)), 2.3);
262 rassert ((dim(2.2, 4.5)), 0.0);
263 rassert ((dim(-10.0, -4.0)), 0.0);
264 rassert ((dim(-4.0, -10.0)), 6.0);
265
266 rassert (exp(1.0), e);
267 rassert (alog(exp(1.0)), 1.0);
268 rassert (exp(alog(10.0)), 10.0);
269 rassert (exp(3.0), 20.08554);
270 rassert (exp(0.5), 1.6487);
271 rassert (exp(-50.0), -1.92875e-22);
272
273 rassert (float(1), 1.0);
274 rassert (float(0), 0.0);
275 rassert (float(-3), -3.0);
276 rassert (float(10000), 10000.0);
277
278 rassert(abs(4.5), 4.5);
279 rassert (abs(-4.5), 4.5);
280 rassert (aint(0.5), 0.0);
281 rassert (aint(1.1), 1.0);
282 rassert (aint(-3.2), -3.0);
283 iassert (iabs(10), 10);
284 iassert (iabs(0), 0);
285 iassert (iabs(-20), 20);
286
287 iassert ((idim(20,10)), 10);
288 iassert ((idim(10,20)), 0);
289
290 iassert ((idim(-10,-4)), 0);
291 iassert ((idim(-4,-10)), 6);
292
293 iassert (ifix(2.1), 2);
294 iassert (ifix(0.5), 0);
295 iassert (ifix(-3.2), -3);
296
297 iassert (ifix(2.1), int(2.1));
298 iassert (ifix(0.5), int(0.4));
299 iassert (ifix(-4.9), int(-4.9));
300
301 iassert (isign(4,5), 4);
302 iassert (isign(10,-2), -10);
303 $ isign(0,-1) may be -0 on ones complement.
304$ iassert (isign(0, -1), 0);
305 iassert (isign(-10,-2), -10);
306
307 iassert (mod(10,3), 1);
308 iassert (mod(6, 3), 0);
309 iassert (mod(0, 5), 0);
310 iassert (mod(-10, 3), -1);
311 iassert (mod(-12,-4), 0);
312 iassert (mod(-15, 7), -1);
313
314 rassert (sqrt(100.0), 10.0);
315 rassert (sqrt(1.0), 1.0);
316 rassert (sqrt(2.0), 1.41414);
317
318 rassert (tanh(0.10), 0.09967);
319 rassert (tanh(0.50), 0.46212);
320 rassert (tanh(1.00), 0.76159);
321 rassert (tanh(1.50), 0.90515);
322
323 end prog;
1 .=member tmac
2 $ this deck tests macro processor
3 setlistc01
4 this card should be seen
5 setlistc00
6 this card should not be seen
7 setlistc01
8 this seen
9 setlistc26
10 not this
11 +*thislong(w)=this long macro definitin should eventually be seen
12 w w w**
13 setlistc00
14while this should be totally absent
15 setlistc40
16and this should be in buffer bt no listed
17 thislong (along with its call)
18 setlistc17
19 thislong (along with its call in punched form)
20 and., a., terminator., should., start., a.,
21 new., line., every., once., in., a., while.,
22 while a /label/, yes a /label/,
23 should always start a new line.
24 +*withthe=present setting this macro should appear in both
25 xlistings**
26 setlistc23
27 +*with a new = setting this macro definition should not be shown**
28 with a new withanew
29 even though its expansion will be shown
30 setlistc40
31 withanew should restore the 'punch format'
32 listing
33setlistc15
34 +*awdsiz=20** +*iwd=newiwd** +*nexunwd(wd)=routine(wd,0)**
35+*mstklim=100**
36+*quote(wd)=wd** +*s=quote(*)**+*p=quote(+)**
37+*oldmac = original version**
38oldmac oldmac
39 +*q3(w1,w2,w3)=w1 w2 w3**
40 +* revisor=q3(+,*oldmac=new revised version*,*)**
41 revisor
42 oldmac oldmac oldmac
43+*newmac= p s quote(oldmac) =revised second version s s **
44newmac
45oldmac oldmac oldmac
46 **test data for the above**
47+*aa=aa**
48*a=aa*b
49+a=aa*b
50+*c(,**
51+*da,-**
52+*ab(c) def edf**
53+*ab(z,z)=x**
54+*ab(ab)=y**
55+*d(a,-**
56amac +*z=y**
57 data for systematic macro testing
58 +*mac1=this is a first macro**
59 mac1 mac1(with an argument)
60 +*mac1=this is a second version of same macro**
61 mac1 mac1(with an argument)
62 +*macro=showing double nesting**
63 mac1
64 +*nesting=and even triple level expansion**
65 mac1
66 +*macro=**
67 mac1
68 +*mac3(wd)=wd is substituted in this macro**
69 mac3(oneword)
70bmac
71 mac3(two words)
72zmac
73 mac3(a whole long phrase)
74 mac3 omitting arguments
75 mac3(a phrase,separated by commas)
76 mac3(a phrase., containing the delimiter)
77 mac1(unnecessary arguments)
78 mac3(a phrase(with embedded .,terminator) in parentheses)
79 +*mac4(a,b)=a is first,b second**
80 mac4(one word,another)
81 mac4(just one)
82 mac4(with,three,parameters)
83 mac4(mac1,mac2)
84 mac4(mac4(inward,outward),final)
85 +*mac5=zzza and zzzb are generated symbols.
86 zzza and zzzb can be repeated. they
87 contain the integers zzya and zzyb**
88 mac5
89 +*mac5=**
90 mac5
91 mac3(a phrase (with parenthesized) subphrase)
92 mac3(a phrase(with comma,separated) subphrase)
93 +*mac5=whatever**
94 mac5
95 +*mac6=first version,macro 6**
96 mac6
97 +*mac6=second version,macro 6**
98 mac6
1 .=member treal
2
3 /* test floating point features by seeing if various points
4 define a tetrahedron.
5
6 author r. abes (cims) jul 74
7 d. shields (cims) dec 77 (revise to level 2.3)
8 */
9 prog treal;
10
11 +* yes = 1 ** +* no = 0 **
12
13 size nerrors(.ps.); nerrors = 0; $ number of errors detected.
14
15 call tetra(1.1, 1.2, 1.3, 1.4, 1.5, 1.6, yes);
16 call tetra(1.5, 1.3, 1.6, 1.2, 1.1, 1.4, yes);
17 call tetra(5.2, 5.2, 100.1, 5.2, 5.2, 5.2, no);
18 call tetra(8.0, 8.0, 20.1, 20.1, 8.0, 8.0, no);
19 call tetra(1.1, 1.2, -1.2, 1.1, 1.1, 1.1, no);
20 call tetra(.5, .5, 0.0, .5, .4, .3, no);
21 call tetra(10., 9., .5, 1.1, 1.1, 10., yes);
22 call tetra(.2e10, .2e10, .25e10, 7.e10, 7.e10, 7.e10, yes);
23 call tetra(.2e-10, .2e-10, .25e-10, 7.e-10, 7.e-10, 7.e-10, yes);
24 if nerrors then
25 put ,'*** error - test failed ' :nerrors,i ,' times ***',skip;
26 else
27 put ,'*** test passed ***' ,skip;
28 end if;
29 end prog treal;
30 subr tetra(a, b, c, d, e, f, valid);;
31
32 $ this subroutine decides whether its six floating point input
33 $ arguments can be the lengths of the edges of a non-degenerate
34 $ tetrahedron.
35
36 real a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, area;
37 size valid(1); $ true if points define tetrahedron.
38
39 +* check =
40 l = area(f, j, h);
41 m = area(g, h, i);
42 n = area(g, j, k);
43 o = area(f, i, k);
44 if ((l > 0.0) & (m > 0.0) & (n > 0.0) &
45 (o > 0.0)) then
46 if ((l < m+n+o) & (m < l+n+o) & (n < l+m+o)
47 & (o < l+m+n)) go to pgood; end if **
48
49 +* setup(t, u, v, w, x) =
50 g = t; h = u;
51 i = v; j = w; k = x; check; j = x; k = w; check;
52 i = w; j = v; k = x; check; j = x; k = v; check;
53 i = x; j = v; k = w; check; j = w; k = v; check **
54
55
56
57
58 if ((a <= 0.0) .or. (b <= 0.0) .or. (c <= 0.0) .or.
59 (d <= 0.0) .or. (e <= 0.0) .or. (f <= 0.0)) go to nono;
60
61 $ test for tetrahedron
62
63 setup(a, b, c, d, e);
64 setup(b, a, c, d, e);
65 setup(c, a, b, d, e);
66 setup(d, a, b, c, e);
67 setup(e, a, b, c, d);
68
69 /nono/
70 if (valid = no) return; $ if expect invalid case.
71 nerrors = nerrors+1;
72 put ,skip ,' input parameters to tetra:' ,skip;
73 put :a:b:c,ne(12,5) ,skip :d:e:f,ne(12,5) ,skip;
74 put ,' these cannot be lengths of edges of a tetrahedron'
75 ,skip;
76 return;
77
78 /pgood/
79 if (valid=yes) return; $ if expect valid tetrahedron.
80 nerrors = nerrors+1;
81 put ,skip ,' input parameters to tetra:' ,skip;
82 put :a:b:c,ne(12,5) ,skip :d:e:f,ne(12,5) ,skip;
83 put ,' a non-degenerate tetrahedron exists with'
84 ,' these quantities as the lengths of its edges' ,skip;
85 put ,' side q s = ' :f,e(12,5);
86 put ,' side p r = ' :g,e(12,5);
87 put ,' side p s = ' :h,e(12,5) ,skip;
88 put ,' side r s = ' :i,e(12,5);
89 put ,' side p q = ' :j,e(12,5);
90 put ,' side q r = ' :k,e(12,5);
91
92 end subr tetra;
93 fnct area(x, y, z);
94
95 $ returns four times the area of the triangle with sides x, y, z.
96
97 real area, x, y, z;
98 area = (x+y+z) * (x+y-z) * (x+z-y) * (y+z-x);
99 if (area > 0.0)
100 then area = sqrt(area);
101 else area = 0.0;
102 end if;
103 end fnct area;
1 .=member tsynerr
2 $ this program contains a number of syntactic errors to check
3 $ error detection of little parser.
4 $ author - d. shields (cims) 01 oct 77
5 prog main;
6 +* ws = .ws. ** +* ps = .ps. ** +* cs = .cs. **
7 size e1(ws), e2(ws), e3(ws);
8 size i1(ps), i2(ps), i3(ps), i4(ps);
9 size str1(.sds. 80), str2(.sds. 80);
10 size c1(cs), c2(cs), c3(cs);
11 size ara1(ws), ara2(ws); dims ara1(10), ara2(20);
12
13
14 put ,g(10); $ illformed o
15 put ,g(10); $ illformed control format.
16 put : fw
17 put : i1 ,-20; $ illformed data format
18 e1 = e2 + /;
19 put : e1,i()();
20 file 3 recordlen = 200; $ recordlen is invalid attribute.
21 file 2 ttile=20;
22 monitor +; $ illformed parameter list.
23 put 3 : e1 , i(10/; $ illformed data format
24 e1 = 10/ ; $ not terminated by semicolon;
25 10 = e1;
26 e1 = .not. *;
27 /l(+)/ e1=1;
28 /l(1// e1 = 1;
29 /+1/ e1=1;
30 access 1; $ expect nameset name.
31 assr
32 assert +;
33 call 1;
34 call p1,+,2);
35 call p1(1,2)/;
36 call p1(a ());
37 call p1(a+1 +);
38 check index;
39 data e1 10;
40 data e1=+;
41 data 10=e1;
42 data a1(+) = 1;
43 data a1(+/ = 1;
44 data a1 = 10(a);
45 data a1 = 'abc'(10);
46 dims a
47 dima
48 size dv(ws);
49 dims dv(10;
50 dimvs dv 10;
51 si
52 dims dv /10);
53 dims dv(100000);
54 do i1 = 10 two 20;
55 end do;
56 do i1 from 10 to 20; end do;
57 do i1 = + to 20; end do;
58 do i1 = 10 to +/;
59 if e1 then e2=2; elsyif
60 if e1 then e2=1 elseif e2 thenn e2=2; edd if;
61 if e1 then e2=1 elseif e2 thenn e2=2; end if;
62 if e1 then e2=1 elseif 6/ then e2=2; end if;
63 file + title='';
64 e1 = filestat(+,err);
65 e1 = filestat(1 err)
66 e1 = filestat(1 erry
67 e1 = filestat(1, err/;
68 e1 = filestat(1 err);
69 e1 = filestat(down,3);
70 e1 = filestat(1, violet);
71 e1 = filestat+2;
72 go to l1(e1) inrange 1 to 2;
73 go to l2(e1) in 1 two 3;
74 go to l1(e1) in i1 to 4;
75 go to l1(e1) in 1 to e3;
76 go to l1(+);
77 go to l1(1/;
78 go two l1;
79 goto l1;
80 goto 10;
81 go to 10;
82 goby e1+l1,l2,l3);
83 goby e1;
84 goby e1(l1,l2;
85 goby e1(10,l2);
86 if + then a=1; end if;
87 monitor limit = thursday+;
88 monitor limit 100;
89 monitor lymit = 10;
90 nameset 10;
91 read + a,b;
92 read a,b;
93 read 3, a,b,.;
94 rewind +;
95 size s1,+);
96 size s1(10;
97 size s1+10);
98 size s1(100000); $ very large size.
99 subr 1; end subr;
100 subr subr1(10,20);
101 subr s2(10;
102 end subr;
103 until +; end until;
104 while +; end while;
105 while )/2; end while;
106 e1 == 10;
107 e1 := 10;
108 e1 = +;
109 read 4, a(1) two a(4);
110 read 4, a(10 to 20;
111 read 4, a(1) to 30;
112 read 4, a(1) to aa(4);
113 .f. +, 20, e1 = 2;
114 .f. 1, +, e1 = 0;
115 .f. 1, 20, a1(+) = 1;
116 .f. 1, 1, e1 = +;
117 .ch. 1, str1 = +;
118 .ch. 1, 2, a(1) = 10;
119 .s. 0, 10, str1 = +;
120 .s. +, 20, str1 = '';
121 .s. 1, +, str1 == '';
122 .s. 1, 1, str1 =
123 .s. 1, +, str1 = '';
124 size c1(.cs., c2(.cs., c3(.cs.)
1 .=member tcodgen
2 +* ws=60** +* ps=17 **
3 subr code;
4 $ examine code produced by little compiler
5 $ check for expected optimizations;
6 +* d(v) = size v(ws); **
7 d(w) d(w1) d(w2) d(w3) d(w4) d(w5) d(w6)
8 d(wa) d(wa1) d(wa2)
9 dims wa(100), wa1(100), wa2(100);
10 +* d(v) = size v(ps); ** $ declare pointer size
11 d(p) d(p1) d(p2) d(p3) d(p4) d(p5) d(p6)
12 d(pa) d(pa1) d(pa2) d(pa3) d(pa4)
13 dims pa(100), pa1(100), pa2(50), pa3(50);
14
15 $ constont folding
16 call confold;
17 w1 = 50*4 - 5*6; $ should be constant
18 w3 = w1-4;
19 w4 = w1+5;
20 w2 = wa1(10); $ constant subscript;
21
22 $ redundant subexpressions
23 call redund;
24 w1 = w;
25 w3 = w1+w2;
26 w4=w1;
27 w5=w4+w2; $ should be same as w3
28 w = w4;
29 wa(1) = w1+w2;
30 wa(3) = w3;
31 wa(4) = w1+w2;
32 w2 = wa(1)+wa(2); $ constant subscripts
33 w3 = wa(1) + wa(2);
34
35 $ check field extracts
36 call fldext;
37 p1 = .f. 3, 2, w;
38 p2 = .f. 3, 2, w; $ same field
39 .f. 3, 2, w1 = 1;
40 p3 = .f. 3, 2, w; $ seting p3 to 1
41 $ tests
42 call tests;
43 if(w=0) go to lab;
44 if(w>0) go to lab;
45 if(w1=w2) go to lab;
46 if( (w1>w2) & (w1 ^= w3)) go to lab;
47 if ( .f. 31, 1, w3 = 0) go to lab; $ testing single bit
48 call other; /lab/;
49 $ indexed field
50 call ndxfld;
51 w1 = .f. 2, 3, wa(p1);
52 w2 = .f. 2, 3, wa(p1);
53 call array2;
54 w = wa(p1);
55 w4 = wa(p1);
56 call array3;
57 .f. 2, 7, w4 = .f. 2, 7, w1;
58 $ multi-word index and fld extract
59 call multwd;
60 size ww(120), ww1(120), ww3(120), ww4(120); $ two word
61 w1 = .f. 2, 5, ww1;
62 size ww2(120);
63 w3 = .f. 62, 4, ww1;
64 .f. 1, 1, ww2 = 0;
65 $ redundant function call
66 call redfunc;
67 size fun(ws);
68 w1 = fun(p1); w2 = fun(p1); $ only 1 call needed
69 call muldiv;
70 p1 = p2/10; p3 = p4/60;
71 p4 = p4*2; p1 = p1/2;
72 $short loops ( see if in stack)
73 call memzero;
74 p1=1;
75 /memloop/ wa(p1)=0; p1=p1+1; if(p1.le.100) go to memloop;
76
77 $ loop - memory move
78 call memove;
79 p1 = 20;
80 /moveloop/ wa(p1) = wa1(p1);
81 +*d=**
82 call done; end;
83 subr srtl;
84 /* srtl code fragments for code test */
85 size t(ws), maxzzyz(ws), tres(ws), running(ws);
86 t=5000 - maxzzyz; tres=t; running=t;
87 return; end;
88 subr getstg(n,p); size n(ps), p(ps);
89 if(n=0) go to l1; go to l2;
90 /l1/ call abort; /l2/ return; end;
91 subr eg3;
92 size u(ws), t(ps); dims u(100);
93 u(t*1) = 0; t=t+1; return; end;
94 subr eg4;
95 size temp(ws), storage(ws); dims storage(100);
96 temp=1;
97 /a/ if(temp.gt. 5000) go to b;
98 storage(temp)=0; temp=temp+1; go to a;
99 /b/
100 return; end;
101 subr eg5;
102 size storage(ws); dims storage(500);
103 size p1(ps), p2(ps), p3(ps); size w1(ws), w2(ws), w3(ws);
104 storage(400-10+1) = 1; storage(400-5+1) = 6;
105 storage( .f. 1, ps, w1) = .f. 20, ps, w1;
106 storage(w1-10 + 1) = 1; $ var -con + con case
107 return; end;
1 .=member testss
2 +* ws = .ws. ** +* ps =.ps. ** +* cs = .cs. **
3 +* ss_blank = 1b'000001' **
4 +* ss_separ = 1b'000010' **
5 +* ss_digit = 1b'000100' **
6 +* ss_ucltr = 1b'001000' **
7 +* ss_lcltr = 1b'010000' **
8 +* ss_break = 1b'100000' **
9 prog testss;
10 size al(.sds. 26); data al = 'abcdefghijklmnopqrstuvwxyz';
11 size nu(.sds. 10); data nu = '1234567890';
12 size bl(.sds. 1); data bl = ' ';
13 size brkc(ws),brks(ws),spnc(ws),spns(ws);
14 size anys(ws), nays(ws), anyc(ws);
15 size rbrc(ws), rbrs(ws), rspc(ws), rsps(ws);
16 size ss_vow(ps); $ string set for vowels.
17 size ss_pri(ps); $ string set for primes.
18
19
20 assert anyc(1ra, ss_ucltr) = 1;
21 assert anyc(1r1, ss_digit) = 1;
22 assert anyc(1r , ss_blank) = 1;
23 assert anyc(1r , ss_separ) = 1;
24 assert anyc(1r_ , ss_break) = 1;
25 assert anys(al, 1, ss_digit) = 0;
26 assert anys(al, 1, ss_ucltr) = 1;
27 assert anys(al, 26, ss_ucltr) = 1;
28 assert anys(al, 13, ss_ucltr) = 1;
29 assert nays(al, 1, ss_digit) = 1;
30 assert nays(al, 1, ss_ucltr) = 0;
31
32 assert brkc(al, 1, 1re) = 4;
33 assert brks(al, 1, ss_ucltr) = 0;
34 assert brks(al, 1, ss_blank) = -1;
35 assert brkc(al, 1, 1ra) = 0;
36
37 assert spnc(al, 1, 1rb) = -1;
38 assert spnc(al, 1, 1ra) = 1;
39 assert spns(al, 1, ss_digit) = -1;
40 assert spns(al, 1, ss_ucltr) = 26;
41 assert spns(nu, 1, ss_digit) = 10;
42
43 assert rbrc(al, (.len. al), 1re) = 21;
44 assert rbrs(al, (.len. al), ss_blank) = -1;
45 assert rbrc(al, (.len. al), 1rz) = 0;
46
47 assert rspc(al, (.len. al), 1rb) = -1;
48 assert rspc(al, (.len. al), 1rz) = 1;
49 assert rsps(al, (.len. al), ss_digit) = -1;
50 assert rsps(al, (.len. al), ss_ucltr) = 26;
51
52 ss_vow = 1b'1000000'; $ search set for vowels
53 ss_pri = 1b'10000000'; $ search set for pri digitss.
54
55 call blds('aeiou', ss_vow);
56 call blds('357', ss_pri);
57
58 assert anys(al, 1, ss_vow) = 1;
59 assert nays(al, 1, ss_pri) = 1;
60
61 assert brks(al, 1, ss_vow) = 0;
62 assert rbrs(al, (.len. al), ss_vow) = 5; $ u is rightmost vowel.
63
64 assert brks(nu, 1, ss_pri) = 2;
65 assert spns(nu, 1, ss_pri) = -1;
66
67 assert rbrs(nu, (.len. nu), ss_pri) = 3;
68
69 call rpld('0123456789', 'abcdefghij');
70 call rple(nu);
71 assert nu .seq. 'bcdefghija';
72
73 end prog;