![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to lam2.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 42BSD / ucb / lisp / franz|
Return to lam2.c CVS log | Up to [CSRG BSD Unix] / 42BSD / ucb / lisp / franz |
1.1 root 1: #ifndef lint
2: static char *rcsid =
3: "$Header: /na/franz/franz/RCS/lam2.c,v 1.3 83/08/06 08:37:23 jkf Exp $";
4: #endif
5:
6: /* -[Fri Aug 5 12:46:16 1983 by jkf]-
7: * lam2.c $Locker: $
8: * lambda functions
9: *
10: * (c) copyright 1982, Regents of the University of California
11: */
12:
13: # include "global.h"
14: # include <signal.h>
15: # include "structs.h"
16: # include "chars.h"
17: # include "chkrtab.h"
18: /*
19: * (flatc 'thing ['max]) returns the smaller of max and the number of chars
20: * required to print thing linearly.
21: * if max argument is not given, we assume the second arg is infinity
22: */
23: static flen; /*Internal to this module, used as a running counter of flatsize*/
24: static fmax; /*used for maximum for quick reference */
25: char *strcpy();
26:
27: lispval
28: Lflatsi()
29: {
30: register lispval current;
31: Savestack(1); /* fixup entry mask */
32:
33: fmax = 0x7fffffff; /* biggest integer by default */
34: switch(np-lbot)
35: {
36: case 2: current = lbot[1].val;
37: while(TYPE(current) != INT)
38: current = errorh1(Vermisc,
39: "flatsize: second arg not integer",
40: nil,TRUE,0,current);
41: fmax = current->i;
42: case 1: break;
43: default: argerr("flatsize");
44: }
45:
46: flen = 0;
47: current = lbot->val;
48: protect(nil); /*create space for argument to pntlen*/
49: Iflatsi(current);
50: Restorestack();
51: return(inewint(flen));
52: }
53: /*
54: * Iflatsi does the real work of the calculation for flatc
55: */
56: Iflatsi(current)
57: register lispval current;
58: {
59:
60: if(flen > fmax) return;
61: switch(TYPE(current)) {
62:
63: patom:
64: case INT: case ATOM: case DOUB: case STRNG:
65: np[-1].val = current;
66: flen += Ipntlen();
67: return;
68:
69: pthing:
70: case DTPR:
71: flen++;
72: Iflatsi(current->d.car);
73: current = current->d.cdr;
74: if(current == nil) {
75: flen++;
76: return;
77: }
78: if(flen > fmax) return;
79: switch(TYPE(current)) {
80: case INT: case ATOM: case DOUB:
81: flen += 4;
82: goto patom;
83: case DTPR:
84: goto pthing;
85: }
86: }
87: }
88:
89:
90: #define EADC -1
91: #define EAD -2
92: lispval
93: Lread()
94: { return (r(EAD)); }
95:
96: lispval
97: Lratom()
98: { return (r(ATOM)); }
99:
100: lispval
101: Lreadc()
102: { return (r(EADC)); }
103:
104:
105: extern unsigned char *ctable;
106: /* r *********************************************************************/
107: /* this function maps the desired read function into the system-defined */
108: /* reading functions after testing for a legal port. */
109: lispval
110: r(op)
111: int op;
112: {
113: unsigned char c; register lispval result;
114: register cc;
115: int orlevel; extern int rlevel;
116: FILE *ttemp;
117: struct nament *oldbnp = bnp;
118: Savestack(2);
119:
120: switch(np-lbot) {
121: case 0:
122: protect(nil);
123: case 1:
124: protect(nil);
125: case 2: break;
126: default:
127: argerr("read or ratom or readc");
128: }
129: result = Vreadtable->a.clb;
130: chkrtab(result);
131: orlevel = rlevel;
132: rlevel = 0;
133: ttemp = okport(Vpiport->a.clb,stdin);
134: ttemp = okport(lbot->val,ttemp);
135: /*printf("entering switch\n");*/
136: if(ttemp == stdin) fflush(stdout); /* flush any pending
137: * characters if reading stdin
138: * there should be tests to see
139: * if this is a tty or pipe
140: */
141:
142: switch (op)
143: {
144: case EADC: rlevel = orlevel;
145: cc = getc(ttemp);
146: c = cc;
147: if(cc == EOF)
148: {
149: Restorestack();
150: return(lbot[1].val);
151: } else {
152: strbuf[0] = hash = (c & 0177);
153: strbuf[1] = 0;
154: atmlen = 2;
155: Restorestack();
156: return((lispval)getatom(TRUE));
157: }
158:
159: case ATOM: rlevel = orlevel;
160: result = (ratomr(ttemp));
161: goto out;
162:
163: case EAD: PUSHDOWN(Vpiport,P(ttemp)); /* rebind Vpiport */
164: result = readr(ttemp);
165: out: if(result==eofa)
166: {
167: if(sigintcnt > 0) sigcall(SIGINT);
168: result = lbot[1].val;
169: }
170: rlevel = orlevel;
171: popnames(oldbnp); /* unwind bindings */
172: Restorestack();
173: return(result);
174: }
175: /* NOTREACHED */
176: }
177:
178: /* Lload *****************************************************************/
179: /* Reads in and executes forms from the specified file. This should */
180: /* really be an nlambda taking multiple arguments, but the error */
181: /* handling gets funny in that case (one file out of several not */
182: /* openable, for instance). */
183: lispval
184: Lload()
185: {
186: register FILE *port;
187: register char *p, *ttemp; register lispval vtemp;
188: struct nament *oldbnp = bnp;
189: int orlevel,typ;
190: char longname[100];
191: char *shortname, *end2, *Ilibdir();
192: /*Savestack(4); not necessary because np not altered */
193:
194: chkarg(1,"load");
195: if((typ = TYPE(lbot->val)) == ATOM)
196: ttemp = lbot->val->a.pname ; /* ttemp will point to name */
197: else if(typ == STRNG)
198: ttemp = (char *) lbot->val;
199: else
200: return(error("FILENAME MUST BE ATOMIC",FALSE));
201: strcpy(longname, Ilibdir());
202: for(p = longname; *p; p++);
203: *p++ = '/'; *p = 0;
204: shortname = p;
205: strcpy(p,ttemp);
206: for(; *p; p++);
207: end2 = p;
208: strcpy(p,".l");
209: if ((port = fopen(shortname,"r")) == NULL &&
210: (port = fopen(longname, "r")) == NULL) {
211: *end2 = 0;
212: if ((port = fopen(shortname,"r")) == NULL &&
213: (port = fopen(longname, "r")) == NULL)
214: errorh1(Vermisc,"Can't open file: ",
215: nil,FALSE,0,lbot->val);
216: }
217: orlevel = rlevel;
218: rlevel = 0;
219:
220: if(ISNIL(copval(gcload,CNIL)) &&
221: loading->a.clb != tatom &&
222: ISNIL(copval(gcdis,CNIL)))
223: gc((struct types *)CNIL); /* do a gc if gc will be off */
224:
225: /* shallow bind the value of lisp atom piport */
226: /* so readmacros will work */
227: PUSHDOWN(Vpiport,P(port));
228: PUSHDOWN(loading,tatom); /* set indication of loading status */
229:
230: while ((vtemp = readr(port)) != eofa) {
231: eval(vtemp);
232: }
233: popnames(oldbnp); /* unbind piport, loading */
234:
235: rlevel = orlevel;
236: fclose(port);
237: return(nil);
238: }
239:
240: /* concat **************************************************
241: -
242: - use: (concat arg1 arg2 ... )
243: -
244: - concatenates the print names of all of its arguments.
245: - the arguments may be atoms, integers or real numbers.
246: -
247: - *********************************************************/
248: lispval
249: Iconcat(unintern)
250: {
251: char *sprintf();
252: register struct argent *temnp;
253: register int atmlen; /* Passt auf! atmlen in the external
254: sense calculated by newstr */
255: lispval cur;
256:
257: atmlen = 0 ;
258: strbuf[0] = NULL_CHAR ;
259:
260: /* loop for each argument */
261: for(temnp = lbot + AD ; temnp < np ; temnp++)
262: {
263: cur = temnp->val;
264: loop: if(atmlen > 512) error("concat: string buffer overflow",FALSE);
265: switch(TYPE(cur))
266: {
267: case ATOM:
268: strcpy(&strbuf[atmlen], ((struct atom *) cur) -> pname) ;
269: break;
270:
271: case STRNG:
272: strcpy(&strbuf[atmlen], (char *) cur);
273: break;
274:
275: case INT:
276: sprintf(&strbuf[atmlen],"%d",cur->i);
277: break;
278:
279: case DOUB:
280: sprintf(&strbuf[atmlen],"%f",cur->f);
281: break;
282:
283: case SDOT: {
284: struct _iobuf _myiob;
285:
286: _myiob._flag = _IOWRT+_IOSTRG;
287: _myiob._ptr = &strbuf[atmlen];
288: _myiob._cnt = STRBLEN - 1 - atmlen;
289:
290: pbignum(cur,&_myiob);
291: putc(0,&_myiob);
292: break; }
293:
294: default:
295: cur = error("Non atom or number to concat",TRUE);
296: goto loop; /* if returns value, try it */
297: }
298: atmlen = strlen(strbuf);
299:
300: }
301:
302: if(unintern)
303: return( (lispval) newatom(FALSE)); /* uninterned atoms may
304: have printname gc'd*/
305: else
306: return( (lispval) getatom(FALSE)) ;
307: }
308: lispval
309: Lconcat(){
310: return(Iconcat(FALSE));
311: }
312: lispval
313: Luconcat(){
314: return(Iconcat(TRUE));
315: }
316:
317: lispval
318: Lputprop()
319: {
320: lispval Iputprop();
321: chkarg(3,"putprop");
322: return(Iputprop(lbot->val,lbot[1].val,lbot[2].val));
323: }
324:
325: /*
326: * Iputprop :internal version of putprop used by some C functions
327: * note: prop and ind are lisp values but are not protected (by this
328: * function) from gc. The caller should protect them!!
329: */
330: lispval
331: Iputprop(atm,prop,ind)
332: register lispval prop, ind, atm;
333: {
334: register lispval pptr;
335: lispval *tack; /* place to begin property list */
336: lispval pptr2;
337: lispval errorh();
338: Savestack(4);
339:
340: top:
341: switch (TYPE(atm)) {
342: case ATOM:
343: if(atm == nil) tack = &nilplist;
344: else tack = &(atm->a.plist);
345: break;
346: case DTPR:
347: for (pptr = atm->d.cdr ; pptr != nil ; pptr = pptr->d.cdr->d.cdr)
348: if(TYPE(pptr) != DTPR || TYPE(pptr->d.cdr) != DTPR) break;
349: if(pptr != nil)
350: { atm = errorh1(Vermisc,
351: "putprop: bad disembodied property list",
352: nil,TRUE,0,atm);
353: goto top;
354: }
355: tack = (lispval *) &(atm->d.cdr);
356: break;
357: default:
358: errorh1(Vermisc,"putprop: Bad first argument: ",nil,FALSE,0,atm);
359: }
360: pptr = *tack; /* start of property list */
361: /*findit:*/
362: for (pptr = *tack ; pptr != nil ; pptr = pptr->d.cdr->d.cdr)
363: if (pptr->d.car == ind) {
364: (pptr->d.cdr)->d.car = prop;
365: Restorestack();
366: return(prop);
367: }
368: /* not found, add to front
369: be careful, a gc could occur before the second newdot() */
370:
371: pptr = newdot();
372: pptr->d.car = prop;
373: pptr->d.cdr = *tack;
374: protect(pptr);
375: pptr2 = newdot();
376: pptr2->d.car = ind;
377: pptr2->d.cdr = pptr;
378: *tack = pptr2;
379: Restorestack();
380: return(prop);
381: }
382:
383: /* get from property list
384: * there are three routines to accomplish this
385: * Lget - lisp callable, the first arg can be a symbol or a disembodied
386: * property list. In the latter case we check to make sure it
387: * is a real one (as best we can).
388: * Iget - internal routine, the first arg must be a symbol, no disembodied
389: * plists allowed
390: * Igetplist - internal routine, the first arg is the plist to search.
391: */
392: lispval
393: Lget()
394: {
395: register lispval ind, atm;
396: register lispval dum1;
397: lispval Igetplist();
398:
399: chkarg(2,"get");
400: ind = lbot[1].val;
401: atm = lbot[0].val;
402: top:
403: switch(TYPE(atm)) {
404: case ATOM:
405: if(atm==nil) atm = nilplist;
406: else atm = atm->a.plist;
407: break;
408:
409: case DTPR:
410: for (dum1 = atm->d.cdr; dum1 != nil; dum1 = dum1->d.cdr->d.cdr)
411: if((TYPE(dum1) != DTPR) ||
412: (TYPE(dum1->d.cdr) != DTPR)) break; /* bad prop list */
413: if(dum1 != nil)
414: { atm = errorh1(Vermisc,
415: "get: bad disembodied property list",
416: nil,TRUE,0,atm);
417: goto top;
418: }
419: atm = atm->d.cdr;
420: break;
421: default:
422: /* remove since maclisp doesnt treat
423: this as an error, ugh
424: return(errorh1(Vermisc,"get: bad first argument: ",
425: nil,FALSE,0,atm));
426: */
427: return(nil);
428: }
429:
430: while (atm != nil)
431: {
432: if (atm->d.car == ind)
433: return ((atm->d.cdr)->d.car);
434: atm = (atm->d.cdr)->d.cdr;
435: }
436: return(nil);
437: }
438: /*
439: * Iget - the first arg must be a symbol.
440: */
441:
442: lispval
443: Iget(atm,ind)
444: register lispval atm, ind;
445: {
446: lispval Igetplist();
447:
448: if(atm==nil)
449: atm = nilplist;
450: else
451: atm = atm->a.plist;
452: return(Igetplist(atm,ind));
453: }
454:
455: /*
456: * Igetplist
457: * pptr is a plist
458: * ind is the indicator
459: */
460:
461: lispval
462: Igetplist(pptr,ind)
463: register lispval pptr,ind;
464: {
465: while (pptr != nil)
466: {
467: if (pptr->d.car == ind)
468: return ((pptr->d.cdr)->d.car);
469: pptr = (pptr->d.cdr)->d.cdr;
470: }
471: return(nil);
472: }
473: lispval
474: Lgetd()
475: {
476: register lispval typ;
477:
478: chkarg(1,"getd");
479: typ = lbot->val;
480: if (TYPE(typ) != ATOM)
481: errorh1(Vermisc,
482: "getd: Only symbols have function definitions",
483: nil,
484: FALSE,
485: 0,
486: typ);
487: return(typ->a.fnbnd);
488: }
489: lispval
490: Lputd()
491: {
492: register lispval atom, list;
493:
494: chkarg(2,"putd");
495: list = lbot[1].val;
496: atom = lbot->val;
497: if (TYPE(atom) != ATOM) error("only symbols have function definitions",
498: FALSE);
499: atom->a.fnbnd = list;
500: return(list);
501: }
502:
503: /* ===========================================================
504: - mapping functions which return a list of the answers
505: - mapcar applies the given function to successive elements
506: - maplist applies the given function to successive sublists
507: - ===========================================================*/
508:
509: lispval
510: Lmapcrx(maptyp,join)
511: int maptyp; /* 0 = mapcar, 1 = maplist */
512: int join; /* 0 = the above, 1 = s/car/can/ */
513: {
514: register struct argent *namptr;
515: register index;
516: register lispval temp;
517: register lispval current;
518:
519: struct argent *first, *last;
520: int count;
521: lispval lists[25], result;
522: Savestack(4);
523:
524: namptr = lbot + 1;
525: count = np - namptr;
526: if (count <= 0) return (nil);
527: result = current = (lispval) np;
528: protect(nil); /* set up space for returned list */
529: protect(lbot->val); /*copy funarg for call to funcall */
530: lbot = np -1;
531: first = np;
532: last = np += count;
533: for(index = 0; index < count; index++) {
534: temp =(namptr++)->val;
535: if (TYPE (temp ) != DTPR && temp!=nil)
536: error ( "bad list argument to map",FALSE);
537: lists[index] = temp;
538: }
539: for(;;) {
540: for(namptr=first,index=0; index<count; index++) {
541: temp = lists[index];
542: if(temp==nil) goto done;
543:
544: if(maptyp==0) (namptr++)->val = temp->d.car;
545: else (namptr++)->val = temp;
546:
547: lists[index] = temp->d.cdr;
548: }
549: if (join == 0) {
550: current->l = newdot();
551: current->l->d.car = Lfuncal();
552: current = (lispval) ¤t->l->d.cdr;
553: } else {
554: current->l = Lfuncal();
555: if ( TYPE ( current -> l) != DTPR && current->l != nil)
556: error("bad type returned from funcall inside map",FALSE);
557: else while ( current -> l != nil )
558: current = (lispval) & (current ->l ->d.cdr);
559: }
560: np = last;
561: }
562: done: if (join == 0)current->l = nil;
563: Restorestack();
564: return(result->l);
565: }
566:
567: /* ============================
568: -
569: - Lmapcar
570: - =============================*/
571:
572: lispval
573: Lmapcar()
574: {
575: return(Lmapcrx(0,0)); /* call general routine */
576: }
577:
578:
579: /* ============================
580: -
581: -
582: - Lmaplist
583: - ==============================*/
584:
585: lispval
586: Lmaplist()
587: {
588: return(Lmapcrx(1,0)); /* call general routine */
589: }
590:
591:
592: /* ================================================
593: - mapping functions which return the value of the last function application.
594: - mapc and map
595: - ===================================================*/
596:
597: lispval
598: Lmapcx(maptyp)
599: int maptyp; /* 0= mapc , 1= map */
600: {
601: register struct argent *namptr;
602: register index;
603: register lispval temp;
604: register lispval result;
605:
606: int count;
607: struct argent *first;
608: lispval lists[25], errorh();
609: Savestack(4);
610:
611: namptr = lbot + 1;
612: count = np - namptr;
613: if(count <= 0) return(nil);
614: result = lbot[1].val; /*This is what macsyma wants so ... */
615: /*copy funarg for call to funcall */
616: lbot = np; protect((namptr - 1)->val);
617: first = np; np += count;
618:
619: for(index = 0; index < count; index++) {
620: temp = (namptr++)->val;
621: while(temp!=nil && TYPE(temp)!=DTPR)
622: temp = errorh1(Vermisc,"Inappropriate list argument to mapc",nil,TRUE,0,temp);
623: lists[index] = temp;
624: }
625: for(;;) {
626: for(namptr=first,index=0; index<count; index++) {
627: temp = lists[index];
628: if(temp==nil)
629: goto done;
630: if(maptyp==0)
631: (namptr++)->val = temp->d.car;
632: else
633: (namptr++)->val = temp;
634: lists[index] = temp->d.cdr;
635: }
636: Lfuncal();
637: }
638: done:
639: Restorestack();
640: return(result);
641: }
642:
643:
644: /* ==================================
645: -
646: - mapc map the car of the lists
647: -
648: - ==================================*/
649:
650: lispval
651: Lmapc()
652: { return( Lmapcx(0) ); }
653:
654:
655: /* =================================
656: -
657: - map map the cdr of the lists
658: -
659: - ===================================*/
660:
661: lispval
662: Lmap()
663: { return( Lmapcx(1) ); }
664:
665:
666: lispval
667: Lmapcan()
668: {
669: lispval Lmapcrx();
670:
671: return ( Lmapcrx ( 0,1 ) );
672: }
673:
674: lispval
675: Lmapcon()
676: {
677: lispval Lmapcrx();
678:
679: return ( Lmapcrx ( 1,1 ) );
680: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.