home *** CD-ROM | disk | FTP | other *** search
/ Carousel Volume 2 #1 / carousel.iso / mactosh / lang / xlisp.sha / xlread.c < prev    next >
Encoding:
C/C++ Source or Header  |  1985-02-17  |  8.2 KB  |  407 lines
  1. /* xlread - xlisp expression input routine */
  2.  
  3. #include "xlisp.h"
  4. #include "ctype.h"
  5.  
  6. /* external variables */
  7. extern NODE *s_stdout,*true;
  8. extern NODE *s_quote,*s_function,*s_bquote,*s_comma,*s_comat;
  9. extern NODE *xlstack;
  10. extern int xlplevel;
  11.  
  12. /* external routines */
  13. extern FILE *fopen();
  14.  
  15. /* forward declarations */
  16. FORWARD NODE *plist();
  17. FORWARD NODE *pstring();
  18. FORWARD NODE *pquote();
  19. FORWARD NODE *pname();
  20.  
  21. /* xlload - load a file of xlisp expressions */
  22. int xlload(name,vflag,pflag)
  23.   char *name; int vflag,pflag;
  24. {
  25.     NODE *oldstk,fptr,expr;
  26.     char fname[50];
  27.     CONTEXT cntxt;
  28.     int sts;
  29.  
  30.     /* create a new stack frame */
  31.     oldstk = xlsave(&fptr,&expr,NULL);
  32.  
  33.     /* allocate a file node */
  34.     fptr.n_ptr = newnode(FPTR);
  35.     fptr.n_ptr->n_fp = NULL;
  36.     fptr.n_ptr->n_savech = 0;
  37.  
  38.     /* create the file name and print the information line */
  39.     strcpy(fname,name); strcat(fname,".lsp");
  40.     if (vflag)
  41.     printf("; loading \"%s\"\n",fname);
  42.  
  43.     /* open the file */
  44.     if ((fptr.n_ptr->n_fp = fopen(fname,"r")) == NULL) {
  45.     xlstack = oldstk;
  46.     return (FALSE);
  47.     }
  48.  
  49.     /* read, evaluate and possibly print each expression in the file */
  50.     xlbegin(&cntxt,CF_ERROR,true);
  51.     if (setjmp(cntxt.c_jmpbuf))
  52.     sts = FALSE;
  53.     else {
  54.     while (xlread(fptr.n_ptr,&expr.n_ptr)) {
  55.         expr.n_ptr = xleval(expr.n_ptr);
  56.         if (pflag)
  57.         stdprint(expr.n_ptr);
  58.     }
  59.     sts = TRUE;
  60.     }
  61.     xlend(&cntxt);
  62.  
  63.     /* close the file */
  64.     fclose(fptr.n_ptr->n_fp);
  65.     fptr.n_ptr->n_fp = NULL;
  66.  
  67.     /* restore the previous stack frame */
  68.     xlstack = oldstk;
  69.  
  70.     /* return status */
  71.     return (sts);
  72. }
  73.  
  74. /* xlread - read an xlisp expression */
  75. int xlread(fptr,pval)
  76.   NODE *fptr,**pval;
  77. {
  78.     /* initialize */
  79.     xlplevel = 0;
  80.  
  81.     /* parse an expression */
  82.     return (parse(fptr,pval));
  83. }
  84.  
  85. /* parse - parse an xlisp expression */
  86. LOCAL int parse(fptr,pval)
  87.   NODE *fptr,**pval;
  88. {
  89.     int ch;
  90.  
  91.     /* keep looking for a node skipping comments */
  92.     while (TRUE)
  93.  
  94.     /* check next character for type of node */
  95.     switch (ch = nextch(fptr)) {
  96.     case EOF:
  97.         xlgetc(fptr);
  98.         return (FALSE);
  99.     case '\'':            /* a quoted expression */
  100.         xlgetc(fptr);
  101.         *pval = pquote(fptr,s_quote);
  102.         return (TRUE);
  103.     case '#':            /* a quoted function */
  104.         xlgetc(fptr);
  105.         if ((ch = xlgetc(fptr)) == '<')
  106.             xlfail("unreadable atom");
  107.         else if (ch != '\'')
  108.             xlfail("expected quote after #");
  109.         *pval = pquote(fptr,s_function);
  110.         return (TRUE);
  111.     case '`':            /* a back quoted expression */
  112.         xlgetc(fptr);
  113.         *pval = pquote(fptr,s_bquote);
  114.         return (TRUE);
  115.     case ',':            /* a comma or comma-at expression */
  116.         xlgetc(fptr);
  117.         if (xlpeek(fptr) == '@') {
  118.             xlgetc(fptr);
  119.             *pval = pquote(fptr,s_comat);
  120.         }
  121.         else
  122.             *pval = pquote(fptr,s_comma);
  123.         return (TRUE);
  124.     case '(':            /* a sublist */
  125.         *pval = plist(fptr);
  126.         return (TRUE);
  127.     case ')':            /* closing paren - shouldn't happen */
  128.         xlfail("extra right paren");
  129.     case '.':            /* dot - shouldn't happen */
  130.         xlfail("misplaced dot");
  131.     case ';':            /* a comment */
  132.         pcomment(fptr);
  133.         break;
  134.     case '"':            /* a string */
  135.         *pval = pstring(fptr);
  136.         return (TRUE);
  137.     default:
  138.         if (issym(ch))        /* a name */
  139.             *pval = pname(fptr);
  140.         else
  141.             xlfail("invalid character");
  142.         return (TRUE);
  143.     }
  144. }
  145.  
  146. /* pcomment - parse a comment */
  147. LOCAL pcomment(fptr)
  148.   NODE *fptr;
  149. {
  150.     int ch;
  151.  
  152.     /* skip to end of line */
  153.     while ((ch = checkeof(fptr)) != EOF && ch != '\n')
  154.     ;
  155. }
  156.  
  157. /* plist - parse a list */
  158. LOCAL NODE *plist(fptr)
  159.   NODE *fptr;
  160. {
  161.     NODE *oldstk,val,*lastnptr,*nptr,*p;
  162.     int ch;
  163.  
  164.     /* increment the nesting level */
  165.     xlplevel += 1;
  166.  
  167.     /* create a new stack frame */
  168.     oldstk = xlsave(&val,NULL);
  169.  
  170.     /* skip the opening paren */
  171.     xlgetc(fptr);
  172.  
  173.     /* keep appending nodes until a closing paren is found */
  174.     lastnptr = NIL;
  175.     for (lastnptr = NIL; (ch = nextch(fptr)) != ')'; lastnptr = nptr) {
  176.  
  177.     /* check for end of file */
  178.     if (ch == EOF)
  179.         badeof(fptr);
  180.  
  181.     /* check for a dotted pair */
  182.     if (ch == '.') {
  183.  
  184.         /* skip the dot */
  185.         xlgetc(fptr);
  186.  
  187.         /* make sure there's a node */
  188.         if (lastnptr == NIL)
  189.         xlfail("invalid dotted pair");
  190.  
  191.         /* parse the expression after the dot */
  192.         if (!parse(fptr,&p))
  193.         badeof(fptr);
  194.         rplacd(lastnptr,p);
  195.  
  196.         /* make sure its followed by a close paren */
  197.         if (nextch(fptr) != ')')
  198.         xlfail("invalid dotted pair");
  199.  
  200.         /* done with this list */
  201.         break;
  202.     }
  203.  
  204.     /* allocate a new node and link it into the list */
  205.     nptr = newnode(LIST);
  206.     if (lastnptr == NIL)
  207.         val.n_ptr = nptr;
  208.     else
  209.         rplacd(lastnptr,nptr);
  210.  
  211.     /* initialize the new node */
  212.     if (!parse(fptr,&p))
  213.         badeof(fptr);
  214.     rplaca(nptr,p);
  215.     }
  216.  
  217.     /* skip the closing paren */
  218.     xlgetc(fptr);
  219.  
  220.     /* restore the previous stack frame */
  221.     xlstack = oldstk;
  222.  
  223.     /* decrement the nesting level */
  224.     xlplevel -= 1;
  225.  
  226.     /* return successfully */
  227.     return (val.n_ptr);
  228. }
  229.  
  230. /* pstring - parse a string */
  231. LOCAL NODE *pstring(fptr)
  232.   NODE *fptr;
  233. {
  234.     NODE *oldstk,val;
  235.     char sbuf[STRMAX+1];
  236.     int ch,i,d1,d2,d3;
  237.  
  238.     /* create a new stack frame */
  239.     oldstk = xlsave(&val,NULL);
  240.  
  241.     /* skip the opening quote */
  242.     xlgetc(fptr);
  243.  
  244.     /* loop looking for a closing quote */
  245.     for (i = 0; i < STRMAX && (ch = checkeof(fptr)) != '"'; i++) {
  246.     switch (ch) {
  247.     case EOF:
  248.         badeof(fptr);
  249.     case '\\':
  250.         switch (ch = checkeof(fptr)) {
  251.         case 'e':
  252.             ch = '\033';
  253.             break;
  254.         case 'n':
  255.             ch = '\n';
  256.             break;
  257.         case 'r':
  258.             ch = '\r';
  259.             break;
  260.         case 't':
  261.             ch = '\t';
  262.             break;
  263.         default:
  264.             if (ch >= '0' && ch <= '7') {
  265.                 d1 = ch - '0';
  266.                 d2 = checkeof(fptr) - '0';
  267.                 d3 = checkeof(fptr) - '0';
  268.                 ch = (d1 << 6) + (d2 << 3) + d3;
  269.             }
  270.             break;
  271.         }
  272.     }
  273.     sbuf[i] = ch;
  274.     }
  275.     sbuf[i] = 0;
  276.  
  277.     /* initialize the node */
  278.     val.n_ptr = newnode(STR);
  279.     val.n_ptr->n_str = strsave(sbuf);
  280.     val.n_ptr->n_strtype = DYNAMIC;
  281.  
  282.     /* restore the previous stack frame */
  283.     xlstack = oldstk;
  284.  
  285.     /* return the new string */
  286.     return (val.n_ptr);
  287. }
  288.  
  289. /* pquote - parse a quoted expression */
  290. LOCAL NODE *pquote(fptr,sym)
  291.   NODE *fptr,*sym;
  292. {
  293.     NODE *oldstk,val,*p;
  294.  
  295.     /* create a new stack frame */
  296.     oldstk = xlsave(&val,NULL);
  297.  
  298.     /* allocate two nodes */
  299.     val.n_ptr = newnode(LIST);
  300.     rplaca(val.n_ptr,sym);
  301.     rplacd(val.n_ptr,newnode(LIST));
  302.  
  303.     /* initialize the second to point to the quoted expression */
  304.     if (!parse(fptr,&p))
  305.     badeof(fptr);
  306.     rplaca(cdr(val.n_ptr),p);
  307.  
  308.     /* restore the previous stack frame */
  309.     xlstack = oldstk;
  310.  
  311.     /* return the quoted expression */
  312.     return (val.n_ptr);
  313. }
  314.  
  315. /* pname - parse a symbol name */
  316. LOCAL NODE *pname(fptr)
  317.   NODE *fptr;
  318. {
  319.     char sname[STRMAX+1];
  320.     NODE *val;
  321.     int i;
  322.  
  323.     /* get symbol name */
  324.     for (i = 0; i < STRMAX && issym(xlpeek(fptr)); )
  325.     sname[i++] = xlgetc(fptr);
  326.     sname[i] = 0;
  327.  
  328.     /* check for a number or enter the symbol into the oblist */
  329.     return (isnumber(sname,&val) ? val : xlenter(sname,DYNAMIC));
  330. }
  331.  
  332. /* nextch - look at the next non-blank character */
  333. LOCAL int nextch(fptr)
  334.   NODE *fptr;
  335. {
  336.     int ch;
  337.  
  338.     /* return and save the next non-blank character */
  339.     while ((ch = xlpeek(fptr)) != EOF && isspace(ch))
  340.     xlgetc(fptr);
  341.     return (ch);
  342. }
  343.  
  344. /* checkeof - get a character and check for end of file */
  345. LOCAL int checkeof(fptr)
  346.   NODE *fptr;
  347. {
  348.     int ch;
  349.  
  350.     if ((ch = xlgetc(fptr)) == EOF)
  351.     badeof(fptr);
  352.     return (ch);
  353. }
  354.  
  355. /* badeof - unexpected eof */
  356. LOCAL badeof(fptr)
  357.   NODE *fptr;
  358. {
  359.     xlgetc(fptr);
  360.     xlfail("unexpected EOF");
  361. }
  362.  
  363. /* isnumber - check if this string is a number */
  364. int isnumber(str,pval)
  365.   char *str; NODE **pval;
  366. {
  367.     char *p;
  368.     int d;
  369.  
  370.     /* initialize */
  371.     p = str; d = 0;
  372.  
  373.     /* check for a sign */
  374.     if (*p == '+' || *p == '-')
  375.     p++;
  376.  
  377.     /* check for a string of digits */
  378.     while (isdigit(*p))
  379.     p++, d++;
  380.  
  381.     /* make sure there was at least one digit and this is the end */
  382.     if (d == 0 || *p)
  383.     return (FALSE);
  384.  
  385.     /* convert the string to an integer and return successfully */
  386.     *pval = newnode(INT);
  387.     (*pval)->n_int = atoi(*str == '+' ? ++str : str);
  388.     return (TRUE);
  389. }
  390.  
  391. /* issym - check whether a character if valid in a symbol name */
  392. LOCAL int issym(ch)
  393.   int ch;
  394. {
  395.     if (ch <= ' ' || ch >= 0177 ||
  396.         ch == '(' ||
  397.         ch == ')' ||
  398.         ch == ';' || 
  399.     ch == ',' ||
  400.     ch == '`' ||
  401.         ch == '"' ||
  402.         ch == '\'')
  403.     return (FALSE);
  404.     else
  405.     return (TRUE);
  406. }
  407.