2.11BSD#431 - /usr/src/new/OLD/apl/src/ai.c

   1: static char Sccsid[] = "ai.c @(#)ai.c	1.2	10/1/82 Berkeley ";
   2: #include <signal.h>
   3: #include "apl.h"
   4: 
   5: char *bad_fn  = "apl.badfn";
   6: int prolgerr;       /* Flag -- set if bad fetch in prologue */
   7: 
   8: /*
   9:  * funedit -- edit a file and read it in.
  10:  *
  11:  * If the arg to funedit is non-zero, it is used as a
  12:  * pointer to the file name to be used.  If it is zero,
  13:  * the namep of the function is used for the file name.
  14:  */
  15: funedit(fname, editor)
  16: char *fname;
  17: {
  18:     register struct item *p;
  19:     register f, (*a)();
  20:     char *c;
  21:     extern edmagic;
  22: 
  23:     p = sp[-1];
  24:     if(p->type != LV)
  25:         error("fed B");
  26:     sichk(p);
  27:     if(fname == 0)
  28:         fname = ((struct nlist *)p)->namep;
  29:     a = signal(SIGINT, SIG_IGN);
  30:     f = FORKF(1);
  31:     if(f == 0) {
  32:         for(f=3; f<7; f++)
  33:             close(f);
  34:         c = (editor == DEL ? "/usr/bin/apldel" : "/usr/local/xed");
  35:         execl(c+9, c+9, fname, "-f", apl_term ? "-A":"-a", "-p", edmagic ? "-r":0, 0);
  36:         execl(c+4, c+9, fname, "-f", apl_term ? "-A":"-a", "-p", edmagic ? "-r":0, 0);
  37:         execl(c, c+9, fname, "-f", apl_term ? "-A":"-a", "-p", edmagic ? "-r":0, 0);
  38:         printf("cannot find the editor!\n");
  39:         exit(1);
  40:     }
  41:     if(f == -1)
  42:         error("try again");
  43:     while(wait(0) != f)
  44:         ;
  45:     signal(SIGINT, a);
  46: 
  47:     /* Read function into workspace.  If "funread" (which calls
  48: 	 * "fundef") returns 0, an error occurred in processing the
  49: 	 * header (line 0).  If this happened with "editf" or "del",
  50: 	 * save the bad function in the file "bad_fn".
  51: 	 */
  52: 
  53:     if (funread(fname) == 0 && fname == scr_file){
  54:         unlink(bad_fn);
  55:         if (badfnsv(fname))
  56:             printf("function saved in %s\n", bad_fn);
  57:     }
  58: }
  59: 
  60: 
  61: funread(fname)
  62: char *fname;
  63: {
  64:     register struct item *p;
  65:     register f, pid;
  66: 
  67:     p = sp[-1];
  68:     sp--;
  69:     if(p->type != LV)
  70:         error("fnl B");
  71:     if(fname == 0)
  72:         fname = ((struct nlist *)p)->namep;
  73:     f = opn(fname, 0);
  74:     return(fundef(f));
  75: }
  76: 
  77: funwrite(fname)
  78: char *fname;
  79: {
  80:     register struct nlist *n;
  81:     register i, cnt;
  82:     int fd1, fd2;
  83:     char buf[512];
  84: 
  85:     n = (struct nlist *)sp[-1];
  86:     sp--;
  87:     if(n->type != LV)
  88:         error("fnwrite B");
  89:     if(fname ==0)
  90:         fname = n->namep;
  91:     fd1 = opn(fname, 0644);
  92:     switch(n->use){
  93:     default:
  94:         CLOSEF(fd1);
  95:         error("fnwrite T");
  96: 
  97:     case 0:         /* undefined fn */
  98:         printf("\t[new fn]\n");
  99:         break;      /* empty file already created -- do nothing */
 100: 
 101:     case NF:
 102:     case MF:
 103:     case DF:
 104:         fd2 = DUPF(wfile);
 105:         SEEKF(fd2, (long)n->label, 0);
 106:         do {
 107:             cnt = READF(fd2, buf, 512);
 108:             if(cnt <= 0)
 109:                 error("fnwrite eof");
 110:             for(i=0; i<cnt; i++)
 111:                 if(buf[i] == 0)
 112:                     break;
 113:             WRITEF(fd1, buf, i);
 114:         } while(i == 512);
 115:         CLOSEF(fd2);
 116:         break;
 117:     }
 118:     CLOSEF(fd1);
 119: }
 120: 
 121: fundef(f)
 122: {
 123:     register a, c;
 124:     struct nlist *np;
 125:     char b[512];
 126: 
 127:     ifile = f;
 128:     a = rline(0);
 129:     if(a == 0)
 130:         error("fnd eof");
 131:     c = compile(a, 2);
 132:     free(a);
 133:     if(c == 0)
 134:         goto out;
 135:     copy(IN, c+1, &np, 1);
 136:     sichk(np);
 137:     erase(np);
 138:     np->use = ((struct chrstrct *)c)->c[0];
 139:     np->label = SEEKF(wfile, 0L, 2);
 140:     SEEKF(ifile, 0L, 0);
 141:     while((a=READF(ifile, b, 512)) > 0)
 142:         WRITEF(wfile, b, a);
 143:     WRITEF(wfile, "", 1);
 144: out:
 145:     CLOSEF(ifile);
 146:     ifile = 0;
 147:     return(c);
 148: }
 149: 
 150: data lnumb;
 151: char *labcpp,*labcpe;
 152: 
 153: funcomp(np)
 154: struct nlist *np;
 155: {
 156:     register char *a, *c;
 157:     register  *p;
 158:     int i, err, size;
 159:     char labp[MAXLAB*20], labe[MAXLAB*4];
 160: 
 161:     ifile = DUPF(wfile);
 162:     SEEKF(ifile, (long)np->label, 0);
 163:     size = 0;
 164:     err = 0;
 165: 
 166:     labgen = 0;
 167: pass1:
 168:     a = rline(0);
 169:     if(a == 0) {
 170:         if(err)
 171:             goto out;
 172:         p = (int *)alloc((size+2)*SINT);
 173:         *p = size;
 174:         size = 0;
 175:         SEEKF(ifile, (long)np->label, 0);
 176:         err++;
 177:         labcpp = labp;
 178:         labcpe = labe;
 179:         labgen = 1;
 180:         goto pass2;
 181:     }
 182:     c = compile(a, size==0? 3: 5);
 183:     size++;
 184:     free(a);
 185:     if(c == 0) {
 186:         err++;
 187:         goto pass1;
 188:     }
 189:     free(c);
 190:     goto pass1;
 191: 
 192: pass2:
 193:     a = rline(0);
 194:     if(a == 0)
 195:         goto pass3;
 196:     lnumb = size;
 197:     c = compile(a, size==0? 3: 5);
 198:     size++;
 199:     free(a);
 200:     if(c == 0)
 201:         goto out;
 202:     p[size] = c;
 203:     goto pass2;
 204: 
 205: pass3:
 206:     labgen = 0;
 207:     SEEKF(ifile, (long)np->label, 0);
 208:     a = rline(0);
 209:     if(a == 0){
 210:         err++;
 211:         goto out;
 212:     }
 213:     c = compile(a, 4);
 214:     free(a);
 215:     if(c == 0)
 216:         goto out;
 217:     if(labcpp != labp){
 218:         reverse(labe);
 219:         p[size+1] = catcode(labe, c);
 220:         free(c);
 221:         /*
 222: 		/*		*** KLUDGE ***
 223: 		/*
 224: 		/* due to the "line-at-a-time" nature of the parser,
 225: 		/* we have to screw around with the compiled strings.
 226: 		/*
 227: 		/* At this point, we have:
 228: 		/*
 229: 		/* fn-prologue (p[1]):		<AUTOs and ARGs>, ELID, EOF
 230: 		/* label-prologue (labp):	<AUTOs and LABELs>, EOF
 231: 		/*
 232: 		/* and we want to produce:
 233: 		/*
 234: 		/* fn-prologue (p[1]):	<AUTOs and ARGs>,<AUTOs and LABELs>,  ELID, EOF.
 235: 		 */
 236:         a = csize(p[1]) - 1;
 237:         c = csize(labp) - 1;
 238:         /*
 239: 		 * if there is an ELID at the end of the fn-prologue,
 240: 		 * move it to  the end of the label-prologue.
 241: 		 */
 242:         if (p[1]->c[(int)a-1] == ELID){
 243:             p[1]->c[(int)a-1] = EOF;
 244:             labp[(int)c] = ELID;
 245:             labp[(int)c+1] = EOF;
 246:         } else
 247:             error("elid B");
 248:         /* *** END KLUDGE *** */
 249:         a = p[1];
 250:         p[1] = catcode(a,labp);
 251:         free(a);
 252:     } else
 253:         p[size+1] = c;
 254:     if(debug) {
 255:         dump(p[1], 1);
 256:         dump(p[size+1], 1);
 257:     }
 258:     np->itemp = (struct item *)p;
 259:     err = 0;
 260: 
 261: out:
 262:     CLOSEF(ifile);
 263:     ifile = 0;
 264:     if(err)
 265:         error("syntax");
 266: }
 267: 
 268: ex_fun()
 269: {
 270:     struct nlist *np;
 271:     register *p, s;
 272:     struct si si;
 273: 
 274:     pcp += copy(IN, pcp, &np, 1);
 275:     if (np->use < NF || np->use > DF) {
 276:         printf("%s: ", np->namep);
 277:         error("not a fn");
 278:     }
 279:     if(np->itemp == 0)
 280:         funcomp(np);
 281:     p = (int *)np->itemp;
 282:     /* setup new state indicator */
 283:     si.sip = gsip;
 284:     gsip = &si;
 285:     si.np = np;
 286:     si.oldsp = 0;       /* we can add a more complicated version, later */
 287:     si.oldpcp = pcp;
 288:     si.funlc = 0;
 289:     si.suspended = 0;
 290:     prolgerr = 0;       /* Reset error flag */
 291:     s = *p;
 292:     checksp();
 293:     if(funtrace)
 294:         printf("\ntrace: fn %s entered: ", np->namep);
 295:     if (setjmp(si.env))
 296:         goto reenter;
 297:     while(1){
 298:         si.funlc++;
 299:         if(funtrace)
 300:             printf("\ntrace: fn %s[%d]: ", np->namep, si.funlc-1);
 301:         execute(p[si.funlc]);
 302:         if(si.funlc == 1){
 303:             si.oldsp = sp;
 304:             if (prolgerr)
 305:                 error("");
 306:         }
 307:         if(intflg)
 308:             error("I");
 309:     reenter:
 310:         if(si.funlc <= 0 || si.funlc >= s) {
 311:             si.funlc = 1;   /* for pretty traceback */
 312:             if(funtrace)
 313:                 printf("\ntrace: fn %s exits ", np->namep);
 314:             execute(p[s+1]);
 315:             /* restore state indicator to previous state */
 316:             gsip = si.sip;
 317:             pcp = si.oldpcp;
 318:             return;
 319:         }
 320:         pop();
 321:     }
 322: }
 323: 
 324: ex_arg1()
 325: {
 326:     register struct item *p;
 327:     struct nlist *np;
 328: 
 329:     pcp += copy(IN, pcp, &np, 1);
 330:     p = fetch1();
 331:     sp[-1] = np->itemp;
 332:     np->itemp = p;
 333:     np->use = DA;
 334: }
 335: 
 336: ex_arg2()
 337: {
 338:     register struct item *p1, *p2;
 339:     struct nlist *np1, *np2;
 340: 
 341:     pcp += copy(IN, pcp, &np2, 1);  /* get first argument's name */
 342:     pcp++;              /* skip over ARG1 */
 343:     pcp += copy(IN, pcp, &np1, 1);  /* get second arg's name */
 344:     p1 = fetch1();          /* get first expr to be bound to arg */
 345:     p2 = fetch(sp[-2]);     /* get second one */
 346:     sp[-1] = np1->itemp;        /* save old value of name on stack */
 347:     sp[-2] = np2->itemp;        /* save second */
 348:     np1->itemp = p1;        /* new arg1 binding */
 349:     np2->itemp = p2;        /* ditto arg2 */
 350:     np1->use = DA;          /* release safety catch */
 351:     np2->use = DA;
 352: }
 353: 
 354: ex_auto()
 355: {
 356:     struct nlist *np;
 357: 
 358:     pcp += copy(IN, pcp, &np, 1);
 359:     checksp();
 360:     *sp++ = np->itemp;
 361:     np->itemp = 0;
 362:     np->use = 0;
 363: }
 364: 
 365: ex_rest()
 366: {
 367:     register struct item *p;
 368:     struct nlist *np;
 369: 
 370:     p = sp[-1];
 371:     /*
 372: 	 * the following is commented out because
 373: 	 * of an obscure bug in the parser, which is
 374: 	 * too difficult to correct right now.
 375: 	 * the bug is related to the way the
 376: 	 * "fn epilog" is compiled.  To accomodate labels,
 377: 	 * it was kludged up to have the label restoration
 378: 	 * code added after the entire fn was parsed.  A problem
 379: 	 * is that the generated code is like:
 380: 	 *
 381: 	 * "rest-lab1 rest-lab2 eol rval-result rest-arg1 ..."
 382: 	 *
 383: 	 * the "eol rval-result" pops off the previous result, and
 384: 	 * puts a "fetched" version of the returned value (result)
 385: 	 * onto the stack.  The bug is that the "eol rval." should
 386: 	 * be output at the beginning of the fn epilog.
 387: 	 * The following two lines used to be a simple
 388: 	 * "p = fetch(p)", which is used to disallow
 389: 	 * a fn to return a LV, (by fetching it, it gets
 390: 	 * converted to a RVAL.)  Since we later added
 391: 	 * code which returned stuff which could not be
 392: 	 * fetched (the DU, dummy datum, for example),
 393: 	 * this thing had to be eliminated.  An earlier
 394: 	 * version only fetched LV's, but that was eliminated
 395: 	 * by adding the "RVAL" operator.  The test below
 396: 	 * was made a botch, because no LV's should ever be
 397: 	 * passed back.  However, for this to be true, the
 398: 	 * "eol" should be executed first, so that any possible
 399: 	 * LV's left around by the last line executed are
 400: 	 * discarded.  Since we have some "rest"s in the epilog
 401: 	 * before the eol, the following test fails.
 402: 	 * I can't think of why it won't work properly as it
 403: 	 * is, but if I had the time, I'd fix it properly.
 404: 	 *	--jjb
 405: 	 */
 406: /*	if(p->type == LV)
 407: 		error("rest B");	*/
 408:     pcp += copy(IN, pcp, &np, 1);
 409:     erase(np);
 410:     np->itemp = sp[-2];
 411:     np->use = 0;
 412:     if(np->itemp)
 413:         np->use = DA;
 414:     sp--;
 415:     sp[-1] = p;
 416: }
 417: 
 418: ex_br0()
 419: {
 420: 
 421:     gsip->funlc = 0;
 422:     ex_elid();
 423: }
 424: 
 425: ex_br()
 426: {
 427:     register struct item *p;
 428: 
 429:     p = fetch1();
 430:     if(p->size == 0)
 431:         return;
 432:     gsip->funlc = fix(getdat(p));
 433: }
 434: /*
 435:  * immediate niladic branch -- reset SI
 436:  */
 437: ex_ibr0()
 438: {
 439:     register struct si *s;
 440:     register *p;
 441: 
 442:     s = gsip;
 443:     if(s == 0)
 444:         error("no suspended fn");
 445:     if(s->suspended == 0)
 446:         error("imm } B1");
 447:     gsip->suspended = 0;
 448:     while((s = gsip) && s->suspended == 0){
 449:         if(s->oldsp == 0 || sp < s->oldsp)
 450:             error("imm } B2");
 451:         while(sp > s->oldsp){
 452:             pop();
 453:         }
 454:         pop();      /* pop off possibly bad previous result */
 455:         ex_nilret();    /* and stick on some dummy datum */
 456:         p = (int *)s->np->itemp;
 457:         execute(p[*p + 1]);
 458:         gsip = s->sip;
 459:     }
 460:     if(gsip == 0)
 461:         while(sp > stack)
 462:             pop();
 463: }
 464: 
 465: /*
 466:  * monadic immediate branch -- resume fn at specific line
 467:  */
 468: 
 469: ex_ibr()
 470: {
 471:     register struct si *s;
 472:     if((s = gsip) == 0)
 473:         error("no suspended fn");
 474:     ex_br();
 475:     if(s->oldsp == 0 || sp < s->oldsp)
 476:         error("imm }n B");
 477:     while(sp > s->oldsp){
 478:         pop();
 479:     }
 480:     pop();      /* pop off possibly bad previous result */
 481:     ex_nilret();    /* and stick on some dummy datum */
 482:     longjmp(s->env);        /* warp out */
 483: }
 484: 
 485: ex_fdef()
 486: {
 487:     register struct item *p;
 488:     register char *p1, *p2;
 489:     struct nlist *np;
 490:     char b[512];
 491:     int i, dim0, dim1;
 492: 
 493:     p = fetch1();
 494:     if((p->rank != 2 && p->rank != 1) || p->type != CH)
 495:         error("Lfx D");
 496: 
 497: 
 498:     /* The following code has been commented out as a
 499: 	 * test of slight modifications to the compiler.
 500: 	 * Before this change, it was impossible to use "Lfx"
 501: 	 * from inside an APL function, for it might damage
 502: 	 * an existing function by the same name.  The compiler
 503: 	 * now checks when processing function headers to see
 504: 	 * if the function is suspended by calling "sichk", which
 505: 	 * will generate an error if so.  Hopefully this will now
 506: 	 * allow "Lfx" to be used freely without disastrous side-
 507: 	 * effects.
 508: 	 */
 509: 
 510: /*	if(gsip)
 511: 		error("si damage -- type ')reset'");	*/
 512: 
 513:     dim0 = p->dim[0];
 514:     dim1 = p->dim[1];
 515:     if(p->rank == 1)
 516:         dim1 = dim0;
 517:     copy(CH, p->datap, b, dim1);
 518:     b[dim1] = '\n';
 519: 
 520:     p2 = compile(b, 2);
 521:     if(p2 != 0){
 522:         copy(IN, p2+1, &np, 1);
 523:         erase(np);
 524:         np->use = *p2;
 525:         free(p2);
 526: 
 527:         np->label = SEEKF(wfile, 0L, 2);
 528:         fappend(wfile, p);
 529:         WRITEF(wfile,"",1);
 530:     }
 531:     pop();
 532:     *sp++ = newdat(DA, 1, 0);
 533: }
 534: 
 535: ex_nilret()
 536: {
 537:     checksp();
 538:     *sp++ = newdat(DU,0,0); /* put looser onto stack */
 539:                 /* (should be discarded) */
 540: }
 541: 
 542: reverse(s)
 543: char *s;
 544: {
 545:     register char *p, *q;
 546:     register char c;
 547:     int j;
 548: 
 549: #define EXCH(a,b)   {c=a;a=b;b=c;}
 550: 
 551:     p = q = s;
 552:     while(*p != EOF)
 553:         p++;
 554:     p -= 1+sizeof(char *);
 555:     while(q < p){
 556:         for(j=0; j<1+sizeof (char *); j++)
 557:             EXCH(p[j], q[j]);
 558:         q += j;
 559:         p -= j;
 560:     }
 561: }
 562: 
 563: /*
 564:  * produce trace back info
 565:  */
 566: char *atfrom[] = {"at\t", "from\t", "", ""};
 567: tback(flag)
 568: {
 569:     register struct si *p;
 570:     register i;
 571: 
 572:     p = gsip;
 573:     i = 0;
 574:     if(flag)
 575:         i = 2;
 576:     while(p){
 577:         if(flag==0 && p->suspended)
 578:             return;
 579:         if (p->funlc != 1 || i){    /* skip if at line 0 */
 580:             printf("%s%s[%d]%s\n",
 581:                 atfrom[i],
 582:                 p->np->namep,
 583:                 p->funlc - 1,
 584:                 (p->suspended ? "   *" : "")
 585:             );
 586:             i |= 1;
 587:         }
 588:         p = p->sip;
 589:     }
 590: }
 591: 
 592: sichk(n)
 593: struct nlist *n;
 594: {
 595:     register struct si *p;
 596: 
 597:     p = gsip;
 598:     while(p){
 599:         if(n == p->np)
 600:             error("si damage -- type ')reset'");
 601:         p = p->sip;
 602:     }
 603: }
 604: ex_shell(){
 605: 
 606:     /* If the environment variable SHELL is defined, attempt to
 607: 	 * execute that shell.  If not, or if that exec fails, attempt
 608: 	 * to execute the standard shell, /bin/sh
 609: 	 */
 610: 
 611:     int (*addr)(), (*addr2)();
 612:     char *getenv();
 613:     register char *sh;
 614:     register i;
 615: 
 616:     addr = signal(SIGINT, SIG_IGN);
 617:     addr2 = signal(SIGQUIT, SIG_IGN);
 618:     i = FORKF(1);
 619:     if (i == 0){
 620:         for(i=3; i<20; i++) close(i);
 621:         signal(SIGINT, SIG_DFL);
 622:         signal(SIGQUIT, SIG_DFL);
 623:         if (sh=getenv("SHELL"))
 624:             execl(sh, sh, 0);
 625:         execl("/bin/sh", "sh", 0);
 626:         printf("no shell!\n");
 627:         exit(1);
 628:     }
 629:     if (i == -1) error("try again");
 630:     while(wait(0) != i);
 631:     signal(SIGINT, addr);
 632:     signal(SIGQUIT, addr2);
 633: }
 634: badfnsv(fname)
 635: char *fname;
 636: {
 637: 
 638:     /* This routine saves the contents of "fname" in the file
 639: 	 * named in "bad_fn".  It is called by "funedit" if the
 640: 	 * header of a function just read in is messed up (thus,
 641: 	 * the entire file is not lost).  Returns 1 if successful,
 642: 	 * 0 if not.
 643: 	 */
 644: 
 645:     register fd1, fd2, len;
 646:     char buf[512];
 647: 
 648:     if ((fd1=OPENF(fname, 0)) < 0 || (fd2=CREATF(bad_fn, 0644)) < 0)
 649:         return(0);
 650:     while((len=READF(fd1, buf, 512)) > 0)
 651:         WRITEF(fd2, buf, len);
 652:     CLOSEF(fd1);
 653:     CLOSEF(fd2);
 654:     return(1);
 655: }

Defined functions

Defined variables

Defined macros