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