![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to lam1.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 lam1.c CVS log | Up to [CSRG BSD Unix] / 40BSD / cmd / lisp |
1.1 root 1: static char *sccsid = "@(#)lam1.c 34.3 10/24/80";
2:
3: # include "global.h"
4: # include <sgtty.h>
5: # include "chkrtab.h"
6: /**************************************************************************/
7: /* */
8: /* file: ccdfns.i */
9: /* contents: LISP functions coded in C */
10: /* */
11: /* These include LISP primitives, numeric and boolean functions and */
12: /* predicates, some list-processing functions, i/o support functions */
13: /* and control flow functions (e.g. cont, break). */
14: /* There are two types of functions: lambda (prefixed "L") and nlambda */
15: /* (prefixed "N"). */
16: /* Lambda's all call chkarg to insure that at least the minimum number */
17: /* of necessary arguments are on the namestack. */
18: /* All functions take their arguments from the namestack in a read- */
19: /* only manner, and return their results via the normal C value */
20: /* return mechanism. */
21: /* */
22:
23: lispval
24: Leval()
25: {
26: register lispval temp;
27:
28: chkarg(1,"eval");
29: temp = lbot->val;
30: return(eval(temp));
31: }
32:
33: lispval
34: Lxcar()
35: { register int typ;
36: register lispval temp, result;
37:
38: chkarg(1,"xcar");
39: temp = lbot->val;
40: if (((typ = TYPE(temp)) == DTPR) || (typ == ATOM) || HUNKP(temp))
41: return(temp->d.car);
42: else if(typ == SDOT) {
43: result = inewint(temp->i);
44: return(result);
45: } else if(Schainp!=nil && typ==ATOM)
46: return(nil);
47: else
48: return(error("Bad arg to car",FALSE));
49:
50: }
51:
52: lispval
53: Lxcdr()
54: { register int typ;
55: register lispval temp, result;
56:
57: chkarg(1,"xcdr");
58: temp = lbot->val;
59: if(temp==nil) return (nil);
60:
61: if (((typ = TYPE(temp)) == DTPR) || HUNKP(temp))
62: return(temp->d.cdr);
63: else if(typ==SDOT) {
64: if(temp->s.CDR==0) return(nil);
65: return(temp->s.CDR);
66: } else if(Schainp!=nil && typ==ATOM)
67: return(nil);
68: else
69: return(error("Bad arg to cdr", FALSE));
70: }
71:
72: lispval
73: cxxr(as,ds)
74: register int as,ds;
75: {
76:
77: register lispval temp, temp2;
78: int i, typ;
79: lispval errorh();
80:
81: chkarg(1,"c{ad}+r");
82: temp = lbot->val;
83:
84: for( i=0 ; i<ds ; i++)
85: {
86: if( temp != nil)
87: {
88: typ = TYPE(temp);
89: if ((typ == DTPR) || HUNKP(temp))
90: temp = temp->d.cdr;
91: else
92: if(typ==SDOT)
93: {
94: if(temp->s.CDR==0)
95: temp = nil;
96: else
97: temp = temp->s.CDR;
98: }
99: else
100: if(Schainp!=nil && typ==ATOM)
101: return(nil);
102: else
103: return(errorh(Vermisc,"Bad arg to cdr",nil,FALSE,5,temp));
104: }
105: }
106:
107: for( i=0 ; i<as ; i++)
108: {
109: if( temp != nil )
110: {
111: typ = TYPE(temp);
112: if ((typ == DTPR) || HUNKP(temp))
113: temp = temp->d.car;
114: else if(typ == SDOT)
115: temp2 = inewint(temp->i), temp = temp2;
116: else if(Schainp!=nil && typ==ATOM)
117: return(nil);
118: else
119: return(errorh(Vermisc,"Bad arg to car",nil,FALSE,5,temp));
120: }
121: }
122:
123: return(temp);
124: }
125:
126: lispval
127: Lcar()
128: { return(cxxr(1,0)); }
129:
130: lispval
131: Lcdr()
132: { return(cxxr(0,1)); }
133:
134: lispval
135: Lcadr()
136: { return(cxxr(1,1)); }
137:
138: lispval
139: Lcaar()
140: { return(cxxr(2,0)); }
141:
142: lispval
143: Lc02r()
144: { return(cxxr(0,2)); } /* cddr */
145:
146: lispval
147: Lc12r()
148: { return(cxxr(1,2)); } /* caddr */
149:
150: lispval
151: Lc03r()
152: { return(cxxr(0,3)); } /* cdddr */
153:
154: lispval
155: Lc13r()
156: { return(cxxr(1,3)); } /* cadddr */
157:
158: lispval
159: Lc04r()
160: { return(cxxr(0,4)); } /* cddddr */
161:
162: lispval
163: Lc14r()
164: { return(cxxr(1,4)); } /* caddddr */
165:
166: /*
167: *
168: * (nthelem num list)
169: *
170: * Returns the num'th element of the list, by doing a caddddd...ddr
171: * where there are num-1 d's. If num<=0 or greater than the length of
172: * the list, we return nil.
173: *
174: */
175:
176: lispval
177: Lnthelem()
178: {
179: register lispval temp;
180: register int i;
181:
182: chkarg(2,"nthelem");
183:
184: if( TYPE(temp = lbot->val) != INT)
185: return (error ("First arg to nthelem must be a fixnum",FALSE));
186:
187: i = temp->i; /* pick up the first arg */
188:
189: if( i <= 0) return(nil);
190:
191: ++lbot; /* fix lbot for call to cxxr() 'cadddd..r' */
192: temp = cxxr(1,i-1);
193: --lbot;
194:
195: return(temp);
196: }
197:
198: lispval
199: Lscons()
200: {
201: register struct argent *argp = lbot;
202: register lispval retp, handy;
203: register int typ;
204:
205: chkarg(2,"scons");
206: retp = newsdot();
207: handy = (argp) -> val;
208: if(TYPE(handy)!=INT)
209: error("First arg to scons must be an int.",FALSE);
210: retp->s.I = handy->i;
211: handy = (argp+1)->val;
212: if(handy==nil)
213: retp->s.CDR = (lispval) 0;
214: else {
215: if(TYPE(handy)!=SDOT)
216: error("Currently you may only link sdots to sdots.",FALSE);
217: retp->s.CDR = handy;
218: }
219: return(retp);
220: }
221:
222: lispval
223: Lcons()
224: {
225: register lispval retp;
226: register struct argent *argp;
227:
228: chkarg(2,"cons");
229: retp = newdot();
230: retp->d.car = ((argp = lbot) -> val);
231: retp->d.cdr = argp[1].val;
232: return(retp);
233: }
234: #define CA 0
235: #define CD 1
236:
237: lispval
238: rpla(what)
239: int what;
240: { register struct argent *argp;
241: register int typ; register lispval first, second;
242:
243: chkarg(2,"rplac[ad]");
244: argp = np-1;
245: first = (argp-1)->val;
246: while(first==nil)
247: first = error("Attempt to rplac[ad] nil.",TRUE);
248: second = argp->val;
249: if (((typ = TYPE(first)) == DTPR) || (typ == ATOM) || HUNKP(first)) {
250: if (what == CA)
251: first->d.car = second;
252: else
253: first->d.cdr = second;
254: return(first);
255: }
256: if (typ==SDOT) {
257: if(what == CA) {
258: typ = TYPE(second);
259: if(typ!=INT) error("Rplacca of a bignum will only replace INTS",FALSE);
260: first->s.I = second->i;
261: } else {
262: if(second==nil)
263: first->s.CDR = (lispval) 0;
264: else
265: first->s.CDR = second;
266: }
267: return(first);
268: }
269: return(error("Bad arg to rpla",FALSE));
270: }
271: lispval
272: Lrplaca()
273: { return(rpla(CA)); }
274:
275: lispval
276: Lrplacd()
277: { return(rpla(CD)); }
278:
279:
280: lispval
281: Leq()
282: {
283: register struct argent *mynp = lbot + AD;
284: int itemp, flag;
285:
286: chkarg(2,"eq");
287: if(mynp->val==(mynp+1)->val) return(tatom);
288: return(nil);
289: }
290:
291:
292:
293: lispval
294: Lnull()
295: { chkarg(1,"null");
296: return ((lbot->val == nil) ? tatom : nil);
297: }
298:
299:
300:
301: /* Lreturn **************************************************************/
302: /* Returns the first argument - which is nill if not specified. */
303:
304: Lreturn()
305: {
306: snpand(0);
307: if(lbot==np) protect (nil);
308: contval = lbot->val;
309: reset(BRRETN);
310: }
311:
312:
313: /* Lretbrk **************************************************************/
314: /* The first argument must be an integer and must be in the range */
315: /* -1 .. -depth. */
316: lispval
317: Lretbrk()
318: {
319: lispval number;
320: register level;
321:
322: snpand(1);
323: if(lbot==np) protect (nil);
324: number = lbot->val;
325: if (TYPE(number) != INT)
326: level = -1;
327: else
328: level = number->i;
329: if(level < 0)
330: level += depth;
331: contval = (lispval) level;
332: if (level < depth)
333: reset(BRRETB);
334: return(nil);
335: }
336:
337:
338:
339: lispval
340: Linfile()
341: {
342: FILE *port;
343: register lispval name;
344: int typ;
345: snpand(1);
346:
347: chkarg(1,"infile");
348: name = lbot->val;
349: loop:
350: name = verify(name,"infile: file name must be atom or string");
351: /* return nil if file couldnt be opened
352: if ((port = fopen((char *)name,"r")) == NULL) return(nil); */
353:
354: if ((port = fopen((char *)name,"r")) == NULL) {
355: name = errorh(Vermisc,"Unable to open file for reading.",nil,TRUE,31,name);
356: goto loop;
357: }
358: ioname[PN(port)] = (lispval) inewstr(name); /* remember name */
359: return(P(port));
360: }
361:
362: lispval
363: Loutfile()
364: {
365: FILE *port; register lispval name;
366:
367: chkarg(1,"outfile");
368: name = lbot->val;
369: loop:
370: name = verify(name,"Please supply atom or string name for port.");
371: if ((port = fopen(name,"w")) == NULL) {
372: name = errorh(Vermisc,"Unable to open file for writing.",nil,TRUE,31,name);
373: goto loop;
374: }
375: ioname[PN(port)] = (lispval) inewstr(name);
376: return(P(port));
377: }
378:
379: lispval
380: Lterpr()
381: {
382: FILE *port;
383:
384: snpand(0);
385: if(lbot==np) protect (nil);
386: port = okport(lbot->val,okport(Vpoport->a.clb,stdout));
387: putc('\n',port);
388: fflush(port);
389: return(nil);
390: }
391:
392: lispval
393: Lclose()
394: {
395: lispval port;
396:
397: if(lbot==np)
398: port = error("Close requires one argument of type port",TRUE);
399: port = lbot->val;
400: if((TYPE(port))==PORT) fclose(port->p);
401: ioname[PN(port->p)] = nil;
402: return(tatom);
403: }
404:
405: lispval
406: Lnwritn()
407: {
408: register FILE *port;
409: register value;
410:
411: snpand(2);
412: if(lbot==np) protect (nil);
413: port = okport(lbot->val,okport(Vpoport->a.clb,stdout));
414: value = port->_ptr - port->_base;
415: return(inewint(value));
416: }
417:
418: lispval
419: Ldrain()
420: {
421: register FILE *port;
422: register int iodes;
423: struct sgttyb arg;
424:
425: snpand(2);
426: if(lbot==np) protect (nil);
427: port = okport(lbot->val, okport(Vpoport->a.clb,stdout));
428: if(port->_flag & _IOWRT) {
429: fflush(port);
430: return(nil);
431: }
432: if(! port->_flag & _IOREAD) return(nil);
433: port->_cnt = 0;
434: port->_ptr = port->_base;
435: iodes = fileno(port);
436: if(gtty(iodes,&arg) != -1) stty(iodes,&arg);
437: return((lispval)(xports + (port - _iob)));
438: }
439:
440: lispval
441: Llist()
442: {
443: /* added for the benefit of mapping functions. */
444: register struct argent *ulim, *namptr;
445: register lispval temp, result;
446: register struct argent *lbot, *np;
447:
448: ulim = np;
449: namptr = lbot + AD;
450: temp = result = (lispval) np;
451: protect(nil);
452: for(; namptr < ulim;) {
453: temp = temp->l = newdot();
454: temp->d.car = (namptr++)->val;
455: }
456: temp->l = nil;
457: return(result->l);
458: }
459:
460: lispval
461: Lnumberp()
462: {
463: chkarg(1,"numberp");
464: switch(TYPE(lbot->val)) {
465: case INT: case DOUB: case SDOT:
466: return(tatom);
467: }
468: return(nil);
469: }
470:
471: lispval
472: Latom()
473: {
474: register struct argent *lb = lbot;
475: chkarg(1,"atom");
476: if(TYPE(lb->val)==DTPR || (HUNKP(lb->val)))
477: return(nil);
478: else
479: return(tatom);
480: }
481:
482: lispval
483: Ltype()
484: {
485: chkarg(1,"type");
486: switch(TYPE(lbot->val)) {
487: case INT:
488: return(int_name);
489: case ATOM:
490: return(atom_name);
491: case SDOT:
492: return(sdot_name);
493: case DOUB:
494: return(doub_name);
495: case DTPR:
496: return(dtpr_name);
497: case STRNG:
498: return(str_name);
499: case ARRAY:
500: return(array_name);
501: case BCD:
502: return(funct_name);
503:
504: case HUNK2:
505: return(hunk_name[0]);
506: case HUNK4:
507: return(hunk_name[1]);
508: case HUNK8:
509: return(hunk_name[2]);
510: case HUNK16:
511: return(hunk_name[3]);
512: case HUNK32:
513: return(hunk_name[4]);
514: case HUNK64:
515: return(hunk_name[5]);
516: case HUNK128:
517: return(hunk_name[6]);
518:
519: case VALUE:
520: return(val_name);
521: case PORT:
522: return(port_name);
523: }
524: return(nil);
525: }
526:
527: lispval
528: Ldtpr()
529: {
530: chkarg(1,"dtpr");
531: return(typred(DTPR, lbot->val));
532: }
533:
534: lispval
535: Lbcdp()
536: {
537: chkarg(1,"bcdp");
538: return(typred(BCD, lbot->val));
539: }
540:
541: lispval
542: Lportp()
543: {
544: chkarg(1,"portp");
545: return(typred(PORT, lbot->val));
546: }
547:
548: lispval
549: Larrayp()
550: {
551: chkarg(1,"arrayp");
552: return(typred(ARRAY, lbot->val));
553: }
554:
555: /*
556: * (hunkp 'g_arg1)
557: * Returns t if g_arg1 is a hunk, otherwise returns nil.
558: */
559:
560: lispval
561: Lhunkp()
562: {
563: chkarg(1,"hunkp");
564: if (HUNKP(lbot->val))
565: return(tatom); /* If a hunk, return t */
566: else
567: return(nil); /* else nil */
568: }
569:
570: lispval
571: Lset()
572: {
573: lispval varble;
574: snpand(0);
575:
576: chkarg(2,"set");
577: varble = lbot->val;
578: switch(TYPE(varble))
579: {
580: case ATOM: return(varble->a.clb = lbot[1].val);
581:
582: case VALUE: return(varble->l = lbot[1].val);
583: }
584:
585: error("IMPROPER USE OF SET",FALSE);
586: }
587:
588: lispval
589: Lequal()
590: {
591: register lispval first, second;
592: register type1, type2;
593: register struct argent *lbot, *np;
594: lispval Lsub(),Lzerop(), *stack(), unstack(), *sp();
595: lispval *oldsp; int mustloop = FALSE, result;
596: chkarg(2,"equal");
597:
598:
599: if(lbot->val==lbot[1].val) return(tatom);
600:
601: for((oldsp=sp(), stack(lbot->val,lbot[1].val));
602: oldsp > sp();) {
603:
604: first = unstack(); second = unstack();
605: again:
606: if(first==second) continue;
607:
608: type1=TYPE(first); type2=TYPE(second);
609: if(type1!=type2) {
610: if((type1==SDOT&&type2==INT)||(type1==INT&&type2==SDOT))
611: goto dosub;
612: return(nil);
613: }
614: switch(type1) {
615: case DTPR:
616: stack(first->d.cdr,second->d.cdr);
617: first = first->d.car; second = second->d.car;
618: goto again;
619: case DOUB:
620: if(first->r!=second->r)
621: return(nil);
622: continue;
623: case INT:
624: if(first->i!=second->i)
625: return(nil);
626: continue;
627: dosub:
628: case SDOT:
629: lbot = np;
630: np++->val = first;
631: np++->val = second;
632: lbot->val = Lsub();
633: if(TYPE(lbot->val)!=INT || lbot->val->i!=0)
634: return(nil);
635: np = lbot;
636: continue;
637: case VALUE:
638: if(first->l!=second->l)
639: return(nil);
640: continue;
641: case STRNG:
642: if(strcmp(first,second)!=0)
643: return(nil);
644: continue;
645:
646: default:
647: return(nil);
648: }
649: }
650: return(tatom);
651: }
652: lispval
653: oLequal()
654: {
655: chkarg(2,"equal");
656:
657: if( lbot[1].val == lbot->val ) return(tatom);
658: if(Iequal(lbot[1].val,lbot->val)) return(tatom); else return(nil);
659: }
660:
661: Iequal(first,second)
662: register lispval first, second;
663: {
664: register type1, type2;
665: register struct argent *lbot, *np;
666: lispval Lsub(),Lzerop();
667:
668: if(first==second)
669: return(1);
670: type1=TYPE(first);
671: type2=TYPE(second);
672: if(type1!=type2) {
673: if((type1==SDOT&&type2==INT)||(type1==INT&&type2==SDOT))
674: goto dosub;
675: return(0);
676: }
677: switch(type1) {
678: case DTPR:
679: return(
680: Iequal(first->d.car,second->d.car) &&
681: Iequal(first->d.cdr,second->d.cdr) );
682: case DOUB:
683: return(first->r==second->r);
684: case INT:
685: return( (first->i==second->i));
686: dosub:
687: case SDOT:
688: lbot = np;
689: np++->val = first;
690: np++->val = second;
691: lbot->val = Lsub();
692: np = lbot + 1;
693: return(TYPE(lbot->val)==INT&& lbot->val->i==0);
694: case VALUE:
695: return( first->l==second->l );
696: case STRNG:
697: return(strcmp(first,second)==0);
698: }
699: return(0);
700: }
701: lispval
702: Zequal()
703: {
704: register lispval first, second;
705: register type1, type2;
706: register struct argent *lbot, *np;
707: lispval Lsub(),Lzerop(), *stack(), unstack(), *sp();
708: lispval *oldsp; int mustloop = FALSE, result;
709: chkarg(2,"equal");
710:
711:
712: if(lbot->val==lbot[1].val) return(tatom);
713:
714: for((oldsp=sp(), stack(lbot->val,lbot[1].val));
715: oldsp > sp();) {
716:
717: first = unstack(); second = unstack();
718: again:
719: if(first==second) continue;
720:
721: type1=TYPE(first); type2=TYPE(second);
722: if(type1!=type2) {
723: if((type1==SDOT&&type2==INT)||(type1==INT&&type2==SDOT))
724: goto dosub;
725: return(nil);
726: }
727: switch(type1) {
728: case DTPR:
729: stack(first->d.cdr,second->d.cdr);
730: first = first->d.car; second = second->d.car;
731: goto again;
732: case DOUB:
733: if(first->r!=second->r)
734: return(nil);
735: continue;
736: case INT:
737: if(first->i!=second->i)
738: return(nil);
739: continue;
740: dosub:
741: case SDOT:
742: lbot = np;
743: np++->val = first;
744: np++->val = second;
745: lbot->val = Lsub();
746: if(TYPE(lbot->val)!=INT || lbot->val->i!=0)
747: return(nil);
748: np = lbot;
749: continue;
750: case VALUE:
751: if(first->l!=second->l)
752: return(nil);
753: continue;
754: case STRNG:
755: if(strcmp(first,second)!=0)
756: return(nil);
757: continue;
758: }
759: }
760: return(tatom);
761: }
762:
763: lispval
764: Lprint()
765: {
766: extern int prinlevel,prinlength;
767:
768: snpand(0);
769: if(np-lbot==1) protect(nil);
770: chkarg(2,"print");
771: chkrtab(Vreadtable->a.clb);
772: if(TYPE(Vprinlevel->a.clb) == INT)
773: {
774: prinlevel = Vprinlevel->a.clb->i;
775: }
776: else prinlevel = -1;
777: if(TYPE(Vprinlength->a.clb) == INT)
778: {
779: prinlength = Vprinlength->a.clb->i;
780: }
781: else prinlength = -1;
782: printr(lbot->val,okport(lbot[1].val,okport(Vpoport->a.clb,poport)));
783: return(nil);
784: }
785:
786: /* patom does not use prinlevel or prinlength */
787: lispval
788: Lpatom()
789: {
790: register lispval temp;
791: register int typ;
792: FILE *port;
793: extern int prinlevel,prinlength;
794:
795: snpand(2);
796: if(np-lbot==1) protect(nil);
797: chkarg(2,"patom");
798: temp = Vreadtable->a.clb;
799: chkrtab(temp);
800: port = okport(lbot[1].val, okport(Vpoport->a.clb,stdout));
801: if ((typ= TYPE((temp = (lbot)->val))) == ATOM)
802: fputs(temp->a.pname, port);
803: else if(typ == STRNG)
804: fputs(temp,port);
805: else
806: {
807: printr(temp, port);
808: }
809: return(temp);
810: }
811:
812: /*
813: * (pntlen thing) returns the length it takes to print out
814: * an atom or number.
815: */
816:
817: lispval
818: Lpntlen()
819: {
820: register lispval temp;
821: return(inewint(Ipntlen()));
822: }
823: Ipntlen()
824: {
825: register lispval temp;
826: register char *handy;
827:
828: temp = np[-1].val;
829: loop: switch(TYPE(temp)) {
830:
831: case ATOM:
832: handy = temp->a.pname;
833: break;
834:
835: case STRNG:
836: handy = (char *) temp;
837: break;
838:
839: case INT:
840: sprintf(strbuf,"%d",temp->i);
841: handy =strbuf;
842: break;
843:
844: case DOUB:
845: sprintf(strbuf,"%g",temp->r);
846: handy =strbuf;
847: break;
848:
849: default:
850: temp = error("Non atom or number to pntlen\n",TRUE);
851: goto loop;
852: }
853:
854: return( strlen(handy));
855: }
856: #undef okport
857: FILE *
858: okport(arg,proper)
859: lispval arg;
860: FILE *proper;
861: {
862: if(TYPE(arg)!=PORT)
863: return(proper);
864: else
865: return(arg->p);
866: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.