![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to fex1.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 40BSD / cmd / lisp|
Return to fex1.c CVS log | Up to [CSRG BSD Unix] / 40BSD / cmd / lisp |
1.1 root 1: static char *sccsid = "@(#)fex1.c 34.2 11/7/80";
2:
3: #include "global.h"
4: /* Nprog ****************************************************************/
5: /* This first sets the local variables to nil while saving their old */
6: /* values on the name stack. Then, pointers to various things are */
7: /* saved as this function may be returned to by an "Ngo" or by a */
8: /* "Lreturn". At the end is the loop that cycles through the contents */
9: /* of the prog. */
10:
11: lispval
12: Nprog() {
13: int saveme[SAVSIZE];
14: register struct nament *mybnp = bnp;
15: register struct argent *savednp;
16: register lispval where, temp;
17: register struct argent *lbot, *np;
18: struct argent *savedlbot;
19: struct nament *savedbnp;
20: struct nament *topbind;
21: long myerrp; extern long errp;
22:
23: savednp = np;
24: savedlbot = lbot;
25: savedbnp = bnp;
26: temp = where = (lbot->val)->d.car;
27: while (TYPE(temp) == DTPR)
28: {
29: temp = where->d.car;
30: if (TYPE(temp) == ATOM)
31: {
32: bnp->atm = temp;
33: bnp->val = (temp)->a.clb;
34: (temp)->a.clb = nil;
35: temp = where = where->d.cdr;
36: if(bnp++ > bnplim)
37: binderr();
38: }
39: else return(CNIL);
40: }
41: topbind = bnp;
42: myerrp = errp;
43: if (where != nil) return(CNIL);
44: temp = where = savedlbot->val->d.cdr;
45: getexit(saveme);
46: while (retval = setexit()) {
47: errp = myerrp;
48: switch (retval) {
49:
50: case BRRETN: resexit(saveme);
51: popnames(savedbnp);
52: lbot = savedlbot;
53: return(contval);
54:
55: case BRGOTO: where = (savedlbot->val)->d.cdr;
56: while ((TYPE(where) == DTPR) && (where->d.car != contval))
57: where = where->d.cdr;
58: if (where->d.car == contval) {
59: /* This seems wrong - M Marcus
60: resexit(saveme); */
61: popnames(topbind);
62: lbot = savedlbot;
63: break;
64: }
65:
66: default:
67: resexit(saveme);
68: reset(retval);
69:
70: }
71: }
72: while (TYPE(where) == DTPR)
73: {
74: temp = where->d.car;
75: if((TYPE(temp))!=ATOM) eval(temp);
76: where = where->d.cdr;
77: }
78: resexit(saveme);
79: return((where == nil) ? nil : CNIL);
80: }
81:
82: lispval globtag;
83: /*
84: Ncatch is now actually *catch , which has the form
85: (*catch tag form)
86: tag is evaluated and then the catch entry is set up.
87: then form is evaluated
88: finally the catch entry is removed.
89:
90: (catch form [tag]) is translated to (*catch 'tag form)
91: by a macro.
92: */
93: lispval
94: Ncatch()
95: {
96: struct argent *savednp,*savedlbot;
97: register lispval where, tag, todo;
98: register temp;
99: register struct argent *lbot, *np;
100: int type;
101:
102:
103: where = lbot->val;
104: if((TYPE(where))!=DTPR) return(nil);
105: todo = where->d.cdr->d.car;
106: tag = eval(where->d.car);
107: while((TYPE(tag)!=ATOM) && (TYPE(tag) != DTPR))
108: tag = error("Bad type of tag in *catch.",TRUE);
109: asm(" pushab On1");
110: asm(" pushr $0x2540");
111: asm(" subl2 $44,sp"); /* THIS IS A CROCK ....
112: saves current environment
113: for (return) z.B. */
114: asm(" movc3 $44,_setsav,(sp)");
115: asm(" pushl _bnp");
116: asm(" pushl r10");
117: asm(" pushl $1");
118: asm(" pushl _errp");
119: asm(" movl sp,_errp");
120: where = (eval(todo));
121: asm(" movl (sp),_errp");
122: return(where);
123: asm("On1:ret");
124: }
125:
126: /* (errset form [flag])
127: if present, flag determines if the error message will be printed
128: if an error reaches the errset.
129: if no error occurs, errset returns a list of one element, the
130: value returned from form.
131: if an error occurs, nil is usually returned although it could
132: be non nil if err threw a non nil value
133: */
134:
135: lispval Nerrset()
136: {
137: register lispval flag,where,todo; /* order important */
138: register lispval handy = Vlerall; /* to access this easily */
139: register struct argent *lbot, *np;
140: where = lbot->val;
141:
142: if(TYPE(where) != DTPR) return(nil); /* no form */
143:
144: todo = where->d.car; /* form to eval */
145: flag = where->d.cdr;
146: if(flag != nil) flag = eval(flag->d.car); /* tag to tell if er messg */
147: else flag = tatom; /* if not present , assume t */
148:
149: /* push on a catch frame */
150:
151: asm(" pushab On2"); /* where to jump if error */
152: asm(" pushr $0x2540");
153: asm(" subl2 $44,sp"); /* THIS IS A CROCK ....
154: saves current environment
155: for (return) z.B. */
156: asm(" movc3 $44,_setsav,(sp)");
157: asm(" pushl _bnp");
158: asm(" pushl r8"); /* tag , (ER%all) */
159: asm(" pushl r11"); /* flag */
160: asm(" pushl _errp"); /* link in */
161: asm(" movl sp,_errp"); /* " */
162:
163: /* evaluate form, and if ok, listify */
164:
165: handy = eval(todo);
166: asm(" movl (sp),_errp"); /* unlink this frame */
167: protect(handy); /* may gc on nxt call */
168: (flag = newdot()) ->d.car = handy; /* listify arg */
169:
170: return(flag);
171:
172: asm("On2: ret"); /* if error occured */
173:
174: }
175:
176: /* this was changed from throw to *throw 21nov79
177: it really should be called Lthrow
178: */
179: Nthrow()
180: {
181: register lispval todo, where;
182: lispval globtag,contval;
183: snpand(2); /* save register mask */
184: switch(np-lbot) {
185: case 0:
186: protect(nil);
187: case 1:
188: protect(nil);
189: case 2: break;
190: default:
191: argerr("throw");
192: }
193: globtag = lbot->val;
194: contval = (lbot+1)->val;
195: Idothrow(globtag,contval);
196: error("Uncaught throw",FALSE);
197: }
198: #include "catchfram.h"
199:
200: Idothrow(tag,value)
201: lispval tag,value;
202: {
203: typedef struct catchfr *cp;
204: register cp curp; /* must be first register */
205: extern long errp;
206: extern lispval globtag;
207: int pass1,founduw;
208: lispval handy,handy2;
209: snpand(1);
210:
211: globtag = tag;
212: /*
213: printf("throw,value ");printr(tag,stdout); printf(" ");
214: printr(value,stdout); fflush(stdout);
215: */
216: pass1 = TRUE;
217: ps2:
218: founduw = FALSE;
219:
220: for (curp=(cp)errp ; curp != (cp) nil ; curp =curp->link)
221: {
222: /* printf(" lbl: ");printr(curp->labl,stdout);fflush(stdout); */
223: if(curp->labl == Veruwpt)
224: { founduw = TRUE;
225: if(!pass1) goto foundit;
226: }
227: if(curp->labl == nil || curp->labl == tag) goto foundit;
228: if(TYPE(curp->labl) == DTPR)
229: {
230: for( handy = curp->labl ; handy != nil ; handy = handy->d.cdr)
231: {
232: if(handy->d.car == tag) goto foundit;
233: }
234: }
235: }
236: return;
237:
238: foundit: /* restore context at catch */
239: if(pass1 && founduw)
240: { pass1 = FALSE;
241: goto ps2;
242: }
243: if(founduw) /* remember the state */
244: { protect(handy2 = newdot());
245: handy2->d.car = Veruwpt;
246: handy = handy2->d.cdr = newdot();
247: handy->d.car = tatom; /* t for throw */
248: handy = handy->d.cdr = newdot();
249: handy->d.car = tag;
250: handy = handy->d.cdr = newdot();
251: handy->d.car = value;
252: value = handy2;
253: /* printf("Ret uwp: ");printr(value,stdout);fflush(stdout);*/
254: }
255:
256: popnames(curp->svbnp);
257: errp = (int) curp->link;
258: /*
259: * return value must go into r7 until after movc3 since
260: * a movc3 clobbers r0
261: */
262: asm(" movl 8(ap),r7"); /* return value */
263: asm(" addl3 $16,r11,sp");
264: /* account for current (return) */
265: asm(" movc3 $44,(sp),_setsav");
266: asm(" addl2 $44,sp");
267: asm(" popr $0x2540");
268: asm(" movl r7,r0");
269: asm(" rsb");
270:
271: }
272:
273:
274:
275: /* Ngo ******************************************************************/
276: /* First argument only is checked - and must be an atom or evaluate */
277: /* to one. */
278: Ngo()
279: {
280: contval = (lbot->val)->d.car;
281: while (TYPE(contval) != ATOM)
282: {
283: contval = eval(contval);
284: while (TYPE(contval) != ATOM) contval = error("GO ARG NOT ATOM",TRUE);
285: }
286: reset(BRGOTO);
287: }
288:
289:
290: /* Nreset ***************************************************************/
291: /* All arguments are ignored. This just returns-from-break to depth 0. */
292: Nreset()
293: {
294: contval = 0;
295: reset(BRRETB);
296: }
297:
298: /* Nresetio *************************************************************/
299:
300: lispval
301: Nresetio() {
302: register FILE *p;
303:
304: for(p = &_iob[3]; p < _iob + _NFILE; p++) {
305: if(p->_flag & (_IOWRT | _IOREAD)) fclose(p);
306: }
307: return(nil);
308:
309: }
310:
311:
312: /* Nbreak ***************************************************************/
313: /* If first argument is not nil, this is evaluated and printed. Then */
314: /* error is called with the "breaking" message. */
315:
316: lispval
317: Nbreak()
318: {
319: register lispval hold; register FILE *port;
320: port = okport(Vpoport->a.clb,stdout);
321: fprintf(port,"Breaking:");
322:
323: if ((hold = lbot->val) != nil && ((hold = hold->d.car) != nil))
324: {
325: printr(hold,port);
326: }
327: putc('\n',port);
328: dmpport(port);
329: return(errorh(Verbrk,"",nil,TRUE,0));
330: }
331:
332:
333: /* Nexit ****************************************************************/
334: /* Just calls lispend with no message. */
335: Nexit()
336: {
337: lispend("");
338: }
339:
340:
341: /* Nsys *****************************************************************/
342: /* Just calls lispend with no message. */
343:
344: lispval
345: Nsys()
346: {
347: lispend("");
348: }
349:
350:
351:
352:
353: lispval
354: Ndef() {
355: register lispval arglist, body, name, form;
356: snpand(4);
357:
358: form = lbot->val;
359: name = form->d.car;
360: body = form->d.cdr->d.car;
361: arglist = body->d.cdr->d.car;
362: if((TYPE(arglist))!=DTPR && arglist != nil)
363: error("Warning: defining function with nonlist of args",
364: TRUE);
365: name->a.fnbnd = body;
366: return(name);
367: }
368:
369:
370: lispval
371: Nquote()
372: {
373: snpand(0);
374: return((lbot->val)->d.car);
375: }
376:
377:
378: lispval
379: Nsetq()
380: { register lispval handy, where, value;
381: register int lefttype;
382: register struct argent *lbot, *np;
383:
384:
385: for(where = lbot->val; where != nil; where = handy->d.cdr) {
386: handy = where->d.cdr;
387: if((TYPE(handy))!=DTPR)
388: error("odd number of args to setq",FALSE);
389: if((lefttype=TYPE(where->d.car))==ATOM) {
390: if(where->d.car==nil)
391: error("Attempt to set nil",FALSE);
392: where->d.car->a.clb = value = eval(handy->d.car);
393: }else if(lefttype==VALUE)
394: where->d.car->l = value = eval(handy->d.car);
395: else error("CAN ONLY SETQ ATOMS OR VALUES",FALSE);
396: }
397: return(value);
398: }
399:
400:
401: lispval
402: Ncond()
403: {
404: register lispval where, last;
405: snpand(2);
406:
407: where = lbot->val;
408: last = nil;
409: for(;;) {
410: if ((TYPE(where))!=DTPR)
411: break;
412: if ((TYPE(where->d.car))!=DTPR)
413: break;
414: if ((last=eval((where->d.car)->d.car)) != nil)
415: break;
416: where = where->d.cdr;
417: }
418:
419: if ((TYPE(where)) != DTPR)
420: return(nil);
421: where = (where->d.car)->d.cdr;
422: while ((TYPE(where))==DTPR) {
423: last = eval(where->d.car);
424: where = where->d.cdr;
425: }
426: return(last);
427: }
428:
429: lispval
430: Nand()
431: {
432: register lispval current, temp;
433: snpand(2);
434:
435: current = lbot->val;
436: temp = tatom;
437: while (current != nil)
438: if ( (temp = current->d.car)!=nil && (temp = eval(temp))!=nil)
439: current = current->d.cdr;
440: else {
441: current = nil;
442: temp = nil;
443: }
444: return(temp);
445: }
446:
447:
448: lispval
449: Nor()
450: {
451: register lispval current, temp;
452: snpand(2);
453:
454: current = lbot->val;
455: temp = nil;
456: while (current != nil)
457: if ( (temp = eval(current->d.car)) == nil)
458: current = current->d.cdr;
459: else
460: break;
461: return(temp);
462: }
463:
464:
465: lispval
466: Nprocess() {
467: int wflag , childsi , childso , childnum, child;
468: register lispval current, temp;
469: char * sharg;
470: int handler;
471: int itemp;
472: FILE *bufs[2],*obufs[2];
473:
474: wflag = 1;
475: childsi = 0;
476: childso = 1;
477: current = lbot->val;
478: if( (TYPE(current))!=DTPR )
479: return(nil);
480: temp = current->d.car;
481: if( (TYPE(temp))!=ATOM )
482: return(nil);
483:
484: sharg = temp->a.pname;
485:
486: if( (current = current->d.cdr)!=nil && (TYPE((temp = current->d.car)))==ATOM ) {
487:
488: if (temp == tatom) {
489: wflag = 0;
490: childsi = 0;
491: } else if (temp != nil) {
492: fpipe(bufs);
493: wflag = 0;
494: temp->a.clb = P(bufs[1]);
495: childsi = fileno(bufs[0]);
496: }
497:
498: if( (current = current->d.cdr)!=nil && (TYPE((temp = current->d.car)))==ATOM ) {
499:
500: if (temp != nil) {
501: fpipe(obufs);
502: temp->a.clb = P(obufs[0]);
503: childso = fileno(obufs[1]);
504: }
505: }
506: }
507: handler = signal(2,1);
508: if((child = fork()) == 0 ) {
509: if(wflag!=0 && handler !=1)
510: signal(2,0);
511: else
512: signal(2,1);
513: if(childsi != 0) {
514: close(0);
515: dup(childsi);
516: }
517: if (childso !=1) {
518: close(1);
519: dup(childso);
520: }
521: execlp("csh", "csh", "-c",sharg,0);
522: execlp("sh", "sh", "-c",sharg,0);
523: exit(-1); /* if exec fails, signal problems*/
524: }
525:
526: if(childsi != 0) fclose(bufs[0]);
527: if(childso != 1) fclose(obufs[1]);
528:
529: if(wflag && child!= -1) {
530: int status=0;
531: wait(&status);
532: itemp = status >> 8;
533: } else
534: itemp = child;
535: signal(2,handler);
536: return(inewint(itemp));
537: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.