From 4847ea83e1d0f4fa8596b71ba64519bdb004de7d Mon Sep 17 00:00:00 2001 From: andy Date: Wed, 20 Oct 1999 02:16:05 +0000 Subject: [PATCH] [project @ 1999-10-20 02:15:56 by andy] Adding final diffs between Hugs98 (Jan99) and Hugs98 (Sep99) manually to STG Hugs. --- ghc/includes/options.h | 12 +- ghc/interpreter/compiler.c | 16 ++- ghc/interpreter/connect.h | 27 ++++- ghc/interpreter/dynamic.c | 14 ++- ghc/interpreter/hugs.c | 15 +-- ghc/interpreter/machdep.c | 75 ++++++++++++- ghc/interpreter/output.c | 47 ++++++-- ghc/interpreter/parser.y | 156 ++++++++++++++++++++------ ghc/interpreter/preds.c | 266 ++++++++++++++++++++++++++++++++++++++++++-- ghc/interpreter/prelude.h | 18 ++- ghc/interpreter/storage.c | 21 +++- 11 files changed, 577 insertions(+), 90 deletions(-) diff --git a/ghc/includes/options.h b/ghc/includes/options.h index a0315c5..e395d53 100644 --- a/ghc/includes/options.h +++ b/ghc/includes/options.h @@ -13,8 +13,8 @@ * Hugs version 1.4, December 1997 * * $RCSfile: options.h,v $ - * $Revision: 1.8 $ - * $Date: 1999/05/11 16:46:20 $ + * $Revision: 1.9 $ + * $Date: 1999/10/20 02:15:56 $ * ------------------------------------------------------------------------*/ @@ -267,6 +267,10 @@ /* Doesn't work in current system - I don't know what the primops do */ #define TREX 0 +/* Define if :xplain should be enabled */ +#define EXPLAIN_INSTANCE_RESOLUTION 0 + + /* Define if you want to run Haskell code through a preprocessor * * Note that the :reload command doesn't know about any dependencies @@ -332,10 +336,12 @@ /* Define if debugging generated bytecodes or the bytecode interpreter */ #define DEBUG_CODE 1 +/* Define if debugging generated supercombinator definitions or compiler */ +#define DEBUG_SHOWSC 0 + /* Define if you want to use a low-level printer from within a debugger */ #define DEBUG_PRINTER 1 - /* -------------------------------------------------------------------------- * Experimental features * These are likely to disappear/change in future versions and should not diff --git a/ghc/interpreter/compiler.c b/ghc/interpreter/compiler.c index c70d56c..0d5c2bd 100644 --- a/ghc/interpreter/compiler.c +++ b/ghc/interpreter/compiler.c @@ -11,8 +11,8 @@ * included in the distribution. * * $RCSfile: compiler.c,v $ - * $Revision: 1.9 $ - * $Date: 1999/10/15 21:41:03 $ + * $Revision: 1.10 $ + * $Date: 1999/10/20 02:15:58 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -136,7 +136,9 @@ Cell e; { case STRCELL : case BIGCELL : case CHARCELL : return e; - +#if IPARAM + case IPVAR : return nameId; +#endif case FINLIST : mapOver(translate,snd(e)); return mkConsList(snd(e)); @@ -215,7 +217,15 @@ static List local transBinds(bs) /* Translate list of bindings: */ List bs; { /* eliminating pattern matching on */ List newBinds = NIL; /* lhs of bindings. */ for (; nonNull(bs); bs=tl(bs)) { +#if IPARAM + Cell v = fst(hd(bs)); + while (isAp(v) && fst(v) == nameInd) + v = arg(v); + fst(hd(bs)) = v; + if (isVar(v)) { +#else if (isVar(fst(hd(bs)))) { +#endif mapProc(transAlt,snd(hd(bs))); newBinds = cons(hd(bs),newBinds); } diff --git a/ghc/interpreter/connect.h b/ghc/interpreter/connect.h index 5d3f097..0864ba8 100644 --- a/ghc/interpreter/connect.h +++ b/ghc/interpreter/connect.h @@ -8,8 +8,8 @@ * included in the distribution. * * $RCSfile: connect.h,v $ - * $Revision: 1.11 $ - * $Date: 1999/10/16 02:17:30 $ + * $Revision: 1.12 $ + * $Date: 1999/10/20 02:15:59 $ * ------------------------------------------------------------------------*/ /* -------------------------------------------------------------------------- @@ -156,6 +156,7 @@ extern Bool preludeLoaded; /* TRUE => prelude has been loaded */ extern Bool gcMessages; /* TRUE => print GC messages */ extern Bool literateScripts; /* TRUE => default lit scripts */ extern Bool literateErrors; /* TRUE => report errs in lit scrs */ +extern Bool showInstRes; /* TRUE => show instance resolution */ extern Bool optimise; /* TRUE => simplify STG */ extern Int cutoff; /* Constraint Cutoff depth */ @@ -326,8 +327,26 @@ extern Bool broken; /* indicates interrupt received */ # define ctrlbrk(bh) # define allowBreak() kbhit() #else /* !HUGS_FOR_WINDOWS */ -# define ctrlbrk(bh) signal(SIGINT,bh); signal(SIGBREAK,bh) -# define allowBreak() if (broken) { broken=FALSE; sigRaise(breakHandler); } +# if HAVE_SIGPROCMASK +# include +# define ctrlbrk(bh) { sigset_t mask; \ + signal(SIGINT,bh); \ + sigemptyset(&mask); \ + sigaddset(&mask, SIGINT); \ + sigprocmask(SIG_UNBLOCK, &mask, NULL); \ + } +# else +# define ctrlbrk(bh) signal(SIGINT,bh) +# endif +#if SYMANTEC_C +extern int time_release; +extern int allow_break_count; +# define allowBreak() if (time_release !=0 && \ + (++allow_break_count % time_release) == 0) \ + ProcessEvent(); +#else +# define allowBreak() if (broken) { broken=FALSE; sigRaise(breakHandler); } +#endif #endif /* !HUGS_FOR_WINDOWS */ /*--------------------------------------------------------------------------- diff --git a/ghc/interpreter/dynamic.c b/ghc/interpreter/dynamic.c index 3718c44..58e085e 100644 --- a/ghc/interpreter/dynamic.c +++ b/ghc/interpreter/dynamic.c @@ -9,8 +9,8 @@ * included in the distribution. * * $RCSfile: dynamic.c,v $ - * $Revision: 1.7 $ - * $Date: 1999/10/15 21:41:05 $ + * $Revision: 1.8 $ + * $Date: 1999/10/20 02:15:59 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -78,11 +78,17 @@ String symbol; { #else /* eg FreeBSD doesn't have RTLD_LAZY */ ObjectFile instance = dlopen(dll,1); #endif + void *sym; + if (NULL == instance) { - ERRMSG(0) "Error %s while importing DLL \"%s\"", dlerror(), dll + ERRMSG(0) "Error while importing DLL \"%s\":\n%s\n", dll, dlerror() EEND; } - return dlsym(instance,symbol); + if (sym = dlsym(instance,symbol)) + return sym; + + ERRMSG(0) "Error loading sym:\n%s\n", dlerror() + EEND; } #elif HAVE_DL_H /* eg HPUX */ diff --git a/ghc/interpreter/hugs.c b/ghc/interpreter/hugs.c index 92e8a35..7060e35 100644 --- a/ghc/interpreter/hugs.c +++ b/ghc/interpreter/hugs.c @@ -9,8 +9,8 @@ * included in the distribution. * * $RCSfile: hugs.c,v $ - * $Revision: 1.14 $ - * $Date: 1999/10/19 23:51:57 $ + * $Revision: 1.15 $ + * $Date: 1999/10/20 02:15:59 $ * ------------------------------------------------------------------------*/ #include @@ -1422,8 +1422,6 @@ static Void local showtype() { /* print type of expression (if any)*/ static Void local browseit(mod,t) Module mod; String t; { -#if 0 - /* AJG: DISABLED FOR NOW */ if (nonNull(mod)) { Cell cs; Printf("module %s where\n",textToStr(module(mod).text)); @@ -1444,9 +1442,6 @@ String t; { } else if (isSfun(nm)) { Printf(" -- selector function"); } - if (name(nm).primDef) { - Printf(" -- primitive"); - } Printf("\n"); } } @@ -1456,7 +1451,6 @@ String t; { Printf("Unknown module %s\n",t); } } -#endif } static Void local browse() { /* browse modules */ @@ -1715,8 +1709,7 @@ Text t; { Printf(" => "); } printPred(stdout,cclass(cl).head); -#if 0 - /* AJG: commented out for now */ + if (nonNull(cclass(cl).fds)) { List fds = cclass(cl).fds; String pre = " | "; @@ -1726,7 +1719,7 @@ Text t; { pre = ", "; } } -#endif + if (nonNull(cclass(cl).members)) { List ms = cclass(cl).members; Printf(" where"); diff --git a/ghc/interpreter/machdep.c b/ghc/interpreter/machdep.c index 56089a7..9b5579e 100644 --- a/ghc/interpreter/machdep.c +++ b/ghc/interpreter/machdep.c @@ -13,8 +13,8 @@ * included in the distribution. * * $RCSfile: machdep.c,v $ - * $Revision: 1.8 $ - * $Date: 1999/10/15 21:40:52 $ + * $Revision: 1.9 $ + * $Date: 1999/10/20 02:16:01 $ * ------------------------------------------------------------------------*/ #ifdef HAVE_SIGNAL_H @@ -100,6 +100,9 @@ extern unsigned _stklen = 8000; /* Allocate an 8k stack segment */ #ifdef HAVE_UNIX_H #include #endif +#if SYMANTEC_C +int allow_break_count = 0; +#endif /* -------------------------------------------------------------------------- * Prototypes for registry reading @@ -113,7 +116,7 @@ extern unsigned _stklen = 8000; /* Allocate an 8k stack segment */ #endif #define HugsRoot ("SOFTWARE\\Haskell\\Hugs\\" HUGS_VERSION "\\") -#define ProjectRoot ("SOFTWARE\\Haskell\\Hugs\\Projects\\") +#define ProjectRoot ("SOFTWARE\\Haskell\\Projects\\") static Bool local createKey Args((HKEY, String, PHKEY, REGSAM)); static Bool local queryValue Args((HKEY, String, String, LPDWORD, LPBYTE, DWORD)); @@ -306,7 +309,7 @@ static String local hugsdir() { /* directory containing lib/Prelude.hs */ } #if HSCRIPT -static String local hscriptDir() { /* directory containing ?? what Daan? */ +static String local hscriptDir() { /* Directory containing hscript.dll */ static char dir[FILENAME_MAX+1] = ""; if (dir[0] == '\0') { /* not initialised yet */ String s = readRegString(HKEY_LOCAL_MACHINE,HScriptRoot,"InstallDir",""); @@ -1064,7 +1067,54 @@ Int readTerminalChar() { /* read character from terminal */ if (terminalEchoReqd) { return getchar(); } else { - Int c = getch(); +#if IS_WIN32 && !HUGS_FOR_WINDOWS && !__BORLANDC__ + /* When reading a character from the console/terminal, we want + * to operate in 'raw' mode (to use old UNIX tty parlance) and have + * it return when a character is available and _not_ wait until + * the next time the user hits carriage return. On Windows platforms, + * this _can_ be done by reading directly from the console, using + * getch(). However, this doesn't sit well with programming + * environments such as Emacs which allow you to create sub-processes + * running Hugs, and then communicate with the running interpreter + * through its standard input and output handles. If you use getch() + * in that setting, you end up trying to read the (unused) console + * of the editor itself, through which not a lot of characters is + * bound to come out, since the editor communicates input to Hugs + * via the standard input handle. + * + * To avoid this rather unfortunate situation, we use the Win32 + * console API and re-jig the input properties of the standard + * input handle before trying to read a character using stdio's + * getchar(). + * + * The 'cost' of this solution is that it is Win32 specific and + * won't work with Windows 3.1 + it is kind of ugly and verbose + * to have to futz around with the console properties on a + * per-char basis. Both of these disadvantages aren't in my + * opinion fatal. + * + * -- sof 5/99 + */ + Int c; + DWORD mo; + HANDLE hIn; + + /* I don't quite understand why, but if the FILE*'s underlying file + descriptor is in text mode, we seem to lose the first carriage + return. + */ + setmode(fileno(stdin), _O_BINARY); + hIn = GetStdHandle(STD_INPUT_HANDLE); + GetConsoleMode(hIn, &mo); + SetConsoleMode(hIn, mo & ~(ENABLE_LINE_INPUT | ENABLE_ECHO_INPUT)); + c = getc(stdin); + + /* Same as it ever was - revert back state of stdin. */ + SetConsoleMode(hIn, mo); + setmode(fileno(stdin), _O_TEXT); +#else + Int c = getch(); +#endif return c=='\r' ? '\n' : c; /* slight paranoia about CR-LF */ } } @@ -1121,8 +1171,21 @@ static sigHandler(panic) { /* exit in a panic, on receipt of */ } #endif /* !DONT_PANIC */ +#if IS_WIN32 +BOOL WINAPI consoleHandler(DWORD dwCtrlType) { + switch (dwCtrlType) { /* Allows Hugs to be terminated */ + case CTRL_CLOSE_EVENT : /* from the window's close menu. */ + ExitProcess(0); + } + return FALSE; +} +#endif + static Void local installHandlers() { /* Install handlers for all fatal */ /* signals except SIGINT and SIGBREAK*/ +#if IS_WIN32 + SetConsoleCtrlHandler(consoleHandler,TRUE); +#endif #if !DONT_PANIC && !DOS # ifdef SIGABRT signal(SIGABRT,panic); @@ -1173,7 +1236,7 @@ String nm; { /* or just line may be zero */ String ec = editorCmd; String rd = NULL; /* Set to nonnull to redo ... */ - for (; n>0 && *he && *he!=' '; n--) + for (; n>0 && *he && *he!=' ' && *he!='%'; n--) *ec++ = *he++; /* Copy editor name to buffer */ /* assuming filename ends at space */ diff --git a/ghc/interpreter/output.c b/ghc/interpreter/output.c index bc0d75e..904d4c4 100644 --- a/ghc/interpreter/output.c +++ b/ghc/interpreter/output.c @@ -10,8 +10,8 @@ * included in the distribution. * * $RCSfile: output.c,v $ - * $Revision: 1.7 $ - * $Date: 1999/10/16 02:17:28 $ + * $Revision: 1.8 $ + * $Date: 1999/10/20 02:16:02 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -148,6 +148,18 @@ Cell e; { case CONOPCELL : unlexVar(textOf(e)); break; +#if IPARAM + case IPVAR : putChr('?'); + unlexVar(textOf(e)); + break; + + case WITHEXP : OPEN(d>WHERE_PREC); + putStr("dlet {...} in "); + put(WHERE_PREC+1,fst(snd(e))); + CLOSE(d>WHERE_PREC); + break; +#endif + #if TREX case RECSEL : putChr('#'); unlexVar(extText(snd(e))); @@ -622,9 +634,12 @@ List qs; Int fr; { Int len = length(ps) + length(qs); Int c = len; - if (len!=1) { - putChr('('); - } +#if IPARAM + Bool useParens = len!=1 || isIP(fun(hd(ps))); +#else + Bool useParens = len!=1; +#endif + if (useParens) for (; nonNull(ps); ps=tl(ps)) { putPred(hd(ps),fr); if (--c > 0) { @@ -637,9 +652,8 @@ Int fr; { putStr(", "); } } - if (len!=1) { + if (useParens) putChr(')'); - } } static Void local putPred(pi,fr) /* Output predicate */ @@ -654,6 +668,15 @@ Int fr; { return; } #endif +#if IPARAM + if (whatIs(fun(pi)) == IPCELL) { + putChr('?'); + putPred(fun(pi),fr); + putStr(" :: "); + putType(arg(pi),NEVER,fr); + return; + } +#endif putPred(fun(pi),fr); putChr(' '); putType(arg(pi),ALWAYS,fr); @@ -662,6 +685,10 @@ Int fr; { putStr(textToStr(cclass(pi).text)); else if (isCon(pi)) putStr(textToStr(textOf(pi))); +#if IPARAM + else if (whatIs(pi) == IPCELL) + unlexVar(textOf(pi)); +#endif else putStr(""); } @@ -688,7 +715,7 @@ Int fr; { for (; isAp(ks); ks=tl(ks)) { putTyVar(fr++); if (isAp(tl(ks))) - putChr(','); + putChr(' '); } putStr(". "); putType(monotypeOf(t),NEVER,fr); @@ -747,12 +774,14 @@ Int fr; { CLOSE(prec>=ARROW_PREC); return; } +#if 0 else if (argCount==1) { putChr('('); putType(arg(t),ARROW_PREC,fr); putStr("->)"); return; } +#endif } else if (isTuple(typeHead)) { if (argCount==tupleOf(typeHead)) { @@ -770,7 +799,7 @@ Int fr; { putStr(punc); punc = ", "; putStr(textToStr(extText(typeHead))); - putStr("::"); + putStr(" :: "); putType(extField(t),NEVER,fr); t = extRow(t); typeHead = getHead(t); diff --git a/ghc/interpreter/parser.y b/ghc/interpreter/parser.y index 13fcec3..0d787cf 100644 --- a/ghc/interpreter/parser.y +++ b/ghc/interpreter/parser.y @@ -5,14 +5,15 @@ * Expect 6 shift/reduce conflicts when passing this grammar through yacc, * but don't worry; they should all be resolved in an appropriate manner. * - * Hugs 98 is Copyright (c) Mark P Jones, Alastair Reid and the Yale - * Haskell Group 1994-99, and is distributed as Open Source software - * under the Artistic License; see the file "Artistic" that is included - * in the distribution for details. + * 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: parser.y,v $ - * $Revision: 1.10 $ - * $Date: 1999/10/16 02:17:29 $ + * $Revision: 1.11 $ + * $Date: 1999/10/20 02:16:02 $ * ------------------------------------------------------------------------*/ %{ @@ -46,6 +47,9 @@ static Cell local checkTyLhs Args((Cell)); #if !TREX static Void local noTREX Args((String)); #endif +#if !IPARAM +static Void local noIP Args((String)); +#endif /* For the purposes of reasonably portable garbage collection, it is * necessary to simulate the YACC stack on the Hugs stack to keep @@ -78,11 +82,14 @@ static Void local noTREX Args((String)); %token THEN ELSE WHERE LET IN %token INFIXN INFIXL INFIXR FOREIGN TNEWTYPE %token DEFAULT DERIVING DO TCLASS TINSTANCE +/*#if IPARAM*/ +%token WITH DLET +/*#endif*/ %token REPEAT ALL NUMLIT CHARLIT STRINGLIT %token VAROP VARID CONOP CONID %token QVAROP QVARID QCONOP QCONID /*#if TREX*/ -%token RECSELID +%token RECSELID IPVARID /*#endif*/ %token COCO '=' UPTO '@' '\\' %token '|' '-' FROM ARROW '~' @@ -96,6 +103,7 @@ static Void local noTREX Args((String)); /*- Top level script/module structure -------------------------------------*/ start : EXPR exp wherePart {inputExpr = letrec($3,$2); sp-=2;} + | CONTEXT context {inputContext = $2; sp-=1;} | SCRIPT topModule {valDefns = $2; sp-=1;} | INTERFACE iface {sp-=1;} | error {syntaxError("input");} @@ -641,7 +649,7 @@ unsafe_flag: /* empty */ {$$ = gc0(NIL);} /*- Class declarations: ---------------------------------------------------*/ -topDecl : TCLASS crule wherePart {classDefn(intOf($1),$2,$3,NIL); sp-=3;} +topDecl : TCLASS crule fds wherePart {classDefn(intOf($1),$2,$4,$3); sp-=4;} | TINSTANCE irule wherePart {instDefn(intOf($1),$2,$3); sp-=3;} | DEFAULT '(' dtypes ')' {defaultDefn(intOf($1),$3); sp-=4;} | TCLASS error {syntaxError("class declaration");} @@ -661,9 +669,27 @@ dtypes1 : dtypes1 ',' type {$$ = gc3(cons($3,$1));} | type {$$ = gc1(cons($1,NIL));} ; -/*- Type expressions: -----------------------------------------------------*/ - -topType : context IMPLIES topType1 {$$ = gc3(qualify($1,$3));} +fds : /* empty */ {$$ = gc0(NIL);} + | '|' fds1 {h98DoesntSupport(row,"dependent parameters"); + $$ = gc2(rev($2));} + ; +fds1 : fds1 ',' fd {$$ = gc3(cons($3,$1));} + | fd {$$ = gc1(cons($1,NIL));} + | + ; +fd : varids0 ARROW varids0 {$$ = gc3(pair(rev($1),rev($3)));} + ; +varids0 : /* empty */ {$$ = gc0(NIL);} + | varids0 varid {$$ = gc2(cons($2,$1));} + ; + + /*- Type expressions: -----------------------------------------------------*/ + +topType : ALL varids '.' topType0 {$$ = gc4(ap(POLYTYPE, + pair(rev($2),$4)));} + | topType0 {$$ = $1;} + ; +topType0 : context IMPLIES topType1 {$$ = gc3(qualify($1,$3));} | topType1 {$$ = $1;} ; topType1 : bpolyType ARROW topType1 {$$ = gc3(fn($1,$3));} @@ -673,11 +699,12 @@ topType1 : bpolyType ARROW topType1 {$$ = gc3(fn($1,$3));} ; polyType : ALL varids '.' sigType {$$ = gc4(ap(POLYTYPE, pair(rev($2),$4)));} + | context IMPLIES type {$$ = gc3(qualify($1,$3));} | bpolyType {$$ = $1;} ; bpolyType : '(' polyType ')' {$$ = gc3($2);} ; -varids : varids ',' varid {$$ = gc3(cons($3,$1));} +varids : varids varid {$$ = gc2(cons($2,$1));} | varid {$$ = gc1(singleton($1));} ; sigType : context IMPLIES type {$$ = gc3(qualify($1,$3));} @@ -698,6 +725,13 @@ lacks : varid '\\' varid { noTREX("a type context"); #endif } + | IPVARID COCO type { +#if IPARAM + $$ = gc3(pair(mkIParam($1),$3)); +#else + noIP("a type context"); +#endif + } ; lacks1 : btypes2 ',' lacks {$$ = gc3(cons($3,$1));} | lacks1 ',' btype2 {$$ = gc3(cons($3,$1));} @@ -735,7 +769,6 @@ atype1 : varid {$$ = $1;} | '(' tupCommas ')' {$$ = gc3($2);} | '(' btypes2 ')' {$$ = gc3(buildTuple($2));} | '(' typeTuple ')' {$$ = gc3(buildTuple($2));} -/*#if TREX*/ | '(' tfields ')' { #if TREX $$ = gc3(revOnto($2,typeNoRow)); @@ -743,11 +776,17 @@ atype1 : varid {$$ = $1;} noTREX("a type"); #endif } - | '(' tfields '|' type ')' {$$ = gc5(revOnto($2,$4));} -/*#endif*/ + | '(' tfields '|' type ')' { +#if TREX + $$ = gc5(revOnto($2,$4)); +#else + noTREX("a type"); +#endif + } | '[' type ']' {$$ = gc3(ap(typeList,$2));} | '[' ']' {$$ = gc2(typeList);} - | '_' {$$ = gc1(inventVar());} + | '_' {h98DoesntSupport(row,"anonymous type variables"); + $$ = gc1(inventVar());} ; btypes2 : btypes2 ',' btype2 {$$ = gc3(cons($3,$1));} | btype2 ',' btype2 {$$ = gc3(cons($3,cons($1,NIL)));} @@ -761,7 +800,8 @@ typeTuple : type1 ',' type {$$ = gc3(cons($3,cons($1,NIL)));} tfields : tfields ',' tfield {$$ = gc3(cons($3,$1));} | tfield {$$ = gc1(singleton($1));} ; -tfield : varid COCO type {$$ = gc3(ap(mkExt(textOf($1)),$3));} +tfield : varid COCO type {h98DoesntSupport(row,"extensible records"); + $$ = gc3(ap(mkExt(textOf($1)),$3));} ; /*#endif*/ @@ -853,6 +893,7 @@ pat0_vI : pat10_vI {$$ = $1;} | infixPat {$$ = gc1(ap(INFIX,$1));} ; infixPat : '-' pat10 {$$ = gc2(ap(NEG,only($2)));} + | '-' error {syntaxError("pattern");} | var qconop pat10 {$$ = gc3(ap(ap($2,only($1)),$3));} | var qconop '-' pat10 {$$ = gc4(ap(NEG,ap2($2,only($1),$4)));} | NUMLIT qconop pat10 {$$ = gc3(ap(ap($2,only($1)),$3));} @@ -932,6 +973,13 @@ exp : exp_err {$$ = $1;} | error {syntaxError("expression");} ; exp_err : exp0a COCO sigType {$$ = gc3(ap(ESIGN,pair($1,$3)));} + | exp0a WITH dbinds { +#if IPARAM + $$ = gc3(ap(WITHEXP,pair($1,$3))); +#else + noIP("an expression"); +#endif + } | exp0 {$$ = $1;} ; exp0 : exp0a {$$ = $1;} @@ -966,6 +1014,13 @@ exp10b : '\\' pats ARROW exp {$$ = gc4(ap(LAMBDA, pair($3,$4))));} | LET decls IN exp {$$ = gc4(letrec($2,$4));} | IF exp THEN exp ELSE exp {$$ = gc6(ap(COND,triple($2,$4,$6)));} + | DLET dbinds IN exp { +#if IPARAM + $$ = gc4(ap(WITHEXP,pair($4,$2))); +#else + noIP("an expression"); +#endif + } ; pats : pats apat {$$ = gc2(cons($2,$1));} | apat {$$ = gc1(cons($1,NIL));} @@ -976,6 +1031,7 @@ appExp : appExp aexp {$$ = gc2(ap($1,$2));} aexp : qvar {$$ = $1;} | qvar '@' aexp {$$ = gc3(ap(ASPAT,pair($1,$3)));} | '~' aexp {$$ = gc2(ap(LAZYPAT,$2));} + | IPVARID {$$ = $1;} | '_' {$$ = gc1(WILDCARD);} | gcon {$$ = $1;} | qcon '{' fbinds '}' {$$ = gc4(ap(CONFLDS,pair($1,$3)));} @@ -1057,6 +1113,18 @@ fbind : var {$$ = $1;} | qvar '=' exp {$$ = gc3(pair($1,$3));} ; +dbinds : '{' dbs0 end {$$ = gc3($2);} + | '{' dbs1 end {$$ = gc3($2);} + ; +dbs0 : /* empty */ {$$ = gc0(NIL);} + | dbs0 ';' {$$ = gc2($1);} + | dbs1 ';' {$$ = gc2($1);} + ; +dbs1 : dbs0 dbind {$$ = gc2(cons($2,$1));} + ; +dbind : IPVARID '=' exp {$$ = gc3(pair($1,$3));} + ; + /*- List Expressions: -------------------------------------------------------*/ list : exp {$$ = gc1(ap(FINLIST,cons($1,NIL)));} @@ -1245,7 +1313,15 @@ static String local unexpected() { /* find name for unexpected token */ case DEFAULT : keyword("default"); case IMPORT : keyword("import"); case TMODULE : keyword("module"); + /* AJG: Hugs98/Classic use the keyword forall + rather than __forall. + Agree on one or the other + */ case ALL : keyword("__forall"); +#if IPARAM + case DLET : keyword("dlet"); + case WITH : keyword("with"); +#endif #undef keyword case ARROW : return "`->'"; @@ -1257,12 +1333,12 @@ static String local unexpected() { /* find name for unexpected token */ case '@' : return "`@'"; case '(' : return "`('"; case ')' : return "`)'"; - case '{' : return "`{'"; - case '}' : return "`}'"; + case '{' : return "`{', possibly due to bad layout"; + case '}' : return "`}', possibly due to bad layout"; case '_' : return "`_'"; case '|' : return "`|'"; case '.' : return "`.'"; - case ';' : return "`;'"; + case ';' : return "`;', possibly due to bad layout"; case UPTO : return "`..'"; case '[' : return "`['"; case ']' : return "`]'"; @@ -1275,6 +1351,11 @@ static String local unexpected() { /* find name for unexpected token */ textToStr(extText(snd(yylval)))); return buffer; #endif +#if IPARAM + case IPVARID : sprintf(buffer,"implicit parameter \"?%s\"", + textToStr(textOf(yylval))); + return buffer; +#endif case VAROP : case VARID : case CONOP : @@ -1339,7 +1420,11 @@ Cell c; { /* constraint */ if (isExt(cn) && argCount==1) return c; #endif - if (!isQCon(cn) || argCount==0) +#if IPARAM + if (isIP(cn)) + return c; +#endif + if (!isQCon(cn) /*|| argCount==0*/) syntaxError("class expression"); return c; } @@ -1355,21 +1440,20 @@ List dqs; { /* to an (expr,quals) pair */ return dqs; } -static Cell local checkTyLhs(c) /* check that lhs is of the form */ -Cell c; { /* T a1 ... a */ +static Cell local checkTyLhs(c) /* check that lhs is of the form */ +Cell c; { /* T a1 ... a */ Cell tlhs = c; - while (isAp(tlhs) && whatIs(arg(tlhs))==VARIDCELL) - tlhs = fun(tlhs); - switch (whatIs(tlhs)) { - case CONIDCELL : return c; - - default : - ERRMSG(row) "Illegal left hand side in datatype definition" - EEND; + while (isAp(tlhs) && whatIs(arg(tlhs))==VARIDCELL) { + tlhs = fun(tlhs); + } + if (whatIs(tlhs)!=CONIDCELL) { + ERRMSG(row) "Illegal left hand side in datatype definition" + EEND; } - return 0; /* NOTREACHED */ + return c; } + #if !TREX static Void local noTREX(where) String where; { @@ -1378,5 +1462,13 @@ String where; { EEND; } #endif +#if !IPARAM +static Void local noIP(where) +String where; { + ERRMSG(row) "Attempt to use Implicit Parameters while parsing %s.\n", where ETHEN + ERRTEXT "(Implicit Parameters are disabled in this build of Hugs)" + EEND; +} +#endif /*-------------------------------------------------------------------------*/ diff --git a/ghc/interpreter/preds.c b/ghc/interpreter/preds.c index 612dfa3..1c95a58 100644 --- a/ghc/interpreter/preds.c +++ b/ghc/interpreter/preds.c @@ -9,8 +9,8 @@ * included in the distribution. * * $RCSfile: preds.c,v $ - * $Revision: 1.7 $ - * $Date: 1999/10/19 15:11:31 $ + * $Revision: 1.8 $ + * $Date: 1999/10/20 02:16:04 $ * ------------------------------------------------------------------------*/ /* -------------------------------------------------------------------------- @@ -18,6 +18,11 @@ * ------------------------------------------------------------------------*/ static Cell local assumeEvid Args((Cell,Int)); +#if IPARAM +static Cell local findIPEvid Args((Text)); +static Void local removeIPEvid Args((Text)); +static Void local matchupIPs Args((List,List)); +#endif static List local makePredAss Args((List,Int)); static List local copyPreds Args((List)); static Void local qualify Args((List,Cell)); @@ -30,6 +35,10 @@ static Cell local scFind Args((Cell,Cell,Int,Cell,Int,Int)); static Cell local scEntail Args((List,Cell,Int,Int)); static Cell local entail Args((List,Cell,Int,Int)); static Cell local inEntail Args((List,Cell,Int,Int)); +#if MULTI_INST +static Cell local inEntails Args((List,Cell,Int,Int)); +static Bool local instCompare Args((Inst, Inst)); +#endif #if TREX static Cell local lacksNorm Args((Type,Int,Cell)); #endif @@ -45,6 +54,7 @@ static Void local normPreds Args((Int)); static Bool local resolveDefs Args((List)); static Bool local resolveVar Args((Int)); static Class local classConstraining Args((Int,Cell,Int)); +static Bool local instComp_ Args((Inst,Inst)); /* -------------------------------------------------------------------------- * Predicate assignments: @@ -67,6 +77,33 @@ Int o; { return nd; } +#if IPARAM +static Cell local findIPEvid(t) +Text t; { + List ps = preds; + for (; nonNull(ps); ps=tl(ps)) { + Cell p = hd(ps); + if (ipMatch(fst3(p), t)) + return p; + } + return NIL; +} + +static Void local removeIPEvid(t) +Text t; { + List ps = preds; + List *prev = &preds; + for (; nonNull(ps); ps = tl(ps)) + if (ipMatch(fst3(hd(ps)), t)) { + *prev = tl(ps); + return; + } else { + prev = &tl(ps); + } +} +#endif + + static List local makePredAss(qs,o) /* Make list of predicate assumps. */ List qs; /* from qs (offset o), w/ new dict */ Int o; { /* vars for each predicate */ @@ -174,7 +211,7 @@ Cell ev; { * * ------------------------------------------------------------------------*/ -Int cutoff = 60; /* Used to limit depth of recursion*/ +Int cutoff = 64; /* Used to limit depth of recursion*/ static Void local cutoffExceeded(pi,o,pi1,o1,ps) Cell pi, pi1; /* Display error msg when cutoff */ @@ -208,9 +245,13 @@ Int d; { Class h1 = getHead(pi1); Class h = getHead(pi); - if (h==h1 && samePred(pi1,o1,pi,o)) + /* the h==h1 test is just an optimization, and I'm not + sure it will work with IPs, so I'm being conservative + and commenting it out */ + if (/* h==h1 && */ samePred(pi1,o1,pi,o)) return e; + /* the cclass.level test is also an optimization */ if (isClass(h1) && (!isClass(h) || cclass(h).level= cutoff) + cutoffExceeded(pi,o,NIL,0,ps); + +#if EXPLAIN_INSTANCE_RESOLUTION + if (showInstRes) { + pi_ = copyPred(pi, o); + for (i = 0; i < d; i++) + fputc(' ', stdout); + fputs("inEntails: ", stdout); + printPred(stdout, pi_); + fputc('\n', stdout); + } +#endif + + ins = findInstsFor(pi,o); + for (; nonNull(ins); ins=tl(ins)) { + in = snd(hd(ins)); + if (nonNull(in)) { + Int beta = fst(hd(ins)); + Cell e = inst(in).builder; + Cell es = inst(in).specifics; + Cell es_ = es; + +#if EXPLAIN_INSTANCE_RESOLUTION + if (showInstRes) { + for (i = 0; i < d; i++) + fputc(' ', stdout); + fputs("try ", stdout); + printContext(stdout, es); + fputs(" => ", stdout); + printPred(stdout, inst(in).head); + fputc('\n', stdout); + } +#endif + + for (; nonNull(es); es=tl(es)) { + Cell ev = entail(ps,hd(es),beta,d); + if (nonNull(ev)) + e = ap(e,ev); + else { + e = NIL; + break; + } + } +#if EXPLAIN_INSTANCE_RESOLUTION + if (showInstRes) + for (i = 0; i < d; i++) + fputc(' ', stdout); +#endif + if (nonNull(e)) { +#if EXPLAIN_INSTANCE_RESOLUTION + if (showInstRes) + fprintf(stdout, "Sat\n"); +#endif + if (k > 0) { + if (instCompare (in_, in)) { + ERRMSG(0) "Multiple satisfiable instances for " + ETHEN + ERRPRED(copyPred(pi, o)); + ERRTEXT "\nin_ " ETHEN ERRPRED(inst(in_).head); + ERRTEXT "\nin " ETHEN ERRPRED(inst(in).head); + ERRTEXT "\n" + EEND; + } + } + if (k++ == 0) { + e_ = e; + in_ = in; + } + continue; + } else { +#if EXPLAIN_INSTANCE_RESOLUTION + if (showInstRes) + fprintf(stdout, "not Sat\n"); +#endif + continue; + } + } +#if EXPLAIN_INSTANCE_RESOLUTION + if (showInstRes) { + for (i = 0; i < d; i++) + fputc(' ', stdout); + fprintf(stdout, "not Sat.\n"); + } +#endif + } + if (k > 0) + return e_; +#if EXPLAIN_INSTANCE_RESOLUTION + if (showInstRes) { + for (i = 0; i < d; i++) + fputc(' ', stdout); + fprintf(stdout, "all not Sat.\n"); + } +#endif + return NIL; +#if TREX + } +#endif +} + +static Bool local instComp_(ia,ib) /* See if ia is an instance of ib */ +Inst ia, ib;{ + Int alpha = newKindedVars(inst(ia).kinds); + Int beta = newKindedVars(inst(ib).kinds); + return matchPred(inst(ia).head,alpha,inst(ib).head,beta); +} + +static Bool local instCompare (ia, ib) +Inst ia, ib; +{ + return instComp_(ia, ib) && instComp_(ib, ia); +} +#endif + Cell provePred(ks,ps,pi) /* Find evidence for predicate pi */ Kinds ks; /* assuming ps. If ps is null, */ List ps; /* then we get to decide whether */ @@ -499,9 +731,11 @@ List sps; { /* preds that contain no generics. */ for (preds=scSimplify(preds); nonNull(preds); ) { Cell pi = hd(preds); Cell nx = tl(preds); - if (anyGenerics(fst3(pi),intOf(snd3(pi)))) { /* Retain predicate*/ - tl(preds) = qs; - qs = preds; + if (anyGenerics(fst3(pi),intOf(snd3(pi))) + || !isAp(fst3(pi)) + || isIP(fun(fst3(pi)))) { + tl(preds) = qs; /* Retain predicate*/ + qs = preds; } else { /* Defer predicate */ tl(preds) = sps; @@ -524,10 +758,10 @@ List sps; { /* context ps. sps = savePreds. */ Cell ev = entail(ps,pi,o,0); preds = tl(preds); - if (nonNull(ev)) /* Discharge if ps ||- (pi,o) */ + if (nonNull(ev)) { /* Discharge if ps ||- (pi,o) */ overEvid(thd3(hd(p)),ev); - else if (!anyGenerics(pi,o)) { /* Defer if no generics */ - tl(p) = sps; + } else if (!isAp(pi) || isIP(fun(pi)) || !anyGenerics(pi,o)) { + tl(p) = sps; /* Defer if no generics */ sps = p; } else { /* Try to split generics and fixed */ @@ -554,7 +788,15 @@ static Void local reducePreds() { /* Context reduce predicates: uggh!*/ Cell p = preds; Cell pi = fst3(hd(p)); Int o = intOf(snd3(hd(p))); - Inst in = findInstFor(pi,o); + Inst in = NIL; +#if MULTI_INST + List ins = NIL; + if (multiInstRes) { + ins = findInstsFor(pi,o); + in = nonNull(ins) && isNull(tl(ins)) ? hd(ins) : NIL; + } else +#endif + in = findInstFor(pi,o); preds = tl(preds); if (nonNull(in)) { List qs = inst(in).specifics; diff --git a/ghc/interpreter/prelude.h b/ghc/interpreter/prelude.h index b83f284..ac563b2 100644 --- a/ghc/interpreter/prelude.h +++ b/ghc/interpreter/prelude.h @@ -10,10 +10,13 @@ * included in the distribution. * * $RCSfile: prelude.h,v $ - * $Revision: 1.5 $ - * $Date: 1999/10/15 21:40:54 $ + * $Revision: 1.6 $ + * $Date: 1999/10/20 02:16:04 $ * ------------------------------------------------------------------------*/ +#define NON_POSIX_SOURCE +/* AJG: machdep.h needs this, for S_IREAD and S_IFREG in cygwin? */ + #include "config.h" #include "options.h" #include @@ -337,3 +340,14 @@ extern Void hugsPutc Args((int, FILE*)); #endif /*-------------------------------------------------------------------------*/ +/* AJG: This needs moved to a more appropreate location + * + * TREX to include support for Typed Rows and EXtensions. + * IPARAM to include support for Implicit Parameters. + * MULTI_INST to include support for Multi-Instance Resolution. + */ +#define TREX 0 +#define IPARAM 0 +#define MULTI_INST 0 + +/*-------------------------------------------------------------------------*/ diff --git a/ghc/interpreter/storage.c b/ghc/interpreter/storage.c index ce11734..e08b3e7 100644 --- a/ghc/interpreter/storage.c +++ b/ghc/interpreter/storage.c @@ -9,8 +9,8 @@ * included in the distribution. * * $RCSfile: storage.c,v $ - * $Revision: 1.12 $ - * $Date: 1999/10/19 23:51:58 $ + * $Revision: 1.13 $ + * $Date: 1999/10/20 02:16:05 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -349,7 +349,7 @@ Cell id; { } default : internal("findQualTycon2"); } - return 0; /* NOTREACHED */ + return NIL; /* NOTREACHED */ } Tycon addPrimTycon(t,kind,ar,what,defn) /* add new primitive type constr */ @@ -713,6 +713,7 @@ Text t; { cclass(classHw).arity = 0; cclass(classHw).kinds = NIL; cclass(classHw).head = NIL; + cclass(classHw).fds = NIL; cclass(classHw).dcon = NIL; cclass(classHw).supers = NIL; cclass(classHw).dsels = NIL; @@ -957,7 +958,7 @@ Cell c; { case CONIDCELL : return findModule(textOf(c)); default : internal("findModid"); } - assert(0); return 0; /* NOTREACHED */ + return NIL;/*NOTUSED*/ } static local Module findQualifier(t) /* locate Module in import list */ @@ -1427,11 +1428,14 @@ Cell c; { /* cells reachable from given root */ } } + /* STACK_CHECK: Avoid stack overflows during recursive marking. */ if (isGenPair(fst(c))) { + STACK_CHECK fst(c) = markCell(fst(c)); markSnd(c); } else if (isNull(fst(c)) || fst(c)>=BCSTAG) { + STACK_CHECK markSnd(c); } @@ -1757,6 +1761,14 @@ Int depth; { case CONOPCELL: Printf("{id %s}",textToStr(textOf(c))); break; +#if IPARAM + case IPCELL : + Printf("{ip %s}",textToStr(textOf(c))); + break; + case IPVAR : + Printf("?%s",textToStr(textOf(c))); + break; +#endif case QUALIDENT: Printf("{qid %s.%s}",textToStr(qmodOf(c)),textToStr(qtextOf(c))); break; @@ -2428,6 +2440,7 @@ Int what; { for (i=CLASSMIN; i