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