![[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] / 3BSD / cmd / lisp|
Return to lam1.c CVS log | Up to [CSRG BSD Unix] / 3BSD / cmd / lisp |
1.1 root 1:
2: # include "global.h"
3: # include <sgtty.h>
4: # include "chkrtab.h"
5: /**************************************************************************/
6: /* */
7: /* file: ccdfns.i */
8: /* contents: LISP functions coded in C */
9: /* */
10: /* These include LISP primitives, numeric and boolean functions and */
11: /* predicates, some list-processing functions, i/o support functions */
12: /* and control flow functions (e.g. cont, break). */
13: /* There are two types of functions: lambda (prefixed "L") and nlambda */
14: /* (prefixed "N"). */
15: /* Lambda's all call chkarg to insure that at least the minimum number */
16: /* of necessary arguments are on the namestack. */
17: /* All functions take their arguments from the namestack in a read- */
18: /* only manner, and return their results via the normal C value */
19: /* return mechanism. */
20: /* */
21:
22:
23:
24: lispval
25: Leval()
26: {
27: register lispval temp;
28:
29: chkarg(1);
30: temp = lbot->val;
31: return(eval(temp));
32: }
33:
34: lispval
35: Lxcar()
36: { register int typ;
37: register lispval temp, result;
38:
39: chkarg(1);
40: temp = lbot->val;
41: if (((typ = TYPE(temp)) == DTPR) || (typ == ATOM))
42: return(temp -> car);
43: else if(typ == SDOT) {
44: result = inewint(temp->i);
45: return(result);
46: } else if(Schainp!=nil && typ==ATOM)
47: return(nil);
48: else
49: return(error("BAD ARG TO CAR",FALSE));
50:
51: }
52:
53: lispval
54: Lxcdr()
55: { register int typ;
56: register lispval temp, result;
57:
58: chkarg(1);
59: temp = lbot->val;
60: if(temp==nil) return (nil);
61:
62: if ((typ = TYPE(temp)) == DTPR)
63: return(temp -> cdr);
64: else if(typ==SDOT) {
65: if(temp->CDR==0) return(nil);
66: return(temp->CDR);
67: } else if(Schainp!=nil && typ==ATOM)
68: return(nil);
69: else
70: return(error("BAD ARG TO CDR",FALSE));
71: }
72:
73: lispval
74: cxxr(as,ds)
75: register int as,ds;
76: {
77:
78: register lispval temp, temp2;
79: int i, typ;
80: lispval errorh();
81:
82: chkarg(1);
83: temp = lbot->val;
84:
85: for( i=0 ; i<ds ; i++)
86: {
87: if( temp != nil)
88: {
89: if ((typ = TYPE(temp)) == DTPR)
90: temp = temp -> cdr;
91: else if(typ==SDOT) {
92: if(temp->CDR==0) temp = nil;
93: else temp = temp->CDR;
94: }
95: else if(Schainp!=nil && typ==ATOM)
96: return(nil);
97: else
98: return(errorh(Vermisc,"BAD ARG TO CDR",nil,FALSE,5,temp));
99: }
100: }
101:
102: for( i=0 ; i<as ; i++)
103: {
104: if( temp != nil )
105: {
106: if ((typ = TYPE(temp)) == DTPR)
107: temp = temp -> car;
108: else if(typ == SDOT)
109: temp2 = inewint(temp->i), temp = temp2;
110: else if(Schainp!=nil && typ==ATOM)
111: return(nil);
112: else
113: return(errorh(Vermisc,"BAD ARG TO CAR",nil,FALSE,5,temp));
114: }
115: }
116:
117: return(temp);
118: }
119:
120:
121: lispval
122: Lcar()
123: { return(cxxr(1,0));
124: }
125:
126: lispval
127: Lcdr()
128: { return(cxxr(0,1));
129: }
130:
131: lispval
132: Lcadr()
133: { return(cxxr(1,1));
134: }
135:
136: lispval
137: Lcaar()
138: { return(cxxr(2,0));
139: }
140:
141: lispval
142: Lc02r()
143: { return(cxxr(0,2)); /* cddr */
144: }
145:
146: lispval
147: Lc12r()
148: { return(cxxr(1,2)); /* caddr */
149: }
150:
151: lispval
152: Lc03r()
153: { return(cxxr(0,3)); /* cdddr */
154: }
155:
156: lispval
157: Lc13r()
158: { return(cxxr(1,3)); /* cadddr */
159: }
160:
161: lispval
162: Lc04r()
163: { return(cxxr(0,4)); /* cddddr */
164: }
165:
166: lispval
167: Lc14r()
168: { return(cxxr(1,4)); /* caddddr */
169: }
170:
171: /*************************
172: *
173: * (nthelem num list)
174: * returns the num'th element of the list, by doing a caddddd...ddr
175: * where there are num-1 d's
176: * if num<=0 or greater than the length of the list, we return nil
177: ******************************************************/
178:
179: lispval
180: Lnthelem()
181: {
182: register lispval temp;
183: register int i;
184:
185: chkarg(2);
186:
187: if( TYPE(temp = lbot->val) != INT)
188: return (error ("First arg to nthelem must be a fixnum",FALSE));
189:
190: i = temp->i; /* pick up the first arg */
191:
192: if( i <= 0) return(nil);
193:
194: ++lbot; /* fix lbot for call to cxxr() 'cadddd..r' */
195: temp = cxxr(1,i-1);
196: --lbot;
197:
198: return(temp);
199: }
200:
201:
202:
203:
204:
205: lispval
206: Lscons()
207: {
208: register struct argent *argp = lbot;
209: register lispval retp, handy;
210: register int typ;
211:
212: chkarg(2);
213: retp = newsdot();
214: handy = (argp) -> val;
215: if(TYPE(handy)!=INT)
216: error("First arg to scons must be an int.",FALSE);
217: retp->I = handy->i;
218: handy = (argp+1)->val;
219: if(handy==nil)
220: retp->CDR = (lispval) 0;
221: else {
222: if(TYPE(handy)!=SDOT)
223: error("Currently you may only link sdots to sdots.",FALSE);
224: retp->CDR = handy;
225: }
226: return(retp);
227: }
228: lispval
229: Lcons()
230: { register struct argent *argp;
231: lispval retp;
232:
233: chkarg(2);
234: retp = newdot();
235: retp -> cdr = ((argp = np-1) -> val);
236: retp -> car = (--argp) -> val;
237: return(retp);
238: }
239: #define CA 0
240: #define CD 1
241:
242: lispval
243: rpla(what)
244: int what;
245: { register struct argent *argp;
246: register int typ; register lispval first, second;
247:
248: chkarg(2);
249: argp = np-1;
250: first = (argp-1)->val;
251: while(first==nil)
252: first = error("Attempt to rplac[ad] nil.",TRUE);
253: second = argp->val;
254: if (((typ = TYPE(first)) == DTPR) || (typ == ATOM)) {
255: if (what == CA)
256: first->car = second;
257: else
258: first->cdr = second;
259: return(first);
260: }
261: if (typ==SDOT) {
262: if(what == CA) {
263: typ = TYPE(second);
264: if(typ!=INT) error("Rplacca of a bignum will only replace INTS",FALSE);
265: first->i = second->i;
266: } else {
267: if(second==nil)
268: first->CDR = (lispval) 0;
269: else
270: first->CDR = second;
271: }
272: return(first);
273: }
274: return(error("BAD ARG TO RPLA",FALSE));
275: }
276: lispval
277: Lrplaca()
278: { return(rpla(CA)); }
279:
280: lispval
281: Lrplacd()
282: { return(rpla(CD)); }
283:
284:
285: lispval
286: Leq()
287: {
288: register struct argent *mynp = lbot + AD;
289: int itemp, flag;
290:
291: chkarg(2);
292: if(mynp->val==(mynp+1)->val) return(tatom);
293: return(nil);
294: }
295:
296:
297:
298: lispval
299: Lnull()
300: { chkarg(1);
301: return ((lbot->val == nil) ? tatom : nil);
302: }
303:
304:
305:
306: /* Lreturn **************************************************************/
307: /* Returns the first argument - which is nill if not specified. */
308: Lreturn()
309: {
310: chkarg(1);
311: contval = lbot->val;
312: reset(BRRETN);
313: }
314:
315:
316: /* Lretbrk **************************************************************/
317: /* The first argument must be an integer and must be in the range */
318: /* -1 .. -depth. */
319: lispval
320: Lretbrk()
321: {
322: lispval number;
323: register level;
324:
325:
326: chkarg(1);
327: number = lbot->val;
328: if (TYPE(number) != INT)
329: level = -1;
330: else
331: level = number->i;
332: if(level < 0)
333: level += depth;
334: contval = (lispval) level;
335: if (level < depth)
336: reset(BRRETB);
337: return(nil);
338: }
339:
340:
341:
342: lispval
343: Linfile()
344: {
345: FILE *port;
346: register lispval name;
347: snpand(1);
348:
349: chkarg(1);
350: name = lbot->val;
351: while (TYPE(name)!=ATOM)
352: name = error("Please supply atom name for port.",TRUE);
353: /* return nil if file couldnt be opened
354: if ((port = fopen(name->pname,"r")) == NULL) return(nil); */
355:
356: while ((port = fopen(name->pname,"r")) == NULL)
357: name = errorh(Vermisc,"Unable to open file for reading.",nil,TRUE,31,name);
358:
359: return((lispval)(xports + (port - _iob)));
360: }
361:
362: lispval
363: Loutfile()
364: {
365: FILE *port; register lispval name;
366:
367: chkarg(1);
368: name = lbot->val;
369: while (TYPE(name)!=ATOM)
370: name = error("Please supply atom name for port.",TRUE);
371: while ((port = fopen(name->pname,"w")) == NULL)
372: name = errorh(Vermisc,"Unable to open file for writing.",nil,TRUE,31,name);
373: return((lispval)(xports + (port - _iob)));
374: }
375: lispval
376: Lterpr()
377: {
378: FILE *port;
379:
380: chkarg(1);
381: port = okport(lbot->val,okport(Vpoport->clb,stdout));
382: putc('\n',port);
383: fflush(port);
384: return(nil);
385: }
386: lispval
387: Lclose()
388: {
389: lispval port;
390:
391: if(lbot==np)
392: port = error("Close requires one argument of type port",TRUE);
393: port = lbot->val;
394: if((TYPE(port))==PORT) fclose(port->p);
395: return(tatom);
396: }
397:
398: lispval
399: Lnwritn()
400: {
401: register FILE *port;
402: register value;
403:
404: chkarg(1);
405: port = okport(lbot->val,okport(Vpoport->clb,stdout));
406: value = port->_ptr - port->_base;
407: return(inewint(value));
408: }
409:
410: lispval
411: Ldrain()
412: {
413: register FILE *port;
414: register int iodes;
415: struct sgttyb arg;
416:
417: chkarg(1);
418: port = okport(lbot->val, okport(Vpoport->clb,stdout));
419: if(port->_flag & _IOWRT) {
420: fflush(port);
421: return(nil);
422: }
423: if(! port->_flag & _IOREAD) return(nil);
424: port->_cnt = 0;
425: port->_ptr = port->_base;
426: iodes = fileno(port);
427: if(gtty(iodes,&arg) != -1) stty(iodes,&arg);
428: return((lispval)(xports + (port - _iob)));
429: }
430: lispval
431: Llist()
432: {
433: /* added for the benefit of mapping functions. */
434: register struct argent *ulim, *namptr;
435: register lispval temp, result;
436: register struct argent *lbot, *np;
437:
438: ulim = np;
439: namptr = lbot + AD;
440: temp = result = (lispval) np;
441: protect(nil);
442: for(; namptr < ulim;) {
443: temp = temp->l = newdot();
444: temp->car = (namptr++)->val;
445: }
446: temp->l = nil;
447: return(result->l);
448: }
449:
450: lispval
451: Lnumberp()
452: {
453: chkarg(1);
454: switch(TYPE(lbot->val)) {
455: case INT: case DOUB: case SDOT:
456: return(tatom);
457: }
458: return(nil);
459: }
460:
461: lispval
462: Latom()
463: {
464: chkarg(1);
465: if(TYPE(lbot->val)==DTPR)
466: return(nil);
467: else
468: return(tatom);
469: }
470: lispval
471: Ltype()
472: {
473: chkarg(1);
474: switch(TYPE(lbot->val)) {
475: case INT:
476: return(int_name);
477: case ATOM:
478: return(atom_name);
479: case SDOT:
480: return(sdot_name);
481: case DOUB:
482: return(doub_name);
483: case DTPR:
484: return(dtpr_name);
485: case STRNG:
486: return(str_name);
487: case ARRAY:
488: return(array_name);
489: case BCD:
490: return(funct_name);
491: case VALUE:
492: return(val_name);
493: case PORT:
494: return(matom("port")); /* fix this when name exists */
495: }
496: return(nil);
497: }
498:
499: lispval
500: Ldtpr()
501: {
502: chkarg(1);
503: return(typred(DTPR,lbot->val));
504: }
505:
506: lispval
507: Lbcdp()
508: {
509: chkarg(1);
510: return(typred(BCD,lbot->val));
511: }
512:
513: lispval
514: Lportp()
515: {
516: chkarg(1);
517: return(typred(PORT,lbot->val));
518: }
519:
520: lispval
521: Larrayp()
522: {
523: chkarg(1);
524: return(typred(ARRAY,lbot->val));
525: }
526: lispval
527: Lset()
528: {
529: lispval varble;
530: snpand(0);
531:
532: chkarg(2);
533: varble = lbot->val;
534: switch(TYPE(varble))
535: {
536: case ATOM: return(varble->clb = lbot[1].val);
537:
538: case VALUE: return(varble->l = lbot[1].val);
539: }
540:
541: error("IMPROPER USE OF SET",FALSE);
542: }
543: lispval
544: Lequal()
545: {
546: chkarg(2);
547:
548: if( lbot[1].val == lbot->val ) return(tatom);
549: if(Iequal(lbot[1].val,lbot->val)) return(tatom); else return(nil);
550: }
551:
552: Iequal(first,second)
553: register lispval first, second;
554: {
555: register type1, type2;
556: register struct argent *lbot, *np;
557: lispval Lsub(),Lzerop();
558:
559: if(first==second)
560: return(1);
561: type1=TYPE(first);
562: type2=TYPE(second);
563: if(type1!=type2) {
564: if((type1==SDOT&&type2==INT)||(type1==INT&&type2==SDOT))
565: goto dosub;
566: return(0);
567: }
568: switch(type1) {
569: case DTPR:
570: return(
571: Iequal(first->car,second->car) &&
572: Iequal(first->cdr,second->cdr) );
573: case DOUB:
574: return(first->r==second->r);
575: case INT:
576: return( (first->i==second->i));
577: dosub:
578: case SDOT:
579: lbot = np;
580: np++->val = first;
581: np++->val = second;
582: lbot->val = Lsub();
583: np = lbot + 1;
584: return(Lzerop()!=nil);
585: case VALUE:
586: return( first->l==second->l );
587: case STRNG:
588: return(strcmp(first,second)==0);
589: }
590: return(0);
591: }
592:
593: lispval
594: Lprint()
595: {
596: chkarg(2);
597: chkrtab(Vreadtable->clb);
598: printr(lbot->val,okport(lbot[1].val,okport(Vpoport->clb,poport)));
599: return(nil);
600: }
601:
602: FILE *
603: okport(arg,proper)
604: lispval arg;
605: FILE *proper;
606: {
607: if(TYPE(arg)!=PORT)
608: return(proper);
609: else
610: return(arg->p);
611: }
612: lispval
613: Lpatom()
614: {
615: register lispval temp;
616: FILE *port;
617:
618: chkarg(2);
619: temp = Vreadtable->clb;
620: chkrtab(temp);
621: port = okport(lbot[1].val, okport(Vpoport->clb,stdout));
622: if ((TYPE((temp = (lbot)->val)))!=ATOM)
623: printr(temp, port);
624: else
625: fputs(temp->pname, port);
626: return(temp);
627: }
628:
629: /*
630: * (pntlen thing) returns the length it takes to print out
631: * an atom or number.
632: */
633:
634: lispval
635: Lpntlen()
636: {
637: register lispval temp;
638: return(inewint(Ipntlen()));
639: }
640: Ipntlen()
641: {
642: register lispval temp;
643: register char *handy;
644:
645: temp = np[-1].val;
646: loop: switch(TYPE(temp)) {
647:
648: case ATOM:
649: handy = temp->pname;
650: break;
651:
652: case INT:
653: sprintf(strbuf,"%d",temp->i);
654: handy =strbuf;
655: break;
656:
657: case DOUB:
658: sprintf(strbuf,"%g",temp->r);
659: handy =strbuf;
660: break;
661:
662: default:
663: temp = error("Non atom or number to pntlen\n",TRUE);
664: goto loop;
665: }
666:
667: return( strlen(handy));
668: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.