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