home *** CD-ROM | disk | FTP | other *** search
/ ftp.barnyard.co.uk / 2015.02.ftp.barnyard.co.uk.tar / ftp.barnyard.co.uk / cpm / walnut-creek-CDROM / CPM / LANGUAGS / XLISP / XLISP11.ARK / XLREAD.C < prev    next >
Text File  |  1986-10-12  |  8KB  |  372 lines
  1. /* xlread - xlisp expression input routine */
  2.  
  3. #ifdef AZTEC
  4. #include "a:stdio.h"
  5. #else
  6. #include <stdio.h>
  7. #include <ctype.h>
  8. #endif
  9.  
  10. #include "xlisp.h"
  11.  
  12. /* global variables */
  13. struct node *oblist;
  14.  
  15. /* external variables */
  16. extern struct node *xlstack;
  17. extern int (*xlgetc)();
  18. extern int xlplevel;
  19.  
  20. /* local variables */
  21. static int savech;
  22.  
  23. /* forward declarations (the extern hack is for decusc) */
  24. extern struct node *parse();
  25. extern struct node *plist();
  26. extern struct node *pstring();
  27. extern struct node *pnumber();
  28. extern struct node *pquote();
  29. extern struct node *pname();
  30.  
  31. /* xlread - read an xlisp expression */
  32. struct node *xlread()
  33. {
  34.     /* initialize */
  35.     savech = -1;
  36.     xlplevel = 0;
  37.  
  38.     /* parse an expression */
  39.     return (parse());
  40. }
  41.  
  42. /* parse - parse an xlisp expression */
  43. static struct node *parse()
  44. {
  45.     int ch;
  46.  
  47.     /* keep looking for a node skipping comments */
  48.     while (TRUE)
  49.  
  50.     /* check next character for type of node */
  51.     switch (ch = nextch()) {
  52.     case '\'':            /* a quoted expression */
  53.         return (pquote());
  54.     case '(':            /* a sublist */
  55.         return (plist());
  56.     case ')':            /* closing paren - shouldn't happen */
  57.         xlfail("extra right paren");
  58.     case '.':            /* dot - shouldn't happen */
  59.         xlfail("misplaced dot");
  60.     case ';':            /* a comment */
  61.         pcomment();
  62.         break;
  63.     case '"':            /* a string */
  64.         return (pstring());
  65.     default:
  66.         if (isdigit(ch))    /* a number */
  67.             return (pnumber(1));
  68.         else if (issym(ch))    /* a name */
  69.             return (pname());
  70.         else
  71.             xlfail("invalid character");
  72.     }
  73. }
  74.  
  75. /* pcomment - parse a comment */
  76. static pcomment()
  77. {
  78.     /* skip to end of line */
  79.     while (getch() != '\n')
  80.     ;
  81. }
  82.  
  83. /* plist - parse a list */
  84. static struct node *plist()
  85. {
  86.     struct node *oldstk,val,*lastnptr,*nptr;
  87.     int ch;
  88.  
  89.     /* increment the nesting level */
  90.     xlplevel += 1;
  91.  
  92.     /* create a new stack frame */
  93.     oldstk = xlsave(&val,NULL);
  94.  
  95.     /* skip the opening paren */
  96.     savech = -1;
  97.  
  98.     /* keep appending nodes until a closing paren is found */
  99.     for (lastnptr = NULL; (ch = nextch()) > 0 && ch != ')'; lastnptr = nptr) {
  100.  
  101.     /* check for a dotted pair */
  102.     if (ch == '.') {
  103.  
  104.         /* skip the dot */
  105.         savech = -1;
  106.  
  107.         /* make sure there's a node */
  108.         if (lastnptr == NULL)
  109.         xlfail("invalid dotted pair");
  110.  
  111.         /* parse the expression after the dot */
  112.         lastnptr->n_listnext = parse();
  113.  
  114.         /* make sure its followed by a close paren */
  115.         if (nextch() != ')')
  116.         xlfail("invalid dotted pair");
  117.  
  118.         /* done with this list */
  119.         break;
  120.     }
  121.  
  122.     /* allocate a new node and link it into the list */
  123.     nptr = newnode(LIST);
  124.     if (lastnptr == NULL)
  125.         val.n_ptr = nptr;
  126.     else
  127.         lastnptr->n_listnext = nptr;
  128.  
  129.     /* initialize the new node */
  130.     nptr->n_listvalue = parse();
  131.     }
  132.  
  133.     /* skip the closing paren */
  134.     savech = -1;
  135.  
  136.     /* restore the previous stack frame */
  137.     xlstack = oldstk;
  138.  
  139.     /* decrement the nesting level */
  140.     xlplevel -= 1;
  141.  
  142.     /* return successfully */
  143.     return (val.n_ptr);
  144. }
  145.  
  146. /* pstring - parse a string */
  147. static struct node *pstring()
  148. {
  149.     struct node *oldstk,val;
  150.     char sbuf[STRMAX+1];
  151.     int ch,i,d1,d2,d3;
  152.  
  153.     /* create a new stack frame */
  154.     oldstk = xlsave(&val,NULL);
  155.  
  156.     /* skip the opening quote */
  157.     savech = -1;
  158.  
  159.     /* loop looking for a closing quote */
  160.     for (i = 0; i < STRMAX && (ch = getch()) != '"'; i++) {
  161.     switch (ch) {
  162.     case '\\':
  163.         switch (ch = getch()) {
  164.         case 'e':
  165.             ch = '\033';
  166.             break;
  167.         case 'n':
  168.             ch = '\n';
  169.             break;
  170.         case 'r':
  171.             ch = '\r';
  172.             break;
  173.         case 't':
  174.             ch = '\t';
  175.             break;
  176.         default:
  177.             if (ch >= '0' && ch <= '7') {
  178.                 d1 = ch - '0';
  179.                 d2 = getch() - '0';
  180.                 d3 = getch() - '0';
  181.                 ch = (d1 << 6) + (d2 << 3) + d3;
  182.             }
  183.             break;
  184.         }
  185.     }
  186.     sbuf[i] = ch;
  187.     }
  188.     sbuf[i] = 0;
  189.  
  190.     /* initialize the node */
  191.     val.n_ptr = newnode(STR);
  192.     val.n_ptr->n_str = strsave(sbuf);
  193.  
  194.     /* restore the previous stack frame */
  195.     xlstack = oldstk;
  196.  
  197.     /* return the new string */
  198.     return (val.n_ptr);
  199. }
  200.  
  201. /* pnumber - parse a number */
  202. static struct node *pnumber(sign)
  203.   int sign;
  204. {
  205.     struct node *val;
  206.     int ch,ival;
  207.  
  208.     /* loop looking for digits */
  209.     for (ival = 0; isdigit(ch = thisch()); savech = -1)
  210.     ival = ival * 10 + ch - '0';
  211.  
  212.     /* make sure the number terminated correctly */
  213.     if (issym(ch))
  214.     xlfail("badly formed number");
  215.  
  216.     /* initialize the node */
  217.     val = newnode(INT);
  218.     val->n_int = sign * ival;
  219.  
  220.     /* return the new number */
  221.     return (val);
  222. }
  223.  
  224. /* xlenter - enter a symbol into the symbol table */
  225. struct node *xlenter(sname)
  226.   char *sname;
  227. {
  228.     struct node *sptr;
  229.  
  230.     /* check for nil */
  231.     if (strcmp(sname,"nil") == 0)
  232.     return (NULL);
  233.  
  234.     /* check for the oblist being undefined */
  235.     if (oblist == NULL) {
  236.     oblist = newnode(SYM);
  237.     oblist->n_symname = strsave("oblist");
  238.     oblist->n_symvalue = newnode(LIST);
  239.     oblist->n_symvalue->n_listvalue = oblist;
  240.     }
  241.  
  242.     /* check for symbol already in table */
  243.     for (sptr = oblist->n_symvalue; sptr != NULL; sptr = sptr->n_listnext)
  244.     if (sptr->n_listvalue == NULL)
  245.         printf("bad oblist\n");
  246.     else if (sptr->n_listvalue->n_symname == NULL)
  247.         printf("bad oblist symbol\n");
  248.     else
  249.     if (strcmp(sptr->n_listvalue->n_symname,sname) == 0)
  250.         return (sptr->n_listvalue);
  251.  
  252.     /* enter a new symbol and link it into the symbol list */
  253.     sptr = newnode(LIST);
  254.     sptr->n_listnext = oblist->n_symvalue;
  255.     oblist->n_symvalue = sptr;
  256.     sptr->n_listvalue = newnode(SYM);
  257.     sptr->n_listvalue->n_symname = strsave(sname);
  258.  
  259.     /* return the new symbol */
  260.     return (sptr->n_listvalue);
  261. }
  262.  
  263. /* pquote - parse a quoted expression */
  264. static struct node *pquote()
  265. {
  266.     struct node *oldstk,val;
  267.  
  268.     /* create a new stack frame */
  269.     oldstk = xlsave(&val,NULL);
  270.  
  271.     /* skip the quote character */
  272.     savech = -1;
  273.  
  274.     /* allocate two nodes */
  275.     val.n_ptr = newnode(LIST);
  276.     val.n_ptr->n_listvalue = xlenter("quote");
  277.     val.n_ptr->n_listnext = newnode(LIST);
  278.  
  279.     /* initialize the second to point to the quoted expression */
  280.     val.n_ptr->n_listnext->n_listvalue = parse();
  281.  
  282.     /* restore the previous stack frame */
  283.     xlstack = oldstk;
  284.  
  285.     /* return the quoted expression */
  286.     return (val.n_ptr);
  287. }
  288.  
  289. /* pname - parse a symbol name */
  290. static struct node *pname()
  291. {
  292.     char sname[STRMAX+1];
  293.     int ch,i;
  294.  
  295.     /* get the first character */
  296.     ch = sname[0] = getch();
  297.  
  298.     /* check for signed number */
  299.     if (ch == '+' || ch == '-') {
  300.     if (isdigit(thisch()))
  301.         return (pnumber(ch == '+' ? 1 : -1));
  302.     }
  303.  
  304.     /* get symbol name */
  305.     for (i = 1; i < STRMAX && issym(thisch()); i++)
  306.     sname[i] = getch();
  307.     sname[i] = 0;
  308.  
  309.     /* initialize value */
  310.     return (xlenter(sname));
  311. }
  312.  
  313. /* nextch - look at the next non-blank character */
  314. static int nextch()
  315. {
  316.     /* look for a non-blank character */
  317.     while (isspace(thisch()))
  318.     savech = -1;
  319.  
  320.     /* return the character */
  321.     return (thisch());
  322. }
  323.  
  324. /* thisch - look at the current character */
  325. static int thisch()
  326. {
  327.     /* return and save the current character */
  328.     return (savech = getch());
  329. }
  330.  
  331. /* getch - get the next character */
  332. static int getch()
  333. {
  334.     int ch;
  335.  
  336.     /* check for a saved character */
  337.     if ((ch = savech) >= 0)
  338.     savech = -1;
  339.     else
  340.     ch = (*xlgetc)();
  341.  
  342.     /* check for the abort character */
  343.     if (ch == EOF)
  344.     if (xlplevel > 0) {
  345.         putchar('\n');
  346.         xltin(FALSE);
  347.         xlfail("input aborted");
  348.     }
  349.     else
  350.         exit();
  351.  
  352.     /* return the character */
  353.     return (ch);
  354. }
  355.  
  356. /* issym - check whether a character if valid in a symbol name */
  357. static int issym(ch)
  358.   int ch;
  359. {
  360.     if (isspace(ch) ||
  361.         ch <  ' ' ||
  362.         ch == '(' ||
  363.         ch == ')' ||
  364.         ch == ';' || 
  365.         ch == '.' ||
  366.         ch == '"' ||
  367.         ch == '\'')
  368.     return (FALSE);
  369.     else
  370.     return (TRUE);
  371. }
  372.