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