home *** CD-ROM | disk | FTP | other *** search
/ Club Amiga de Montreal - CAM / CAM_CD_1.iso / files / 254b.lha / AMXLISP_v2.0 / src / XLREAD.C < prev    next >
C/C++ Source or Header  |  1989-05-09  |  17KB  |  812 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();
  33. FORWARD LVAL 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.         rplaca(val,pvector(fptr));
  178.         break;
  179.     case 'b':
  180.     case 'B':
  181.         rplaca(val,pnumber(fptr,2));
  182.         break;
  183.     case 'o':
  184.     case 'O':
  185.         rplaca(val,pnumber(fptr,8));
  186.         break;
  187.     case 'x':
  188.     case 'X':
  189.             rplaca(val,pnumber(fptr,16));
  190.         break;
  191.     case '\\':
  192.         xlungetc(fptr,ch);
  193.         pname(fptr,&escflag);
  194.         ch = buf[0];
  195.         if (strlen(buf) > 1) {
  196.             upcase(buf);
  197.             if (strcmp(buf,"NEWLINE") == 0)
  198.             ch = '\n';
  199.             else if (strcmp(buf,"SPACE") == 0)
  200.             ch = ' ';
  201.             else
  202.             xlerror("unknown character name",cvstring(buf));
  203.         }
  204.         rplaca(val,cvchar(ch));
  205.         break;
  206.     case ':':
  207.             rplaca(val,punintern(fptr));
  208.         break;
  209.     case '|':
  210.             pcomment(fptr);
  211.         val = NIL;
  212.         break;
  213.     default:
  214.         xlerror("illegal character after #",cvfixnum((FIXTYPE)ch));
  215.     }
  216.  
  217.     /* restore the stack */
  218.     xlpop();
  219.  
  220.     /* return the value */
  221.     return (val);
  222. }
  223.  
  224. /* rmquote - read macro for '\'' */
  225. LVAL rmquote()
  226. {
  227.     LVAL fptr,mch;
  228.  
  229.     /* get the file and macro character */
  230.     fptr = xlgetfile();
  231.     mch = xlgachar();
  232.     xllastarg();
  233.  
  234.     /* parse the quoted expression */
  235.     return (consa(pquote(fptr,s_quote)));
  236. }
  237.  
  238. /* rmdquote - read macro for '"' */
  239. LVAL rmdquote()
  240. {
  241.     unsigned char buf[STRMAX+1],*p,*sptr;
  242.     LVAL fptr,str,newstr,mch;
  243.     int len,blen,ch,d2,d3;
  244.  
  245.     /* protect some pointers */
  246.     xlsave1(str);
  247.  
  248.     /* get the file and macro character */
  249.     fptr = xlgetfile();
  250.     mch = xlgachar();
  251.     xllastarg();
  252.  
  253.     /* loop looking for a closing quote */
  254.     len = blen = 0; p = buf;
  255.     while ((ch = checkeof(fptr)) != '"') {
  256.  
  257.     /* handle escaped characters */
  258.     switch (ch) {
  259.     case '\\':
  260.         switch (ch = checkeof(fptr)) {
  261.         case 't':
  262.             ch = '\011';
  263.             break;
  264.         case 'n':
  265.             ch = '\012';
  266.             break;
  267.         case 'f':
  268.             ch = '\014';
  269.             break;
  270.         case 'r':
  271.             ch = '\015';
  272.             break;
  273.         default:
  274.             if (ch >= '0' && ch <= '7') {
  275.                 d2 = checkeof(fptr);
  276.                 d3 = checkeof(fptr);
  277.                 if (d2 < '0' || d2 > '7'
  278.                  || d3 < '0' || d3 > '7')
  279.                 xlfail("invalid octal digit");
  280.                 ch -= '0'; d2 -= '0'; d3 -= '0';
  281.                 ch = (ch << 6) | (d2 << 3) | d3;
  282.             }
  283.             break;
  284.         }
  285.     }
  286.  
  287.     /* check for buffer overflow */
  288.     if (blen >= STRMAX) {
  289.          newstr = newstring(len + STRMAX + 1);
  290.         sptr = getstring(newstr); *sptr = '\0';
  291.         if (str) strcat(sptr,getstring(str));
  292.         *p = '\0'; strcat(sptr,buf);
  293.         p = buf; blen = 0;
  294.         len += STRMAX;
  295.         str = newstr;
  296.     }
  297.  
  298.     /* store the character */
  299.     *p++ = ch; ++blen;
  300.     }
  301.  
  302.     /* append the last substring */
  303.     if (str == NIL || blen) {
  304.     newstr = newstring(len + blen + 1);
  305.     sptr = getstring(newstr); *sptr = '\0';
  306.     if (str) strcat(sptr,getstring(str));
  307.     *p = '\0'; strcat(sptr,buf);
  308.     str = newstr;
  309.     }
  310.  
  311.     /* restore the stack */
  312.     xlpop();
  313.  
  314.     /* return the new string */
  315.     return (consa(str));
  316. }
  317.  
  318. /* rmbquote - read macro for '`' */
  319. LVAL rmbquote()
  320. {
  321.     LVAL fptr,mch;
  322.  
  323.     /* get the file and macro character */
  324.     fptr = xlgetfile();
  325.     mch = xlgachar();
  326.     xllastarg();
  327.  
  328.     /* parse the quoted expression */
  329.     return (consa(pquote(fptr,s_bquote)));
  330. }
  331.  
  332. /* rmcomma - read macro for ',' */
  333. LVAL rmcomma()
  334. {
  335.     LVAL fptr,mch,sym;
  336.     int ch;
  337.  
  338.     /* get the file and macro character */
  339.     fptr = xlgetfile();
  340.     mch = xlgachar();
  341.     xllastarg();
  342.  
  343.     /* check the next character */
  344.     if ((ch = xlgetc(fptr)) == '@')
  345.     sym = s_comat;
  346.     else {
  347.     xlungetc(fptr,ch);
  348.     sym = s_comma;
  349.     }
  350.  
  351.     /* make the return value */
  352.     return (consa(pquote(fptr,sym)));
  353. }
  354.  
  355. /* rmlpar - read macro for '(' */
  356. LVAL rmlpar()
  357. {
  358.     LVAL fptr,mch;
  359.  
  360.     /* get the file and macro character */
  361.     fptr = xlgetfile();
  362.     mch = xlgachar();
  363.     xllastarg();
  364.  
  365.     /* make the return value */
  366.     return (consa(plist(fptr)));
  367. }
  368.  
  369. /* rmrpar - read macro for ')' */
  370. LVAL rmrpar()
  371. {
  372.     xlfail("misplaced right paren");
  373. }
  374.  
  375. /* rmsemi - read macro for ';' */
  376. LVAL rmsemi()
  377. {
  378.     LVAL fptr,mch;
  379.     int ch;
  380.  
  381.     /* get the file and macro character */
  382.     fptr = xlgetfile();
  383.     mch = xlgachar();
  384.     xllastarg();
  385.  
  386.     /* skip to end of line */
  387.     while ((ch = xlgetc(fptr)) != EOF && ch != '\n')
  388.     ;
  389.  
  390.     /* return nil (nothing read) */
  391.     return (NIL);
  392. }
  393.  
  394. /* pcomment - parse a comment delimited by #| and |# */
  395. LOCAL pcomment(fptr)
  396.   LVAL fptr;
  397. {
  398.     int lastch,ch,n;
  399.  
  400.     /* look for the matching delimiter (and handle nesting) */
  401.     for (n = 1, lastch = -1; n > 0 && (ch = xlgetc(fptr)) != EOF; ) {
  402.     if (lastch == '|' && ch == '#')
  403.         { --n; ch = -1; }
  404.     else if (lastch == '#' && ch == '|')
  405.         { ++n; ch = -1; }
  406.     lastch = ch;
  407.     }
  408. }
  409.  
  410. /* pnumber - parse a number */
  411. LOCAL LVAL pnumber(fptr,radix)
  412.   LVAL fptr; int radix;
  413. {
  414.     int digit,ch;
  415.     long num;
  416.     
  417.     for (num = 0L; (ch = xlgetc(fptr)) != EOF; ) {
  418.     if (islower(ch)) ch = toupper(ch);
  419.     if (!('0' <= ch && ch <= '9') && !('A' <= ch && ch <= 'F'))
  420.         break;
  421.     if ((digit = (ch <= '9' ? ch - '0' : ch - 'A' + 10)) >= radix)
  422.         break;
  423.     num = num * (long)radix + (long)digit;
  424.     }
  425.     xlungetc(fptr,ch);
  426.     return (cvfixnum((FIXTYPE)num));
  427. }
  428.  
  429. /* plist - parse a list */
  430. LOCAL LVAL plist(fptr)
  431.   LVAL fptr;
  432. {
  433.     LVAL val,expr,lastnptr,nptr;
  434.  
  435.     /* protect some pointers */
  436.     xlstkcheck(2);
  437.     xlsave(val);
  438.     xlsave(expr);
  439.  
  440.     /* keep appending nodes until a closing paren is found */
  441.     for (lastnptr = NIL; nextch(fptr) != ')'; )
  442.  
  443.     /* get the next expression */
  444.     switch (readone(fptr,&expr)) {
  445.     case EOF:
  446.         badeof(fptr);
  447.     case TRUE:
  448.  
  449.         /* check for a dotted tail */
  450.         if (expr == s_dot) {
  451.  
  452.         /* make sure there's a node */
  453.         if (lastnptr == NIL)
  454.             xlfail("invalid dotted pair");
  455.  
  456.         /* parse the expression after the dot */
  457.         if (!xlread(fptr,&expr,TRUE))
  458.             badeof(fptr);
  459.         rplacd(lastnptr,expr);
  460.  
  461.         /* make sure its followed by a close paren */
  462.         if (nextch(fptr) != ')')
  463.             xlfail("invalid dotted pair");
  464.         }
  465.  
  466.         /* otherwise, handle a normal list element */
  467.         else {
  468.         nptr = consa(expr);
  469.         if (lastnptr == NIL)
  470.             val = nptr;
  471.         else
  472.             rplacd(lastnptr,nptr);
  473.         lastnptr = nptr;
  474.         }
  475.         break;
  476.     }
  477.  
  478.     /* skip the closing paren */
  479.     xlgetc(fptr);
  480.  
  481.     /* restore the stack */
  482.     xlpopn(2);
  483.  
  484.     /* return successfully */
  485.     return (val);
  486. }
  487.  
  488. /* pvector - parse a vector */
  489. LOCAL LVAL pvector(fptr)
  490.   LVAL fptr;
  491. {
  492.     LVAL list,expr,val,lastnptr,nptr;
  493.     int len,ch,i;
  494.  
  495.     /* protect some pointers */
  496.     xlstkcheck(2);
  497.     xlsave(list);
  498.     xlsave(expr);
  499.  
  500.     /* keep appending nodes until a closing paren is found */
  501.     for (lastnptr = NIL, len = 0; (ch = nextch(fptr)) != ')'; ) {
  502.  
  503.     /* check for end of file */
  504.     if (ch == EOF)
  505.         badeof(fptr);
  506.  
  507.     /* get the next expression */
  508.     switch (readone(fptr,&expr)) {
  509.     case EOF:
  510.         badeof(fptr);
  511.     case TRUE:
  512.         nptr = consa(expr);
  513.         if (lastnptr == NIL)
  514.         list = nptr;
  515.         else
  516.         rplacd(lastnptr,nptr);
  517.         lastnptr = nptr;
  518.         len++;
  519.         break;
  520.     }
  521.     }
  522.  
  523.     /* skip the closing paren */
  524.     xlgetc(fptr);
  525.  
  526.     /* make a vector of the appropriate length */
  527.     val = newvector(len);
  528.  
  529.     /* copy the list into the vector */
  530.     for (i = 0; i < len; ++i, list = cdr(list))
  531.     setelement(val,i,car(list));
  532.  
  533.     /* restore the stack */
  534.     xlpopn(2);
  535.  
  536.     /* return successfully */
  537.     return (val);
  538. }
  539.  
  540. /* pquote - parse a quoted expression */
  541. LOCAL LVAL pquote(fptr,sym)
  542.   LVAL fptr,sym;
  543. {
  544.     LVAL val,p;
  545.  
  546.     /* protect some pointers */
  547.     xlsave1(val);
  548.  
  549.     /* allocate two nodes */
  550.     val = consa(sym);
  551.     rplacd(val,consa(NIL));
  552.  
  553.     /* initialize the second to point to the quoted expression */
  554.     if (!xlread(fptr,&p,TRUE))
  555.     badeof(fptr);
  556.     rplaca(cdr(val),p);
  557.  
  558.     /* restore the stack */
  559.     xlpop();
  560.  
  561.     /* return the quoted expression */
  562.     return (val);
  563. }
  564.  
  565. /* psymbol - parse a symbol name */
  566. LOCAL LVAL psymbol(fptr)
  567.   LVAL fptr;
  568. {
  569.     int escflag;
  570.     LVAL val;
  571.     pname(fptr,&escflag);
  572.     return (escflag || !isnumber(buf,&val) ? xlenter(buf) : val);
  573. }
  574.  
  575. /* punintern - parse an uninterned symbol */
  576. LOCAL LVAL punintern(fptr)
  577.   LVAL fptr;
  578. {
  579.     int escflag;
  580.     pname(fptr,&escflag);
  581.     return (xlmakesym(buf));
  582. }
  583.  
  584. /* pname - parse a symbol/package name */
  585. LOCAL int pname(fptr,pescflag)
  586.   LVAL fptr; int *pescflag;
  587. {
  588.     int mode,ch,i;
  589.     LVAL type;
  590.  
  591.     /* initialize */
  592.     *pescflag = FALSE;
  593.     mode = NORMAL;
  594.     i = 0;
  595.  
  596.     /* accumulate the symbol name */
  597.     while (mode != DONE) {
  598.  
  599.     /* handle normal mode */
  600.     while (mode == NORMAL)
  601.         if ((ch = xlgetc(fptr)) == EOF)
  602.         mode = DONE;
  603.         else if ((type = tentry(ch)) == k_sescape) {
  604.         i = storech(buf,i,checkeof(fptr));
  605.         *pescflag = TRUE;
  606.         }
  607.         else if (type == k_mescape) {
  608.         *pescflag = TRUE;
  609.         mode = ESCAPE;
  610.         }
  611.         else if (type == k_const
  612.          ||  (consp(type) && car(type) == k_nmacro))
  613.         i = storech(buf,i,islower(ch) ? toupper(ch) : ch);
  614.         else
  615.         mode = DONE;
  616.  
  617.     /* handle multiple escape mode */
  618.     while (mode == ESCAPE)
  619.         if ((ch = xlgetc(fptr)) == EOF)
  620.         badeof(fptr);
  621.         else if ((type = tentry(ch)) == k_sescape)
  622.         i = storech(buf,i,checkeof(fptr));
  623.         else if (type == k_mescape)
  624.         mode = NORMAL;
  625.         else
  626.         i = storech(buf,i,ch);
  627.     }
  628.     buf[i] = 0;
  629.  
  630.     /* check for a zero length name */
  631.     if (i == 0)
  632.     xlerror("zero length name");
  633.  
  634.     /* unget the last character and return it */
  635.     xlungetc(fptr,ch);
  636.     return (ch);
  637. }
  638.  
  639. /* storech - store a character in the print name buffer */
  640. LOCAL int storech(buf,i,ch)
  641.   char *buf; int i,ch;
  642. {
  643.     if (i < STRMAX)
  644.     buf[i++] = ch;
  645.     return (i);
  646. }
  647.  
  648. /* tentry - get a readtable entry */
  649. LVAL tentry(ch)
  650.   int ch;
  651. {
  652.     LVAL rtable;
  653.     rtable = getvalue(s_rtable);
  654.     if (!vectorp(rtable) || ch < 0 || ch >= getsize(rtable))
  655.     return (NIL);
  656.     return (getelement(rtable,ch));
  657. }
  658.  
  659. /* nextch - look at the next non-blank character */
  660. LOCAL int nextch(fptr)
  661.   LVAL fptr;
  662. {
  663.     int ch;
  664.  
  665.     /* return and save the next non-blank character */
  666.     while ((ch = xlgetc(fptr)) != EOF && isspace(ch))
  667.     ;
  668.     xlungetc(fptr,ch);
  669.     return (ch);
  670. }
  671.  
  672. /* checkeof - get a character and check for end of file */
  673. LOCAL int checkeof(fptr)
  674.   LVAL fptr;
  675. {
  676.     int ch;
  677.  
  678.     if ((ch = xlgetc(fptr)) == EOF)
  679.     badeof(fptr);
  680.     return (ch);
  681. }
  682.  
  683. /* badeof - unexpected eof */
  684. LOCAL badeof(fptr)
  685.   LVAL fptr;
  686. {
  687.     xlgetc(fptr);
  688.     xlfail("unexpected EOF");
  689. }
  690.  
  691. /* isnumber - check if this string is a number */
  692. int isnumber(str,pval)
  693.   char *str; LVAL *pval;
  694. {
  695.     int dl,dr;
  696.     char *p;
  697.  
  698.     /* initialize */
  699.     p = str; dl = dr = 0;
  700.  
  701.     /* check for a sign */
  702.     if (*p == '+' || *p == '-')
  703.     p++;
  704.  
  705.     /* check for a string of digits */
  706.     while (isdigit(*p))
  707.     p++, dl++;
  708.  
  709.     /* check for a decimal point */
  710.     if (*p == '.') {
  711.     p++;
  712.     while (isdigit(*p))
  713.         p++, dr++;
  714.     }
  715.  
  716.     /* check for an exponent */
  717.     if ((dl || dr) && *p == 'E') {
  718.     p++;
  719.  
  720.     /* check for a sign */
  721.     if (*p == '+' || *p == '-')
  722.         p++;
  723.  
  724.     /* check for a string of digits */
  725.     while (isdigit(*p))
  726.         p++, dr++;
  727.     }
  728.  
  729.     /* make sure there was at least one digit and this is the end */
  730.     if ((dl == 0 && dr == 0) || *p)
  731.     return (FALSE);
  732.  
  733.     /* convert the string to an integer and return successfully */
  734.     if (pval) {
  735.     if (*str == '+') ++str;
  736.     if (str[strlen(str)-1] == '.') str[strlen(str)-1] = 0;
  737.     *pval = (dr ? cvflonum(atof(str)) : cvfixnum(ICNV(str)));
  738.     }
  739.     return (TRUE);
  740. }
  741.  
  742. /* defmacro - define a read macro */
  743. defmacro(ch,type,offset)
  744.   int ch; LVAL type; int offset;
  745. {
  746.     extern FUNDEF funtab[];
  747.     LVAL subr;
  748.     subr = cvsubr(funtab[offset].fd_subr,funtab[offset].fd_type,offset);
  749.     setelement(getvalue(s_rtable),ch,cons(type,subr));
  750. }
  751.  
  752. /* callmacro - call a read macro */
  753. LVAL callmacro(fptr,ch)
  754.   LVAL fptr; int ch;
  755. {
  756.     LVAL *newfp;
  757.  
  758.     /* create the new call frame */
  759.     newfp = xlsp;
  760.     pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
  761.     pusharg(cdr(getelement(getvalue(s_rtable),ch)));
  762.     pusharg(cvfixnum((FIXTYPE)2));
  763.     pusharg(fptr);
  764.     pusharg(cvchar(ch));
  765.     xlfp = newfp;
  766.     return (xlapply(2));
  767. }
  768.  
  769. /* upcase - translate a string to upper case */
  770. LOCAL upcase(str)
  771.   unsigned char *str;
  772. {
  773.     for (; *str != '\0'; ++str)
  774.     if (islower(*str))
  775.         *str = toupper(*str);
  776. }
  777.  
  778. /* xlrinit - initialize the reader */
  779. xlrinit()
  780. {
  781.     LVAL rtable;
  782.     char *p;
  783.     int ch;
  784.  
  785.     /* create the read table */
  786.     rtable = newvector(256);
  787.     setvalue(s_rtable,rtable);
  788.  
  789.     /* initialize the readtable */
  790.     for (p = WSPACE; ch = *p++; )
  791.     setelement(rtable,ch,k_wspace);
  792.     for (p = CONST1; ch = *p++; )
  793.     setelement(rtable,ch,k_const);
  794.     for (p = CONST2; ch = *p++; )
  795.     setelement(rtable,ch,k_const);
  796.  
  797.     /* setup the escape characters */
  798.     setelement(rtable,'\\',k_sescape);
  799.     setelement(rtable,'|', k_mescape);
  800.  
  801.     /* install the read macros */
  802.     defmacro('#', k_nmacro,FT_RMHASH);
  803.     defmacro('\'',k_tmacro,FT_RMQUOTE);
  804.     defmacro('"', k_tmacro,FT_RMDQUOTE);
  805.     defmacro('`', k_tmacro,FT_RMBQUOTE);
  806.     defmacro(',', k_tmacro,FT_RMCOMMA);
  807.     defmacro('(', k_tmacro,FT_RMLPAR);
  808.     defmacro(')', k_tmacro,FT_RMRPAR);
  809.     defmacro(';', k_tmacro,FT_RMSEMI);
  810. }
  811.  
  812.