![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to a1.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 40BSD / cmd / apl|
Return to a1.c CVS log | Up to [CSRG BSD Unix] / 40BSD / cmd / apl |
1.1 root 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: };
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.