-/* -*- mode: hugs-c; -*- */
/* --------------------------------------------------------------------------
* Input functions, lexical analysis parsing etc...
*
- * Copyright (c) The University of Nottingham and Yale University, 1994-1997.
- * All rights reserved. See NOTICE for details and conditions of use etc...
- * Hugs version 1.4, December 1997
+ * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the
+ * Yale Haskell Group, and the Oregon Graduate Institute of Science and
+ * Technology, 1994-1999, All rights reserved. It is distributed as
+ * free software under the license in the file "License", which is
+ * included in the distribution.
*
* $RCSfile: input.c,v $
- * $Revision: 1.2 $
- * $Date: 1998/12/02 13:22:12 $
+ * $Revision: 1.30 $
+ * $Date: 2000/04/25 17:43:49 $
* ------------------------------------------------------------------------*/
-#include "prelude.h"
+#include "hugsbasictypes.h"
#include "storage.h"
#include "connect.h"
-#include "charset.h"
-#include "input.h"
-#include "static.h"
-#include "interface.h"
-#include "command.h"
#include "errors.h"
-#include "link.h"
-#include "hugs.h" /* for target */
+
#include <ctype.h>
#if HAVE_GETDELIM_H
#include "getdelim.h"
#endif
-#include "machdep.h" /* for findPathname */
+#if IS_WIN32
+#include <windows.h>
+#endif
-#if HUGS_FOR_WINDOWS
+#if IS_WIN32
#undef IN
#endif
+#if HAVE_READLINE_LIBS && HAVE_READLINE_HEADERS
+#define USE_READLINE 1
+#else
+#define USE_READLINE 0
+#endif
+
+#if USE_READLINE
+#include <readline/readline.h>
+#include <readline/history.h>
+#endif
+
+
/* --------------------------------------------------------------------------
* Global data:
* ------------------------------------------------------------------------*/
-List tyconDefns = NIL; /* type constructor definitions */
-List typeInDefns = NIL; /* type synonym restrictions */
-List valDefns = NIL; /* value definitions in script */
-List opDefns = NIL; /* operator defns in script */
-List classDefns = NIL; /* class defns in script */
-List instDefns = NIL; /* instance defns in script */
-List selDefns = NIL; /* list of selector lists */
-List genDefns = NIL; /* list of generated names */
-List unqualImports = NIL; /* unqualified import list */
-List foreignImports = NIL; /* foreign imports */
-List foreignExports = NIL; /* foreign exportsd */
-List defaultDefns = NIL; /* default definitions (if any) */
-Int defaultLine = 0; /* line in which default defs occur*/
-List evalDefaults = NIL; /* defaults for evaluator */
-
-Cell inputExpr = NIL; /* input expression */
-Bool literateScripts = FALSE; /* TRUE => default to lit scripts */
-Bool literateErrors = TRUE; /* TRUE => report errs in lit scrs */
+List tyconDefns = NIL; /* type constructor definitions */
+List typeInDefns = NIL; /* type synonym restrictions */
+List valDefns = NIL; /* value definitions in script */
+List classDefns = NIL; /* class defns in script */
+List instDefns = NIL; /* instance defns in script */
+List selDefns = NIL; /* list of selector lists */
+List genDefns = NIL; /* list of generated names */
+List unqualImports = NIL; /* unqualified import list */
+List foreignImports = NIL; /* foreign imports */
+List foreignExports = NIL; /* foreign exportsd */
+List defaultDefns = NIL; /* default definitions (if any) */
+Int defaultLine = 0; /* line in which default defs occur*/
+List evalDefaults = NIL; /* defaults for evaluator */
+
+Cell inputExpr = NIL; /* input expression */
+Cell inputContext = NIL; /* input context */
+Bool literateScripts = FALSE; /* TRUE => default to lit scripts */
+Bool literateErrors = TRUE; /* TRUE => report errs in lit scrs */
+Bool offsideON = TRUE; /* TRUE => implement offside rule */
+Bool readingInterface = FALSE;
String repeatStr = 0; /* Repeat last expr */
* Local function prototypes:
* ------------------------------------------------------------------------*/
-static Void local fileInput Args((String,Long));
-static Bool local literateMode Args((String));
-static Bool local linecmp Args((String,String));
-static Int local nextLine Args((Void));
-static Void local skip Args((Void));
-static Void local thisLineIs Args((Int));
-static Void local newlineSkip Args((Void));
-static Void local closeAnyInput Args((Void));
-
- Int yyparse Args((Void)); /* can't stop yacc making this */
+static Void local initCharTab ( Void );
+static Void local fileInput ( String,Long );
+static Bool local literateMode ( String );
+static Bool local linecmp ( String,String );
+static Int local nextLine ( Void );
+static Void local skip ( Void );
+static Void local thisLineIs ( Int );
+static Void local newlineSkip ( Void );
+static Void local closeAnyInput ( Void );
+
+ Int yyparse ( Void ); /* can't stop yacc making this */
/* public, but don't advertise */
/* it in a header file. */
-static Void local endToken Args((Void));
-static Text local readOperator Args((Void));
-static Text local readIdent Args((Void));
-static Cell local readRadixNumber Args((Int));
-static Cell local readNumber Args((Void));
-static Cell local readChar Args((Void));
-static Cell local readString Args((Void));
-static Void local saveStrChr Args((Char));
-static Cell local readAChar Args((Bool));
-
-static Bool local lazyReadMatches Args((String));
-static Cell local readEscapeChar Args((Bool));
-static Void local skipGap Args((Void));
-static Cell local readCtrlChar Args((Void));
-static Cell local readOctChar Args((Void));
-static Cell local readHexChar Args((Void));
-static Int local readHexDigit Args((Char));
-static Cell local readDecChar Args((Void));
-
-static Void local goOffside Args((Int));
-static Void local unOffside Args((Void));
-static Bool local canUnOffside Args((Void));
-
-static Void local skipWhitespace Args((Void));
-static Int local yylex Args((Void));
-static Int local repeatLast Args((Void));
-
-static Void local parseInput Args((Int));
+static Void local endToken ( Void );
+static Text local readOperator ( Void );
+static Text local readIdent ( Void );
+static Cell local readRadixNumber ( Int );
+static Cell local readNumber ( Void );
+static Cell local readChar ( Void );
+static Cell local readString ( Void );
+static Void local saveStrChr ( Char );
+static Cell local readAChar ( Bool );
+
+static Bool local lazyReadMatches ( String );
+static Cell local readEscapeChar ( Bool );
+static Void local skipGap ( Void );
+static Cell local readCtrlChar ( Void );
+static Cell local readOctChar ( Void );
+static Cell local readHexChar ( Void );
+static Int local readHexDigit ( Char );
+static Cell local readDecChar ( Void );
+
+static Void local goOffside ( Int );
+static Void local unOffside ( Void );
+static Bool local canUnOffside ( Void );
+
+static Void local skipWhitespace ( Void );
+static Int local yylex ( Void );
+static Int local repeatLast ( Void );
+
+static Cell local parseInput ( Int );
+
+static Bool local doesNotExceed ( String,Int,Int );
+static Int local stringToInt ( String,Int );
+
/* --------------------------------------------------------------------------
* Text values for reserved words and special symbols:
static Text textThen, textElse, textWhere, textLet, textIn;
static Text textInfix, textInfixl, textInfixr, textForeign, textNewtype;
static Text textDefault, textDeriving, textDo, textClass, textInstance;
+static Text textMdo;
+#if IPARAM
+static Text textWith, textDlet;
+#endif
static Text textCoco, textEq, textUpto, textAs, textLambda;
static Text textBar, textMinus, textFrom, textArrow, textLazy;
static Text textBang, textDot, textAll, textImplies;
static Text textWildcard;
-static Text textModule, textImport, textPrelude, textPreludeHugs;
-static Text textHiding, textQualified, textAsMod;
-static Text textExport, textInterface, textRequires, textUnsafe;
+static Text textModule, textImport, textInterface, textInstImport;
+static Text textHiding, textQualified, textAsMod, textPrivileged;
+static Text textExport, textDynamic, textUUExport;
+static Text textUnsafe, textUUAll, textUUUsage;
-#if NPLUSK
+Text textCcall; /* ccall */
+Text textStdcall; /* stdcall */
+
+Text textNum; /* Num */
+Text textPrelPrim; /* PrelPrim */
+Text textPrelude; /* Prelude */
Text textPlus; /* (+) */
-#endif
-Cell conPrelude; /* Prelude */
static Cell conMain; /* Main */
static Cell varMain; /* main */
-static Cell conUnit; /* () */
-static Cell conList; /* [] */
-static Cell conNil; /* [] */
-static Cell conPreludeUnit; /* Prelude.() */
-static Cell conPreludeList; /* Prelude.[] */
-static Cell conPreludeNil; /* Prelude.[] */
-
static Cell varMinus; /* (-) */
+static Cell varPlus; /* (+) */
static Cell varBang; /* (!) */
static Cell varDot; /* (.) */
static Cell varHiding; /* hiding */
static Cell varQualified; /* qualified */
static Cell varAsMod; /* as */
-static Cell varNegate;
-static Cell varFlip;
-static Cell varEnumFrom;
-static Cell varEnumFromThen;
-static Cell varEnumFromTo;
-static Cell varEnumFromThenTo;
-
static List imps; /* List of imports to be chased */
+
+/* --------------------------------------------------------------------------
+ * Character set handling:
+ *
+ * Hugs follows Haskell 1.3 in assuming that input uses the ISO-8859-1
+ * character set. The following code provides methods for classifying
+ * input characters according to the lexical structure specified by the
+ * report. Hugs should still accept older programs because ASCII is
+ * essentially just a subset of the ISO character set.
+ *
+ * Notes: If you want to port Hugs to a machine that uses something
+ * substantially different from the ISO character set, then you will need
+ * to insert additional code to map between character sets.
+ *
+ * At some point, the following data structures may be exported in a .h
+ * file to allow the information contained here to be picked up in the
+ * implementation of LibChar is* primitives.
+ *
+ * Relies, implicitly but for this comment, on assumption that NUM_CHARS=256.
+ * ------------------------------------------------------------------------*/
+
+static Bool charTabBuilt;
+static unsigned char ctable[NUM_CHARS];
+#define isIn(c,x) (ctable[(unsigned char)(c)]&(x))
+#define isISO(c) (0<=(c) && (c)<NUM_CHARS)
+
+#define DIGIT 0x01
+#define SMALL 0x02
+#define LARGE 0x04
+#define SYMBOL 0x08
+#define IDAFTER 0x10
+#define ZPACE 0x20
+#define PRINT 0x40
+
+static Void local initCharTab() { /* Initialize char decode table */
+#define setRange(x,f,t) {Int i=f; while (i<=t) ctable[i++] |=x;}
+#define setChar(x,c) ctable[c] |= (x)
+#define setChars(x,s) {char *p=s; while (*p) ctable[(Int)*p++]|=x;}
+#define setCopy(x,c) {Int i; \
+ for (i=0; i<NUM_CHARS; ++i) \
+ if (isIn(i,c)) \
+ ctable[i]|=x; \
+ }
+
+ setRange(DIGIT, '0','9'); /* ASCII decimal digits */
+
+ setRange(SMALL, 'a','z'); /* ASCII lower case letters */
+ setRange(SMALL, 223,246); /* ISO lower case letters */
+ setRange(SMALL, 248,255); /* (omits division symbol, 247) */
+ setChar (SMALL, '_');
+
+ setRange(LARGE, 'A','Z'); /* ASCII upper case letters */
+ setRange(LARGE, 192,214); /* ISO upper case letters */
+ setRange(LARGE, 216,222); /* (omits multiplication, 215) */
+
+ setRange(SYMBOL, 161,191); /* Symbol characters + ':' */
+ setRange(SYMBOL, 215,215);
+ setChar (SYMBOL, 247);
+ setChars(SYMBOL, ":!#$%&*+./<=>?@\\^|-~");
+
+ setChar (IDAFTER, '\''); /* Characters in identifier */
+ setCopy (IDAFTER, (DIGIT|SMALL|LARGE));
+
+ setChar (ZPACE, ' '); /* ASCII space character */
+ setChar (ZPACE, 160); /* ISO non breaking space */
+ setRange(ZPACE, 9,13); /* special whitespace: \t\n\v\f\r */
+
+ setChars(PRINT, "(),;[]_`{}"); /* Special characters */
+ setChars(PRINT, " '\""); /* Space and quotes */
+ setCopy (PRINT, (DIGIT|SMALL|LARGE|SYMBOL));
+
+ charTabBuilt = TRUE;
+#undef setRange
+#undef setChar
+#undef setChars
+#undef setCopy
+}
+
+
/* --------------------------------------------------------------------------
* Single character input routines:
*
* At the lowest level of input, characters are read one at a time, with the
* current character held in c0 and the following (lookahead) character in
- * c1. The corrdinates of c0 within the file are held in (column,row).
+ * c1. The coordinates of c0 within the file are held in (column,row).
* The input stream is advanced by one character using the skip() function.
* ------------------------------------------------------------------------*/
#if USE_READLINE /* for command line editors */
static String currentLine; /* editline or GNU readline */
static String nextChar;
-#define nextConsoleChar() (unsigned char)(*nextChar=='\0' ? '\n' : *nextChar++)
-extern Void add_history Args((String));
-extern String readline Args((String));
+#define nextConsoleChar() \
+ (unsigned char)(*nextChar=='\0' ? '\n' : *nextChar++)
#else
-#define nextConsoleChar() getc(stdin)
+#define nextConsoleChar() getc(stdin)
#endif
static Int litLines; /* count defn lines in lit script */
Long len; { /* used to set target for reading) */
#if USE_PREPROCESSOR && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
if (preprocessor) {
- char cmd[100];
- strncpy(cmd,preprocessor,100);
- strncat(cmd," ",100);
- strncat(cmd,nm,100);
- cmd[99] = '\0'; /* paranoia */
+ Int reallen = strlen(preprocessor) + 1 + strlen(nm) + 1;
+ char *cmd = malloc(reallen);
+ if (cmd == NULL) {
+ ERRMSG(0) "Unable to allocate memory for filter command."
+ EEND;
+ }
+ strcpy(cmd,preprocessor);
+ strcat(cmd," ");
+ strcat(cmd,nm);
inputStream = popen(cmd,"r");
+ free(cmd);
} else {
inputStream = fopen(nm,"r");
}
row = 1;
nextStringChar = s;
+ if (!charTabBuilt)
+ initCharTab();
}
-static Bool local literateMode(nm) /* select literate mode for file */
+static Bool local literateMode(nm) /* Select literate mode for file */
String nm; {
char *dot = strrchr(nm,'.'); /* look for last dot in file name */
if (dot) {
return literateScripts; /* otherwise, use the default */
}
-Bool isInterfaceFile(nm) /* is nm an interface file? */
-String nm; {
- char *dot = strrchr(nm,'.'); /* look for last dot in file name */
- return (dot && filenamecmp(dot+1,"myhi")==0);
+
+Void hi_o_namesFromSrcName ( String srcName, String* hiName, String* oName )
+{
+ Int len;
+ String dot;
+ len = 1 + strlen ( srcName );
+ *hiName = malloc(len);
+ *oName = malloc(len);
+ if (!(*hiName && *oName)) internal("hi_o_namesFromSource");
+ (*hiName)[0] = (*oName)[0] = 0;
+ dot = strrchr(srcName, '.');
+ if (!dot) return;
+ if (filenamecmp(dot+1, "hs")==0 &&
+ filenamecmp(dot+1, "lhs")==0 &&
+ filenamecmp(dot+1, "verb")==0) return;
+
+ strcpy(*hiName, srcName);
+ dot = strrchr(*hiName, '.');
+ dot[1] = 'h';
+ dot[2] = 'i';
+ dot[3] = 0;
+
+ strcpy(*oName, srcName);
+ dot = strrchr(*oName, '.');
+ dot[1] = 'o';
+ dot[2] = 0;
}
+
/* This code originally came from Sigbjorn Finne (sof@dcs.gla.ac.uk).
* I've removed the loop (since newLineSkip contains a loop too) and
* replaced the warnings with errors. ADR
if (s[i] != '\0') { /* check s `isPrefixOf` line */
return FALSE;
}
- while (isIn(line[i], SPACE)) { /* allow whitespace at end of line */
+ while (isIn(line[i], ZPACE)) { /* allow whitespace at end of line */
++i;
}
return (line[i] == '\0');
if (lineLength <= 0) { /* EOF / IO error, who knows.. */
return lineLength;
}
- else if (lineLength >= 2 && lineBuffer[0] == '#' && lineBuffer[1] == '!') {
+ else if (lineLength >= 2 && lineBuffer[0] == '#' &&
+ lineBuffer[1] == '!') {
lineBuffer[0]='\n'; /* pretend it's a blank line */
lineBuffer[1]='\0';
lineLength=1;
closeAnyInput();
}
else if (reading==KEYBOARD) {
- allowBreak();
+ /* allowBreak(); */
if (c0=='\n')
c1 = EOF;
else {
c1 = nextConsoleChar();
- /* On Win32, hitting ctrl-C causes the next getchar to
- * fail - returning "-1" to indicate an error.
- * This is one of the rare cases where "-1" does not mean EOF.
- */
- if (EOF == c1 && !feof(stdin)) {
+#if IS_WIN32
+ Sleep(0);
+#endif
+ /* On Win32, hitting ctrl-C causes the next getchar to
+ * fail - returning "-1" to indicate an error.
+ * This is one of the rare cases where "-1" does not mean EOF.
+ */
+ if (EOF == c1 && (!feof(stdin) /* || broken==TRUE */)) {
c1 = ' ';
}
}
litLines++;
return;
}
- while (c0==' ' || c0=='\t')/* maybe line is blank? */
+ while (c0 != '\n' && isIn(c0,ZPACE)) /* maybe line is blank? */
skip();
if (c0=='\n' || c0==EOF)
thisLineIs(BLANKLINE);
* entry to the routine.
* ------------------------------------------------------------------------*/
-#define MAX_TOKEN 500
+#define MAX_TOKEN 4000
#define startToken() tokPos = 0
#define saveTokenChar(c) if (tokPos<=MAX_TOKEN) saveChar(c); else ++tokPos
#define saveChar(c) tokenStr[tokPos++]=(char)(c)
} while (isISO(c0) && isIn(c0,IDAFTER));
endToken();
identType = isIn(tokenStr[0],LARGE) ? CONID : VARID;
- return findText(tokenStr);
+ if (readingInterface)
+ return unZcodeThenFindText(tokenStr); else
+ return findText(tokenStr);
+}
+
+
+static Bool local doesNotExceed(s,radix,limit)
+String s;
+Int radix;
+Int limit; {
+ Int n = 0;
+ Int p = 0;
+ while (TRUE) {
+ if (s[p] == 0) return TRUE;
+ if (overflows(n,radix,s[p]-'0',limit)) return FALSE;
+ n = radix*n + (s[p]-'0');
+ p++;
+ }
+}
+
+static Int local stringToInt(s,radix)
+String s;
+Int radix; {
+ Int n = 0;
+ Int p = 0;
+ while (TRUE) {
+ if (s[p] == 0) return n;
+ n = radix*n + (s[p]-'0');
+ p++;
+ }
}
static Cell local readRadixNumber(r) /* Read literal in specified radix */
Int r; { /* from input of the form 0c{digs} */
Int d;
startToken();
- saveTokenChar(c0);
skip(); /* skip leading zero */
if ((d=readHexDigit(c1))<0 || d>=r) {
/* Special case; no digits, lex as */
/* if it had been written "0 c..." */
saveTokenChar('0');
} else {
- Int n = 0;
- saveTokenChar(c0);
skip();
do {
- saveTokenChar(c0);
+ saveTokenChar('0'+readHexDigit(c0));
skip();
d = readHexDigit(c0);
} while (d>=0 && d<r);
}
endToken();
- /* ToDo: return an INTCELL if small enough */
- return stringToBignum(tokenStr);
+
+ if (doesNotExceed(tokenStr,r,MAXPOSINT))
+ return mkInt(stringToInt(tokenStr,r));
+ else
+ if (r == 10)
+ return stringToBignum(tokenStr);
+ else {
+ ERRMSG(row) "Hexadecimal or octal constant exceeds `Int' range"
+ EEND;
+ }
}
static Cell local readNumber() { /* read numeric constant */
- Bool intTooLarge = FALSE;
if (c0=='0') {
if (c1=='x' || c1=='X') /* Maybe a hexadecimal literal? */
if (c0!='.' || !isISO(c1) || !isIn(c1,DIGIT)) {
endToken();
- /* ToDo: return an INTCELL if small enough */
- return stringToBignum(tokenStr);
+ if (doesNotExceed(tokenStr,10,MAXPOSINT))
+ return mkInt(stringToInt(tokenStr,10)); else
+ return stringToBignum(tokenStr);
}
saveTokenChar(c0); /* save decimal point */
}
endToken();
- return stringToFloat(tokenStr);
+ return mkFloat(stringToFloat(tokenStr));
}
+
+
+
+
+
+
static Cell local readChar() { /* read character constant */
Cell charRead;
ERRMSG(row) "Illegal escape sequence"
EEND;
}
- else if (isIn(c0,SPACE)) {
+ else if (isIn(c0,ZPACE)) {
if (isStrLit) {
skipGap();
return NIL;
newlineSkip();
else
skip();
- while (isISO(c0) && isIn(c0,SPACE));
+ while (isISO(c0) && isIn(c0,ZPACE));
if (c0!='\\') {
ERRMSG(row) "Missing `\\' terminating string literal gap"
EEND;
if (s) {
String t = s;
Char c;
- while ((c = *t)!=0 && isISO(c) && isIn(c,PRINT) && c!='"' && !isIn(c,SPACE)) {
+ while ((c = *t)!=0 && isISO(c)
+ && isIn(c,PRINT) && c!='"' && !isIn(c,ZPACE)) {
t++;
}
if (*t) {
}
/* -------------------------------------------------------------------------
- * Handle special types of input for us in interpreter:
+ * Handle special types of input for use in interpreter:
* -----------------------------------------------------------------------*/
Command readCommand(cmds,start,sys) /* read command at start of input */
do { /* which is empty */
saveTokenChar(c0);
skip();
- } while (c0!=EOF && !isIn(c0,SPACE));
+ } while (c0!=EOF && !isIn(c0,ZPACE));
endToken();
for (; cmds->cmdString; ++cmds)
return 0;
startToken();
- while (c0!=EOF && !isIn(c0,SPACE)) {
- if (c0=='"') {
+ while (c0!=EOF && !isIn(c0,ZPACE)) {
+ if (c0=='"') {
skip();
while (c0!=EOF && c0!='\"') {
Cell c = readAChar(TRUE);
- if (nonNull(c))
+ if (nonNull(c)) {
saveTokenChar(charOf(c));
+ }
}
if (c0=='"')
skip();
* - Otherwise, if no `{' follows the keywords WHERE/LET or OF, a SOFT `{'
* is inserted with the column number of the first token after the
* WHERE/LET/OF keyword.
- * - When a soft indentation is uppermost on the indetation stack with
+ * - When a soft indentation is uppermost on the indentation stack with
* column col' we insert:
* `}' in front of token with column<col' and pop indentation off stack,
* `;' in front of token with column==col'.
static Void local goOffside(col) /* insert offside marker */
Int col; { /* for specified column */
+ assert(offsideON);
if (indentDepth>=MAXINDENT) {
ERRMSG(row) "Too many levels of program nesting"
EEND;
}
static Void local unOffside() { /* leave layout rule area */
+ assert(offsideON);
indentDepth--;
}
static Bool local canUnOffside() { /* Decide if unoffside permitted */
+ assert(offsideON);
return indentDepth>=0 && layout[indentDepth]!=HARD;
}
return; /* report allows ... */
else if (c0=='\n')
newlineSkip();
- else if (isIn(c0,SPACE))
+ else if (isIn(c0,ZPACE))
skip();
else if (c0=='{' && c1=='-') { /* (potentially) nested comment */
Int nesting = 1;
return firstTokenIs;
}
- if (insertOpen) { /* insert `soft' opening brace */
+ if (offsideON && insertOpen) { /* insert `soft' opening brace */
insertOpen = FALSE;
insertedToken = TRUE;
goOffside(column);
push(yylval = mkInt(row)); /* default token value is line no. */
/* subsequent changes to yylval must also set top() to the same value */
- if (indentDepth>=0) /* layout rule(s) active ? */
+ if (indentDepth>=0) { /* layout rule(s) active ? */
if (insertedToken) /* avoid inserting multiple `;'s */
insertedToken = FALSE; /* or putting `;' after `{' */
- else if (layout[indentDepth]!=HARD)
+ else
+ if (offsideON && layout[indentDepth]!=HARD) {
if (column<layout[indentDepth]) {
unOffside();
return '}';
insertedToken = TRUE;
return ';';
}
+ }
+ }
/* ----------------------------------------------------------------------
* Now try to identify token type:
* --------------------------------------------------------------------*/
+ if (readingInterface) {
+ if (c0 == '(' && c1 == '#') { skip(); skip(); return UTL; };
+ if (c0 == '#' && c1 == ')') { skip(); skip(); return UTR; };
+ }
+
switch (c0) {
case EOF : return 0; /* End of file/input */
case '[' : skip(); return '[';
case ']' : skip(); return ']';
case '`' : skip(); return '`';
- case '{' : goOffside(HARD);
+ case '{' : if (offsideON) goOffside(HARD);
skip();
return '{';
- case '}' : if (indentDepth<0) {
+ case '}' : if (offsideON && indentDepth<0) {
ERRMSG(row) "Misplaced `}'"
EEND;
}
- if (layout[indentDepth]==HARD) /* skip over hard }*/
- skip();
- unOffside(); /* otherwise, we have to insert a }*/
+ if (!(offsideON && layout[indentDepth]!=HARD))
+ skip(); /* skip over hard }*/
+ if (offsideON)
+ unOffside(); /* otherwise, we have to insert a }*/
return '}'; /* to (try to) avoid an error... */
/* Character and string literals */
return STRINGLIT;
}
+#if IPARAM
+ if (c0=='?' && isIn(c1,SMALL) && !haskell98) {
+ Text it; /* Look for implicit param name */
+ skip();
+ it = readIdent();
+ top() = yylval = ap(IPVAR,it);
+ return identType=IPVARID;
+ }
+#endif
#if TREX
- if (c0=='#' && isIn(c1,SMALL)) { /* Look for record selector name */
- Text it;
+ if (c0=='#' && isIn(c1,SMALL) && !haskell98) {
+ Text it; /* Look for record selector name */
skip();
it = readIdent();
top() = yylval = ap(RECSEL,mkExt(it));
} else {
top() = yylval = mkCon(it);
return identType;
- } /* We could easily keep a record of*/
- } /* the qualifying name here ... */
- if (isIn(c0,(SMALL|LARGE)) || c0 == '_') {
+ }
+ }
+ if (isIn(c0,(SMALL|LARGE))) {
Text it = readIdent();
if (it==textCase) return CASEXP;
if (it==textWhere) lookAhead(WHERE);
if (it==textLet) lookAhead(LET);
if (it==textIn) return IN;
- if (it==textInfix) return INFIX;
+ if (it==textInfix) return INFIXN;
if (it==textInfixl) return INFIXL;
if (it==textInfixr) return INFIXR;
if (it==textForeign) return FOREIGN;
if (it==textDo) lookAhead(DO);
if (it==textClass) return TCLASS;
if (it==textInstance) return TINSTANCE;
- if (it==textModule) return MODULETOK;
+ if (it==textModule) return TMODULE;
if (it==textInterface) return INTERFACE;
- if (it==textRequires) return REQUIRES;
+ if (it==textInstImport) return INSTIMPORT;
if (it==textImport) return IMPORT;
if (it==textExport) return EXPORT;
+ if (it==textDynamic) return DYNAMIC;
+ if (it==textCcall) return CCALL;
+ if (it==textStdcall) return STDKALL;
+ if (it==textUUExport) return UUEXPORT;
if (it==textHiding) return HIDING;
if (it==textQualified) return QUALIFIED;
if (it==textAsMod) return ASMOD;
if (it==textWildcard) return '_';
- if (it==textAll) return ALL;
+ if (it==textAll && !haskell98) return ALL;
+#if IPARAM
+ if (it==textWith && !haskell98) lookAhead(WITH);
+ if (it==textDlet && !haskell98) lookAhead(DLET);
+ if (it==textMdo && !haskell98) lookAhead(MDO);
+#endif
+ if (it==textUUAll) return ALL;
+ if (it==textUUUsage) return UUUSAGE;
if (it==textRepeat && reading==KEYBOARD)
return repeatLast();
if (it==textBar) return '|';
if (it==textFrom) return FROM;
if (it==textMinus) return '-';
+ if (it==textPlus) return '+';
if (it==textBang) return '!';
if (it==textDot) return '.';
if (it==textArrow) return ARROW;
return NUMLIT;
}
- ERRMSG(row) "Unrecognised character `\\%d' in column %d", ((int)c0), column
+ ERRMSG(row) "Unrecognised character `\\%d' in column %d",
+ ((int)c0), column
EEND;
return 0; /*NOTREACHED*/
}
return REPEAT;
}
+Syntax defaultSyntax(t) /* Find default syntax of var named*/
+Text t; { /* by t ... */
+ String s = textToStr(t);
+ return isIn(s[0],SYMBOL) ? DEF_OPSYNTAX : APPLIC;
+}
+
+Syntax syntaxOf(n) /* Find syntax for name */
+Name n; {
+ if (name(n).syntax==NO_SYNTAX) /* Return default if no syntax set */
+ return defaultSyntax(name(n).text);
+ return name(n).syntax;
+}
+
/* --------------------------------------------------------------------------
* main entry points to parser/lexer:
* ------------------------------------------------------------------------*/
-static Void local parseInput(startWith)/* Parse input with given first tok,*/
+static Cell local parseInput(startWith)/* Parse input with given first tok,*/
Int startWith; { /* determining whether to read a */
- firstToken = TRUE; /* script or an expression */
+ Cell final = NIL; /* script or an expression */
+ firstToken = TRUE;
firstTokenIs = startWith;
+ if (startWith==INTERFACE) {
+ offsideON = FALSE; readingInterface = TRUE;
+ } else {
+ offsideON = TRUE; readingInterface = FALSE;
+ }
clearStack();
if (yyparse()) { /* This can only be parser overflow */
ERRMSG(row) "Parser overflow" /* as all syntax errors are caught */
EEND; /* in the parser... */
}
- drop();
- assert(stackEmpty()); /* stack should now be empty */
+
+ if (startWith==SCRIPT) pop(); /* zap spurious closing } token */
+ final = pop();
+
+ if (!stackEmpty()) /* stack should now be empty */
+ internal("parseInput");
+ return final;
+}
+
+Void parseExp() { /* Read an expression to evaluate */
+ parseInput(EXPR);
+ setLastExpr(inputExpr);
}
-Void parseScript(nm,len) /* Read a script */
+#if EXPLAIN_INSTANCE_RESOLUTION
+Void parseContext() { /* Read a context to prove */
+ parseInput(CONTEXT);
+}
+#endif
+
+Cell parseInterface(nm,len) /* Read a GHC interface file */
String nm;
Long len; { /* Used to set a target for reading */
- input(RESET);
- fileInput(nm,len);
- parseInput(SCRIPT);
+ input(RESET);
+ Printf("Reading interface \"%s\"\n", nm );
+ fileInput(nm,len);
+ return parseInput(INTERFACE);
}
-Void parseInterface(nm,len) /* Read a GHC interface file */
+Cell parseModule(nm,len) /* Read a module */
String nm;
Long len; { /* Used to set a target for reading */
input(RESET);
+ Printf("Reading source file \"%s\"\n", nm );
fileInput(nm,len);
- parseInput(INTERFACE);
+ return parseInput(SCRIPT);
}
-Void parseExp() { /* Read an expression to evaluate */
- parseInput(EXPR);
- setLastExpr(inputExpr);
-}
/* --------------------------------------------------------------------------
* Input control:
Void input(what)
Int what; {
switch (what) {
- case INSTALL : initCharTab();
+ case POSTPREL: break;
+
+ case PREPREL : initCharTab();
textCase = findText("case");
textOfK = findText("of");
textData = findText("data");
textDefault = findText("default");
textDeriving = findText("deriving");
textDo = findText("do");
+ textMdo = findText("mdo");
textClass = findText("class");
+#if IPARAM
+ textWith = findText("with");
+ textDlet = findText("dlet");
+#endif
textInstance = findText("instance");
textCoco = findText("::");
textEq = findText("=");
textLambda = findText("\\");
textBar = findText("|");
textMinus = findText("-");
+ textPlus = findText("+");
textFrom = findText("<-");
textArrow = findText("->");
textLazy = findText("~");
textBang = findText("!");
textDot = findText(".");
textImplies = findText("=>");
-#if NPLUSK
- textPlus = findText("+");
-#endif
+ textPrelPrim = findText("PrelPrim");
+ textPrelude = findText("Prelude");
+ textNum = findText("Num");
textModule = findText("module");
textInterface = findText("__interface");
- textRequires = findText("__requires");
+ textInstImport = findText("__instimport");
+ textExport = findText("export");
+ textDynamic = findText("dynamic");
+ textCcall = findText("ccall");
+ textStdcall = findText("stdcall");
+ textUUExport = findText("__export");
textImport = findText("import");
- textExport = findText("__export");
textHiding = findText("hiding");
textQualified = findText("qualified");
textAsMod = findText("as");
textWildcard = findText("_");
textAll = findText("forall");
+ textUUAll = findText("__forall");
+ textUUUsage = findText("__u");
varMinus = mkVar(textMinus);
+ varPlus = mkVar(textPlus);
varBang = mkVar(textBang);
varDot = mkVar(textDot);
varHiding = mkVar(textHiding);
varAsMod = mkVar(textAsMod);
conMain = mkCon(findText("Main"));
varMain = mkVar(findText("main"));
- textPrelude = findText("Prelude");
- textPreludeHugs= findText("PreludeBuiltin");
- conPrelude = mkCon(textPrelude);
- conNil = mkCon(findText("[]"));
- conList = mkCon(findText("[]"));
- conUnit = mkCon(findText("()"));
- conPreludeNil = mkQCon(textPreludeHugs,findText("[]"));
- conPreludeList = mkQCon(textPreludeHugs,findText("[]"));
- conPreludeUnit = mkQCon(textPreludeHugs,findText("()"));
- varNegate = mkQVar(textPreludeHugs,findText("negate"));
- varFlip = mkQVar(textPreludeHugs,findText("flip"));
- varEnumFrom = mkQVar(textPreludeHugs,findText("enumFrom"));
- varEnumFromThen = mkQVar(textPreludeHugs,findText("enumFromThen"));
- varEnumFromTo = mkQVar(textPreludeHugs,findText("enumFromTo"));
- varEnumFromThenTo = mkQVar(textPreludeHugs,findText("enumFromThenTo"));
-
evalDefaults = NIL;
input(RESET);
case RESET : tyconDefns = NIL;
typeInDefns = NIL;
valDefns = NIL;
- opDefns = NIL;
classDefns = NIL;
instDefns = NIL;
selDefns = NIL;
case MARK : mark(tyconDefns);
mark(typeInDefns);
mark(valDefns);
- mark(opDefns);
mark(classDefns);
mark(instDefns);
mark(selDefns);
mark(evalDefaults);
mark(inputExpr);
mark(varMinus);
- mark(varNegate);
- mark(varFlip);
- mark(varEnumFrom);
- mark(varEnumFromThen);
- mark(varEnumFromTo);
- mark(varEnumFromThenTo);
+ mark(varPlus);
mark(varBang);
mark(varDot);
mark(varHiding);
mark(varQualified);
mark(varAsMod);
mark(varMain);
- mark(conPrelude);
mark(conMain);
- mark(conNil);
- mark(conList);
- mark(conUnit);
- mark(conPreludeNil);
- mark(conPreludeList);
- mark(conPreludeUnit);
mark(imps);
break;
}
projects / ghc-hetmet.git / blobdiff