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