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