* 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 $
* ------------------------------------------------------------------------*/
/* 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
/* 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
* 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"
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));
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);
}
* 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 $
* ------------------------------------------------------------------------*/
/* --------------------------------------------------------------------------
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 */
# 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 <signal.h>
+# 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 */
/*---------------------------------------------------------------------------
* 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"
#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 */
* 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 <setjmp.h>
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));
} else if (isSfun(nm)) {
Printf(" -- selector function");
}
- if (name(nm).primDef) {
- Printf(" -- primitive");
- }
Printf("\n");
}
}
Printf("Unknown module %s\n",t);
}
}
-#endif
}
static Void local browse() { /* browse modules */
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 = " | ";
pre = ", ";
}
}
-#endif
+
if (nonNull(cclass(cl).members)) {
List ms = cclass(cl).members;
Printf(" where");
* 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
#ifdef HAVE_UNIX_H
#include <unix.h>
#endif
+#if SYMANTEC_C
+int allow_break_count = 0;
+#endif
/* --------------------------------------------------------------------------
* Prototypes for registry reading
#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));
}
#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","");
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 */
}
}
}
#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);
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 */
* 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"
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)));
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) {
putStr(", ");
}
}
- if (len!=1) {
+ if (useParens)
putChr(')');
- }
}
static Void local putPred(pi,fr) /* Output predicate */
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);
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("<unknownPredicate>");
}
for (; isAp(ks); ks=tl(ks)) {
putTyVar(fr++);
if (isAp(tl(ks)))
- putChr(',');
+ putChr(' ');
}
putStr(". ");
putType(monotypeOf(t),NEVER,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)) {
putStr(punc);
punc = ", ";
putStr(textToStr(extText(typeHead)));
- putStr("::");
+ putStr(" :: ");
putType(extField(t),NEVER,fr);
t = extRow(t);
typeHead = getHead(t);
* 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 $
* ------------------------------------------------------------------------*/
%{
#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
%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 '~'
/*- 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");}
/*- 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");}
| 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));}
;
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));}
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));}
| '(' tupCommas ')' {$$ = gc3($2);}
| '(' btypes2 ')' {$$ = gc3(buildTuple($2));}
| '(' typeTuple ')' {$$ = gc3(buildTuple($2));}
-/*#if TREX*/
| '(' tfields ')' {
#if TREX
$$ = gc3(revOnto($2,typeNoRow));
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)));}
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*/
| 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));}
| 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;}
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));}
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)));}
| 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)));}
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 "`->'";
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 "`]'";
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 :
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;
}
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; {
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
/*-------------------------------------------------------------------------*/
* 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 $
* ------------------------------------------------------------------------*/
/* --------------------------------------------------------------------------
* ------------------------------------------------------------------------*/
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));
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
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:
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 */
*
* ------------------------------------------------------------------------*/
-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 */
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<cclass(h1).level)) {
Int beta = newKindedVars(cclass(h1).kinds);
List scs = cclass(h1).supers;
return NIL;
}
+#if IPARAM
+static Cell local ipEntail(ps,ip,o) /* Find evidence for (ip,o) from ps*/
+List ps;
+Cell ip;
+Int o; {
+ Class h = getHead(ip);
+ int i;
+ for (; nonNull(ps); ps=tl(ps)) {
+ Cell pr1 = hd(ps);
+ Cell pi1 = fst3(pr1);
+ Int o1 = intOf(snd3(pr1));
+ Class h1 = getHead(pi1);
+ if (isIP(h1)) {
+ if (textOf(h1) == textOf(h)) {
+ if (unify(arg(pi1),o1,arg(ip),o)) {
+ return thd3(pr1);
+ } else {
+ ERRMSG(0) "Mismatching uses of implicit parameter\n" ETHEN
+ ERRPRED(copyPred(pi1,o1));
+ ERRTEXT "\n" ETHEN
+ ERRPRED(copyPred(ip,o));
+ ERRTEXT "\n"
+ EEND;
+ }
+ }
+ }
+ }
+ return NIL;
+}
+#endif
+
/* --------------------------------------------------------------------------
* Now we reach the main entailment routine:
*
Int o;
Int d; {
Cell ev = scEntail(ps,pi,o,d);
- return nonNull(ev) ? ev : inEntail(ps,pi,o,d);
+ return nonNull(ev) ? ev :
+#if MULTI_INST
+ multiInstRes ? inEntails(ps,pi,o,d) :
+ inEntail(ps,pi,o,d);
+#else
+ inEntail(ps,pi,o,d);
+#endif
}
static Cell local inEntail(ps,pi,o,d) /* Calc evidence for (pi,o) from ps*/
#endif
}
+#if MULTI_INST
+static Cell local inEntails(ps,pi,o,d) /* Calc evidence for (pi,o) from ps*/
+List ps; /* using a top-level instance */
+Cell pi; /* entailment */
+Int o;
+Int d; {
+ int i;
+ int k = 0;
+ Cell ins; /* Class predicates */
+ Inst in, in_;
+ Cell pi_;
+ Cell e_;
+
+#if TREX
+ if (isAp(pi) && isExt(fun(pi))) { /* Lacks predicates */
+ Cell e = fun(pi);
+ Cell l;
+ l = lacksNorm(arg(pi),o,e);
+ if (isNull(l) || isInt(l))
+ return l;
+ else {
+ List qs = ps;
+ for (; nonNull(qs); qs=tl(qs)) {
+ Cell qi = fst3(hd(qs));
+ if (isAp(qi) && fun(qi)==e) {
+ Cell lq = lacksNorm(arg(qi),intOf(snd3(hd(qs))),e);
+ if (isAp(lq) && intOf(fst(l))==intOf(fst(lq))) {
+ Int f = intOf(snd(l)) - intOf(snd(lq));
+ return (f==0) ? thd3(hd(qs)) : ap2(nameAddEv,
+ mkInt(f),
+ thd3(hd(qs)));
+ }
+ }
+ }
+ return NIL;
+ }
+ }
+ else {
+#endif
+ if (d++ >= 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 */
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;
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 */
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;
* 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 <stdio.h>
#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
+
+/*-------------------------------------------------------------------------*/
* 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"
}
default : internal("findQualTycon2");
}
- return 0; /* NOTREACHED */
+ return NIL; /* NOTREACHED */
}
Tycon addPrimTycon(t,kind,ar,what,defn) /* add new primitive type constr */
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;
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 */
}
}
+ /* 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);
}
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;
for (i=CLASSMIN; i<classHw; ++i) {
mark(cclass(i).head);
mark(cclass(i).kinds);
+ mark(cclass(i).fds);
mark(cclass(i).dsels);
mark(cclass(i).supers);
mark(cclass(i).members);
projects / ghc-hetmet.git / commitdiff