Commit | Line | Data |
---|---|---|
8cd657f4 JF |
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) */ |