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