![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to fex2.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSD / ucb / lisp / franz|
Return to fex2.c CVS log | Up to [CSRG BSD Unix] / 43BSD / ucb / lisp / franz |
1.1 root 1:
2: #ifndef lint
3: static char *rcsid =
4: "$Header: fex2.c,v 1.3 83/09/07 17:55:38 sklower Exp $";
5: #endif
6:
7: /* -[Mon Jan 31 21:54:52 1983 by layer]-
8: * fex2.c $Locker: $
9: * nlambda functions
10: *
11: * (c) copyright 1982, Regents of the University of California
12: */
13:
14: #include "global.h"
15: #define NDOVARS 30
16: #include "frame.h"
17:
18: /*
19: * Ndo maclisp do function.
20: */
21: lispval
22: Ndo()
23: {
24: register lispval current, where, handy;
25: register struct nament *mybnp;
26: lispval temp, atom;
27: lispval body, endtest, endform, varstuff, renewals[NDOVARS] ;
28: struct argent *getem, *startnp;
29: struct nament *savedbnp = bnp;
30: int count, repeatdo, index;
31: extern struct frame *errp;
32: pbuf pb;
33: Savestack(3);
34:
35: current = lbot->val;
36: varstuff = current->d.car;
37:
38: switch( TYPE(varstuff) ) {
39:
40: case ATOM: /* This is old style maclisp do;
41: atom is var, cadr(current) = init;
42: caddr(current) = repeat etc. */
43: if(varstuff==nil) goto newstyle;
44: current = current->d.cdr; /* car(current) is now init */
45: PUSHDOWN(varstuff,eval(current->d.car));
46: /* Init var. */
47: *renewals = (current = current->d.cdr)->d.car;
48: /* get repeat form */
49: endtest = (current = current->d.cdr)->d.car;
50: body = current->d.cdr;
51:
52: errp = Pushframe(F_PROG,nil,nil);
53:
54: switch (retval) {
55: case C_RET: /*
56: * returning from this prog, value to return
57: * is in lispretval
58: */
59: errp = Popframe();
60: popnames(savedbnp);
61: return(lispretval);
62:
63: case C_GO: /*
64: * going to a certain label, label to go to in
65: * in lispretval
66: */
67: where = body;
68: while ((TYPE(where) == DTPR)
69: & (where->d.car != lispretval))
70: where = where->d.cdr;
71: if (where->d.car == lispretval) {
72: popnames(errp->svbnp);
73: where = where->d.cdr;
74: goto singbody;
75: }
76: /* label not found in this prog, must
77: * go up to higher prog
78: */
79: Inonlocalgo(C_GO,lispretval,nil);
80:
81: /* NOT REACHED */
82:
83: case C_INITIAL: break; /* fall through */
84:
85: }
86:
87: singtop:
88: if(eval(endtest)!=nil) {
89: errp = Popframe();
90: popnames(savedbnp);
91: return(nil);
92: }
93: where = body;
94:
95: singbody:
96: while (TYPE(where) == DTPR)
97: {
98: temp = where->d.car;
99: if((TYPE(temp))!=ATOM) eval(temp);
100: where = where->d.cdr;
101: }
102: varstuff->a.clb = eval(*renewals);
103: goto singtop;
104:
105:
106: newstyle:
107: case DTPR: /* New style maclisp do; atom is
108: list of things of the form
109: (var init repeat) */
110: count = 0;
111: startnp = np;
112: for(where = varstuff; where != nil; where = where->d.cdr) {
113: /* do inits and count do vars. */
114: /* requires "simultaneous" eval
115: of all inits */
116: while (TYPE(where->d.car) != DTPR)
117: where->d.car =
118: errorh1(Vermisc,"do: variable forms must be lists ",
119: nil,TRUE,0,where->d.car);
120: handy = where->d.car->d.cdr;
121: temp = nil;
122: if(handy !=nil)
123: temp = eval(handy->d.car);
124: protect(temp);
125: count++;
126: }
127: if(count > NDOVARS)
128: error("More than 15 do vars",FALSE);
129: where = varstuff;
130: getem = startnp; /* base of stack of init forms */
131: for(index = 0; index < count; index++) {
132:
133: handy = where->d.car;
134: /* get var name from group */
135:
136: atom = handy->d.car;
137: while((TYPE(atom) != ATOM) || (atom == nil))
138: atom = errorh1(Vermisc,"do variable must be a non nil symbol ",
139: nil,TRUE,0,atom);
140: PUSHDOWN(atom,getem->val);
141: getem++;
142: handy = handy->d.cdr->d.cdr;
143: if(handy==nil)
144: handy = CNIL; /* be sure not to rebind later */
145: else
146: handy = handy->d.car;
147: renewals[index] = handy;
148:
149: /* more loop "increments" */
150: where = where->d.cdr;
151: }
152: np = startnp; /* pop off all init forms */
153: /* Examine End test and End form */
154: current = current->d.cdr;
155: handy = current->d.car;
156: body = current->d.cdr;
157:
158: /*
159: * a do form with a test of nil just does the body once
160: * and returns nil
161: */
162: if (handy == nil) repeatdo = 1; /* just do it once */
163: else repeatdo = -1; /* do it forever */
164:
165: endtest = handy->d.car;
166: endform = handy->d.cdr;
167:
168: where = body;
169:
170: errp = Pushframe(F_PROG,nil,nil);
171: while(TRUE) {
172:
173: switch (retval) {
174: case C_RET: /*
175: * returning from this prog, value to return
176: * is in lispretval
177: */
178: errp = Popframe();
179: popnames(savedbnp);
180: Restorestack();
181: return(lispretval);
182:
183: case C_GO: /*
184: * going to a certain label, label to go to in
185: * in lispretval
186: */
187: where = body;
188: while ((TYPE(where) == DTPR)
189: & (where->d.car != lispretval))
190: where = where->d.cdr;
191: if (where->d.car == lispretval) {
192: popnames(errp->svbnp);
193: where = where->d.cdr;
194: goto bodystart;
195: }
196: /* label not found in this prog, must
197: * go up to higher prog
198: */
199: Inonlocalgo(C_GO,lispretval,nil);
200:
201: /* NOT REACHED */
202:
203: case C_INITIAL: break; /* fall through */
204:
205: }
206:
207: loop:
208: np = startnp; /* is bumped when doing repeat forms */
209:
210: if((repeatdo-- == 0) || (eval(endtest) !=nil)) {
211: for(handy = nil; endform!=nil; endform = endform->d.cdr)
212: {
213: handy = eval(endform->d.car);
214: }
215: errp = Popframe();
216: popnames(savedbnp);
217: Restorestack();
218: return(handy);
219: }
220:
221: bodystart:
222: while (TYPE(where) == DTPR)
223: {
224: temp = where->d.car;
225: if((TYPE(temp))!=ATOM) eval(temp);
226: where = where->d.cdr;
227: }
228: where = body;
229: getem = np = startnp;
230: /* Simultaneously eval repeat forms */
231: for(index = 0; index < count; index++) {
232: temp = renewals[index];
233: if (temp == nil || temp == CNIL)
234: protect(temp);
235: else
236: protect(eval(temp));
237: }
238: /* now simult. rebind all the atoms */
239: mybnp = savedbnp;
240: for(index = 0; index < count; index++)
241: {
242: if( getem->val != CNIL ) /* if this atom has a repeat */
243: mybnp->atm->a.clb = (getem)->val; /* rebind */
244: mybnp++;
245: getem++;
246: }
247: goto loop;
248: }
249: default:
250: error("do: neither list nor atom follows do", FALSE);
251: }
252: /* NOTREACHED */
253: }
254:
255: lispval
256: Nprogv()
257: {
258: register lispval where, handy;
259: register struct nament *namptr;
260: register struct argent *vars;
261: struct nament *oldbnp = bnp;
262: Savestack(4);
263:
264: where = lbot->val;
265: protect(eval(where->d.car)); /* list of vars = lbot[1].val */
266: protect(eval((where = where->d.cdr)->d.car));
267: /* list of vals */
268: handy = lbot[2].val;
269: namptr = oldbnp;
270: /* simultaneous eval of all
271: args */
272: for(;handy!=nil; handy = handy->d.cdr) {
273: (np++)->val = (handy->d.car);
274: /* Note, each element should not be reevaluated like it
275: * was before. - dhl */
276: /* Before: (np++)->val = eval(handy->d.car);*/
277: TNP;
278: }
279: /*asm("# Here is where rebinding is done"); /* very cute */
280: for(handy=lbot[1].val,vars=lbot+3; handy!=nil; handy=handy->d.cdr) {
281: namptr->atm = handy->d.car;
282: ++namptr; /* protect against interrupts
283: while re-lambda binding */
284: bnp = namptr;
285: namptr[-1].atm = handy->d.car;
286: namptr[-1].val = handy->d.car->a.clb;
287: if(vars < np)
288: handy->d.car->a.clb = vars++->val;
289: else
290: handy->d.car->a.clb = nil;
291: }
292:
293: handy = nil;
294: for(where = where->d.cdr; where != nil; where = where->d.cdr)
295: handy = eval(where->d.car);
296: popnames(oldbnp);
297: Restorestack();
298: return(handy);
299: }
300:
301: lispval
302: Nprogn()
303: {
304: register lispval result, where;
305:
306: result = nil;
307: for(where = lbot->val; where != nil; where = where->d.cdr)
308: result = eval(where->d.car);
309: return(result);
310:
311:
312: }
313: lispval
314: Nprog2()
315: {
316: register lispval result, where;
317:
318: where = lbot->val;
319: eval(where->d.car);
320: result = eval((where = where->d.cdr)->d.car);
321: protect(result);
322: for(where = where->d.cdr; where != nil; where = where->d.cdr)
323: eval(where->d.car);
324: np--;
325: return(result);
326: }
327: lispval
328: typred(typ,ptr)
329: int typ;
330: lispval ptr;
331:
332: { int tx;
333: if ((tx = TYPE(ptr)) == typ) return(tatom);
334: if ((tx == INT) && (typ == ATOM)) return(tatom);
335: return(nil);
336: }
337:
338: /*
339: * function
340: * In the interpreter, function is the same as quote
341: */
342: lispval
343: Nfunction()
344: {
345: if((lbot->val == nil) || (lbot->val->d.cdr != nil))
346: argerr("function");
347: return(lbot->val->d.car);
348: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.