![[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] / 42BSD / ucb / lisp / franz|
Return to lam1.c CVS log | Up to [CSRG BSD Unix] / 42BSD / ucb / lisp / franz |
1.1 root 1: #ifndef lint
2: static char *rcsid =
3: "$Header: lam1.c,v 1.4 83/09/12 14:10:52 sklower Exp $";
4: #endif
5:
6: /* -[Fri Aug 12 07:28:13 1983 by jkf]-
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: Lrplaca()
294: { return(rpla(CA)); }
295:
296: lispval
297: Lrplacd()
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: }
428:
429: lispval
430: Ltruename()
431: {
432: chkarg(1,"truename");
433: if(TYPE(lbot->val) != PORT)
434: errorh1(Vermisc,"truename: non port argument",nil,FALSE,0,lbot->val);
435:
436: return(ioname[PN(lbot->val->p)]);
437: }
438:
439: lispval
440: Lnwritn()
441: {
442: register FILE *port;
443: register value;
444: register lispval handy;
445:
446: if(lbot==np) handy = nil;
447: else
448: {
449: chkarg(1,"nwritn");
450: handy = lbot->val;
451: }
452:
453: port = okport(handy,okport(Vpoport->a.clb,stdout));
454: value = port->_ptr - port->_base;
455: return(inewint(value));
456: }
457:
458: lispval
459: Ldrain()
460: {
461: register FILE *port;
462: register int iodes;
463: register lispval handy;
464: struct sgttyb arg;
465:
466: if(lbot==np) handy = nil;
467: else
468: {
469: chkarg(1,"nwritn");
470: handy = lbot->val;
471: }
472: port = okport(handy, okport(Vpoport->a.clb,stdout));
473: if(port->_flag & _IOWRT) {
474: fflush(port);
475: return(nil);
476: }
477: if(! port->_flag & _IOREAD) return(nil);
478: port->_cnt = 0;
479: port->_ptr = port->_base;
480: iodes = fileno(port);
481: if(gtty(iodes,&arg) != -1) stty(iodes,&arg);
482: return((lispval)(xports + (port - _iob)));
483: }
484:
485: lispval
486: Llist()
487: {
488: /* added for the benefit of mapping functions. */
489: register struct argent *ulim, *namptr;
490: register lispval temp, result;
491: Savestack(4);
492:
493: ulim = np;
494: namptr = lbot + AD;
495: temp = result = (lispval) np;
496: protect(nil);
497: for(; namptr < ulim;) {
498: temp = temp->l = newdot();
499: temp->d.car = (namptr++)->val;
500: }
501: temp->l = nil;
502: Restorestack();
503: return(result->l);
504: }
505:
506: lispval
507: Lnumberp()
508: {
509: chkarg(1,"numberp");
510: switch(TYPE(lbot->val)) {
511: case INT: case DOUB: case SDOT:
512: return(tatom);
513: }
514: return(nil);
515: }
516:
517: lispval
518: Latom()
519: {
520: register struct argent *lb = lbot;
521: chkarg(1,"atom");
522: if(TYPE(lb->val)==DTPR || (HUNKP(lb->val)))
523: return(nil);
524: else
525: return(tatom);
526: }
527:
528: lispval
529: Ltype()
530: {
531: chkarg(1,"type");
532: switch(TYPE(lbot->val)) {
533: case INT:
534: return(int_name);
535: case ATOM:
536: return(atom_name);
537: case SDOT:
538: return(sdot_name);
539: case DOUB:
540: return(doub_name);
541: case DTPR:
542: return(dtpr_name);
543: case STRNG:
544: return(str_name);
545: case ARRAY:
546: return(array_name);
547: case BCD:
548: return(funct_name);
549: case OTHER:
550: return(other_name);
551:
552: case HUNK2:
553: return(hunk_name[0]);
554: case HUNK4:
555: return(hunk_name[1]);
556: case HUNK8:
557: return(hunk_name[2]);
558: case HUNK16:
559: return(hunk_name[3]);
560: case HUNK32:
561: return(hunk_name[4]);
562: case HUNK64:
563: return(hunk_name[5]);
564: case HUNK128:
565: return(hunk_name[6]);
566:
567: case VECTOR:
568: return(vect_name);
569: case VECTORI:
570: return(vecti_name);
571:
572: case VALUE:
573: return(val_name);
574: case PORT:
575: return(port_name);
576: }
577: return(nil);
578: }
579:
580: lispval
581: Ldtpr()
582: {
583: chkarg(1,"dtpr");
584: return(typred(DTPR, lbot->val));
585: }
586:
587: lispval
588: Lbcdp()
589: {
590: chkarg(1,"bcdp");
591: return(typred(BCD, lbot->val));
592: }
593:
594: lispval
595: Lportp()
596: {
597: chkarg(1,"portp");
598: return(typred(PORT, lbot->val));
599: }
600:
601: lispval
602: Larrayp()
603: {
604: chkarg(1,"arrayp");
605: return(typred(ARRAY, lbot->val));
606: }
607:
608: /*
609: * (hunkp 'g_arg1)
610: * Returns t if g_arg1 is a hunk, otherwise returns nil.
611: */
612:
613: lispval
614: Lhunkp()
615: {
616: chkarg(1,"hunkp");
617: if (HUNKP(lbot->val))
618: return(tatom); /* If a hunk, return t */
619: else
620: return(nil); /* else nil */
621: }
622:
623: lispval
624: Lset()
625: {
626: lispval varble;
627:
628: chkarg(2,"set");
629: varble = lbot->val;
630: switch(TYPE(varble))
631: {
632: case ATOM: return(varble->a.clb = lbot[1].val);
633:
634: case VALUE: return(varble->l = lbot[1].val);
635: }
636:
637: error("IMPROPER USE OF SET",FALSE);
638: /* NOTREACHED */
639: }
640:
641: lispval
642: Lequal()
643: {
644: register lispval first, second;
645: register type1, type2;
646: lispval Lsub(),Lzerop();
647: long *oldsp;
648: Keepxs();
649: chkarg(2,"equal");
650:
651:
652: if(lbot->val==lbot[1].val) return(tatom);
653:
654: oldsp=sp(); stack((long)lbot->val);stack((long)lbot[1].val);
655: for(;oldsp > sp();) {
656:
657: first = (lispval) unstack(); second = (lispval) unstack();
658: again:
659: if(first==second) continue;
660:
661: type1=TYPE(first); type2=TYPE(second);
662: if(type1!=type2) {
663: if((type1==SDOT&&type2==INT)||(type1==INT&&type2==SDOT))
664: goto dosub;
665: {Freexs(); return(nil);}
666: }
667: switch(type1) {
668: case DTPR:
669: stack((long)first->d.cdr); stack((long)second->d.cdr);
670: first = first->d.car; second = second->d.car;
671: goto again;
672: case DOUB:
673: if(first->r!=second->r)
674: {Freexs(); return(nil);}
675: continue;
676: case INT:
677: if(first->i!=second->i)
678: {Freexs(); return(nil);}
679: continue;
680: case VECTOR:
681: if(!vecequal(first,second)) {Freexs(); return(nil);}
682: continue;
683: case VECTORI:
684: if(!veciequal(first,second)) {Freexs(); return(nil);}
685: continue;
686: dosub:
687: case SDOT: {
688: lispval temp;
689: struct argent *OLDlbot = lbot;
690: lbot = np;
691: np++->val = first;
692: np++->val = second;
693: temp = Lsub();
694: np = lbot;
695: lbot = OLDlbot;
696: if(TYPE(temp)!=INT || temp->i!=0)
697: {Freexs(); return(nil);}
698: }
699: continue;
700: case VALUE:
701: if(first->l!=second->l)
702: {Freexs(); return(nil);}
703: continue;
704: case STRNG:
705: if(strcmp((char *)first,(char *)second)!=0)
706: {Freexs(); return(nil);}
707: continue;
708:
709: default:
710: {Freexs(); return(nil);}
711: }
712: }
713: {Freexs(); return(tatom);}
714: }
715: lispval
716: oLequal()
717: {
718: chkarg(2,"equal");
719:
720: if( lbot[1].val == lbot->val ) return(tatom);
721: if(Iequal(lbot[1].val,lbot->val)) return(tatom); else return(nil);
722: }
723:
724: Iequal(first,second)
725: register lispval first, second;
726: {
727: register type1, type2;
728: lispval Lsub(),Lzerop();
729:
730: if(first==second)
731: return(1);
732: type1=TYPE(first);
733: type2=TYPE(second);
734: if(type1!=type2) {
735: if((type1==SDOT&&type2==INT)||(type1==INT&&type2==SDOT))
736: goto dosub;
737: return(0);
738: }
739: switch(type1) {
740: case DTPR:
741: return(
742: Iequal(first->d.car,second->d.car) &&
743: Iequal(first->d.cdr,second->d.cdr) );
744: case DOUB:
745: return(first->r==second->r);
746: case INT:
747: return( (first->i==second->i));
748: dosub:
749: case SDOT:
750: {
751: lispval temp;
752: struct argent *OLDlbot = lbot;
753: lbot = np;
754: np++->val = first;
755: np++->val = second;
756: temp = Lsub();
757: np = lbot;
758: lbot = OLDlbot;
759: return(TYPE(temp)==INT&& temp->i==0);
760: }
761: case VALUE:
762: return( first->l==second->l );
763: case STRNG:
764: return(strcmp((char *)first,(char *)second)==0);
765: }
766: return(0);
767: }
768: lispval
769: Zequal()
770: {
771: register lispval first, second;
772: register type1, type2;
773: lispval Lsub(),Lzerop();
774: long *oldsp;
775: Keepxs();
776: chkarg(2,"equal");
777:
778:
779: if(lbot->val==lbot[1].val) return(tatom);
780:
781: oldsp=sp(); stack((long)lbot->val);stack((long)lbot[1].val);
782:
783: for(;oldsp > sp();) {
784:
785: first = (lispval) unstack(); second = (lispval) unstack();
786: again:
787: if(first==second) continue;
788:
789: type1=TYPE(first); type2=TYPE(second);
790: if(type1!=type2) {
791: if((type1==SDOT&&type2==INT)||(type1==INT&&type2==SDOT))
792: goto dosub;
793: {Freexs(); return(nil);}
794: }
795: switch(type1) {
796: case DTPR:
797: stack((long)first->d.cdr); stack((long)second->d.cdr);
798: first = first->d.car; second = second->d.car;
799: goto again;
800: case DOUB:
801: if(first->r!=second->r)
802: {Freexs(); return(nil);}
803: continue;
804: case INT:
805: if(first->i!=second->i)
806: {Freexs(); return(nil);}
807: continue;
808: dosub:
809: case SDOT:
810: {
811: lispval temp;
812: struct argent *OLDlbot = lbot;
813: lbot = np;
814: np++->val = first;
815: np++->val = second;
816: temp = Lsub();
817: np = lbot;
818: lbot = OLDlbot;
819: if(TYPE(temp)!=INT || temp->i!=0)
820: {Freexs(); return(nil);}
821: }
822: continue;
823: case VALUE:
824: if(first->l!=second->l)
825: {Freexs(); return(nil);}
826: continue;
827: case STRNG:
828: if(strcmp((char *)first,(char *)second)!=0)
829: {Freexs(); return(nil);}
830: continue;
831: }
832: }
833: {Freexs(); return(tatom);}
834: }
835:
836: /*
837: * (print 'expression ['port]) prints the given expression to the given
838: * port or poport if no port is given. The amount of structure
839: * printed is a function of global lisp variables plevel and
840: * plength.
841: */
842: lispval
843: Lprint()
844: {
845: register lispval handy;
846: extern int plevel,plength;
847:
848:
849: handy = nil; /* port is optional, default nil */
850: switch(np-lbot)
851: {
852: case 2: handy = lbot[1].val;
853: case 1: break;
854: default: argerr("print");
855: }
856:
857: chkrtab(Vreadtable->a.clb);
858: if(TYPE(Vprinlevel->a.clb) == INT)
859: {
860: plevel = Vprinlevel->a.clb->i;
861: }
862: else plevel = -1;
863: if(TYPE(Vprinlength->a.clb) == INT)
864: {
865: plength = Vprinlength->a.clb->i;
866: }
867: else plength = -1;
868: printr(lbot->val,okport(handy,okport(Vpoport->a.clb,poport)));
869: return(nil);
870: }
871:
872: /* patom does not use plevel or plength
873: *
874: * form is (patom 'value ['port])
875: */
876: lispval
877: Lpatom()
878: {
879: register lispval temp;
880: register lispval handy;
881: register int typ;
882: FILE *port;
883:
884: handy = nil; /* port is optional, default nil */
885: switch(np-lbot)
886: {
887: case 2: handy = lbot[1].val;
888: case 1: break;
889: default: argerr("patom");
890: }
891:
892: temp = Vreadtable->a.clb;
893: chkrtab(temp);
894: port = okport(handy, okport(Vpoport->a.clb,stdout));
895: if ((typ= TYPE((temp = (lbot)->val))) == ATOM)
896: fputs(temp->a.pname, port);
897: else if(typ == STRNG)
898: fputs((char *)temp,port);
899: else
900: {
901: if(TYPE(Vprinlevel->a.clb) == INT)
902: {
903: plevel = Vprinlevel->a.clb->i;
904: }
905: else plevel = -1;
906: if(TYPE(Vprinlength->a.clb) == INT)
907: {
908: plength = Vprinlength->a.clb->i;
909: }
910: else plength = -1;
911:
912: printr(temp, port);
913: }
914: return(temp);
915: }
916:
917: /*
918: * (pntlen thing) returns the length it takes to print out
919: * an atom or number.
920: */
921:
922: lispval
923: Lpntlen()
924: {
925: return(inewint((long)Ipntlen()));
926: }
927: Ipntlen()
928: {
929: register lispval temp;
930: register char *handy;
931: char *sprintf();
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.