![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to ai.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 ai.c CVS log | Up to [CSRG BSD Unix] / 43BSD / contrib / apl / src |
1.1 root 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: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.