![[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] / 43BSD / contrib / apl / src|
Return to a1.c CVS log | Up to [CSRG BSD Unix] / 43BSD / contrib / apl / src |
1.1 root 1: static char Sccsid[] = "a1.c @(#)a1.c 1.1 10/1/82 Berkeley ";
2: #include "apl.h"
3:
4: execute(s)
5: char *s;
6: {
7: register i;
8: register data *dp;
9: register struct item *p;
10: struct item *p1;
11: int j;
12: data (*f)(), d;
13: extern char *opname[];
14: char *psiskp();
15:
16: if(debug)
17: dump(s,0);
18:
19: loop:
20: i = *s++;
21: if(i != EOF)
22: i &= 0377;
23: lastop = i;
24: if(debug && i >= 0)
25: printf(" exec %s\n", opname[i]);
26: switch(i) {
27:
28: default:
29: error("exec B");
30:
31: case EOF:
32: return;
33:
34: case EOL:
35: pop();
36: goto loop;
37:
38: case COMNT:
39: *sp++ = newdat(DA, 1, 0);
40: goto loop;
41:
42: case ADD:
43: case SUB:
44: case MUL:
45: case DIV:
46: case MOD:
47: case MIN:
48: case MAX:
49: case PWR:
50: case LOG:
51: case CIR:
52: case COMB:
53: case AND:
54: case OR:
55: case NAND:
56: case NOR:
57: f = exop[i];
58: p = fetch2();
59: p1 = sp[-2];
60: ex_dscal(0, f, p, p1);
61: goto loop;
62:
63:
64: case LT:
65: case LE:
66: case EQ:
67: case GE:
68: case GT:
69: case NE:
70: f = exop[i];
71: p = fetch2();
72: p1 = sp[-2];
73: ex_dscal(1, f, p, p1);
74: goto loop;
75:
76:
77: case PLUS:
78: case MINUS:
79: case SGN:
80: case RECIP:
81: case ABS:
82: case FLOOR:
83: case CEIL:
84: case EXP:
85: case LOGE:
86: case PI:
87: case RAND:
88: case FAC:
89: case NOT:
90: f = exop[i];
91: p = fetch1();
92: if(p->type != DA)
93: error("monadic T");
94: dp = p->datap;
95: for(i=0; i<p->size; i++) {
96: *dp = (*f)(*dp);
97: dp++;
98: }
99: goto loop;
100:
101: case MEPS: /* execute */
102: case MENC: /* monadic encode */
103: case DRHO:
104: case DIOT:
105: case EPS:
106: case REP:
107: case BASE:
108: case DEAL:
109: case DTRN:
110: case CAT:
111: case CATK:
112: case TAKE:
113: case DROP:
114: case DDOM:
115: case MDOM:
116: case GDU:
117: case GDUK:
118: case GDD:
119: case GDDK:
120: case COM:
121: case COM0:
122: case COMK:
123: case EXD:
124: case EXD0:
125: case EXDK:
126: case ROT:
127: case ROT0:
128: case ROTK:
129: case MRHO:
130: case MTRN:
131: case RAV:
132: case RAVK:
133: case RED:
134: case RED0:
135: case REDK:
136: case SCAN:
137: case SCANK:
138: case SCAN0:
139: case REV:
140: case REV0:
141: case REVK:
142: case ASGN:
143: case INDEX:
144: case ELID:
145: case IPROD:
146: case OPROD:
147: case IMMED:
148: case HPRINT:
149: case PRINT:
150: case MIOT:
151: case MIBM:
152: case DIBM:
153: case BRAN0:
154: case BRAN:
155: case FUN:
156: case ARG1:
157: case ARG2:
158: case AUTO:
159: case REST:
160: case QRUN:
161: case QEXEC:
162: case FDEF:
163: case QFORK:
164: case QEXIT:
165: case QWAIT:
166: case QREAD:
167: case QWRITE:
168: case QUNLNK:
169: case QRD:
170: case QDUP:
171: case QAP:
172: case QKILL:
173: case QSEEK:
174: case QOPEN:
175: case QCREAT:
176: case QCLOSE:
177: case QCHDIR:
178: case QPIPE:
179: case QCRP:
180: case MFMT:
181: case DFMT:
182: case QNC:
183: case NILRET:
184: case LABEL:
185: case SICLR:
186: case SICLR0:
187: case QSIGNL:
188: case QFLOAT:
189: case QNL:
190: pcp = s;
191: (*exop[i])();
192: s = pcp;
193: goto loop;
194:
195: case RVAL: /* de-referenced LVAL */
196: s += copy(IN, s, &p1, 1);
197: if(((struct nlist *)p1)->use != DA)
198: ex_nilret(); /* no fn rslt */
199: else
200: *sp++ = fetch(p1);
201: goto loop;
202:
203: case NAME:
204: s += copy(IN, s, sp, 1);
205: sp++;
206: goto loop;
207:
208: case QUOT:
209: j = CH;
210: goto con;
211:
212: case CONST:
213: j = DA;
214:
215: con:
216: i = *s++;
217: p = newdat(j, i==1?0:1, i);
218: s += copy(j, s, p->datap, i);
219: *sp++ = p;
220: goto loop;
221:
222: case QUAD:
223: *sp++ = newdat(QD, 0, 0);
224: goto loop;
225:
226: case XQUAD:
227: *sp++ = newdat(QX, 0, 0);
228: goto loop;
229:
230: case QQUAD:
231: *sp++ = newdat(QQ, 0, 0);
232: goto loop;
233:
234: case CQUAD:
235: *sp++ = newdat(QC, 0, 0);
236: goto loop;
237:
238: case PSI1:
239: p = fetch1();
240: if (p->size != 0){
241: pop();
242: goto loop;
243: }
244: else s = psiskp (s);
245: goto loop;
246: case ISP1:
247: p = fetch1();
248: if (p->size == 0){
249: pop();
250: goto loop;
251: }
252: else s = psiskp (s);
253: goto loop;
254:
255: case PSI2:
256: case ISP2:
257: goto loop;
258: }
259: }
260:
261: char *
262: psiskp (s)
263: char *s;
264: {
265: register i;
266: register struct item *p;
267: register cnt;
268:
269: pop();
270: cnt = 1;
271: psilp:
272: i = *s++;
273: switch (i){
274: default:
275: goto psilp;
276: case NAME:
277: s += copy(IN,s,sp,1);
278: sp++;
279: pop();
280: goto psilp;
281: case QUOT:
282: i = *s++;
283: s += i;
284: goto psilp;
285: case CONST:
286: i = *s++;
287: s += i * SDAT;
288: goto psilp;
289: case PSI1:
290: case ISP1:
291: cnt++;
292: goto psilp;
293:
294: case PSI2:
295: case ISP2:
296: if((--cnt) == 0) {
297: *sp++ = newdat (DA, 1, 0);
298: return (s);
299: }
300: goto psilp;
301: }
302: }
303:
304: ex_dscal(m, f, p1, p2)
305: int (*f)();
306: struct item *p1, *p2;
307: {
308: if(p1->type != p2->type)
309: error("dyadic C");
310: if(p1->type == CH )
311: if(m)
312: ex_cdyad(f, p1, p2);
313: else
314: error("dyadic T");
315: else
316: ex_ddyad(f, p1, p2);
317: }
318:
319: ex_ddyad(f, ap, ap1)
320: data (*f)();
321: struct item *ap, *ap1;
322: {
323: register i;
324: register struct item *p;
325: register data *dp;
326: struct item *p1;
327: data d;
328:
329:
330: /* Conform arguments to function if necessary. If they
331: * do not conform and one argument is a scalar, extend
332: * it into an array with the same dimensions as the
333: * other argument. If neither argument is a scalar, but
334: * one is a 1-element vector, extend its shape to match
335: * the other argument.
336: */
337:
338: p = ap;
339: p1 = ap1;
340:
341: if(p->rank < 2 && p->size == 1 && p1->rank != 0){
342: d = p->datap[0];
343: pop();
344: p = p1;
345: dp = p->datap;
346: for(i=0; i<p->size; i++) {
347: *dp = (*f)(d, *dp);
348: dp++;
349: }
350: return;
351: }
352: if(p1->rank < 2 && p1->size == 1) {
353: sp--;
354: d = p1->datap[0];
355: pop();
356: *sp++ = p;
357: dp = p->datap;
358: for(i=0; i<p->size; i++) {
359: *dp = (*f)(*dp, d);
360: dp++;
361: }
362: return;
363: }
364: if(p1->rank != p->rank)
365: error("dyadic C");
366: for(i=0; i<p->rank; i++)
367: if(p->dim[i] != p1->dim[i])
368: error("dyadic C");
369: dp = p1->datap;
370: for(i=0; i<p->size; i++) {
371: *dp = (*f)(p->datap[i], *dp);
372: dp++;
373: }
374: pop();
375: }
376:
377: ex_cdyad(f, ap, ap1)
378: data (*f)();
379: struct item *ap, *ap1;
380: {
381: register i;
382: register struct item *p;
383: register char *cp;
384: struct item *p1;
385: data d1, d2;
386:
387: p = ap;
388: p1 = ap1;
389: if(p->rank == 0 || p->size == 1) {
390: d1 = ((struct chrstrct *)p->datap)->c[0];
391: pop();
392: p = p1;
393: cp = (char *)p->datap;
394: for(i=0; i<p->size; i++) {
395: d2 = *cp;
396: *cp = (*f)(d1, d2);
397: cp++;
398: }
399: } else if(p1->rank == 0 || p1->size == 1) {
400: sp--;
401: d1 = ((struct chrstrct *)p1->datap)->c[0];
402: pop();
403: *sp++ = p;
404: cp = (char *)p->datap;
405: for(i=0; i<p->size; i++) {
406: d2 = *cp;
407: *cp = (*f)(d2, d1);
408: cp++;
409: }
410: } else {
411: if(p1->rank != p->rank)
412: error("dyadic C");
413: for(i=0; i<p->rank; i++)
414: if(p->dim[i] != p1->dim[i])
415: error("dyadic C");
416: cp = (char *)p1->datap;
417: for(i=0; i<p->size; i++) {
418: d1 = ((struct chrstrct *)p->datap)->c[i];
419: d2 = *cp;
420: *cp = (*f)(d1, d2);
421: cp++;
422: }
423: p = p1;
424: pop();
425: }
426: /*
427: * now convert the character vector to
428: * a numeric array. Someday, we can make this a
429: * call to whomever creates "logical" type data.
430: */
431: p1 = p;
432: cp = (char *)p->datap;
433: p = newdat(DA, p->rank, p->size);
434: for(i=0; i<p->rank; i++)
435: p->dim[i] = p1->dim[i];
436: for(i=0; i<p->size; i++)
437: p->datap[i] = (*cp++) & 0377;
438: pop();
439: *sp++ = p;
440: }
441:
442: /*
443: * exop[] moved to seperate file "at.c"
444: * (a1.c had a "symbol table overflow".)
445: */
446:
447: ex_botch()
448: {
449: error("exec P E");
450: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.