home *** CD-ROM | disk | FTP | other *** search
/ The C Users' Group Library 1994 August / wc-cdrom-cusersgrouplibrary-1994-08.iso / vol_100 / 176_01 / xlread.c < prev    next >
Text File  |  1985-12-09  |  16KB  |  743 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. #ifdef MEGAMAX
  9. overlay "io"
  10. #endif
  11.  
  12. /* external variables */
  13. extern NODE *s_stdout,*true,*s_dot;
  14. extern NODE *s_quote,*s_function,*s_bquote,*s_comma,*s_comat;
  15. extern NODE *s_rtable,*k_wspace,*k_const,*k_nmacro,*k_tmacro;
  16. extern NODE ***xlstack;
  17. extern int xlplevel;
  18. extern char buf[];
  19.  
  20. /* external routines */
  21. extern FILE *fopen();
  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 NODE *callmacro();
  31. FORWARD NODE *phexnumber(),*pquote(),*plist(),*pvector(),*pname();
  32. FORWARD NODE *tentry();
  33.  
  34. /* xlload - load a file of xlisp expressions */
  35. int xlload(fname,vflag,pflag)
  36.   char *fname; int vflag,pflag;
  37. {
  38.     NODE ***oldstk,*fptr,*expr;
  39.     char fullname[STRMAX+1];
  40.     CONTEXT cntxt;
  41.     FILE *fp;
  42.     int sts;
  43.  
  44.     /* create a new stack frame */
  45.     oldstk = xlsave(&fptr,&expr,NULL);
  46.  
  47.     /* create the full file name */
  48.     if (needsextension(fname)) {
  49.     strcpy(fullname,fname);
  50.     strcat(fullname,".lsp");
  51.     fname = fullname;
  52.     }
  53.  
  54.     /* allocate a file node */
  55.     fptr = cvfile(NULL);
  56.  
  57.     /* print the information line */
  58.     if (vflag)
  59.     { sprintf(buf,"; loading \"%s\"\n",fname); stdputstr(buf); }
  60.  
  61.     /* open the file */
  62.     if ((fp = fopen(fname,"r")) == NULL) {
  63.     xlstack = oldstk;
  64.     return (FALSE);
  65.     }
  66.     setfile(fptr,fp);
  67.  
  68.     /* read, evaluate and possibly print each expression in the file */
  69.     xlbegin(&cntxt,CF_ERROR,true);
  70.     if (setjmp(cntxt.c_jmpbuf))
  71.     sts = FALSE;
  72.     else {
  73.     while (xlread(fptr,&expr,FALSE)) {
  74.         expr = xleval(expr);
  75.         if (pflag)
  76.         stdprint(expr);
  77.     }
  78.     sts = TRUE;
  79.     }
  80.     xlend(&cntxt);
  81.  
  82.     /* close the file */
  83.     fclose(getfile(fptr));
  84.     setfile(fptr,NULL);
  85.  
  86.     /* restore the previous stack frame */
  87.     xlstack = oldstk;
  88.  
  89.     /* return status */
  90.     return (sts);
  91. }
  92.  
  93. /* xlread - read an xlisp expression */
  94. int xlread(fptr,pval,rflag)
  95.   NODE *fptr,**pval; int rflag;
  96. {
  97.     int sts;
  98.  
  99.     /* reset the paren nesting level */
  100.     if (!rflag)
  101.     xlplevel = 0;
  102.  
  103.     /* read an expression */
  104.     while ((sts = readone(fptr,pval)) == FALSE)
  105.     ;
  106.  
  107.     /* return status */
  108.     return (sts == EOF ? FALSE : TRUE);
  109. }
  110.  
  111. /* readone - attempt to read a single expression */
  112. int readone(fptr,pval)
  113.   NODE *fptr,**pval;
  114. {
  115.     NODE *val,*type;
  116.     int ch;
  117.  
  118.     /* get a character and check for EOF */
  119.     if ((ch = xlgetc(fptr)) == EOF)
  120.     return (EOF);
  121.  
  122.     /* handle white space */
  123.     if ((type = tentry(ch)) == k_wspace)
  124.     return (FALSE);
  125.  
  126.     /* handle symbol constituents */
  127.     else if (type == k_const) {
  128.     *pval = pname(fptr,ch);
  129.     return (TRUE);
  130.     }
  131.  
  132.     /* handle read macros */
  133.     else if (consp(type)) {
  134.     if ((val = callmacro(fptr,ch)) && consp(val)) {
  135.         *pval = car(val);
  136.         return (TRUE);
  137.     }
  138.     else
  139.         return (FALSE);
  140.     }
  141.  
  142.     /* handle illegal characters */
  143.     else
  144.     xlerror("illegal character",cvfixnum((FIXNUM)ch));
  145. }
  146.  
  147. /* rmhash - read macro for '#' */
  148. NODE *rmhash(args)
  149.   NODE *args;
  150. {
  151.     NODE ***oldstk,*fptr,*mch,*val;
  152.     int ch;
  153.  
  154.     /* create a new stack frame */
  155.     oldstk = xlsave(&fptr,&mch,&val,NULL);
  156.  
  157.     /* get the file and macro character */
  158.     fptr = xlgetfile(&args);
  159.     mch = xlmatch(INT,&args);
  160.     xllastarg(args);
  161.  
  162.     /* make the return value */
  163.     val = consa(NIL);
  164.  
  165.     /* check the next character */
  166.     switch (ch = xlgetc(fptr)) {
  167.     case '\'':
  168.         rplaca(val,pquote(fptr,s_function));
  169.         break;
  170.     case '(':
  171.         rplaca(val,pvector(fptr));
  172.         break;
  173.     case 'x':
  174.     case 'X':
  175.             rplaca(val,phexnumber(fptr));
  176.         break;
  177.     case '\\':
  178.         rplaca(val,cvfixnum((FIXNUM)xlgetc(fptr)));
  179.         break;
  180.     default:
  181.         xlerror("illegal character after #",cvfixnum((FIXNUM)ch));
  182.     }
  183.  
  184.     /* restore the previous stack frame */
  185.     xlstack = oldstk;
  186.  
  187.     /* return the value */
  188.     return (val);
  189. }
  190.  
  191. /* rmquote - read macro for '\'' */
  192. NODE *rmquote(args)
  193.   NODE *args;
  194. {
  195.     NODE ***oldstk,*fptr,*mch,*val;
  196.     int ch;
  197.  
  198.     /* create a new stack frame */
  199.     oldstk = xlsave(&fptr,&mch,&val,NULL);
  200.  
  201.     /* get the file and macro character */
  202.     fptr = xlgetfile(&args);
  203.     mch = xlmatch(INT,&args);
  204.     xllastarg(args);
  205.  
  206.     /* make the return value */
  207.     val = consa(NIL);
  208.     rplaca(val,pquote(fptr,s_quote));
  209.  
  210.     /* restore the previous stack frame */
  211.     xlstack = oldstk;
  212.  
  213.     /* return the value */
  214.     return (val);
  215. }
  216.  
  217. /* rmdquote - read macro for '"' */
  218. NODE *rmdquote(args)
  219.   NODE *args;
  220. {
  221.     NODE ***oldstk,*fptr,*mch,*val;
  222.     int ch,i,d1,d2,d3;
  223.  
  224.     /* create a new stack frame */
  225.     oldstk = xlsave(&fptr,&mch,&val,NULL);
  226.  
  227.     /* get the file and macro character */
  228.     fptr = xlgetfile(&args);
  229.     mch = xlmatch(INT,&args);
  230.     xllastarg(args);
  231.  
  232.     /* loop looking for a closing quote */
  233.     for (i = 0; i < STRMAX && (ch = checkeof(fptr)) != '"'; i++) {
  234.     switch (ch) {
  235.     case '\\':
  236.         switch (ch = checkeof(fptr)) {
  237.         case 'f':
  238.             ch = '\f';
  239.             break;
  240.         case 'n':
  241.             ch = '\n';
  242.             break;
  243.         case 'r':
  244.             ch = '\r';
  245.             break;
  246.         case 't':
  247.             ch = '\t';
  248.             break;
  249.         default:
  250.             if (ch >= '0' && ch <= '7') {
  251.                 d1 = ch - '0';
  252.                 d2 = checkeof(fptr) - '0';
  253.                 d3 = checkeof(fptr) - '0';
  254.                 ch = (d1 << 6) + (d2 << 3) + d3;
  255.             }
  256.             break;
  257.         }
  258.     }
  259.     buf[i] = ch;
  260.     }
  261.     buf[i] = 0;
  262.  
  263.     /* initialize the node */
  264.     val = consa(NIL);
  265.     rplaca(val,cvstring(buf));
  266.  
  267.     /* restore the previous stack frame */
  268.     xlstack = oldstk;
  269.  
  270.     /* return the new string */
  271.     return (val);
  272. }
  273.  
  274. /* rmbquote - read macro for '`' */
  275. NODE *rmbquote(args)
  276.   NODE *args;
  277. {
  278.     NODE ***oldstk,*fptr,*mch,*val;
  279.     int ch;
  280.  
  281.     /* create a new stack frame */
  282.     oldstk = xlsave(&fptr,&mch,&val,NULL);
  283.  
  284.     /* get the file and macro character */
  285.     fptr = xlgetfile(&args);
  286.     mch = xlmatch(INT,&args);
  287.     xllastarg(args);
  288.  
  289.     /* make the return value */
  290.     val = consa(NIL);
  291.     rplaca(val,pquote(fptr,s_bquote));
  292.  
  293.     /* restore the previous stack frame */
  294.     xlstack = oldstk;
  295.  
  296.     /* return the value */
  297.     return (val);
  298. }
  299.  
  300. /* rmcomma - read macro for ',' */
  301. NODE *rmcomma(args)
  302.   NODE *args;
  303. {
  304.     NODE ***oldstk,*fptr,*mch,*val,*sym;
  305.     int ch;
  306.  
  307.     /* create a new stack frame */
  308.     oldstk = xlsave(&fptr,&mch,&val,NULL);
  309.  
  310.     /* get the file and macro character */
  311.     fptr = xlgetfile(&args);
  312.     mch = xlmatch(INT,&args);
  313.     xllastarg(args);
  314.  
  315.     /* check the next character */
  316.     if (xlpeek(fptr) == '@') {
  317.     sym = s_comat;
  318.     xlgetc(fptr);
  319.     }
  320.     else
  321.     sym = s_comma;
  322.  
  323.     /* make the return value */
  324.     val = consa(NIL);
  325.     rplaca(val,pquote(fptr,sym));
  326.  
  327.     /* restore the previous stack frame */
  328.     xlstack = oldstk;
  329.  
  330.     /* return the value */
  331.     return (val);
  332. }
  333.  
  334. /* rmlpar - read macro for '(' */
  335. NODE *rmlpar(args)
  336.   NODE *args;
  337. {
  338.     NODE ***oldstk,*fptr,*mch,*val;
  339.     int ch;
  340.  
  341.     /* create a new stack frame */
  342.     oldstk = xlsave(&fptr,&mch,&val,NULL);
  343.  
  344.     /* get the file and macro character */
  345.     fptr = xlgetfile(&args);
  346.     mch = xlmatch(INT,&args);
  347.     xllastarg(args);
  348.  
  349.     /* make the return value */
  350.     val = consa(NIL);
  351.     rplaca(val,plist(fptr));
  352.  
  353.     /* restore the previous stack frame */
  354.     xlstack = oldstk;
  355.  
  356.     /* return the value */
  357.     return (val);
  358. }
  359.  
  360. /* rmrpar - read macro for ')' */
  361. NODE *rmrpar(args)
  362.   NODE *args;
  363. {
  364.     xlfail("misplaced right paren");
  365. }
  366.  
  367. /* rmsemi - read macro for ';' */
  368. NODE *rmsemi(args)
  369.   NODE *args;
  370. {
  371.     NODE ***oldstk,*fptr,*mch;
  372.     int ch;
  373.  
  374.     /* create a new stack frame */
  375.     oldstk = xlsave(&fptr,&mch,NULL);
  376.  
  377.     /* get the file and macro character */
  378.     fptr = xlgetfile(&args);
  379.     mch = xlmatch(INT,&args);
  380.     xllastarg(args);
  381.  
  382.     /* skip to end of line */
  383.     while ((ch = xlgetc(fptr)) != EOF && ch != '\n')
  384.     ;
  385.  
  386.     /* restore the previous stack frame */
  387.     xlstack = oldstk;
  388.  
  389.     /* return nil (nothing read) */
  390.     return (NIL);
  391. }
  392.  
  393. /* phexnumber - parse a hexidecimal number */
  394. LOCAL NODE *phexnumber(fptr)
  395.   NODE *fptr;
  396. {
  397.     long num;
  398.     int ch;
  399.     
  400.     num = 0L;
  401.     while ((ch = xlpeek(fptr)) != EOF) {
  402.     if (islower(ch)) ch = toupper(ch);
  403.     if (!isdigit(ch) && !(ch >= 'A' && ch <= 'F'))
  404.         break;
  405.     xlgetc(fptr);
  406.     num = num * 16L + (long)(ch <= '9' ? ch - '0' : ch - 'A' + 10);
  407.     }
  408.     return (cvfixnum((FIXNUM)num));
  409. }
  410.  
  411. /* plist - parse a list */
  412. LOCAL NODE *plist(fptr)
  413.   NODE *fptr;
  414. {
  415.     NODE ***oldstk,*val,*expr,*lastnptr,*nptr;
  416.     int ch;
  417.  
  418.     /* create a new stack frame */
  419.     oldstk = xlsave(&val,&expr,NULL);
  420.  
  421.     /* increase the paren nesting level */
  422.     ++xlplevel;
  423.  
  424.     /* keep appending nodes until a closing paren is found */
  425.     lastnptr = NIL;
  426.     for (lastnptr = NIL; (ch = nextch(fptr)) != ')'; lastnptr = nptr)
  427.  
  428.     /* get the next expression */
  429.     switch (readone(fptr,&expr)) {
  430.     case EOF:
  431.         badeof(fptr);
  432.     case TRUE:
  433.  
  434.         /* check for a dotted tail */
  435.         if (expr == s_dot) {
  436.  
  437.         /* make sure there's a node */
  438.         if (lastnptr == NIL)
  439.             xlfail("invalid dotted pair");
  440.  
  441.         /* parse the expression after the dot */
  442.         if (!xlread(fptr,&expr,TRUE))
  443.             badeof(fptr);
  444.         rplacd(lastnptr,expr);
  445.  
  446.         /* make sure its followed by a close paren */
  447.         if (nextch(fptr) != ')')
  448.             xlfail("invalid dotted pair");
  449.  
  450.         /* done with this list */
  451.         break;
  452.         }
  453.  
  454.         /* otherwise, handle a normal list element */
  455.         else {
  456.         nptr = consa(expr);
  457.         if (lastnptr == NIL)
  458.             val = nptr;
  459.         else
  460.             rplacd(lastnptr,nptr);
  461.         }
  462.         break;
  463.     }
  464.  
  465.     /* skip the closing paren */
  466.     xlgetc(fptr);
  467.  
  468.     /* decrease the paren nesting level */
  469.     --xlplevel;
  470.  
  471.     /* restore the previous stack frame */
  472.     xlstack = oldstk;
  473.  
  474.     /* return successfully */
  475.     return (val);
  476. }
  477.  
  478. /* pvector - parse a vector */
  479. LOCAL NODE *pvector(fptr)
  480.   NODE *fptr;
  481. {
  482.     NODE ***oldstk,*list,*expr,*val,*lastnptr,*nptr;
  483.     int len,ch,i;
  484.  
  485.     /* create a new stack frame */
  486.     oldstk = xlsave(&list,&expr,NULL);
  487.  
  488.     /* keep appending nodes until a closing paren is found */
  489.     lastnptr = NIL; len = 0;
  490.     for (lastnptr = NIL; (ch = nextch(fptr)) != ')'; lastnptr = nptr) {
  491.  
  492.     /* check for end of file */
  493.     if (ch == EOF)
  494.         badeof(fptr);
  495.  
  496.     /* get the next expression */
  497.     switch (readone(fptr,&expr)) {
  498.     case EOF:
  499.         badeof(fptr);
  500.     case TRUE:
  501.         nptr = consa(expr);
  502.         if (lastnptr == NIL)
  503.         list = nptr;
  504.         else
  505.         rplacd(lastnptr,nptr);
  506.         len++;
  507.         break;
  508.     }
  509.     }
  510.  
  511.     /* skip the closing paren */
  512.     xlgetc(fptr);
  513.  
  514.     /* make a vector of the appropriate length */
  515.     val = newvector(len);
  516.  
  517.     /* copy the list into the vector */
  518.     for (i = 0; i < len; ++i, list = cdr(list))
  519.     setelement(val,i,car(list));
  520.  
  521.     /* restore the previous stack frame */
  522.     xlstack = oldstk;
  523.  
  524.     /* return successfully */
  525.     return (val);
  526. }
  527.  
  528. /* pquote - parse a quoted expression */
  529. LOCAL NODE *pquote(fptr,sym)
  530.   NODE *fptr,*sym;
  531. {
  532.     NODE ***oldstk,*val,*p;
  533.  
  534.     /* create a new stack frame */
  535.     oldstk = xlsave(&val,NULL);
  536.  
  537.     /* allocate two nodes */
  538.     val = consa(sym);
  539.     rplacd(val,consa(NIL));
  540.  
  541.     /* initialize the second to point to the quoted expression */
  542.     if (!xlread(fptr,&p,TRUE))
  543.     badeof(fptr);
  544.     rplaca(cdr(val),p);
  545.  
  546.     /* restore the previous stack frame */
  547.     xlstack = oldstk;
  548.  
  549.     /* return the quoted expression */
  550.     return (val);
  551. }
  552.  
  553. /* pname - parse a symbol name */
  554. LOCAL NODE *pname(fptr,ch)
  555.   NODE *fptr; int ch;
  556. {
  557.     NODE *val,*type;
  558.     int i;
  559.  
  560.     /* get symbol name */
  561.     for (i = 0; ; xlgetc(fptr)) {
  562.     if (i < STRMAX)
  563.         buf[i++] = (islower(ch) ? toupper(ch) : ch);
  564.     if ((ch = xlpeek(fptr)) == EOF ||
  565.         ((type = tentry(ch)) != k_const &&
  566.              !(consp(type) && car(type) == k_nmacro)))
  567.         break;
  568.     }
  569.     buf[i] = 0;
  570.  
  571.     /* check for a number or enter the symbol into the oblist */
  572.     return (isnumber(buf,&val) ? val : xlenter(buf,DYNAMIC));
  573. }
  574.  
  575. /* tentry - get a readtable entry */
  576. LOCAL NODE *tentry(ch)
  577.   int ch;
  578. {
  579.     NODE *rtable;
  580.     rtable = getvalue(s_rtable);
  581.     if (!vectorp(rtable) || ch < 0 || ch >= getsize(rtable))
  582.     return (NIL);
  583.     return (getelement(rtable,ch));
  584. }
  585.  
  586. /* nextch - look at the next non-blank character */
  587. LOCAL int nextch(fptr)
  588.   NODE *fptr;
  589. {
  590.     int ch;
  591.  
  592.     /* return and save the next non-blank character */
  593.     while ((ch = xlpeek(fptr)) != EOF && isspace(ch))
  594.     xlgetc(fptr);
  595.     return (ch);
  596. }
  597.  
  598. /* checkeof - get a character and check for end of file */
  599. LOCAL int checkeof(fptr)
  600.   NODE *fptr;
  601. {
  602.     int ch;
  603.  
  604.     if ((ch = xlgetc(fptr)) == EOF)
  605.     badeof(fptr);
  606.     return (ch);
  607. }
  608.  
  609. /* badeof - unexpected eof */
  610. LOCAL badeof(fptr)
  611.   NODE *fptr;
  612. {
  613.     xlgetc(fptr);
  614.     xlfail("unexpected EOF");
  615. }
  616.  
  617. /* isnumber - check if this string is a number */
  618. int isnumber(str,pval)
  619.   char *str; NODE **pval;
  620. {
  621.     int dl,dr;
  622.     char *p;
  623.  
  624.     /* initialize */
  625.     p = str; dl = dr = 0;
  626.  
  627.     /* check for a sign */
  628.     if (*p == '+' || *p == '-')
  629.     p++;
  630.  
  631.     /* check for a string of digits */
  632.     while (isdigit(*p))
  633.     p++, dl++;
  634.  
  635.     /* check for a decimal point */
  636.     if (*p == '.') {
  637.     p++;
  638.     while (isdigit(*p))
  639.         p++, dr++;
  640.     }
  641.  
  642.     /* check for an exponent */
  643.     if ((dl || dr) && *p == 'E') {
  644.     p++;
  645.  
  646.     /* check for a sign */
  647.     if (*p == '+' || *p == '-')
  648.         p++;
  649.  
  650.     /* check for a string of digits */
  651.     while (isdigit(*p))
  652.         p++, dr++;
  653.     }
  654.  
  655.     /* make sure there was at least one digit and this is the end */
  656.     if ((dl == 0 && dr == 0) || *p)
  657.     return (FALSE);
  658.  
  659.     /* convert the string to an integer and return successfully */
  660.     if (*str == '+') ++str;
  661.     if (str[strlen(str)-1] == '.') str[strlen(str)-1] = 0;
  662.     *pval = (dr ? cvflonum(atof(str)) : cvfixnum(ICNV(str)));
  663.     return (TRUE);
  664. }
  665.  
  666. /* defmacro - define a read macro */
  667. defmacro(ch,type,fun)
  668.   int ch; NODE *type,*(*fun)();
  669. {
  670.     NODE *p;
  671.     p = consa(type);
  672.     setelement(getvalue(s_rtable),ch,p);
  673.     rplacd(p,cvsubr(fun,SUBR));
  674. }
  675.  
  676. /* callmacro - call a read macro */
  677. NODE *callmacro(fptr,ch)
  678.   NODE *fptr; int ch;
  679. {
  680.     NODE ***oldstk,*fun,*args,*val;
  681.  
  682.     /* create a new stack frame */
  683.     oldstk = xlsave(&fun,&args,NULL);
  684.  
  685.     /* get the macro function */
  686.     fun = cdr(getelement(getvalue(s_rtable),ch));
  687.  
  688.     /* create the argument list */
  689.     args = consa(fptr);
  690.     rplacd(args,consa(NIL));
  691.     rplaca(cdr(args),cvfixnum((FIXNUM)ch));
  692.  
  693.     /* apply the macro function to the arguments */
  694.     val = xlapply(fun,args);
  695.  
  696.     /* restore the previous stack frame */
  697.     xlstack = oldstk;
  698.  
  699.     /* return the result */
  700.     return (val);
  701. }
  702.  
  703. /* needsextension - determine if a filename needs an extension */
  704. int needsextension(name)
  705.   char *name;
  706. {
  707.     while (*name)
  708.     if (*name++ == '.')
  709.         return (FALSE);
  710.     return (TRUE);
  711. }
  712.  
  713. /* xlrinit - initialize the reader */
  714. xlrinit()
  715. {
  716.     NODE *rtable;
  717.     char *p;
  718.     int ch;
  719.  
  720.     /* create the read table */
  721.     rtable = newvector(256);
  722.     setvalue(s_rtable,rtable);
  723.  
  724.     /* initialize the readtable */
  725.     for (p = WSPACE; ch = *p++; )
  726.     setelement(rtable,ch,k_wspace);
  727.     for (p = CONST1; ch = *p++; )
  728.     setelement(rtable,ch,k_const);
  729.     for (p = CONST2; ch = *p++; )
  730.     setelement(rtable,ch,k_const);
  731.  
  732.     /* install the read macros */
  733.     defmacro('#', k_nmacro,rmhash);
  734.     defmacro('\'',k_tmacro,rmquote);
  735.     defmacro('"', k_tmacro,rmdquote);
  736.     defmacro('`', k_tmacro,rmbquote);
  737.     defmacro(',', k_tmacro,rmcomma);
  738.     defmacro('(', k_tmacro,rmlpar);
  739.     defmacro(')', k_tmacro,rmrpar);
  740.     defmacro(';', k_tmacro,rmsemi);
  741. }
  742.  
  743.