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