![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to io.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 io.c CVS log | Up to [CSRG BSD Unix] / 42BSD / ucb / lisp / franz |
1.1 root 1: #ifndef lint
2: static char *rcsid =
3: "$Header: /na/franz/franz/RCS/io.c,v 1.8 83/08/06 08:38:42 jkf Exp $";
4: #endif
5:
6: /* -[Fri Aug 5 12:45:22 1983 by jkf]-
7: * io.c $Locker: $
8: * input output functions
9: *
10: * (c) copyright 1982, Regents of the University of California
11: */
12:
13: #include "global.h"
14: #include <ctype.h>
15: #include "chars.h"
16: #include "chkrtab.h"
17:
18: struct readtable {
19: unsigned char ctable[132];
20: } initread = {
21: /* ^@ nul ^A soh ^B stx ^C etx ^D eot ^E eng ^F ack ^G bel */
22: VERR, VERR, VERR, VERR, VERR, VERR, VERR, VERR,
23: /* ^H bs ^I ht ^J nl ^K vt ^L np ^M cr ^N so ^O si */
24: VCHAR, VSEP, VSEP, VSEP, VSEP, VSEP, VERR, VERR,
25: /* ^P dle ^Q dc1 ^R dc2 ^S dc3 ^T dc4 ^U nak ^V syn ^W etb */
26: VERR, VERR, VERR, VERR, VERR, VERR, VERR, VERR,
27: /* ^X can ^Y em ^Z sub ^[ esc ^\ fs ^] gs ^^ rs ^_ us */
28: VERR, VERR, VERR, VSEP, VERR, VERR, VERR, VERR,
29: /* sp ! " # $ % & ' */
30: VSEP, VCHAR, VSD, VCHAR, VCHAR, VCHAR, VCHAR, VSQ,
31: /* ( ) * + , - . / */
32: VLPARA, VRPARA, VCHAR, VSIGN, VCHAR, VSIGN, VPERD, VCHAR,
33: /* 0 1 2 3 4 5 6 7 */
34: VNUM, VNUM, VNUM, VNUM, VNUM, VNUM, VNUM, VNUM,
35: /* 8 9 : ; < = > ? */
36: VNUM, VNUM, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR,
37: /* @ A B C D E F G */
38: VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR,
39: /* H I J K L M N O */
40: VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR,
41: /* P Q R S T U V W */
42: VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR,
43: /* X Y Z [ \ ] ^ _ */
44: VCHAR, VCHAR, VCHAR, VLBRCK, VESC, VRBRCK, VCHAR, VCHAR,
45: /* ` a b c d e f g */
46: VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR,
47: /* h i j k l m n o */
48: VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR,
49: /* p q r s t u v w */
50: VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR,
51: /* x y z { | } ~ del */
52: VCHAR, VCHAR, VCHAR, VCHAR, VDQ, VCHAR, VCHAR, VERR,
53: /* unused Xsdc Xesc Xdqc */
54: 0, '"', '\\', '|'
55: };
56:
57: extern unsigned char *ctable;
58: lispval atomval; /* external varaible containing atom returned
59: from internal atom reading routine */
60: lispval readrx(); lispval readr(); lispval readry();
61: char *atomtoolong();
62: int keywait;
63: int plevel = -1; /* contains maximum list recursion count */
64: int plength = -1; /* maximum number of list elements printed */
65: static int dbqflag;
66: static int mantisfl = 0;
67: extern int uctolc;
68: extern lispval lastrtab; /* external variable designating current reader
69: table */
70: static char baddot1[]=
71: "Bad reader construction: (. <something>)\nShould be (nil . <something>)\n";
72: static char baddot2[]=
73: "Bad reader construction: (<something> .)\n\
74: Should be (<something> . <something>), assumed to be (<something>)";
75: static char baddot3[]=
76: "Bad reader construction: (<something> . <something> not followed by )";
77:
78: /* readr ****************************************************************/
79: /* returns a s-expression read in from the port specified as the first */
80: /* argument. Handles superbrackets, reader macros. */
81: lispval
82: readr(useport)
83: FILE *useport;
84: {
85: register lispval handy = Vreadtable->a.clb;
86:
87: chkrtab(handy);
88: rbktf = FALSE;
89: rdrport = (FILE *) useport;
90: if(useport==stdin)
91: keywait = TRUE;
92: handy = readrx(Iratom());
93: if(useport==stdin)
94: keywait = FALSE;
95: return(handy);
96:
97: }
98:
99:
100: /* readrx **************************************************************/
101: /* returns a s-expression beginning with the syntax code of an atom */
102: /* passed in the first */
103: /* argument. Does the actual work for readr, including list, dotted */
104: /* pair, and quoted atom detection */
105: lispval
106: readrx(code)
107: register int code;
108: {
109: register lispval work;
110: register lispval *current;
111: register struct argent *result;
112: int inlbkt = FALSE;
113: lispval errorh();
114: Savestack(4); /* ???not necessary because np explicitly restored if
115: changed */
116:
117: top:
118: switch(code)
119: {
120: case TLBKT:
121: inlbkt = TRUE;
122: case TLPARA:
123: result = np;
124: current = (lispval *)np;
125: np++->val = nil; /*protect(nil);*/
126: for(EVER) {
127: switch(code = Iratom())
128: {
129: case TRPARA:
130: if(rbktf && inlbkt)
131: rbktf = FALSE;
132: goto out;
133: default:
134: atomval = readrx(code);
135: case TSCA:
136: np++->val=atomval;
137: *current = work = newdot();
138: work->d.car = atomval;
139: np--;
140: current = (lispval *) &(work->d.cdr);
141: break;
142: case TINF:
143: imacrox(result->val,TRUE);
144: work = atomval;
145: result->val = work->d.car;
146: current = (lispval *) & (result->val);
147: goto mcom;
148: case TSPL:
149: macrox(); /* input and output in atomval */
150: *current = atomval;
151: mcom:
152: while(*current!=nil) {
153: if(TYPE(*current)!=DTPR)
154: errorh1(Vermisc,"Non-list returned from splicing macro",nil,FALSE,7,*current);
155: current=(lispval *)&((*current)->d.cdr);
156: }
157: break;
158: case TPERD:
159: if(result->val==nil) {
160: work = result->val=newdot();
161: current = (lispval *) &(work->d.cdr);
162: fprintf(stderr,baddot1);
163: }
164: code = Iratom();
165: if(code==TRPARA) {
166: result->val = errorh1(Vermisc,baddot2,nil,TRUE,58,result->val);
167: goto out;
168: }
169: *current = readrx(code);
170: /* there is the possibility that the expression
171: following the dot is terminated with a "]"
172: and thus needs no closing lparens to follow
173: */
174: if(!rbktf && ((code = Iratom()))!=TRPARA) {
175: errorh2(Vermisc,baddot3,nil,TRUE,59,result->val,atomval);
176: }
177: if(rbktf && inlbkt)
178: rbktf = FALSE;
179: goto out;
180: case TEOF:
181: errorh1(Vermisc,"Premature end of file after ",
182: nil,FALSE,0,result->val);
183: }
184: if(rbktf) {
185: if(inlbkt)
186: rbktf = FALSE;
187: goto out;
188: }
189: }
190: case TSCA:
191: Restorestack();
192: return(atomval);
193: case TEOF:
194: Restorestack();
195: return(eofa);
196: case TMAC:
197: macrox();
198: Restorestack();
199: return(atomval);
200: case TINF:
201: imacrox(nil,FALSE);
202: work = atomval;
203: if(work==nil) { code = Iratom(); goto top;}
204: work = work->d.car;
205: Restorestack();
206: if(work->d.cdr==nil)
207: return(work->d.car);
208: else
209: return(work);
210: case TSPL:
211: macrox();
212: if((work = atomval)!=nil) {
213: if(TYPE(work)==DTPR && work->d.cdr==nil) {
214: Restorestack();
215: return(work->d.car);
216: } else {
217: errorh1(Vermisc,
218: "Improper value returned from splicing macro at top-level",nil,FALSE,9,work);
219: }
220: }
221: code = Iratom();
222: goto top;
223: /* return(readrx(Iratom())); */
224: case TSQ:
225: result = np;
226: protect(newdot());
227: (work = result->val)->d.car = quota;
228: work = work->d.cdr = newdot();
229: work->d.car = readrx(Iratom());
230: goto out;
231:
232: case TRPARA:
233: Restorestack();
234: return(errorh(Vermisc,
235: "read: read a right paren when expecting an s-expression",
236: nil,FALSE,0));
237: case TPERD:
238: Restorestack();
239: return(errorh(Vermisc,
240: "read: read a period when expecting an s-expression",
241: nil,FALSE,0));
242:
243: /* should never get here, we should have covered all cases above */
244: default:
245: Restorestack();
246: return(errorh1(Vermisc,"Readlist error, code ",nil,FALSE,0,inewint((long)code)));
247: }
248: out:
249: work = result->val;
250: np = result;
251: Restorestack();
252: return(work);
253: }
254: macrox()
255: {
256: FILE *svport;
257: lispval handy, Lapply();
258:
259: Savestack(0);
260: svport = rdrport; /* save from possible changing */
261: lbot = np;
262: protect(handy=Iget(atomval,lastrtab));
263: if (handy == nil)
264: {
265: errorh1(Vermisc,"read: can't find the character macro for ",nil,
266: FALSE,0,atomval);
267: }
268: protect(nil);
269: atomval = Lapply();
270: chkrtab(Vreadtable->a.clb); /* the macro could have changed
271: the readtable
272: */
273: rdrport = svport; /* restore old value */
274: Restorestack();
275: return;
276: }
277: imacrox(current,inlist)
278: register lispval current;
279: {
280: FILE *svport;
281: register lispval work;
282: lispval Lapply(), handy;
283:
284: Savestack(2);
285: svport = rdrport; /* save from possible changing */
286: if(inlist)
287: {
288: protect(handy = newdot());
289: handy->d.car = current;
290: for(work = handy->d.car; (TYPE(work->d.cdr))==DTPR; )
291: work = work->d.cdr;
292: handy->d.cdr = work;
293: }
294: else handy = current;
295:
296: lbot = np;
297: protect(Iget(atomval,lastrtab));
298: protect(handy);
299: atomval = Lfuncal();
300: chkrtab(Vreadtable->a.clb); /* the macro could have changed
301: the readtable
302: */
303: rdrport = svport; /* restore old value */
304: Restorestack();
305: return;
306: }
307:
308:
309:
310: /* ratomr ***************************************************************/
311: /* this routine returns a pointer to an atom read in from the port given*/
312: /* by the first argument */
313: lispval
314: ratomr(useport)
315: register FILE *useport;
316: {
317: rdrport = useport;
318: switch(Iratom())
319: {
320: case TEOF:
321: return(eofa);
322: case TSQ:
323: case TRPARA:
324: case TLPARA:
325: case TLBKT:
326: case TPERD:
327: strbuf[1]=0;
328: return(getatom(TRUE));
329: default:
330: return(atomval);
331: }
332: }
333:
334: #define push(); *name++ = c; if(name>=endstrb) name = atomtoolong(name);
335: #define next() (((cc=getc(useport))!=EOF)?(stats = ctable[c = cc &0177]):\
336: ((c=0),(saweof = 1),(stats = SEPMASK)))
337: Iratom()
338: {
339: register FILE *useport = rdrport;
340: register char c, marker, *name;
341: extern lispval finatom(), calcnum(), getnum();
342: int code, cc;
343: int strflag = FALSE;
344:
345: name = strbuf;
346:
347: again: cc = getc(useport);
348: if(cc==EOF)
349: {
350: clearerr(useport);
351: return(TEOF);
352: }
353: c = cc & 0177;
354: *name = c;
355:
356: switch(synclass(ctable[c])) {
357:
358: default: goto again;
359:
360: case synclass(VNUM):
361:
362: case synclass(VSIGN): *name++ = c;
363: atomval = (getnum(name));
364: return(TSCA);
365:
366: case synclass(VESC):
367: dbqflag = TRUE;
368: *name++ = getc(useport) & 0177;
369: atomval = (finatom(name));
370: return(TSCA);
371:
372: case synclass(VCHAR):
373: if(uctolc && isupper(c)) c = tolower(c);
374: *name++ = c;
375: atomval = (finatom(name));
376: return(TSCA);
377:
378: case synclass(VLPARA): return(TLPARA);
379:
380: case synclass(VRPARA): return(TRPARA);
381:
382: case synclass(VPERD): marker = peekc(useport) & 0177;
383: if(synclass(VNUM)!=synclass(ctable[marker]))
384: { if(SEPMASK & ctable[marker])
385: return(TPERD);
386: else { *name++ = c; /* this period begins an atm */
387: atomval = finatom(name);
388: return(TSCA);
389: }
390: }
391: *name++ = '.';
392: mantisfl = 1;
393: atomval = (getnum(name));
394: return(TSCA);
395:
396: case synclass(VLBRCK): return(TLBKT);
397:
398: case synclass(VRBRCK): rbktf = TRUE;
399: return(TRPARA);
400:
401: case synclass(VSQ): return(TSQ);
402:
403: case synclass(VSD): strflag = TRUE;
404: case synclass(VDQ): name = strbuf;
405: marker = c;
406: while ((c = getc(useport)) != marker) {
407:
408: if(synclass(VESC)==synclass(ctable[c]))
409: c = getc(useport) & 0177;
410: push();
411: if (feof(useport)) {
412: clearerr(useport);
413: error("EOF encountered while reading atom", FALSE);
414: }
415: }
416: *name = NULL_CHAR;
417: if(strflag)
418: atomval = (lispval) pinewstr(strbuf);
419: else
420: atomval = (getatom(TRUE));
421: return(TSCA);
422:
423: case synclass(VERR): if (c == '\0')
424: {
425: fprintf(stderr,"[read: null read and ignored]\n");
426: goto again; /* null pname */
427: }
428: fprintf(stderr,"%c (%o): ",c,(int) c);
429: error("ILLEGAL CHARACTER IN ATOM",TRUE);
430:
431: case synclass(VSINF):
432: code = TINF;
433: goto same;
434: case synclass(VSSPL):
435: code = TSPL;
436: goto same;
437: case synclass(VSMAC):
438: code = TMAC;
439: same:
440: marker = peekc(rdrport);
441: if(! (SEPMASK & ctable[marker]) ) {
442: *name++ = c; /* this is not a macro */
443: atomval = (finatom(name));
444: return(TSCA);
445: }
446: goto simple;
447: case synclass(VINF):
448: code = TINF;
449: goto simple;
450: case synclass(VSCA):
451: code = TSCA;
452: goto simple;
453: case synclass(VSPL):
454: code = TSPL;
455: goto simple;
456: case synclass(VMAC):
457: code = TMAC;
458: simple:
459: strbuf[0] = c;
460: strbuf[1] = 0;
461: atomval = (getatom(TRUE));
462: return(code);
463: }
464: }
465:
466: lispval
467: getnum(name)
468: register char *name;
469: {
470: unsigned char c;
471: register lispval result;
472: register FILE *useport=rdrport;
473: unsigned char stats;
474: int sawdigit = 0, saweof = 0,cc;
475: char *exploc = (char *) 0;
476: double realno;
477: extern lispval finatom(), calcnum(), newdoub(), dopow();
478:
479: if(mantisfl) {
480: mantisfl = 0;
481: next();
482: goto mantissa;
483: }
484: if(VNUM==ctable[*(unsigned char*)(name-1)]) sawdigit = 1;
485: while(VNUM==next()) {
486: push(); /* recognize [0-9]*, in "ex" parlance */
487: sawdigit = 1;
488: }
489: if(c=='.') {
490: push(); /* continue */
491: } else if(stats & SEPMASK) {
492: if(!saweof)ungetc((int)c,useport);
493: return(calcnum(strbuf,name,(int)ibase->a.clb->i));
494: } else if(c=='^') {
495: push();
496: return(dopow(name,(int)ibase->a.clb->i));
497: } else if(c=='_') {
498: if(sawdigit) /* _ must be preceeded by a digit */
499: {
500: push();
501: return(dopow(name,2));
502: }
503: else goto backout;
504: } else if(c=='e' || c=='E' || c=='d' ||c=='D') {
505: if(sawdigit) goto expt;
506: else goto backout;
507: } else {
508: backout:
509: ungetc((int)c,useport);
510: return(finatom(name));
511: }
512: /* at this point we have [0-9]*\. , which might
513: be a decimal int or the leading part of a
514: float */
515: if(next()!=VNUM) {
516: if(c=='e' || c=='E' || c=='d' ||c=='D')
517: goto expt;
518: else if(c=='^') {
519: push();
520: return(dopow(name,(int)ibase->a.clb->i));
521: } else if(c=='_') {
522: push();
523: return(dopow(name,2));
524: } else if( stats & SEPMASK) {
525: /* Here we have 1.x where x is not number
526: * but is a separator
527: * Here we have decimal int. NOT FORTRAN!
528: */
529: if(!saweof)ungetc((int)c,useport);
530: return(calcnum(strbuf,name-1,10));
531: }
532: else goto last; /* return a symbol */
533: }
534: mantissa:
535: do {
536: push();
537: } while (VNUM==next());
538:
539: /* Here we have [0-9]*\.[0-9]*
540: * three possibilities:
541: * next character is e,E,d or D in which case we examine
542: * the exponent [then we are faced with a similar
543: * situation to this one: is the character after the
544: * exponent a separator or not]
545: * next character is a separator, in which case we have a
546: * number (without an exponent)
547: * next character is not a separator in which case we have
548: * an atom (whose prefix just happens to look like a
549: * number)
550: */
551: if( (c == 'e') || (c == 'E') || (c == 'd') || (c == 'D')) goto expt;
552:
553: if(stats & SEPMASK) goto verylast; /* a real number */
554: else goto last; /* prefix makes it look like a number, but it isn't */
555:
556: expt:
557: exploc = name; /* remember location of exponent character */
558: push();
559: next();
560: if(c=='+' || c =='-') {
561: push();
562: next();
563: }
564: while (VNUM==stats) {
565: push();
566: next();
567: }
568:
569: /* if a separator follows then we have a number, else just
570: * an atom
571: */
572: if (stats & SEPMASK) goto verylast;
573:
574: last: /* get here when what looks like a number turns out to be an atom */
575: if(!saweof) ungetc((int)c,useport);
576: return(finatom(name));
577:
578: verylast:
579: if(!saweof) ungetc((int)c,useport);
580: /* scanf requires that the exponent be 'e' */
581: if(exploc != (char *) 0 ) *exploc = 'e';
582: *name=0;
583: sscanf(strbuf,"%F",&realno);
584: (result = newdoub())->r = realno;
585: return(result);
586: }
587:
588: lispval
589: dopow(part2,base)
590: register char *part2;
591: {
592: register char *name = part2;
593: register FILE *useport = rdrport;
594: register int power;
595: lispval work;
596: unsigned char stats,c;
597: int cc, saweof = 0;
598: char *end1 = part2 - 1; lispval Ltimes();
599: Savestack(4);
600:
601: while(VNUM==next()) {
602: push();
603: }
604: if(c!='.') {
605: if(!saweof)ungetc((int)c,useport);
606: }
607: if(c!='.' && !(stats & SEPMASK)) {
608: return(finatom(name));
609: }
610: lbot = np;
611: np++->val = inewint(base);
612: /* calculate "mantissa"*/
613: if(*end1=='.')
614: np++->val = calcnum(strbuf,end1-1,10);
615: else
616: np++->val = calcnum(strbuf,end1,(int)ibase->a.clb->i);
617:
618: /* calculate exponent */
619: if(c=='.')
620: power = calcnum(part2,name,10)->i;
621: else
622: power = calcnum(part2,name,(int)ibase->a.clb->i)->i;
623: while(power-- > 0)
624: lbot[1].val = Ltimes();
625: work = lbot[1].val;
626: Restorestack();
627: return(work);
628: }
629:
630:
631: lispval
632: calcnum(strbuf,name,base)
633: register char *name;
634: char *strbuf;
635: {
636: register char *p;
637: register lispval result, temp;
638: int negflag = 0;
639:
640: result = temp = newsdot(); /* initialize sdot cell */
641: protect(temp);
642: p = strbuf;
643: if(*p=='+') p++;
644: else if(*p=='-') {negflag = 1; p++;}
645: *name = 0;
646: if(p>=name) return(getatom(TRUE));
647:
648: for(;p < name; p++)
649: dmlad(temp,(long)base,(long)*p-'0');
650: if(negflag)
651: dmlad(temp,-1L,0L);
652:
653: if(temp->s.CDR==0) {
654: result = inewint(temp->i);
655: pruneb(np[-1].val);
656: }
657: np--;
658: return(result);
659: }
660: lispval
661: finatom(name)
662: register char *name;
663: {
664: register FILE *useport = rdrport;
665: unsigned char c, stats;
666: int cc, saweof = 0;
667:
668: while(!(next()&SEPMASK)) {
669:
670: if(synclass(stats) == synclass(VESC)) {
671: c = getc(useport) & 0177;
672: } else {
673: if(uctolc && isupper(c)) c = tolower(c);
674: }
675: push();
676: }
677: *name = NULL_CHAR;
678: if(!saweof)ungetc((int)c,useport);
679: return(getatom(TRUE));
680: }
681:
682: char *
683: atomtoolong(copyto)
684: char *copyto;
685: {
686: int size;
687: register char *oldp = strbuf;
688: register char *newp;
689: lispval nveci();
690: /*
691: * the string buffer contains an string which is too long
692: * so we get a bigger buffer.
693: */
694:
695: size = (endstrb - strbuf)*4 + 28 ;
696: newp = (char *) nveci(size);
697: atom_buffer = (lispval) newp;
698: strbuf = newp;
699: endstrb = newp + size - 1;
700: while(oldp < copyto) *newp++ = *oldp++;
701: return(newp);
702: }
703:
704: /* printr ***************************************************************/
705: /* prints the first argument onto the port specified by the second */
706:
707: /*
708: * Last modified Mar 21, 1980 for hunks
709: */
710:
711: printr(a,useport)
712: register lispval a;
713: register FILE *useport;
714: {
715: register hsize, i;
716: char strflag = 0;
717: char Idqc = 0;
718: char *chstr;
719: int curplength = plength;
720: int quot;
721: lispval Istsrch();
722: lispval debugmode;
723:
724: val_loop:
725: if(! VALID(a)) {
726: debugmode = Istsrch(matom("debugging"))->d.cdr->d.cdr->d.cdr;
727: if(debugmode != nil) {
728: printf("<printr:bad lisp data: 0x%x>\n",a);
729: error("Bad lisp data encountered by printr", FALSE);
730: } else {
731: a = badst;
732: printf("<printr:bad lisp data: 0x%x>",a);
733: return;
734: }
735: }
736:
737: switch (TYPE(a))
738: {
739:
740:
741: case UNBO: fputs("<UNBOUND>",useport);
742: break;
743:
744: case VALUE: fputs("(ptr to)",useport);
745: a = a->l;
746: goto val_loop;
747:
748: case INT: fprintf(useport,"%d",a->i);
749: break;
750:
751: case DOUB: { char buf[64];
752: lfltpr(buf,a->r);
753: fputs(buf,useport);
754: }
755: break;
756:
757: case PORT: { lispval cp;
758: if((cp = ioname[PN(a->p)]) == nil)
759: fputs("%$unopenedport",useport);
760: else fprintf(useport,"%%%s",cp);
761: }
762: break;
763:
764: case HUNK2:
765: case HUNK4:
766: case HUNK8:
767: case HUNK16:
768: case HUNK32:
769: case HUNK64:
770: case HUNK128:
771: if(plevel == 0)
772: {
773: fputs("%",useport);
774: break;
775: }
776: hsize = 2 << HUNKSIZE(a);
777: fputs("{", useport);
778: plevel--;
779: printr(a->h.hunk[0], useport);
780: curplength--;
781: for (i=1; i < hsize; i++)
782: {
783: if (a->h.hunk[i] == hunkfree)
784: break;
785: if (curplength-- == 0)
786: {
787: fputs(" ...",useport);
788: break;
789: }
790: else
791: {
792: fputs(" ", useport);
793: printr(a->h.hunk[i], useport);
794: }
795: }
796: fputs("}", useport);
797: plevel++;
798: break;
799:
800: case VECTOR:
801: chstr = "vector";
802: quot = 4; /* print out # of longwords */
803: goto veccommon;
804:
805: case VECTORI:
806: chstr = "vectori";
807: quot = 1;
808: veccommon:
809: /* print out 'vector' or 'vectori' except in
810: * these circumstances:
811: * property is a symbol, in which case print
812: * the symbol's pname
813: * property is a list with a 'print' property,
814: * in which case it is funcalled to print the
815: * vector
816: */
817: if(a->v.vector[VPropOff] != nil)
818: {
819: if ((i=TYPE(a->v.vector[VPropOff])) == ATOM)
820: {
821: chstr = a->v.vector[VPropOff]->a.pname;
822: }
823: else if ((i == DTPR) && vectorpr(a,useport))
824: {
825: break; /* printed by vectorpr */
826: }
827: else if ((i == DTPR)
828: && (a->v.vector[VPropOff]->d.car != nil)
829: && TYPE(a->v.vector[VPropOff]->d.car)
830: == ATOM)
831: {
832: chstr = a->v.vector[VPropOff]->d.car->a.pname;
833: }
834: }
835: fprintf(useport,"%s[%d]",
836: chstr, a->vl.vectorl[VSizeOff]/quot);
837: break;
838:
839: case ARRAY: fputs("array[",useport);
840: printr(a->ar.length,useport);
841: fputs("]",useport);
842: break;
843:
844: case BCD: fprintf(useport,"#%X-",a->bcd.start);
845: printr(a->bcd.discipline,useport);
846: break;
847:
848: case OTHER: fprintf(useport,"#Other-%X",a);
849: break;
850:
851: case SDOT: pbignum(a,useport);
852: break;
853:
854: case DTPR: if(plevel==0)
855: {
856: fputs("&",useport);
857: break;
858: }
859: plevel--;
860: if(a->d.car==quota && a->d.cdr!=nil
861: && a->d.cdr->d.cdr==nil) {
862: putc('\'',useport);
863: printr(a->d.cdr->d.car,useport);
864: plevel++;
865: break;
866: }
867: putc('(',useport);
868: curplength--;
869: morelist: printr(a->d.car,useport);
870: if ((a = a->d.cdr) != nil)
871: {
872: if(curplength-- == 0)
873: {
874: fputs(" ...",useport);
875: goto out;
876: }
877: putc(' ',useport);
878: if (TYPE(a) == DTPR) goto morelist;
879: fputs(". ",useport);
880: printr(a,useport);
881: }
882: out:
883: fputc(')',useport);
884: plevel++;
885: break;
886:
887: case STRNG: strflag = TRUE;
888: Idqc = Xsdc;
889:
890: case ATOM: {
891: char *front, *temp, first; int clean;
892: temp = front = (strflag ? ((char *) a) : a->a.pname);
893: if(Idqc==0) Idqc = Xdqc;
894:
895: if(Idqc) {
896: clean = first = *temp;
897: first &= 0177;
898: switch(QUTMASK & ctable[first]) {
899: case QWNFRST:
900: case QALWAYS:
901: clean = 0; break;
902: case QWNUNIQ:
903: if(temp[1]==0) clean = 0;
904: }
905: if (first=='-'||first=='+') temp++;
906: if(synclass(ctable[*temp])==VNUM) clean = 0;
907: while (clean && *temp) {
908: if((ctable[*temp]&QUTMASK)==QALWAYS)
909: clean = 0;
910: else if(uctolc && (isupper(*temp)))
911: clean = 0;
912: temp++;
913: }
914: if (clean && !strflag)
915: fputs(front,useport);
916: else {
917: putc(Idqc,useport);
918: for(temp=front;*temp;temp++) {
919: if( *temp==Idqc
920: || (synclass(ctable[*temp])) == CESC)
921: putc(Xesc,useport);
922: putc(*temp,useport);
923: }
924: putc(Idqc,useport);
925: }
926:
927: } else {
928: register char *cp = front;
929: int handy = ctable[*cp & 0177];
930:
931: if(synclass(handy)==CNUM)
932: putc(Xesc,useport);
933: else switch(handy & QUTMASK) {
934: case QWNUNIQ:
935: if(cp[1]==0) putc(Xesc,useport);
936: break;
937: case QWNFRST:
938: case QALWAYS:
939: putc(Xesc,useport);
940: }
941: for(; *cp; cp++) {
942: if((ctable[*cp]& QUTMASK)==QALWAYS)
943: putc(Xesc,useport);
944: putc(*cp,useport);
945: }
946: }
947: }
948: }
949: }
950:
951: /* -- vectorpr
952: * (perhaps) print out vector specially
953: * this is called with a vector whose property list begins with
954: * a list. We search for the 'print' property and if it exists,
955: * funcall the print function with two args: the vector and the port.
956: * We return TRUE iff we funcalled the function, else we return FALSE
957: * to have the standard printing done
958: */
959:
960: vectorpr(vec,port)
961: register lispval vec;
962: FILE *port;
963: {
964: register lispval handy;
965: Savestack(2);
966:
967:
968: for ( handy = vec->v.vector[VPropOff]->d.cdr
969: ; handy != nil; handy = handy->d.cdr->d.cdr)
970: {
971: if (handy->d.car == Vprintsym)
972: {
973: lbot = np;
974: protect(handy->d.cdr->d.car); /* function to call */
975: protect(vec);
976: protect(P(port));
977: Lfuncal();
978: Restorestack();
979: return(TRUE); /* did the call */
980: }
981: }
982: Restorestack();
983: return(FALSE); /* nothing printed */
984: }
985:
986:
987:
988:
989:
990:
991: lfltpr(buf,val) /* lisp floating point printer */
992: char *buf;
993: double val;
994: {
995: register char *cp1; char *sprintf();
996:
997: sprintf(buf,(char *)Vfloatformat->a.clb,val);
998: for(cp1 = buf; *cp1; cp1++)
999: if(*cp1=='.'|| *cp1=='E' || *cp1 == 'e') return;
1000:
1001: /* if we are here, there was no dot, so the number was
1002: an integer. Furthermore, cp1 already points to the
1003: end of the string. */
1004:
1005: *cp1++ = '.';
1006: *cp1++ = '0';
1007: *cp1++ = 0;
1008: }
1009:
1010:
1011: /* dmpport ****************************************************************/
1012: /* outputs buffer indicated by first argument whether full or not */
1013:
1014: dmpport(useport)
1015: FILE *useport;
1016: {
1017: fflush(useport);
1018: }
1019:
1020: /* protect and unprot moved to eval.c (whr) */
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.