![[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] / 40BSD / cmd / lisp|
Return to io.c CVS log | Up to [CSRG BSD Unix] / 40BSD / cmd / lisp |
1.1 root 1: static char *sccsid = "@(#)io.c 34.5 10/24/80";
2:
3: #include "global.h"
4: #include <ctype.h>
5: #include "chars.h"
6:
7: struct readtable {
8: char ctable[132];
9: } initread = {
10: /* ^@ nul ^A soh ^B stx ^C etx ^D eot ^E eng ^F ack ^G bel */
11: VERR, VERR, VERR, VERR, VERR, VERR, VERR, VERR,
12: /* ^H bs ^I ht ^J nl ^K vt ^L np ^M cr ^N so ^O si */
13: VCHAR, VSEP, VSEP, VSEP, VSEP, VSEP, VERR, VERR,
14: /* ^P dle ^Q dc1 ^R dc2 ^S dc3 ^T dc4 ^U nak ^V syn ^W etb */
15: VERR, VERR, VERR, VERR, VERR, VERR, VERR, VERR,
16: /* ^X can ^Y em ^Z sub ^[ esc ^\ fs ^] gs ^^ rs ^_ us */
17: VERR, VERR, VERR, VSEP, VERR, VERR, VERR, VERR,
18: /* sp ! " # $ % & ' */
19: VSEP, VCHAR, VSD, VCHAR, VCHAR, VCHAR, VCHAR, VSQ,
20: /* ( ) * + , - . / */
21: VLPARA, VRPARA, VCHAR, VSIGN, VCHAR, VSIGN, VPERD, VCHAR,
22: /* 0 1 2 3 4 5 6 7 */
23: VNUM, VNUM, VNUM, VNUM, VNUM, VNUM, VNUM, VNUM,
24: /* 8 9 : ; < = > ? */
25: VNUM, VNUM, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR,
26: /* @ A B C D E F G */
27: VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR,
28: /* H I J K L M N O */
29: VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR,
30: /* P Q R S T U V W */
31: VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR,
32: /* X Y Z [ \ ] ^ _ */
33: VCHAR, VCHAR, VCHAR, VLBRCK, VESC, VRBRCK, VCHAR, VCHAR,
34: /* ` a b c d e f g */
35: VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR,
36: /* h i j k l m n o */
37: VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR,
38: /* p q r s t u v w */
39: VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR,
40: /* x y z { | } ~ del */
41: VCHAR, VCHAR, VCHAR, VCHAR, VDQ, VCHAR, VCHAR, VEOF,
42: /* unused Xsdc Xesc Xdqc */
43: 0, '"', '\\', '|'
44: };
45:
46: char *ctable = initread.ctable;
47: lispval atomval; /* external varaible containing atom returned
48: from internal atom reading routine */
49: lispval readrx(); lispval readr(); lispval readry();
50: int keywait;
51: int prinlevel = -1; /* contains maximum list recursion count */
52: int prinlength = -1; /* maximum number of list elements printed */
53: static int dbqflag;
54: static int macflag;
55: static int splflag;
56: static int mantisfl = 0;
57: extern lispval lastrtab; /* external variable designating current reader
58: table */
59: static char baddot1[]=
60: "Bad reader construction: (. <something>)\nShould be (nil . <something>)\n";
61: static char baddot2[]=
62: "Bad reader construction: (<something> .)\n\
63: Should be (<something> . <something>), assumed to be (<something>)";
64: static char baddot3[]=
65: "Bad reader construction: (<something> . <something> not followed by )";
66:
67: #include "chkrtab.h"
68: /* readr ****************************************************************/
69: /* returns a s-expression read in from the port specified as the first */
70: /* argument. Handles superbrackets, reader macros. */
71: lispval
72: readr(useport)
73: FILE *useport;
74: {
75: register lispval handy = Vreadtable->a.clb;
76:
77: chkrtab(handy);
78: rbktf = FALSE;
79: rdrport = (FILE *) useport;
80: if(useport==stdin)
81: keywait = TRUE;
82: handy = readrx(Iratom());
83: if(useport==stdin)
84: keywait = FALSE;
85: return(handy);
86:
87: }
88:
89:
90: /* readrx **************************************************************/
91: /* returns a s-expression beginning with the syntax code of an atom */
92: /* passed in the first */
93: /* argument. Does the actual work for readr, including list, dotted */
94: /* pair, and quoted atom detection */
95: lispval
96: readrx(code)
97: register int code;
98: {
99: register lispval work;
100: register lispval *current;
101: register struct argent *result;
102: register struct argent *lbot, *np;
103: int inlbkt = FALSE;
104: lispval errorh();
105:
106: top:
107: switch(code)
108: {
109: case TLBKT:
110: inlbkt = TRUE;
111: case TLPARA:
112: result = np;
113: current = (lispval *)np;
114: np++->val = nil; /*protect(nil);*/
115: for(EVER) {
116: switch(code = Iratom())
117: {
118: case TRPARA:
119: if(rbktf && inlbkt)
120: rbktf = FALSE;
121: return(result->val);
122: default:
123: atomval = readrx(code);
124: case TSCA:
125: np++->val=atomval;
126: *current = work = newdot();
127: work->d.car = atomval;
128: np--;
129: current = (lispval *) &(work->d.cdr);
130: break;
131: case TSPL:
132: macrox(); /* input and output in atomval */
133: *current = atomval;
134: while(*current!=nil) {
135: if(TYPE(*current)!=DTPR)
136: errorh(Vermisc,"Non-list returned from splicing macro",nil,FALSE,7,*current);
137: current=(lispval *)&((*current)->d.cdr);
138: }
139: break;
140: case TPERD:
141: if(result->val==nil) {
142: work = result->val=newdot();
143: current = (lispval *) &(work->d.cdr);
144: fprintf(stderr,baddot1);
145: }
146: code = Iratom();
147: if(code==TRPARA) {
148: return(errorh(Vermisc,baddot2,nil,TRUE,58,result->val));
149: }
150: *current = readrx(code);
151: /* there is the possibility that the expression
152: following the dot is terminated with a "]"
153: and thus needs no closing lparens to follow
154: */
155: if(!rbktf && ((code = Iratom()))!=TRPARA) {
156: errorh(Vermisc,baddot3,nil,TRUE,59,result->val,atomval);
157: }
158: if(rbktf && inlbkt)
159: rbktf = FALSE;
160: return(result->val);
161: case TEOF:
162: errorh(Vermisc,"Premature end of file after ",
163: nil,FALSE,0,result->val);
164: }
165: if(rbktf) {
166: if(inlbkt)
167: rbktf = FALSE;
168: return(result->val);
169: }
170: }
171: case TSCA:
172: return(atomval);
173: case TEOF:
174: return(eofa);
175: case TMAC:
176: macrox();
177: return(atomval);
178: case TSPL:
179: macrox();
180: if((work = atomval)!=nil) {
181: if(TYPE(work)==DTPR && work->d.cdr==nil)
182: return(work->d.car);
183: else
184: errorh(Vermisc,
185: "Improper value returned from splicing macro at top-level",nil,FALSE,9,work);
186: }
187: code = Iratom();
188: goto top;
189: /* return(readrx(Iratom())); */
190: case TSQ:
191: result = np;
192: protect(newdot());
193: (work = result->val)->d.car = quota;
194: work = work->d.cdr = newdot();
195: work->d.car = readrx(Iratom());
196: return(result->val);
197: default:
198: return(errorh(Vermisc,"Readlist error, code ",nil,FALSE,0,inewint(code)));
199: }
200: }
201: macrox()
202: {
203: lispval Lapply();
204:
205: snpand(0);
206: lbot = np;
207: protect(Iget(atomval,macro));
208: protect(nil);
209: atomval = Lapply();
210: chkrtab(Vreadtable->a.clb); /* the macro could have changed
211: the readtable
212: */
213: return;
214: }
215:
216:
217:
218: /* ratomr ***************************************************************/
219: /* this routine returns a pointer to an atom read in from the port given*/
220: /* by the first argument */
221: lispval
222: ratomr(useport)
223: register FILE *useport;
224: {
225: rdrport = useport;
226: switch(Iratom())
227: {
228: case TEOF:
229: return(eofa);
230: case TSQ:
231: case TRPARA:
232: case TLPARA:
233: case TLBKT:
234: case TPERD:
235: strbuf[1]=0;
236: return(getatom());
237: default:
238: return(atomval);
239: }
240: }
241: Iratom()
242: {
243: register FILE *useport = rdrport;
244: register char c, marker, *name;
245: extern lispval finatom(), calcnum(), getnum();
246: char positv = TRUE;
247: int code;
248: int strflag = FALSE;
249:
250: name = strbuf;
251:
252: again: c = getc(useport) & 0177;
253: *name = c;
254:
255: switch(ctable[c] & 0377) {
256:
257: default: goto again;
258:
259: case VNUM:
260:
261: case VSIGN: *name++ = c;
262: atomval = (getnum(name));
263: return(TSCA);
264:
265: case VESC:
266: dbqflag = TRUE;
267: *name++ = getc(useport) & 0177;
268: atomval = (finatom(name));
269: return(TSCA);
270:
271: case VCHAR:
272: *name++ = c;
273: atomval = (finatom(name));
274: return(TSCA);
275:
276: case VLPARA: return(TLPARA);
277:
278: case VRPARA: return(TRPARA);
279:
280: case VPERD: c = peekc(useport) & 0177;
281: if(VNUM!=ctable[c])
282: { if(SEPMASK & ctable[c])
283: return(TPERD);
284: else { *name++ = '.'; /* this period begins an atm */
285: atomval = finatom(name);
286: return(TSCA);
287: }
288: }
289: *name++ = '.';
290: mantisfl = 1;
291: atomval = (getnum(name));
292: return(TSCA);
293:
294: case VLBRCK: return(TLBKT);
295:
296: case VRBRCK: rbktf = TRUE;
297: return(TRPARA);
298:
299: case VEOF: /*printf("returning eof atom\n");*/
300: clearerr(useport);
301: return(TEOF);
302:
303: case VSQ: return(TSQ);
304:
305: case VSD: strflag = TRUE;
306: case VDQ: name = strbuf;
307: marker = c;
308: while ((c = getc(useport)) != marker) {
309:
310: if(VESC==ctable[c]) c = getc(useport) & 0177;
311: *name++ = c;
312: if (name >= endstrb)
313: error("ATOM TOO LONG",FALSE);
314: if (feof(useport)) {
315: clearerr(useport);
316: error("EOF encountered while reading atom", FALSE);
317: }
318: }
319: *name = NULL_CHAR;
320: if(strflag)
321: atomval = (lispval) inewstr(strbuf);
322: else
323: atomval = (getatom(name));
324: return(TSCA);
325:
326: case VERR: if (c == '\0')
327: {
328: fprintf(stderr,"[read: null read and ignored]\n");
329: goto again; /* null pname */
330: }
331: fprintf(stderr,"%c (%o): ",c,(int) c);
332: error("ILLEGAL CHARACTER IN ATOM",TRUE);
333:
334: case VSPL:
335: code = TSPL;
336: goto same;
337: case VMAC:
338: code = TMAC;
339: goto same;
340: case VSCA:
341: code = TSCA;
342: same:
343: strbuf[0] = c;
344: strbuf[1] = 0;
345: atomval = (getatom());
346: return(code);
347: }
348: }
349:
350: #define push(); if(name==endstrb) error("Int too long",FALSE); else *name++=c;
351: #define next() (stats = ctable[c=getc(useport) & 0177])
352:
353: lispval
354: getnum(name)
355: register char *name;
356: {
357: register char c;
358: register lispval result;
359: register FILE *useport=rdrport;
360: char stats;
361: double realno;
362: extern lispval finatom(), calcnum(), newdoub(), dopow();
363:
364: if(mantisfl) {
365: mantisfl = 0;
366: next();
367: goto mantissa;
368: }
369: while(VNUM==next()) {
370: push(); /* recognize [0-9]*, in "ex" parlance */
371: }
372: if(stats==VPERD) {
373: push(); /* continue */
374: } else if(stats & SEPMASK) {
375: ungetc(c,useport);
376: return(calcnum(strbuf,name,ibase->a.clb->i));
377: } else if(c=='^') {
378: push();
379: return(dopow(name,ibase->a.clb->i));
380: } else if(c=='_') {
381: push();
382: return(dopow(name,2));
383: } else if(c=='e' || c=='E' || c=='d' ||c=='D') {
384: goto expt;
385: } else {
386: ungetc(c,useport);
387: return(finatom(name));
388: }
389: /* at this point we have [0-9]*\. , which might
390: be a decimal int or the leading part of a
391: float */
392: if(next()!=VNUM) {
393: if(c=='e' || c=='E' || c=='d' ||c=='D')
394: goto expt;
395: else if(c=='^') {
396: push();
397: return(dopow(name,ibase->a.clb->i));
398: } else if(c=='_') {
399: push();
400: return(dopow(name,2));
401: } else {
402: /* Here we have 1.x where x not num, not sep */
403: /* Here we have decimal int. NOT FORTRAN! */
404: ungetc(c,useport);
405: return(calcnum(strbuf,name-1,10));
406: }
407: }
408: mantissa:
409: do {
410: push();
411: } while (VNUM==next());
412: /* Here we have [0-9]*\.[0-9]* */
413: if(stats & SEPMASK)
414: goto last;
415: else if(c!='e' && c!='E' && c!='d' && c!='D') {
416: ungetc(c,useport);
417: goto verylast;
418: }
419: expt: push();
420: next();
421: if(c=='+' || c =='-') {
422: push();
423: next();
424: }
425: while (VNUM==stats) {
426: push();
427: next();
428: }
429: last: ungetc(c,useport);
430: if(! (stats & SEPMASK) )
431: return(finatom(name));
432:
433: verylast:
434: *name=0;
435: sscanf(strbuf,"%F",&realno);
436: (result = newdoub())->r = realno;
437: return(result);
438: }
439:
440: lispval
441: dopow(part2,base)
442: lispval base;
443: register char *part2;
444: {
445: register char *name = part2;
446: register FILE *useport = rdrport;
447: register int power;
448: register struct argent *lbot, *np;
449: char stats,c;
450: char *end1 = part2 - 1; lispval Ltimes();
451:
452: while(VNUM==next()) {
453: push();
454: }
455: if(c!='.') {
456: ungetc(c,useport);
457: }
458: if(c!='.' && !(stats & SEPMASK)) {
459: return(finatom(name));
460: }
461: lbot = np;
462: np++->val = inewint(base);
463: /* calculate "mantissa"*/
464: if(*end1=='.')
465: np++->val = calcnum(strbuf,end1-1,10);
466: else
467: np++->val = calcnum(strbuf,end1,ibase->a.clb->i);
468:
469: /* calculate exponent */
470: if(c=='.')
471: power = calcnum(part2,name,10)->i;
472: else
473: power = calcnum(part2,name,ibase->a.clb->i)->i;
474: while(power-- > 0)
475: lbot[1].val = Ltimes();
476: return(lbot[1].val);
477: }
478:
479:
480: lispval
481: calcnum(strbuf,name,base)
482: char *name;
483: char *strbuf;
484: {
485: register char *p;
486: register lispval result, temp;
487: int negflag = 0;
488:
489: temp = rdrsdot; /* initialize sdot cell */
490: temp->s.CDR = nil;
491: temp->i = 0;
492: p = strbuf;
493: if(*p=='+') p++;
494: else if(*p=='-') {negflag = 1; p++;}
495: *name = 0;
496: if(p>=name) return(getatom());
497:
498: for(;p < name; p++)
499: dmlad(temp,base,*p-'0');
500: if(negflag)
501: dmlad(temp,-1,0);
502:
503: if(temp->s.CDR==0) {
504: result = inewint(temp->i);
505: return(result);
506: } else {
507: (result = newsdot())->i = temp->i;
508: result->s.CDR = temp->s.CDR;
509: temp->s.CDR = 0;
510: }
511: return(result);
512: }
513: lispval
514: finatom(name)
515: register char *name;
516: {
517: extern int uctolc;
518: register FILE *useport = rdrport;
519: register char c, stats;
520: register char *savenm;
521: savenm = name - 1; /* remember start of name */
522: while(!(next()&SEPMASK)) {
523:
524: if(stats == VESC) c = getc(useport) & 0177;
525: *name++=c;
526: if (name >= endstrb)
527: error("ATOM TOO LONG",FALSE);
528: }
529: *name = NULL_CHAR;
530: ungetc(c,useport);
531: if (uctolc) for(; *savenm ; savenm++)
532: if( isupper(*savenm) ) *savenm = tolower(*savenm);
533: return(getatom());
534: }
535:
536: /* printr ***************************************************************/
537: /* prints the first argument onto the port specified by the second */
538:
539: /*
540: * Last modified Mar 21, 1980 for hunks
541: */
542:
543: printr(a,useport)
544: register lispval a;
545: register FILE *useport;
546: {
547: register lispval temp;
548: register hsize, i;
549: char strflag = 0;
550: char Idqc = 0;
551: int curprinlength = prinlength;
552:
553: val_loop:
554: if( ! VALID(a) )
555: {
556: /* error("Bad lisp data encountered by printr", TRUE);
557: a = badst; */
558: printf("<printr:bad lisp data: 0x%x>",a);
559: return;
560: }
561:
562: switch (TYPE(a))
563: {
564:
565:
566: case UNBO: fputs("<UNBOUND>",useport);
567: break;
568:
569: case VALUE: fputs("(ptr to)",useport);
570: a = a->l;
571: goto val_loop;
572:
573: case INT: fprintf(useport,"%d",a->i);
574: break;
575:
576: case DOUB: { char buf[64];
577: lfltpr(buf,a->r);
578: fputs(buf,useport);
579: }
580: break;
581:
582: case PORT: { lispval cp;
583: if((cp = ioname[PN(a->p)]) == nil)
584: fputs("%$unopenedport",useport);
585: else fprintf(useport,"%%%s",cp);
586: }
587: break;
588:
589: case HUNK2:
590: case HUNK4:
591: case HUNK8:
592: case HUNK16:
593: case HUNK32:
594: case HUNK64:
595: case HUNK128:
596: if(prinlevel == 0)
597: {
598: fputs("%",useport);
599: break;
600: }
601: hsize = 2 << HUNKSIZE(a);
602: fputs("{", useport);
603: prinlevel--;
604: printr(a->h.hunk[0], useport);
605: curprinlength--;
606: for (i=1; i < hsize; i++)
607: {
608: if (a->h.hunk[i] == hunkfree)
609: break;
610: if (curprinlength-- == 0)
611: {
612: fputs(" ...",useport);
613: break;
614: }
615: else
616: {
617: fputs(" ", useport);
618: printr(a->h.hunk[i], useport);
619: }
620: }
621: fputs("}", useport);
622: prinlevel++;
623: break;
624:
625: case ARRAY: fputs("array[",useport);
626: printr(a->ar.length,useport);
627: fputs("]",useport);
628: break;
629:
630: case BCD: fprintf(useport,"#%X-",a->bcd.entry);
631: printr(a->bcd.discipline,useport);
632: break;
633:
634: case SDOT: pbignum(a,useport);
635: break;
636:
637: case DTPR: if(prinlevel==0)
638: {
639: fputs("&",useport);
640: break;
641: }
642: prinlevel--;
643: if(a->d.car==quota && a->d.cdr!=nil
644: && a->d.cdr->d.cdr==nil) {
645: putc('\'',useport);
646: printr(a->d.cdr->d.car,useport);
647: prinlevel++;
648: break;
649: }
650: putc('(',useport);
651: curprinlength--;
652: morelist: printr(a->d.car,useport);
653: if ((a = a->d.cdr) != nil)
654: {
655: if(curprinlength-- == 0)
656: {
657: fputs(" ...",useport);
658: goto out;
659: }
660: putc(' ',useport);
661: if (TYPE(a) == DTPR) goto morelist;
662: fputs(". ",useport);
663: printr(a,useport);
664: }
665: out:
666: fputc(')',useport);
667: prinlevel++;
668: break;
669:
670: case STRNG: strflag = TRUE;
671: Idqc = Xsdc;
672:
673: case ATOM: {
674: char *front, *temp; int clean;
675: temp = front = (strflag ? ((char *) a) : a->a.pname);
676: if(Idqc==0) Idqc = Xdqc;
677:
678: if(Idqc) {
679: clean = *temp;
680: if (*temp == '-') temp++;
681: clean = clean && (ctable[*temp] != VNUM);
682: while (clean && *temp)
683: clean = (!(ctable[*temp++] & QUTMASK));
684: if (clean & !strflag)
685: fputs(front,useport);
686: else {
687: putc(Idqc,useport);
688: for(temp=front;*temp;temp++) {
689: if( *temp==Idqc
690: || ctable[*temp] == VESC)
691: putc(Xesc,useport);
692: putc(*temp,useport);
693: }
694: putc(Idqc,useport);
695: }
696:
697: } else {
698: register char *cp = front;
699:
700: if(ctable[*cp]==VNUM)
701: putc(Xesc,useport);
702: for(; *cp; cp++) {
703: if(ctable[*cp]& QUTMASK)
704: putc(Xesc,useport);
705: putc(*cp,useport);
706: }
707:
708: }
709:
710: }
711: }
712: }
713:
714: lfltpr(buf,val) /* lisp floating point printer */
715: char *buf;
716: double val;
717: {
718: register char *cp1;
719:
720: sprintf(buf,"%.16G",val);
721: for(cp1 = buf; *cp1; cp1++)
722: if(*cp1=='.'|| *cp1=='E') return;
723:
724: /* if we are here, there was no dot, so the number was
725: an integer. Furthermore, cp1 already points to the
726: end of the string. */
727:
728: *cp1++ = '.';
729: *cp1++ = '0';
730: *cp1++ = 0;
731: }
732:
733:
734: /* dmpport ****************************************************************/
735: /* outputs buffer indicated by first argument whether full or not */
736:
737: dmpport(useport)
738: register lispval useport;
739: {
740: fflush(useport);
741: }
742:
743: /* 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.