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