![[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.