Commit | Line | Data |
---|---|---|
52661f63 KT |
1 | #include "apl.h" |
2 | ||
3 | char *continu = "continue"; | |
4 | ||
5 | execute(s) | |
6 | char *s; | |
7 | { | |
8 | register i; | |
9 | register data *dp; | |
10 | register struct item *p; | |
11 | struct item *p1; | |
12 | int j; | |
13 | data (*f)(), d; | |
14 | ||
15 | #ifdef SOMED | |
16 | if(debug) | |
17 | dump(s); | |
18 | #endif | |
19 | ||
20 | loop: | |
21 | i = *s++; | |
22 | #ifdef FULLD | |
23 | if(debug) { | |
24 | extern char *opname[]; | |
25 | if(i==-1) | |
26 | aprintf("exec eof\n"); | |
27 | else if(0<=i&&i<103) { | |
28 | aprintf("exec "); aprintf(opname[i]); aputchar('\n'); | |
29 | } else | |
30 | aprintf("exec %d\n",i); | |
31 | } | |
32 | #endif | |
33 | #ifdef SHORTD | |
34 | if(debug) | |
35 | aprintf("exec %d\n", i); | |
36 | #endif | |
37 | switch(i) { | |
38 | ||
39 | default: | |
40 | error("exec B"); | |
41 | ||
42 | case EOF: | |
43 | return; | |
44 | ||
45 | case EOL: | |
46 | pop(); | |
47 | goto loop; | |
48 | ||
49 | case COMNT: | |
50 | push(newdat(DA,1,0)); | |
51 | goto loop; | |
52 | ||
53 | case ADD: | |
54 | case SUB: | |
55 | case MUL: | |
56 | case DIV: | |
57 | case MOD: | |
58 | case MIN: | |
59 | case MAX: | |
60 | case PWR: | |
61 | case LOG: | |
62 | case CIR: | |
63 | case COMB: | |
64 | case AND: | |
65 | case OR: | |
66 | case NAND: | |
67 | case NOR: | |
68 | case LT: | |
69 | case LE: | |
70 | case EQ: | |
71 | case GE: | |
72 | case GT: | |
73 | case NE: | |
74 | f = exop[i]; | |
75 | p = fetch2(); | |
76 | p1 = sp[-2]; | |
77 | if(p->type!=DA||p1->type!=DA) { | |
78 | if(p->type==CH&&p1->type==CH) { | |
79 | charfun(i, p, p1); | |
80 | goto loop; | |
81 | } else | |
82 | error("dyadic T E"); | |
83 | } | |
84 | if(!p->rank||p->rank==1&&p->size==1) { | |
85 | d = p->datap[0]; | |
86 | pop(); | |
87 | p = p1; | |
88 | dp = p->datap; | |
89 | for(i=0; i<p->size; i++) { | |
90 | *dp = (*f)(d, *dp); | |
91 | dp++; | |
92 | } | |
93 | goto loop; | |
94 | } | |
95 | if(!p1->rank||p1->rank==1&&p1->size==1) { | |
96 | sp--; | |
97 | d = p1->datap[0]; | |
98 | pop(); | |
99 | push(p); | |
100 | dp = p->datap; | |
101 | for(i=0; i<p->size; i++) { | |
102 | *dp = (*f)(*dp, d); | |
103 | dp++; | |
104 | } | |
105 | goto loop; | |
106 | } | |
107 | if(p1->rank != p->rank) | |
108 | error("dyadic C E"); | |
109 | for(i=0; i<p->rank; i++) | |
110 | if(p->dim[i] != p1->dim[i]) | |
111 | error("dyadic C E"); | |
112 | dp = p1->datap; | |
113 | for(i=0; i<p->size; i++) { | |
114 | *dp = (*f)(p->datap[i], *dp); | |
115 | dp++; | |
116 | } | |
117 | pop(); | |
118 | goto loop; | |
119 | ||
120 | ||
121 | ||
122 | case PLUS: | |
123 | case MINUS: | |
124 | case SGN: | |
125 | case RECIP: | |
126 | case ABS: | |
127 | case FLOOR: | |
128 | case CEIL: | |
129 | case EXP: | |
130 | case LOGE: | |
131 | case PI: | |
132 | case RAND: | |
133 | case FAC: | |
134 | case NOT: | |
135 | f = exop[i]; | |
136 | p = fetch1(); | |
137 | if(p->type != DA) | |
138 | error("monadic T E"); | |
139 | dp = p->datap; | |
140 | for(i=0; i<p->size; i++) { | |
141 | *dp = (*f)(*dp); | |
142 | dp++; | |
143 | } | |
144 | goto loop; | |
145 | ||
146 | case MEPS: /* execute */ | |
147 | case MENC: /* monadic encode */ | |
148 | case DRHO: | |
149 | case DIOT: | |
150 | case EPS: | |
151 | case REP: | |
152 | case BASE: | |
153 | case DEAL: | |
154 | case DTRN: | |
155 | case CAT: | |
156 | case CATK: | |
157 | case TAKE: | |
158 | case DROP: | |
159 | case DDOM: | |
160 | case MDOM: | |
161 | case GDU: | |
162 | case GDUK: | |
163 | case GDD: | |
164 | case GDDK: | |
165 | case COM: | |
166 | case COM0: | |
167 | case COMK: | |
168 | case EXD: | |
169 | case EXD0: | |
170 | case EXDK: | |
171 | case ROT: | |
172 | case ROT0: | |
173 | case ROTK: | |
174 | case MRHO: | |
175 | case MTRN: | |
176 | case RAV: | |
177 | case RAVK: | |
178 | case RED: | |
179 | case RED0: | |
180 | case REDK: | |
181 | case SCAN: | |
182 | case SCANK: | |
183 | case SCAN0: | |
184 | case REV: | |
185 | case REV0: | |
186 | case REVK: | |
187 | case ASGN: | |
188 | case INDEX: | |
189 | case ELID: | |
190 | case IPROD: | |
191 | case OPROD: | |
192 | case IMMED: | |
193 | case HPRINT: | |
194 | case PRINT: | |
195 | case MIOT: | |
196 | case MIBM: | |
197 | case DIBM: | |
198 | case BRAN0: | |
199 | case BRAN: | |
200 | case FUN: | |
201 | case ARG1: | |
202 | case ARG2: | |
203 | case AUTO: | |
204 | case REST: | |
205 | pcp = s; | |
206 | (*exop[i])(); | |
207 | s = pcp; | |
208 | goto loop; | |
209 | ||
210 | case NAME: | |
211 | s += copy(IN, s, sp, 1); | |
212 | sp++; | |
213 | if(sp>staktop) | |
214 | newstak(); | |
215 | goto loop; | |
216 | ||
217 | case QUOT: | |
218 | j = CH; | |
219 | goto con; | |
220 | ||
221 | case CONST: | |
222 | j = DA; | |
223 | ||
224 | con: | |
225 | i = *s++; | |
226 | p = newdat(j, i==1?0:1, i); | |
227 | s += copy(j, s, p->datap, i); | |
228 | push(p); | |
229 | goto loop; | |
230 | ||
231 | case QUAD: | |
232 | push(newdat(QD,0,0)); | |
233 | goto loop; | |
234 | ||
235 | case QQUAD: | |
236 | push(newdat(QQ,0,0)); | |
237 | goto loop; | |
238 | ||
239 | case CQUAD: | |
240 | push(newdat(QC,0,0)); | |
241 | goto loop; | |
242 | } | |
243 | } | |
244 | ||
245 | static int comop; | |
246 | ||
247 | charfun(op, p, p1) | |
248 | struct item *p, *p1; | |
249 | { | |
250 | register char c, *cxi; | |
251 | register double *dxi; | |
252 | int i; | |
253 | ||
254 | comop = op; | |
255 | switch(op) { | |
256 | default: | |
257 | error("Y D E"); | |
258 | case LT: | |
259 | case LE: | |
260 | case EQ: | |
261 | case GE: | |
262 | case GT: | |
263 | case NE: | |
264 | /* OK */; | |
265 | } | |
266 | if(!p->rank) { | |
267 | c = *((char*)(p->datap)); | |
268 | cxi = (char*)(p1->datap); | |
269 | push(newdat(DA,p1->rank,p1->size)); | |
270 | copy(IN, p1->dim, sp[-1]->dim, p1->rank); | |
271 | dxi = sp[-1]->datap; | |
272 | for(i=0; i<p1->size; i++) | |
273 | *dxi++ = (double)charcom(c,*cxi++); | |
274 | goto done; | |
275 | } | |
276 | if(!p1->rank) { | |
277 | c = ((char*)(p1->datap))[0]; | |
278 | cxi = (char*)(p->datap); | |
279 | push(newdat(DA,p->rank,p->size)); | |
280 | copy(IN, p->dim, sp[-1]->dim, p->rank); | |
281 | dxi = sp[-1]->datap; | |
282 | for(i=0; i<p->size; i++) | |
283 | *dxi++ = (double)charcom(*cxi++,c); | |
284 | goto done; | |
285 | } | |
286 | if(p1->rank != p->rank) | |
287 | error("dyadic Y C E"); | |
288 | for(i=0; i<p->rank; i++) | |
289 | if(p->dim[i]!=p1->dim[i]) | |
290 | error("dyadic Y C E"); | |
291 | cxi = (char*)(p1->datap); | |
292 | push(newdat(DA,p->rank,p->size)); | |
293 | copy(IN, p->dim, sp[-1]->dim, p->rank); | |
294 | dxi = sp[-1]->datap; | |
295 | for(i=0; i<p->size; i++) | |
296 | *dxi++ = (double)charcom(((char*)(p->datap))[i],*cxi++); | |
297 | done: dealloc(sp[-2]); | |
298 | dealloc(sp[-3]); | |
299 | sp[-3] = sp[-1]; | |
300 | sp -= 2; | |
301 | return; | |
302 | } | |
303 | ||
304 | charcom(c1, c2) | |
305 | register char c1, c2; | |
306 | { | |
307 | switch(comop) { | |
308 | case LE: | |
309 | return c1<=c2; | |
310 | case LT: | |
311 | return c1<c2; | |
312 | case EQ: | |
313 | return c1==c2; | |
314 | case NE: | |
315 | return c1!=c2; | |
316 | case GT: | |
317 | return c1>c2; | |
318 | case GE: | |
319 | return c1>=c2; | |
320 | } | |
321 | error("Y B"); /* "Cannot happen" */ | |
322 | } | |
323 | ||
324 | int ex_add(), ex_plus(), ex_sub(), ex_minus(), | |
325 | ex_mul(), ex_sgn(), ex_div(), ex_recip(), | |
326 | ex_mod(), ex_abs(), ex_min(), ex_floor(), | |
327 | ex_max(), ex_ceil(), ex_pwr(), ex_exp(), | |
328 | ex_log(), ex_loge(), ex_cir(), ex_pi(), | |
329 | ex_comb(), ex_fac(), ex_deal(), ex_rand(), | |
330 | ex_drho(), ex_mrho(), ex_diot(), ex_miot(), | |
331 | ex_rot0(), ex_rev0(), ex_dtrn(), ex_mtrn(), | |
332 | ex_dibm(), ex_mibm(), ex_gdu(), ex_gduk(), | |
333 | ex_gdd(), ex_gddk(), ex_exd(), ex_scan(), | |
334 | ex_exdk(), ex_scnk(), ex_iprod(), ex_oprod(), | |
335 | ex_br0(), ex_br(), ex_ddom(), ex_mdom(), | |
336 | ex_com(), ex_red(), ex_comk(), ex_redk(), | |
337 | ex_rot(), ex_rev(), ex_rotk(), ex_revk(), | |
338 | ex_cat(), ex_rav(), ex_catk(), ex_ravk(), | |
339 | ex_print(), ex_elid(), ex_index(), ex_hprint(), | |
340 | ex_lt(), ex_le(), ex_gt(), ex_ge(), | |
341 | ex_eq(), ex_ne(), ex_and(), ex_or(), | |
342 | ex_nand(), ex_nor(), ex_not(), ex_eps(), | |
343 | ex_meps(), ex_rep(), ex_take(), ex_drop(), | |
344 | ex_exd0(), ex_asgn(), ex_immed(), ex_fun(), | |
345 | ex_arg1(), ex_arg2(), ex_auto(), ex_rest(), | |
346 | ex_com0(), ex_red0(), ex_exd0(), ex_scn0(), | |
347 | ex_base(), ex_menc(); | |
348 | ||
349 | int (*exop[])() = | |
350 | { | |
351 | 0, /* 0 */ | |
352 | ex_add, /* 1 */ | |
353 | ex_plus, /* 2 */ | |
354 | ex_sub, /* 3 */ | |
355 | ex_minus, /* 4 */ | |
356 | ex_mul, /* 5 */ | |
357 | ex_sgn, /* 6 */ | |
358 | ex_div, /* 7 */ | |
359 | ex_recip, /* 8 */ | |
360 | ex_mod, /* 9 */ | |
361 | ex_abs, /* 10 */ | |
362 | ex_min, /* 11 */ | |
363 | ex_floor, /* 12 */ | |
364 | ex_max, /* 13 */ | |
365 | ex_ceil, /* 14 */ | |
366 | ex_pwr, /* 15 */ | |
367 | ex_exp, /* 16 */ | |
368 | ex_log, /* 17 */ | |
369 | ex_loge, /* 18 */ | |
370 | ex_cir, /* 19 */ | |
371 | ex_pi, /* 20 */ | |
372 | ex_comb, /* 21 */ | |
373 | ex_fac, /* 22 */ | |
374 | ex_deal, /* 23 */ | |
375 | ex_rand, /* 24 */ | |
376 | ex_drho, /* 25 */ | |
377 | ex_mrho, /* 26 */ | |
378 | ex_diot, /* 27 */ | |
379 | ex_miot, /* 28 */ | |
380 | ex_rot0, /* 29 */ | |
381 | ex_rev0, /* 30 */ | |
382 | ex_dtrn, /* 31 */ | |
383 | ex_mtrn, /* 32 */ | |
384 | ex_dibm, /* 33 */ | |
385 | ex_mibm, /* 34 */ | |
386 | ex_gdu, /* 35 */ | |
387 | ex_gduk, /* 36 */ | |
388 | ex_gdd, /* 37 */ | |
389 | ex_gddk, /* 38 */ | |
390 | ex_exd, /* 39 */ | |
391 | ex_scan, /* 40 */ | |
392 | ex_exdk, /* 41 */ | |
393 | ex_scnk, /* 42 */ | |
394 | ex_iprod, /* 43 */ | |
395 | ex_oprod, /* 44 */ | |
396 | 0, /* 45 */ | |
397 | 0, /* 46 */ | |
398 | ex_br0, /* 47 */ | |
399 | ex_br, /* 48 */ | |
400 | ex_ddom, /* 49 */ | |
401 | ex_mdom, /* 50 */ | |
402 | ex_com, /* 51 */ | |
403 | ex_red, /* 52 */ | |
404 | ex_comk, /* 53 */ | |
405 | ex_redk, /* 54 */ | |
406 | ex_rot, /* 55 */ | |
407 | ex_rev, /* 56 */ | |
408 | ex_rotk, /* 57 */ | |
409 | ex_revk, /* 58 */ | |
410 | ex_cat, /* 59 */ | |
411 | ex_rav, /* 60 */ | |
412 | ex_catk, /* 61 */ | |
413 | ex_ravk, /* 62 */ | |
414 | ex_print, /* 63 */ | |
415 | 0, /* 64 */ | |
416 | ex_elid, /* 65 */ | |
417 | 0, /* 66 */ | |
418 | 0, /* 67 */ | |
419 | ex_index, /* 68 */ | |
420 | ex_hprint, /* 69 */ | |
421 | 0, /* 70 */ | |
422 | ex_lt, /* 71 */ | |
423 | ex_le, /* 72 */ | |
424 | ex_gt, /* 73 */ | |
425 | ex_ge, /* 74 */ | |
426 | ex_eq, /* 75 */ | |
427 | ex_ne, /* 76 */ | |
428 | ex_and, /* 77 */ | |
429 | ex_or, /* 78 */ | |
430 | ex_nand, /* 79 */ | |
431 | ex_nor, /* 80 */ | |
432 | ex_not, /* 81 */ | |
433 | ex_eps, /* 82 */ | |
434 | ex_meps, /* 83 */ | |
435 | ex_rep, /* 84 */ | |
436 | ex_take, /* 85 */ | |
437 | ex_drop, /* 86 */ | |
438 | ex_exd0, /* 87 */ | |
439 | ex_asgn, /* 88 */ | |
440 | ex_immed, /* 89 */ | |
441 | 0, /* 90 */ | |
442 | 0, /* 91 */ | |
443 | ex_fun, /* 92 */ | |
444 | ex_arg1, /* 93 */ | |
445 | ex_arg2, /* 94 */ | |
446 | ex_auto, /* 95 */ | |
447 | ex_rest, /* 96 */ | |
448 | ex_com0, /* 97 */ | |
449 | ex_red0, /* 98 */ | |
450 | ex_exd0, /* 99 */ | |
451 | ex_scn0, /*100 */ | |
452 | ex_base, /*101 */ | |
453 | ex_menc, /*102 */ /* monadic encod */ | |
454 | }; |