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