![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to a0.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 a0.c CVS log | Up to [CSRG BSD Unix] / 43BSD / contrib / apl / src |
1.1 root 1: static char Sccsid[] = "a0.c @(#)a0.c 1.4 6/4/85 Berkeley ";
2: #include <signal.h>
3: #include "apl.h"
4: #include <math.h>
5: int chartab[];
6: int mkcore = 0; /* produce core image upon fatal error */
7: int edmagic = 0; /* turn on "ed" magic characters */
8:
9: main(argc, argp)
10: char **argp;
11: {
12: register char *p;
13: register a, b;
14: int c;
15: int fflag;
16: int intr(), intprws();
17: extern headline[];
18: #ifdef NBUF
19: struct iobuf iobf[NBUF]; /* Actual buffers */
20: #endif
21:
22: time(&stime);
23: #ifdef NBUF
24: iobuf = iobf; /* Set up buffer pointer */
25: initbuf(); /* Set up to run */
26: #endif
27: /*
28: * setup scratch files
29: */
30: a = getpid();
31: scr_file = "/tmp/apled.000000";
32: ws_file = "/tmp/aplws.000000";
33: for(c=16; c > 10; c--){
34: b = '0' + a%10;
35: scr_file[c] = b;
36: ws_file[c] = b;
37: a /= 10;
38: }
39: offexit = isatty(0);
40: echoflg = !offexit;
41: a = 1; /* catch signals */
42:
43: /* Check to see if argp[0] is "prws". If so, set prwsflg */
44:
45: for(p=argp[0]; *p; p++);
46: while(p > argp[0] && *p != '/') p--;
47: if (*p == '/') p++;
48: for(c=0; c < 4; c++)
49: if (!p[c] || p[c] != "prws"[c])
50: goto notprws;
51: prwsflg = 1;
52: CLOSEF(0);
53: notprws:
54:
55: /* other flags... */
56:
57: while(argc > 1 && argp[1][0] == '-'){
58: argc--;
59: argp++;
60: while(*++*argp) switch(**argp){
61: case 'e': echoflg = 1; break;
62: case 'q': echoflg = 0; break;
63: case 'd':
64: case 'D': a = 0;
65: case 'c':
66: case 'C': mkcore = 1; break;
67: case 't': scr_file += 5;
68: ws_file += 5;
69: case 'm': apl_term = 1; break;
70: case 'r': edmagic = 1; break;
71: case 'o': offexit = 0; break;
72: }
73: }
74:
75: if (prwsflg)
76: echoflg = mkcore = a = 0; /* "prws" settings */
77:
78: thread.iorg = 1;
79: srand(thread.rl = 1);
80: thread.width = 72;
81: thread.digits = 9;
82: thread.fuzz = 1.0e-13;
83:
84: aplmod(1); /* Turn on APL mode */
85: if (a)
86: catchsigs();
87: if (prwsflg)
88: signal(SIGINT, intprws);
89: else
90: fppinit();
91:
92: /*
93: * open ws file
94: */
95:
96: CLOSEF(opn(WSFILE,0600));
97: wfile = opn(WSFILE,2);
98: zero = 0;
99: one = 1;
100: maxexp = 88;
101: pi = 3.141592653589793238462643383;
102:
103: sp = stack;
104: fflag = 1;
105: if (!prwsflg){
106: if((unsigned)signal(SIGINT, intr) & 01)
107: signal(SIGINT, 1);
108: printf(headline);
109: }
110: setexit();
111: if(fflag) {
112: fflag = 0;
113: if(argc > 1 && (a = opn(argp[1], 0)) > 0){
114: wsload(a);
115: printf(" %s\n", argp[1]);
116: CLOSEF(a);
117: } else {
118: if((a=OPENF("continue",0)) < 0) {
119: printf("clear ws\n");
120: } else {
121: wsload(a);
122: printf(" continue\n");
123: CLOSEF(a);
124: }
125: }
126: if (prwsflg){
127: ex_prws();
128: term(0);
129: }
130: evLlx(); /* eval latent expr, if any */
131: }
132: mainloop();
133: }
134:
135: mainloop()
136: {
137: register char *a, *comp;
138: static eotcount = MAXEOT; /* maximum eot's on input */
139:
140: setexit();
141: while(1){
142: if(echoflg)
143: echoflg = 1; /* enabled echo echo suppress off */
144: checksp();
145: if(intflg)
146: error("I");
147: putchar('\t');
148: a = rline(8);
149: if(a == 0) {
150: offexit &= isatty(0);
151: if (offexit) {
152: if (eotcount-- > 0)
153: printf("\ruse \')off\' to exit\n");
154: else
155: panic(0);
156: continue;
157: } else
158: term(0); /* close down and exit */
159: }
160: comp = compile(a, 0);
161: free(a);
162: if(comp == 0)
163: continue;
164: execute(comp);
165: free(comp);
166: /* note that if the execute errors out, then
167: * the allocated space pointed to by comp is never
168: * freed. This is hard to fix.
169: */
170: }
171: }
172:
173: intr()
174: {
175:
176: intflg = 1;
177: signal(SIGINT, intr);
178: SEEKF(0, 0L, 2);
179: }
180:
181: intprws()
182: {
183: /* "prws" interrupt -- restore old tty modes and exit */
184:
185: term(0177);
186: }
187:
188: char *
189: rline(s)
190: {
191: int rlcmp();
192: char line[CANBS];
193: register char *p;
194: register c, col;
195: char *cp, *retval;
196: char *dp;
197: int i,j;
198:
199: column = 0;
200: col = s;
201: p = line;
202: loop:
203: c = getchar();
204: if(intflg)
205: error("I");
206: switch(c) {
207:
208: case '\0':
209: case -1:
210: return(0);
211:
212: case '\b':
213: if(col)
214: col--;
215: goto loop;
216:
217: case '\t':
218: col = (col+8) & ~7;
219: goto loop;
220:
221: case ' ':
222: col++;
223: goto loop;
224:
225: case '\r':
226: col = 0;
227: goto loop;
228:
229: default:
230: if (p >= line+CANBS-2 || col > 127)
231: error("line too long");
232: *p++ = col;
233: *p++ = c; /* was and'ed with 0177... */
234: col++;
235: goto loop;
236:
237: case '\n':
238: ;
239: }
240: qsort(line, (p-line)/2, 2, rlcmp);
241: c = p[-2];
242: if(p == line)
243: c = 1; /* check for blank line */
244: *p = -1;
245: col = -1;
246: cp = (retval=alloc(c+3)) - 1;
247: for(p=line; p[0] != -1; p+=2) {
248: while(++col != p[0])
249: *++cp = ' ';
250: *++cp = p[1];
251: while(p[2] == col) {
252: if(p[3] != *cp) {
253: i = *cp ;
254: *cp = p[3];
255: break;
256: }
257: p += 2;
258: }
259: if(p[2] != col) continue;
260: while(p[2] == col) {
261: if(p[3] != *cp)
262: goto yuck;
263: p += 2;
264: }
265: #ifdef vax
266: i = ((i<<8) | *cp)&0177777;
267: #else
268: i |= *cp << 8;
269: #endif
270: for(j=0; chartab[j]; j++){
271: if(i == chartab[j]) {
272: *cp = j | 0200;
273: j = 0;
274: break;
275: }
276: }
277: if(j) {
278: yuck:
279: *cp = '\n';
280: pline(cp,++col);
281: error("Y error");
282: }
283: }
284: *++cp = '\n';
285: return(retval);
286: }
287:
288: rlcmp(a, b)
289: char *a, *b;
290: {
291: register c;
292:
293: if(c = a[0] - b[0])
294: return(c);
295: return(a[1] - b[1]);
296: }
297:
298: pline(str, loc)
299: char *str;
300: {
301: register c, l, col;
302:
303: col = 0;
304: l = 0;
305: do {
306: c = *str++;
307: l++;
308: if(l == loc)
309: col = column;
310: putchar(c);
311: } while(c != '\n');
312: if(col) {
313: putto(col);
314: putchar('^');
315: putchar('\n');
316: }
317: }
318:
319: putto(col)
320: {
321: while(col > column+8)
322: putchar('\t');
323: while(col > column)
324: putchar(' ');
325: }
326:
327: term(s)
328: {
329:
330: register j;
331:
332: unlink(WSFILE);
333: unlink(scr_file);
334: putchar('\n');
335: aplmod(0); /* turn off APL mode */
336: for(j=0; j<NFDS; j++) /* Close files */
337: CLOSEF(j);
338: exit(s);
339: }
340:
341: fix(d)
342: data d;
343: {
344: register i;
345:
346: i = floor(d+0.5);
347: return(i);
348: }
349:
350: fuzz(d1, d2)
351: data d1, d2;
352: {
353: double f1, f2;
354:
355: f1 = d1;
356: if(f1 < 0.)
357: f1 = -f1;
358: f2 = d2;
359: if(f2 < 0.)
360: f2 = -f2;
361: if(f2 > f1)
362: f1 = f2;
363: f1 *= thread.fuzz;
364: if(d1 > d2) {
365: if(d2+f1 >= d1)
366: return(0);
367: return(1);
368: }
369: if(d1+f1 >= d2)
370: return(0);
371: return(-1);
372: }
373:
374: pop()
375: {
376:
377: if(sp <= stack)
378: error("pop B");
379: dealloc(*--sp);
380: }
381:
382: erase(np)
383: struct nlist *np;
384: {
385: register *p;
386:
387: p = np->itemp;
388: if(p) {
389: switch(np->use) {
390: case NF:
391: case MF:
392: case DF:
393: for(; *p>0; (*p)--)
394: free(p[*p]);
395:
396: }
397: free(p);
398: np->itemp = 0;
399: }
400: np->use = 0;
401: }
402:
403: dealloc(p)
404: struct item *p;
405: {
406:
407: switch(p->type) {
408: default:
409: printf("[dealloc botch: %d]\n", p->type);
410: return;
411: case LBL:
412: ((struct nlist *)p)->use = 0; /* delete label */
413: case LV:
414: return;
415:
416: case DA:
417: case CH:
418: case QQ:
419: case QD:
420: case QC:
421: case EL:
422: case DU:
423: case QX:
424: free(p);
425: }
426: }
427:
428: struct item *
429: newdat(type, rank, size)
430: {
431: register i;
432: register struct item *p;
433:
434: /* Allocate a new data item. I have searched the specifications
435: * for C and as far as I can tell, it should be legal to
436: * declare a zero-length array inside a structure. However,
437: * the VAX C compiler (which I think is a derivative of the
438: * portable C compiler) does not allow this. The Ritchie
439: * V7 PDP-11 compiler does. I have redeclared "dim" to
440: * contain MRANK elements. When the data is allocated,
441: * space is only allocated for as many dimensions as there
442: * actually are. Thus, if there are 0 dimensions, no space
443: * will be allocated for "dim". This had better make the
444: * VAX happy, since it has sure made me unhappy.
445: *
446: * --John Bruner
447: */
448:
449:
450: if(rank > MRANK)
451: error("max R");
452: i = sizeof *p - SINT * (MRANK-rank);
453: if(type == DA)
454: i += size * SDAT; else
455: if(type == CH)
456: i += size;
457: p = alloc(i);
458: p->rank = rank;
459: p->type = type;
460: p->size = size;
461: p->index = 0;
462: if(rank == 1)
463: p->dim[0] = size;
464: p->datap = (data *)&p->dim[rank];
465: return(p);
466: }
467:
468: struct item *
469: dupdat(ap)
470: struct item *ap;
471: {
472: register struct item *p1, *p2;
473: register i;
474:
475: p1 = ap;
476: p2 = newdat(p1->type, p1->rank, p1->size);
477: for(i=0; i<p1->rank; i++)
478: p2->dim[i] = p1->dim[i];
479: copy(p1->type, p1->datap, p2->datap, p1->size);
480: return(p2);
481: }
482:
483: copy(type, from, to, size)
484: char *from, *to;
485: {
486: register i;
487: register char *a, *b;
488: int s;
489:
490: if((i = size) == 0)
491: return(0);
492: a = from;
493: b = to;
494: if(type == DA)
495: i *= SDAT; else
496: if(type == IN)
497: i *= SINT;
498: s = i;
499: do
500: *b++ = *a++;
501: while(--i);
502: return(s);
503: }
504:
505: struct item *
506: fetch1()
507: {
508: register struct item *p;
509:
510: p = fetch(sp[-1]);
511: sp[-1] = p;
512: return(p);
513: }
514:
515: struct item *
516: fetch2()
517: {
518: register struct item *p;
519:
520: sp[-2] = fetch(sp[-2]);
521: p = fetch(sp[-1]);
522: sp[-1] = p;
523: return(p);
524: }
525:
526: struct item *
527: fetch(ip)
528: struct item *ip;
529: {
530: register struct item *p, *q;
531: register i;
532: struct nlist *n;
533: int c;
534: struct chrstrct *cc;
535: extern prolgerr;
536:
537: p = ip;
538:
539: loop:
540: switch(p->type) {
541:
542: case QX:
543: free(p);
544: n = nlook("Llx");
545: if(n){
546: q = n->itemp;
547: p = dupdat(q);
548: copy(q->type, q->datap, p->datap, q->size);
549: } else
550: p = newdat(CH, 1, 0);
551: goto loop;
552:
553: case QQ:
554: free(p);
555: cc = rline(0);
556: if(cc == 0)
557: error("eof");
558: for(i=0; cc->c[i] != '\n'; i++)
559: ;
560: p = newdat(CH, 1, i);
561: copy(CH, cc, p->datap, i);
562: goto loop;
563:
564: case QD:
565: case QC:
566: printf("L:\n\t");
567: i = rline(8);
568: if(i == 0)
569: error("eof");
570: c = compile(i, 1);
571: free(i);
572: if(c == 0)
573: goto loop;
574: i = pcp;
575: execute(c);
576: pcp = i;
577: free(c);
578: free(p);
579: p = *--sp;
580: goto loop;
581:
582: case DU:
583: if(lastop != PRINT)
584: error("no fn result");
585:
586: case DA:
587: case CH:
588: p->index = 0;
589: return(p);
590:
591: case LV:
592:
593: /* KLUDGE --
594: *
595: * Currently, if something prevents APL from completing
596: * execution of line 0 of a function, it leaves with
597: * the stack in an unknown state and "gsip->oldsp" is
598: * zero. This is nasty because there is no way to
599: * reset out of it. The principle cause of error
600: * exits from line 0 is the fetch of an undefined
601: * function argument. The following code attempts
602: * to fix this by setting an error flag and creating
603: * a dummy variable for the stack if "used before set"
604: * occurs in the function header. "ex_fun" then will
605: * note that the flag is high and cause an error exit
606: * AFTER all header processing has been completed.
607: */
608:
609: if(((struct nlist *)p)->use != DA){
610: printf("%s: used before set",
611: ((struct nlist *)ip)->namep);
612: if ((!gsip) || gsip->funlc != 1)
613: error("");
614: q = newdat(DA, 0, 1); /* Dummy */
615: q->datap[0] = 0;
616: prolgerr = 1; /* ERROR flag */
617: return(q);
618: }
619: p = ((struct nlist *)p)->itemp;
620: i = p->type;
621: if(i == LBL)
622: i = DA; /* treat label as data */
623: q = newdat(i, p->rank, p->size);
624: copy(IN, p->dim, q->dim, p->rank);
625: copy(i, p->datap, q->datap, p->size);
626: return(q);
627:
628: default:
629: error("fetch B");
630: }
631: }
632:
633: topfix()
634: {
635: register struct item *p;
636: register i;
637:
638: p = fetch1();
639: if(p->type != DA || p->size != 1)
640: error("topval C");
641: i = fix(p->datap[0]);
642: pop();
643: return(i);
644: }
645:
646: bidx(ip)
647: struct item *ip;
648: {
649: register struct item *p;
650:
651: p = ip;
652: idx.type = p->type;
653: idx.rank = p->rank;
654: copy(IN, p->dim, idx.dim, idx.rank);
655: size();
656: }
657:
658: size()
659: {
660: register i, s;
661:
662: s = 1;
663: for(i=idx.rank-1; i>=0; i--) {
664: idx.del[i] = s;
665: s *= idx.dim[i];
666: }
667: idx.size = s;
668: return(s);
669: }
670:
671: colapse(k)
672: {
673: register i;
674:
675: if(k < 0 || k >= idx.rank)
676: error("collapse X");
677: idx.dimk = idx.dim[k];
678: idx.delk = idx.del[k];
679: for(i=k; i<idx.rank; i++) {
680: idx.del[i] = idx.del[i+1];
681: idx.dim[i] = idx.dim[i+1];
682: }
683: if (idx.dimk)
684: idx.size /= idx.dimk;
685: idx.rank--;
686: }
687:
688: forloop(co, arg)
689: int (*co)();
690: {
691: register i;
692:
693: if (idx.size == 0)
694: return; /* for null items */
695: if(idx.rank == 0) {
696: (*co)(arg);
697: return;
698: }
699: for(i=0;;) {
700: while(i < idx.rank)
701: idx.idx[i++] = 0;
702: (*co)(arg);
703: while(++idx.idx[i-1] >= idx.dim[i-1])
704: if(--i <= 0)
705: return;
706: }
707: }
708:
709: access()
710: {
711: register i, n;
712:
713: n = 0;
714: for(i=0; i<idx.rank; i++)
715: n += idx.idx[i] * idx.del[i];
716: return(n);
717: }
718:
719: data
720: getdat(ip)
721: struct item *ip;
722: {
723: register struct item *p;
724: register i;
725: data d;
726:
727: /* Get the data value stored at index p->index. If the
728: * index is out of range it will be wrapped around. If
729: * the data item is null, a zero or blank will be returned.
730: */
731:
732: p = ip;
733: i = p->index;
734: while(i >= p->size) {
735: if (p->size == 0) /* let the caller beware */
736: return((p->type == DA) ? zero : (data)' ');
737: /*
738: if (i == 0)
739: error("getdat B");
740: */
741: i -= p->size;
742: }
743: if(p->type == DA) {
744: d = p->datap[i];
745: } else
746: if(p->type == CH) {
747: d = ((struct chrstrct *)p->datap)->c[i];
748: } else
749: error("getdat B");
750: i++;
751: p->index = i;
752: return(d);
753: }
754:
755: putdat(ip, d)
756: data d;
757: struct item *ip;
758: {
759: register struct item *p;
760: register i;
761:
762: p = ip;
763: i = p->index;
764: if(i >= p->size)
765: error("putdat B");
766: if(p->type == DA) {
767: p->datap[i] = d;
768: } else
769: if(p->type == CH) {
770: ((struct chrstrct *)p->datap)->c[i] = d;
771: } else
772: error("putdat B");
773: i++;
774: p->index = i;
775: }
776:
777: /* aplmod has been moved to am.c */
778:
779: struct item *
780: s2vect(ap)
781: struct item *ap;
782: {
783: register struct item *p, *q;
784:
785: p = ap;
786: q = newdat(p->type, 1, 1);
787: q->datap = p->datap;
788: q->dim[0] = 1;
789: return(q);
790: }
791:
792: struct nlist *
793: nlook(name)
794: char *name;
795: {
796: register struct nlist *np;
797:
798: for(np = nlist; np->namep; np++)
799: if(equal(np->namep, name))
800: return(np);
801: return(0);
802: }
803:
804: checksp()
805: {
806: if(sp >= &stack[STKS])
807: error("stack overflow");
808: }
809: char *
810: concat(s1,s2)
811: char *s1, *s2;
812: {
813: register i,j;
814: char *p,*q;
815:
816: i = lsize(s1) - 1;
817: j = lsize(s2) - 1;
818: p = q = alloc(i+j);
819: p += copy(CH, s1, p, i);
820: copy(CH, s2, p, j);
821: return(q);
822: }
823:
824: char *
825: catcode(s1,s2)
826: char *s1, *s2;
827: {
828: register i,j;
829: char *p,*q;
830:
831: i = csize(s1) - 1;
832: j = csize(s2);
833: p = q = alloc(i+j);
834: p += copy(CH, s1, p, i);
835: copy(CH, s2, p, j);
836: return(q);
837: }
838:
839: /*
840: * csize -- return size (in bytes) of a compiled string
841: */
842: csize(s)
843: char *s;
844: {
845: register c,len;
846: register char *p;
847: int i;
848:
849: len = 1;
850: p = s;
851: while((c = *p++) != EOF){
852: len++;
853: c &= 0377;
854: switch(c){
855: default:
856: i = 0;
857: break;
858:
859: case QUOT:
860: i = *p++;
861: break;
862:
863: case CONST:
864: i = *p++;
865: i *= SDAT;
866: len++;
867: break;
868:
869: case NAME:
870: case FUN:
871: case ARG1:
872: case ARG2:
873: case AUTO:
874: case REST:
875: case RVAL:
876: i = 2;
877: break;
878: }
879: p += i;
880: len += i;
881: }
882: return(len);
883: }
884:
885: opn(file, rw)
886: char file[];
887: {
888: register fd, (*p)();
889: char f2[100];
890: extern OPENF(), CREATF();
891:
892: p = (rw > 2 ? CREATF : OPENF);
893: if((fd = (*p)(file,rw)) < 0){
894: for(fd=0; fd<13; fd++)
895: f2[fd] = LIBDIR[fd];
896: for(fd=0; file[fd]; fd++)
897: f2[fd+13] = file[fd];
898: f2[fd+13] = 0;
899: if((fd = (*p)(f2, rw)) >= 0){
900: printf("[using %s]\n", f2);
901: return(fd);
902: }
903: printf("can't open file %s\n", file);
904: error("");
905: }
906: return(fd);
907: }
908:
909: catchsigs()
910: {
911: extern panic();
912:
913: signal(SIGHUP, panic);
914: signal(SIGQUIT, panic);
915: signal(SIGILL, panic);
916: signal(SIGTRAP, panic);
917: signal(SIGEMT, panic);
918: /* signal(SIGFPE, fpe); /* (fppinit called by "main") */
919: signal(SIGBUS, panic);
920: signal(SIGSEGV, panic);
921: signal(SIGSYS, panic);
922: signal(SIGPIPE, panic);
923: signal(SIGTERM, panic);
924: }
925:
926: panic(signum)
927: unsigned signum;
928: {
929:
930: register fd;
931: static insane = 0; /* if != 0, die */
932: static char *abt_file = "aplws.abort";
933: static char *errtbl[] = {
934: "excessive eofs",
935: "hangup",
936: "interrupt",
937: "quit",
938: "illegal instruction",
939: "trace trap",
940: "i/o trap instruction",
941: "emt trap",
942: "floating exception",
943: "kill",
944: "bus error",
945: "segmentation violation",
946: "bad system call",
947: "write no pipe",
948: "alarm clock",
949: "software termination"
950: };
951:
952: /* Attempt to save workspace. A signal out of here always
953: * causes immediate death.
954: */
955:
956: mencflg = 0;
957: signal(signum, panic);
958: printf("\nfatal signal: %s\n",
959: errtbl[(signum < NSIG) ? signum : 0]);
960:
961: if (mkcore) abort();
962:
963: if (!insane++){
964: if ((fd=CREATF(abt_file, 0644)) >= 0){
965: printf("[attempting ws dump]\n");
966: wssave(fd);
967: printf(" workspace saved in %s\n", abt_file);
968: CLOSEF(fd);
969: } else
970: printf("workspace lost -- sorry\n");
971: } else
972: printf("recursive errors: unrecoverable\n");
973:
974: term(0);
975: }
976: #ifdef vax
977: abort(){
978: kill(getpid(), SIGIOT);
979: exit(1);
980: }
981: #endif
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.