projects / unix-history / blame
? search:
summary | tags | clone url | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
BSD 3 development
[unix-history] / usr / src / cmd / lisp / io.c
CommitLineData
8cd657f4
JF		 1#include "global.h"
2#include <stdio.h>
3#include <ctype.h>
4#include "chars.h"
5
6struct readtable {
7char 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
45char *ctable = initread.ctable;
46lispval atomval; /* external varaible containing atom returned
47 from internal atom reading routine */
48lispval protect();
49lispval unprotect();
50lispval readrx(); lispval readr(); lispval readry();
51int keywait;
52static int dbqflag;
53static int macflag;
54static int splflag;
55static int mantisfl = 0;
56lispval lastrtab; /* external variable designating current reader
57 table */
58static char baddot1[]=
59"Bad reader construction: (. <something>)\nShould be (nil . <something>)\n";
60static char baddot2[]=
61"Bad reader construction: (<something> .)\n\
62Should be (<something> . <something>), assumed to be (<something>)";
63static 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. */
70lispval
71readr(useport)
72FILE *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 */
94lispval
95readrx(code)
96register 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
105top:
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}
196macrox()
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 */
213lispval
214ratomr(useport)
215register 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}
233Iratom()
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
244again: 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
334lispval
335getnum(name)
336register 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 }
387mantissa:
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 }
398expt: push();
399 next();
400 if(c=='+' || c =='-') {
401 push();
402 next();
403 }
404 while (VNUM==stats) {
405 push();
406 next();
407 }
408last: ungetc(c,useport);
409 if(! (stats & SEPMASK) )
410 return(finatom(name));
411
412verylast:
413 *name=0;
414 sscanf(strbuf,"%F",&realno);
415 (result = newdoub())->r = realno;
416 return(result);
417}
418
419lispval
420dopow(part2,base)
421lispval base;
422char *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
460lispval
461calcnum(strbuf,name,base)
462char *name;
463char *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}
493lispval
494finatom(name)
495register 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 */
518printr(a,useport)
519register lispval a;
520register FILE *useport;
521{
522 register lispval temp;
523 char strflag = 0;
524 char Idqc = 0;
525
526
527val_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 */
629dmpport(useport)
630register lispval useport;
631 {
632 fflush(useport);
633}
634
635/* protect and unprot moved to eval.c (whr) */
Continuous source code history from original PDP-7 UNIX to FreeBSD 2, the first fully unencumbered FreeBSD release.