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