ghc/interpreter/input.c

   1
   2 /* --------------------------------------------------------------------------
   3  * Input functions, lexical analysis parsing etc...
   4  *
   5  * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the
   6  * Yale Haskell Group, and the Oregon Graduate Institute of Science and
   7  * Technology, 1994-1999, All rights reserved.  It is distributed as
   8  * free software under the license in the file "License", which is
   9  * included in the distribution.
  10  *
  11  * $RCSfile: input.c,v $
  12  * $Revision: 1.11 $
  13  * $Date: 1999/11/12 16:38:31 $
  14  * ------------------------------------------------------------------------*/
  15
  16 #include "prelude.h"
  17 #include "storage.h"
  18 #include "backend.h"
  19 #include "connect.h"
  20 #include "command.h"
  21 #include "errors.h"
  22 #include "link.h"
  23 #include <ctype.h>
  24 #if HAVE_GETDELIM_H
  25 #include "getdelim.h"
  26 #endif
  27
  28 #if IS_WIN32
  29 #include <windows.h>
  30 #endif
  31
  32 #if IS_WIN32 || HUGS_FOR_WINDOWS
  33 #undef IN
  34 #endif
  35
  36 #if HAVE_LIBREADLINE && HAVE_READLINE_READLINE_H
  37 #define USE_READLINE 1
  38 #else
  39 #define USE_READLINE 0
  40 #endif
  41
  42 #if USE_READLINE
  43 #include <readline/readline.h>
  44 #include <readline/history.h>
  45 #endif
  46
  47
  48 /* --------------------------------------------------------------------------
  49  * Global data:
  50  * ------------------------------------------------------------------------*/
  51
  52 List tyconDefns      = NIL;             /* type constructor definitions    */
  53 List typeInDefns     = NIL;             /* type synonym restrictions       */
  54 List valDefns        = NIL;             /* value definitions in script     */
  55 List classDefns      = NIL;             /* class defns in script           */
  56 List instDefns       = NIL;             /* instance defns in script        */
  57 List selDefns        = NIL;             /* list of selector lists          */
  58 List genDefns        = NIL;             /* list of generated names         */
  59 List unqualImports   = NIL;             /* unqualified import list         */
  60 List foreignImports  = NIL;             /* foreign imports                 */
  61 List foreignExports  = NIL;             /* foreign exportsd                */
  62 List defaultDefns    = NIL;             /* default definitions (if any)    */
  63 Int  defaultLine     = 0;               /* line in which default defs occur*/
  64 List evalDefaults    = NIL;             /* defaults for evaluator          */
  65
  66 Cell inputExpr       = NIL;             /* input expression                */
  67 Cell inputContext    = NIL;             /* input context                   */
  68 Bool literateScripts = FALSE;           /* TRUE => default to lit scripts  */
  69 Bool literateErrors  = TRUE;            /* TRUE => report errs in lit scrs */
  70 Bool offsideON       = TRUE;            /* TRUE => implement offside rule  */
  71
  72 String repeatStr     = 0;               /* Repeat last expr                */
  73
  74 #if USE_PREPROCESSOR && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
  75 String preprocessor  = 0;
  76 #endif
  77
  78 /* --------------------------------------------------------------------------
  79  * Local function prototypes:
  80  * ------------------------------------------------------------------------*/
  81
  82 static Void local initCharTab     Args((Void));
  83 static Void local fileInput       Args((String,Long));
  84 static Bool local literateMode    Args((String));
  85 static Bool local linecmp         Args((String,String));
  86 static Int  local nextLine        Args((Void));
  87 static Void local skip            Args((Void));
  88 static Void local thisLineIs      Args((Int));
  89 static Void local newlineSkip     Args((Void));
  90 static Void local closeAnyInput   Args((Void));
  91
  92        Int  yyparse         Args((Void)); /* can't stop yacc making this   */
  93                                           /* public, but don't advertise   */
  94                                           /* it in a header file.          */
  95
  96 static Void local endToken        Args((Void));
  97 static Text local readOperator    Args((Void));
  98 static Text local readIdent       Args((Void));
  99 static Cell local readRadixNumber Args((Int));
 100 static Cell local readNumber      Args((Void));
 101 static Cell local readChar        Args((Void));
 102 static Cell local readString      Args((Void));
 103 static Void local saveStrChr      Args((Char));
 104 static Cell local readAChar       Args((Bool));
 105
 106 static Bool local lazyReadMatches Args((String));
 107 static Cell local readEscapeChar  Args((Bool));
 108 static Void local skipGap         Args((Void));
 109 static Cell local readCtrlChar    Args((Void));
 110 static Cell local readOctChar     Args((Void));
 111 static Cell local readHexChar     Args((Void));
 112 static Int  local readHexDigit    Args((Char));
 113 static Cell local readDecChar     Args((Void));
 114
 115 static Void local goOffside       Args((Int));
 116 static Void local unOffside       Args((Void));
 117 static Bool local canUnOffside    Args((Void));
 118
 119 static Void local skipWhitespace  Args((Void));
 120 static Int  local yylex           Args((Void));
 121 static Int  local repeatLast      Args((Void));
 122
 123 static Void local parseInput      Args((Int));
 124
 125 static Bool local doesNotExceed   Args((String,Int,Int));
 126 static Int  local stringToInt     Args((String,Int));
 127
 128
 129 /* --------------------------------------------------------------------------
 130  * Text values for reserved words and special symbols:
 131  * ------------------------------------------------------------------------*/
 132
 133 static Text textCase,    textOfK,      textData,   textType,   textIf;
 134 static Text textThen,    textElse,     textWhere,  textLet,    textIn;
 135 static Text textInfix,   textInfixl,   textInfixr, textForeign, textNewtype;
 136 static Text textDefault, textDeriving, textDo,     textClass,  textInstance;
 137 #if IPARAM
 138 static Text textWith,  textDlet;
 139 #endif
 140
 141 static Text textCoco,    textEq,       textUpto,   textAs,     textLambda;
 142 static Text textBar,     textMinus,    textFrom,   textArrow,  textLazy;
 143 static Text textBang,    textDot,      textAll,    textImplies;
 144 static Text textWildcard;
 145
 146 static Text textModule,  textImport,    textInterface,  textInstImport;
 147 static Text textHiding,  textQualified, textAsMod;
 148 static Text textExport,  textDynamic,   textUUExport;
 149 static Text textUnsafe,  textUUAll;
 150
 151 Text   textCcall;                       /* ccall                           */
 152 Text   textStdcall;                     /* stdcall                         */
 153
 154 Text   textNum;                         /* Num                             */
 155 Text   textPrelude;                     /* Prelude                         */
 156 Text   textPlus;                        /* (+)                             */
 157
 158 static Cell conMain;                    /* Main                            */
 159 static Cell varMain;                    /* main                            */
 160
 161 static Cell varMinus;                   /* (-)                             */
 162 static Cell varPlus;                    /* (+)                             */
 163 static Cell varBang;                    /* (!)                             */
 164 static Cell varDot;                     /* (.)                             */
 165 static Cell varHiding;                  /* hiding                          */
 166 static Cell varQualified;               /* qualified                       */
 167 static Cell varAsMod;                   /* as                              */
 168
 169 static List imps;                       /* List of imports to be chased    */
 170
 171
 172 /* --------------------------------------------------------------------------
 173  * Character set handling:
 174  *
 175  * Hugs follows Haskell 1.3 in assuming that input uses the ISO-8859-1
 176  * character set.  The following code provides methods for classifying
 177  * input characters according to the lexical structure specified by the
 178  * report.  Hugs should still accept older programs because ASCII is
 179  * essentially just a subset of the ISO character set.
 180  *
 181  * Notes: If you want to port Hugs to a machine that uses something
 182  * substantially different from the ISO character set, then you will need
 183  * to insert additional code to map between character sets.
 184  *
 185  * At some point, the following data structures may be exported in a .h
 186  * file to allow the information contained here to be picked up in the
 187  * implementation of LibChar is* primitives.
 188  *
 189  * Relies, implicitly but for this comment, on assumption that NUM_CHARS=256.
 190  * ------------------------------------------------------------------------*/
 191
 192 static  Bool            charTabBuilt;
 193 static  unsigned char   ctable[NUM_CHARS];
 194 #define isIn(c,x)       (ctable[(unsigned char)(c)]&(x))
 195 #define isISO(c)        (0<=(c) && (c)<NUM_CHARS)
 196
 197 #define DIGIT           0x01
 198 #define SMALL           0x02
 199 #define LARGE           0x04
 200 #define SYMBOL          0x08
 201 #define IDAFTER         0x10
 202 #define ZPACE           0x20
 203 #define PRINT           0x40
 204
 205 static Void local initCharTab() {       /* Initialize char decode table    */
 206 #define setRange(x,f,t) {Int i=f;   while (i<=t) ctable[i++] |=x;}
 207 #define setChar(x,c)    ctable[c] |= (x)
 208 #define setChars(x,s)   {char *p=s; while (*p)   ctable[(Int)*p++]|=x;}
 209 #define setCopy(x,c)    {Int i;                         \
 210                          for (i=0; i<NUM_CHARS; ++i)    \
 211                              if (isIn(i,c))             \
 212                                  ctable[i]|=x;          \
 213                         }
 214
 215     setRange(DIGIT,     '0','9');       /* ASCII decimal digits            */
 216
 217     setRange(SMALL,     'a','z');       /* ASCII lower case letters        */
 218     setRange(SMALL,     223,246);       /* ISO lower case letters          */
 219     setRange(SMALL,     248,255);       /* (omits division symbol, 247)    */
 220     setChar (SMALL,     '_');
 221
 222     setRange(LARGE,     'A','Z');       /* ASCII upper case letters        */
 223     setRange(LARGE,     192,214);       /* ISO upper case letters          */
 224     setRange(LARGE,     216,222);       /* (omits multiplication, 215)     */
 225
 226     setRange(SYMBOL,    161,191);       /* Symbol characters + ':'         */
 227     setRange(SYMBOL,    215,215);
 228     setChar (SYMBOL,    247);
 229     setChars(SYMBOL,    ":!#$%&*+./<=>?@\\^|-~");
 230
 231     setChar (IDAFTER,   '\'');          /* Characters in identifier        */
 232     setCopy (IDAFTER,   (DIGIT|SMALL|LARGE));
 233
 234     setChar (ZPACE,     ' ');           /* ASCII space character           */
 235     setChar (ZPACE,     160);           /* ISO non breaking space          */
 236     setRange(ZPACE,     9,13);          /* special whitespace: \t\n\v\f\r  */
 237
 238     setChars(PRINT,     "(),;[]_`{}");  /* Special characters              */
 239     setChars(PRINT,     " '\"");        /* Space and quotes                */
 240     setCopy (PRINT,     (DIGIT|SMALL|LARGE|SYMBOL));
 241
 242     charTabBuilt = TRUE;
 243 #undef setRange
 244 #undef setChar
 245 #undef setChars
 246 #undef setCopy
 247 }
 248
 249
 250 /* --------------------------------------------------------------------------
 251  * Single character input routines:
 252  *
 253  * At the lowest level of input, characters are read one at a time, with the
 254  * current character held in c0 and the following (lookahead) character in
 255  * c1.  The corrdinates of c0 within the file are held in (column,row).
 256  * The input stream is advanced by one character using the skip() function.
 257  * ------------------------------------------------------------------------*/
 258
 259 #define TABSIZE    8                   /* spacing between tabstops         */
 260
 261 #define NOTHING    0                   /* what kind of input is being read?*/
 262 #define KEYBOARD   1                   /* - keyboard/console?              */
 263 #define SCRIPTFILE 2                   /* - script file                    */
 264 #define PROJFILE   3                   /* - project file                   */
 265 #define STRING     4                   /* - string buffer?                 */
 266
 267 static Int    reading   = NOTHING;
 268
 269 static Target readSoFar;
 270 static Int    row, column, startColumn;
 271 static int    c0, c1;
 272 static FILE   *inputStream = 0;
 273 static Bool   thisLiterate;
 274 static String nextStringChar;          /* next char in string buffer       */
 275
 276 #if     USE_READLINE                   /* for command line editors         */
 277 static  String currentLine;            /* editline or GNU readline         */
 278 static  String nextChar;
 279 #define nextConsoleChar() \
 280            (unsigned char)(*nextChar=='\0' ? '\n' : *nextChar++)
 281 #else
 282 #define nextConsoleChar() getc(stdin)
 283 #endif
 284
 285 static  Int litLines;                  /* count defn lines in lit script   */
 286 #define DEFNCHAR  '>'                  /* definition lines begin with this */
 287 static  Int lastLine;                  /* records type of last line read:  */
 288 #define STARTLINE 0                    /* - at start of file, none read    */
 289 #define BLANKLINE 1                    /* - blank (may preceed definition) */
 290 #define TEXTLINE  2                    /* - text comment                   */
 291 #define DEFNLINE  3                    /* - line containing definition     */
 292 #define CODELINE  4                    /* - line inside code block         */
 293
 294 #define BEGINCODE "\\begin{code}"
 295 #define ENDCODE   "\\end{code}"
 296
 297 #if HAVE_GETDELIM_H
 298 static char *lineBuffer = NULL;   /* getline() does the initial allocation */
 299 #else
 300 #define LINEBUFFER_SIZE 1000
 301 static char lineBuffer[LINEBUFFER_SIZE];
 302 #endif
 303 static int lineLength = 0;
 304 static int inCodeBlock = FALSE; /* Inside \begin{code}..\end{code} */
 305 static int linePtr = 0;
 306
 307 Void consoleInput(prompt)              /* prepare to input characters from */
 308 String prompt; {                       /* standard in (i.e. console/kbd)   */
 309     reading     = KEYBOARD;            /* keyboard input is Line oriented, */
 310     c0          =                      /* i.e. input terminated by '\n'    */
 311     c1          = ' ';
 312     column      = (-1);
 313     row         = 0;
 314
 315 #if USE_READLINE
 316     /* Paranoid freeing code supplied by Sverker Nilsson (sverker@opq.se)
 317      * avoids accidentally freeing currentLine twice.
 318      */
 319     if (currentLine) {
 320         String oldCurrentLine = currentLine;
 321         currentLine = 0;           /* We may lose the space of currentLine */
 322         free(oldCurrentLine);      /* if interrupted here - unlikely       */
 323     }
 324     currentLine = readline(prompt);
 325     nextChar    = currentLine;
 326     if (currentLine) {
 327         if (*currentLine)
 328             add_history(currentLine);
 329     }
 330     else
 331         c0 = c1 = EOF;
 332 #else
 333     Printf("%s",prompt);
 334     FlushStdout();
 335 #endif
 336 }
 337
 338 Void projInput(nm)                     /* prepare to input characters from */
 339 String nm; {                           /* from named project file          */
 340     if ((inputStream = fopen(nm,"r"))!=0) {
 341         reading = PROJFILE;
 342         c0      = ' ';
 343         c1      = '\n';
 344         column  = 1;
 345         row     = 0;
 346     }
 347     else {
 348         ERRMSG(0) "Unable to open project file \"%s\"", nm
 349         EEND;
 350     }
 351 }
 352
 353 static Void local fileInput(nm,len)     /* prepare to input characters from*/
 354 String nm;                              /* named file (specified length is */
 355 Long   len; {                           /* used to set target for reading) */
 356 #if USE_PREPROCESSOR && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
 357     if (preprocessor) {
 358         Int reallen = strlen(preprocessor) + 1 + strlen(nm) + 1;
 359         char *cmd = malloc(reallen);
 360         if (cmd == NULL) {
 361             ERRMSG(0) "Unable to allocate memory for filter command."
 362             EEND;
 363         }
 364         strcpy(cmd,preprocessor);
 365         strcat(cmd," ");
 366         strcat(cmd,nm);
 367         inputStream = popen(cmd,"r");
 368         free(cmd);
 369     } else {
 370         inputStream = fopen(nm,"r");
 371     }
 372 #else
 373     inputStream = fopen(nm,"r");
 374 #endif
 375     if (inputStream) {
 376         reading      = SCRIPTFILE;
 377         c0           = ' ';
 378         c1           = '\n';
 379         column       = 1;
 380         row          = 0;
 381
 382         lastLine     = STARTLINE;       /* literate file processing */
 383         litLines     = 0;
 384         linePtr      = 0;
 385         lineLength   = 0;
 386         thisLiterate = literateMode(nm);
 387         inCodeBlock  = FALSE;
 388
 389         readSoFar    = 0;
 390         setGoal("Parsing", (Target)len);
 391     }
 392     else {
 393         ERRMSG(0) "Unable to open file \"%s\"", nm
 394         EEND;
 395     }
 396 }
 397
 398 Void stringInput(s)             /* prepare to input characters from string */
 399 String s; {
 400     reading      = STRING;
 401     c0           = EOF;
 402     c1           = EOF;
 403     if (*s) c0 = *s++;
 404     if (*s) c1 = *s++;
 405     column       = 1;
 406     row          = 1;
 407
 408     nextStringChar = s;
 409     if (!charTabBuilt)
 410         initCharTab();
 411 }
 412
 413 static Bool local literateMode(nm)      /* Select literate mode for file   */
 414 String nm; {
 415     char *dot = strrchr(nm,'.');        /* look for last dot in file name  */
 416     if (dot) {
 417         if (filenamecmp(dot+1,"hs")==0) /* .hs files are never literate    */
 418             return FALSE;
 419         if (filenamecmp(dot+1,"lhs") ==0 || /* .lhs, .verb files are always*/
 420             filenamecmp(dot+1,"verb")==0) /* literate scripts              */
 421             return TRUE;
 422     }
 423     return literateScripts;             /* otherwise, use the default      */
 424 }
 425
 426
 427 Void hi_o_namesFromSrcName ( String srcName, String* hiName, String* oName )
 428 {
 429    Int len;
 430    String dot;
 431    len = 1 + strlen ( srcName );
 432    *hiName = malloc(len);
 433    *oName  = malloc(len);
 434    if (!(*hiName && *oName)) internal("hi_o_namesFromSource");
 435    (*hiName)[0] = (*oName)[0] = 0;
 436    dot = strrchr(srcName, '.');
 437    if (!dot) return;
 438    if (filenamecmp(dot+1, "hs")==0 &&
 439        filenamecmp(dot+1, "lhs")==0 &&
 440        filenamecmp(dot+1, "verb")==0) return;
 441
 442    strcpy(*hiName, srcName);
 443    dot = strrchr(*hiName, '.');
 444    dot[1] = 'h';
 445    dot[2] = 'i';
 446    dot[3] = 0;
 447
 448    strcpy(*oName, srcName);
 449    dot = strrchr(*oName, '.');
 450    dot[1] = 'o';
 451    dot[2] = 0;
 452 }
 453
 454
 455
 456 /* This code originally came from Sigbjorn Finne (sof@dcs.gla.ac.uk).
 457  * I've removed the loop (since newLineSkip contains a loop too) and
 458  * replaced the warnings with errors. ADR
 459  */
 460 /*
 461  * To deal with literate \begin{code}...\end{code} blocks,
 462  * add a line buffer that rooms the current line. The old c0 and c1
 463  * stream pointers are used as before within that buffer -- sof
 464  *
 465  * Upon reading a new line into the line buffer, we check to see if
 466  * we're reading in a line containing \begin{code} or \end{code} and
 467  * take appropriate action.
 468  */
 469
 470 static Bool local linecmp(s,line)       /* compare string with line        */
 471 String s;                               /* line may end in whitespace      */
 472 String line; {
 473     Int i=0;
 474     while (s[i] != '\0' && s[i] == line[i]) {
 475         ++i;
 476     }
 477     /* s[0..i-1] == line[0..i-1] */
 478     if (s[i] != '\0') {                 /* check s `isPrefixOf` line       */
 479         return FALSE;
 480     }
 481     while (isIn(line[i], ZPACE)) {      /* allow whitespace at end of line */
 482         ++i;
 483     }
 484     return (line[i] == '\0');
 485 }
 486
 487 /* Returns line length (including \n) or 0 upon EOF. */
 488 static Int local nextLine()
 489 {
 490 #if HAVE_GETDELIM_H
 491     /*
 492        Forget about fgets(), it is utterly braindead.
 493        (Assumes \NUL free streams and does not gracefully deal
 494        with overflow.) Instead, use GNU libc's getline().
 495        */
 496     lineLength = getline(&lineBuffer, &lineLength, inputStream);
 497 #else
 498     if (NULL != fgets(lineBuffer, LINEBUFFER_SIZE, inputStream))
 499         lineLength = strlen(lineBuffer);
 500     else
 501         lineLength = 0;
 502 #endif
 503     /* printf("Read: \"%s\"", lineBuffer); */
 504     if (lineLength <= 0) { /* EOF / IO error, who knows.. */
 505         return lineLength;
 506     }
 507     else if (lineLength >= 2 && lineBuffer[0] == '#' &&
 508              lineBuffer[1] == '!') {
 509         lineBuffer[0]='\n'; /* pretend it's a blank line */
 510         lineBuffer[1]='\0';
 511         lineLength=1;
 512     } else if (thisLiterate) {
 513         if (linecmp(BEGINCODE, lineBuffer)) {
 514             if (!inCodeBlock) {             /* Entered a code block        */
 515                 inCodeBlock = TRUE;
 516                 lineBuffer[0]='\n'; /* pretend it's a blank line */
 517                 lineBuffer[1]='\0';
 518                 lineLength=1;
 519             }
 520             else {
 521                 ERRMSG(row) "\\begin{code} encountered inside code block"
 522                 EEND;
 523             }
 524         }
 525         else if (linecmp(ENDCODE, lineBuffer)) {
 526             if (inCodeBlock) {              /* Finished code block         */
 527                 inCodeBlock = FALSE;
 528                 lineBuffer[0]='\n'; /* pretend it's a blank line */
 529                 lineBuffer[1]='\0';
 530                 lineLength=1;
 531             }
 532             else {
 533                 ERRMSG(row) "\\end{code} encountered outside code block"
 534                 EEND;
 535             }
 536         }
 537     }
 538     /* printf("Read: \"%s\"", lineBuffer); */
 539     return lineLength;
 540 }
 541
 542 static Void local skip() {              /* move forward one char in input  */
 543     if (c0!=EOF) {                      /* stream, updating c0, c1, ...    */
 544         if (c0=='\n') {                 /* Adjusting cursor coords as nec. */
 545             row++;
 546             column=1;
 547             if (reading==SCRIPTFILE)
 548                 soFar(readSoFar);
 549         }
 550         else if (c0=='\t')
 551             column += TABSIZE - ((column-1)%TABSIZE);
 552         else
 553             column++;
 554
 555         c0 = c1;
 556         readSoFar++;
 557
 558         if (c0==EOF) {
 559             column = 0;
 560             if (reading==SCRIPTFILE)
 561                 done();
 562             closeAnyInput();
 563         }
 564         else if (reading==KEYBOARD) {
 565             allowBreak();
 566             if (c0=='\n')
 567                 c1 = EOF;
 568             else {
 569                 c1 = nextConsoleChar();
 570 #if IS_WIN32 && !HUGS_FOR_WINDOWS
 571                 Sleep(0);
 572 #endif
 573                 /* On Win32, hitting ctrl-C causes the next getchar to
 574                  * fail - returning "-1" to indicate an error.
 575                  * This is one of the rare cases where "-1" does not mean EOF.
 576                  */
 577                 if (EOF == c1 && (!feof(stdin) || broken==TRUE)) {
 578                     c1 = ' ';
 579                 }
 580             }
 581         }
 582         else if (reading==STRING) {
 583             c1 = (unsigned char) *nextStringChar++;
 584             if (c1 == '\0')
 585                 c1 = EOF;
 586         }
 587         else {
 588             if (lineLength <=0 || linePtr == lineLength) {
 589                 /* Current line, exhausted - get new one */
 590                 if (nextLine() <= 0) { /* EOF */
 591                     c1 = EOF;
 592                 }
 593                 else {
 594                     linePtr = 0;
 595                     c1 = (unsigned char)lineBuffer[linePtr++];
 596                 }
 597             }
 598             else {
 599                 c1 = (unsigned char)lineBuffer[linePtr++];
 600             }
 601         }
 602
 603     }
 604 }
 605
 606 static Void local thisLineIs(kind)     /* register kind of current line    */
 607 Int kind; {                            /* & check for literate script errs */
 608     if (literateErrors) {
 609         if ((kind==DEFNLINE && lastLine==TEXTLINE) ||
 610             (kind==TEXTLINE && lastLine==DEFNLINE)) {
 611             ERRMSG(row) "Program line next to comment"
 612             EEND;
 613         }
 614         lastLine = kind;
 615     }
 616 }
 617
 618 static Void local newlineSkip() {      /* skip `\n' (supports lit scripts) */
 619     /* assert(c0=='\n'); */
 620     if (reading==SCRIPTFILE && thisLiterate) {
 621         do {
 622             skip();
 623             if (inCodeBlock) {         /* pass chars on definition lines   */
 624                 thisLineIs(CODELINE);  /* to lexer (w/o leading DEFNCHAR)  */
 625                 litLines++;
 626                 return;
 627             }
 628             if (c0==DEFNCHAR) {        /* pass chars on definition lines   */
 629                 thisLineIs(DEFNLINE);  /* to lexer (w/o leading DEFNCHAR)  */
 630                 skip();
 631                 litLines++;
 632                 return;
 633             }
 634             while (c0 != '\n' && isIn(c0,ZPACE)) /* maybe line is blank?   */
 635                 skip();
 636             if (c0=='\n' || c0==EOF)
 637                 thisLineIs(BLANKLINE);
 638             else {
 639                 thisLineIs(TEXTLINE);  /* otherwise it must be a comment   */
 640                 while (c0!='\n' && c0!=EOF)
 641                     skip();
 642             }                          /* by now, c0=='\n' or c0==EOF      */
 643         } while (c0!=EOF);             /* if new line, start again         */
 644
 645         if (litLines==0 && literateErrors) {
 646             ERRMSG(row) "Empty script - perhaps you forgot the `%c's?",
 647                         DEFNCHAR
 648             EEND;
 649         }
 650         return;
 651     }
 652     skip();
 653 }
 654
 655 static Void local closeAnyInput() {    /* Close input stream, if open,     */
 656     switch (reading) {                 /* or skip to end of console line   */
 657         case PROJFILE   :
 658         case SCRIPTFILE : if (inputStream) {
 659 #if USE_PREPROCESSOR && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
 660                               if (preprocessor) {
 661                                   pclose(inputStream);
 662                               } else {
 663                                   fclose(inputStream);
 664                               }
 665 #else
 666                               fclose(inputStream);
 667 #endif
 668                               inputStream = 0;
 669                           }
 670                           break;
 671         case KEYBOARD   : while (c0!=EOF)
 672                               skip();
 673                           break;
 674     }
 675     reading=NOTHING;
 676 }
 677
 678 /* --------------------------------------------------------------------------
 679  * Parser: Uses table driven parser generated from parser.y using yacc
 680  * ------------------------------------------------------------------------*/
 681
 682 #include "parser.c"
 683
 684 /* --------------------------------------------------------------------------
 685  * Single token input routines:
 686  *
 687  * The following routines read the values of particular kinds of token given
 688  * that the first character of the token has already been located in c0 on
 689  * entry to the routine.
 690  * ------------------------------------------------------------------------*/
 691
 692 #define MAX_TOKEN           4000
 693 #define startToken()        tokPos = 0
 694 #define saveTokenChar(c)    if (tokPos<=MAX_TOKEN) saveChar(c); else ++tokPos
 695 #define saveChar(c)         tokenStr[tokPos++]=(char)(c)
 696 #define overflows(n,b,d,m)  (n > ((m)-(d))/(b))
 697
 698 static char tokenStr[MAX_TOKEN+1];     /* token buffer                     */
 699 static Int  tokPos;                    /* input position in buffer         */
 700 static Int  identType;                 /* identifier type: CONID / VARID   */
 701 static Int  opType;                    /* operator type  : CONOP / VAROP   */
 702
 703 static Void local endToken() {         /* check for token overflow         */
 704     if (tokPos>MAX_TOKEN) {
 705         ERRMSG(row) "Maximum token length (%d) exceeded", MAX_TOKEN
 706         EEND;
 707     }
 708     tokenStr[tokPos] = '\0';
 709 }
 710
 711 static Text local readOperator() {     /* read operator symbol             */
 712     startToken();
 713     do {
 714         saveTokenChar(c0);
 715         skip();
 716     } while (isISO(c0) && isIn(c0,SYMBOL));
 717     opType = (tokenStr[0]==':' ? CONOP : VAROP);
 718     endToken();
 719     return findText(tokenStr);
 720 }
 721
 722 static Text local readIdent() {        /* read identifier                  */
 723     startToken();
 724     do {
 725         saveTokenChar(c0);
 726         skip();
 727     } while (isISO(c0) && isIn(c0,IDAFTER));
 728     endToken();
 729     identType = isIn(tokenStr[0],LARGE) ? CONID : VARID;
 730     return findText(tokenStr);
 731 }
 732
 733
 734 static Bool local doesNotExceed(s,radix,limit)
 735 String s;
 736 Int    radix;
 737 Int    limit; {
 738     Int n = 0;
 739     Int p = 0;
 740     while (TRUE) {
 741         if (s[p] == 0) return TRUE;
 742         if (overflows(n,radix,s[p]-'0',limit)) return FALSE;
 743         n = radix*n + (s[p]-'0');
 744         p++;
 745     }
 746 }
 747
 748 static Int local stringToInt(s,radix)
 749 String s;
 750 Int    radix; {
 751     Int n = 0;
 752     Int p = 0;
 753     while (TRUE) {
 754         if (s[p] == 0) return n;
 755         n = radix*n + (s[p]-'0');
 756         p++;
 757     }
 758 }
 759
 760 static Cell local readRadixNumber(r)   /* Read literal in specified radix  */
 761 Int r; {                               /* from input of the form 0c{digs}  */
 762     Int d;
 763     startToken();
 764     skip();                            /* skip leading zero                */
 765     if ((d=readHexDigit(c1))<0 || d>=r) {
 766         /* Special case; no digits, lex as  */
 767         /* if it had been written "0 c..."  */
 768         saveTokenChar('0');
 769     } else {
 770         skip();
 771         do {
 772             saveTokenChar('0'+readHexDigit(c0));
 773             skip();
 774             d = readHexDigit(c0);
 775         } while (d>=0 && d<r);
 776     }
 777     endToken();
 778
 779     if (doesNotExceed(tokenStr,r,MAXPOSINT))
 780         return mkInt(stringToInt(tokenStr,r));
 781     else
 782     if (r == 10)
 783         return stringToBignum(tokenStr);
 784     else {
 785         ERRMSG(row) "Hexadecimal or octal constant exceeds `Int' range"
 786         EEND;
 787     }
 788 }
 789
 790 static Cell local readNumber() {        /* read numeric constant           */
 791
 792     if (c0=='0') {
 793         if (c1=='x' || c1=='X')         /* Maybe a hexadecimal literal?    */
 794             return readRadixNumber(16);
 795         if (c1=='o' || c1=='O')         /* Maybe an octal literal?         */
 796             return readRadixNumber(8);
 797     }
 798
 799     startToken();
 800     do {
 801         saveTokenChar(c0);
 802         skip();
 803     } while (isISO(c0) && isIn(c0,DIGIT));
 804
 805     if (c0!='.' || !isISO(c1) || !isIn(c1,DIGIT)) {
 806         endToken();
 807         if (doesNotExceed(tokenStr,10,MAXPOSINT))
 808             return mkInt(stringToInt(tokenStr,10)); else
 809             return stringToBignum(tokenStr);
 810     }
 811
 812     saveTokenChar(c0);                  /* save decimal point              */
 813     skip();
 814     do {                                /* process fractional part ...     */
 815         saveTokenChar(c0);
 816         skip();
 817     } while (isISO(c0) && isIn(c0,DIGIT));
 818
 819     if (c0=='e' || c0=='E') {           /* look for exponent part...       */
 820         saveTokenChar('e');
 821         skip();
 822         if (c0=='-') {
 823             saveTokenChar('-');
 824             skip();
 825         }
 826         else if (c0=='+')
 827             skip();
 828
 829         if (!isISO(c0) || !isIn(c0,DIGIT)) {
 830             ERRMSG(row) "Missing digits in exponent"
 831             EEND;
 832         }
 833         else {
 834             do {
 835                 saveTokenChar(c0);
 836                 skip();
 837             } while (isISO(c0) && isIn(c0,DIGIT));
 838         }
 839     }
 840
 841     endToken();
 842     return mkFloat(stringToFloat(tokenStr));
 843 }
 844
 845
 846
 847
 848
 849
 850
 851 static Cell local readChar() {         /* read character constant          */
 852     Cell charRead;
 853
 854     skip(/* '\'' */);
 855     if (c0=='\'' || c0=='\n' || c0==EOF) {
 856         ERRMSG(row) "Illegal character constant"
 857         EEND;
 858     }
 859
 860     charRead = readAChar(FALSE);
 861
 862     if (c0=='\'')
 863         skip(/* '\'' */);
 864     else {
 865         ERRMSG(row) "Improperly terminated character constant"
 866         EEND;
 867     }
 868     return charRead;
 869 }
 870
 871 static Cell local readString() {       /* read string literal              */
 872     Cell c;
 873
 874     startToken();
 875     skip(/* '\"' */);
 876     while (c0!='\"' && c0!='\n' && c0!=EOF) {
 877         c = readAChar(TRUE);
 878         if (nonNull(c))
 879             saveStrChr(charOf(c));
 880     }
 881
 882     if (c0=='\"')
 883         skip(/* '\"' */);
 884     else {
 885         ERRMSG(row) "Improperly terminated string"
 886         EEND;
 887     }
 888     endToken();
 889     return mkStr(findText(tokenStr));
 890 }
 891
 892 static Void local saveStrChr(c)        /* save character in string         */
 893 Char c; {
 894     if (c!='\0' && c!='\\') {          /* save non null char as single char*/
 895         saveTokenChar(c);
 896     }
 897     else {                             /* save null char as TWO null chars */
 898         if (tokPos+1<MAX_TOKEN) {
 899             saveChar('\\');
 900             if (c=='\\')
 901                 saveChar('\\');
 902             else
 903                 saveChar('0');
 904         }
 905     }
 906 }
 907
 908 static Cell local readAChar(isStrLit)  /* read single char constant        */
 909 Bool isStrLit; {                       /* TRUE => enable \& and gaps       */
 910     Cell c = mkChar(c0);
 911
 912     if (c0=='\\')                      /* escape character?                */
 913         return readEscapeChar(isStrLit);
 914     if (!isISO(c0)) {
 915         ERRMSG(row) "Non ISO character `\\%d' in constant", ((int)c0)
 916         EEND;
 917     }
 918     skip();                            /* normal character?                */
 919     return c;
 920 }
 921
 922 /* --------------------------------------------------------------------------
 923  * Character escape code sequences:
 924  * ------------------------------------------------------------------------*/
 925
 926 static struct {                        /* table of special escape codes    */
 927     char *codename;
 928     int  codenumber;
 929 } escapes[] = {
 930    {"a",    7}, {"b",    8}, {"f",   12}, {"n",   10},  /* common escapes  */
 931    {"r",   13}, {"t",    9}, {"\\",'\\'}, {"\"",'\"'},
 932    {"\'",'\''}, {"v",   11},
 933    {"NUL",  0}, {"SOH",  1}, {"STX",  2}, {"ETX",  3},  /* ascii codenames */
 934    {"EOT",  4}, {"ENQ",  5}, {"ACK",  6}, {"BEL",  7},
 935    {"BS",   8}, {"HT",   9}, {"LF",  10}, {"VT",  11},
 936    {"FF",  12}, {"CR",  13}, {"SO",  14}, {"SI",  15},
 937    {"DLE", 16}, {"DC1", 17}, {"DC2", 18}, {"DC3", 19},
 938    {"DC4", 20}, {"NAK", 21}, {"SYN", 22}, {"ETB", 23},
 939    {"CAN", 24}, {"EM",  25}, {"SUB", 26}, {"ESC", 27},
 940    {"FS",  28}, {"GS",  29}, {"RS",  30}, {"US",  31},
 941    {"SP",  32}, {"DEL", 127},
 942    {0,0}
 943 };
 944
 945 static Int  alreadyMatched;            /* Record portion of input stream   */
 946 static char alreadyRead[10];           /* that has been read w/o a match   */
 947
 948 static Bool local lazyReadMatches(s)   /* compare input stream with string */
 949 String s; {                            /* possibly using characters that   */
 950     int i;                             /* have already been read           */
 951
 952     for (i=0; i<alreadyMatched; ++i)
 953         if (alreadyRead[i]!=s[i])
 954             return FALSE;
 955
 956     while (s[i] && s[i]==c0) {
 957         alreadyRead[alreadyMatched++]=(char)c0;
 958         skip();
 959         i++;
 960     }
 961
 962     return s[i]=='\0';
 963 }
 964
 965 static Cell local readEscapeChar(isStrLit)/* read escape character         */
 966 Bool isStrLit; {
 967     int i=0;
 968
 969     skip(/* '\\' */);
 970     switch (c0) {
 971         case '&'  : if (isStrLit) {
 972                         skip();
 973                         return NIL;
 974                     }
 975                     ERRMSG(row) "Illegal use of `\\&' in character constant"
 976                     EEND;
 977                     break;/*NOTREACHED*/
 978
 979         case '^'  : return readCtrlChar();
 980
 981         case 'o'  : return readOctChar();
 982         case 'x'  : return readHexChar();
 983
 984         default   : if (!isISO(c0)) {
 985                         ERRMSG(row) "Illegal escape sequence"
 986                         EEND;
 987                     }
 988                     else if (isIn(c0,ZPACE)) {
 989                         if (isStrLit) {
 990                             skipGap();
 991                             return NIL;
 992                         }
 993                         ERRMSG(row) "Illegal use of gap in character constant"
 994                         EEND;
 995                         break;
 996                     }
 997                     else if (isIn(c0,DIGIT))
 998                         return readDecChar();
 999     }
1000
1001     for (alreadyMatched=0; escapes[i].codename; i++)
1002         if (lazyReadMatches(escapes[i].codename))
1003             return mkChar(escapes[i].codenumber);
1004
1005     alreadyRead[alreadyMatched++] = (char)c0;
1006     alreadyRead[alreadyMatched++] = '\0';
1007     ERRMSG(row) "Illegal character escape sequence \"\\%s\"",
1008                 alreadyRead
1009     EEND;
1010     return NIL;/*NOTREACHED*/
1011 }
1012
1013 static Void local skipGap() {          /* skip over gap in string literal  */
1014     do                                 /* (simplified in Haskell 1.1)      */
1015         if (c0=='\n')
1016             newlineSkip();
1017         else
1018             skip();
1019     while (isISO(c0) && isIn(c0,ZPACE));
1020     if (c0!='\\') {
1021         ERRMSG(row) "Missing `\\' terminating string literal gap"
1022         EEND;
1023     }
1024     skip(/* '\\' */);
1025 }
1026
1027 static Cell local readCtrlChar() {     /* read escape sequence \^x         */
1028     static String controls = "@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
1029     String which;
1030
1031     skip(/* '^' */);
1032     if ((which = strchr(controls,c0))==NULL) {
1033         ERRMSG(row) "Unrecognised escape sequence `\\^%c'", c0
1034         EEND;
1035     }
1036     skip();
1037     return mkChar(which-controls);
1038 }
1039
1040 static Cell local readOctChar() {      /* read octal character constant    */
1041     Int n = 0;
1042     Int d;
1043
1044     skip(/* 'o' */);
1045     if ((d = readHexDigit(c0))<0 || d>=8) {
1046         ERRMSG(row) "Empty octal character escape"
1047         EEND;
1048     }
1049     do {
1050         if (overflows(n,8,d,MAXCHARVAL)) {
1051             ERRMSG(row) "Octal character escape out of range"
1052             EEND;
1053         }
1054         n = 8*n + d;
1055         skip();
1056     } while ((d = readHexDigit(c0))>=0 && d<8);
1057
1058     return mkChar(n);
1059 }
1060
1061 static Cell local readHexChar() {      /* read hex character constant      */
1062     Int n = 0;
1063     Int d;
1064
1065     skip(/* 'x' */);
1066     if ((d = readHexDigit(c0))<0) {
1067         ERRMSG(row) "Empty hexadecimal character escape"
1068         EEND;
1069     }
1070     do {
1071         if (overflows(n,16,d,MAXCHARVAL)) {
1072             ERRMSG(row) "Hexadecimal character escape out of range"
1073             EEND;
1074         }
1075         n = 16*n + d;
1076         skip();
1077     } while ((d = readHexDigit(c0))>=0);
1078
1079     return mkChar(n);
1080 }
1081
1082 static Int local readHexDigit(c)       /* read single hex digit            */
1083 Char c; {
1084     if ('0'<=c && c<='9')
1085         return c-'0';
1086     if ('A'<=c && c<='F')
1087         return 10 + (c-'A');
1088     if ('a'<=c && c<='f')
1089         return 10 + (c-'a');
1090     return -1;
1091 }
1092
1093 static Cell local readDecChar() {      /* read decimal character constant  */
1094     Int n = 0;
1095
1096     do {
1097         if (overflows(n,10,(c0-'0'),MAXCHARVAL)) {
1098             ERRMSG(row) "Decimal character escape out of range"
1099             EEND;
1100         }
1101         n = 10*n + (c0-'0');
1102         skip();
1103     } while (c0!=EOF && isIn(c0,DIGIT));
1104
1105     return mkChar(n);
1106 }
1107
1108 /* --------------------------------------------------------------------------
1109  * Produce printable representation of character:
1110  * ------------------------------------------------------------------------*/
1111
1112 String unlexChar(c,quote)              /* return string representation of  */
1113 Char c;                                /* character...                     */
1114 Char quote; {                          /* protect quote character          */
1115     static char buffer[12];
1116
1117     if (c<0)                           /* deal with sign extended chars..  */
1118         c += NUM_CHARS;
1119
1120     if (isISO(c) && isIn(c,PRINT)) {   /* normal printable character       */
1121         if (c==quote || c=='\\') {     /* look for quote of approp. kind   */
1122             buffer[0] = '\\';
1123             buffer[1] = (char)c;
1124             buffer[2] = '\0';
1125         }
1126         else {
1127             buffer[0] = (char)c;
1128             buffer[1] = '\0';
1129         }
1130     }
1131     else {                             /* look for escape code             */
1132         Int escs;
1133         for (escs=0; escapes[escs].codename; escs++)
1134             if (escapes[escs].codenumber==c) {
1135                 sprintf(buffer,"\\%s",escapes[escs].codename);
1136                 return buffer;
1137             }
1138         sprintf(buffer,"\\%d",c);      /* otherwise use numeric escape     */
1139     }
1140     return buffer;
1141 }
1142
1143 Void printString(s)                    /* print string s, using quotes and */
1144 String s; {                            /* escapes if any parts need them   */
1145     if (s) {
1146         String t = s;
1147         Char   c;
1148         while ((c = *t)!=0 && isISO(c)
1149                            && isIn(c,PRINT) && c!='"' && !isIn(c,ZPACE)) {
1150             t++;
1151         }
1152         if (*t) {
1153             Putchar('"');
1154             for (t=s; *t; t++)
1155                 Printf("%s",unlexChar(*t,'"'));
1156             Putchar('"');
1157         }
1158         else
1159             Printf("%s",s);
1160     }
1161 }
1162
1163 /* -------------------------------------------------------------------------
1164  * Handle special types of input for use in interpreter:
1165  * -----------------------------------------------------------------------*/
1166
1167 Command readCommand(cmds,start,sys)    /* read command at start of input   */
1168 struct cmd *cmds;                      /* line in interpreter              */
1169 Char   start;                          /* characters introducing a cmd     */
1170 Char   sys; {                          /* character for shell escape       */
1171     while (c0==' ' || c0 =='\t')
1172         skip();
1173
1174     if (c0=='\n')                      /* look for blank command lines     */
1175         return NOCMD;
1176     if (c0==EOF)                       /* look for end of input stream     */
1177         return QUIT;
1178     if (c0==sys) {                     /* single character system escape   */
1179         skip();
1180         return SYSTEM;
1181     }
1182     if (c0==start && c1==sys) {        /* two character system escape      */
1183         skip();
1184         skip();
1185         return SYSTEM;
1186     }
1187
1188     startToken();                      /* All cmds start with start        */
1189     if (c0==start)                     /* except default (usually EVAL)    */
1190         do {                           /* which is empty                   */
1191             saveTokenChar(c0);
1192             skip();
1193         } while (c0!=EOF && !isIn(c0,ZPACE));
1194     endToken();
1195
1196     for (; cmds->cmdString; ++cmds)
1197         if (strcmp((cmds->cmdString),tokenStr)==0 ||
1198             (tokenStr[0]==start &&
1199              tokenStr[1]==(cmds->cmdString)[1] &&
1200              tokenStr[2]=='\0'))
1201             return (cmds->cmdCode);
1202     return BADCMD;
1203 }
1204
1205 String readFilename() {                /* Read filename from input (if any)*/
1206     if (reading==PROJFILE)
1207         skipWhitespace();
1208     else
1209         while (c0==' ' || c0=='\t')
1210             skip();
1211
1212     if (c0=='\n' || c0==EOF)           /* return null string at end of line*/
1213         return 0;
1214
1215     startToken();
1216     while (c0!=EOF && !isIn(c0,ZPACE)) {
1217         if (c0=='"') {
1218             skip();
1219             while (c0!=EOF && c0!='\"') {
1220                 Cell c = readAChar(TRUE);
1221                 if (nonNull(c)) {
1222                     saveTokenChar(charOf(c));
1223                 }
1224             }
1225             if (c0=='"')
1226                 skip();
1227             else {
1228                 ERRMSG(row) "a closing quote, '\"', was expected"
1229                 EEND;
1230             }
1231         }
1232         else {
1233             saveTokenChar(c0);
1234             skip();
1235         }
1236     }
1237     endToken();
1238     return tokenStr;
1239 }
1240
1241 String readLine() {                    /* Read command line from input     */
1242     while (c0==' ' || c0=='\t')        /* skip leading whitespace          */
1243         skip();
1244
1245     startToken();
1246     while (c0!='\n' && c0!=EOF) {
1247         saveTokenChar(c0);
1248         skip();
1249     }
1250     endToken();
1251
1252     return tokenStr;
1253 }
1254
1255 /* --------------------------------------------------------------------------
1256  * This lexer supports the Haskell layout rule:
1257  *
1258  * - Layout area bounded by { ... }, with `;'s in between.
1259  * - A `{' is a HARD indentation and can only be matched by a corresponding
1260  *   HARD '}'
1261  * - Otherwise, if no `{' follows the keywords WHERE/LET or OF, a SOFT `{'
1262  *   is inserted with the column number of the first token after the
1263  *   WHERE/LET/OF keyword.
1264  * - When a soft indentation is uppermost on the indetation stack with
1265  *   column col' we insert:
1266  *    `}'  in front of token with column<col' and pop indentation off stack,
1267  *    `;'  in front of token with column==col'.
1268  * ------------------------------------------------------------------------*/
1269
1270 #define MAXINDENT  100                 /* maximum nesting of layout rule   */
1271 static  Int        layout[MAXINDENT+1];/* indentation stack                */
1272 #define HARD       (-1)                /* indicates hard indentation       */
1273 static  Int        indentDepth = (-1); /* current indentation nesting      */
1274
1275 static Void local goOffside(col)       /* insert offside marker            */
1276 Int col; {                             /* for specified column             */
1277 assert(offsideON);
1278     if (indentDepth>=MAXINDENT) {
1279         ERRMSG(row) "Too many levels of program nesting"
1280         EEND;
1281     }
1282     layout[++indentDepth] = col;
1283 }
1284
1285 static Void local unOffside() {        /* leave layout rule area           */
1286 assert(offsideON);
1287     indentDepth--;
1288 }
1289
1290 static Bool local canUnOffside() {     /* Decide if unoffside permitted    */
1291 assert(offsideON);
1292     return indentDepth>=0 && layout[indentDepth]!=HARD;
1293 }
1294
1295 /* --------------------------------------------------------------------------
1296  * Main tokeniser:
1297  * ------------------------------------------------------------------------*/
1298
1299 static Void local skipWhitespace() {   /* Skip over whitespace/comments    */
1300     for (;;)                           /* Strictly speaking, this code is  */
1301         if (c0==EOF)                   /* a little more liberal than the   */
1302             return;                    /* report allows ...                */
1303         else if (c0=='\n')
1304             newlineSkip();
1305         else if (isIn(c0,ZPACE))
1306             skip();
1307         else if (c0=='{' && c1=='-') { /* (potentially) nested comment     */
1308             Int nesting = 1;
1309             Int origRow = row;         /* Save original row number         */
1310             skip();
1311             skip();
1312             while (nesting>0 && c0!=EOF)
1313                 if (c0=='{' && c1=='-') {
1314                     skip();
1315                     skip();
1316                     nesting++;
1317                 }
1318                 else if (c0=='-' && c1=='}') {
1319                     skip();
1320                     skip();
1321                     nesting--;
1322                 }
1323                 else if (c0=='\n')
1324                     newlineSkip();
1325                 else
1326                     skip();
1327             if (nesting>0) {
1328                 ERRMSG(origRow) "Unterminated nested comment {- ..."
1329                 EEND;
1330             }
1331         }
1332         else if (c0=='-' && c1=='-') {  /* One line comment                */
1333             do
1334                 skip();
1335             while (c0!='\n' && c0!=EOF);
1336             if (c0=='\n')
1337                 newlineSkip();
1338         }
1339         else
1340             return;
1341 }
1342
1343 static Bool firstToken;                /* Set to TRUE for first token      */
1344 static Int  firstTokenIs;              /* ... with token value stored here */
1345
1346 static Int local yylex() {             /* Read next input token ...        */
1347     static Bool insertOpen    = FALSE;
1348     static Bool insertedToken = FALSE;
1349     static Text textRepeat;
1350
1351 #define lookAhead(t) {skipWhitespace(); insertOpen = (c0!='{'); return t;}
1352
1353     if (firstToken) {                  /* Special case for first token     */
1354         indentDepth   = (-1);
1355         firstToken    = FALSE;
1356         insertOpen    = FALSE;
1357         insertedToken = FALSE;
1358         if (reading==KEYBOARD)
1359             textRepeat = findText(repeatStr);
1360         return firstTokenIs;
1361     }
1362
1363     if (offsideON && insertOpen) {     /* insert `soft' opening brace      */
1364         insertOpen    = FALSE;
1365         insertedToken = TRUE;
1366         goOffside(column);
1367         push(yylval = mkInt(row));
1368         return '{';
1369     }
1370
1371     /* ----------------------------------------------------------------------
1372      * Skip white space, and insert tokens to support layout rules as reqd.
1373      * --------------------------------------------------------------------*/
1374
1375     skipWhitespace();
1376     startColumn = column;
1377     push(yylval = mkInt(row));         /* default token value is line no.  */
1378     /* subsequent changes to yylval must also set top() to the same value  */
1379
1380     if (indentDepth>=0) {              /* layout rule(s) active ?          */
1381         if (insertedToken)             /* avoid inserting multiple `;'s    */
1382             insertedToken = FALSE;     /* or putting `;' after `{'         */
1383         else
1384         if (offsideON && layout[indentDepth]!=HARD) {
1385             if (column<layout[indentDepth]) {
1386                 unOffside();
1387                 return '}';
1388             }
1389             else if (column==layout[indentDepth] && c0!=EOF) {
1390                 insertedToken = TRUE;
1391                 return ';';
1392             }
1393         }
1394     }
1395
1396     /* ----------------------------------------------------------------------
1397      * Now try to identify token type:
1398      * --------------------------------------------------------------------*/
1399
1400     switch (c0) {
1401         case EOF  : return 0;                   /* End of file/input       */
1402
1403         /* The next 10 characters make up the `special' category in 1.3    */
1404         case '('  : skip(); return '(';
1405         case ')'  : skip(); return ')';
1406         case ','  : skip(); return ',';
1407         case ';'  : skip(); return ';';
1408         case '['  : skip(); return '[';
1409         case ']'  : skip(); return ']';
1410         case '`'  : skip(); return '`';
1411         case '{'  : if (offsideON) goOffside(HARD);
1412                     skip();
1413                     return '{';
1414         case '}'  : if (offsideON && indentDepth<0) {
1415                         ERRMSG(row) "Misplaced `}'"
1416                         EEND;
1417                     }
1418                     if (!(offsideON && layout[indentDepth]!=HARD))
1419                         skip();                         /* skip over hard }*/
1420                     if (offsideON)
1421                         unOffside();    /* otherwise, we have to insert a }*/
1422                     return '}';         /* to (try to) avoid an error...   */
1423
1424         /* Character and string literals                                   */
1425         case '\'' : top() = yylval = readChar();
1426                     return CHARLIT;
1427
1428         case '\"' : top() = yylval = readString();
1429                     return STRINGLIT;
1430     }
1431
1432 #if IPARAM
1433     if (c0=='?' && isIn(c1,SMALL) && !haskell98) {
1434         Text it;                        /* Look for implicit param name    */
1435         skip();
1436         it    = readIdent();
1437         top() = yylval = ap(IPVAR,it);
1438         return identType=IPVARID;
1439     }
1440 #endif
1441 #if TREX
1442     if (c0=='#' && isIn(c1,SMALL) && !haskell98) {
1443         Text it;                        /* Look for record selector name   */
1444         skip();
1445         it    = readIdent();
1446         top() = yylval = ap(RECSEL,mkExt(it));
1447         return identType=RECSELID;
1448     }
1449 #endif
1450     if (isIn(c0,LARGE)) {               /* Look for qualified name         */
1451         Text it = readIdent();          /* No keyword begins with LARGE ...*/
1452         if (c0=='.' && isIn(c1,(SMALL|LARGE|SYMBOL))) {
1453             Text it2 = NIL;
1454             skip();                     /* Skip qualifying dot             */
1455             if (isIn(c0,SYMBOL)) { /* Qualified operator */
1456                 it2 = readOperator();
1457                 if (opType==CONOP) {
1458                     top() = yylval = mkQConOp(it,it2);
1459                     return QCONOP;
1460                 } else {
1461                     top() = yylval = mkQVarOp(it,it2);
1462                     return QVAROP;
1463                 }
1464             } else {               /* Qualified identifier */
1465                 it2 = readIdent();
1466                 if (identType==CONID) {
1467                     top() = yylval = mkQCon(it,it2);
1468                     return QCONID;
1469                 } else {
1470                     top() = yylval = mkQVar(it,it2);
1471                     return QVARID;
1472                 }
1473             }
1474         } else {
1475             top() = yylval = mkCon(it);
1476             return identType;
1477         }
1478     }
1479     if (isIn(c0,(SMALL|LARGE))) {
1480         Text it = readIdent();
1481
1482         if (it==textCase)              return CASEXP;
1483         if (it==textOfK)               lookAhead(OF);
1484         if (it==textData)              return DATA;
1485         if (it==textType)              return TYPE;
1486         if (it==textIf)                return IF;
1487         if (it==textThen)              return THEN;
1488         if (it==textElse)              return ELSE;
1489         if (it==textWhere)             lookAhead(WHERE);
1490         if (it==textLet)               lookAhead(LET);
1491         if (it==textIn)                return IN;
1492         if (it==textInfix)             return INFIXN;
1493         if (it==textInfixl)            return INFIXL;
1494         if (it==textInfixr)            return INFIXR;
1495         if (it==textForeign)           return FOREIGN;
1496         if (it==textUnsafe)            return UNSAFE;
1497         if (it==textNewtype)           return TNEWTYPE;
1498         if (it==textDefault)           return DEFAULT;
1499         if (it==textDeriving)          return DERIVING;
1500         if (it==textDo)                lookAhead(DO);
1501         if (it==textClass)             return TCLASS;
1502         if (it==textInstance)          return TINSTANCE;
1503         if (it==textModule)            return TMODULE;
1504         if (it==textInterface)         return INTERFACE;
1505         if (it==textInstImport)        return INSTIMPORT;
1506         if (it==textImport)            return IMPORT;
1507         if (it==textExport)            return EXPORT;
1508         if (it==textDynamic)           return DYNAMIC;
1509         if (it==textCcall)             return CCALL;
1510         if (it==textStdcall)           return STDCALL;
1511         if (it==textUUExport)          return UUEXPORT;
1512         if (it==textHiding)            return HIDING;
1513         if (it==textQualified)         return QUALIFIED;
1514         if (it==textAsMod)             return ASMOD;
1515         if (it==textWildcard)          return '_';
1516         if (it==textAll && !haskell98) return ALL;
1517 #if IPARAM
1518         if (it==textWith && !haskell98) lookAhead(WITH);
1519         if (it==textDlet && !haskell98) lookAhead(DLET);
1520 #endif
1521         if (it==textUUAll)             return ALL;
1522         if (it==textRepeat && reading==KEYBOARD)
1523             return repeatLast();
1524
1525         top() = yylval = ap((identType==CONID ? CONIDCELL : VARIDCELL),it);
1526         return identType;
1527     }
1528
1529     if (isIn(c0,SYMBOL)) {
1530         Text it = readOperator();
1531
1532         if (it==textCoco)    return COCO;
1533         if (it==textEq)      return '=';
1534         if (it==textUpto)    return UPTO;
1535         if (it==textAs)      return '@';
1536         if (it==textLambda)  return '\\';
1537         if (it==textBar)     return '|';
1538         if (it==textFrom)    return FROM;
1539         if (it==textMinus)   return '-';
1540         if (it==textPlus)    return '+';
1541         if (it==textBang)    return '!';
1542         if (it==textDot)     return '.';
1543         if (it==textArrow)   return ARROW;
1544         if (it==textLazy)    return '~';
1545         if (it==textImplies) return IMPLIES;
1546         if (it==textRepeat && reading==KEYBOARD)
1547             return repeatLast();
1548
1549         top() = yylval = ap((opType==CONOP ? CONOPCELL : VAROPCELL),it);
1550         return opType;
1551     }
1552
1553     if (isIn(c0,DIGIT)) {
1554         top() = yylval = readNumber();
1555         return NUMLIT;
1556     }
1557
1558     ERRMSG(row) "Unrecognised character `\\%d' in column %d",
1559                 ((int)c0), column
1560     EEND;
1561     return 0; /*NOTREACHED*/
1562 }
1563
1564 static Int local repeatLast() {         /* Obtain last expression entered  */
1565     if (isNull(yylval=getLastExpr())) {
1566         ERRMSG(row) "Cannot use %s without any previous input", repeatStr
1567         EEND;
1568     }
1569     return REPEAT;
1570 }
1571
1572 Syntax defaultSyntax(t)                 /* Find default syntax of var named*/
1573 Text t; {                               /* by t ...                        */
1574     String s = textToStr(t);
1575     return isIn(s[0],SYMBOL) ? DEF_OPSYNTAX : APPLIC;
1576 }
1577
1578 Syntax syntaxOf(n)                      /* Find syntax for name            */
1579 Name n; {
1580     if (name(n).syntax==NO_SYNTAX)      /* Return default if no syntax set */
1581         return defaultSyntax(name(n).text);
1582     return name(n).syntax;
1583 }
1584
1585 /* --------------------------------------------------------------------------
1586  * main entry points to parser/lexer:
1587  * ------------------------------------------------------------------------*/
1588
1589 static Void local parseInput(startWith)/* Parse input with given first tok,*/
1590 Int startWith; {                       /* determining whether to read a    */
1591     firstToken   = TRUE;               /* script or an expression          */
1592     firstTokenIs = startWith;
1593     if (startWith==INTERFACE)
1594        offsideON = FALSE; else
1595        offsideON = TRUE;
1596
1597     clearStack();
1598     if (yyparse()) {                   /* This can only be parser overflow */
1599         ERRMSG(row) "Parser overflow"  /* as all syntax errors are caught  */
1600         EEND;                          /* in the parser...                 */
1601     }
1602     drop();
1603     if (!stackEmpty())                 /* stack should now be empty        */
1604         internal("parseInput");
1605 }
1606
1607 #ifdef HSCRIPT
1608 static String memPrefix = "@mem@";
1609 static Int lenMemPrefix = 5;   /* strlen(memPrefix)*/
1610
1611 Void makeMemScript(mem,fname)
1612 String mem;
1613 String fname; {
1614    strcat(fname,memPrefix);
1615    itoa((int)mem, fname+strlen(fname), 10);
1616 }
1617
1618 Bool isMemScript(fname)
1619 String fname; {
1620    return (strstr(fname,memPrefix) != NULL);
1621 }
1622
1623 String memScriptString(fname)
1624 String fname; {
1625     String p = strstr(fname,memPrefix);
1626     if (p) {
1627         return (String)atoi(p+lenMemPrefix);
1628     } else {
1629         return NULL;
1630     }
1631 }
1632
1633 Void parseScript(fname,len)             /* Read a script, possibly from mem */
1634 String fname;
1635 Long len; {
1636     input(RESET);
1637     if (isMemScript(fname)) {
1638         char* s = memScriptString(fname);
1639         stringInput(s);
1640     } else {
1641         fileInput(fname,len);
1642     }
1643     parseInput(SCRIPT);
1644 }
1645 #else
1646 Void parseScript(nm,len)               /* Read a script                    */
1647 String nm;
1648 Long   len; {                          /* Used to set a target for reading */
1649     input(RESET);
1650     fileInput(nm,len);
1651     parseInput(SCRIPT);
1652 }
1653 #endif
1654
1655 Void parseExp() {                      /* Read an expression to evaluate   */
1656     parseInput(EXPR);
1657     setLastExpr(inputExpr);
1658 }
1659
1660 Void parseContext() {                  /* Read a context to prove   */
1661     parseInput(CONTEXT);
1662 }
1663
1664 Void parseInterface(nm,len)            /* Read a GHC interface file        */
1665 String nm;
1666 Long   len; {                          /* Used to set a target for reading */
1667     input(RESET);
1668     fileInput(nm,len);
1669     parseInput(INTERFACE);
1670 }
1671
1672
1673 /* --------------------------------------------------------------------------
1674  * Input control:
1675  * ------------------------------------------------------------------------*/
1676
1677 Void input(what)
1678 Int what; {
1679     switch (what) {
1680         case INSTALL : initCharTab();
1681                        textCase       = findText("case");
1682                        textOfK        = findText("of");
1683                        textData       = findText("data");
1684                        textType       = findText("type");
1685                        textIf         = findText("if");
1686                        textThen       = findText("then");
1687                        textElse       = findText("else");
1688                        textWhere      = findText("where");
1689                        textLet        = findText("let");
1690                        textIn         = findText("in");
1691                        textInfix      = findText("infix");
1692                        textInfixl     = findText("infixl");
1693                        textInfixr     = findText("infixr");
1694                        textForeign    = findText("foreign");
1695                        textUnsafe     = findText("unsafe");
1696                        textNewtype    = findText("newtype");
1697                        textDefault    = findText("default");
1698                        textDeriving   = findText("deriving");
1699                        textDo         = findText("do");
1700                        textClass      = findText("class");
1701 #if IPARAM
1702                        textWith       = findText("with");
1703                        textDlet       = findText("dlet");
1704 #endif
1705                        textInstance   = findText("instance");
1706                        textCoco       = findText("::");
1707                        textEq         = findText("=");
1708                        textUpto       = findText("..");
1709                        textAs         = findText("@");
1710                        textLambda     = findText("\\");
1711                        textBar        = findText("|");
1712                        textMinus      = findText("-");
1713                        textPlus       = findText("+");
1714                        textFrom       = findText("<-");
1715                        textArrow      = findText("->");
1716                        textLazy       = findText("~");
1717                        textBang       = findText("!");
1718                        textDot        = findText(".");
1719                        textImplies    = findText("=>");
1720                        textPrelude    = findText("Prelude");
1721                        textNum        = findText("Num");
1722                        textModule     = findText("module");
1723                        textInterface  = findText("__interface");
1724                        textInstImport = findText("__instimport");
1725                        textExport     = findText("export");
1726                        textDynamic    = findText("dynamic");
1727                        textCcall      = findText("ccall");
1728                        textStdcall    = findText("stdcall");
1729                        textUUExport   = findText("__export");
1730                        textImport     = findText("import");
1731                        textHiding     = findText("hiding");
1732                        textQualified  = findText("qualified");
1733                        textAsMod      = findText("as");
1734                        textWildcard   = findText("_");
1735                        textAll        = findText("forall");
1736                        textUUAll      = findText("__forall");
1737                        varMinus       = mkVar(textMinus);
1738                        varPlus        = mkVar(textPlus);
1739                        varBang        = mkVar(textBang);
1740                        varDot         = mkVar(textDot);
1741                        varHiding      = mkVar(textHiding);
1742                        varQualified   = mkVar(textQualified);
1743                        varAsMod       = mkVar(textAsMod);
1744                        conMain        = mkCon(findText("Main"));
1745                        varMain        = mkVar(findText("main"));
1746                        evalDefaults   = NIL;
1747
1748                        input(RESET);
1749                        break;
1750
1751         case RESET   : tyconDefns   = NIL;
1752                        typeInDefns  = NIL;
1753                        valDefns     = NIL;
1754                        classDefns   = NIL;
1755                        instDefns    = NIL;
1756                        selDefns     = NIL;
1757                        genDefns     = NIL;
1758                        //primDefns    = NIL;
1759                        unqualImports= NIL;
1760                        foreignImports= NIL;
1761                        foreignExports= NIL;
1762                        defaultDefns = NIL;
1763                        defaultLine  = 0;
1764                        inputExpr    = NIL;
1765                        imps         = NIL;
1766                        closeAnyInput();
1767                        break;
1768
1769         case BREAK   : if (reading==KEYBOARD)
1770                            c0 = EOF;
1771                        break;
1772
1773         case MARK    : mark(tyconDefns);
1774                        mark(typeInDefns);
1775                        mark(valDefns);
1776                        mark(classDefns);
1777                        mark(instDefns);
1778                        mark(selDefns);
1779                        mark(genDefns);
1780                        //mark(primDefns);
1781                        mark(unqualImports);
1782                        mark(foreignImports);
1783                        mark(foreignExports);
1784                        mark(defaultDefns);
1785                        mark(evalDefaults);
1786                        mark(inputExpr);
1787                        mark(varMinus);
1788                        mark(varPlus);
1789                        mark(varBang);
1790                        mark(varDot);
1791                        mark(varHiding);
1792                        mark(varQualified);
1793                        mark(varAsMod);
1794                        mark(varMain);
1795                        mark(conMain);
1796                        mark(imps);
1797                        break;
1798     }
1799 }
1800
1801 /*-------------------------------------------------------------------------*/