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