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