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