![[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] / 43BSDTahoe / ucb / lisp / franz|
Return to lam1.c CVS log | Up to [CSRG BSD Unix] / 43BSDTahoe / ucb / lisp / franz |
1.1 root 1: #ifndef lint
2: static char *rcsid =
3: "$Header: lam1.c,v 1.8 87/12/14 18:39:12 sklower Exp $";
4: #endif
5:
6: /* -[Fri Feb 17 16:44:24 1984 by layer]-
7: * lam1.c $Locker: $
8: * lambda functions
9: *
10: * (c) copyright 1982, Regents of the University of California
11: */
12:
13: # include "global.h"
14: # include <sgtty.h>
15: # include "chkrtab.h"
16: # include "frame.h"
17:
18: lispval
19: Leval()
20: {
21: register lispval temp;
22:
23: chkarg(1,"eval");
24: temp = lbot->val;
25: return(eval(temp));
26: }
27:
28: lispval
29: Lxcar()
30: { register int typ;
31: register lispval temp, result;
32:
33: chkarg(1,"xcar");
34: temp = lbot->val;
35: if (((typ = TYPE(temp)) == DTPR) || (typ == ATOM) || HUNKP(temp))
36: return(temp->d.car);
37: else if(typ == SDOT) {
38: result = inewint(temp->i);
39: return(result);
40: } else if(Schainp!=nil && typ==ATOM)
41: return(nil);
42: else
43: return(error("Bad arg to car",FALSE));
44:
45: }
46:
47: lispval
48: Lxcdr()
49: { register int typ;
50: register lispval temp;
51:
52: chkarg(1,"xcdr");
53: temp = lbot->val;
54: if(temp==nil) return (nil);
55:
56: if (((typ = TYPE(temp)) == DTPR) || HUNKP(temp))
57: return(temp->d.cdr);
58: else if(typ==SDOT) {
59: if(temp->s.CDR==0) return(nil);
60: temp = temp->s.CDR;
61: if(TYPE(temp)==DTPR)
62: errorh1(Vermisc,"Fell off the end of a bignum",nil,FALSE,5,lbot->val);
63: return(temp);
64: } else if(Schainp!=nil && typ==ATOM)
65: return(nil);
66: else
67: return(error("Bad arg to cdr", FALSE));
68: }
69:
70: lispval
71: cxxr(as,ds)
72: register int as,ds;
73: {
74:
75: register lispval temp, temp2;
76: int i, typ;
77: lispval errorh();
78:
79: chkarg(1,"c{ad}+r");
80: temp = lbot->val;
81:
82: for( i=0 ; i<ds ; i++)
83: {
84: if( temp != nil)
85: {
86: typ = TYPE(temp);
87: if ((typ == DTPR) || HUNKP(temp))
88: temp = temp->d.cdr;
89: else
90: if(typ==SDOT)
91: {
92: if(temp->s.CDR==0)
93: temp = nil;
94: else
95: temp = temp->s.CDR;
96: if(TYPE(temp)==DTPR)
97: errorh1(Vermisc,"Fell off the end of a bignum",nil,FALSE,5,lbot->val);
98: }
99: else
100: if(Schainp!=nil && typ==ATOM)
101: return(nil);
102: else
103: return(errorh1(Vermisc,"Bad arg to cdr",nil,FALSE,5,temp));
104: }
105: }
106:
107: for( i=0 ; i<as ; i++)
108: {
109: if( temp != nil )
110: {
111: typ = TYPE(temp);
112: if ((typ == DTPR) || HUNKP(temp))
113: temp = temp->d.car;
114: else if(typ == SDOT)
115: temp2 = inewint(temp->i), temp = temp2;
116: else if(Schainp!=nil && typ==ATOM)
117: return(nil);
118: else
119: return(errorh1(Vermisc,"Bad arg to car",nil,FALSE,5,temp));
120: }
121: }
122:
123: return(temp);
124: }
125:
126: lispval
127: Lcar()
128: { return(cxxr(1,0)); }
129:
130: lispval
131: Lcdr()
132: { return(cxxr(0,1)); }
133:
134: lispval
135: Lcadr()
136: { return(cxxr(1,1)); }
137:
138: lispval
139: Lcaar()
140: { return(cxxr(2,0)); }
141:
142: lispval
143: Lc02r()
144: { return(cxxr(0,2)); } /* cddr */
145:
146: lispval
147: Lc12r()
148: { return(cxxr(1,2)); } /* caddr */
149:
150: lispval
151: Lc03r()
152: { return(cxxr(0,3)); } /* cdddr */
153:
154: lispval
155: Lc13r()
156: { return(cxxr(1,3)); } /* cadddr */
157:
158: lispval
159: Lc04r()
160: { return(cxxr(0,4)); } /* cddddr */
161:
162: lispval
163: Lc14r()
164: { return(cxxr(1,4)); } /* caddddr */
165:
166: /*
167: *
168: * (nthelem num list)
169: *
170: * Returns the num'th element of the list, by doing a caddddd...ddr
171: * where there are num-1 d's. If num<=0 or greater than the length of
172: * the list, we return nil.
173: *
174: */
175:
176: lispval
177: Lnthelem()
178: {
179: register lispval temp;
180: register int i;
181:
182: chkarg(2,"nthelem");
183:
184: if( TYPE(temp = lbot->val) != INT)
185: return (error ("First arg to nthelem must be a fixnum",FALSE));
186:
187: i = temp->i; /* pick up the first arg */
188:
189: if( i <= 0) return(nil);
190:
191: ++lbot; /* fix lbot for call to cxxr() 'cadddd..r' */
192: temp = cxxr(1,i-1);
193: --lbot;
194:
195: return(temp);
196: }
197:
198: lispval
199: Lscons()
200: {
201: register struct argent *argp = lbot;
202: register lispval retp, handy;
203:
204: chkarg(2,"scons");
205: retp = newsdot();
206: handy = (argp) -> val;
207: if(TYPE(handy)!=INT)
208: error("First arg to scons must be an int.",FALSE);
209: retp->s.I = handy->i;
210: handy = (argp+1)->val;
211: if(handy==nil)
212: retp->s.CDR = (lispval) 0;
213: else {
214: if(TYPE(handy)!=SDOT)
215: error("Currently you may only link sdots to sdots.",FALSE);
216: retp->s.CDR = handy;
217: }
218: return(retp);
219: }
220:
221: lispval
222: Lbigtol(){
223: register lispval handy,newp;
224:
225: chkarg(1,"Bignum-to-list");
226: handy = lbot->val;
227: while(TYPE(handy)!=SDOT)
228: handy = errorh1(Vermisc,
229: "Non bignum argument to Bignum-to-list",
230: nil,TRUE,5755,handy);
231: protect(newp = newdot());
232: while(handy) {
233: newp->d.car = inewint((long)handy->s.I);
234: if(handy->s.CDR==(lispval) 0) break;
235: newp->d.cdr = newdot();
236: newp = newp->d.cdr;
237: handy = handy->s.CDR;
238: }
239: handy = (--np)->val;
240: return(handy);
241: }
242:
243: lispval
244: Lcons()
245: {
246: register lispval retp;
247: register struct argent *argp;
248:
249: chkarg(2,"cons");
250: retp = newdot();
251: retp->d.car = ((argp = lbot) -> val);
252: retp->d.cdr = argp[1].val;
253: return(retp);
254: }
255: #define CA 0
256: #define CD 1
257:
258: lispval
259: rpla(what)
260: int what;
261: { register struct argent *argp;
262: register int typ; register lispval first, second;
263:
264: chkarg(2,"rplac[ad]");
265: argp = np-1;
266: first = (argp-1)->val;
267: while(first==nil)
268: first = error("Attempt to rplac[ad] nil.",TRUE);
269: second = argp->val;
270: if (((typ = TYPE(first)) == DTPR) || (typ == ATOM) || HUNKP(first)) {
271: if (what == CA)
272: first->d.car = second;
273: else
274: first->d.cdr = second;
275: return(first);
276: }
277: if (typ==SDOT) {
278: if(what == CA) {
279: typ = TYPE(second);
280: if(typ!=INT) error("Rplacca of a bignum will only replace INTS",FALSE);
281: first->s.I = second->i;
282: } else {
283: if(second==nil)
284: first->s.CDR = (lispval) 0;
285: else
286: first->s.CDR = second;
287: }
288: return(first);
289: }
290: return(error("Bad arg to rpla",FALSE));
291: }
292: lispval
293: Lrplca()
294: { return(rpla(CA)); }
295:
296: lispval
297: Lrplcd()
298: { return(rpla(CD)); }
299:
300:
301: lispval
302: Leq()
303: {
304: register struct argent *mynp = lbot + AD;
305:
306: chkarg(2,"eq");
307: if(mynp->val==(mynp+1)->val) return(tatom);
308: return(nil);
309: }
310:
311:
312:
313: lispval
314: Lnull()
315: { chkarg(1,"null");
316: return ((lbot->val == nil) ? tatom : nil);
317: }
318:
319:
320:
321: /* Lreturn **************************************************************/
322: /* Returns the first argument - which is nill if not specified. */
323:
324: lispval
325: Lreturn()
326: {
327: if(lbot==np) protect (nil);
328: Inonlocalgo(C_RET,lbot->val,nil);
329: /* NOT REACHED */
330: }
331:
332:
333: lispval
334: Linfile()
335: {
336: FILE *port;
337: register lispval name;
338:
339: chkarg(1,"infile");
340: name = lbot->val;
341: loop:
342: name = verify(name,"infile: file name must be atom or string");
343: /* return nil if file couldnt be opened
344: if ((port = fopen((char *)name,"r")) == NULL) return(nil); */
345:
346: if ((port = fopen((char *)name,"r")) == NULL) {
347: name = errorh1(Vermisc,"Unable to open file for reading.",nil,TRUE,31,name);
348: goto loop;
349: }
350: ioname[PN(port)] = (lispval) inewstr((char *)name); /* remember name */
351: return(P(port));
352: }
353:
354: /* outfile - open a file for writing.
355: * 27feb81 [jkf] - modifed to accept two arguments, the second one being a
356: * string or atom, which if it begins with an `a' tells outfile to open the
357: * file in append mode
358: */
359: lispval
360: Loutfile()
361: {
362: FILE *port; register lispval name;
363: char *mode ="w"; /* mode is w for create new file, a for append */
364: char *given;
365:
366: if(lbot+1== np) protect(nil);
367: chkarg(2,"outfile");
368: name = lbot->val;
369: given = (char *)verify((lbot+1)->val,"Illegal file open mode.");
370: if(*given == 'a') mode = "a";
371: loop:
372: name = verify(name,"Please supply atom or string name for port.");
373: #ifdef os_vms
374: /*
375: * If "w" mode, open it as a "txt" file for convenience in VMS
376: */
377: if (strcmp(mode,"w") == 0) {
378: int fd;
379:
380: if ((fd = creat(name,0777,"txt")) < 0) {
381: name = errorh1(Vermisc,"Unable to open file for writing.",nil,TRUE,31,name);
382: goto loop;
383: }
384: port = fdopen(fd,mode);
385: } else
386: #endif
387: if ((port = fopen((char *)name,mode)) == NULL) {
388: name = errorh1(Vermisc,"Unable to open file for writing.",nil,TRUE,31,name);
389: goto loop;
390: }
391: ioname[PN(port)] = (lispval) inewstr((char *)name);
392: return(P(port));
393: }
394:
395: lispval
396: Lterpr()
397: {
398: register lispval handy;
399: FILE *port;
400:
401: if(lbot==np) handy = nil;
402: else
403: {
404: chkarg(1,"terpr");
405: handy = lbot->val;
406: }
407:
408: port = okport(handy,okport(Vpoport->a.clb,stdout));
409: putc('\n',port);
410: fflush(port);
411: return(nil);
412: }
413:
414: lispval
415: Lclose()
416: {
417: lispval port;
418:
419: chkarg(1,"close");
420: port = lbot->val;
421: if((TYPE(port))==PORT) {
422: fclose(port->p);
423: ioname[PN(port->p)] = nil;
424: return(tatom);
425: }
426: errorh1(Vermisc,"close:Non-port",nil,FALSE,987,port);
427: /* not reached */
428: }
429:
430: lispval
431: Ltruename()
432: {
433: chkarg(1,"truename");
434: if(TYPE(lbot->val) != PORT)
435: errorh1(Vermisc,"truename: non port argument",nil,FALSE,0,lbot->val);
436:
437: return(ioname[PN(lbot->val->p)]);
438: }
439:
440: lispval
441: Lnwritn()
442: {
443: register FILE *port;
444: register value;
445: register lispval handy;
446:
447: if(lbot==np) handy = nil;
448: else
449: {
450: chkarg(1,"nwritn");
451: handy = lbot->val;
452: }
453:
454: port = okport(handy,okport(Vpoport->a.clb,stdout));
455: value = port->_ptr - port->_base;
456: return(inewint(value));
457: }
458:
459: lispval
460: Ldrain()
461: {
462: register FILE *port;
463: register int iodes;
464: register lispval handy;
465: struct sgttyb arg;
466:
467: if(lbot==np) handy = nil;
468: else
469: {
470: chkarg(1,"nwritn");
471: handy = lbot->val;
472: }
473: port = okport(handy, okport(Vpoport->a.clb,stdout));
474: if(port->_flag & _IOWRT) {
475: fflush(port);
476: return(nil);
477: }
478: if(! port->_flag & _IOREAD) return(nil);
479: port->_cnt = 0;
480: port->_ptr = port->_base;
481: iodes = fileno(port);
482: if(gtty(iodes,&arg) != -1) stty(iodes,&arg);
483: return(P(port));
484: }
485:
486: lispval
487: Llist()
488: {
489: /* added for the benefit of mapping functions. */
490: register struct argent *ulim, *namptr;
491: register lispval temp, result;
492: Savestack(4);
493:
494: ulim = np;
495: namptr = lbot + AD;
496: temp = result = (lispval) np;
497: protect(nil);
498: for(; namptr < ulim;) {
499: temp = temp->l = newdot();
500: temp->d.car = (namptr++)->val;
501: }
502: temp->l = nil;
503: Restorestack();
504: return(result->l);
505: }
506:
507: lispval
508: Lnumberp()
509: {
510: chkarg(1,"numberp");
511: switch(TYPE(lbot->val)) {
512: case INT: case DOUB: case SDOT:
513: return(tatom);
514: }
515: return(nil);
516: }
517:
518: lispval
519: Latom()
520: {
521: register struct argent *lb = lbot;
522: chkarg(1,"atom");
523: if(TYPE(lb->val)==DTPR || (HUNKP(lb->val)))
524: return(nil);
525: else
526: return(tatom);
527: }
528:
529: lispval
530: Ltype()
531: {
532: chkarg(1,"type");
533: switch(TYPE(lbot->val)) {
534: case INT:
535: return(int_name);
536: case ATOM:
537: return(atom_name);
538: case SDOT:
539: return(sdot_name);
540: case DOUB:
541: return(doub_name);
542: case DTPR:
543: return(dtpr_name);
544: case STRNG:
545: return(str_name);
546: case ARRAY:
547: return(array_name);
548: case BCD:
549: return(funct_name);
550: case OTHER:
551: return(other_name);
552:
553: case HUNK2:
554: return(hunk_name[0]);
555: case HUNK4:
556: return(hunk_name[1]);
557: case HUNK8:
558: return(hunk_name[2]);
559: case HUNK16:
560: return(hunk_name[3]);
561: case HUNK32:
562: return(hunk_name[4]);
563: case HUNK64:
564: return(hunk_name[5]);
565: case HUNK128:
566: return(hunk_name[6]);
567:
568: case VECTOR:
569: return(vect_name);
570: case VECTORI:
571: return(vecti_name);
572:
573: case VALUE:
574: return(val_name);
575: case PORT:
576: return(port_name);
577: }
578: return(nil);
579: }
580:
581: lispval
582: Ldtpr()
583: {
584: chkarg(1,"dtpr");
585: return(typred(DTPR, lbot->val));
586: }
587:
588: lispval
589: Lbcdp()
590: {
591: chkarg(1,"bcdp");
592: return(typred(BCD, lbot->val));
593: }
594:
595: lispval
596: Lportp()
597: {
598: chkarg(1,"portp");
599: return(typred(PORT, lbot->val));
600: }
601:
602: lispval
603: Larrayp()
604: {
605: chkarg(1,"arrayp");
606: return(typred(ARRAY, lbot->val));
607: }
608:
609: /*
610: * (hunkp 'g_arg1)
611: * Returns t if g_arg1 is a hunk, otherwise returns nil.
612: */
613:
614: lispval
615: Lhunkp()
616: {
617: chkarg(1,"hunkp");
618: if (HUNKP(lbot->val))
619: return(tatom); /* If a hunk, return t */
620: else
621: return(nil); /* else nil */
622: }
623:
624: lispval
625: Lset()
626: {
627: lispval varble;
628:
629: chkarg(2,"set");
630: varble = lbot->val;
631: switch(TYPE(varble))
632: {
633: case ATOM: return(varble->a.clb = lbot[1].val);
634:
635: case VALUE: return(varble->l = lbot[1].val);
636: }
637:
638: error("IMPROPER USE OF SET",FALSE);
639: /* NOTREACHED */
640: }
641:
642: lispval
643: Lequal()
644: {
645: register lispval first, second;
646: register type1, type2;
647: lispval Lsub(),Lzerop();
648: long *oldsp;
649: Keepxs();
650: chkarg(2,"equal");
651:
652:
653: if(lbot->val==lbot[1].val) return(tatom);
654:
655: oldsp=sp(); stack((long)lbot->val);stack((long)lbot[1].val);
656: for(;oldsp > sp();) {
657:
658: first = (lispval) unstack(); second = (lispval) unstack();
659: again:
660: if(first==second) continue;
661:
662: type1=TYPE(first); type2=TYPE(second);
663: if(type1!=type2) {
664: if((type1==SDOT&&type2==INT)||(type1==INT&&type2==SDOT))
665: goto dosub;
666: {Freexs(); return(nil);}
667: }
668: switch(type1) {
669: case DTPR:
670: stack((long)first->d.cdr); stack((long)second->d.cdr);
671: first = first->d.car; second = second->d.car;
672: goto again;
673: case DOUB:
674: if(first->r!=second->r)
675: {Freexs(); return(nil);}
676: continue;
677: case INT:
678: if(first->i!=second->i)
679: {Freexs(); return(nil);}
680: continue;
681: case VECTOR:
682: if(!vecequal(first,second)) {Freexs(); return(nil);}
683: continue;
684: case VECTORI:
685: if(!veciequal(first,second)) {Freexs(); return(nil);}
686: continue;
687: dosub:
688: case SDOT: {
689: lispval temp;
690: struct argent *OLDlbot = lbot;
691: lbot = np;
692: np++->val = first;
693: np++->val = second;
694: temp = Lsub();
695: np = lbot;
696: lbot = OLDlbot;
697: if(TYPE(temp)!=INT || temp->i!=0)
698: {Freexs(); return(nil);}
699: }
700: continue;
701: case VALUE:
702: if(first->l!=second->l)
703: {Freexs(); return(nil);}
704: continue;
705: case STRNG:
706: if(strcmp((char *)first,(char *)second)!=0)
707: {Freexs(); return(nil);}
708: continue;
709:
710: default:
711: {Freexs(); return(nil);}
712: }
713: }
714: {Freexs(); return(tatom);}
715: }
716: lispval
717: oLequal()
718: {
719: chkarg(2,"equal");
720:
721: if( lbot[1].val == lbot->val ) return(tatom);
722: if(Iequal(lbot[1].val,lbot->val)) return(tatom); else return(nil);
723: }
724:
725: Iequal(first,second)
726: register lispval first, second;
727: {
728: register type1, type2;
729: lispval Lsub(),Lzerop();
730:
731: if(first==second)
732: return(1);
733: type1=TYPE(first);
734: type2=TYPE(second);
735: if(type1!=type2) {
736: if((type1==SDOT&&type2==INT)||(type1==INT&&type2==SDOT))
737: goto dosub;
738: return(0);
739: }
740: switch(type1) {
741: case DTPR:
742: return(
743: Iequal(first->d.car,second->d.car) &&
744: Iequal(first->d.cdr,second->d.cdr) );
745: case DOUB:
746: return(first->r==second->r);
747: case INT:
748: return( (first->i==second->i));
749: dosub:
750: case SDOT:
751: {
752: lispval temp;
753: struct argent *OLDlbot = lbot;
754: lbot = np;
755: np++->val = first;
756: np++->val = second;
757: temp = Lsub();
758: np = lbot;
759: lbot = OLDlbot;
760: return(TYPE(temp)==INT&& temp->i==0);
761: }
762: case VALUE:
763: return( first->l==second->l );
764: case STRNG:
765: return(strcmp((char *)first,(char *)second)==0);
766: }
767: return(0);
768: }
769: lispval
770: Zequal()
771: {
772: register lispval first, second;
773: register type1, type2;
774: lispval Lsub(),Lzerop();
775: long *oldsp;
776: Keepxs();
777: chkarg(2,"equal");
778:
779:
780: if(lbot->val==lbot[1].val) return(tatom);
781:
782: oldsp=sp(); stack((long)lbot->val);stack((long)lbot[1].val);
783:
784: for(;oldsp > sp();) {
785:
786: first = (lispval) unstack(); second = (lispval) unstack();
787: again:
788: if(first==second) continue;
789:
790: type1=TYPE(first); type2=TYPE(second);
791: if(type1!=type2) {
792: if((type1==SDOT&&type2==INT)||(type1==INT&&type2==SDOT))
793: goto dosub;
794: {Freexs(); return(nil);}
795: }
796: switch(type1) {
797: case DTPR:
798: stack((long)first->d.cdr); stack((long)second->d.cdr);
799: first = first->d.car; second = second->d.car;
800: goto again;
801: case DOUB:
802: if(first->r!=second->r)
803: {Freexs(); return(nil);}
804: continue;
805: case INT:
806: if(first->i!=second->i)
807: {Freexs(); return(nil);}
808: continue;
809: dosub:
810: case SDOT:
811: {
812: lispval temp;
813: struct argent *OLDlbot = lbot;
814: lbot = np;
815: np++->val = first;
816: np++->val = second;
817: temp = Lsub();
818: np = lbot;
819: lbot = OLDlbot;
820: if(TYPE(temp)!=INT || temp->i!=0)
821: {Freexs(); return(nil);}
822: }
823: continue;
824: case VALUE:
825: if(first->l!=second->l)
826: {Freexs(); return(nil);}
827: continue;
828: case STRNG:
829: if(strcmp((char *)first,(char *)second)!=0)
830: {Freexs(); return(nil);}
831: continue;
832: }
833: }
834: {Freexs(); return(tatom);}
835: }
836:
837: /*
838: * (print 'expression ['port]) prints the given expression to the given
839: * port or poport if no port is given. The amount of structure
840: * printed is a function of global lisp variables plevel and
841: * plength.
842: */
843: lispval
844: Lprint()
845: {
846: register lispval handy;
847: extern int plevel,plength;
848:
849:
850: handy = nil; /* port is optional, default nil */
851: switch(np-lbot)
852: {
853: case 2: handy = lbot[1].val;
854: case 1: break;
855: default: argerr("print");
856: }
857:
858: chkrtab(Vreadtable->a.clb);
859: if(TYPE(Vprinlevel->a.clb) == INT)
860: {
861: plevel = Vprinlevel->a.clb->i;
862: }
863: else plevel = -1;
864: if(TYPE(Vprinlength->a.clb) == INT)
865: {
866: plength = Vprinlength->a.clb->i;
867: }
868: else plength = -1;
869: printr(lbot->val,okport(handy,okport(Vpoport->a.clb,poport)));
870: return(nil);
871: }
872:
873: /* patom does not use plevel or plength
874: *
875: * form is (patom 'value ['port])
876: */
877: lispval
878: Lpatom()
879: {
880: register lispval temp;
881: register lispval handy;
882: register int typ;
883: FILE *port;
884:
885: handy = nil; /* port is optional, default nil */
886: switch(np-lbot)
887: {
888: case 2: handy = lbot[1].val;
889: case 1: break;
890: default: argerr("patom");
891: }
892:
893: temp = Vreadtable->a.clb;
894: chkrtab(temp);
895: port = okport(handy, okport(Vpoport->a.clb,stdout));
896: if ((typ= TYPE((temp = (lbot)->val))) == ATOM)
897: fputs(temp->a.pname, port);
898: else if(typ == STRNG)
899: fputs((char *)temp,port);
900: else
901: {
902: if(TYPE(Vprinlevel->a.clb) == INT)
903: {
904: plevel = Vprinlevel->a.clb->i;
905: }
906: else plevel = -1;
907: if(TYPE(Vprinlength->a.clb) == INT)
908: {
909: plength = Vprinlength->a.clb->i;
910: }
911: else plength = -1;
912:
913: printr(temp, port);
914: }
915: return(temp);
916: }
917:
918: /*
919: * (pntlen thing) returns the length it takes to print out
920: * an atom or number.
921: */
922:
923: lispval
924: Lpntlen()
925: {
926: return(inewint((long)Ipntlen()));
927: }
928: Ipntlen()
929: {
930: register lispval temp;
931: register char *handy;
932:
933: temp = np[-1].val;
934: loop: switch(TYPE(temp)) {
935:
936: case ATOM:
937: handy = temp->a.pname;
938: break;
939:
940: case STRNG:
941: handy = (char *) temp;
942: break;
943:
944: case INT:
945: sprintf(strbuf,"%d",temp->i);
946: handy =strbuf;
947: break;
948:
949: case DOUB:
950: sprintf(strbuf,"%g",temp->r);
951: handy =strbuf;
952: break;
953:
954: default:
955: temp = error("Non atom or number to pntlen\n",TRUE);
956: goto loop;
957: }
958:
959: return( strlen(handy));
960: }
961: #undef okport
962: FILE *
963: okport(arg,proper)
964: lispval arg;
965: FILE *proper;
966: {
967: if(TYPE(arg)!=PORT)
968: return(proper);
969: else
970: return(arg->p);
971: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.