![[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] / 42BSD / ucb / lisp / franz|
Return to fex1.c CVS log | Up to [CSRG BSD Unix] / 42BSD / ucb / lisp / franz |
1.1 root 1: #ifndef lint
2: static char *rcsid =
3: "$Header: fex1.c,v 1.3 83/09/07 17:55:28 sklower Exp $";
4: #endif
5:
6: /* -[Sat Mar 5 19:50:28 1983 by layer]-
7: * fex1.c $Locker: $
8: * nlambda functions
9: *
10: * (c) copyright 1982, Regents of the University of California
11: */
12:
13:
14: #include "global.h"
15: #include "frame.h"
16:
17: /* Nprog ****************************************************************/
18: /* This first sets the local variables to nil while saving their old */
19: /* values on the name stack. Then, pointers to various things are */
20: /* saved as this function may be returned to by an "Ngo" or by a */
21: /* "Lreturn". At the end is the loop that cycles through the contents */
22: /* of the prog. */
23:
24: lispval
25: Nprog() {
26: register lispval where, temp;
27: struct nament *savedbnp = bnp;
28: extern struct frame *errp;
29: pbuf pb;
30: extern int retval;
31: extern lispval lispretval;
32:
33: if((np-lbot) < 1) chkarg(1,"prog");
34:
35: /* shallow bind the local variables to nil */
36: if(lbot->val->d.car != nil)
37: {
38: for( where = lbot->val->d.car ; where != nil; where = where->d.cdr )
39: {
40: if(TYPE(where) != DTPR || TYPE(temp=where->d.car) != ATOM)
41: errorh1(Vermisc,
42: "Illegal local variable list in prog ",nil,FALSE,
43: 1,where);
44: PUSHDOWN(temp,nil);
45: }
46: }
47:
48: /* put a frame on the stack which can be 'return'ed to or 'go'ed to */
49: errp = Pushframe(F_PROG,nil,nil);
50:
51: where = lbot->val->d.cdr; /* first thing in the prog body */
52:
53: switch (retval) {
54: case C_RET: /*
55: * returning from this prog, value to return
56: * is in lispretval
57: */
58: errp = Popframe();
59: popnames(savedbnp);
60: return(lispretval);
61:
62: case C_GO: /*
63: * going to a certain label, label to go to in
64: * in lispretval
65: */
66: where = (lbot->val)->d.cdr;
67: while ((TYPE(where) == DTPR)
68: && (where->d.car != lispretval))
69: where = where->d.cdr;
70: if (where->d.car == lispretval) {
71: popnames(errp->svbnp);
72: break;
73: }
74: /* label not found in this prog, must
75: * go up to higher prog
76: */
77: errp = Popframe(); /* go to next frame */
78: Inonlocalgo(C_GO,lispretval,nil);
79:
80: /* NOT REACHED */
81:
82: case C_INITIAL: break;
83:
84: }
85:
86: while (TYPE(where) == DTPR)
87: {
88: temp = where->d.car;
89: if((TYPE(temp))!=ATOM) eval(temp);
90: where = where->d.cdr;
91: }
92: if((where != nil) && (TYPE(where) != DTPR))
93: errorh1(Vermisc,"Illegal form in prog body ", nil,FALSE,0,where);
94: errp = Popframe();
95: popnames(savedbnp); /* pop off locals */
96: return(nil);
97: }
98:
99: lispval globtag;
100: /*
101: Ncatch is now linked to the lisp symbol *catch , which has the form
102: (*catch tag form)
103: tag is evaluated and then the catch entry is set up.
104: then form is evaluated
105: finally the catch entry is removed.
106:
107: *catch is still an nlambda since its arguments should not be evaluated
108: before this routine is called.
109:
110: (catch form [tag]) is translated to (*catch 'tag form) by a macro.
111: */
112: lispval
113: Ncatch()
114: {
115: register lispval tag;
116: pbuf pb;
117: Savestack(3); /* save stack pointers */
118:
119: if((TYPE(lbot->val))!=DTPR) return(nil);
120: protect(tag = eval(lbot->val->d.car)); /* protect tag from gc */
121:
122: errp = Pushframe(F_CATCH,tag,nil);
123:
124: switch(retval) {
125:
126: case C_THROW: /*
127: * value thrown is in lispretval
128: */
129: break;
130:
131: case C_INITIAL: /*
132: * calculate value of expression
133: */
134: lispretval = eval(lbot->val->d.cdr->d.car);
135: }
136:
137:
138: errp = Popframe();
139: Restorestack();
140: return(lispretval);
141: }
142: /* (errset form [flag])
143: if present, flag determines if the error message will be printed
144: if an error reaches the errset.
145: if no error occurs, errset returns a list of one element, the
146: value returned from form.
147: if an error occurs, nil is usually returned although it could
148: be non nil if err threw a non nil value
149: */
150:
151: lispval Nerrset()
152: {
153: lispval temp,flag;
154: pbuf pb;
155: Savestack(0);
156:
157: if(TYPE(lbot->val) != DTPR) return(nil); /* no form */
158:
159: /* evaluate and save flag first */
160: flag = lbot->val->d.cdr;
161: if(TYPE(flag) == DTPR) flag = eval(flag->d.car);
162: else flag = tatom; /* if not present , assume t */
163: protect(flag);
164:
165: errp = Pushframe(F_CATCH,Verall,flag);
166:
167: switch(retval) {
168:
169: case C_THROW: /*
170: * error thrown to this routine, value thrown is
171: * in lispretval
172: */
173: break;
174:
175: case C_INITIAL: /*
176: * normally just evaluate expression and listify it.
177: */
178: temp = eval(lbot->val->d.car);
179: protect(temp);
180: (lispretval = newdot())->d.car = temp;
181: break;
182: }
183:
184: errp = Popframe();
185: Restorestack();
186: return(lispretval);
187: }
188:
189: /* this was changed from throw to *throw 21nov79
190: it is now a lambda and really should be called Lthrow
191: */
192: lispval
193: Nthrow()
194: {
195: switch(np-lbot) {
196: case 0:
197: protect(nil);
198: case 1:
199: protect(nil);
200: case 2: break;
201: default:
202: argerr("throw");
203: }
204: Inonlocalgo(C_THROW,lbot->val,(lbot+1)->val);
205: /* NOT REACHED */
206: }
207:
208:
209:
210: /* Ngo ******************************************************************/
211: /* First argument only is checked - and must be an atom or evaluate */
212: /* to one. */
213: lispval
214: Ngo()
215: {
216: register lispval temp;
217: chkarg(1,"go");
218:
219: temp = (lbot->val)->d.car;
220: if (TYPE(temp) != ATOM)
221: {
222: temp = eval(temp);
223: while(TYPE(temp) != ATOM)
224: temp = errorh1(Vermisc,"Illegal tag to go to",nil,TRUE, 0,lbot->val);
225: }
226: Inonlocalgo(C_GO,temp,nil);
227: /* NOT REACHED */
228: }
229:
230:
231: /* Nreset ***************************************************************/
232: /* All arguments are ignored. This just returns-from-break to depth 0. */
233: lispval
234: Nreset()
235: {
236: Inonlocalgo(C_RESET,inewint(0),nil);
237: }
238:
239: /* Nresetio *************************************************************/
240:
241: lispval
242: Nresetio() {
243: register FILE *p;
244:
245: for(p = &_iob[3]; p < _iob + _NFILE; p++) {
246: if(p->_flag & (_IOWRT | _IOREAD)) fclose(p);
247: }
248: return(nil);
249:
250: }
251:
252:
253: /* Nbreak ***************************************************************/
254: /* If first argument is not nil, this is evaluated and printed. Then */
255: /* error is called with the "breaking" message. */
256:
257: lispval
258: Nbreak()
259: {
260: register lispval hold; register FILE *port;
261: port = okport(Vpoport->a.clb,stdout);
262: fprintf(port,"Breaking:");
263:
264: if ((hold = lbot->val) != nil && ((hold = hold->d.car) != nil))
265: {
266: printr(hold,port);
267: }
268: putc('\n',port);
269: dmpport(port);
270: return(errorh(Verbrk,"",nil,TRUE,0));
271: }
272:
273:
274: /* Nexit ****************************************************************/
275: /* Just calls lispend with no message. */
276: Nexit()
277: {
278: lispend("");
279: }
280:
281:
282: /* Nsys *****************************************************************/
283: /* Just calls lispend with no message. */
284:
285: lispval
286: Nsys()
287: {
288: lispend("");
289: }
290:
291:
292:
293:
294: lispval
295: Ndef() {
296: register lispval arglist, body, name, form;
297:
298: form = lbot->val;
299: name = form->d.car;
300: body = form->d.cdr->d.car;
301: arglist = body->d.cdr->d.car;
302: if((TYPE(arglist))!=DTPR && arglist != nil)
303: error("Warning: defining function with nonlist of args",
304: TRUE);
305: name->a.fnbnd = body;
306: return(name);
307: }
308:
309:
310: lispval
311: Nquote()
312: {
313: return((lbot->val)->d.car);
314: }
315:
316:
317: lispval
318: Nsetq()
319: { register lispval handy, where, value;
320: register int lefttype;
321:
322: value = nil;
323:
324: for(where = lbot->val; where != nil; where = handy->d.cdr) {
325: handy = where->d.cdr;
326: if((TYPE(handy))!=DTPR)
327: error("odd number of args to setq",FALSE);
328: if((lefttype=TYPE(where->d.car))==ATOM) {
329: if(where->d.car==nil)
330: error("Attempt to set nil",FALSE);
331: where->d.car->a.clb = value = eval(handy->d.car);
332: }else if(lefttype==VALUE)
333: where->d.car->l = value = eval(handy->d.car);
334: else errorh1(Vermisc,
335: "Can only setq atoms or values",nil,FALSE,0,
336: where->d.car);
337: }
338: return(value);
339: }
340:
341:
342: lispval
343: Ncond()
344: {
345: register lispval where, last;
346:
347: where = lbot->val;
348: last = nil;
349: for(;;) {
350: if ((TYPE(where))!=DTPR)
351: break;
352: if ((TYPE(where->d.car))!=DTPR)
353: break;
354: if ((last=eval((where->d.car)->d.car)) != nil)
355: break;
356: where = where->d.cdr;
357: }
358:
359: if ((TYPE(where)) != DTPR)
360: return(nil);
361: where = (where->d.car)->d.cdr;
362: while ((TYPE(where))==DTPR) {
363: last = eval(where->d.car);
364: where = where->d.cdr;
365: }
366: return(last);
367: }
368:
369: lispval
370: Nand()
371: {
372: register lispval current, temp;
373:
374: current = lbot->val;
375: temp = tatom;
376: while (current != nil)
377: if ( (temp = current->d.car)!=nil && (temp = eval(temp))!=nil)
378: current = current->d.cdr;
379: else {
380: current = nil;
381: temp = nil;
382: }
383: return(temp);
384: }
385:
386:
387: lispval
388: Nor()
389: {
390: register lispval current, temp;
391:
392: current = lbot->val;
393: temp = nil;
394: while (current != nil)
395: if ( (temp = eval(current->d.car)) == nil)
396: current = current->d.cdr;
397: else
398: break;
399: return(temp);
400: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.