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