home *** CD-ROM | disk | FTP | other *** search
/ APDL Public Domain 1 / APDL_PD1A.iso / program / language / gofer / Sources / c / input < prev    next >
Encoding:
Text File  |  1993-03-04  |  35.8 KB  |  1,244 lines
  1. /* --------------------------------------------------------------------------
  2.  * input.c:     Copyright (c) Mark P Jones 1991-1993.   All rights reserved.
  3.  *              See goferite.h for details and conditions of use etc...
  4.  *              Gofer version 2.28 January 1993
  5.  *
  6.  * Input functions, lexical analysis parsing etc...
  7.  * ------------------------------------------------------------------------*/
  8.  
  9. #include "prelude.h"
  10. #include "storage.h"
  11. #include "connect.h"
  12. #include "command.h"
  13. #include "errors.h"
  14. #include <ctype.h>
  15.  
  16. /* --------------------------------------------------------------------------
  17.  * Global data:
  18.  * ------------------------------------------------------------------------*/
  19.  
  20. List tyconDefns         = NIL;        /* type constructor definitions       */
  21. List typeInDefns     = NIL;        /* type synonym restrictions        */
  22. List valDefns         = NIL;        /* value definitions in script       */
  23. List opDefns         = NIL;        /* operator defns in script       */
  24. List classDefns      = NIL;        /* class defns in script        */
  25. List instDefns       = NIL;        /* instance defns in script       */
  26. List overDefns         = NIL;        /* overloaded implementation names */
  27.  
  28. Cell inputExpr         = NIL;        /* input expression           */
  29. Bool literateScripts = FALSE;        /* TRUE => default to lit scripts  */
  30. Bool literateErrors  = TRUE;        /* TRUE => report errs in lit scrs */
  31.  
  32. String repeatStr     = 0;        /* Repeat last expr           */
  33.  
  34. /* --------------------------------------------------------------------------
  35.  * Local function prototypes:
  36.  * ------------------------------------------------------------------------*/
  37.  
  38. static Void local fileInput      Args((String,Long));
  39. static Bool local literateMode      Args((String));
  40. static Void local skip          Args((Void));
  41. static Void local thisLineIs      Args((Int));
  42. static Void local newlineSkip      Args((Void));
  43. static Void local closeAnyInput   Args((Void));
  44.  
  45.        Int  yyparse        Args((Void)); /* can't stop yacc making this   */
  46.                       /* public, but don't advertise   */
  47.                       /* it in a header file.       */
  48.  
  49. static Void local endToken      Args((Void));
  50. static Text local readOperator      Args((Void));
  51. static Text local readIdent      Args((Void));
  52. static Cell local readNumber      Args((Void));
  53. static Cell local readChar      Args((Void));
  54. static Cell local readString      Args((Void));
  55. static Void local saveStrChr      Args((Char));
  56. static Cell local readAChar      Args((Bool));
  57.  
  58. static Bool local lazyReadMatches Args((String));
  59. static Cell local readEscapeChar  Args((Bool));
  60. static Void local skipGap      Args((Void));
  61. static Cell local readCtrlChar      Args((Void));
  62. static Cell local readOctChar      Args((Void));
  63. static Int  local readOctDigit      Args((Void));
  64. static Cell local readHexChar      Args((Void));
  65. static Int  local readHexDigit      Args((Void));
  66. static Cell local readDecChar      Args((Void));
  67.  
  68. static Void local goOffside      Args((Int));
  69. static Void local unOffside      Args((Void));
  70. static Bool local canUnOffside      Args((Void));
  71.  
  72. static Void local skipWhitespace  Args((Void));
  73. static Int  local yylex       Args((Void));
  74. static Int  local repeatLast      Args((Void));
  75.  
  76. static Void local parseInput      Args((Int));
  77.  
  78. /* --------------------------------------------------------------------------
  79.  * Text values for reserved words and special symbols:
  80.  * ------------------------------------------------------------------------*/
  81.  
  82. static Text textCase,    textOfK,    textData,    textType,   textIf;
  83. static Text textThen,    textElse,   textWhere,    textLet,    textIn;
  84. static Text textInfix,  textInfixl, textInfixr, textPrim;
  85.  
  86. static Text textCoco,    textEq,     textUpto,    textAs,     textLambda;
  87. static Text textBar,    textMinus,  textFrom,    textArrow,  textLazy;
  88.  
  89. static Text textClass,  textImplies,textInstance;
  90.  
  91. static Text textDefault, textDeriving, textHiding, textInterface;
  92. static Text textImport,  textModule,   textTo,     textRenaming;
  93.  
  94. static Cell varMinus;            /* (-)                   */
  95. static Cell varNegate;            /* negate               */
  96. static Cell varFlip;            /* flip                   */
  97. static Cell varFrom;            /* [_..]               */
  98. static Cell varFromTo;            /* [_.._]               */
  99. static Cell varFromThen;        /* [_,_..]               */
  100. static Cell varFromThenTo;        /* [_,_.._]               */
  101.  
  102. Text   textPlus;            /* (+)                   */
  103. Text   textMult;            /* (*)                   */
  104.  
  105. /* --------------------------------------------------------------------------
  106.  * Single character input routines:
  107.  *
  108.  * At the lowest level of input, characters are read one at a time, with the
  109.  * current character held in c0 and the following (lookahead) character in
  110.  * c1.    The corrdinates of c0 within the file are held in (column,row).
  111.  * The input stream is advanced by one character using the skip() function.
  112.  * ------------------------------------------------------------------------*/
  113.  
  114. #define TABSIZE    8               /* spacing between tabstops       */
  115.  
  116. #define NOTHING    0               /* what kind of input is being read?*/
  117. #define KEYBOARD   1               /* - keyboard/console?           */
  118. #define SCRIPTFILE 2               /* - script file            */
  119. #define PROJFILE   3               /* - project file           */
  120.  
  121. static Int    reading    = NOTHING;
  122.  
  123. static Target readSoFar;
  124. static Int    row, column, startColumn;
  125. static int    c0, c1;
  126. static FILE   *inputStream;
  127. static Bool   thisLiterate;
  128.  
  129. #if     USE_READLINE            /* for command line editors       */
  130. static  String currentLine;        /* editline or GNU readline       */
  131. static  String nextChar;
  132. #define nextConsoleChar()   (*nextChar=='\0' ? '\n' : *nextChar++)
  133. extern  Void add_history    Args((String));
  134. extern  String readline        Args((String));
  135.  
  136. #define PROMPTMAX        20        /* max chars in a sensible prompt  */
  137. static  String addSpace(str)        /* add trailing space to prompt       */
  138. String str; {
  139.     static char promptBuf[PROMPTMAX+2];
  140.     if (strlen(str)>PROMPTMAX)
  141.     return str;
  142.     strcpy(promptBuf,str);
  143.     strcat(promptBuf," ");
  144.     return promptBuf;
  145. }
  146. #else
  147. #define nextConsoleChar()   getc(stdin)
  148. #endif
  149.  
  150. static    Int litLines;               /* count defn lines in lit script   */
  151. #define DEFNCHAR  '>'               /* definition lines begin with this */
  152. static    Int lastLine;               /* records type of last line read:  */
  153. #define STARTLINE 0               /* - at start of file, none read    */
  154. #define BLANKLINE 1               /* - blank (may preceed definition) */
  155. #define TEXTLINE  2               /* - text comment           */
  156. #define DEFNLINE  3               /* - line containing definition       */
  157.  
  158. Void consoleInput(prompt)        /* prepare to input characters from*/
  159. String prompt; {            /* standard in (i.e. console/kbd)  */
  160.     reading    = KEYBOARD;        /* keyboard input is Line oriented,*/
  161.     c0        =            /* i.e. input terminated by '\n'   */
  162.     c1        = ' ';
  163.     column    = (-1);
  164.     row     = 0;
  165.  
  166. #if USE_READLINE
  167.     if (currentLine)
  168.     free(currentLine);
  169.     currentLine = readline(addSpace(prompt));
  170.     nextChar    = currentLine;
  171.     if (currentLine) {
  172.     if (*currentLine)
  173.         add_history(currentLine);
  174.     }
  175.     else
  176.     c0 = c1 = EOF;
  177. #else
  178.     printf("%s ",prompt);
  179.     fflush(stdout);
  180. #endif
  181. }
  182.  
  183. Void projInput(nm)               /* prepare to input characters from */
  184. String nm; {                   /* from named project file       */
  185.     if (inputStream = fopen(nm,"r")) {
  186.     reading = PROJFILE;
  187.     c0      = ' ';
  188.         c1      = '\n';
  189.         column  = 1;
  190.         row     = 0;
  191.     }
  192.     else {
  193.     ERROR(0) "Unable to open project file \"%s\"", nm
  194.     EEND;
  195.     }
  196. }
  197.  
  198. static Void local fileInput(nm,len)    /* prepare to input characters from*/
  199. String nm;                /* named file (specified length is */
  200. Long   len; {                /* used to set target for reading) */
  201.     if (inputStream = fopen(nm,"r")) {
  202.     reading      = SCRIPTFILE;
  203.     c0         = ' ';
  204.     c1         = '\n';
  205.     column         = 1;
  206.     row         = 0;
  207.     readSoFar    = 0;
  208.     lastLine     = STARTLINE;
  209.     litLines     = 0;
  210.     thisLiterate = literateMode(nm);
  211.     setGoal("Parsing", (Target)len);
  212.     }
  213.     else {
  214.     ERROR(0) "Unable to open file"
  215.     EEND;
  216.     }
  217. }
  218.  
  219. static Bool local literateMode(nm)    /* selecte literate mode for file  */
  220. String nm; {
  221.     String dot = 0;
  222.  
  223. #if !RISCOS
  224.     for (; *nm; ++nm)            /* look for last dot in file name  */
  225.     if (*nm == '.')
  226.         dot = nm+1;
  227.  
  228.     if (dot) {
  229.     if (strcmp(dot,"hs")==0   ||    /* .hs, .gs, .has, .gof files are  */
  230.         strcmp(dot,"gs")==0   ||    /* never literate scripts       */
  231.         strcmp(dot,"gof")==0  ||
  232.         strcmp(dot,"has")==0  ||
  233.         strcmp(dot,"prelude")==0)    /* special suffix for prelude files*/
  234.         return FALSE;
  235.  
  236.     if (strcmp(dot,"lhs")==0  ||    /* .lhs, .lgs, .verb, .lit scripts */
  237.         strcmp(dot,"lgs")==0  ||    /* are always literate scripts       */
  238.         strcmp(dot,"verb")==0 ||
  239.         strcmp(dot,"lit")==0)
  240.         return TRUE;
  241.     }
  242. #else
  243.     char *start = nm;
  244.     for (; *nm; ++nm)            /* look for last dot in file name  */
  245.     if (*nm == '.')
  246.         dot = nm+1;
  247.     if(dot)
  248.     {
  249.       char *prev = dot-1;
  250.       while(prev > start && *--prev != '.') ;
  251.       if(*prev == '.') ++prev;
  252.       if (namecmp(prev,"hs")
  253.       ||  namecmp(prev,"gs")
  254.       ||  namecmp(prev,"gof")
  255.       ||  namecmp(prev,"has")
  256.       ||  namecmp(prev,"prelude"))
  257.         return FALSE;
  258.       if (namecmp(prev,"lhs")
  259.       ||  namecmp(prev,"lgs")
  260.       ||  namecmp(prev,"lit")
  261.       ||  namecmp(prev,"verb"))
  262.         return TRUE;
  263.     }
  264. #endif
  265.     return literateScripts;        /* otherwise, use the default       */
  266. }
  267.  
  268. static Void local skip() {        /* move forward one char in input  */
  269.     if (c0!=EOF) {            /* stream, updating c0, c1, ...       */
  270.     if (c0=='\n') {            /* Adjusting cursor coords as nec. */
  271.         row++;
  272.         column=1;
  273.         if (reading==SCRIPTFILE)
  274.         soFar(readSoFar);
  275.     }
  276.     else if (c0=='\t')
  277.         column += TABSIZE - ((column-1)%TABSIZE);
  278.     else
  279.         column++;
  280.  
  281.     c0 = c1;
  282.     readSoFar++;
  283.  
  284.     if (c0==EOF) {
  285.         column = 0;
  286.         if (reading==SCRIPTFILE)
  287.         done();
  288.         closeAnyInput();
  289.     }
  290.     else if (reading==KEYBOARD) {
  291.         if (c0=='\n')
  292.         c1 = EOF;
  293.         else
  294.         c1 = nextConsoleChar();
  295.     }
  296.     else
  297.         c1 = getc(inputStream);
  298.     }
  299. }
  300.  
  301. static Void local thisLineIs(kind)    /* register kind of current line   */
  302. Int kind; {                /* & check for literate script errs*/
  303.     if (literateErrors && ((kind==DEFNLINE && lastLine==TEXTLINE) ||
  304.                (kind==TEXTLINE && lastLine==DEFNLINE))) {
  305.     ERROR(row) "Program line next to comment"
  306.     EEND;
  307.     }
  308.     lastLine = kind;
  309. }
  310.  
  311. static Void local newlineSkip() {      /* skip `\n' (supports lit scripts) */
  312.     if (reading==SCRIPTFILE && thisLiterate) {
  313.     do {
  314.         skip();
  315.         if (c0==DEFNCHAR) {        /* pass chars on definition lines   */
  316.         thisLineIs(DEFNLINE);  /* to lexer (w/o leading DEFNCHAR)  */
  317.         skip();
  318.         litLines++;
  319.         return;
  320.         }
  321.         while (c0==' ' || c0=='\t')/* maybe line is blank?           */
  322.         skip();
  323.         if (c0=='\n' || c0==EOF)
  324.         thisLineIs(BLANKLINE);
  325.         else {
  326.         thisLineIs(TEXTLINE);  /* otherwise it must be a comment   */
  327.         while (c0!='\n' && c0!=EOF)
  328.             skip();
  329.         }                   /* by now, c0=='\n' or c0==EOF       */
  330.     } while (c0!=EOF);           /* if new line, start again       */
  331.  
  332.     if (litLines==0 && literateErrors) {
  333.         ERROR(row) "Empty script - perhaps you forgot the `%c's?",
  334.                DEFNCHAR
  335.         EEND;
  336.     }
  337.     return;
  338.     }
  339.     skip();
  340. }
  341.  
  342. static Void local closeAnyInput() {    /* close input stream, if open      */
  343.     if (reading==SCRIPTFILE || reading==PROJFILE)
  344.     fclose(inputStream);
  345.     else if (reading==KEYBOARD)        /* or skip to end of console line  */
  346.     while (c0!=EOF)
  347.         skip();
  348.     reading=NOTHING;
  349. }
  350.  
  351. /* --------------------------------------------------------------------------
  352.  * Parser: Uses table driven parser generated from parser.y using yacc
  353.  * ------------------------------------------------------------------------*/
  354.  
  355. #include "parser.c"
  356.  
  357. /* --------------------------------------------------------------------------
  358.  * Single token input routines:
  359.  *
  360.  * The following routines read the values of particular kinds of token given
  361.  * that the first character of the token has already been located in c0 on
  362.  * entry to the routine.
  363.  * ------------------------------------------------------------------------*/
  364.  
  365. #define MAX_TOKEN        250
  366. #define startToken()        tokPos = 0
  367. #define saveTokenChar(c)    if (tokPos<MAX_TOKEN) saveChar(c); else ++tokPos
  368. #define saveChar(c)        tokenStr[tokPos++]=(c)
  369. #define SPECIALS        "(),;[]_{}"
  370. #define SYMBOLS         ":!#$%&*+./<=>?@\\^|-" /* For Haskell 1.1: `-' */
  371. #define PRESYMBOLS         "~"               /* should be a PRESYMBOL*/
  372.                                                    /* but including it here*/
  373.                                                    /* means we loose eg <- */
  374. #define isoneof(c,cs)        (strchr(cs,c)!=(char *)0)
  375. #define overflows(n,b,d,m)  (n > ((m)-(d))/(b))
  376.  
  377. static char tokenStr[MAX_TOKEN+1];    /* token buffer               */
  378. static Int  tokPos;            /* input position in buffer       */
  379. static Int  identType;            /* identifier type: CONID / VARID  */
  380. static Int  opType;            /* operator type  : CONOP / VAROP  */
  381.  
  382. static Void local endToken() {        /* check for token overflow       */
  383.     if (tokPos>MAX_TOKEN) {
  384.     ERROR(row) "Maximum token length (%d) exceeded", MAX_TOKEN
  385.     EEND;
  386.     }
  387.     tokenStr[tokPos] = '\0';
  388. }
  389.  
  390. static Text local readOperator() {    /* read operator symbol           */
  391.     startToken();
  392.     do {
  393.     saveTokenChar(c0);
  394.     skip();
  395.     } while (isascii(c0) && isoneof(c0,SYMBOLS));
  396.     opType = (tokenStr[0]==':' ? CONOP : VAROP);
  397.     endToken();
  398.     return findText(tokenStr);
  399. }
  400.  
  401. static Text local readIdent() {        /* read identifier           */
  402.     startToken();
  403.     do {
  404.     saveTokenChar(c0);
  405.     skip();
  406.     } while ((isascii(c0) && isalnum(c0)) || c0=='_' || c0=='\'');
  407.     endToken();
  408.     identType = isupper(tokenStr[0]) ? CONID : VARID;
  409.     return findText(tokenStr);
  410. }
  411.  
  412. static Cell local readNumber() {       /* read numeric constant        */
  413.     Int   n           = 0;
  414.     Bool  intTooLarge = FALSE;
  415.  
  416.     startToken();
  417.     do {
  418.     if (overflows(n,10,(c0-'0'),MAXPOSINT))
  419.         intTooLarge = TRUE;
  420.     n  = 10*n  + (c0-'0');
  421.     saveTokenChar(c0);
  422.     skip();
  423.     } while (isascii(c0) && isdigit(c0));
  424.  
  425.     if (c0!='.' || !isascii(c1) || !isdigit(c1)) {
  426.     endToken();
  427.     if (!intTooLarge)
  428.         return mkInt(n);
  429. #if HAS_FLOATS
  430.     if (intTooLarge)
  431.         return mkFloat(stringToFloat(tokenStr));
  432. #endif
  433.     ERROR(row) "Integer literal out of range"
  434.     EEND;
  435.     }
  436.  
  437.     saveTokenChar(c0);                /* save decimal point           */
  438.     skip();
  439.     do {                /* process fractional part ...       */
  440.     saveTokenChar(c0);
  441.     skip();
  442.     } while (isascii(c0) && isdigit(c0));
  443.  
  444.     if (c0=='e' || c0=='E') {        /* look for exponent part...       */
  445.     saveTokenChar('e');
  446.     skip();
  447.     if (c0=='-') {
  448.         saveTokenChar('-');
  449.         skip();
  450.     }
  451.     else if (c0=='+')
  452.         skip();
  453.  
  454.     if (!isascii(c0) || !isdigit(c0)) {
  455.         ERROR(row) "Missing digits in exponent"
  456.         EEND;
  457.     }
  458.     else {
  459.         do {
  460.         saveTokenChar(c0);
  461.         skip();
  462.         } while (isascii(c0) && isdigit(c0));
  463.     }
  464.     }
  465.  
  466.     endToken();
  467. #if !HAS_FLOATS
  468.     ERROR(row) "No floating point numbers in this implementation"
  469.     EEND;
  470. #endif
  471.  
  472.     return mkFloat(stringToFloat(tokenStr));
  473. }
  474.  
  475. static Cell local readChar() {           /* read character constant       */
  476.     Cell charRead;
  477.  
  478.     skip(/* '\'' */);
  479.     if (c0=='\'' || c0=='\n' || c0==EOF) {
  480.     ERROR(row) "Illegal character constant"
  481.     EEND;
  482.     }
  483.  
  484.     charRead = readAChar(FALSE);
  485.  
  486.     if (c0=='\'')
  487.     skip(/* '\'' */);
  488.     else {
  489.     ERROR(row) "Improperly terminated character constant"
  490.     EEND;
  491.     }
  492.     return charRead;
  493. }
  494.  
  495. static Cell local readString() {       /* read string literal           */
  496.     Cell c;
  497.  
  498.     startToken();
  499.     skip(/* '\"' */);
  500.     while (c0!='\"' && c0!='\n' && c0!=EOF) {
  501.     c = readAChar(TRUE);
  502.     if (nonNull(c))
  503.         saveStrChr(charOf(c));
  504.     }
  505.  
  506.     if (c0=='\"')
  507.     skip(/* '\"' */);
  508.     else {
  509.     ERROR(row) "improperly terminated string"
  510.     EEND;
  511.     }
  512.     endToken();
  513.     return mkStr(findText(tokenStr));
  514. }
  515.  
  516. static Void local saveStrChr(c)        /* save character in string       */
  517. Char c; {
  518.     if (c!='\0' && c!='\\') {           /* save non null char as single char*/
  519.     saveTokenChar(c);
  520.     }
  521.     else {                   /* save null char as TWO null chars */
  522.     if (tokPos+1<MAX_TOKEN) {
  523.         saveChar('\\');
  524.         if (c=='\\')
  525.         saveChar('\\');
  526.         else
  527.         saveChar('0');
  528.     }
  529.     }
  530. }
  531.  
  532. static Cell local readAChar(allowEmpty)/* read single char constant       */
  533. Bool allowEmpty; {               /* TRUE => enable use of \& and gaps*/
  534.     Cell c = mkChar(c0);
  535.  
  536.     if (c0=='\\')               /* escape character?           */
  537.     return readEscapeChar(allowEmpty);
  538.     if (!isprint(c0)) {
  539.     ERROR(row) "Non printable character in constant"
  540.     EEND;
  541.     }
  542.     skip();                   /* normal character?           */
  543.     return c;
  544. }
  545.  
  546. /* --------------------------------------------------------------------------
  547.  * Character escape code sequences:
  548.  * ------------------------------------------------------------------------*/
  549.  
  550. static struct {                /* table of special escape codes    */
  551.     char *codename;
  552.     int  codenumber;
  553. } escapes[] = {
  554.    {"a",    7}, {"b",     8}, {"f",   12}, {"n",   10},    /* common escapes  */
  555.    {"r",   13}, {"t",     9}, {"\\",'\\'}, {"\"",'\"'},
  556.    {"\'",'\''}, {"v",    11},
  557.    {"NUL",  0}, {"SOH",  1}, {"STX",  2}, {"ETX",  3},    /* ascii codenames */
  558.    {"EOT",  4}, {"ENQ",  5}, {"ACK",  6}, {"BEL",  7},
  559.    {"BS",   8}, {"HT",     9}, {"LF",  10}, {"VT",  11},
  560.    {"FF",  12}, {"CR",    13}, {"SO",  14}, {"SI",  15},
  561.    {"DLE", 16}, {"DC1", 17}, {"DC2", 18}, {"DC3", 19},
  562.    {"DC4", 20}, {"NAK", 21}, {"SYN", 22}, {"ETB", 23},
  563.    {"CAN", 24}, {"EM",    25}, {"SUB", 26}, {"ESC", 27},
  564.    {"FS",  28}, {"GS",    29}, {"RS",  30}, {"US",  31},
  565.    {"SP",  32}, {"DEL", 127},
  566.    {0,0}
  567. };
  568.  
  569. static Int  alreadyMatched;           /* Record portion of input stream   */
  570. static char alreadyRead[10];           /* that has been read w/o a match   */
  571.  
  572. static Bool local lazyReadMatches(s)   /* compare input stream with string */
  573. String s; {                   /* possibly using characters that   */
  574.     int i;                   /* have already been read       */
  575.  
  576.     for (i=0; i<alreadyMatched; ++i)
  577.     if (alreadyRead[i]!=s[i])
  578.         return FALSE;
  579.  
  580.     while (s[i] && s[i]==c0) {
  581.     alreadyRead[alreadyMatched++]=c0;
  582.     skip();
  583.     i++;
  584.     }
  585.  
  586.     return s[i]=='\0';
  587. }
  588.  
  589. static Cell local readEscapeChar(allowEmpty) /* read escape character       */
  590. Bool allowEmpty; {
  591.     int i=0;
  592.  
  593.     skip(/* '\\' */);
  594.     switch (c0) {
  595.     case '&'  : if (allowEmpty) {
  596.             skip();
  597.             return NIL;
  598.             }
  599.             ERROR(row) "Illegal use of \\& in character constant"
  600.             EEND;
  601.             break;/*NOTREACHED*/
  602.     case ' '  :
  603.     case '\n' :
  604.     case '\t' : if (allowEmpty) {
  605.             skipGap();
  606.             return NIL;
  607.             }
  608.             ERROR(row) "Illegal use of gap in character constant"
  609.             EEND;
  610.             break;
  611.     case '^'  : return readCtrlChar();
  612.     case 'o'  : return readOctChar();
  613.     case 'x'  : return readHexChar();
  614.     default   : if (isdigit(c0))
  615.             return readDecChar();
  616.     }
  617.  
  618.     for (alreadyMatched=0; escapes[i].codename; i++)
  619.     if (lazyReadMatches(escapes[i].codename))
  620.         return mkChar(escapes[i].codenumber);
  621.  
  622.     alreadyRead[alreadyMatched++] = c0;
  623.     alreadyRead[alreadyMatched++] = '\0';
  624.     ERROR(row) "Illegal character escape sequence \"\\%s\"",
  625.            alreadyRead
  626.     EEND;
  627.     return NIL;/*NOTREACHED*/
  628. }
  629.  
  630. static Void local skipGap() {        /* skip over gap in string literal */
  631.     do                    /* (simplified in Haskell 1.1)       */
  632.     skip();
  633.     while (c0==' ' || c0=='\t' || c0=='\n');
  634.     if (c0!='\\') {
  635.     ERROR(row) "Missing `\\' terminating string literal gap"
  636.     EEND;
  637.     }
  638.     skip(/* '\\' */);
  639. }
  640.  
  641. static Cell local readCtrlChar() {     /* read escape sequence \^x       */
  642.     static String controls = "@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
  643.     String which;
  644.  
  645.     skip(/* '^' */);
  646.     if ((which = strchr(controls,c0))==NULL) {
  647.     ERROR(row) "Unrecognised escape sequence `\\^%c'", c0
  648.     EEND;
  649.     }
  650.     skip();
  651.     return mkChar(which-controls);
  652. }
  653.  
  654. static Cell local readOctChar() {      /* read octal character constant    */
  655.     Int n = 0;
  656.     Int d;
  657.  
  658.     skip(/* 'o' */);
  659.     if ((d = readOctDigit())<0) {
  660.     ERROR(row) "Empty octal character escape"
  661.     EEND;
  662.     }
  663.     do {
  664.     if (overflows(n,8,d,MAXCHARVAL)) {
  665.         ERROR(row) "Octal character escape out of range"
  666.         EEND;
  667.     }
  668.     n = 8*n + d;
  669.     skip();
  670.     } while ((d = readOctDigit())>=0);
  671.  
  672.     return mkChar(n);
  673. }
  674.  
  675. static Int local readOctDigit() {      /* read single octal digit       */
  676.     if ('0'<=c0 && c0<='7')
  677.     return c0-'0';
  678.     return -1;
  679. }
  680.  
  681. static Cell local readHexChar() {      /* read hex character constant       */
  682.     Int n = 0;
  683.     Int d;
  684.  
  685.     skip(/* 'x' */);
  686.     if ((d = readHexDigit())<0) {
  687.     ERROR(row) "Empty hexadecimal character escape"
  688.     EEND;
  689.     }
  690.     do {
  691.     if (overflows(n,16,d,MAXCHARVAL)) {
  692.         ERROR(row) "Hexadecimal character escape out of range"
  693.         EEND;
  694.     }
  695.     n = 16*n + d;
  696.     skip();
  697.     } while ((d = readHexDigit())>=0);
  698.  
  699.     return mkChar(n);
  700. }
  701.  
  702. static Int local readHexDigit() {      /* read single hex digit        */
  703.     if ('0'<=c0 && c0<='9')
  704.     return c0-'0';
  705.     if ('A'<=c0 && c0<='F')
  706.     return 10 + (c0-'A');
  707.     if ('a'<=c0 && c0<='f')
  708.     return 10 + (c0-'a');
  709.     return -1;
  710. }
  711.  
  712. static Cell local readDecChar() {      /* read decimal character constant  */
  713.     Int n = 0;
  714.  
  715.     do {
  716.     if (overflows(n,10,(c0-'0'),MAXCHARVAL)) {
  717.         ERROR(row) "Decimal character escape out of range"
  718.         EEND;
  719.     }
  720.     n = 10*n + (c0-'0');
  721.     skip();
  722.     } while (isascii(c0) && isdigit(c0));
  723.  
  724.     return mkChar(n);
  725. }
  726.  
  727. /* --------------------------------------------------------------------------
  728.  * Produce printable representation of character:
  729.  * ------------------------------------------------------------------------*/
  730.  
  731. String unlexChar(c,quote)        /* return string representation of */
  732. Char c;                    /* character...               */
  733. Char quote; {                /* protect quote character       */
  734.     static char buffer[12];
  735.  
  736.     if (c<0)                /* deal with sign extended chars.. */
  737.     c += NUM_CHARS;
  738.  
  739.     if (isascii(c) && isprint(c)) {    /* normal printable character       */
  740.     if (c==quote) {            /* look for quote of approp. kind  */
  741.         buffer[0] = '\\';        
  742.         buffer[1] = c;
  743.         buffer[2] = '\0';
  744.     }
  745.     else {
  746.             buffer[0] = c;
  747.             buffer[1] = '\0';
  748.     }
  749.     }
  750.     else {                /* look for escape code           */
  751.         Int escs;
  752.         for (escs=0; escapes[escs].codename; escs++)
  753.         if (escapes[escs].codenumber==c) {
  754.         sprintf(buffer,"\\%s",escapes[escs].codename);
  755.         return buffer;
  756.         }
  757.         sprintf(buffer,"\\%d",c);    /* otherwise use numeric escape       */
  758.     }
  759.     return buffer;
  760. }
  761.  
  762. /* --------------------------------------------------------------------------
  763.  * Handle special types of input for use in interpreter:
  764.  * ------------------------------------------------------------------------*/
  765.  
  766. Command readCommand(cmds,start,sys)    /* read command at start of input  */
  767. struct cmd *cmds;            /* line in interpreter           */
  768. Char   start;                /* characters introducing a cmd    */
  769. Char   sys; {                /* character for shell escape       */
  770.     while (c0==' ' || c0 =='\t')
  771.     skip();
  772.  
  773.     if (c0=='\n')            /* look for blank command lines    */
  774.     return NOCMD;
  775.     if (c0==EOF)            /* look for end of input stream       */
  776.     return QUIT;
  777.     if (c0==sys) {            /* single character system escape  */
  778.     skip();
  779.     return SYSTEM;
  780.     }
  781.     if (c0==start && c1==sys) {        /* two character system escape       */
  782.     skip();
  783.     skip();
  784.     return SYSTEM;
  785.     }
  786.  
  787.     startToken();            /* All cmds start with start       */
  788.     if (c0==start)            /* except default (usually EVAL)   */
  789.     do {                /* which is empty           */
  790.         saveTokenChar(c0);
  791.         skip();
  792.     } while (c0!=' ' && c0!='\t' && c0!='\n' && c0!=EOF);
  793.     endToken();
  794.  
  795.     for (; cmds->cmdString; ++cmds)
  796.     if (strcmp((cmds->cmdString),tokenStr)==0 ||
  797.             (tokenStr[0]==start &&
  798.              tokenStr[1]==(cmds->cmdString)[1] &&
  799.              tokenStr[2]=='\0'))
  800.         return (cmds->cmdCode);
  801.     return BADCMD;
  802. }
  803.  
  804. String readFilename() {            /* Read filename from input (if any)*/
  805.     if (reading==PROJFILE)
  806.     skipWhitespace();
  807.     else
  808.     while (c0==' ' || c0=='\t')
  809.         skip();
  810.  
  811.     if (c0=='\n' || c0==EOF)           /* return null string at end of line*/
  812.     return 0;
  813.  
  814.     startToken();
  815.     while (c0!=' ' && c0!='\t' && c0!='\n' && c0!='\r' && c0!=EOF) {
  816.     saveTokenChar(c0);
  817.     skip();
  818.     }
  819.     endToken();
  820.  
  821.     return tokenStr;
  822. }
  823.  
  824. String readLine() {            /* Read command line from input       */
  825.     while (c0==' ' || c0=='\t')        /* skip leading whitespace       */
  826.     skip();
  827.  
  828.     startToken();
  829.     while (c0!='\n' && c0!=EOF) {
  830.     saveTokenChar(c0);
  831.     skip();
  832.     }
  833.     endToken();
  834.  
  835.     return tokenStr;
  836. }
  837.  
  838. /* --------------------------------------------------------------------------
  839.  * This lexer supports the Haskell layout rule:
  840.  *
  841.  * - Layout area bounded by { ... }, with `;'s in between.
  842.  * - A `{' is a HARD indentation and can only be matched by a corresponding
  843.  *   HARD '}'
  844.  * - Otherwise, if no `{' follows the keywords WHERE/LET or OF, a SOFT `{'
  845.  *   is inserted with the column number of the first token after the
  846.  *   WHERE/LET/OF keyword.
  847.  * - When a soft indentation is uppermost on the indetation stack with
  848.  *   column col' we insert:
  849.  *    `}'  in front of token with column<col' and pop indentation off stack,
  850.  *    `;'  in front of token with column==col'.
  851.  * ------------------------------------------------------------------------*/
  852.  
  853. #define MAXINDENT  100               /* maximum nesting of layout rule   */
  854. static    Int       layout[MAXINDENT+1];/* indentation stack           */
  855. #define HARD       (-1)            /* indicates hard indentation       */
  856. static    Int       indentDepth = (-1); /* current indentation nesting       */
  857.  
  858. static Void local goOffside(col)       /* insert offside marker        */
  859. Int col; {                   /* for specified column           */
  860.     if (indentDepth>=MAXINDENT) {
  861.     ERROR(row) "Too many levels of program nesting"
  862.     EEND;
  863.     }
  864.     layout[++indentDepth] = col;
  865. }
  866.  
  867. static Void local unOffside() {        /* leave layout rule area       */
  868.     indentDepth--;
  869. }
  870.  
  871. static Bool local canUnOffside() {     /* Decide if unoffside permitted    */
  872.     return indentDepth>=0 && layout[indentDepth]!=HARD;
  873. }
  874.  
  875. /* --------------------------------------------------------------------------
  876.  * Main tokeniser:
  877.  * ------------------------------------------------------------------------*/
  878.  
  879. static Void local skipWhitespace() {   /* skip over whitespace/comments    */
  880.  
  881. ws: while (c0==' ' || c0=='\t' || c0=='\r' || c0=='\f')
  882.     skip();
  883.  
  884.     if (c0=='\n') {               /* skip newline characters       */
  885.     newlineSkip();
  886.     goto ws;
  887.     }
  888.  
  889.     if (c0=='{' && c1=='-') {           /* (potentially) nested comment       */
  890.     Int nesting = 1;
  891.     Int origRow = row;           /* save original row number       */
  892.  
  893.         skip();
  894.         skip();
  895.     while (nesting>0 && c0!=EOF) {
  896.         if (c0=='{' && c1=='-') {
  897.         skip();
  898.         nesting++;
  899.         }
  900.         else if (c0=='-' && c1=='}') {
  901.         skip();
  902.         nesting--;
  903.         }
  904.  
  905.         if (c0=='\n')
  906.         newlineSkip();
  907.         else
  908.         skip();
  909.     }
  910.     if (nesting>0) {
  911.         ERROR(origRow) "Unterminated nested comment {- ..."
  912.         EEND;
  913.     }
  914.     goto ws;
  915.     }
  916.  
  917.     if (c0=='-' && c1=='-') {           /* one line comment           */
  918.     do
  919.         skip();
  920.     while (c0!='\n' && c0!=EOF);
  921.     if (c0=='\n')
  922.         newlineSkip();
  923.     goto ws;
  924.     }
  925. }
  926.  
  927. static Bool firstToken;            /* Set to TRUE for first token       */
  928. static Int  firstTokenIs;           /* ... with token value stored here */
  929.  
  930. static Int local yylex() {           /* Read next input token ...       */
  931.     static Bool insertOpen    = FALSE;
  932.     static Bool insertedToken = FALSE;
  933.     static Text textRepeat;
  934.  
  935. #define lookAhead(t) {skipWhitespace(); insertOpen = (c0!='{'); return t;}
  936.  
  937.     if (firstToken) {               /* Special case for first token       */
  938.     indentDepth   = (-1);
  939.     firstToken    = FALSE;
  940.     insertOpen    = FALSE;
  941.     insertedToken = FALSE;
  942.     if (reading==KEYBOARD)
  943.         textRepeat = findText(repeatStr);
  944.     return firstTokenIs;
  945.     }
  946.  
  947.     if (insertOpen) {               /* insert `soft' opening brace       */
  948.     insertOpen    = FALSE;
  949.     insertedToken = TRUE;
  950.     goOffside(column);
  951.     push(yylval = mkInt(row));
  952.     return '{';
  953.     }
  954.  
  955.     /* ----------------------------------------------------------------------
  956.      * Skip white space, and insert tokens to support layout rules as reqd.
  957.      * --------------------------------------------------------------------*/
  958.  
  959.     skipWhitespace();
  960.     startColumn = column;
  961.     push(yylval = mkInt(row));           /* default token value is line no.  */
  962.     /* subsequent changes to yylval must also set top() to the same value  */
  963.  
  964.     if (indentDepth>=0)            /* layout rule(s) active ?       */
  965.         if (insertedToken)           /* avoid inserting multiple `;'s    */
  966.         insertedToken = FALSE;     /* or putting `;' after `{'       */
  967.         else if (layout[indentDepth]!=HARD)
  968.         if (column<layout[indentDepth]) {
  969.         unOffside();
  970.         return '}';
  971.             }
  972.             else if (column==layout[indentDepth] && c0!=EOF) {
  973.                 insertedToken = TRUE;
  974.                 return ';';
  975.             }
  976.  
  977.     /* ----------------------------------------------------------------------
  978.      * Now try to identify token type as one of:
  979.      * - end of file character
  980.      * - Special character:  ( ) , ; [ ] _ { } `
  981.      * - Character constant
  982.      * - String Constant
  983.      * - Integer literal
  984.      * - Alphanum: reservedid, VARID or CONID
  985.      * - operator: reservedop, VAROP or CONOP
  986.      * --------------------------------------------------------------------*/
  987.  
  988.     switch (c0) {
  989.     case EOF  : return 0;
  990.  
  991.     case '('  : skip();
  992.             return '(';
  993.  
  994.     case ')'  : skip();
  995.             return ')';
  996.  
  997.     case ','  : skip();
  998.             return ',';
  999.  
  1000.     case ';'  : skip();
  1001.             return ';';
  1002.  
  1003.     case '['  : skip();
  1004.             return '[';
  1005.  
  1006.     case ']'  : skip();
  1007.             return ']';
  1008.  
  1009.     case '_'  : skip();
  1010.             return '_';
  1011.  
  1012.     case '{'  : goOffside(HARD);
  1013.             skip();
  1014.             return '{';
  1015.  
  1016.     case '}'  : if (indentDepth<0) {
  1017.             ERROR(row) "Misplaced `}'"
  1018.             EEND;
  1019.             }
  1020.             if (layout[indentDepth]==HARD)    /* skip over hard } */
  1021.             skip();
  1022.             unOffside();    /* otherwise, we have to insert a } */
  1023.             return '}';        /* to (try to) avoid an error...    */
  1024.  
  1025.     case '\'' : top() = yylval = readChar();
  1026.             return CHARLIT;
  1027.  
  1028.     case '\"' : top() = yylval = readString();
  1029.             return STRINGLIT;
  1030.  
  1031.     case '`'  : skip();
  1032.             return '`';
  1033.     }
  1034.  
  1035.     if (!(isascii(c0) && isprint(c0))) {
  1036.     ERROR(row) "Unrecognised character in column %d", column
  1037.     EEND;
  1038.     }
  1039.  
  1040.     if (isalpha(c0)) {
  1041.     Text it = readIdent();
  1042.  
  1043.     if (it==textCase)              return CASEXP;
  1044.     if (it==textOfK)               lookAhead(OF);
  1045.     if (it==textData)           return DATA;
  1046.     if (it==textType)           return TYPE;
  1047.     if (it==textIf)            return IF;
  1048.     if (it==textThen)           return THEN;
  1049.     if (it==textElse)           return ELSE;
  1050.     if (it==textWhere)             lookAhead(WHERE);
  1051.         if (it==textLet)               lookAhead(LET);
  1052.         if (it==textIn)                return IN;
  1053.     if (it==textInfix)           return INFIX;
  1054.     if (it==textInfixl)           return INFIXL;
  1055.     if (it==textInfixr)           return INFIXR;
  1056.     if (it==textPrim)              return PRIMITIVE;
  1057.     if (it==textClass)           return TCLASS;
  1058.     if (it==textInstance)           return TINSTANCE;
  1059.     if (it==textDeriving)           return DERIVING;
  1060.     if (it==textDefault)           return DEFAULT;
  1061.     if (it==textHiding)           return HIDING;
  1062.     if (it==textImport)           return IMPORT;
  1063.     if (it==textInterface)           return INTERFACE;
  1064.     if (it==textModule)           return MODULE;
  1065.     if (it==textTo)               return TO;
  1066.     if (it==textRenaming)           return RENAMING;
  1067.     if (it==textRepeat && reading==KEYBOARD)
  1068.         return repeatLast();
  1069.  
  1070.     top() = yylval = ap((identType==CONID ? CONIDCELL : VARIDCELL),it);
  1071.     return identType;
  1072.     }
  1073.  
  1074.     if (isoneof(c0,SYMBOLS) || isoneof(c0,PRESYMBOLS)) {
  1075.     Text it = readOperator();
  1076.  
  1077.     if (it==textCoco)    return COCO;
  1078.     if (it==textEq)      return '=';
  1079.     if (it==textUpto)    return UPTO;
  1080.     if (it==textAs)      return '@';
  1081.     if (it==textLambda)  return '\\';
  1082.     if (it==textBar)     return '|';
  1083.     if (it==textFrom)    return FROM;/*relies on notElem '-' PRESYMBOLS*/
  1084.     if (it==textMinus)   return '-';
  1085.     if (it==textArrow)   return FUNARROW;
  1086.     if (it==textLazy)    return '~';
  1087.     if (it==textImplies) return IMPLIES;
  1088.     if (it==textRepeat && reading==KEYBOARD)
  1089.         return repeatLast();
  1090.  
  1091.     top() = yylval = ap((opType==CONOP ? CONOPCELL : VAROPCELL),it);
  1092.     return opType;
  1093.     }
  1094.  
  1095.     if (isdigit(c0)) {
  1096.     top() = yylval = readNumber();
  1097.     return NUMLIT;
  1098.     }
  1099.  
  1100.     ERROR(row) "Unrecognised token in column %d", column
  1101.     EEND;
  1102.     return 0; /*NOTREACHED*/
  1103. }
  1104.  
  1105. static Int local repeatLast() {        /* obtain last expression entered  */
  1106.     if (isNull(yylval=getLastExpr())) {
  1107.     ERROR(row) "Cannot use %s without any previous input", repeatStr
  1108.     EEND;
  1109.     }
  1110.     return REPEAT;
  1111. }
  1112.  
  1113. Syntax defaultSyntax(t)            /* find default syntax of var named */
  1114. Text t; {                   /* by t ...               */
  1115.     String s = textToStr(t);
  1116.     if ((isascii(s[0]) && isalpha(s[0])) || s[0]=='_' || strcmp(s,"[]")==0)
  1117.     return APPLIC;
  1118.     else
  1119.     return DEF_OPSYNTAX;
  1120. }
  1121.  
  1122. /* --------------------------------------------------------------------------
  1123.  * main entry points to parser/lexer:
  1124.  * ------------------------------------------------------------------------*/
  1125.  
  1126. static Void local parseInput(startWith)/* parse input with given first tok,*/
  1127. Int startWith; {               /* determining whether to read a    */
  1128.     firstToken     = TRUE;           /* script or an expression       */
  1129.     firstTokenIs = startWith;
  1130.  
  1131.     clearStack();
  1132.     if (yyparse()) {               /* This can only be parser overflow */
  1133.     ERROR(row) "Parser overflow"   /* as all syntax errors are caught  */
  1134.     EEND;                   /* in the parser...           */
  1135.     }
  1136.     drop();
  1137.     if (!stackEmpty())               /* stack should now be empty       */
  1138.     internal("parseInput");
  1139. }
  1140.  
  1141. Void parseScript(nm,len)           /* Read a script: sets valDefns and */
  1142. String nm;                   /*                tyconDefns       */
  1143. Long   len; {                   /* used to set a target for reading)*/
  1144.     input(RESET);
  1145.     fileInput(nm,len);
  1146.     parseInput(SCRIPT);
  1147. }
  1148.  
  1149. Void parseExp() {               /* read an expression to evaluate   */
  1150.     parseInput(EVALEX);
  1151.     setLastExpr(inputExpr);
  1152. }
  1153.  
  1154. /* --------------------------------------------------------------------------
  1155.  * Input control:
  1156.  * ------------------------------------------------------------------------*/
  1157.  
  1158. Void input(what)
  1159. Int what; {
  1160.     switch (what) {
  1161.     case RESET   : tyconDefns  = NIL;
  1162.                typeInDefns = NIL;
  1163.                valDefns    = NIL;
  1164.                opDefns       = NIL;
  1165.                classDefns  = NIL;
  1166.                        instDefns   = NIL;
  1167.                overDefns   = NIL;
  1168.                inputExpr   = NIL;
  1169.                closeAnyInput();
  1170.                break;
  1171.  
  1172.     case BREAK   : if (reading==KEYBOARD)
  1173.                c0 = EOF;
  1174.                break;
  1175.  
  1176.     case MARK    : mark(tyconDefns);
  1177.                mark(typeInDefns);
  1178.                mark(valDefns);
  1179.                mark(opDefns);
  1180.                mark(classDefns);
  1181.                        mark(instDefns);
  1182.                mark(overDefns);
  1183.                mark(inputExpr);
  1184.                mark(varNegate);
  1185.                mark(varFlip);
  1186.                mark(varMinus);
  1187.                mark(varFrom);
  1188.                mark(varFromTo);
  1189.                mark(varFromThen);
  1190.                mark(varFromThenTo);
  1191.                break;
  1192.  
  1193.     case INSTALL : input(RESET);
  1194.                textCase       = findText("case");
  1195.                textOfK          = findText("of");
  1196.                textData       = findText("data");
  1197.                textType       = findText("type");
  1198.                textIf          = findText("if");
  1199.                textThen       = findText("then");
  1200.                textElse       = findText("else");
  1201.                textWhere      = findText("where");
  1202.                        textLet        = findText("let");
  1203.                        textIn         = findText("in");
  1204.                textInfix      = findText("infix");
  1205.                textInfixl     = findText("infixl");
  1206.                textInfixr     = findText("infixr");
  1207.                textPrim       = findText("primitive");
  1208.                textCoco       = findText("::");
  1209.                textEq          = findText("=");
  1210.                textUpto       = findText("..");
  1211.                textAs          = findText("@");
  1212.                textLambda     = findText("\\");
  1213.                textBar          = findText("|");
  1214.                textMinus      = findText("-");
  1215.                textFrom       = findText("<-");
  1216.                textArrow      = findText("->");
  1217.                textLazy       = findText("~");
  1218.                textClass      = findText("class");
  1219.                textInstance   = findText("instance");
  1220.                textImplies    = findText("=>");
  1221.                textPlus          = findText("+");
  1222.                textMult          = findText("*");
  1223.                textDefault    = findText("default");
  1224.                textDeriving   = findText("deriving");
  1225.                textHiding     = findText("hiding");
  1226.                textInterface  = findText("interface");
  1227.                textImport     = findText("import");
  1228.                textModule     = findText("module");
  1229.                textTo         = findText("to");
  1230.                textRenaming   = findText("renaming");
  1231.  
  1232.                varMinus          = mkVar(findText("-"));
  1233.                varNegate      = mkVar(findText("negate"));
  1234.                varFlip          = mkVar(findText("flip"));
  1235.                varFrom          = mkVar(findText("enumFrom"));
  1236.                varFromTo      = mkVar(findText("enumFromTo"));
  1237.                varFromThen    = mkVar(findText("enumFromThen"));
  1238.                varFromThenTo  = mkVar(findText("enumFromThenTo"));
  1239.                break;
  1240.     }
  1241. }
  1242.  
  1243. /*-------------------------------------------------------------------------*/
  1244.