![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to lam3.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 lam3.c CVS log | Up to [CSRG BSD Unix] / 3BSD / cmd / lisp |
1.1 root 1: # include "global.h"
2: lispval
3: Lalfalp()
4: {
5: register lispval first, second;
6: register struct argent *inp;
7: snpand(3); /* clobber save mask */
8:
9: chkarg(2);
10: inp = lbot;
11: first = (inp)->val;
12: second = (inp+1)->val;
13: if( (TYPE(first))!=ATOM || (TYPE(second))!=ATOM)
14: error("alphalessp expects atoms");
15: if(strcmp(first->pname,second->pname) <= 0)
16: return(tatom);
17: else
18: return(nil);
19: }
20:
21: lispval
22: Lncons()
23: {
24: register lispval handy;
25: snpand(1); /* clobber save mask */
26:
27: chkarg(1);
28: handy = newdot();
29: handy -> cdr = nil;
30: handy -> car = lbot->val;
31: return(handy);
32: }
33: lispval
34: Lzerop()
35: {
36: register lispval handy;
37: snpand(1); /* clobber save mask */
38:
39: chkarg(1);
40: handy = lbot->val;
41: switch(TYPE(handy)) {
42: case INT:
43: return(handy->i==0?tatom:nil);
44: case DOUB:
45: return(handy->r==0.0?tatom:nil);
46: }
47: return(nil);
48: }
49: lispval
50: Lonep()
51: {
52: register lispval handy; lispval Ladd();
53: snpand(1); /* clobber save mask */
54:
55: chkarg(1);
56: handy = lbot->val;
57: switch(TYPE(handy)) {
58: case INT:
59: return(handy->i==1?tatom:nil);
60: case DOUB:
61: return(handy->r==1.0?tatom:nil);
62: case SDOT:
63: protect(inewint(0));
64: handy = Ladd();
65: if(TYPE(handy)!=INT || handy->i !=1)
66: return(nil);
67: else
68: return(tatom);
69: }
70: return(nil);
71: }
72:
73: lispval
74: cmpx(lssp)
75: {
76: register struct argent *argp;
77: register struct argent *outarg;
78: register struct argent *handy;
79: register count;
80: register struct argent *lbot;
81: register struct argent *np;
82: struct argent *onp = np;
83:
84:
85: argp = lbot + 1;
86: outarg = np;
87: while(argp < onp) {
88:
89: np = outarg + 2;
90: lbot = outarg;
91: if(lssp)
92: *outarg = argp[-1], outarg[1] = *argp++;
93: else
94: outarg[1] = argp[-1], *outarg = *argp++;
95: lbot->val = Lsub();
96: np = lbot + 1;
97: if(Lnegp()==nil) return(nil);
98: }
99: return(tatom);
100: }
101:
102: lispval
103: Lgreaterp()
104: {
105: return(cmpx(FALSE));
106: }
107:
108: lispval
109: Llessp()
110: {
111: return(cmpx(TRUE));
112: }
113:
114: lispval
115: Ldiff()
116: {
117: register lispval arg1,arg2; register handy = 0;
118: snpand(3); /* clobber save mask */
119:
120:
121: chkarg(2);
122: arg1 = lbot->val;
123: arg2 = (lbot+1)->val;
124: if(TYPE(arg1)==INT && TYPE(arg2)==INT) {
125: handy=arg1->i - arg2->i;
126: }
127: else error("non-numeric argument",FALSE);
128: return(inewint(handy));
129: }
130:
131: lispval
132: Lmod()
133: {
134: register lispval arg1,arg2; lispval handy;
135: struct sdot fake1, fake2;
136: fake2.CDR = 0;
137: fake1.CDR = 0;
138: snpand(2); /* clobber save mask */
139:
140: chkarg(2);
141: handy = arg1 = lbot->val;
142: arg2 = (lbot+1)->val;
143: switch(TYPE(arg1)) {
144: case SDOT:
145: break;
146: case INT:
147: fake1.I = arg1->i;
148: arg1 =(lispval) &fake1;
149: break;
150: default:
151: error("non-numeric argument",FALSE);
152: }
153: switch(TYPE(arg2)) {
154: case SDOT:
155: break;
156: case INT:
157: fake2.I = arg2->i;
158: arg2 =(lispval) &fake2;
159: break;
160: default:
161: error("non-numeric argument",FALSE);
162: }
163: if(Lzerop()!=nil) return(handy);
164: divbig(arg1,arg2,0,&handy);
165: if(handy==((lispval)&fake1))
166: handy = inewint(fake1.I);
167: if(handy==((lispval)&fake2))
168: handy = inewint(fake2.I);
169: return(handy);
170:
171: }
172:
173:
174: lispval
175: Ladd1()
176: {
177: register lispval handy;
178: lispval Ladd();
179: snpand(1); /* fixup entry mask */
180:
181: handy = rdrint;
182: handy->i = 1;
183: protect(handy);
184: return(Ladd());
185:
186: }
187:
188: lispval
189: Lsub1()
190: {
191: register lispval handy;
192: lispval Ladd();
193: snpand(1); /* fixup entry mask */
194:
195: handy = rdrint;
196: handy->i = - 1;
197: protect(handy);
198: return(Ladd());
199: }
200:
201: lispval
202: Lminus()
203: {
204: register lispval arg1, handy;
205: register temp;
206: lispval subbig();
207: snpand(3); /* clobber save mask */
208:
209: chkarg(1);
210: arg1 = lbot->val;
211: handy = nil;
212: switch(TYPE(arg1)) {
213: case INT:
214: handy= inewint(0 - arg1->i);
215: break;
216: case DOUB:
217: handy = newdoub();
218: handy->r = -arg1->r;
219: break;
220: case SDOT:
221: handy = rdrsdot;
222: handy->I = 0;
223: handy->CDR = (lispval) 0;
224: handy = subbig(handy,arg1);
225: break;
226:
227: default:
228: error("non-numeric argument",FALSE);
229: }
230: return(handy);
231: }
232:
233: lispval
234: Lnegp()
235: {
236: register lispval handy = np[-1].val, work;
237: register flag = 0;
238: snpand(3); /* clobber save mask */
239:
240: loop:
241: switch(TYPE(handy)) {
242: case INT:
243: if(handy->i < 0) flag = TRUE;
244: break;
245: case DOUB:
246: if(handy->r < 0) flag = TRUE;
247: break;
248: case SDOT:
249: for(work = handy; work->CDR!=(lispval) 0; work = work->CDR);
250: if(work->I < 0) flag = TRUE;
251: break;
252: default:
253: handy = errorh(Vermisc,
254: "minusp: Non-(int,real,bignum) arg: ",
255: nil,
256: TRUE,
257: 0,
258: handy);
259: goto loop;
260: }
261: if(flag) return(tatom);
262: return(nil);
263: }
264:
265: lispval
266: Labsval()
267: {
268: register lispval arg1, handy;
269: register temp;
270: snpand(3); /* clobber save mask */
271:
272: chkarg(1);
273: arg1 = lbot->val;
274: if(Lnegp()!=nil) return(Lminus());
275:
276: return(arg1);
277: }
278:
279: #include "frame.h"
280: /* new version of showstack,
281: We will set fp to point where the register fp points.
282: Then fp+2 = saved ap
283: fp+4 = saved pc
284: fp+3 = saved fp
285: ap+1 = first arg
286: If we find that the saved pc is somewhere in the routine eval,
287: then we print the first argument to that eval frame. This is done
288: by looking one beyond the saved ap.
289: */
290: lispval
291: Lshostk()
292: { lispval isho();
293: return(isho(1));
294: }
295: static lispval
296: isho(f)
297: int f;
298: {
299: register struct frame *myfp; register lispval handy;
300: int **fp; /* this must be the first local */
301: int virgin=1;
302: lispval _qfuncl(),tynames(); /* locations in qfuncl */
303:
304: if(f==1)
305: printf("Forms in evaluation:\n");
306: else
307: printf("Backtrace:\n\n");
308:
309: myfp = (struct frame *) (&fp +1); /* point to current frame */
310:
311: while(TRUE)
312: {
313: if( (myfp->pc > eval && /* interpreted code */
314: myfp->pc < popnames)
315: ||
316: (myfp->pc > _qfuncl && /* compiled code */
317: myfp->pc < tynames) )
318: {
319: handy = (myfp->ap[1]);
320: if(f==1)
321: printr(handy,stdout), putchar('\n');
322: else {
323: if(virgin)
324: virgin = 0;
325: else
326: printf(" -- ");
327: printr((TYPE(handy)==DTPR)?handy->car:handy,stdout);
328: }
329:
330: }
331:
332: if(myfp > myfp->fp) break; /* end of frames */
333: else myfp = myfp->fp;
334: }
335: putchar('\n');
336: return(nil);
337: }
338: lispval
339: Lbaktrace()
340: {
341: isho(0);
342: }
343: /* ===========================================================
344: -
345: **** baktrace **** (moved back by kls)
346: -
347: - baktrace will print the names of all functions being evaluated
348: - from the current one (baktrace) down to the first one.
349: - currently it only prints the function name. Planned is a
350: - list of local variables in all stack frames.
351: - written by jkf.
352: -
353: -============================================================*/
354:
355: /*=============================================================
356: -
357: -*** oblist ****
358: -
359: - oblist returns a list of all symbols in the oblist
360: -
361: - written by jkf.
362: ============================================================*/
363:
364: lispval
365: Loblist()
366: {
367: int indx;
368: lispval headp, tailp ;
369: struct atom *symb ;
370:
371: headp = tailp = newdot(); /* allocate first DTPR */
372: protect(headp); /*protect the list from garbage collection*/
373: /*line added by kls */
374:
375: for( indx=0 ; indx <= HASHTOP-1 ; indx++ ) /* though oblist */
376: {
377: for( symb = hasht[indx] ;
378: symb != (struct atom *) CNIL ;
379: symb = symb-> hshlnk)
380: {
381: tailp->car = (lispval) symb ; /* remember this atom */
382: tailp = tailp->cdr = newdot() ; /* link to next DTPR */
383: }
384: }
385:
386: tailp->cdr = nil ; /* close the list unfortunately throwing away
387: the last DTPR
388: */
389: return(headp);
390: }
391:
392: /*
393: * Maclisp setsyntax function:
394: * (setsyntax c s x)
395: * c represents character either by fixnum or atom
396: * s is the atom "macro" or the atom "splicing" (in which case x is the
397: * macro to be invoked); or nil (meaning don't change syntax of c); or
398: * (well thats enough for now) if s is a fixnum then we modify the bits
399: * for c in the readtable.
400: */
401: #define VMAC 0316
402: #define VSPL 0315
403: #define VDQ 0212
404: #define VESC 0217
405: #include "chkrtab.h"
406:
407: lispval
408: Lsetsyn()
409: {
410: register lispval s, c;
411: register struct argent *mynp;
412: register index;
413: register struct argent *lbot, *np;
414: lispval x;
415: extern char *ctable;
416: int value;
417:
418: chkarg(3);
419: s = Vreadtable->clb;
420: chkrtab(s);
421: mynp = lbot;
422: c = (mynp++)->val;
423: s = (mynp++)->val;
424: x = (mynp++)->val;
425:
426: switch(TYPE(c)) {
427: default:
428: error("neither fixnum nor atom as char to setsyntax",FALSE);
429:
430: case ATOM:
431: index = *(c->pname);
432: if((c->pname)[1])error("Only 1 char atoms to setsyntax",FALSE);
433: break;
434:
435: case INT:
436: index = c->i;
437: }
438: switch(TYPE(s)) {
439: case INT:
440: if(s->i == VESC) Xesc = (char) index;
441: else if(s->i == VDQ) Xdqc = (char) index;
442:
443: if(ctable[index] == VESC /* if we changed the current esc */
444: && s->i != VESC /* to something else, pick current */
445: && Xesc == (char) index) {
446: ctable[index] = s->i;
447: rpltab(VESC,&Xesc);
448: }
449: else if(ctable[index] == VDQ /* likewise for double quote */
450: && s->i != VDQ
451: && Xdqc == (char) index) {
452: ctable[index] = s->i;
453: rpltab(VDQ,&Xdqc);
454: }
455: else ctable[index] = s->i;
456:
457: break;
458: case ATOM:
459: if(s==splice)
460: ctable[index] = VSPL;
461: else if(s==macro)
462: ctable[index] = VMAC;
463: if(TYPE(c)!=ATOM) {
464: strbuf[0] = index;
465: strbuf[1] = 0;
466: c = (getatom());
467: }
468: Iputprop(c,x,macro);
469: }
470: return(tatom);
471: }
472:
473:
474:
475: /* this aux function is used by setsyntax to determine the new current
476: escape or double quote character. It scans the character table for
477: the first character with the given class (either VESC or VDQ) and
478: puts that character in Xesc or Xdqc (whichever is pointed to by
479: addr).
480: */
481: rpltab(cclass,addr)
482: char cclass;
483: char *addr;
484: {
485: register int i;
486: extern char *ctable;
487: for(i=0; i<=127 && ctable[i] != cclass; i++);
488: if(i<=127) *addr = (char) i;
489: else *addr = '\0';
490: }
491:
492:
493:
494: lispval
495: Lzapline()
496: {
497: register FILE *port;
498: extern FILE * rdrport;
499:
500: port = rdrport;
501: while (!feof(port) && (getc(port)!='\n') );
502: return(nil);
503: }
504:
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.