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