home *** CD-ROM | disk | FTP | other *** search
/ GEMini Atari / GEMini_Atari_CD-ROM_Walnut_Creek_December_1993.iso / files / language / sbprolog / token.c < prev    next >
Encoding:
C/C++ Source or Header  |  1993-10-23  |  32.6 KB  |  883 lines
  1. /*  File        : Token.c
  2.     Author      : Richard A. O'Keefe
  3.     Modified by : Deeporn H. Beardsley & Saumya Debray
  4.     Updated     : Summer 1988
  5.     Purpose     : Tokenizer for SB-Prolog.
  6.  
  7. */
  8.  
  9. #ifdef  vms
  10. #include stdio
  11. #else
  12. #include <stdio.h>
  13. #endif
  14.  
  15. /* stuff defined to interface with SB-Prolog */
  16.  
  17. #include "builtin.h"
  18. #include <errno.h>
  19.  
  20. /*  We used to use an 8-bit character set under VMS, but 7-bit ASCII
  21.  *  elsewhere.  Now that DIS 8859/1 exists (a draft international
  22.  *  standard for an 8-bit extension of ASCII) we use that, and we are
  23.  *  in luck: it is almost identical to the VMS character set.
  24.  */
  25. #define AlphabetSize 256
  26. #define SBPMAXINT       268435455
  27.  
  28. extern  char *strcpy(/* CHAR_PTR, CHAR_PTR */);
  29. #define StrCpy(dst, src) (void)strcpy(dst, src)
  30. #define Printf           (void)printf
  31. #define Sprintf          (void)sprintf
  32. #define Fprintf          (void)fprintf
  33.  
  34. #define InRange(X,L,U) ((unsigned)((X)-(L)) <= (unsigned)((U)-(L)))
  35. #define IsLayout(X) InRange(InType(X), SPACE, EOLN)
  36.  
  37. /*  VERY IMPORTANT NOTE: I assume that the stdio library returns the value
  38.  *  EOF when character input hits the end of the file, and that this value
  39.  *  is actually the integer -1.  You will note the DigVal(), InType(), and
  40.  *  OuType() macros below, and there is a ChType() macro used in crack().
  41.  *  They all depend on this assumption.
  42.  */
  43.  
  44. #define DIGIT    0              /* 0 .. 9 */
  45. #define BREAK    1              /* _ */
  46. #define UPPER    2              /* A .. Z */
  47. #define LOWER    3              /* a .. z */
  48. #define SIGN     4              /* -/+*<=>#@$\^&~`:.? */
  49. #define NOBLE    5              /* !; (don't form compounds) */
  50. #define PUNCT    6              /* (),[]|{}% */
  51. #define ATMQT    7              /* ' (atom quote) */
  52. #define LISQT    8              /* " (list quote) */
  53. #define STRQT    9              /* $ (string quote) */
  54. #define CHRQT   10              /* ` (character quote, maybe) */
  55. #define TILDE   11              /* ~ (like character quote but buggy) */
  56. #define SPACE   12              /* layout and control chars */
  57. #define EOLN    13              /* line terminators ^J ^L */
  58. #define REALO   14              /* floating point number */
  59. #define EOFCH   15              /* end of file */
  60. #define ALPHA   DIGIT           /* any of digit, break, upper, lower */
  61. #define BEGIN   BREAK           /* atom left-paren pair */
  62. #define ENDCL   EOLN            /* end of clause token */
  63. #define RREAL    16        /* radix number(real) - overflowed */
  64. #define RDIGIT    17        /* radix number(int) */
  65.  
  66. #define InType(c)  (intab.chtype+1)[c]
  67. #define DigVal(c)  (digval+1)[c]
  68.  
  69. BYTE outqt[EOFCH+1];
  70.  
  71. struct CHARS
  72. {
  73.    int  eolcom;         /* End-of-line comment, default % */
  74.    int  endeol;         /* early terminator of eolcoms, default none */
  75.    int  begcom;         /* In-line comment start, default / */
  76.    int  astcom;         /* In-line comment second, default * */
  77.    int  endcom;         /* In-line comment finish, default / */
  78.    int  radix;          /* Radix character, default ' */
  79.    int  dpoint;         /* Decimal point, default . */
  80.    int  escape;         /* String escape character, default \ */
  81.    int  termin;         /* Terminates a clause */
  82.    CHAR chtype[AlphabetSize+1];
  83. };
  84.  
  85. struct CHARS intab =       /* Special character table */
  86. {
  87.    '%',                    /* eolcom: end of line comments */
  88.    -1,                     /* endeol: early end for eolcoms */
  89.    '/',                    /* begcom: in-line comments */
  90.    '*',                    /* astcom: in-line comments */
  91.    '/',                    /* endcom: in-line comments */
  92.    '\'',                   /* radix : radix separator */
  93.    '.',                    /* dpoint: decimal point */
  94.    -1,                     /* escape: string escape character */
  95.    '.',                    /* termin: ends clause, sign or solo */
  96.    {
  97.        EOFCH,                  /* really the -1th element of the table: */
  98.    /*  ^@      ^A      ^B      ^C      ^D      ^E      ^F      ^G      */
  99.        SPACE,  SPACE,  SPACE,  SPACE,  SPACE,  SPACE,  SPACE,  SPACE,
  100.    /*  ^H      ^I      ^J      ^K      ^L      ^M      ^N      ^O      */
  101.        SPACE,  SPACE,  EOLN,   SPACE,  EOLN,   SPACE,  SPACE,  SPACE,
  102.    /*  ^P      ^Q      ^R      ^S      ^T      ^U      ^V      ^W      */
  103.        SPACE,  SPACE,  SPACE,  SPACE,  SPACE,  SPACE,  SPACE,  SPACE,
  104.    /*  ^X      ^Y      ^Z      ^[      ^\      ^]      ^^      ^_      */
  105.        SPACE,  SPACE,  SPACE,  SPACE,  SPACE,  SPACE,  SPACE,  SPACE,
  106.    /*  sp      !       "       #       $       %       &       '       */
  107.        SPACE,  NOBLE,  LISQT,  SIGN,   LOWER,  PUNCT,  SIGN,   ATMQT,
  108.    /*  (       )       *       +       ,       -       .       /       */
  109.        PUNCT,  PUNCT,  SIGN,   SIGN,   PUNCT,  SIGN,   SIGN,   SIGN,
  110.    /*  0       1       2       3       4       5       6       7       */
  111.        DIGIT,  DIGIT,  DIGIT,  DIGIT,  DIGIT,  DIGIT,  DIGIT,  DIGIT,
  112.    /*  8       9       :       ;       <       =       >       ?       */
  113.        DIGIT,  DIGIT,  SIGN,   PUNCT,  SIGN,   SIGN,   SIGN,   SIGN,
  114.    /*  @       A       B       C       D       E       F       G       */
  115.        SIGN,   UPPER,  UPPER,  UPPER,  UPPER,  UPPER,  UPPER,  UPPER,
  116.    /*  H       I       J       K       L       M       N       O       */
  117.        UPPER,  UPPER,  UPPER,  UPPER,  UPPER,  UPPER,  UPPER,  UPPER,
  118.    /*  P       Q       R       S       T       U       V       W       */
  119.        UPPER,  UPPER,  UPPER,  UPPER,  UPPER,  UPPER,  UPPER,  UPPER,
  120.    /*  X       Y       Z       [       \       ]       ^       _       */
  121.        UPPER,  UPPER,  UPPER,  PUNCT,  SIGN,   PUNCT,  SIGN,   BREAK,
  122.    /*  `       a       b       c       d       e       f       g       */
  123.        SIGN,   LOWER,  LOWER,  LOWER,  LOWER,  LOWER,  LOWER,  LOWER,
  124.    /*  h       i       j       k       l       m       n       o       */
  125.        LOWER,  LOWER,  LOWER,  LOWER,  LOWER,  LOWER,  LOWER,  LOWER,
  126.    /*  p       q       r       s       t       u       v       w       */
  127.        LOWER,  LOWER,  LOWER,  LOWER,  LOWER,  LOWER,  LOWER,  LOWER,
  128.    /*  x       y       z       {       |       }       ~       ^?      */
  129.        LOWER,  LOWER,  LOWER,  PUNCT,  PUNCT,  PUNCT,  SIGN,   SPACE,
  130.    /*  128     129     130     131     132     133     134     135     */
  131.        SPACE,  SPACE,  SPACE,  SPACE,  SPACE,  SPACE,  SPACE,  SPACE,
  132.    /*  136     137     138     139     140     141     142     143     */
  133.        SPACE,  SPACE,  SPACE,  SPACE,  SPACE,  SPACE,  SPACE,  SPACE,
  134.    /*  144     145     146     147     148     149     150     151     */
  135.        SPACE,  SPACE,  SPACE,  SPACE,  SPACE,  SPACE,  SPACE,  SPACE,
  136.    /*  152     153     154     155     156     157     158     159     */
  137.        SPACE,  SPACE,  SPACE,  SPACE,  SPACE,  SPACE,  SPACE,  SPACE,
  138.    /*  NBSP    !-inv   cents   pounds  ching   yen     brobar  section */
  139.        SPACE,  SIGN,   SIGN,   SIGN,   SIGN,   SIGN,   SIGN,   SIGN,
  140.    /*  "accent copyr   -a ord  <<      nothook SHY     (reg)   ovbar   */
  141.        SIGN,   SIGN,   LOWER,  SIGN,   SIGN,   SIGN,   SIGN,   SIGN,
  142.    /*  degrees +/-     super 2 super 3 -       micron  pilcrow -       */
  143.        SIGN,   SIGN,   LOWER,  LOWER,  SIGN,   SIGN,   SIGN,   SIGN,
  144.    /*  ,       super 1 -o ord  >>      1/4     1/2     3/4     ?-inv   */
  145.        SIGN,   LOWER,  LOWER,  SIGN,   SIGN,   SIGN,   SIGN,   SIGN,
  146.    /*  `A      'A      ^A      ~A      "A      oA      AE      ,C      */
  147.        UPPER,  UPPER,  UPPER,  UPPER,  UPPER,  UPPER,  UPPER,  UPPER,
  148.    /*  `E      'E      ^E      "E      `I      'I      ^I      "I      */
  149.        UPPER,  UPPER,  UPPER,  UPPER,  UPPER,  UPPER,  UPPER,  UPPER,
  150.    /*  ETH     ~N      `O      'O      ^O      ~O      "O      x times */
  151. #ifdef  vms
  152.        UPPER,  UPPER,  UPPER,  UPPER,  UPPER,  UPPER,  UPPER,  UPPER,
  153. #else
  154.        UPPER,  UPPER,  UPPER,  UPPER,  UPPER,  UPPER,  UPPER,  SIGN,
  155. #endif
  156.    /*  /O      `U      'U      ^U      "U      'Y      THORN   ,B      */
  157.        UPPER,  UPPER,  UPPER,  UPPER,  UPPER,  UPPER,  UPPER,  LOWER,
  158.    /*  `a      'a      ^a      ~a      "a      oa      ae      ,c      */
  159.        LOWER,  LOWER,  LOWER,  LOWER,  LOWER,  LOWER,  LOWER,  LOWER,
  160.    /*  `e      'e      ^e      "e      `i      'i      ^i      "i      */
  161.        LOWER,  LOWER,  LOWER,  LOWER,  LOWER,  LOWER,  LOWER,  LOWER,
  162.    /*  eth     ~n      `o      'o      ^o      ~o      "o      -:-     */
  163. #ifdef  vms
  164.        LOWER,  LOWER,  LOWER,  LOWER,  LOWER,  LOWER,  LOWER,  LOWER,
  165. #else
  166.        LOWER,  LOWER,  LOWER,  LOWER,  LOWER,  LOWER,  LOWER,  SIGN,
  167. #endif
  168.    /*  /o      `u      'u      ^u      "u      'y      thorn  "y       */
  169. #ifdef  vms
  170.        LOWER,  LOWER,  LOWER,  LOWER,  LOWER,  LOWER,  LOWER,  SPACE
  171. #else
  172.        LOWER,  LOWER,  LOWER,  LOWER,  LOWER,  LOWER,  LOWER,  LOWER
  173. #endif
  174.    }
  175. };
  176.  
  177. CHAR digval[AlphabetSize+1] =
  178. {
  179.         99,                     /* really the -1th element of the table */
  180.     /*  ^@      ^A      ^B      ^C      ^D      ^E      ^F      ^G      */
  181.         99,     99,     99,     99,     99,     99,     99,     99,
  182.     /*  ^H      ^I      ^J      ^K      ^L      ^M      ^N      ^O      */
  183.         99,     99,     99,     99,     99,     99,     99,     99,
  184.     /*  ^P      ^Q      ^R      ^S      ^T      ^U      ^V      ^W      */
  185.         99,     99,     99,     99,     99,     99,     99,     99,
  186.     /*  ^X      ^Y      ^Z      ^[      ^\      ^]      ^^      ^_      */
  187.         99,     99,     99,     99,     99,     99,     99,     99,
  188.     /*  sp      !       "       #       $       %       &       '       */
  189.         99,     99,     99,     99,     99,     99,     99,     99,
  190.     /*  (       )       *       +       ,       -       .       /       */
  191.         99,     99,     99,     99,     99,     99,     99,     99,
  192.     /*  0       1       2       3       4       5       6       7       */
  193.         0,      1,      2,      3,      4,      5,      6,      7,
  194.     /*  8       9       :       ;       <       =       >       ?       */
  195.         8,      9,      99,     99,     99,     99,     99,     99,
  196.     /*  @       A       B       C       D       E       F       G       */
  197.         99,     10,     11,     12,     13,     14,     15,     99,
  198.     /*  H       I       J       K       L       M       N       O       */
  199.         99,     99,     99,     99,     99,     99,     99,     99,
  200.     /*  P       Q       R       S       T       U       V       W       */
  201.         99,     99,     99,     99,     99,     99,     99,     99,
  202.     /*  X       Y       Z       [       \       ]       ^       _       */
  203.         99,     99,     99,     99,     99,     99,     99,     0,  /*NB*/
  204.     /*  `       a       b       c       d       e       f       g       */
  205.         99,     10,     11,     12,     13,     14,     15,     99,
  206.     /*  h       i       j       k       l       m       n       o       */
  207.         99,     99,     99,     99,     99,     99,     99,     99,
  208.     /*  p       q       r       s       t       u       v       w       */
  209.         99,     99,     99,     99,     99,     99,     99,     99,
  210.     /*  x       y       z       {       |       }       ~       ^?      */
  211.         99,     99,     99,     99,     99,     99,     99,     99,
  212.     /*  128     129     130     131     132     133     134     135     */
  213.         99,     99,     99,     99,     99,     99,     99,     99,
  214.     /*  136     137     138     139     140     141     142     143     */
  215.         99,     99,     99,     99,     99,     99,     99,     99,
  216.     /*  144     145     146     147     148     149     150     151     */
  217.         99,     99,     99,     99,     99,     99,     99,     99,
  218.     /*  152     153     154     155     156     157     158     159     */
  219.         99,     99,     99,     99,     99,     99,     99,     99,
  220.     /*  160     161     162     163     164     165     166     167     */
  221.         99,     99,     99,     99,     99,     99,     99,     99,
  222.     /*  168     169     170(-a) 171     172     173     174     175     */
  223.         99,     99,     99,     99,     99,     99,     99,     99,
  224.     /*  176     177     178(2)  179(3)  180     181     182     183     */
  225.         99,     99,     2,      3,      99,     99,     99,     99,
  226.     /*  184     185(1)  186(-o) 187     188     189     190     191     */
  227.         99,     1,      99,     99,     99,     99,     99,     99,
  228.     /*  192     193     194     195     196     197     198     199     */
  229.         99,     99,     99,     99,     99,     99,     99,     99,
  230.     /*  200     201     202     203     204     205     206     207     */
  231.         99,     99,     99,     99,     99,     99,     99,     99,
  232.     /*  208     209     210     211     212     213     214     215     */
  233.         99,     99,     99,     99,     99,     99,     99,     99,
  234.     /*  216     217     218     219     220     221     222     223     */
  235.         99,     99,     99,     99,     99,     99,     99,     99,
  236.     /*  224     225     226     227     228     229     230     231     */
  237.         99,     99,     99,     99,     99,     99,     99,     99,
  238.     /*  232     233     234     235     236     237     238     239     */
  239.         99,     99,     99,     99,     99,     99,     99,     99,
  240.     /*  240     241     242     243     244     245     246     247     */
  241.         99,     99,     99,     99,     99,     99,     99,     99,
  242.     /*  248     249     250     251     252     253     254     255     */
  243.         99,     999,     99,     99,     99,     99,     99,     99
  244.     };
  245.  
  246.  
  247. /* values returned to calling program */
  248.  
  249. #define SPECIAL 0       /* puncuation , ( ) [ ] ... */
  250. #define VARO    1       /* type is a variable */
  251. #define FUNC    2    /* type is atom( */
  252. #define NUMBERO 3       /* type is a number */
  253. #define ATOMO   4       /* type is an atom */
  254. #define ENDCLS    5       /* END of clause but not file */
  255. #define USCORE  6       /* underscore '_' */
  256. #define SEMI    7    /* ; */
  257. #define BADEND  8       /* END of file, not end of clause */
  258. #define STRING  9       /* type is a char string */
  259.  
  260. int cNUMERO = 0, cATOMO   = 0, cFUNC = 0, cVARO   = 0, cUSCORE = 0,
  261.     cSTRING = 0, cSPECIAL = 0, cSEMI = 0, cENDCLS = 0, cENDPRG = 0;
  262.  
  263. extern LONG_PTR insert();
  264. static BYTE perm = PERM;
  265.  
  266. extern FILE *curr_in, *curr_out;    /* current input, output streams */
  267.  
  268.  
  269. void SyntaxError(message)
  270. CHAR_PTR message;
  271. {
  272.    Fprintf(stderr, "Syntax error: %s\n", message);
  273.    exit(1);
  274. }
  275.  
  276. /*  GetToken() reads a single token from the input stream and returns
  277.  *  its type, which is one of
  278.  *      DIGIT   -- a number
  279.  *      BEGIN   -- an atom( pair
  280.  *      LOWER   -- an atom
  281.  *      UPPER   -- a variable
  282.  *      PUNCT   -- a single punctuation mark
  283.  *      LISQT   -- a quoted list of character codes
  284.  *      STRQT   -- a quoted string
  285.  *      ENDCL   -- end of clause (normally '.\n').
  286.  *      EOFCH   -- signifies end-of-file.
  287.  *      RREAL   -- a real, from some radix notation, in double_v.
  288.  *      RDIGIT  -- an integer, from some radix notation, in rad_int.
  289.  *  In all cases except the last, the text of the token is in AtomStr.
  290.  *  There are two questions: between which pairs of adjacent tokens is
  291.  *  a space (a) necessary, (b) desirable?  There is an additional
  292.  *  dummy token type used by the output routines, namely
  293.  *      NOBLE   -- extra space is definitely not needed.
  294.  *  I leave it as an exercise for the reader to answer question (a).
  295.  *  Since this program is to produce output I find palatable (even if
  296.  *  it isn't exactly what I'd write myself), extra spaces are ok.  In
  297.  *  fact, the main use of this program is as an editor command, so it
  298.  *  is normal to do a bit of manual post-processing.  Question (b) is
  299.  *  the one to worry about then.  My answer is that a space is never
  300.  *  written
  301.  *      - after  PUNCT ( [ { |
  302.  *      - before PUNCT ) ] } | , <ENDCL>
  303.  *  is written after comma only sometimes, and is otherwise always
  304.  *  written.  The variable lastput thus takes these values:
  305.  *      ALPHA   -- put a space except before PUNCT
  306.  *      SIGN    -- as alpha, but different so ENDCL knows to put a space.
  307.  *      NOBLE   -- don't put a space
  308.  *      ENDCL   -- just ended a clause
  309.  *      EOFCH   -- at beginning of file
  310.  */
  311.  
  312. int     lastc = ' ';    /* previous character */
  313. #define MaxStrLen      1000 
  314. BYTE    AtomStr[MaxStrLen+20];
  315. LONG    list_p;
  316. int     rtnint;
  317. double  double_v;
  318. LONG    rad_int;
  319.  
  320. CHAR    tok2long[] = "token too long";
  321. CHAR    eofinrem[] = "end of file in comment";
  322. CHAR    badexpt[]  = "bad exponent";
  323. CHAR    badradix[] = "radix > 36";
  324.  
  325.  
  326. /*  read_character(FILE* card, BYTE q)
  327.  *  reads one character from a quoted atom, list, string, or character.
  328.  *  Doubled quotes are read as single characters, otherwise a
  329.  *  quote is returned as -1 and lastc is set to the next character.
  330.  *  If the input syntax has character escapes, they are processed.
  331.  *  Note that many more character escape sequences are accepted than
  332.  *  are generated.  There is a divergence from C: \xhh sequences are
  333.  *  two hexadecimal digits long, not three.
  334.  *  Note that the \c and \<space> sequences combine to make a pretty
  335.  *  way of continuing strings.  Do it like this:
  336.  *      "This is a string, which \c
  337.  *     \ has to be continued over \c
  338.  *     \ several lines.\n".
  339.  */
  340.  
  341. int read_character(card, q)
  342. register FILE *card;
  343. register int q;
  344. {
  345.    register int c;
  346.  
  347.    c = getc(card);
  348. BACK:
  349.    if (c < 0) {
  350. DOERR:
  351.       if (q < 0)
  352.          SyntaxError("end of file in character constant");
  353.       else {
  354.          CHAR message[80];
  355.          Sprintf(message, "end of file in %cquoted%c constant", q, q);
  356.          SyntaxError(message);
  357.       }
  358.    }
  359.    if (c == q) {
  360.       c = getc(card);
  361.       if (c == q)
  362.      return c;
  363.       lastc = c;
  364.       return -1;
  365.    } else if (c != intab.escape)
  366.       return c;
  367.  
  368.    /*  If we get here, we have read the "\" of an escape sequence  */
  369.  
  370.    c = getc(card);
  371.    switch (c) {
  372.       case EOF:
  373.      clearerr(curr_in);
  374.      goto DOERR;
  375.       case 'n':  case 'N':         /* newline */
  376.          return 10;
  377.       case 't':  case 'T':         /* tab */
  378.          return  9;
  379.       case 'r':  case 'R':         /* reeturn */
  380.          return 13;
  381.       case 'v':  case 'V':         /* vertical tab */
  382.          return 11;
  383.       case 'b':  case 'B':         /* backspace */
  384.          return  8;
  385.       case 'f':  case 'F':         /* formfeed */
  386.          return 12;
  387.       case 'e':  case 'E':         /* escape */
  388.          return 27;
  389.       case 'd':  case 'D':         /* delete */
  390.          return 127;
  391.       case 's':  case 'S':         /* space */
  392.          return 32;
  393.       case 'a':  case 'A':         /* alarm */
  394.          return  7;
  395.       case '^':                    /* control */
  396.          c = getc(card);
  397.          if (c < 0)
  398.         goto DOERR;
  399.          return (c == '?' ? 127 : c&31);
  400.       case 'c':  case 'C':         /* continuation */
  401.          while (IsLayout(c = getc(card))) 
  402.         ;
  403.          goto BACK;
  404.       case 'x':  case 'X':         /* hexadecimal */
  405.          {  int i, n;
  406.             for (n = 0, i = 2; --i >= 0; n = (n<<4) + DigVal(c))
  407.                if (DigVal(c = getc(card)) >= 16) {
  408.                   if (c < 0)
  409.                  goto DOERR;
  410.                   (void)ungetc(c, card);
  411.                   break;
  412.                }
  413.             return (n & 255);
  414.          }
  415.       case 'o':  case 'O':         /* octal */
  416.          c = getc(card);
  417.          if (DigVal(c) >= 8) {
  418.             if (c < 0)
  419.            goto DOERR;
  420.             (void)ungetc(c, card);
  421.             return 0;
  422.          }
  423.       case '0':  case '1':  case '2':  case '3':
  424.       case '4':  case '5':  case '6':  case '7':
  425.          {  int i, n;
  426.             for (n = c-'0', i = 2; --i >= 0; n = (n<<3) + DigVal(c))
  427.                if (DigVal(c = getc(card)) >= 8) {
  428.                   if (c < 0)
  429.                  goto DOERR;
  430.                   (void)ungetc(c, card);
  431.                   break;
  432.                }
  433.             return (n & 255);
  434.          }
  435.       default:
  436.          if (!IsLayout(c))
  437.         return c;
  438.          c = getc(card);
  439.          goto BACK;
  440.    }
  441. } 
  442.  
  443.  
  444. /*  com0plain(card, endeol)
  445.  *  These comments have the form
  446.  *      <eolcom> <char>* <newline>                      {PUNCT}
  447.  *  or  <eolcom><eolcom> <char>* <newline>              {SIGN }
  448.  *  depending on the classification of <eolcom>.  Note that we could
  449.  *  handle ADA comments with no trouble at all.  There was a Pop-2
  450.  *  dialect which had end-of-line comments using "!" where the comment
  451.  *  could also be terminated by "!".  You could obtain the effect of
  452.  *  including a "!" in the comment by doubling it, but what you had
  453.  *  then was of course two comments.  The endeol parameter of this
  454.  *  function allows the handling of comments like that which can be
  455.  *  terminated either by a new-line character or an <endeol>, whichever
  456.  *  comes first.  For ordinary purposes, endeol = -1 will do fine.
  457.  *  When this is called, the initial <eolcom>s have been consumed.
  458.  *  We return the first character after the comment.
  459.  *  If the end of the source file is encountered, we do not treat it
  460.  *  as an error, but quietly close the comment and return EOF as the
  461.  *  "FOLLOWing" character.
  462.  */
  463.  
  464. int com0plain(card, endeol)
  465. register FILE *card;        /* source file */
  466. register int endeol;        /* The closing character "!" */
  467. {
  468.    register int c;
  469.  
  470.    while ((c = getc(card)) >= 0 && c != '\n' && c != endeol)
  471.       ;
  472.    if (c >= 0)
  473.       c = getc(card);
  474.    return c;
  475. }
  476.  
  477.  
  478. /*  The states in the next two functions are
  479.  *      0       - after an uninteresting character
  480.  *      1       - after an "astcom"
  481.  *      2       - after a  "begcom"
  482.  *  Assuming begcom = "(", astom = "#", endcom = ")",
  483.  *  com2plain will accept "(#)" as a complete comment.  This can
  484.  *  be changed by initialising the state to 0 rather than 1.
  485.  *  The same is true of com2nest, which accepts "(#(#)#) as a
  486.  *  complete comment.  Changing it would be rather harder.
  487.  *  Fixing the bug where the closing <astcom> is copied if it is
  488.  *  not an asterisk may entail rejecting "(#)".
  489.  */
  490.  
  491. /*  com2plain(card, astcom, endcom)
  492.  *  handles PL/I-style comments, that is, comments which begin with
  493.  *  a pair of characters <begcom><astcom> and end with a pair of
  494.  *  chracters <astcom><endcom>, where nesting is not allowed.  For
  495.  *  example, if we take begcom='(', astcom='*', endcom=')' as in
  496.  *  Pascal, the comment "(* not a (* plain *)^ comment *) ends at
  497.  *  the "^".
  498.  *  For this kind of comment, it is perfectly sensible for any of
  499.  *  the characters to be equal.  For example, if all three of the
  500.  *  bracket characters are "#", then "## stuff ##" is a comment.
  501.  *  When this is called, the initial <begcom><astcom> has been consumed.
  502.  */
  503.  
  504. void com2plain(card, astcom, endcom)
  505. register FILE *card;        /* source file */
  506. int astcom;                 /* The asterisk character "*" */
  507. int endcom;                 /* The closing character "/" */
  508. {
  509.    register int c;
  510.    register int state;
  511.  
  512.    for (state = 0; (c = getc(card)) >= 0; ) {
  513.       if (c == endcom && state)
  514.      break;
  515.       state = c == astcom;
  516.    }
  517.    if (c < 0)
  518.       SyntaxError(eofinrem);
  519. }
  520.  
  521.  
  522. int GetToken()
  523. {
  524.    register FILE *card = curr_in;
  525.    register BYTE_PTR s = AtomStr;
  526.    register int  c, d;
  527.    register int  n = MaxStrLen;
  528.    LONG     oldv = 0, newv = 0; 
  529.    LONG_PTR newpair, list_head, stack_top;
  530.  
  531.    c = lastc;
  532. START:
  533.    switch (InType(c)) {
  534.       case DIGIT:
  535.          /* The FOLLOWing kinds of numbers exist:
  536.           * (1) unsigned decimal integers: d+
  537.           * (2) unsigned based integers: d+Ro+[R]
  538.           * (3) unsigned floats: d* [. d*] [e +/-] d+
  539.           * (4) characters: 0Rc[R]
  540.           * We allow underscores in numbers too, ignoring them.
  541.           */
  542.          do {
  543.             if (c != '_')
  544.            *s++ = c;
  545.             c = getc(card);
  546.          } while (InType(c) <= BREAK);
  547.          if (c == intab.radix) { 
  548.             *s = 0;
  549.             for (d = 0, s = AtomStr; c = *s++; ) {
  550.                d = d*10-'0'+c;
  551.                if (d > 36)
  552.           SyntaxError(badradix);
  553.             }
  554.             if (d == 0) {       /*  0'c['] is a character code  */
  555.                d = read_character(card, -1);
  556.                Sprintf(AtomStr, "%d", d);
  557.                d = getc(card);
  558.                lastc = d == intab.radix ? getc(card) : d;
  559.                return DIGIT;
  560.             }
  561.             while (c = getc(card), DigVal(c) < 99)
  562.                if (c != '_') {
  563.           oldv = newv;
  564.           newv = newv*d + DigVal(c);
  565.           if (newv < oldv || newv > SBPMAXINT) {
  566.              Fprintf(stderr, "*** overflow in radix notation ***\n");
  567.              double_v = oldv*1.0*d + DigVal(c);
  568.              while (c = getc(card), DigVal(c) < 99)
  569.                         if (c != '_') 
  570.                double_v = double_v*d + DigVal(c);
  571.                      if (c == intab.radix)
  572.                 c = getc(card);
  573.                      lastc = c;
  574.              return RREAL;
  575.           }
  576.            }
  577. /*
  578.             Sprintf(AtomStr, "%ld", newv);
  579. */
  580.         rad_int = newv;
  581.             if (c == intab.radix)
  582.            c = getc(card);
  583.             lastc = c;
  584.             return RDIGIT;
  585.          } else if (c == intab.dpoint) {
  586.             d = getc(card);
  587.             if (InType(d) == DIGIT) {
  588. DECIMAL:       *s++ = '.';
  589.                do {
  590.                   if (d != '_')
  591.              *s++ = d;
  592.                   d = getc(card);
  593.                } while (InType(d) <= BREAK);
  594.                if ((d | 32) == 'e') {
  595.                   *s++ = 'E';
  596.                   d = getc(card);
  597.                   if (d == '-') {
  598.              *s++ = d;
  599.              d = getc(card);
  600.           } else if (d == '+')
  601.              d = getc(card);
  602.                   if (InType(d) > BREAK)
  603.              SyntaxError(badexpt);
  604.                   do {
  605.                      if (d != '_')
  606.                 *s++ = d;
  607.                      d = getc(card);
  608.                   } while (InType(d) <= BREAK);
  609.                }
  610.                c = d;
  611.                *s = 0;
  612.            lastc = c;
  613.                return REALO;
  614.             } else       /* c has not changed */
  615.                ungetc(d, card);
  616.          }
  617.          *s = 0;
  618.      lastc = c;
  619.          return DIGIT;
  620.  
  621.       case BREAK:
  622.       case UPPER:
  623.          do {
  624.             if (--n < 0)
  625.            SyntaxError(tok2long);
  626.             *s++ = c;
  627.         c = getc(card);
  628.          } while (InType(c) <= LOWER);
  629.          *s = 0;
  630.      lastc = c;
  631.          rtnint = (int)(s - AtomStr);
  632.          return UPPER;
  633.  
  634.       case LOWER:
  635.           do {
  636.              if (--n < 0) SyntaxError(tok2long);
  637.              *s++ = c;
  638.          c = getc(card);
  639.           } while (InType(c) <= LOWER);
  640.           *s = 0;
  641. SYMBOL:   if (c == '(') {
  642.              lastc = getc(card);
  643.              rtnint = (int)(s - AtomStr);
  644.              return BEGIN;
  645.           } else {
  646.              lastc = c;
  647.              rtnint = (int)(s - AtomStr);
  648.              return LOWER;
  649.           }
  650.  
  651.       case SIGN:
  652.           *s = c;
  653.       d = getc(card);
  654.           if (c == intab.begcom && d == intab.astcom) {
  655. ASTCOM:      com2plain(card, d, intab.endcom);
  656.              c = getc(card);
  657.              goto START;
  658.           } else if (c == intab.dpoint && InType(d) == DIGIT) {
  659.              *s++ = '0';
  660.              goto DECIMAL;
  661.           }
  662.           while (InType(d) == SIGN) {
  663.              if (--n == 0)
  664.         SyntaxError(tok2long);
  665.              *++s = d;
  666.          d = getc(card);
  667.           }
  668.           *++s = 0;
  669.           if (InType(d) >= SPACE && c == intab.termin && AtomStr[1] == 0) {
  670.              lastc = d;
  671.              return ENDCL;       /* i.e. '.' FOLLOWed by layout */
  672.           }
  673.           c = d;
  674.           goto SYMBOL;
  675.  
  676.       case NOBLE:
  677.           if (c == intab.termin) {
  678.              *s = 0;
  679.          lastc = ' ';
  680.              return ENDCL;
  681.           } else if (c == intab.eolcom) {
  682.              c = com0plain(card, intab.endeol);
  683.              goto START;
  684.           }
  685.           *s++ = c;
  686.       *s = 0;
  687.           lastc = c = getc(card);
  688.           goto SYMBOL;
  689.  
  690.       case PUNCT:
  691.          if (c == intab.termin) {
  692.             *s = 0;
  693.         lastc = ' ';
  694.             return ENDCL;
  695.          } else if (c == intab.eolcom) {
  696.             c = com0plain(card, intab.endeol);
  697.             goto START;
  698.          }
  699.          d = getc(card);
  700.          if (c == intab.begcom && d == intab.astcom)
  701.         goto ASTCOM;
  702.  
  703.          /*  If we arrive here, c is an ordinary punctuation mark  */
  704.  
  705.          if (c == '(')    /* need to distingusih between atom( and atom ( */
  706.             *s++ = ' ';
  707.          lastc = d;
  708.      *s++ = c;
  709.      *s = 0;
  710.          rtnint = (int)(s - AtomStr);
  711.          return PUNCT;
  712.  
  713.       case CHRQT:
  714.          /* `c[`] is read as an integer.
  715.            * Eventually we should treat characters as a distinct
  716.            * token type, so they can be generated on output.
  717.            * If the character quote, atom quote, list quote,
  718.            * or string quote is the radix character, we should
  719.            * generate 0'x notation, otherwise `x`.
  720.            */
  721.          d = read_character(card, -1);
  722.          Sprintf(AtomStr, "%d", d);
  723.          d = getc(card);
  724.          lastc = d == c ? getc(card) : d;
  725.          return DIGIT;
  726.  
  727.       case ATMQT:
  728.       case STRQT:
  729.          while ((d = read_character(card, c)) >= 0) {
  730.             if (--n < 0) SyntaxError(tok2long);
  731.             *s++ = d;
  732.          }
  733.          *s = 0;
  734.          rtnint = (int) (s - AtomStr);
  735.          c = lastc;
  736.          goto SYMBOL;
  737.  
  738.       case LISQT: 
  739.      /* check for potential heap overflow */
  740.      /*   (this will guarantee space for lists of up to 50 elements) */
  741.      stack_top = (breg < ereg) ? breg : ereg - ENV_SIZE(cpreg);
  742.      if (stack_top < hreg + 100) {
  743.         /* garbage_collection("GetToken"); */
  744.         if (stack_top < hreg + 100)    /* still too full */
  745.            quit("Heap overflow\n");
  746.      }
  747.  
  748.      list_head = newpair = hreg;
  749.          while ((d = read_character(card, c)) >= 0) {
  750.         hreg += 2;
  751.         *newpair++ = MAKEINT(d);
  752.         *newpair++ = (LONG)hreg | LIST_TAG; 
  753.      }
  754.      if (list_head == hreg)   /* null string */
  755.         list_p = nil_sym;
  756.      else {
  757.         *(--newpair) = nil_sym;
  758.         list_p = (LONG)list_head | LIST_TAG;
  759.      }
  760.      return LISQT;
  761.  
  762.       case EOLN:
  763.       case SPACE:
  764.          c = getc(card);
  765.          goto START;
  766.  
  767.       case EOFCH:
  768.      clearerr(curr_in);
  769.          return EOFCH;
  770.    }
  771.    Fprintf(stderr, "Internal error: InType(%d)==%d\n", c, InType(c));
  772.    abort();                /* There is no way we can get here */
  773.    /*NOTREACHED*/
  774. }
  775.  
  776.  
  777. void b_NEXT_TOKEN()
  778. {
  779.    register LONG     op;
  780.    register LONG_PTR top;
  781.    register FILE     *card = curr_in;
  782.    int      i, atoi(), oldnum, newnum;
  783.    int      len;
  784.    double   atof();
  785.    LONG     makefloat(), ptr;
  786.  
  787.    i = GetToken();
  788.    switch (i) {
  789.       case LOWER:
  790.      op = reg[1];  DEREF(op);  FOLLOW(op) = MAKEINT(ATOMO);
  791.          ptr = (LONG)insert(AtomStr, rtnint, 0, &perm) | CS_TAG;
  792.      op = reg[2];  DEREF(op);  FOLLOW(op) = ptr;
  793. cATOMO++;
  794.          break;
  795.       case BEGIN:
  796.      op = reg[1];  DEREF(op);  FOLLOW(op) = MAKEINT(FUNC);
  797.          ptr = (LONG)insert(AtomStr, rtnint, 0, &perm) | CS_TAG;
  798.      op = reg[2];  DEREF(op);  FOLLOW(op) = ptr;
  799. cFUNC++;
  800.          break;
  801.       case UPPER:
  802.          if (AtomStr[0] == '_' && AtomStr[1] == 0) {
  803.         op = reg[1];  DEREF(op);  FOLLOW(op) = MAKEINT(USCORE);
  804. cUSCORE++;
  805.          } else {
  806.         op = reg[1];  DEREF(op);  FOLLOW(op) = MAKEINT(VARO);
  807. cVARO++;
  808.      }
  809.      if (rtnint > 256) {
  810.         AtomStr[256] = 0;
  811.         rtnint = 256;
  812.         Fprintf(stderr, "*** Name of constant too long: %s\n", AtomStr);
  813.          }
  814.      ptr = (LONG)insert(AtomStr, rtnint, 0, &perm) | CS_TAG;
  815.      op = reg[2];  DEREF(op);  FOLLOW(op) = ptr;
  816.          break;
  817.       case REALO:
  818.      op = reg[2];  DEREF(op);
  819.      FOLLOW(op) = makefloat(atof(AtomStr));
  820.      op = reg[1];  DEREF(op);  FOLLOW(op) = MAKEINT(NUMBERO);
  821. cNUMERO++;
  822.          break;
  823.       case RREAL:
  824.      op = reg[2];  DEREF(op);  FOLLOW(op) = makefloat(double_v);
  825.      op = reg[1];  DEREF(op);  FOLLOW(op) = MAKEINT(NUMBERO);
  826. cNUMERO++;
  827.      break;
  828.       case RDIGIT:
  829. cNUMERO++;
  830.      op = reg[1];  DEREF(op);  FOLLOW(op) = MAKEINT(NUMBERO);
  831.      op = reg[2];  DEREF(op);  FOLLOW(op) = MAKEINT(rad_int);
  832.      break;
  833.       case DIGIT:
  834. cNUMERO++;
  835.      op = reg[1];  DEREF(op);  FOLLOW(op) = MAKEINT(NUMBERO);
  836.      op = reg[2];  DEREF(op); 
  837.      for (len = oldnum = newnum = 0; AtomStr[len] != 0; len++) {
  838.               oldnum = newnum;
  839.             newnum = newnum * 10 + DigVal(AtomStr[len]);
  840.             if (newnum < oldnum || newnum > SBPMAXINT) {
  841.            Fprintf(stderr, "*** overflow >> %s\n", AtomStr);
  842.            len = strlen(AtomStr);
  843.            AtomStr[len++] = '.';    
  844.            AtomStr[len++] = '0';
  845.            AtomStr[len] = 0;
  846.            FOLLOW(op) = makefloat(atof(AtomStr));
  847.            return;
  848.         }
  849.      }
  850.           FOLLOW(op) = MAKEINT(newnum);
  851.          break;
  852.       case LISQT:
  853.      op = reg[1];  DEREF(op);  FOLLOW(op) = MAKEINT(STRING);
  854.      op = reg[2];  DEREF(op);  FOLLOW(op) = list_p;
  855. cSTRING++;
  856.          break;
  857.       case PUNCT:
  858.          /* there are nine punctuation marks, */
  859.          /* ( , )  [ | ]  { ; }  */
  860.          /* % is listed as one, but isn't really. */
  861.          if (AtomStr[0] == ';') {
  862.         op = reg[1];  DEREF(op);  FOLLOW(op) = MAKEINT(SEMI);
  863. cSEMI++;
  864.          } else {
  865.         op = reg[1];  DEREF(op);  FOLLOW(op) = MAKEINT(SPECIAL);
  866. cSPECIAL++;
  867.             ptr = (LONG)insert(AtomStr, rtnint, 0, &perm) | CS_TAG;
  868.         op = reg[2];  DEREF(op);  FOLLOW(op) = ptr;
  869.          }
  870.          break;
  871.       case ENDCL:
  872.      op = reg[1];  DEREF(op);  FOLLOW(op) = MAKEINT(ENDCLS);
  873. cENDCLS++;
  874.          break;
  875.       case EOFCH:
  876.      op = reg[1];  DEREF(op);  FOLLOW(op) = MAKEINT(BADEND);
  877.          break;
  878.       default:
  879.          Fprintf(stderr, "Internal error %d %s\n", i, AtomStr);
  880.    }
  881. }
  882.  
  883.