home *** CD-ROM | disk | FTP | other *** search
/ Super Net 1 / SUPERNET_1.iso / PC / OTROS / MSDOS / WATTCP / DELFT / SAGE.TAR / sage / scheme / schrdr.c < prev    next >
Encoding:
C/C++ Source or Header  |  1991-04-26  |  18.1 KB  |  637 lines
  1. /**********************************************************************
  2. ** MODULE INFORMATION*
  3. **********************
  4. **      FILE     NAME:       SCHRDR.C
  5. **      SYSTEM   NAME:       SCHEME
  6. **      ORIGINAL AUTHOR(S):  Alfred Kayser
  7. **      VERSION  NUMBER:     1.5.5
  8. **      CREATION DATE:       88/10/05
  9. **
  10. ** DESCRIPTION: This module contains the DScheme parser engine.
  11. ***********************************************************************
  12. ** CHANGES INFORMATION **
  13. *************************
  14. ** REVISION:    $Revision:   1.0  $
  15. ** CHANGER:     $Author:   JAN  $
  16. ** WORKFILE:    $Workfile:   schrdr.c  $
  17. ** LOGFILE:     $Logfile:   C:/CPROG/SCHEME/VCS/SCHRDR.C_V  $
  18. ** LOGINFO:     $Log:   C:/CPROG/SCHEME/VCS/SCHRDR.C_V  $
  19. **              
  20. **                 Rev 1.0   12 Oct 1989 11:46:04   JAN
  21. **              Initial revision.
  22. **********************************************************************/
  23. #include "schinc.h"
  24. #include "schdef.h"
  25.  
  26. #ifdef UNIX
  27.     LONG strtol();
  28.     REAL strtod();
  29. #endif
  30. #define EOL '\n'
  31.  
  32. #define INPCC          DsInput(inport)
  33. #define TESTC          DsPeek(inport)
  34. #define UNPCC(c)       DsUnput(inport,c)
  35.  
  36. #define EOFTOKEN    0
  37. #define POSITIVE    1
  38. #define NEGATIVE    2
  39. #define DOT         3
  40. #define PAROPEN     4
  41. #define PARCLOSE    5
  42. #define BRACKETPAR  6
  43. #define SQUOTE      7
  44. #define BACKQUOTE   8
  45. #define COMMA       9
  46. #define COMMAAT     10
  47. #define STRING      11
  48. #define SYM_KEY     12
  49. #define TIMESTAMP   13
  50. #define NUMBERT     14
  51. #define BOOLEAN     15
  52. #define CHARACTER   16
  53. #define OBJECTID    17
  54.  
  55. static PORT *inport;                                    /* current input port */
  56. static BYTE *p;                               /* Character pointer in bigbuf */
  57. static BYTE chars[256];            /* Truth table white space, float and hex */
  58. static CELP yylval;                         /* Lex puts found tokens in here! */
  59.                                   /********************************************/
  60. #define WHITECHAR  0x80           /* +---+---+---+---+----------------------+ */
  61. #define FLOATCHAR  0x40           /* | W | F | N | O |                      | */
  62. #define NUMBER     0x20           /* +---+---+---+---+----------------------+ */
  63. #define OCTAL      0x10           /********************************************/
  64. #define BLANK      0x08           /* Blank means character can be discarded */
  65. #define WHITEC(c)  (chars[(BYTE)(c)] & WHITECHAR)
  66. #define FLOATC(c)  (chars[(BYTE)(c)] & FLOATCHAR)
  67. #define NUMC(c)    (chars[(BYTE)(c)] & NUMBER)
  68. #define OCTALC(c)  (chars[(BYTE)(c)] & OCTAL)
  69. #define BLANKC(c)  (chars[(BYTE)(c)] & BLANK)
  70.  
  71. void   PASCAL  DsSkipBlank   __((void));
  72. CELP   PASCAL  DsReadList    __((void));
  73. void   PASCAL  DsGetWord     __((void));
  74. void   PASCAL  DsLError      __((int nr));
  75. int    PASCAL  DsParser      __((void));
  76. int    PASCAL  DsLex         __((void));
  77. int    PASCAL  DsSpecial     __((void));
  78. int    PASCAL  DsReadNumber  __((int base));
  79. int    PASCAL  DsReadString  __((void));
  80.  
  81. #define DSLERROR(n)   STOP(DsLError(n))
  82.  
  83. /***************************************************************
  84. ** NAME:        DsIniParser
  85. ** SYNOPSIS:    void DsIniParser()
  86. ** DESCRIPTION: Initializes the parser system. The character
  87. **              coding and hex value table is filled here.
  88. ** RETURNS:     void
  89. ***************************************************************/
  90. void PASCAL DsIniParser()
  91. {
  92.     int i;
  93.     memset(chars,0,256);
  94.  
  95.     for (i=0;i<10;i++)
  96.          chars[i+'0'] = (BYTE) (FLOATCHAR | NUMBER | OCTAL);
  97.     chars['8'] = (BYTE) (FLOATCHAR | NUMBER);
  98.     chars['9'] = (BYTE) (FLOATCHAR | NUMBER);
  99.  
  100.     chars[255]  |= WHITECHAR;       /* set whitechar flag */
  101.     chars[' ']  |= WHITECHAR|BLANK;
  102.     chars['\f'] |= WHITECHAR|BLANK; /* formfeed */
  103.     chars['\n'] |= WHITECHAR|BLANK; /* newline */
  104.     chars['\r'] |= WHITECHAR|BLANK; /* return */
  105.     chars[']']  |= WHITECHAR;
  106.     chars[')']  |= WHITECHAR;
  107.     chars['[']  |= WHITECHAR;
  108.     chars['(']  |= WHITECHAR;
  109.     chars[';']  |= WHITECHAR;  /* comment is also white space */
  110.     chars['"']  |= WHITECHAR;
  111.  
  112.     chars['E']  |= FLOATCHAR;
  113.     chars['e']  |= FLOATCHAR;
  114.     chars['.']  |= FLOATCHAR;
  115.     chars['+']  |= FLOATCHAR;
  116.     chars['-']  |= FLOATCHAR;
  117.  
  118.     chars['#']  |= NUMBER;
  119. }
  120.  
  121.  
  122. /*****************************************************************
  123. ** NAME:        DsRead
  124. ** SYNOPSIS:    CELP DsRead(port)
  125. **              PORT *port;
  126. ** DESCRIPTION: DsRead reads an item from the <port>.
  127. ** RETURNS:     Item read.
  128. *****************************************************************/
  129. CELP PASCAL DsRead(port)
  130. PORT *port;
  131. {
  132.     if (GLOB(GCflag)) DsGarbageCollect(NIL);
  133.     inport=port;
  134.     DsSkipBlank();
  135.     GLOB(errline)=inport->lineno;
  136.     switch(DsParser())
  137.     {
  138.     case DOT:      DSERROR(ERRDOT,NIL);
  139.     case PARCLOSE: DSERROR(ERRPARS,NIL);
  140.     }
  141.     return(yylval);
  142. }
  143.  
  144. /*****************************************************************
  145. ** NAME:        DsSkipBlank
  146. ** SYNOPSIS:    void DsSkipBlank()
  147. ** DESCRIPTION: Skips all discardable blank until first
  148. **              non-blank character. Comments are also skipped.
  149. ** RETURNS:     void
  150. *****************************************************************/
  151. void PASCAL DsSkipBlank()
  152. {
  153.     register int c;
  154.     do
  155.     { 
  156.     c=INPCC;
  157.         if (c==';')
  158.             while ((c=INPCC)!=EOL)                /* Crunch until end of line */
  159.                 if (c==EOF) break;                     /* or an EOF! is found */
  160.     } while (BLANKC(c));
  161.     UNPCC(c);                            /* Put first nonblank character back */
  162. }
  163.  
  164.  
  165. /**************************************************************
  166. ** NAME:        DsLError
  167. ** SYNOPSIS:    DsLError(nr);
  168. **              int nr;         The error number
  169. ** DESCRIPTION: DsLError is called by the parser to raise an
  170. **              error. This function calls DsError to handle
  171. **              the error.
  172. ** RETURNS:     void
  173. **************************************************************/
  174. void PASCAL DsLError(nr)
  175. int nr;
  176. {
  177.     *p='\0';                                             /* mark end of input */
  178.     DsGetWord();
  179.     GLOB(errline)=inport->lineno;
  180.     DSERROR(nr,(BIGBUF[0]=='\0'||nr==ERREOF)?NIL:DsStrCell(BIGBUF));
  181. }
  182.  
  183. /**************************************************************
  184. ** NAME:        DsParser
  185. ** SYNOPSIS:    int DsParser()
  186. ** DESCRIPTION: DsParser parses a symbol of expression read
  187. **              from inport.
  188. ** RETURNS:     TRUE, when symbol is completed.
  189. **              FALSE, when EOF is encountered.
  190. **              DOT, when a dot is found.
  191. **              PARCLOSE, when a ')' or ']' is found.
  192. **************************************************************/
  193. int PASCAL DsParser()
  194. {
  195.     register int token;
  196.  
  197.     token=DsLex();
  198.     switch(token)
  199.     {
  200.     case EOFTOKEN:  yylval=Q_eof;return FALSE;
  201.  
  202.     case POSITIVE:  if (DsLex()!=NUMBERT) DSLERROR(ERRNUM);
  203.                     return TRUE;
  204.  
  205.     case NEGATIVE:  if (DsLex()!=NUMBERT) DSLERROR(ERRNUM);
  206.                     switch(TAGpart(yylval))
  207.                     {
  208.                     case TYPE_INT:  INTpart(yylval) = -INTpart(yylval); break;
  209.                     case TYPE_FLT:  yylval->dat.rv = -yylval->dat.rv; break;
  210.                     default:        TAGpart(yylval)=TYPE_BIGN;         break;
  211.                     }
  212.                     return TRUE;
  213.  
  214.     case DOT:       return DOT;
  215.  
  216.     case PAROPEN:   yylval=DsReadList();
  217.                     return TRUE;
  218.  
  219.     case PARCLOSE:  return PARCLOSE;
  220.  
  221.     case BRACKETPAR:yylval=DsReadList();
  222.                     if (ISTRUE(yylval)) yylval=Ds_lstvec(yylval);
  223.                     return TRUE;
  224.  
  225.     case SQUOTE:    if (DsParser()==TRUE)
  226.                     {
  227.                         yylval=LIST(Q_quote,yylval);
  228.                         return TRUE;
  229.                     }
  230.                     else
  231.                     {            
  232.                         BIGBUF[0]='\0';
  233.                         DSLERROR(ERRQUO);
  234.                     }
  235.  
  236.     case BACKQUOTE:
  237.     case COMMA:
  238.     case COMMAAT:   DSLERROR(ERRNOT);
  239.  
  240.     case OBJECTID:
  241.     case STRING:
  242.     case SYM_KEY:
  243.     case TIMESTAMP:
  244.     case NUMBERT:
  245.     case BOOLEAN:
  246.     case CHARACTER: return TRUE;           /*** simple types ***/
  247.  
  248.     default: DSLERROR(ERRPINT);
  249.     }
  250.     return FALSE;            /* Avoids compiler warning */
  251. }
  252.  
  253.  
  254. /**************************************************************
  255. ** NAME:        DsReadList
  256. ** SYNOPSIS:    CELP DsReadList()
  257. ** DESCRIPTION: Readlist calls repeately the DsParser to read
  258. **              in all the elements of the list until a
  259. **              PARCLOSE is found.
  260. ** RETURNS:     The pointer to the new list.
  261. **************************************************************/
  262. CELP PASCAL DsReadList()
  263. {
  264.     CELP f,lp;
  265.  
  266.     f=lp=NIL;
  267.     while (1)
  268.     {
  269.         switch (DsParser())
  270.         {
  271.         case EOFTOKEN:
  272.             DSVERROR(ERREOF);
  273.  
  274.         case DOT:
  275.             if (DsParser()==TRUE) /* next part */
  276.             {
  277.                 if (ISTRUE(lp))
  278.                     CDRpart(lp)=yylval;
  279.                 else
  280.                     f=lp=yylval;
  281.             }
  282.             else
  283.                 DSERROR(ERRDOT,NIL);
  284.             break;
  285.  
  286.         case TRUE:
  287.             if (ISTRUE(lp))
  288.                 lp=CDRpart(lp)=DsCons1(yylval);
  289.             else
  290.                 lp=f=DsCons1(yylval);
  291.             break;
  292.  
  293.         case PARCLOSE:
  294.             return(f);
  295.         }
  296.     }
  297. }
  298.  
  299.  
  300. /**************************************************************
  301. ** NAME:        DsLex
  302. ** SYNOPSIS:    int DsLex()
  303. ** DESCRIPTION: DsLex reads a token from inport.
  304. ** RETURNS:     An token number.
  305. **************************************************************/
  306. int PASCAL DsLex()
  307. {
  308.     int c;
  309.  
  310.     p=(BYTE*)BIGBUF;
  311.     while (1)
  312.     {
  313.         switch(c=INPCC)
  314.         {
  315.         case EOF: return EOFTOKEN;                                     /* EOF */
  316.         case ' ' :
  317.         case '\n':
  318.         case '\t':
  319.         case '\r':
  320.             break;
  321.  
  322.         case ';' :
  323.             while((c=INPCC)!=EOL)                 /* Crunch until end of line */
  324.                 if (c==EOF)
  325.                     return EOFTOKEN;                   /* or an EOF! is found */
  326.             break;
  327.  
  328.         case '[' :
  329.         case '(' :
  330.             return PAROPEN;
  331.  
  332.         case ']' :
  333.         case ')' :
  334.             return PARCLOSE;
  335.  
  336.         case '.' :
  337.             if (FLOATC(TESTC))
  338.         {
  339.         *p++=(BYTE)c;
  340.         DsGetWord();
  341.                 yylval=DsStrReal(BIGBUF);
  342.                 return NUMBER;
  343.         }
  344.             return DOT;
  345.  
  346.         case '-' :
  347.             if (NUMC(TESTC))          /* Look at value of next char in stream */
  348.                 return NEGATIVE;
  349.         goto symbol;
  350.  
  351.         case '+' :
  352.             if (NUMC(TESTC))          /* Look at value of next char in stream */
  353.                 return(POSITIVE);
  354.         goto symbol;
  355.  
  356.         case '\'':
  357.             return SQUOTE;
  358.  
  359.         case '`' :
  360.             return BACKQUOTE;
  361.  
  362.         case ',' :
  363.             if (TESTC!='@')
  364.                 return COMMA;
  365.             else
  366.             {
  367.                 INPCC;
  368.                 return COMMAAT;
  369.             }
  370.  
  371.         case '#' :
  372.             return DsSpecial();
  373.  
  374.         case '"' :
  375.             return DsReadString();
  376.  
  377.         case '0' :
  378.         case '1' :
  379.         case '2' :
  380.         case '3' :
  381.         case '4' :
  382.         case '5' :
  383.         case '6' :
  384.         case '7' :
  385.         case '8' :
  386.         case '9' :
  387.             *p++=(BYTE)c;
  388.             return (DsReadNumber(10));
  389.  
  390.         default:
  391.     symbol:
  392.             *p++=(BYTE)c;
  393.             DsGetWord();                            /* get remainder of token */
  394.             yylval=DsSymbol(strupr(BIGBUF));              /* store identifier */
  395.             return(SYM_KEY);                         /* Its a symbol or a key */
  396.         }
  397.     }
  398. }
  399.  
  400.  
  401. /**************************************************************
  402. ** NAME:        DsSpecial
  403. ** SYNOPSIS:    int DsSpecial()
  404. ** DESCRIPTION: DsSpecial reads a special symbol.
  405. **              A special starts with '#'.
  406. ** RETURNS:     An token number.
  407. **************************************************************/
  408. int PASCAL DsSpecial()
  409. {
  410.     register int c=INPCC;
  411.  
  412.     switch(c)
  413.     {
  414.     case EOF:
  415.         DSLERROR(ERREOF);
  416.  
  417.     case '!' :
  418.         DsReadNumber(16);
  419.         TAGpart(yylval)=TYPE_OID;
  420.         return OBJECTID;
  421.  
  422.     case '@' :
  423.         DsGetWord();
  424.         TMSCEL(yylval,BIGBUF);
  425.         return TIMESTAMP;
  426.  
  427.     case 'f' :
  428.     case 'F' :
  429.         yylval=Q_false;
  430.         return BOOLEAN;
  431.  
  432.     case 't' :
  433.     case 'T' :
  434.         yylval=Q_true;
  435.         return BOOLEAN;
  436.  
  437.     case 'b' :
  438.     case 'B' :
  439.         return(DsReadNumber(2));
  440.  
  441.     case 'o' :
  442.     case 'O' :
  443.         return(DsReadNumber(8));
  444.  
  445.     case 'd' :
  446.     case 'D' :
  447.         return(DsReadNumber(10));
  448.  
  449.     case 'x' :
  450.     case 'X' :
  451.         return(DsReadNumber(16));
  452.  
  453.     case '\\' :
  454.         DsGetWord();                                     /* get rest of token */
  455.         c=BIGBUF[0];
  456.         if (c=='\0')      /* Revised report preferres #\space but some use #\ */
  457.             c=' ';                                  /* See page 24 of r3.99rs */
  458.         else
  459.             if (BIGBUF[1]!='\0')/* string after #\ is longer than 1 character */
  460.             {
  461.                 p=(BYTE *)strupr(BIGBUF);
  462.                 if (!strcmp(p,"SPACE"))          c=' ';
  463.                 else if (!strcmp(p,"NEWLINE"))   c='\n';
  464.                 else if (!strcmp(p,"TAB"))       c='\t';   /* These are extra */
  465.                 else if (!strcmp(p,"BELL"))      c=BELL;   /* These are extra */
  466.                 else if (!strcmp(p,"BACKSPACE")) c='\b';   /* These are extra */
  467.                 else if (!strcmp(p,"RETURN"))    c='\r';   /* These are extra */
  468.                 else if (!strcmp(p,"FORMFEED"))  c='\f';   /* These are extra */
  469.                 else if (!strcmp(p,"ESCAPE"))    c='\27';
  470.                 else DSLERROR(ERRCHAR);
  471.             }
  472.         CHRCEL(yylval,c);
  473.         return(CHARACTER);
  474.  
  475.     case '[' :
  476.     case '(' :
  477.         return BRACKETPAR;
  478.  
  479.     default :
  480.     *p++='#';
  481.     *p++=(BYTE)c;
  482.         DsGetWord();                              /* get remainder of token */
  483.         yylval=DsSymbol(strupr(BIGBUF));        /* store identifier */
  484.         return(SYM_KEY);                         /* Its a symbol or a key */
  485.     }
  486. }
  487.  
  488.                   
  489. /**************************************************************
  490. ** NAME:        DsReadNumber
  491. ** SYNOPSIS:    int DsReadNumber(base)
  492. **              int base;       base number of integer.
  493. ** DESCRIPTION: Reads an integer number.
  494. ** RETURNS:     An token number.
  495. **************************************************************/
  496. int PASCAL DsReadNumber(base)
  497. int base;
  498. {
  499.     DsGetWord();                                 /* Get the rest of the token */
  500.     yylval=DsStrNumber(BIGBUF,base);
  501.     return NUMBERT;
  502. }
  503.  
  504. CELP PASCAL DsStrNumber(str,base)
  505. char *str;
  506. int base;
  507. {
  508.     char *q;
  509.     LONG res;
  510.  
  511.     if (str[0]=='#')
  512.     {
  513.     switch (toupper(str[1]))
  514.     {
  515.         case 'B': base=2;break;
  516.     case 'O': base=8;break;
  517.     case 'X': base=16;break;
  518.     case 'D': base=10;break;
  519.     default : DSLERROR(ERRCHARN);
  520.     }
  521.     str+=2;
  522.     }
  523.     if (base==10)
  524.     {
  525.         for (q=str; *q; q++)          /* Check if it has floating point chars */
  526.             if (base==10 && (*q=='e' || *q=='E' || *q=='.'))
  527.                 return DsStrReal(str);
  528.         if ((q-str)>9 && (GLOB(bignum)))             /* This is a BIG number! */
  529.             return DsStrBig(str);
  530.     }
  531.     errno=0;
  532.     res=strtol(str,&q,base);
  533.     if (*q) DSLERROR(ERRCHARN);
  534.     if (errno)                                           /* Overflow occurred */
  535.     {
  536.         if (base!=10) DSLERROR(ERRBASE);
  537.         return DsStrReal(str);               /* Try to read it as a FP number */
  538.     }
  539.     return DSINTCEL(res);
  540. }
  541.  
  542.                   
  543. /**************************************************************
  544. ** NAME:        read_real
  545. ** SYNOPSIS:    int read_real()
  546. ** DESCRIPTION: read_real reads an floating point number.
  547. ** RETURNS:     An token number.
  548. **************************************************************/
  549. CELP PASCAL DsStrReal(s)
  550. char *s;
  551. {
  552.     REAL r;
  553.  
  554.     errno=0;
  555.     r=strtod(s,&p);                                             /* convert it */
  556.     if (*p!=0 || errno)                /* not at end of string or RANGE error */
  557.          DSERROR(ERRNUMF,NIL);
  558.     return DSFLTCEL(r);                                      /* store in cell */
  559. }
  560.  
  561.  
  562. /**************************************************************
  563. ** NAME:        DsGetWord
  564. ** SYNOPSIS:    void DsGetWord();
  565. ** DESCRIPTION: This function reads the input, and stores it in
  566. **              BIGBUF until a whitespace character is found.
  567. ** RETURNS:     void
  568. **************************************************************/
  569. void PASCAL DsGetWord()
  570. {
  571.     register int c;
  572.     while (!WHITEC(c=INPCC))
  573.     *p++=(BYTE)c;
  574.     UNPCC(c);
  575.     *p='\0';                                     /* Oops read some whitespace */
  576. }
  577.  
  578.  
  579. /**************************************************************
  580. ** NAME:        DsReadString
  581. ** SYNOPSIS:    int DsReadString();
  582. ** DESCRIPTION: This function reads a SCHEME string. Escaped
  583. **              characters are \n (newline), \t (tab) and \\.
  584. ** RETURNS:     predefined token: STRING.
  585. **************************************************************/
  586. int PASCAL DsReadString()
  587. {
  588.     int c;
  589.     int i=0;
  590.  
  591.     c=INPCC;
  592.     while ((i<BIGMAX) && (c!='"'))
  593.     {
  594.         if (c==EOF) DSVERROR(ERREOF);
  595.         if (c=='\\')                                           /* escape key! */
  596.         {
  597.             switch(c=INPCC)       
  598.             {
  599.             case 'a': c=BELL;break;                    /* or escape sequences */
  600.             case 'b': c='\b';break;
  601.             case 't': c='\t';break;
  602.             case 'n': c='\n';break;
  603.             case 'f': c='\f';break;
  604.             case 'r': c='\r';break;
  605.         case '0':
  606.         case '1':
  607.         case '2':
  608.         case '3':
  609.         case '4':
  610.         case '5':
  611.         case '6':
  612.         case '7': i=(c-'0')<<6; c=INPCC;
  613.                   if (!OCTALC(c)) DSLERROR(ERROCTAL);
  614.                   i+=(c-'0')<<3;c=INPCC;
  615.               if (!OCTALC(c)) DSLERROR(ERROCTAL);
  616.                       c+=i-'0';break;
  617.             case EOF: DSVERROR(ERREOF);
  618.             }
  619.         }
  620.         *p++=(BYTE)c;
  621.         i++;
  622.     c=INPCC;
  623.     }
  624.     *p= '\0';                                                /* end of string */
  625.     if (c!='"')                       /* if not at end, crunch rest of string */
  626.     {
  627.         DSLERROR(ERRSTR);
  628.         while ((c=INPCC)!='"')
  629.         {
  630.             if (c==EOF) break;
  631.             if (c=='\\') INPCC;           /* discard char's after escape code */
  632.         }
  633.     }
  634.     STRCEL(yylval,BIGBUF);
  635.     return(STRING);
  636. }
  637.