home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / XSCHEME2.ZIP / xsread.c < prev    next >
C/C++ Source or Header  |  1990-01-08  |  9KB  |  426 lines
  1. /* xsread.c - xscheme input routines */
  2. /*    Copyright (c) 1988, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #include "xscheme.h"
  7.  
  8. /* external variables */
  9. extern LVAL true;
  10.  
  11. /* external routines */
  12. extern double atof();
  13. extern ITYPE;
  14.  
  15. /* forward declarations */
  16. LVAL read_list(),read_quote(),read_comma(),read_symbol();
  17. LVAL read_radix(),read_string(),read_special();
  18.  
  19. /* xlread - read an expression */
  20. int xlread(fptr,pval)
  21.   LVAL fptr,*pval;
  22. {
  23.     int ch;
  24.  
  25.     /* check the next non-blank character */
  26.     while ((ch = scan(fptr)) != EOF)
  27.     switch (ch) {
  28.     case '(':
  29.         *pval = read_list(fptr);
  30.         return (TRUE);
  31.     case ')':
  32.         xlfail("misplaced right paren");
  33.     case '\'':
  34.         *pval = read_quote(fptr,"QUOTE");
  35.         return (TRUE);
  36.     case '`':
  37.         *pval = read_quote(fptr,"QUASIQUOTE");
  38.         return (TRUE);
  39.     case ',':
  40.         *pval = read_comma(fptr);
  41.         return (TRUE);
  42.     case '"':
  43.         *pval = read_string(fptr);
  44.         return (TRUE);
  45.     case '#':
  46.         *pval = read_special(fptr);
  47.         return (TRUE);
  48.     case ';':
  49.             read_comment(fptr);
  50.             break;
  51.     default:
  52.         xlungetc(fptr,ch);
  53.         *pval = read_symbol(fptr);
  54.         return (TRUE);
  55.     }
  56.     return (FALSE);
  57. }
  58.  
  59. /* read_list - read a list */
  60. LOCAL LVAL read_list(fptr)
  61.   LVAL fptr;
  62. {
  63.     LVAL last,val;
  64.     int ch;
  65.  
  66.     cpush(NIL); last = NIL;
  67.     while ((ch = scan(fptr)) != EOF)
  68.     switch (ch) {
  69.     case ';':
  70.         read_comment(fptr);
  71.         break;
  72.     case ')':
  73.         return (pop());
  74.     default:
  75.         xlungetc(fptr,ch);
  76.         if (!xlread(fptr,&val))
  77.         xlfail("unexpected EOF");
  78.         if (val == xlenter(".")) {
  79.         if (last == NIL)
  80.             xlfail("misplaced dot");
  81.         read_cdr(fptr,last);
  82.         return (pop());
  83.         }
  84.         else {
  85.         val = cons(val,NIL);
  86.         if (last) rplacd(last,val);
  87.         else settop(val);
  88.         last = val;
  89.         }
  90.         break;
  91.     }
  92.     xlfail("unexpected EOF");
  93. }
  94.  
  95. /* read_cdr - read the cdr of a dotted pair */
  96. LOCAL read_cdr(fptr,last)
  97.   LVAL fptr,last;
  98. {
  99.     LVAL val;
  100.     int ch;
  101.  
  102.     /* read the cdr expression */
  103.     if (!xlread(fptr,&val))
  104.     xlfail("unexpected EOF");
  105.     rplacd(last,val);
  106.  
  107.     /* check for the close paren */
  108.     while ((ch = scan(fptr)) == ';')
  109.     read_comment(fptr);
  110.     if (ch != ')')
  111.     xlfail("missing right paren");
  112. }
  113.  
  114. /* read_comment - read a comment (to end of line) */
  115. LOCAL read_comment(fptr)
  116.   LVAL fptr;
  117. {
  118.     int ch;
  119.     while ((ch = xlgetc(fptr)) != EOF && ch != '\n')
  120.     ;
  121.     if (ch != EOF) xlungetc(fptr,ch);
  122. }
  123.  
  124. /* read_vector - read a vector */
  125. LOCAL LVAL read_vector(fptr)
  126.   LVAL fptr;
  127. {
  128.     int len=0,ch,i;
  129.     LVAL last,val;
  130.  
  131.     cpush(NIL); last = NIL;
  132.     while ((ch = scan(fptr)) != EOF)
  133.     switch (ch) {
  134.     case ';':
  135.         read_comment(fptr);
  136.         break;
  137.     case ')':
  138.         val = newvector(len);
  139.         for (last = pop(), i = 0; i < len; ++i, last = cdr(last))
  140.         setelement(val,i,car(last));
  141.         return (val);
  142.     default:
  143.         xlungetc(fptr,ch);
  144.         if (!xlread(fptr,&val))
  145.         xlfail("unexpected EOF");
  146.         val = cons(val,NIL);
  147.         if (last) rplacd(last,val);
  148.         else settop(val);
  149.         last = val;
  150.         ++len;
  151.         break;
  152.     }
  153.     xlfail("unexpected EOF");
  154. }
  155.  
  156. /* read_comma - read a unquote or unquote-splicing expression */
  157. LOCAL LVAL read_comma(fptr)
  158.   LVAL fptr;
  159. {
  160.     int ch;
  161.     if ((ch = xlgetc(fptr)) == '@')
  162.     return (read_quote(fptr,"UNQUOTE-SPLICING"));
  163.     else {
  164.     xlungetc(fptr,ch);
  165.     return (read_quote(fptr,"UNQUOTE"));
  166.     }
  167. }
  168.  
  169. /* read_quote - parse the tail of a quoted expression */
  170. LOCAL LVAL read_quote(fptr,sym)
  171.   LVAL fptr; char *sym;
  172. {
  173.     LVAL val;
  174.     if (!xlread(fptr,&val))
  175.     xlfail("unexpected EOF");
  176.     cpush(cons(val,NIL));
  177.     settop(cons(xlenter(sym),top()));
  178.     return (pop());
  179. }
  180.  
  181. /* read_symbol - parse a symbol name (or a number) */
  182. LOCAL LVAL read_symbol(fptr)
  183.   LVAL fptr;
  184. {
  185.     char buf[STRMAX+1];
  186.     LVAL val;
  187.     if (!getsymbol(fptr,buf))
  188.     xlfail("expecting symbol name");
  189.     return (isnumber(buf,&val) ? val : xlenter(buf));
  190. }
  191.  
  192. /* read_string - parse a string */
  193. LOCAL LVAL read_string(fptr)
  194.   LVAL fptr;
  195. {
  196.     char buf[STRMAX+1];
  197.     int ch,i;
  198.  
  199.     /* get symbol name */
  200.     for (i = 0; (ch = checkeof(fptr)) != '"'; ) {
  201.     if (ch == '\\')
  202.         ch = checkeof(fptr);
  203.     if (i < STRMAX)
  204.         buf[i++] = ch;
  205.     }
  206.     buf[i] = '\0';
  207.  
  208.     /* return a string */
  209.     return (cvstring(buf));
  210. }
  211.  
  212. /* read_special - parse an atom starting with '#' */
  213. LOCAL LVAL read_special(fptr)
  214.   LVAL fptr;
  215. {
  216.     char buf[STRMAX+1],buf2[STRMAX+3];
  217.     int ch;
  218.     switch (ch = checkeof(fptr)) {
  219.     case '!':
  220.     if (getsymbol(fptr,buf)) {
  221.         if (strcmp(buf,"TRUE") == 0)
  222.         return (true);
  223.         else if (strcmp(buf,"FALSE") == 0)
  224.         return (NIL);
  225.         else if (strcmp(buf,"NULL") == 0)
  226.         return (NIL);
  227.         else {
  228.         sprintf(buf2,"#!%s",buf);
  229.         return (xlenter(buf2));
  230.         }
  231.     }
  232.     else
  233.         xlfail("expecting symbol after '#!'");
  234.     break;
  235.     case '\\':
  236.     ch = checkeof(fptr);    /* get the next character */
  237.     xlungetc(fptr,ch);    /* but allow getsymbol to get it also */
  238.     if (getsymbol(fptr,buf)) {
  239.         if (strcmp(buf,"NEWLINE") == 0)
  240.         ch = '\n';
  241.         else if (strcmp(buf,"SPACE") == 0)
  242.         ch = ' ';
  243.         else if (strlen(buf) > 1)
  244.         xlerror("unexpected symbol after '#\\'",cvstring(buf));
  245.     }
  246.     else            /* wasn't a symbol, get the character */
  247.         ch = checkeof(fptr);
  248.     return (cvchar(ch));
  249.     case '(':
  250.     return (read_vector(fptr));
  251.     case 'b':
  252.     case 'B':
  253.     return (read_radix(fptr,2));
  254.     case 'o':
  255.     case 'O':
  256.     return (read_radix(fptr,8));
  257.     case 'd':
  258.     case 'D':
  259.     return (read_radix(fptr,10));
  260.     case 'x':
  261.     case 'X':
  262.         return (read_radix(fptr,16));
  263.     default:
  264.     xlungetc(fptr,ch);
  265.     if (getsymbol(fptr,buf)) {
  266.         if (strcmp(buf,"T") == 0)
  267.         return (true);
  268.         else if (strcmp(buf,"F") == 0)
  269.         return (NIL);
  270.         else
  271.         xlerror("unexpected symbol after '#'",cvstring(buf));
  272.     }
  273.     else
  274.         xlerror("unexpected character after '#'",cvchar(xlgetc(fptr)));
  275.     break;
  276.     }
  277. }
  278.  
  279. /* read_radix - read a number in a specified radix */
  280. LOCAL LVAL read_radix(fptr,radix)
  281.   LVAL fptr; int radix;
  282. {
  283.     FIXTYPE val;
  284.     int ch;
  285.  
  286.     /* get symbol name */
  287.     for (val = (FIXTYPE)0; (ch = xlgetc(fptr)) != EOF && issym(ch); ) {
  288.         if (islower(ch)) ch = toupper(ch);
  289.     if (!isradixdigit(ch,radix))
  290.         xlerror("invalid digit",cvchar(ch));
  291.         val = val * radix + getdigit(ch);
  292.     }
  293.  
  294.     /* save the break character */
  295.     xlungetc(fptr,ch);
  296.  
  297.     /* return the number */
  298.     return (cvfixnum(val));
  299. }
  300.  
  301. /* isradixdigit - check to see if a character is a digit in a radix */
  302. LOCAL int isradixdigit(ch,radix)
  303.   int ch,radix;
  304. {
  305.     switch (radix) {
  306.     case 2:    return (ch >= '0' && ch <= '1');
  307.     case 8:    return (ch >= '0' && ch <= '7');
  308.     case 10:    return (ch >= '0' && ch <= '9');
  309.     case 16:    return ((ch >= '0' && ch <= '9')
  310.                      || (ch >= 'A' && ch <= 'F'));
  311.     }
  312. }
  313.  
  314. /* getdigit - convert an ascii code to a digit */
  315. LOCAL int getdigit(ch)
  316.   int ch;
  317. {
  318.     return (ch <= '9' ? ch - '0' : ch - 'A' + 10);
  319. }
  320.  
  321. /* getsymbol - get a symbol name */
  322. LOCAL int getsymbol(fptr,buf)
  323.   LVAL fptr; char *buf;
  324. {
  325.     int ch,i;
  326.  
  327.     /* get symbol name */
  328.     for (i = 0; (ch = xlgetc(fptr)) != EOF && issym(ch); )
  329.     if (i < STRMAX)
  330.         buf[i++] = (islower(ch) ? toupper(ch) : ch);
  331.     buf[i] = '\0';
  332.  
  333.     /* save the break character */
  334.     xlungetc(fptr,ch);
  335.     return (buf[0] != '\0');
  336. }
  337.  
  338. /* isnumber - check if this string is a number */
  339. LOCAL int isnumber(str,pval)
  340.   char *str; LVAL *pval;
  341. {
  342.     int dl,dot,dr;
  343.     char *p;
  344.  
  345.     /* initialize */
  346.     p = str; dl = dot = dr = 0;
  347.  
  348.     /* check for a sign */
  349.     if (*p == '+' || *p == '-')
  350.     p++;
  351.  
  352.     /* check for a string of digits */
  353.     while (isdigit(*p))
  354.     p++, dl++;
  355.  
  356.     /* check for a decimal point */
  357.     if (*p == '.') {
  358.     p++; dot = 1;
  359.     while (isdigit(*p))
  360.         p++, dr++;
  361.     }
  362.  
  363.     /* check for an exponent */
  364.     if ((dl || dr) && *p == 'E') {
  365.     p++; dot = 1;
  366.  
  367.     /* check for a sign */
  368.     if (*p == '+' || *p == '-')
  369.         p++;
  370.  
  371.     /* check for a string of digits */
  372.     while (isdigit(*p))
  373.         p++, dr++;
  374.     }
  375.  
  376.     /* make sure there was at least one digit and this is the end */
  377.     if ((dl == 0 && dr == 0) || *p)
  378.     return (FALSE);
  379.  
  380.     /* convert the string to an integer and return successfully */
  381.     if (pval) {
  382.     if (*str == '+') ++str;
  383.     if (str[strlen(str)-1] == '.') str[strlen(str)-1] = 0;
  384.     *pval = (dot ? cvflonum(atof(str)) : cvfixnum(ICNV(str)));
  385.     }
  386.     return (TRUE);
  387. }
  388.  
  389. /* scan - scan for the first non-blank character */
  390. LOCAL int scan(fptr)
  391.   LVAL fptr;
  392. {
  393.     int ch;
  394.  
  395.     /* look for a non-blank character */
  396.     while ((ch = xlgetc(fptr)) != EOF && isspace(ch))
  397.     ;
  398.  
  399.     /* return the character */
  400.     return (ch);
  401. }
  402.  
  403. /* checkeof - get a character and check for end of file */
  404. LOCAL int checkeof(fptr)
  405.   LVAL fptr;
  406. {
  407.     int ch;
  408.     if ((ch = xlgetc(fptr)) == EOF)
  409.     xlfail("unexpected EOF");
  410.     return (ch);
  411. }
  412.  
  413. /* issym - is this a symbol character? */
  414. LOCAL int issym(ch)
  415.   int ch;
  416. {
  417.     register char *p;
  418.     if (!isspace(ch)) {
  419.     for (p = "()';"; *p != '\0'; )
  420.         if (*p++ == ch)
  421.         return (FALSE);
  422.     return (TRUE);
  423.     }
  424.     return (FALSE);
  425. }
  426.