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