![[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] / 43BSD / ucb / lisp / franz|
Return to lam2.c CVS log | Up to [CSRG BSD Unix] / 43BSD / ucb / lisp / franz |
1.1 root 1: #ifndef lint
2: static char *rcsid =
3: "$Header: lam2.c,v 1.5 83/12/09 16:35:49 sklower 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: register struct argent *temnp;
252: register char *cp = strbuf;
253: register lispval cur;
254: int n;
255: char *sprintf(), *atomtoolong();
256: lispval Lhau();
257:
258: *cp = NULL_CHAR ;
259:
260: /* loop for each argument */
261: for(temnp = lbot + AD ; temnp < np ; temnp++)
262: {
263: cur = temnp->val;
264: switch(TYPE(cur))
265: {
266: case ATOM:
267: n = strlen(cur->a.pname);
268: while(n + cp >= endstrb) cp = atomtoolong(cp);
269: strcpy(cp, cur->a.pname);
270: cp += n;
271: break;
272:
273: case STRNG:
274: n = strlen( (char *) cur);
275: while(n + cp >= endstrb) cp = atomtoolong(cp);
276: strcpy(cp, (char *) cur);
277: cp += n;
278: break;
279:
280: case INT:
281: if(15 + cp >= endstrb) cp = atomtoolong(cp);
282: sprintf(cp,"%d",cur->i);
283: while(*cp) cp++;
284: break;
285:
286: case DOUB:
287: if(15 + cp >= endstrb) cp = atomtoolong(cp);
288: sprintf(cp,"%f",cur->f);
289: while(*cp) cp++;
290: break;
291:
292: case SDOT: {
293: struct _iobuf _myiob;
294: register lispval handy = cur;
295:
296: for(n = 12; handy->s.CDR!=(lispval) 0; handy = handy->s.CDR)
297: n += 12;
298:
299: while(n + cp >= endstrb) cp = atomtoolong(cp);
300:
301: _myiob._flag = _IOWRT+_IOSTRG;
302: _myiob._ptr = cp;
303: _myiob._cnt = endstrb - cp - 1;
304:
305: pbignum(cur,&_myiob);
306: cp = _myiob._ptr;
307: *cp = 0;
308: break; }
309:
310: default:
311: cur = error("Non atom or number to concat",TRUE);
312: continue; /* if returns value, try it */
313: }
314:
315: }
316:
317: if(unintern)
318: return( (lispval) newatom(FALSE)); /* uninterned atoms may
319: have printname gc'd*/
320: else
321: return( (lispval) getatom(FALSE)) ;
322: }
323: lispval
324: Lconcat(){
325: return(Iconcat(FALSE));
326: }
327: lispval
328: Luconcat(){
329: return(Iconcat(TRUE));
330: }
331:
332: lispval
333: Lputprop()
334: {
335: lispval Iputprop();
336: chkarg(3,"putprop");
337: return(Iputprop(lbot->val,lbot[1].val,lbot[2].val));
338: }
339:
340: /*
341: * Iputprop :internal version of putprop used by some C functions
342: * note: prop and ind are lisp values but are not protected (by this
343: * function) from gc. The caller should protect them!!
344: */
345: lispval
346: Iputprop(atm,prop,ind)
347: register lispval prop, ind, atm;
348: {
349: register lispval pptr;
350: lispval *tack; /* place to begin property list */
351: lispval pptr2;
352: lispval errorh();
353: Savestack(4);
354:
355: top:
356: switch (TYPE(atm)) {
357: case ATOM:
358: if(atm == nil) tack = &nilplist;
359: else tack = &(atm->a.plist);
360: break;
361: case DTPR:
362: for (pptr = atm->d.cdr ; pptr != nil ; pptr = pptr->d.cdr->d.cdr)
363: if(TYPE(pptr) != DTPR || TYPE(pptr->d.cdr) != DTPR) break;
364: if(pptr != nil)
365: { atm = errorh1(Vermisc,
366: "putprop: bad disembodied property list",
367: nil,TRUE,0,atm);
368: goto top;
369: }
370: tack = (lispval *) &(atm->d.cdr);
371: break;
372: default:
373: errorh1(Vermisc,"putprop: Bad first argument: ",nil,FALSE,0,atm);
374: }
375: pptr = *tack; /* start of property list */
376: /*findit:*/
377: for (pptr = *tack ; pptr != nil ; pptr = pptr->d.cdr->d.cdr)
378: if (pptr->d.car == ind) {
379: (pptr->d.cdr)->d.car = prop;
380: Restorestack();
381: return(prop);
382: }
383: /* not found, add to front
384: be careful, a gc could occur before the second newdot() */
385:
386: pptr = newdot();
387: pptr->d.car = prop;
388: pptr->d.cdr = *tack;
389: protect(pptr);
390: pptr2 = newdot();
391: pptr2->d.car = ind;
392: pptr2->d.cdr = pptr;
393: *tack = pptr2;
394: Restorestack();
395: return(prop);
396: }
397:
398: /* get from property list
399: * there are three routines to accomplish this
400: * Lget - lisp callable, the first arg can be a symbol or a disembodied
401: * property list. In the latter case we check to make sure it
402: * is a real one (as best we can).
403: * Iget - internal routine, the first arg must be a symbol, no disembodied
404: * plists allowed
405: * Igetplist - internal routine, the first arg is the plist to search.
406: */
407: lispval
408: Lget()
409: {
410: register lispval ind, atm;
411: register lispval dum1;
412: lispval Igetplist();
413:
414: chkarg(2,"get");
415: ind = lbot[1].val;
416: atm = lbot[0].val;
417: top:
418: switch(TYPE(atm)) {
419: case ATOM:
420: if(atm==nil) atm = nilplist;
421: else atm = atm->a.plist;
422: break;
423:
424: case DTPR:
425: for (dum1 = atm->d.cdr; dum1 != nil; dum1 = dum1->d.cdr->d.cdr)
426: if((TYPE(dum1) != DTPR) ||
427: (TYPE(dum1->d.cdr) != DTPR)) break; /* bad prop list */
428: if(dum1 != nil)
429: { atm = errorh1(Vermisc,
430: "get: bad disembodied property list",
431: nil,TRUE,0,atm);
432: goto top;
433: }
434: atm = atm->d.cdr;
435: break;
436: default:
437: /* remove since maclisp doesnt treat
438: this as an error, ugh
439: return(errorh1(Vermisc,"get: bad first argument: ",
440: nil,FALSE,0,atm));
441: */
442: return(nil);
443: }
444:
445: while (atm != nil)
446: {
447: if (atm->d.car == ind)
448: return ((atm->d.cdr)->d.car);
449: atm = (atm->d.cdr)->d.cdr;
450: }
451: return(nil);
452: }
453: /*
454: * Iget - the first arg must be a symbol.
455: */
456:
457: lispval
458: Iget(atm,ind)
459: register lispval atm, ind;
460: {
461: lispval Igetplist();
462:
463: if(atm==nil)
464: atm = nilplist;
465: else
466: atm = atm->a.plist;
467: return(Igetplist(atm,ind));
468: }
469:
470: /*
471: * Igetplist
472: * pptr is a plist
473: * ind is the indicator
474: */
475:
476: lispval
477: Igetplist(pptr,ind)
478: register lispval pptr,ind;
479: {
480: while (pptr != nil)
481: {
482: if (pptr->d.car == ind)
483: return ((pptr->d.cdr)->d.car);
484: pptr = (pptr->d.cdr)->d.cdr;
485: }
486: return(nil);
487: }
488: lispval
489: Lgetd()
490: {
491: register lispval typ;
492:
493: chkarg(1,"getd");
494: typ = lbot->val;
495: if (TYPE(typ) != ATOM)
496: errorh1(Vermisc,
497: "getd: Only symbols have function definitions",
498: nil,
499: FALSE,
500: 0,
501: typ);
502: return(typ->a.fnbnd);
503: }
504: lispval
505: Lputd()
506: {
507: register lispval atom, list;
508:
509: chkarg(2,"putd");
510: list = lbot[1].val;
511: atom = lbot->val;
512: if (TYPE(atom) != ATOM) error("only symbols have function definitions",
513: FALSE);
514: atom->a.fnbnd = list;
515: return(list);
516: }
517:
518: /* ===========================================================
519: - mapping functions which return a list of the answers
520: - mapcar applies the given function to successive elements
521: - maplist applies the given function to successive sublists
522: - ===========================================================*/
523:
524: lispval
525: Lmapcrx(maptyp,join)
526: int maptyp; /* 0 = mapcar, 1 = maplist */
527: int join; /* 0 = the above, 1 = s/car/can/ */
528: {
529: register struct argent *namptr;
530: register index;
531: register lispval temp;
532: register lispval current;
533:
534: struct argent *first, *last;
535: int count;
536: lispval lists[25], result;
537: Savestack(4);
538:
539: namptr = lbot + 1;
540: count = np - namptr;
541: if (count <= 0) return (nil);
542: result = current = (lispval) np;
543: protect(nil); /* set up space for returned list */
544: protect(lbot->val); /*copy funarg for call to funcall */
545: lbot = np -1;
546: first = np;
547: last = np += count;
548: for(index = 0; index < count; index++) {
549: temp =(namptr++)->val;
550: if (TYPE (temp ) != DTPR && temp!=nil)
551: error ( "bad list argument to map",FALSE);
552: lists[index] = temp;
553: }
554: for(;;) {
555: for(namptr=first,index=0; index<count; index++) {
556: temp = lists[index];
557: if(temp==nil) goto done;
558:
559: if(maptyp==0) (namptr++)->val = temp->d.car;
560: else (namptr++)->val = temp;
561:
562: lists[index] = temp->d.cdr;
563: }
564: if (join == 0) {
565: current->l = newdot();
566: current->l->d.car = Lfuncal();
567: current = (lispval) ¤t->l->d.cdr;
568: } else {
569: current->l = Lfuncal();
570: if ( TYPE ( current -> l) != DTPR && current->l != nil)
571: error("bad type returned from funcall inside map",FALSE);
572: else while ( current -> l != nil )
573: current = (lispval) & (current ->l ->d.cdr);
574: }
575: np = last;
576: }
577: done: if (join == 0)current->l = nil;
578: Restorestack();
579: return(result->l);
580: }
581:
582: /* ============================
583: -
584: - Lmapcar
585: - =============================*/
586:
587: lispval
588: Lmpcar()
589: {
590: return(Lmapcrx(0,0)); /* call general routine */
591: }
592:
593:
594: /* ============================
595: -
596: -
597: - Lmaplist
598: - ==============================*/
599:
600: lispval
601: Lmaplist()
602: {
603: return(Lmapcrx(1,0)); /* call general routine */
604: }
605:
606:
607: /* ================================================
608: - mapping functions which return the value of the last function application.
609: - mapc and map
610: - ===================================================*/
611:
612: lispval
613: Lmapcx(maptyp)
614: int maptyp; /* 0= mapc , 1= map */
615: {
616: register struct argent *namptr;
617: register index;
618: register lispval temp;
619: register lispval result;
620:
621: int count;
622: struct argent *first;
623: lispval lists[25], errorh();
624: Savestack(4);
625:
626: namptr = lbot + 1;
627: count = np - namptr;
628: if(count <= 0) return(nil);
629: result = lbot[1].val; /*This is what macsyma wants so ... */
630: /*copy funarg for call to funcall */
631: lbot = np; protect((namptr - 1)->val);
632: first = np; np += count;
633:
634: for(index = 0; index < count; index++) {
635: temp = (namptr++)->val;
636: while(temp!=nil && TYPE(temp)!=DTPR)
637: temp = errorh1(Vermisc,"Inappropriate list argument to mapc",nil,TRUE,0,temp);
638: lists[index] = temp;
639: }
640: for(;;) {
641: for(namptr=first,index=0; index<count; index++) {
642: temp = lists[index];
643: if(temp==nil)
644: goto done;
645: if(maptyp==0)
646: (namptr++)->val = temp->d.car;
647: else
648: (namptr++)->val = temp;
649: lists[index] = temp->d.cdr;
650: }
651: Lfuncal();
652: }
653: done:
654: Restorestack();
655: return(result);
656: }
657:
658:
659: /* ==================================
660: -
661: - mapc map the car of the lists
662: -
663: - ==================================*/
664:
665: lispval
666: Lmapc()
667: { return( Lmapcx(0) ); }
668:
669:
670: /* =================================
671: -
672: - map map the cdr of the lists
673: -
674: - ===================================*/
675:
676: lispval
677: Lmap()
678: { return( Lmapcx(1) ); }
679:
680:
681: lispval
682: Lmapcan()
683: {
684: lispval Lmapcrx();
685:
686: return ( Lmapcrx ( 0,1 ) );
687: }
688:
689: lispval
690: Lmapcon()
691: {
692: lispval Lmapcrx();
693:
694: return ( Lmapcrx ( 1,1 ) );
695: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.