1 /* xlread - xlisp expression input routine */
2 /* Copyright (c) 1985, by David Michael Betz
3 All Rights Reserved
4 Permission is granted for unrestricted non-commercial use */
5 /* CHANGE LOG
6 * --------------------------------------------------------------------
7 * 28Apr03 dm eliminate some compiler warnings
8 * replaced system-specific code with generic calls (see path.c)
9 */
10
11
12 #include "stdlib.h"
13 #include "string.h"
14 #include "switches.h"
15 #include "xlisp.h"
16 #ifdef WINDOWS
17 #include "winfun.h"
18 #endif
19 #ifdef MACINTOSH
20 #include "macstuff.h"
21 #endif
22
23 #ifdef DEBUG_INPUT
24 extern FILE *debug_input_fp;
25 #endif
26
27 /* symbol parser modes */
28 #define DONE 0
29 #define NORMAL 1
30 #define ESCAPE 2
31
32 /* external variables */
33 extern LVAL s_stdout,s_true,s_dot;
34 extern LVAL s_quote,s_function,s_bquote,s_comma,s_comat;
35 extern LVAL s_rtable,k_wspace,k_const,k_nmacro,k_tmacro;
36 extern LVAL k_sescape,k_mescape;
37 extern char buf[];
38
39 /* external routines */
40 extern FILE *osaopen(const char *name, const char *mode);
41 /* on the NeXT, atof is a macro in stdlib.h */
42 /* Is this a mistake? atof is declared in stdlib.h, but it is never a macro:
43 #if !defined(atof) && !defined(_WIN32)
44 extern double atof(const char *);
45 #endif
46 */
47 #ifndef __MWERKS__
48 #if !defined(ITYPE) && !defined(_WIN32)
49 extern ITYPE;
50 #endif
51 #endif
52
53 #define WSPACE "\t \f\r\n"
54 #define CONST1 "!$%&*+-./0123456789:<=>?@[]^_{}~"
55 #define CONST2 "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"
56
57 /* forward declarations */
58 FORWARD LVAL callmacro(LVAL fptr, int ch);
59 FORWARD LOCAL LVAL psymbol(LVAL fptr);
60 FORWARD LOCAL LVAL punintern(LVAL fptr);
61 FORWARD LOCAL LVAL pnumber(LVAL fptr, int radix);
62 FORWARD LOCAL LVAL pquote(LVAL fptr, LVAL sym);
63 FORWARD LOCAL LVAL plist(LVAL fptr);
64 FORWARD LOCAL LVAL pvector(LVAL fptr);
65 FORWARD LOCAL void upcase(char *str);
66 FORWARD LOCAL int pname(LVAL fptr,int *pescflag);
67 FORWARD LOCAL void pcomment(LVAL fptr);
68 FORWARD LOCAL int checkeof(LVAL fptr);
69 FORWARD LOCAL int nextch(LVAL fptr);
70 FORWARD LOCAL void badeof(LVAL fptr);
71 FORWARD LOCAL int storech(char *buf, int i, int ch);
72
73 #ifdef WINDOWS
74 static char save_file_name[STRMAX+1]; /* keeps files opened by prompt */
75 static int sfn_valid = FALSE;
76 #endif
77
78 #ifdef DEBUG_INPUT
79 extern FILE *read_by_xlisp;
80 #endif
81
82
83 /* xlload - load a file of xlisp expressions */
xlload(const char * fname,int vflag,int pflag)84 int xlload(const char *fname, int vflag, int pflag)
85 {
86 char fullname[STRMAX+1];
87 #ifdef WINDOWS
88 char *ptr;
89 #endif
90 LVAL fptr,expr;
91 XLCONTEXT cntxt;
92 FILE *fp;
93 int sts;
94
95 /* protect some pointers */
96 xlstkcheck(2);
97 xlsave(fptr);
98 xlsave(expr);
99
100 /* space for copy + extension? */
101 if (strlen(fname) > STRMAX - 4) {
102 expr = cvstring(fname);
103 goto toolong;
104 }
105 strcpy(fullname,fname);
106 #ifdef WINDOWS
107 #ifdef WINGUI
108 if (strcmp(fullname, "*") == 0) {
109 if (sfn_valid) {
110 strcpy(fullname, save_file_name);
111 } else {
112 strcpy(fullname, "*.*");
113 }
114 }
115 if (strcmp(fullname, "*.*") == 0) {
116 const char *name = getfilename(NULL, "lsp", "r", "Load file");
117 if (name) {
118 strcpy(fullname, name);
119 strcpy(save_file_name, name);
120 sfn_valid = TRUE;
121 } else {
122 xlpopn(2);
123 return FALSE;
124 }
125 }
126 #endif
127 /* replace "/" with "\" so that (current-path) will work */
128 for (ptr = fullname; *ptr; ptr++) {
129 if (*ptr == '/') *ptr = '\\';
130 }
131 #endif
132
133 /* allocate a file node */
134 fptr = cvfile(NULL);
135
136 /* open the file */
137 fp = osaopen(fullname, "r");
138 if (fp == NULL) {
139 /* default the extension if there is room */
140 if (needsextension(fullname)) {
141 char fullname_plus[STRMAX+1];
142 strcpy(fullname_plus, fullname);
143 strcat(fullname_plus, ".lsp");
144 fp = osaopen(fullname_plus, "r");
145 if (fp) strcpy(fullname, fullname_plus);
146 }
147 }
148 if (fp == NULL) {
149 /* new cross-platform code by dmazzoni - new xlisp_path
150 implementation is in path.c */
151 const char *newname = find_in_xlisp_path(fullname);
152 if (newname && newname[0]) {
153 if (strlen(newname) > STRMAX) {
154 expr = cvstring(newname);
155 goto toolong;
156 }
157 strcpy(fullname, newname);
158 fp = osaopen(fullname, "r");
159 }
160 }
161 if (fp == NULL) {
162 /* the file STILL wasn't found */
163 #ifdef DEBUG_INPUT
164 if (read_by_xlisp) {
165 fprintf(read_by_xlisp, ";;;;xlload: failed to open %s\n", fullname);
166 }
167 #endif
168 xlpopn(2);
169 return (FALSE);
170 }
171
172 setfile(fptr,fp);
173 setvalue(s_loadingfiles, cons(fptr, getvalue(s_loadingfiles)));
174 setvalue(s_loadingfiles, cons(cvstring(fullname), getvalue(s_loadingfiles)));
175
176 /* print the information line */
177 if (vflag)
178 { snprintf(buf, STRMAX, "; loading \"%s\"\n", fullname); stdputstr(buf); }
179
180 #ifdef DEBUG_INPUT
181 if (read_by_xlisp) {
182 fprintf(read_by_xlisp, ";;;;xlload: begin loading %s\n", fullname);
183 }
184 #endif
185
186 /* read, evaluate and possibly print each expression in the file */
187 xlbegin(&cntxt,CF_ERROR,s_true);
188 if (_setjmp(cntxt.c_jmpbuf))
189 sts = FALSE;
190 #ifdef DEBUG_INPUT
191 if (read_by_xlisp) {
192 fprintf(read_by_xlisp, ";;;;xlload: catch longjump, back to %s\n", fullname);
193 }
194 #endif
195 else {
196 #ifdef DEBUG_INPUT
197 if (read_by_xlisp) {
198 fprintf(read_by_xlisp, ";;;;xlload: about to read from %s (%x)\n", fullname, fptr);
199 }
200 #endif
201 /* a nested load that fails will cause all loading files to be closed,
202 * so check to make sure fptr is still valid each time through the loop */
203 while (getfile(fptr) && xlread(fptr,&expr,FALSE)) {
204 #ifdef DEBUG_INPUT
205 if (debug_input_fp) {
206 int c = getc(debug_input_fp);
207 ungetc(c, debug_input_fp);
208 }
209 #endif
210
211 expr = xleval(expr);
212
213 #ifdef DEBUG_INPUT
214 if (debug_input_fp) {
215 int c = getc(debug_input_fp);
216 ungetc(c, debug_input_fp);
217 }
218 #endif
219
220 if (pflag)
221 stdprint(expr);
222
223 #ifdef DEBUG_INPUT
224 if (debug_input_fp) {
225 int c = getc(debug_input_fp);
226 ungetc(c, debug_input_fp);
227 }
228 #endif
229 #ifdef DEBUG_INPUT
230 if (read_by_xlisp) {
231 fprintf(read_by_xlisp, ";;;;xlload: about to read from %s (%x)\n", fullname, fptr);
232 }
233 #endif
234 }
235 #ifdef DEBUG_INPUT
236 if (read_by_xlisp) {
237 fprintf(read_by_xlisp, ";;;;xlload: xlread returned false for %s (%x)\n", fullname, fptr);
238 }
239 #endif
240 /* return success only if file did not disappear out from under us */
241 sts = (getfile(fptr) != NULL);
242 }
243 xlend(&cntxt);
244
245 /* close the file */
246 if (getfile(fptr)) { /* test added by RBD, see close_loadingfiles() */
247 osclose(getfile(fptr));
248 setfile(fptr,NULL);
249 }
250 if (consp(getvalue(s_loadingfiles)) &&
251 consp(cdr(getvalue(s_loadingfiles))) &&
252 car(cdr(getvalue(s_loadingfiles))) == fptr) {
253 setvalue(s_loadingfiles, cdr(cdr(getvalue(s_loadingfiles))));
254 }
255
256 /* restore the stack */
257 xlpopn(2);
258
259 #ifdef DEBUG_INPUT
260 if (read_by_xlisp) {
261 fprintf(read_by_xlisp, ";;;;xlload: finished loading %s\n", fullname);
262 }
263 #endif
264
265 /* return status */
266 return (sts);
267
268 toolong:
269 xlcerror("ignore file", "file name too long", expr);
270 xlpopn(2);
271 return FALSE;
272 }
273
274 /* xlread - read an xlisp expression */
xlread(LVAL fptr,LVAL * pval,int rflag)275 int xlread(LVAL fptr, LVAL *pval, int rflag)
276 {
277 int sts;
278
279 /* read an expression */
280 while ((sts = readone(fptr,pval)) == FALSE)
281 #ifdef DEBUG_INPUT
282 if (debug_input_fp) {
283 int c = getc(debug_input_fp);
284 ungetc(c, debug_input_fp);
285 }
286 #endif
287 ;
288
289 /* return status */
290 return (sts == EOF ? FALSE : TRUE);
291 }
292
293 /* readone - attempt to read a single expression */
readone(LVAL fptr,LVAL * pval)294 int readone(LVAL fptr, LVAL *pval)
295 {
296 LVAL val,type;
297 int ch;
298
299 #ifdef DEBUG_INPUT
300 if (debug_input_fp) {
301 int c = getc(debug_input_fp);
302 ungetc(c, debug_input_fp);
303 }
304 #endif
305 /* get a character and check for EOF */
306 if ((ch = xlgetc(fptr)) == EOF)
307 return (EOF);
308
309 /* handle white space */
310 if ((type = tentry(ch)) == k_wspace)
311 return (FALSE);
312
313 /* handle symbol constituents */
314 else if (type == k_const) {
315 xlungetc(fptr,ch);
316 *pval = psymbol(fptr);
317 return (TRUE);
318 }
319
320 /* handle single and multiple escapes */
321 else if (type == k_sescape || type == k_mescape) {
322 xlungetc(fptr,ch);
323 *pval = psymbol(fptr);
324 return (TRUE);
325 }
326
327 /* handle read macros */
328 else if (consp(type)) {
329 if ((val = callmacro(fptr,ch)) && consp(val)) {
330 *pval = car(val);
331 return (TRUE);
332 }
333 else
334 return (FALSE);
335 }
336
337 /* handle illegal characters */
338 else {
339 xlerror("illegal character",cvfixnum((FIXTYPE)ch));
340 /* this point will never be reached because xlerror() does a
341 _longjmp(). The return is added to avoid false positive
342 error messages from static analyzers and compilers */
343 return (FALSE);
344 }
345 }
346
347 /* rmhash - read macro for '#' */
rmhash(void)348 LVAL rmhash(void)
349 {
350 LVAL fptr,mch,val;
351 int escflag,ch;
352
353 /* protect some pointers */
354 xlsave1(val);
355
356 /* get the file and macro character */
357 fptr = xlgetfile();
358 mch = xlgachar();
359 xllastarg();
360
361 /* make the return value */
362 val = consa(NIL);
363
364 /* check the next character */
365 switch (ch = xlgetc(fptr)) {
366 case '\'':
367 rplaca(val,pquote(fptr,s_function));
368 break;
369 case '(':
370 rplaca(val,pvector(fptr));
371 break;
372 case 'b':
373 case 'B':
374 rplaca(val,pnumber(fptr,2));
375 break;
376 case 'o':
377 case 'O':
378 rplaca(val,pnumber(fptr,8));
379 break;
380 case 'x':
381 case 'X':
382 rplaca(val,pnumber(fptr,16));
383 break;
384 case '\\':
385 xlungetc(fptr,ch);
386 pname(fptr,&escflag);
387 ch = buf[0];
388 if (strlen(buf) > 1) {
389 upcase((char *) buf);
390 if (strcmp(buf,"NEWLINE") == 0)
391 ch = '\n';
392 else if (strcmp(buf,"SPACE") == 0)
393 ch = ' ';
394 else if (strcmp(buf,"TAB") == 0)
395 ch = '\t';
396 else
397 xlerror("unknown character name",cvstring(buf));
398 }
399 rplaca(val,cvchar(ch));
400 break;
401 case ':':
402 rplaca(val,punintern(fptr));
403 break;
404 case '|':
405 pcomment(fptr);
406 val = NIL;
407 break;
408 default:
409 xlerror("illegal character after #",cvfixnum((FIXTYPE)ch));
410 }
411
412 /* restore the stack */
413 xlpop();
414
415 /* return the value */
416 return (val);
417 }
418
419 /* rmquote - read macro for '\'' */
rmquote(void)420 LVAL rmquote(void)
421 {
422 LVAL fptr,mch;
423
424 /* get the file and macro character */
425 fptr = xlgetfile();
426 mch = xlgachar();
427 xllastarg();
428
429 /* parse the quoted expression */
430 return (consa(pquote(fptr,s_quote)));
431 }
432
433 /* rmdquote - read macro for '"' */
rmdquote(void)434 LVAL rmdquote(void)
435 {
436 unsigned char buf[STRMAX+1],*p,*sptr;
437 LVAL fptr,str,newstr,mch;
438 int len,blen,ch,d2,d3;
439
440 /* protect some pointers */
441 xlsave1(str);
442
443 /* get the file and macro character */
444 fptr = xlgetfile();
445 mch = xlgachar();
446 xllastarg();
447
448 /* loop looking for a closing quote */
449 len = blen = 0; p = buf;
450 while ((ch = checkeof(fptr)) != '"') {
451
452 /* handle escaped characters */
453 switch (ch) {
454 case '\\':
455 switch (ch = checkeof(fptr)) {
456 case 't':
457 ch = '\011';
458 break;
459 case 'n':
460 ch = '\012';
461 break;
462 case 'f':
463 ch = '\014';
464 break;
465 case 'r':
466 ch = '\015';
467 break;
468 default:
469 if (ch >= '0' && ch <= '7') {
470 d2 = checkeof(fptr);
471 d3 = checkeof(fptr);
472 if (d2 < '0' || d2 > '7'
473 || d3 < '0' || d3 > '7')
474 xlfail("invalid octal digit");
475 ch -= '0'; d2 -= '0'; d3 -= '0';
476 ch = (ch << 6) | (d2 << 3) | d3;
477 }
478 break;
479 }
480 }
481
482 /* check for buffer overflow */
483 if (blen >= STRMAX) {
484 newstr = new_string(len + STRMAX + 1);
485 sptr = getstring(newstr); *sptr = '\0';
486 if (str) strcat((char *) sptr, (char *) getstring(str));
487 *p = '\0'; strcat((char *) sptr, (char *) buf);
488 p = buf; blen = 0;
489 len += STRMAX;
490 str = newstr;
491 }
492
493 /* store the character */
494 *p++ = ch; ++blen;
495 }
496
497 /* append the last substring */
498 if (str == NIL || blen) {
499 newstr = new_string(len + blen + 1);
500 sptr = getstring(newstr); *sptr = '\0';
501 if (str) strcat((char *) sptr, (char *) getstring(str));
502 *p = '\0'; strcat((char *) sptr, (char *) buf);
503 str = newstr;
504 }
505
506 /* restore the stack */
507 xlpop();
508
509 /* return the new string */
510 return (consa(str));
511 }
512
513 /* rmbquote - read macro for '`' */
rmbquote(void)514 LVAL rmbquote(void)
515 {
516 LVAL fptr,mch;
517
518 /* get the file and macro character */
519 fptr = xlgetfile();
520 mch = xlgachar();
521 xllastarg();
522
523 /* parse the quoted expression */
524 return (consa(pquote(fptr,s_bquote)));
525 }
526
527 /* rmcomma - read macro for ',' */
rmcomma(void)528 LVAL rmcomma(void)
529 {
530 LVAL fptr,mch,sym;
531 int ch;
532
533 /* get the file and macro character */
534 fptr = xlgetfile();
535 mch = xlgachar();
536 xllastarg();
537
538 /* check the next character */
539 if ((ch = xlgetc(fptr)) == '@')
540 sym = s_comat;
541 else {
542 xlungetc(fptr,ch);
543 sym = s_comma;
544 }
545
546 /* make the return value */
547 return (consa(pquote(fptr,sym)));
548 }
549
550 /* rmlpar - read macro for '(' */
rmlpar(void)551 LVAL rmlpar(void)
552 {
553 LVAL fptr,mch;
554
555 /* get the file and macro character */
556 fptr = xlgetfile();
557 mch = xlgachar();
558 xllastarg();
559
560 /* make the return value */
561 return (consa(plist(fptr)));
562 }
563
564 /* 4035 is the "no return value" warning message */
565 /* rmrpar, pcomment, badeof, and upcase don't return anything */
566 /* #pragma warning(disable: 4035) */
567
568 /* rmrpar - read macro for ')' */
rmrpar(void)569 LVAL rmrpar(void)
570 {
571 xlfail("misplaced right paren");
572 return NULL; /* never used */
573 }
574
575 /* rmsemi - read macro for ';' */
rmsemi(void)576 LVAL rmsemi(void)
577 {
578 LVAL fptr,mch;
579 int ch;
580
581 /* get the file and macro character */
582 fptr = xlgetfile();
583 mch = xlgachar();
584 xllastarg();
585
586 /* skip to end of line */
587 while ((ch = xlgetc(fptr)) != EOF && ch != '\n')
588 ;
589
590 /* return nil (nothing read) */
591 return (NIL);
592 }
593
594 /* pcomment - parse a comment delimited by #| and |# */
pcomment(LVAL fptr)595 LOCAL void pcomment(LVAL fptr)
596 {
597 int lastch,ch,n;
598
599 /* look for the matching delimiter (and handle nesting) */
600 for (n = 1, lastch = -1; n > 0 && (ch = xlgetc(fptr)) != EOF; ) {
601 if (lastch == '|' && ch == '#')
602 { --n; ch = -1; }
603 else if (lastch == '#' && ch == '|')
604 { ++n; ch = -1; }
605 lastch = ch;
606 }
607 }
608
609 /* pnumber - parse a number */
pnumber(LVAL fptr,int radix)610 LOCAL LVAL pnumber(LVAL fptr, int radix)
611 {
612 int digit,ch;
613 long num;
614
615 for (num = 0L; (ch = xlgetc(fptr)) != EOF; ) {
616 if (islower(ch)) ch = toupper(ch);
617 if (!('0' <= ch && ch <= '9') && !('A' <= ch && ch <= 'F'))
618 break;
619 if ((digit = (ch <= '9' ? ch - '0' : ch - 'A' + 10)) >= radix)
620 break;
621 num = num * (long)radix + (long)digit;
622 }
623 xlungetc(fptr,ch);
624 return (cvfixnum((FIXTYPE)num));
625 }
626
627 /* plist - parse a list */
plist(LVAL fptr)628 LOCAL LVAL plist(LVAL fptr)
629 {
630 LVAL val,expr,lastnptr,nptr;
631
632 /* protect some pointers */
633 xlstkcheck(2);
634 xlsave(val);
635 xlsave(expr);
636
637 /* keep appending nodes until a closing paren is found */
638 for (lastnptr = NIL; nextch(fptr) != ')'; )
639
640 /* get the next expression */
641 switch (readone(fptr,&expr)) {
642 case EOF:
643 badeof(fptr);
644 case TRUE:
645
646 /* check for a dotted tail */
647 if (expr == s_dot) {
648 /* make sure there's a node */
649 if (lastnptr == NIL)
650 xlfail("invalid dotted pair");
651
652 /* parse the expression after the dot */
653 if (!xlread(fptr,&expr,TRUE))
654 badeof(fptr);
655 rplacd(lastnptr,expr);
656
657 /* make sure its followed by a close paren */
658 if (nextch(fptr) != ')')
659 xlfail("invalid dotted pair");
660 }
661
662 /* otherwise, handle a normal list element */
663 else {
664 nptr = consa(expr);
665 if (lastnptr == NIL)
666 val = nptr;
667 else
668 rplacd(lastnptr,nptr);
669 lastnptr = nptr;
670 }
671 break;
672 }
673
674 /* skip the closing paren */
675 xlgetc(fptr);
676
677 /* restore the stack */
678 xlpopn(2);
679
680 /* return successfully */
681 return (val);
682 }
683
684 /* pvector - parse a vector */
pvector(LVAL fptr)685 LOCAL LVAL pvector(LVAL fptr)
686 {
687 LVAL list,expr,val,lastnptr,nptr;
688 int len,ch,i;
689
690 /* protect some pointers */
691 xlstkcheck(2);
692 xlsave(list);
693 xlsave(expr);
694
695 /* keep appending nodes until a closing paren is found */
696 for (lastnptr = NIL, len = 0; (ch = nextch(fptr)) != ')'; ) {
697
698 /* check for end of file */
699 if (ch == EOF)
700 badeof(fptr);
701
702 /* get the next expression */
703 switch (readone(fptr,&expr)) {
704 case EOF:
705 badeof(fptr);
706 case TRUE:
707 nptr = consa(expr);
708 if (lastnptr == NIL)
709 list = nptr;
710 else
711 rplacd(lastnptr,nptr);
712 lastnptr = nptr;
713 len++;
714 break;
715 }
716 }
717
718 /* skip the closing paren */
719 xlgetc(fptr);
720
721 /* make a vector of the appropriate length */
722 val = newvector(len);
723
724 /* copy the list into the vector */
725 for (i = 0; i < len; ++i, list = cdr(list))
726 setelement(val,i,car(list));
727
728 /* restore the stack */
729 xlpopn(2);
730
731 /* return successfully */
732 return (val);
733 }
734
735 /* pquote - parse a quoted expression */
pquote(LVAL fptr,LVAL sym)736 LOCAL LVAL pquote(LVAL fptr, LVAL sym)
737 {
738 LVAL val,p;
739
740 /* protect some pointers */
741 xlsave1(val);
742
743 /* allocate two nodes */
744 val = consa(sym);
745 rplacd(val,consa(NIL));
746
747 /* initialize the second to point to the quoted expression */
748 if (!xlread(fptr,&p,TRUE))
749 badeof(fptr);
750 rplaca(cdr(val),p);
751
752 /* restore the stack */
753 xlpop();
754
755 /* return the quoted expression */
756 return (val);
757 }
758
759 /* psymbol - parse a symbol name */
psymbol(LVAL fptr)760 LOCAL LVAL psymbol(LVAL fptr)
761 {
762 int escflag;
763 LVAL val;
764 pname(fptr,&escflag);
765 return (escflag || !xlisnumber(buf,&val) ? xlenter(buf) : val);
766 }
767
768 /* punintern - parse an uninterned symbol */
punintern(LVAL fptr)769 LOCAL LVAL punintern(LVAL fptr)
770 {
771 int escflag;
772 pname(fptr,&escflag);
773 return (xlmakesym(buf));
774 }
775
776 /* pname - parse a symbol/package name */
pname(LVAL fptr,int * pescflag)777 LOCAL int pname(LVAL fptr,int *pescflag)
778 {
779 int mode,ch=0,i;
780 LVAL type;
781
782 /* initialize */
783 *pescflag = FALSE;
784 mode = NORMAL;
785 i = 0;
786
787 /* accumulate the symbol name */
788 while (mode != DONE) {
789
790 /* handle normal mode */
791 while (mode == NORMAL)
792 if ((ch = xlgetc(fptr)) == EOF)
793 mode = DONE;
794 else if ((type = tentry(ch)) == k_sescape) {
795 i = storech(buf,i,checkeof(fptr));
796 *pescflag = TRUE;
797 }
798 else if (type == k_mescape) {
799 *pescflag = TRUE;
800 mode = ESCAPE;
801 }
802 else if (type == k_const
803 || (consp(type) && car(type) == k_nmacro))
804 i = storech(buf,i,islower(ch) ? toupper(ch) : ch);
805 else
806 mode = DONE;
807
808 /* handle multiple escape mode */
809 while (mode == ESCAPE)
810 if ((ch = xlgetc(fptr)) == EOF)
811 badeof(fptr);
812 else if ((type = tentry(ch)) == k_sescape)
813 i = storech(buf,i,checkeof(fptr));
814 else if (type == k_mescape)
815 mode = NORMAL;
816 else
817 i = storech(buf,i,ch);
818 }
819 buf[i] = 0;
820
821 /* check for a zero length name */
822 if (i == 0)
823 xlerror("zero length name", s_unbound);
824
825 /* unget the last character and return it */
826 xlungetc(fptr,ch);
827 return (ch);
828 }
829
830 /* storech - store a character in the print name buffer */
storech(char * buf,int i,int ch)831 LOCAL int storech(char *buf, int i, int ch)
832 {
833 if (i < STRMAX)
834 buf[i++] = ch;
835 return (i);
836 }
837
838 /* tentry - get a readtable entry */
tentry(int ch)839 LVAL tentry(int ch)
840 {
841 LVAL rtable;
842 rtable = getvalue(s_rtable);
843 if (!vectorp(rtable) || ch < 0 || ch >= getsize(rtable))
844 return (NIL);
845 return (getelement(rtable,ch));
846 }
847
848 /* nextch - look at the next non-blank character */
nextch(LVAL fptr)849 LOCAL int nextch(LVAL fptr)
850 {
851 int ch;
852
853 /* return and save the next non-blank character */
854 while ((ch = xlgetc(fptr)) != EOF && isspace(ch))
855 ;
856 xlungetc(fptr,ch);
857 return (ch);
858 }
859
860 /* checkeof - get a character and check for end of file */
checkeof(LVAL fptr)861 LOCAL int checkeof(LVAL fptr)
862 {
863 int ch;
864
865 if ((ch = xlgetc(fptr)) == EOF)
866 badeof(fptr);
867 return (ch);
868 }
869
870 /* badeof - unexpected eof */
badeof(LVAL fptr)871 LOCAL void badeof(LVAL fptr)
872 {
873 xlgetc(fptr);
874 xlfail("unexpected EOF");
875 }
876
877 /* xlisnumber - check if this string is a number */
xlisnumber(char * str,LVAL * pval)878 int xlisnumber(char *str, LVAL *pval)
879 {
880 int dl,dr;
881 char *p;
882
883 /* initialize */
884 p = str; dl = dr = 0;
885
886 /* check for a sign */
887 if (*p == '+' || *p == '-')
888 p++;
889
890 /* check for a string of digits */
891 while (isdigit(*p)) {
892 p++;
893 dl++;
894 }
895 /* check for a decimal point */
896 if (*p == '.') {
897 p++;
898 while (isdigit(*p)) {
899 p++;
900 dr++;
901 }
902 }
903
904 /* check for an exponent */
905 if ((dl || dr) && *p == 'E') {
906 p++;
907
908 /* check for a sign */
909 if (*p == '+' || *p == '-')
910 p++;
911
912 /* check for a string of digits */
913 while (isdigit(*p)) {
914 p++;
915 dr++;
916 }
917 }
918
919 /* make sure there was at least one digit and this is the end */
920 if ((dl == 0 && dr == 0) || *p)
921 return (FALSE);
922
923 /* convert the string to an integer and return successfully */
924 if (pval) {
925 if (*str == '+') ++str;
926 if (str[strlen(str)-1] == '.') str[strlen(str)-1] = 0;
927 *pval = (dr ? cvflonum(atof(str)) : cvfixnum(ICNV(str)));
928 }
929 return (TRUE);
930 }
931
932 /* defmacro - define a read macro */
defmacro(int ch,LVAL type,int offset)933 void defmacro(int ch, LVAL type, int offset)
934 {
935 extern FUNDEF *funtab;
936 LVAL subr;
937 subr = cvsubr(funtab[offset].fd_subr,funtab[offset].fd_type,offset);
938 setelement(getvalue(s_rtable),ch,cons(type,subr));
939 }
940
941 /* callmacro - call a read macro */
callmacro(LVAL fptr,int ch)942 LVAL callmacro(LVAL fptr, int ch)
943 {
944 LVAL *newfp;
945
946 /* create the new call frame */
947 newfp = xlsp;
948 pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
949 pusharg(cdr(getelement(getvalue(s_rtable),ch)));
950 pusharg(cvfixnum((FIXTYPE)2));
951 pusharg(fptr);
952 pusharg(cvchar(ch));
953 xlfp = newfp;
954 return (xlapply(2));
955 }
956
957 /* upcase - translate a string to upper case */
upcase(char * str)958 LOCAL void upcase(char *str)
959 {
960 for (; *str != '\0'; ++str)
961 if (islower(*str))
962 *str = toupper(*str);
963 }
964
965 /* xlrinit - initialize the reader */
xlrinit(void)966 void xlrinit(void)
967 {
968 LVAL rtable;
969 char *p;
970 int ch;
971
972 /* create the read table */
973 rtable = newvector(256);
974 setvalue(s_rtable,rtable);
975
976 /* initialize the readtable */
977 for (p = WSPACE; (ch = *p++); )
978 setelement(rtable,ch,k_wspace);
979 for (p = CONST1; (ch = *p++); )
980 setelement(rtable,ch,k_const);
981 for (p = CONST2; (ch = *p++); )
982 setelement(rtable,ch,k_const);
983
984 /* setup the escape characters */
985 setelement(rtable,'\\',k_sescape);
986 setelement(rtable,'|', k_mescape);
987
988 /* install the read macros */
989 defmacro('#', k_nmacro,FT_RMHASH);
990 defmacro('\'',k_tmacro,FT_RMQUOTE);
991 defmacro('"', k_tmacro,FT_RMDQUOTE);
992 defmacro('`', k_tmacro,FT_RMBQUOTE);
993 defmacro(',', k_tmacro,FT_RMCOMMA);
994 defmacro('(', k_tmacro,FT_RMLPAR);
995 defmacro(')', k_tmacro,FT_RMRPAR);
996 defmacro(';', k_tmacro,FT_RMSEMI);
997 }
998
999