+++ /dev/null
-/* --------------------------------------------------------------------------
- * 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.
- *
- * Relies, implicitly but for this comment, on assumption that NUM_CHARS=256.
- * ------------------------------------------------------------------------*/
-
-#include "prelude.h"
-#include "storage.h"
-#include "connect.h"
-#include "charset.h"
-
-unsigned char ctable[NUM_CHARS];
-
-Void initCharTab() { /* Initialize char decode table */
-#define setRange(x,f,t) {Int i=f; while (i<=t) ctable[i++] |=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) */
-
- 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);
- setRange(SYMBOL, 247,247);
- setChars(SYMBOL, ":!#$%&*+./<=>?@\\^|-~");
-
- setChars(IDAFTER, "'_"); /* Characters in identifier */
- setCopy (IDAFTER, (DIGIT|SMALL|LARGE));
-
- setRange(SPACE, ' ',' '); /* ASCII space character */
- setRange(SPACE, 160,160); /* ISO non breaking space */
- setRange(SPACE, 9,13); /* special whitespace: \t\n\v\f\r */
-
- setChars(PRINT, "(),;[]_`{}"); /* Special characters */
- setChars(PRINT, " '\""); /* Space and quotes */
- setCopy (PRINT, (DIGIT|SMALL|LARGE|SYMBOL));
-
-#undef setRange
-#undef setChars
-#undef setCopy
-}
-
+++ /dev/null
-/* --------------------------------------------------------------------------
- * 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.
- *
- * Relies, implicitly but for this comment, on assumption that NUM_CHARS=256.
- * ------------------------------------------------------------------------*/
-
-extern unsigned char ctable[NUM_CHARS];
-
-#define isIn(c,x) (ctable[(Int)(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 SPACE 0x20
-#define PRINT 0x40
-
-extern Void local initCharTab Args(( Void ));
-
+++ /dev/null
-extern Void cgBinds Args(( StgRhs rhs ));
-extern void* closureOfVar Args(( StgVar v ));
-extern char* lookupHugsName Args(( void* closure ));
+++ /dev/null
-extern Void compileDefns Args((Void));
-extern Void evalExp Args((Void));
-extern Void newGlobalFunction Args((Name,Int,List,Int,Cell));
+++ /dev/null
-/* -*- mode: hugs-c; -*- */
-/* --------------------------------------------------------------------------
- * Send message to each component of system:
- *
- * 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
- *
- * $RCSfile: connect.c,v $
- * $Revision: 1.2 $
- * $Date: 1998/12/02 13:22:02 $
- * ------------------------------------------------------------------------*/
-
-#include "prelude.h"
-#include "storage.h"
-#include "connect.h"
-
-Void everybody(what) /* send command `what' to each component of*/
-Int what; { /* system to respond as appropriate ... */
- machdep(what); /* The order of calling each component is */
- storage(what); /* important for the INSTALL command */
- substitution(what);
- input(what);
- linkControl(what);
- staticAnalysis(what);
- deriveControl(what);
- typeChecker(what);
- desugarControl(what);
- translateControl(what);
- compiler(what);
- codegen(what);
-}
-
-/*-------------------------------------------------------------------------*/
+++ /dev/null
-/* -*- mode: hugs-c; -*- */
-
-#if DERIVE_SHOW | DERIVE_READ
-extern List cfunSfuns; /* List of (Cfun,[SelectorVar]) */
-#endif
-
-extern List deriveEq Args((Tycon));
-extern List deriveOrd Args((Tycon));
-extern List deriveIx Args((Tycon));
-extern List deriveEnum Args((Tycon));
-extern List deriveShow Args((Tycon));
-extern List deriveRead Args((Cell));
-extern List deriveBounded Args((Tycon));
+++ /dev/null
-/* -*- mode: hugs-c; -*- */
-/* --------------------------------------------------------------------------
- * Desugarer
- *
- * 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
- *
- * $RCSfile: desugar.c,v $
- * $Revision: 1.2 $
- * $Date: 1998/12/02 13:22:05 $
- * ------------------------------------------------------------------------*/
-
-#include "prelude.h"
-#include "storage.h"
-#include "connect.h"
-#include "errors.h"
-#include "link.h"
-
-#include "desugar.h"
-#include "pat.h"
-
-/* --------------------------------------------------------------------------
- * Local function prototypes:
- * ------------------------------------------------------------------------*/
-
-static Void local transPair Args((Pair));
-static Void local transTriple Args((Triple));
-static Void local transCase Args((Cell));
-static Cell local transRhs Args((Cell));
-static Cell local expandLetrec Args((Cell));
-static Cell local transComp Args((Cell,List,Cell));
-static Cell local transDo Args((Cell,Cell,Cell,List));
-static Cell local transConFlds Args((Cell,List));
-static Cell local transUpdFlds Args((Cell,List,List));
-
-/* --------------------------------------------------------------------------
- * Translation: Convert input expressions into a less complex language
- * of terms using only LETREC, AP, constants and vars.
- * Also remove pattern definitions on lhs of eqns.
- * ------------------------------------------------------------------------*/
-
-Cell translate(e) /* Translate expression: */
-Cell e; {
- switch (whatIs(e)) {
- case LETREC : snd(snd(e)) = translate(snd(snd(e)));
- return expandLetrec(e);
-
- case COND : transTriple(snd(e));
- return e;
-
- case AP : fst(e) = translate(fst(e));
-
- if (fst(e)==nameId || fst(e)==nameInd)
- return translate(snd(e));
-#if USE_NEWTYPE_FOR_DICTS
- if (isName(fst(e)) &&
- isMfun(fst(e)) &&
- mfunOf(fst(e))==0)
- return translate(snd(e));
-#endif
- snd(e) = translate(snd(e));
- return e;
-
- case NAME : if (e==nameOtherwise)
- return nameTrue;
- if (isCfun(e)) {
- if (isName(name(e).defn))
- return name(e).defn;
- if (isPair(name(e).defn))
- return snd(name(e).defn);
- }
- return e;
-
-#if TREX
- case RECSEL : return nameRecSel;
-
- case EXT :
-#endif
- case TUPLE :
- case VAROPCELL :
- case VARIDCELL :
- case DICTVAR :
- case INTCELL :
- case BIGCELL :
- case FLOATCELL :
- case STRCELL :
- case CHARCELL : return e;
-
- case FINLIST : mapOver(translate,snd(e));
- return mkConsList(snd(e));
-
- case DOCOMP : { Cell m = translate(fst(fst(snd(e))));
- Cell m0 = snd(fst(snd(e)));
- Cell r = translate(fst(snd(snd(e))));
- if (nonNull(m0))
- m0 = translate(m0);
- return transDo(m,m0,r,snd(snd(snd(e))));
- }
-
- case COMP : return transComp(translate(fst(snd(e))),
- snd(snd(e)),
- nameNil);
-
- case CONFLDS : return transConFlds(fst(snd(e)),snd(snd(e)));
-
- case UPDFLDS : return transUpdFlds(fst3(snd(e)),
- snd3(snd(e)),
- thd3(snd(e)));
-
- case CASE : { Cell nv = inventVar();
- mapProc(transCase,snd(snd(e)));
- return ap(LETREC,
- pair(singleton(pair(nv,snd(snd(e)))),
- ap(nv,translate(fst(snd(e))))));
- }
-
- case LAMBDA : { Cell nv = inventVar();
- transAlt(snd(e));
- return ap(LETREC,
- pair(singleton(pair(
- nv,
- singleton(snd(e)))),
- nv));
- }
-
- default : internal("translate");
- }
- return e;
-}
-
-static Void local transPair(pr) /* Translate each component in a */
-Pair pr; { /* pair of expressions. */
- fst(pr) = translate(fst(pr));
- snd(pr) = translate(snd(pr));
-}
-
-static Void local transTriple(tr) /* Translate each component in a */
-Triple tr; { /* triple of expressions. */
- fst3(tr) = translate(fst3(tr));
- snd3(tr) = translate(snd3(tr));
- thd3(tr) = translate(thd3(tr));
-}
-
-Void transAlt(e) /* Translate alt: */
-Cell e; { /* ([Pat], Rhs) ==> ([Pat], Rhs') */
- snd(e) = transRhs(snd(e));
-}
-
-static Void local transCase(c) /* Translate case: */
-Cell c; { /* (Pat, Rhs) ==> ([Pat], Rhs') */
- fst(c) = singleton(fst(c));
- snd(c) = transRhs(snd(c));
-}
-
-List 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 (isVar(fst(hd(bs)))) {
- mapProc(transAlt,snd(hd(bs)));
- newBinds = cons(hd(bs),newBinds);
- }
- else
- newBinds = remPat(fst(snd(hd(bs))),
- snd(snd(hd(bs)))=transRhs(snd(snd(hd(bs)))),
- newBinds);
- }
- return newBinds;
-}
-
-static Cell local transRhs(rhs) /* Translate rhs: removing line nos */
-Cell rhs; {
- switch (whatIs(rhs)) {
- case LETREC : snd(snd(rhs)) = transRhs(snd(snd(rhs)));
- return expandLetrec(rhs);
-
- case GUARDED : mapOver(snd,snd(rhs)); /* discard line number */
- mapProc(transPair,snd(rhs));
- return rhs;
-
- default : return translate(snd(rhs)); /* discard line number */
- }
-}
-
-Cell mkConsList(es) /* Construct expression for list es */
-List es; { /* using nameNil and nameCons */
- if (isNull(es))
- return nameNil;
- else
- return ap2(nameCons,hd(es),mkConsList(tl(es)));
-}
-
-static Cell local expandLetrec(root) /* translate LETREC with list of */
-Cell root; { /* groups of bindings (from depend. */
- Cell e = snd(snd(root)); /* analysis) to use nested LETRECs */
- List bss = fst(snd(root));
- Cell temp;
-
- if (isNull(bss)) /* should never happen, but just in */
- return e; /* case: LETREC [] IN e ==> e */
-
- mapOver(transBinds,bss); /* translate each group of bindings */
-
- for (temp=root; nonNull(tl(bss)); bss=tl(bss)) {
- fst(snd(temp)) = hd(bss);
- snd(snd(temp)) = ap(LETREC,pair(NIL,e));
- temp = snd(snd(temp));
- }
- fst(snd(temp)) = hd(bss);
-
- return root;
-}
-
-/* --------------------------------------------------------------------------
- * Translation of list comprehensions is based on the description in
- * `The Implementation of Functional Programming Languages':
- *
- * [ e | qs ] ++ l => transComp e qs l
- * transComp e [] l => e : l
- * transComp e ((p<-xs):qs) l => LETREC _h [] = l
- * _h (p:_xs) = transComp e qs (_h _xs)
- * _h (_:_xs) = _h _xs --if p !failFree
- * IN _h xs
- * transComp e (b:qs) l => if b then transComp e qs l else l
- * transComp e (decls:qs) l => LETREC decls IN transComp e qs l
- * ------------------------------------------------------------------------*/
-
-static Cell local transComp(e,qs,l) /* Translate [e | qs] ++ l */
-Cell e;
-List qs;
-Cell l; {
- if (nonNull(qs)) {
- Cell q = hd(qs);
- Cell qs1 = tl(qs);
-
- switch (fst(q)) {
- case FROMQUAL : { Cell ld = NIL;
- Cell hVar = inventVar();
- Cell xsVar = inventVar();
-
- if (!failFree(fst(snd(q))))
- ld = cons(pair(singleton(
- ap2(nameCons,
- WILDCARD,
- xsVar)),
- ap(hVar,xsVar)),
- ld);
-
- ld = cons(pair(singleton(
- ap2(nameCons,
- fst(snd(q)),
- xsVar)),
- transComp(e,
- qs1,
- ap(hVar,xsVar))),
- ld);
- ld = cons(pair(singleton(nameNil),
- l),
- ld);
-
- return ap(LETREC,
- pair(singleton(pair(hVar,
- ld)),
- ap(hVar,
- translate(snd(snd(q))))));
- }
-
- case QWHERE : return
- expandLetrec(ap(LETREC,
- pair(snd(q),
- transComp(e,qs1,l))));
-
- case BOOLQUAL : return ap(COND,
- triple(translate(snd(q)),
- transComp(e,qs1,l),
- l));
- }
- }
-
- return ap2(nameCons,e,l);
-}
-
-/* --------------------------------------------------------------------------
- * Translation of monad comprehensions written using do-notation:
- *
- * do { e } => e
- * do { p <- exp; qs } => LETREC _h p = do { qs }
- * _h _ = zero{m0} -- if monad with 0
- * IN exp >>={m} _h
- * do { LET decls; qs } => LETREC decls IN do { qs }
- * do { IF guard; qs } => if guard then do { qs } else zero{m0}
- * do { e; qs } => LETREC _h _ = [ e | qs ] in bind m exp _h
- *
- * where m :: Monad f, m0 :: Monad0 f
- * ------------------------------------------------------------------------*/
-
-static Cell local transDo(m,m0,e,qs) /* Translate do { qs ; e } */
-Cell m;
-Cell m0;
-Cell e;
-List qs; {
- if (nonNull(qs)) {
- Cell q = hd(qs);
- Cell qs1 = tl(qs);
-
- switch (fst(q)) {
- case FROMQUAL : { Cell ld = NIL;
- Cell hVar = inventVar();
-
- if (!failFree(fst(snd(q))) && nonNull(m0))
- ld = cons(pair(singleton(WILDCARD),
- ap(nameZero,m0)),ld);
-
- ld = cons(pair(singleton(fst(snd(q))),
- transDo(m,m0,e,qs1)),
- ld);
-
- return ap(LETREC,
- pair(singleton(pair(hVar,ld)),
- ap3(nameBind,
- m,
- translate(snd(snd(q))),
- hVar)));
- }
-
- case DOQUAL : { Cell hVar = inventVar();
- Cell ld = cons(pair(singleton(WILDCARD),
- transDo(m,m0,e,qs1)),
- NIL);
- return ap(LETREC,
- pair(singleton(pair(hVar,ld)),
- ap3(nameBind,
- m,
- translate(snd(q)),
- hVar)));
- }
-
- case QWHERE : return
- expandLetrec(ap(LETREC,
- pair(snd(q),
- transDo(m,m0,e,qs1))));
-
- case BOOLQUAL : return ap(COND,
- triple(translate(snd(q)),
- transDo(m,m0,e,qs1),
- ap(nameZero,m0)));
- }
- }
- return e;
-}
-
-/* --------------------------------------------------------------------------
- * Translation of named field construction and update:
- *
- * Construction is implemented using the following transformation:
- *
- * C{x1=e1, ..., xn=en} = C v1 ... vm
- * where:
- * vi = e1, if the ith component of C is labelled with x1
- * ...
- * = en, if the ith component of C is labelled with xn
- * = undefined, otherwise
- *
- * Update is implemented using the following transformation:
- *
- * e{x1=e1, ..., xn=en}
- * = let nv (C a1 ... am) v1 ... vn = C a1' .. am'
- * nv (D b1 ... bk) v1 ... vn = D b1' .. bk
- * ...
- * nv _ v1 ... vn = error "failed update"
- * in nv e e1 ... en
- * where:
- * nv, v1, ..., vn, a1, ..., am, b1, ..., bk, ... are new variables,
- * C,D,... = { K | K is a constr fun s.t. {x1,...,xn} subset of sels(K)}
- * and:
- * ai' = v1, if the ith component of C is labelled with x1
- * ...
- * = vn, if the ith component of C is labelled with xn
- * = ai, otherwise
- * etc...
- *
- * The error case may be omitted if C,D,... is an enumeration of all of the
- * constructors for the datatype concerned. Strictly speaking, error case
- * isn't needed at all -- the only benefit of including it is that the user
- * will get a "failed update" message rather than a cryptic {v354 ...}.
- * So, for now, we'll go with the second option!
- *
- * For the time being, code for each update operation is generated
- * independently of any other updates. However, if updates are used
- * frequently, then we might want to consider changing the implementation
- * at a later stage to cache definitions of functions like nv above. This
- * would create a shared library of update functions, indexed by a set of
- * constructors {C,D,...}.
- * ------------------------------------------------------------------------*/
-
-static Cell local transConFlds(c,flds) /* Translate C{flds} */
-Name c;
-List flds; {
- Cell e = c;
- Int m = name(c).arity;
- Int i;
- for (i=m; i>0; i--)
- e = ap(e,nameUndefined);
- for (; nonNull(flds); flds=tl(flds)) {
- Cell a = e;
- for (i=m-sfunPos(fst(hd(flds)),c); i>0; i--)
- a = fun(a);
- arg(a) = translate(snd(hd(flds)));
- }
- return e;
-}
-
-static Cell local transUpdFlds(e,cs,flds)/* Translate e{flds} */
-Cell e; /* (cs is corresp list of constrs) */
-List cs;
-List flds; {
- Cell nv = inventVar();
- Cell body = ap(nv,translate(e));
- List fs = flds;
- List args = NIL;
- List alts = NIL;
-
- for (; nonNull(fs); fs=tl(fs)) { /* body = nv e1 ... en */
- Cell b = hd(fs); /* args = [v1, ..., vn] */
- body = ap(body,translate(snd(b)));
- args = cons(inventVar(),args);
- }
-
- for (; nonNull(cs); cs=tl(cs)) { /* Loop through constructors to */
- Cell c = hd(cs); /* build up list of alts. */
- Cell pat = c;
- Cell rhs = c;
- List as = args;
- Int m = name(c).arity;
- Int i;
-
- for (i=m; i>0; i--) { /* pat = C a1 ... am */
- Cell a = inventVar(); /* rhs = C a1 ... am */
- pat = ap(pat,a);
- rhs = ap(rhs,a);
- }
-
- for (fs=flds; nonNull(fs); fs=tl(fs), as=tl(as)) {
- Name s = fst(hd(fs)); /* Replace approp ai in rhs with */
- Cell r = rhs; /* vars from [v1,...,vn] */
- for (i=m-sfunPos(s,c); i>0; i--)
- r = fun(r);
- arg(r) = hd(as);
- }
-
- alts = cons(pair(cons(pat,args),rhs),alts);
- }
- return ap(LETREC,pair(singleton(pair(nv,alts)),body));
-}
-
-/* --------------------------------------------------------------------------
- * Desugar control:
- * ------------------------------------------------------------------------*/
-
-Void desugarControl(what)
-Int what; {
- patControl(what);
- switch (what) {
- case INSTALL :
- /* Fall through */
- case RESET : break;
- case MARK : break;
- }
-}
-
-/*-------------------------------------------------------------------------*/
+++ /dev/null
-/* -*- mode: hugs-c; -*- */
-extern Cell translate Args((Cell));
-extern Void transAlt Args((Cell));
-extern List transBinds Args((List));
-
+++ /dev/null
-/* -*- mode: hugs-c; -*- */
-extern List freeVarsBind Args((List, StgVar));
+++ /dev/null
-typedef long Target;
-extern Void setGoal Args((String, Target));
-extern Void soFar Args((Target));
-extern Void done Args((Void));
-
-extern String fromEnv Args((String,String));
-extern Bool chase Args((List));
-
-
-extern String hugsEdit; /* String for editor command */
-extern String hugsPath; /* String for file search path */
-
-extern Cell *CStackBase; /* pointer to base of C stack */
-
-
-
-extern Bool gcMessages; /* TRUE => print GC messages */
-#if DEBUG_CODE
-extern Bool debugCode; /* TRUE => print G-code to screen */
-#endif
-extern Bool kindExpert; /* TRUE => display kind errors in */
- /* full detail */
-extern Bool allowOverlap; /* TRUE => allow overlapping insts */
-
+++ /dev/null
-/****************************************************************
- * Grammar for interface files
- ****************************************************************/
-
-This document purports to describe the syntax (and semantics?) of
-interface files generated by GHC for use by Hugs.
-
-
-/****************************************************************
- * ToDo:
- ****************************************************************/
-
-o GHC currently generates "Functor( :Functor :Functor map )" in export lists.
- This is no longer legal and is very confusing besides - but what
- will GHC generate instead?
-
-
-/****************************************************************
- * Closures generated by GHC
- ****************************************************************/
-
-GHC generates a closure for the following objects (if exported):
-
-o variables
-o instance decls
-o methods selectors and superclass selectors
-o selector functions (from record syntax)
-o data constructors
-
-If an object foo (respectively Foo) is declared in a module Bar, then
-the closure is called Bar_foo_closure (respectively Bar_Foo_closure).
-
-Whether the object is static or not is not reflected in the name. The
-type or arity of the object is not reflected in the name. The name is
-just Bar_foo_closure.
-
-Modifications to the above:
-
-1) Depending on the architecture, it might be necessary to add a
- leading underscore to the name.
-
-2) We also have to apply the infamous Z-encoding:
-
- Code from somewhere inside GHC (circa 1994)
- * Z-escapes:
- "std"++xs -> "Zstd"++xs
- char_to_c 'Z' = "ZZ"
- char_to_c '&' = "Za"
- char_to_c '|' = "Zb"
- char_to_c ':' = "Zc"
- char_to_c '/' = "Zd"
- char_to_c '=' = "Ze"
- char_to_c '>' = "Zg"
- char_to_c '#' = "Zh"
- char_to_c '<' = "Zl"
- char_to_c '-' = "Zm"
- char_to_c '!' = "Zn"
- char_to_c '.' = "Zo"
- char_to_c '+' = "Zp"
- char_to_c '\'' = "Zq"
- char_to_c '*' = "Zt"
- char_to_c '_' = "Zu"
- char_to_c c = "Z" ++ show (ord c)
-
- (There's a commented out piece of code in rts/Printer.c which
- implements this.)
-
-
-/****************************************************************
- * Lexical syntax
- ****************************************************************/
-
-The lexical syntax is exactly the same as for Haskell with the
-following additions:
-
-Keywords
-~~~~~~~~
-
-We add: __export __interface __requires
-
-
-Pragmas
-~~~~~~~
-
-GHC will use pragmas of the form: {-## ##-}.
-
-These are always ignored by Hugs and may be ignored by GHC.
-
-GHC will be able to use lazy parsing for these - just as it
- currently does for unfoldings and the like.
-
-
-Compiler generated names
-~~~~~~~~~~~~~~~~~~~~~~~~
-
-Are of the form _letter(letter|digit|symbol)*.
-
-It's important that they can always be generated by putting "_l"
-in front of a valid Haskell varid, varop, conid or conop.
-
-It's also important that valid Haskell patterns such as _:_
-should not be valid compiler generated names.
-
-The letter indicates something about the kind of object it is
-but all that Hugs needs to do is separate conid/ops from varid/ops
-- which it does depending on whether the letter is uppercase.
-
-
-/****************************************************************
- * Header
- ****************************************************************/
-
-iface : '__interface' ifaceName NUMLIT version 'where' Body
-
-Body : '__requires' STRINGLIT ';'
- { importDecl ';' }
- { instanceImportDecl ';' }
- { exportDecl ';' }
- { fixityDecl ';' }
- { classDecl ';' }
- { instanceDecl ';' }
- { typeDecl ';' }
- { valueDecl ';' }
-
-version : NUMLIT
-
-/****************************************************************
- * Import-export stuff
- *
- * I believe the meaning of 'import' is "qualified import" - but
- * I'm not sure. - ADR
- ****************************************************************/
-
-importDecl : 'import' CONID NUMLIT
-instanceImportDecl : 'instance' 'import' CONID NUMLIT
-exportDecl : '__export' CONID { Entity }
-
-Entity : EntityOcc
- | EntityOcc StuffInside
- | EntityOcc '|' StuffInside
-
-EntityOcc : Var
- | Data
- | '->'
- | '(' '->' ')'
-
-StuffInside : '{' ValOcc { ValOcc } '}'
-
-ValOcc : Var
- | Data
-
-/****************************************************************
- * Fixities
- ****************************************************************/
-
-fixityDecl : 'infixl' optdigit op
- | 'infixr' optdigit op
- | 'infix' optdigit op
-
-/****************************************************************
- * Type declarations
- *
- * o data decls use "Data" on lhs and rhs to allow this decl:
- *
- * data () = ()
- *
- * o data declarations don't have the usual Haskell syntax:
- * o they don't have strictness annotations
- * o they are given an explicit signature instead of a list of
- * argument types
- * o field selectors are given an explicit signature
- *
- * [Simon PJ asked me to look again at how much work it would take to
- * handle the standard syntax. The answer is:
- * o It takes an awful lot of code to process the standard syntax.
- * o I can hardly reuse any of the existing code because it is too
- * tightly interwoven with other parts of static analysis.
- * o The rules for processing data decls are very intricate
- * (and are worse since existentials and local polymorphism were
- * added). Implementing a complicated thing twice (once in
- * GHC and once in Hugs) is bad; implementing it a third time
- * is Just Plain Wrong.
- * ]
- *
- * Data decls look like this:
- *
- * data List a = Nil :: forall [a] => List a
- * | Cons{hd,tl} :: forall [a] => a -> List a -> List a
- * where
- * hd :: forall [a] => List a -> a
- * tl :: forall [a] => List a -> List a
- *
- * o The tyvars on the lhs serve only to help infer the kind of List
- * o The type of each data constructor and selector is written
- * explicitly.
- * o A small amount of work is required to figure out which
- * variables are existentially quantified.
- * o GHC will require an inlining pragma to recover strictness
- * annotations.
- ****************************************************************/
-
-typeDecl : NUMLIT 'type' TCName {TVBndr} '=' Type
- | NUMLIT 'data' Data {TVBndr} ['=' Constrs ['where' Sels]]
- | NUMLIT 'newtype' TCName {TVBndr} [ '=' Data AType ]
-
-Constrs : Constr {'|' Constr}
-Constr : Data [Fields] '::' Type
-Fields : '{' VarName {',' VarName} '}'
-
-Sels : Sel {';' Sel}
-Sel : VarName '::' ['!'] Type
-
-/****************************************************************
- * Classes and instances
- *
- * Question: should the method signature include the class
- * constraint? That is, should we write the Eq decl like this:
- *
- * class Eq a where { (==) :: a -> a -> Bool } -- like Haskell
- *
- * or like this
- *
- * class Eq a where { (==) :: Eq a => a -> a -> Bool }
- *
- * There's not much to choose between them but the second version
- * is more consistent with what we're doing with data constructors.
- ****************************************************************/
-
-classDecl : NUMLIT 'class' [ Context '=>' ] TCName {TVBndr} 'where' CSigs
-instanceDecl : 'instance' [Quant] Class '=' Var
-
-CSigs : '{' CSig { ';' CSigs } '}'
-CSig : VarName ['='] '::' Type
-
-/****************************************************************
- * Types
- ****************************************************************/
-
-Type : Quant Type
- | BType '->' Type
- | BType
-
-Context : '(' Class { ',' Class } ')'
-
-Class : QTCName { AType }
-
-BType : AType { AType }
-
-AType : QTCName
- | TVName
- | '(' ')' // unit
- | '(' Type ')' // parens
- | '(' Type ',' Type { ',' Type } ')' // tuple
- | '[' Type ']' // list
- | '{' QTCName { AType } '}' // dictionary
-
-
-Quant : 'forall' {TVBndr} [Context] '=>'
-
-TVBndr : TVName [ '::' AKind ]
-
-Kind : { AKind -> } AKind
-AKind : VAROP // really '*'
- | '(' Kind ')'
-
-/****************************************************************
- * Values
- ****************************************************************/
-
-valueDecl : NUMLIT Var '::' Type
-
-/****************************************************************
- * Atoms
- ****************************************************************/
-
-VarName : Var
-TVName : VARID
-
-Var : VARID
- | VAROP
- | '!'
- | '.'
- | '-'
-
-Data : CONID
- | CONOP
- | '(' ')'
- | '[' ']'
-
-TCName : CONID
- | CONOP
- | '(' '->' ')'
- | '[' ']'
-
-QTCName : TCName
- | QCONID
- | QCONOP
-
-ifaceName : CONID
-
-/****************************************************************
- * End
- ****************************************************************/
-
+++ /dev/null
-extern String repeatStr; /* Repeat last command string */
-
-extern List tyconDefns; /* list of type constructor defns */
-extern List typeInDefns; /* list of synonym restrictions */
-extern List valDefns; /* list of value definitions */
-extern List opDefns; /* list of operator definitions */
-extern List classDefns; /* list of class definitions */
-extern List instDefns; /* list of instance definitions */
-extern List selDefns; /* list of selector lists */
-extern List genDefns; /* list of generated defns */
-extern List foreignImports; /* foreign import declarations */
-extern List foreignExports; /* foreign export declarations */
-extern List defaultDefns; /* default definitions (if any) */
-extern Int defaultLine; /* line in which default defs occur*/
-extern List evalDefaults; /* defaults for evaluator */
-extern Cell inputExpr; /* evaluator input expression */
-
-extern Bool literateScripts; /* TRUE => default lit scripts */
-extern Bool literateErrors; /* TRUE => report errs in lit scrs */
- /* termination */
-#if USE_PREPROCESSOR
-extern String preprocessor; /* preprocessor command */
-#endif
-
-extern Cell conPrelude; /* Prelude */
-#if NPLUSK
-extern Text textPlus; /* Used to recognise n+k patterns */
-#endif
-
-extern String unlexChar Args((Char,Char));
-extern Void printString Args((String));
-
-extern Void consoleInput Args((String));
-extern Void projInput Args((String));
-extern Void stringInput Args((String));
-extern Void parseScript Args((String,Long));
-extern Void parseInterface Args((String,Long));
-extern Void parseExp Args((Void));
-extern String readFilename Args((Void));
-extern String readLine Args((Void));
-
-extern Bool isInterfaceFile Args((String));
+++ /dev/null
-/* -*- mode: hugs-c; -*- */
-/* --------------------------------------------------------------------------
- * GHC interface file processing for Hugs
- *
- * 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
- *
- * $RCSfile: interface.c,v $
- * $Revision: 1.2 $
- * $Date: 1998/12/02 13:22:15 $
- * ------------------------------------------------------------------------*/
-
-/* ToDo:
- * o use Z encoding
- * o use vectored CONSTR_entry when appropriate
- * o generate export list
- *
- * Needs GHC changes to generate member selectors,
- * superclass selectors, etc
- * o instance decls
- * o dictionary constructors ?
- *
- * o Get Hugs/GHC to agree on what interface files look like.
- * o figure out how to replace the Hugs Prelude with the GHC Prelude
- */
-
-#include "prelude.h"
-#include "storage.h"
-#include "connect.h"
-#include "static.h"
-#include "errors.h"
-#include "link.h"
-#include "modules.h"
-#include "machdep.h" /* for Time */
-#include "input.h" /* for parseInterface */
-#include "type.h" /* for offsetTyVarsIn */
-#include "stg.h" /* for wrapping GHC objects */
-#include "Assembler.h" /* for wrapping GHC objects */
-#include "interface.h"
-#include "dynamic.h"
-
-/* --------------------------------------------------------------------------
- * The "addGHC*" functions act as "impedence matchers" between GHC
- * interface files and Hugs. Their main job is to convert abstract
- * syntax trees into Hugs' internal representations.
- *
- * The main trick here is how we deal with mutually recursive interface
- * files:
- *
- * o As we read an import decl, we add it to a list of required imports
- * (unless it's already loaded, of course).
- *
- * o Processing of declarations is split into two phases:
- *
- * 1) While reading the interface files, we construct all the Names,
- * Tycons, etc declared in the interface file but we don't try to
- * resolve references to any entities the declaration mentions.
- *
- * This is done by the "addGHC*" functions.
- *
- * 2) After reading all the interface files, we finish processing the
- * declarations by resolving any references in the declarations
- * and doing any other processing that may be required.
- *
- * This is done by the "finishGHC*" functions which use the
- * "fixup*" functions to assist them.
- *
- * The interface between these two phases are the "ghc*Decls" which
- * contain lists of decls that haven't been completed yet.
- *
- * ------------------------------------------------------------------------*/
-
-/* --------------------------------------------------------------------------
- * local variables:
- * ------------------------------------------------------------------------*/
-
-static List ghcVarDecls;
-static List ghcConDecls;
-static List ghcSynonymDecls;
-static List ghcClassDecls;
-static List ghcInstanceDecls;
-
-/* --------------------------------------------------------------------------
- * local function prototypes:
- * ------------------------------------------------------------------------*/
-
-static List local addGHCConstrs Args((Int,List,List));
-static Name local addGHCSel Args((Int,Pair,List));
-static Name local addGHCConstr Args((Int,Int,Triple));
-
-
-static Void local finishGHCVar Args((Name));
-static Void local finishGHCCon Args((Name));
-static Void local finishGHCSynonym Args((Tycon));
-static Void local finishGHCClass Args((Class));
-static Void local finishGHCInstance Args((Inst));
-
-static Name local fixupSel Args((Int,Pair,List));
-static Name local fixupConstr Args((Int,Int,Triple));
-static Name local fixupMember Args((Int,Int,Pair));
-static List local fixupMembers Args((Int,List));
-static Type local fixupTypeVar Args((Int,List,Text));
-static Class local fixupClass Args((Int,Text));
-static Cell local fixupPred Args((Int,List,Pair));
-static List local fixupContext Args((Int,List,List));
-static Type local fixupType Args((Int,List,Type));
-static Type local fixupConType Args((Int,Type));
-
-static Void local bindNameToClosure Args((Name,AsmClosure));
-static Kinds local tvsToKind Args((List));
-static Int local arityFromType Args((Type));
-
-static AsmClosure local lookupGHCClosure Args((Module,Text));
-
-/* --------------------------------------------------------------------------
- * code:
- * ------------------------------------------------------------------------*/
-
-static List interfaces; /* Interface files that haven't been loaded yet */
-
-Void loadInterface(String fname)
-{
- ghcVarDecls = NIL;
- ghcConDecls = NIL;
- ghcSynonymDecls = NIL;
- ghcClassDecls = NIL;
- ghcInstanceDecls = NIL;
-
- /* Note: interfaces is added to by addGHCImport which is called by
- * parseInterface so each time round the loop we remove the
- * current interface from the list before calling parseInterface again.
- */
- interfaces=singleton(mkCon(findText(fname)));
- while (nonNull(interfaces)) {
- String fname = textToStr(textOf(hd(interfaces)));
- Time timeStamp; /* not used */
- Long fileSize;
- getFileInfo(fname, &timeStamp, &fileSize);
- interfaces=tl(interfaces);
- parseInterface(fname,fileSize);
- }
-
- /* the order of these doesn't matter
- * (ToDo: unless synonyms have to be eliminated??)
- */
- mapProc(finishGHCVar, ghcVarDecls);
- mapProc(finishGHCCon, ghcConDecls);
- mapProc(finishGHCSynonym, ghcSynonymDecls);
- mapProc(finishGHCClass, ghcClassDecls);
- mapProc(finishGHCInstance, ghcInstanceDecls);
- ghcVarDecls = NIL;
- ghcConDecls = NIL;
- ghcSynonymDecls = NIL;
- ghcClassDecls = NIL;
- ghcInstanceDecls = NIL;
-}
-
-Void openGHCIface(t)
-Text t; {
- Module m = findModule(t);
- if (isNull(m)) {
- m = newModule(t);
- } else if (m != modulePreludeHugs) {
- ERRMSG(0) "Module \"%s\" already loaded", textToStr(t)
- EEND;
- }
- setCurrModule(m);
-}
-
-Void addGHCImport(line,mn,fn)
-Int line;
-Text mn;
-String fn; {
-#if 1 /* new */
- Text t = findText(fn);
- Module m = findModule(mn);
- if (isNull(m)) {
- if (isNull(varIsMember(t,interfaces))) {
- interfaces = cons(mkCon(t),interfaces);
- }
- }
-#else /* old - and probably wrong */
- Module m = findModule(t);
- if (isNull(m)) {
- ERRMSG(0) "Unknown module \"%s\"", textToStr(t)
- EEND;
- }
- /* ToDo: what to do if there's a name conflict? */
- { /* copied from resolveImportList */
- List es = module(m).exports;
- List imports = NIL;
- for(; nonNull(es); es=tl(es)) {
- Cell e = hd(es);
- if (isName(e)) {
- imports = cons(e,imports);
- } else {
- Cell c = fst(e);
- List subentities = NIL;
- imports = cons(c,imports);
- if (isTycon(c)
- && (tycon(c).what == DATATYPE
- || tycon(c).what == NEWTYPE)) {
- subentities = tycon(c).defn;
- } else if (isClass(c)) {
- subentities = cclass(c).members;
- }
- if (DOTDOT == snd(e)) {
- imports = revDupOnto(subentities,imports);
- }
- }
- }
- map1Proc(importEntity,m,imports);
- }
-#endif
-}
-
-void addGHCVar(line,v,ty)
-Int line;
-Text v;
-Type ty;
-{
- Name n = findName(v);
- if (nonNull(n)) {
- ERRMSG(0) "Attempt to redefine variable \"%s\"", textToStr(v)
- EEND;
- }
- n = newName(v);
- bindNameToClosure(n, lookupGHCClosure(name(n).mod,name(n).text));
-
- /* prepare for finishGHCVar */
- name(n).type = ty;
- ghcVarDecls = cons(n,ghcVarDecls);
-}
-
-static Void local finishGHCVar(Name n)
-{
- Int line = name(n).line;
- Type ty = name(n).type;
- setCurrModule(name(n).mod);
- name(n).type = fixupType(line,NIL,ty);
-}
-
-Void addGHCSynonym(line,tycon,tvs,ty)
-Int line;
-Cell tycon; /* ConId */
-List tvs; /* [(VarId,Kind)] */
-Type ty; {
- /* ToDo: worry about being given a decl for (->) ?
- * and worry about qualidents for ()
- */
- Text t = textOf(tycon);
- if (nonNull(findTycon(t))) {
- ERRMSG(line) "Repeated definition of type constructor \"%s\"",
- textToStr(t)
- EEND;
- } else {
- Tycon tc = newTycon(t);
- tycon(tc).line = line;
- tycon(tc).arity = length(tvs);
- tycon(tc).what = SYNONYM;
- tycon(tc).kind = tvsToKind(tvs);
-
- /* prepare for finishGHCSynonym */
- tycon(tc).defn = pair(tvs,ty);
- ghcSynonymDecls = cons(tc,ghcSynonymDecls);
- }
-}
-
-static Void local finishGHCSynonym(Tycon tc)
-{
- Int line = tycon(tc).line;
- List tvs = fst(tycon(tc).defn);
- Type ty = snd(tycon(tc).defn);
-
- setCurrModule(tycon(tc).mod);
- tycon(tc).defn = fixupType(line,singleton(tvs),ty);
-
- /* ToDo: can't really do this until I've done all synonyms
- * and then I have to do them in order
- * tycon(tc).defn = fullExpand(ty);
- */
-}
-
-Void addGHCDataDecl(line,tycon,tvs,constrs,sels)
-Int line;
-Cell tycon; /* ConId | QualConId */
-List tvs; /* [(VarId,Kind)] */
-List constrs; /* [(ConId,[VarId],Type)] */
-List sels; { /* [(VarId,Type)] */
- /* ToDo: worry about being given a decl for (->) ?
- * and worry about qualidents for ()
- */
- Text t = textOf(tycon);
- if (nonNull(findTycon(t))) {
- ERRMSG(line) "Repeated definition of type constructor \"%s\"",
- textToStr(t)
- EEND;
- } else {
- Tycon tc = newTycon(t);
- tycon(tc).line = line;
- tycon(tc).arity = length(tvs);
- tycon(tc).what = DATATYPE;
- tycon(tc).kind = tvsToKind(tvs);
- tycon(tc).defn = addGHCConstrs(line,constrs,sels);
- }
-}
-
-static List local addGHCConstrs(line,cons,sels)
-Int line;
-List cons; /* [(ConId,[VarId],Type)] */
-List sels; { /* [(VarId,Type)] */
- List uses = NIL; /* [(ConName,[VarId])] */
- if (nonNull(cons) && isNull(tl(cons))) { /* Single constructor datatype? */
- List fs = snd3(hd(cons));
- Name c = addGHCConstr(line,0,hd(cons));
- uses = cons(pair(c,fs),uses);
- hd(cons) = c;
- } else {
- Int conNo = 0; /* or maybe 1? */
- List cs = cons;
- for(; nonNull(cs); cs=tl(cs), conNo++) {
- List fs = snd3(hd(cs));
- Name c = addGHCConstr(line,conNo,hd(cs));
- uses = cons(pair(c,fs),uses);
- hd(cs) = c;
- }
- }
- {
- List ss = sels;
- for(; nonNull(ss); ss=tl(ss)) {
- hd(ss) = addGHCSel(line,hd(ss),uses);
- }
- }
- return appendOnto(cons,sels);
-}
-
-static Name local addGHCSel(line,sel,uses)
-Int line;
-Pair sel; /* (VarId,Type) */
-List uses; { /* [(ConName,[VarId])] */
- Text t = textOf(fst(sel));
- Type type = snd(sel);
- List fields = NIL;
-
- Name n = findName(t);
- if (nonNull(n)) {
- ERRMSG(line) "Repeated definition for selector \"%s\"",
- textToStr(t)
- EEND;
- }
-
- n = newName(t);
- name(n).line = line;
- name(n).number = SELNAME;
- name(n).arity = 1;
-
- for(; nonNull(uses); uses=tl(uses)) {
- Int fNo = 1;
- Name c = fst(hd(uses));
- List fs = snd(hd(uses));
- for(; nonNull(fs); fs=tl(fs), fNo++) {
- if (textOf(hd(fs)) == t) {
- fields = cons(pair(c,mkInt(fNo)),fields);
- }
- }
- }
- name(n).defn = fields;
-
- /* prepare for finishGHCVar */
- name(n).type = type;
- ghcVarDecls = cons(n,ghcVarDecls);
-
- return n;
-}
-
-static Name local addGHCConstr(line,conNo,constr)
-Int line;
-Int conNo;
-Triple constr; { /* (ConId,[VarId],Type) */
- /* ToDo: add rank2 annotation and existential annotation
- * these affect how constr can be used.
- */
- Text con = textOf(fst3(constr));
- Type type = thd3(constr);
- Int arity = arityFromType(type);
- Name n = findName(con); /* Allocate constructor fun name */
- if (isNull(n)) {
- n = newName(con);
- } else if (name(n).defn!=PREDEFINED) {
- ERRMSG(line) "Repeated definition for constructor \"%s\"",
- textToStr(con)
- EEND;
- }
- name(n).arity = arity; /* Save constructor fun details */
- name(n).line = line;
- name(n).number = cfunNo(conNo);
- bindNameToClosure(n, lookupGHCClosure(name(n).mod,name(n).text));
-
- /* prepare for finishGHCCon */
- name(n).type = type;
- ghcConDecls = cons(n,ghcConDecls);
-
- return n;
-}
-
-static Void local finishGHCCon(Name n)
-{
- Int line = name(n).line;
- Type ty = name(n).type;
- setCurrModule(name(n).mod);
- name(n).type = fixupConType(line,ty);
-}
-
-Void addGHCNewType(line,tycon,tvs,constr)
-Int line;
-Cell tycon; /* ConId | QualConId */
-List tvs; /* [(VarId,Kind)] */
-Cell constr; {
- /* ToDo: worry about being given a decl for (->) ?
- * and worry about qualidents for ()
- */
- Text t = textOf(tycon);
- if (nonNull(findTycon(t))) {
- ERRMSG(line) "Repeated definition of type constructor \"%s\"",
- textToStr(t)
- EEND;
- } else {
- Tycon tc = newTycon(t);
- tycon(tc).line = line;
- tycon(tc).arity = length(tvs);
- tycon(tc).what = NEWTYPE;
- tycon(tc).kind = tvsToKind(tvs);
- /* can't really do this until I've read in all synonyms */
-
- if (isNull(constr)) {
- tycon(tc).defn = NIL;
- } else {
- /* constr :: (ConId,Type) */
- Text con = textOf(fst(constr));
- Type type = snd(constr);
- Name n = findName(con); /* Allocate constructor fun name */
- if (isNull(n)) {
- n = newName(con);
- } else if (name(n).defn!=PREDEFINED) {
- ERRMSG(line) "Repeated definition for constructor \"%s\"",
- textToStr(con)
- EEND;
- }
- name(n).arity = 1; /* Save constructor fun details */
- name(n).line = line;
- name(n).number = cfunNo(0);
- name(n).defn = nameId;
- tycon(tc).defn = singleton(n);
-
- /* prepare for finishGHCCon */
- /* ToDo: we use finishGHCCon instead of finishGHCVar in case
- * there's any existential quantification in the newtype -
- * but I don't think that's allowed in newtype constrs.
- * Still, no harm done by doing it this way...
- */
- name(n).type = type;
- ghcConDecls = cons(n,ghcConDecls);
- }
- }
-}
-
-Void addGHCClass(line,ctxt,tc_name,tvs,mems)
-Int line;
-List ctxt; /* [(ConId, [Type])] */
-Cell tc_name; /* ConId | QualConId */
-List tvs; /* [(VarId,Kind)] */
-List mems; {
- Text ct = textOf(tc_name);
- if (nonNull(findClass(ct))) {
- ERRMSG(line) "Repeated definition of class \"%s\"",
- textToStr(ct)
- EEND;
- } else if (nonNull(findTycon(ct))) {
- ERRMSG(line) "\"%s\" used as both class and type constructor",
- textToStr(ct)
- EEND;
- } else {
- Class nw = newClass(ct);
- Int arity = length(tvs);
- Cell head = nw;
- Int i;
- for(i=0; i < arity; ++i) {
- head = ap(head,mkOffset(i));
- }
- cclass(nw).line = line;
- cclass(nw).arity = arity;
- cclass(nw).head = head;
- cclass(nw).kinds = tvsToKind(tvs); /* ToDo: I don't think this is right */
- cclass(nw).instances = NIL;
-
- /* prepare for finishGHCClass */
- cclass(nw).supers = pair(tvs,ctxt);
- cclass(nw).members = mems;
- ghcClassDecls = cons(nw,ghcClassDecls);
-
- /* ToDo:
- * cclass(nw).dsels = ?;
- * cclass(nw).dbuild = ?;
- * cclass(nm).dcon = ?;
- * cclass(nm).defaults = ?;
- */
- }
-}
-
-static Void local finishGHCClass(Class nw)
-{
- Int line = cclass(nw).line;
- List tvs = fst(cclass(nw).supers);
- List ctxt = snd(cclass(nw).supers);
- List mems = cclass(nw).members;
-
- setCurrModule(cclass(nw).mod);
-
- cclass(nw).supers = fixupContext(line,singleton(tvs),ctxt);
- cclass(nw).numSupers = length(cclass(nw).supers);
- cclass(nw).members = fixupMembers(line,mems);
- cclass(nw).numMembers = length(cclass(nw).members);
- cclass(nw).level = 0; /* ToDo: level = 1 + max (map level supers) */
-}
-
-Void addGHCInstance (line,quant,cls,var)
-Int line;
-Cell quant;
-Pair cls; /* :: (ConId, [Type]) */
-Text var; {
- Inst in = newInst();
-
- List ctxt = nonNull(quant) ? snd(quant) : NIL; /* [(ConId, [Type])] */
-
- inst(in).line = line;
- inst(in).implements = NIL;
-
- {
- Name b = newName(inventText());
- name(b).line = line;
- name(b).arity = length(ctxt); /* unused? */
- name(b).number = DFUNNAME;
- inst(in).builder = b;
- bindNameToClosure(b, lookupGHCClosure(inst(in).mod,var));
- }
-
- /* prepare for finishGHCInstance */
- inst(in).head = cls;
- inst(in).specifics = quant;
- ghcInstanceDecls = cons(in,ghcInstanceDecls);
-}
-
-static Void local finishGHCInstance(Inst in)
-{
- Int line = inst(in).line;
- Cell cl = fst(inst(in).head);
- List tys = snd(inst(in).head);
- Cell quant = inst(in).specifics;
- List tvs = nonNull(quant) ? fst(quant) : NIL; /* [(VarId,Kind)] */
- List ctxt = nonNull(quant) ? snd(quant) : NIL; /* [(ConId, [Type])] */
- List tyvars = singleton(tvs);
- Class c;
-
- setCurrModule(inst(in).mod);
- c = findClass(textOf(cl));
- if (isNull(c)) {
- ERRMSG(line) "Unknown class \"%s\" in instance",
- textToStr(textOf(cl))
- EEND;
- }
- map2Over(fixupType,line,tyvars,tys);
- inst(in).head = applyToArgs(c,tys);
- inst(in).specifics = fixupContext(line,tyvars,ctxt);
- inst(in).numSpecifics = length(inst(in).specifics);
- cclass(c).instances = cons(in,cclass(c).instances);
-}
-
-/* --------------------------------------------------------------------------
- *
- * ------------------------------------------------------------------------*/
-
-static Name local fixupMember(line,memNo,mem)
-Int line;
-Int memNo;
-Pair mem; { /* :: (Text,Type) */
- Text t = textOf(fst(mem));
- Type type = snd(mem);
- Name m = findName(t);
-
- if (isNull(m)) {
- m = newName(t);
- } else if (name(m).defn!=PREDEFINED) {
- ERRMSG(line) "Repeated definition for member function \"%s\"",
- textToStr(t)
- EEND;
- }
-
- name(m).line = line;
- name(m).arity = 1;
- name(m).number = mfunNo(memNo);
- name(m).type = fixupType(line,NIL,type);
-
- /* ToDo: name(m).stgVar = ?; */
-
- return m;
-}
-
-
-static List local fixupMembers(line,ms)
-Int line;
-List ms; {
- Int memNo = 1;
- List mems = ms;
- for(; nonNull(mems); mems=tl(mems), memNo++) {
- hd(mems) = fixupMember(line,memNo,hd(mems));
- }
- return ms;
-}
-
-static Type local fixupTypeVar(line,tyvars,tv)
-Int line;
-List tyvars; /* [[(VarId,Kind)]] */
-Text tv; {
- Int offset = 0;
- for (; nonNull(tyvars); tyvars=tl(tyvars)) {
- List tvs = hd(tyvars);
- for (; nonNull(tvs); offset++, tvs=tl(tvs)) {
- if (tv == textOf(fst(hd(tvs)))) {
- return mkOffset(offset);
- }
- }
- }
- ERRMSG(line) "Undefined type variable \"%s\"", textToStr(tv)
- EEND;
-}
-
-static Class local fixupClass(line,cls)
-Int line;
-Text cls; {
- Class c = findClass(cls);
- if (isNull(c)) {
- ERRMSG(line)
- "Undefined class \"%s\"", textToStr(cls)
- EEND;
- }
- return c;
-}
-
-static Cell local fixupPred(line,tyvars,pred)
-Int line;
-List tyvars; /* [[(VarId,Kind)]] */
-Pair pred; { /* (ConId,[Type]) */
- Class c = fixupClass(line,textOf(fst(pred)));
- List tys = snd(pred);
-
- map2Over(fixupType,line,tyvars,tys);
- return applyToArgs(c,tys);
-}
-
-static List local fixupContext(line,tyvars,ctxt)
-Int line;
-List tyvars; /* [[(VarId,Kind)]] */
-List ctxt; { /* [(ConId,[Type])] */
- map2Over(fixupPred,line,tyvars,ctxt);
- return ctxt;
-}
-
-static Type local fixupType(line,tyvars,type)
-Int line;
-List tyvars; /* [[(VarId,Kind)]] */
-Type type; {
- switch (whatIs(type)) {
- case AP:
- {
- fst(type) = fixupType(line,tyvars,fst(type));
- snd(type) = fixupType(line,tyvars,snd(type));
- break;
- }
- case DICTAP:
- {
- /* Alternatively: raise an error. These can only
- * occur in the types of instance variables which
- * we could easily separate from "real variables".
- */
- snd(type) = fixupPred(line,tyvars,snd(type));
- break;
- }
- case VARIDCELL:
- return fixupTypeVar(line,tyvars,textOf(type));
- case CONIDCELL:
- {
- Tycon tc = findQualTycon(type);
- if (isNull(tc)) {
- ERRMSG(line)
- "Undefined type constructor \"%s\"",
- identToStr(type)
- EEND;
- }
- return tc;
- }
-#if TREX
- case EXT:
-#endif
- case TYCON:
- case TUPLE:
- break;
- case POLYTYPE:
- {
- List tvs = fst3(snd(type)); /* [(VarId, Kind)] */
- List ctxt = snd3(snd(type)); /* [(ConId, [Type])] */
- Type ty = thd3(snd(type));
-
- if (nonNull(tvs)) {
- tyvars = cons(tvs,tyvars);
- }
- type = fixupType(line,tyvars,ty);
-
- if (nonNull(ctxt)) {
- type = ap(QUAL,pair(fixupContext(line,tyvars,ctxt),type));
- }
- if (nonNull(tvs)) {
- type = mkPolyType(tvsToKind(tvs),type);
- }
- }
- break;
- default:
- internal("fixupType");
- }
- return type;
-}
-
-/* forall as bs. C1 as, C2 as bs => Ts as bs -> T as
- * => forall as. C1 as => exists bs. C2 as bs => Ts as bs -> T as
- */
-static Type local fixupConType(line,type)
-Int line;
-Type type; {
- List sig = NIL;
- List ctxt = NIL;
- type = fixupType(line,NIL,type);
-
- if (isPolyType(type)) {
- sig = polySigOf(type);
- type = monotypeOf(type);
- }
- if (whatIs(type) == QUAL) {
- ctxt = fst(snd(type));
- type = snd(snd(type));
- }
- {
- Type r_ty = type;
- Int nr2 = 0; /* maximum argnum which is a polytype */
- Int argnum = 1;
- while (isAp(r_ty) && getHead(r_ty)==typeArrow) {
- if (isPolyType(arg(fun(r_ty)))) {
- nr2 = argnum;
- }
- argnum++;
- r_ty = arg(r_ty);
- }
-
- if (nr2>0) {
- type = ap(RANK2,pair(mkInt(nr2),type));
- }
- { /* tyvars which don't appear in result are existentially quant'd */
- List result_tvs = offsetTyvarsIn(r_ty,NIL);
- List all_tvs = offsetTyvarsIn(type,NIL);
- Int etvs = length(all_tvs);
- Int ntvs = length(result_tvs);
- if (etvs>ntvs) {
- /* ToDo: split the context into two parts */
- type = ap(EXIST,pair(mkInt(etvs-ntvs),type));
- }
- }
- }
- if (nonNull(ctxt)) {
- type = ap(QUAL,pair(ctxt,type));
- }
- if (nonNull(sig)) {
- type = mkPolyType(sig,type);
- }
- return type;
-}
-
-/* --------------------------------------------------------------------------
- * Utilities
- *
- * None of these do lookups or require that lookups have been resolved
- * so they can be performed while reading interfaces.
- * ------------------------------------------------------------------------*/
-
-static Kinds local tvsToKind(tvs)
-List tvs; { /* [(VarId,Kind)] */
- List rs = NIL;
- Kinds r = STAR; /* ToDo: hope this works */
- for(; nonNull(tvs); tvs=tl(tvs)) { /* make reversed list of kinds */
- rs = cons(snd(hd(tvs)),rs);
- }
- for(; nonNull(rs); rs=tl(rs)) { /* build full kind */
- r = ap(hd(rs),r);
- }
- return r;
-}
-
-static Int local arityFromType(type) /* arity of a constructor with this type */
-Type type; {
- Int arity = 0;
- if (isPolyType(type)) {
- type = monotypeOf(type);
- }
- if (whatIs(type) == QUAL) {
- type = snd(snd(type));
- }
- if (whatIs(type) == EXIST) {
- type = snd(snd(type));
- }
- if (whatIs(type)==RANK2) {
- type = snd(snd(type));
- }
- while (isAp(type) && getHead(type)==typeArrow) {
- arity++;
- type = arg(type);
- }
- return arity;
-}
-
-/* --------------------------------------------------------------------------
- * Dynamic loading code (probably shouldn't be here)
- *
- * o .hi file explicitly says which .so file to load.
- * This avoids the need for a 1-to-1 relationship between .hi and .so files.
- *
- * ToDo: when doing a :reload, we ought to check the modification date
- * on the .so file.
- *
- * o module handles are unloaded (dlclosed) when we call dropScriptsFrom.
- *
- * ToDo: do the same for foreign functions - but with complication that
- * there may be multiple .so files
- * ------------------------------------------------------------------------*/
-
-/* ToDo: move some of this code (back) into dynamic.c and make it portable */
-#include <stdio.h>
-
-static AsmClosure local lookupGHCClosure( Module m, Text t )
-{
- char symbol[100]; /* ToDo: arbitrary constants must die */
- void *c;
- sprintf(symbol,"%s_%s_closure",textToStr(module(m).text),textToStr(t));
- if (module(m).objectFile == NULL) {
- ERRMSG(0) "Interface file must \"require\" at least one file"
- EEND;
- }
- c = lookupSymbol(module(m).objectFile,symbol);
- if (NULL == c) {
- ERRMSG(0) "Error %s while importing symbol \"%s\"", dlerror(), symbol
- EEND;
- }
- return ((AsmClosure)c);
-}
-
-Void loadSharedLib( String fn )
-{
- if (module(currentModule).objectFile != NULL) {
- ERRMSG(0) "Interface file \"require\"s two files"
- EEND;
- }
- module(currentModule).objectFile = loadLibrary(fn);
- if (NULL == module(currentModule).objectFile) {
- ERRMSG(0) "Error %s while importing DLL \"%s\"", dlerror(), fn
- EEND;
- }
-}
-
-static void bindNameToClosure(n,c)
-Name n;
-AsmClosure c; {
- StgVar v = mkStgVar(NIL,mkPtr(asmMkObject(c)));
- name(n).stgVar = v;
-}
-
-/* --------------------------------------------------------------------------
- * Control:
- * ------------------------------------------------------------------------*/
-
-Void interface(what)
-Int what; {
- switch (what) {
- case RESET:
- interfaces = NIL;
- ghcVarDecls = NIL;
- ghcConDecls = NIL;
- ghcSynonymDecls = NIL;
- ghcClassDecls = NIL;
- ghcInstanceDecls = NIL;
- break;
- case MARK:
- mark(interfaces);
- mark(ghcVarDecls);
- mark(ghcConDecls);
- mark(ghcSynonymDecls);
- mark(ghcClassDecls);
- mark(ghcInstanceDecls);
- break;
- }
-}
-
-/*-------------------------------------------------------------------------*/
-
+++ /dev/null
-/* -*- mode: hugs-c; -*- */
-
-extern Void loadInterface Args((String));
-
-extern Void openGHCIface Args((Text));
-extern Void loadSharedLib Args((String));
-extern Void addGHCImport Args((Int,Text,String));
-extern Void addGHCVar Args((Int,Text,Type));
-extern Void addGHCSynonym Args((Int,Cell,List,Type));
-extern Void addGHCDataDecl Args((Int,Cell,List,List,List));
-extern Void addGHCNewType Args((Int,Cell,List,Cell));
-extern Void addGHCClass Args((Int,List,Cell,List,List));
-extern Void addGHCInstance Args((Int,Cell,Pair,Text));
-
+++ /dev/null
-/* -*- mode: hugs-c; -*- */
-/* --------------------------------------------------------------------------
- * Part of type checker dealing with kind inference
- *
- * 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
- *
- * $RCSfile: kind.c,v $
- * $Revision: 1.2 $
- * $Date: 1998/12/02 13:22:16 $
- * ------------------------------------------------------------------------*/
-
-#define newKindvars(n) newTyvars(n) /* to highlight uses of type vars */
- /* as kind variables */
-
-Bool kindExpert = FALSE; /* TRUE => display kind errors in */
- /* full detail */
-
-/* --------------------------------------------------------------------------
- * Kind checking code:
- * ------------------------------------------------------------------------*/
-
-static Void local kindError(l,c,in,wh,k,o)
-Int l; /* line number near constuctor exp */
-Constr c; /* constructor */
-Constr in; /* context (if any) */
-String wh; /* place in which error occurs */
-Kind k; /* expected kind (k,o) */
-Int o; { /* inferred kind (typeIs,typeOff) */
- clearMarks();
-
- if (!kindExpert) { /* for those with a fear of kinds */
- ERRMSG(l) "Illegal type" ETHEN
- if (nonNull(in)) {
- ERRTEXT " \"" ETHEN ERRTYPE(in);
- ERRTEXT "\"" ETHEN
- }
- ERRTEXT " in %s\n", wh
- EEND;
- }
-
- ERRMSG(l) "Kind error in %s", wh ETHEN
- if (nonNull(in)) {
- ERRTEXT "\n*** expression : " ETHEN ERRTYPE(in);
- }
- ERRTEXT "\n*** constructor : " ETHEN ERRTYPE(c);
- ERRTEXT "\n*** kind : " ETHEN ERRKIND(copyType(typeIs,typeOff));
- ERRTEXT "\n*** does not match : " ETHEN ERRKIND(copyType(k,o));
- if (unifyFails) {
- ERRTEXT "\n*** because : %s", unifyFails ETHEN
- }
- ERRTEXT "\n"
- EEND;
-}
-
-#define shouldKind(l,c,in,wh,k,o) if (!kunify(typeIs,typeOff,k,o)) \
- kindError(l,c,in,wh,k,o)
-#define checkKind(l,c,in,wh,k,o) kindConstr(l,c); shouldKind(l,c,in,wh,k,o)
-#define inferKind(k,o) typeIs=k; typeOff=o
-
-static Int locCVars; /* offset to local variable kinds */
-static List unkindTypes; /* types in need of kind annotation*/
-#if TREX
-static Kind extKind; /* Kind of extension, *->row->row */
-#endif
-
-static Void local kindConstr(l,c) /* Determine kind of constructor */
-Int l;
-Cell c; {
- Cell h = getHead(c);
- Int n = argCount;
-
- if (isSynonym(h) && n<tycon(h).arity) {
- ERRMSG(l) "Not enough arguments for type synonym \"%s\"",
- textToStr(tycon(h).text)
- EEND;
- }
-
-#if TREX
- if (isExt(h) && n!=2) {
- ERRMSG(l) "Illegal use of row in " ETHEN ERRTYPE(c);
- ERRTEXT "\n"
- EEND;
- }
-#endif
-
- if (n==0) /* trivial case, no arguments */
- typeIs = kindAtom(c);
- else { /* non-trivial application */
- static String app = "constructor application";
- Cell a = c;
- Int i;
- Kind k;
- Int beta;
-
- varKind(n);
- beta = typeOff;
- k = typeIs;
-
- typeIs = kindAtom(h); /* h :: v1 -> ... -> vn -> w */
- shouldKind(l,h,c,app,k,beta);
-
- for (i=n; i>0; --i) { /* ci :: vi for each 1 <- 1..n */
- checkKind(l,arg(a),c,app,var,beta+i-1);
- a = fun(a);
- }
- tyvarType(beta+n); /* inferred kind is w */
- }
-}
-
-static Kind local kindAtom(c) /* Find kind of atomic constructor */
-Cell c; {
- switch (whatIs(c)) {
- case TUPLE : return simpleKind(tupleOf(c)); /* (,) :: * -> * -> * */
- case OFFSET : return mkInt(locCVars+offsetOf(c));
- case TYCON : return tycon(c).kind;
-#if TREX
- case EXT : return extKind;
-#endif
- }
- internal("kindAtom");
- return STAR;/* not reached */
-}
-
-static Void local kindPred(line,pred) /* Check kinds of arguments in pred*/
-Int line;
-Cell pred; {
- static String predicate = "class constraint";
-#if TREX
- if (isExt(fun(pred))) {
- checkKind(line,arg(pred),NIL,predicate,ROW,0);
- return;
- }
-#endif
- checkKind(line,arg(pred),NIL,predicate,cclass(fun(pred)).sig,0);
-}
-
-static Void local kindType(line,wh,type)/* check that (poss qualified) type*/
-Int line; /* is well-kinded */
-String wh;
-Type type; {
- locCVars = 0;
- if (isPolyType(type)) { /* local constructor vars reqd? */
- Kind k = polySigOf(type);
- Int n = 0;
- for (; isPair(k); k=snd(k))
- n++;
- locCVars = newKindvars(n);
- unkindTypes = cons(pair(mkInt(locCVars),snd(type)),unkindTypes);
- type = monoTypeOf(type);
- }
- if (whatIs(type)==QUAL) { /* examine context (if any) */
- map1Proc(kindPred,line,fst(snd(type)));
- type = snd(snd(type));
- }
- checkKind(line,type,NIL,wh,STAR,0); /* finally, check type part */
-}
-
-static Void local fixKinds() { /* add kind annotations to types */
- for (; nonNull(unkindTypes); unkindTypes=tl(unkindTypes)) {
- Pair pr = hd(unkindTypes);
- Int beta = intOf(fst(pr));
- Cell qts = fst(snd(pr));
- for (;;) {
- if (isNull(hd(qts)))
- hd(qts) = copyKindvar(beta++);
- else
- hd(qts) = ap(hd(qts),copyKindvar(beta++));
- if (nonNull(tl(qts)))
- qts = tl(qts);
- else {
- tl(qts) = STAR;
- break;
- }
- }
-#ifdef DEBUG_KINDS
- Printf("Type expression: ");
- printType(stdout,snd(snd(pr)));
- Printf(" :: ");
- printKind(stdout,fst(snd(pr)));
- Printf("\n");
-#endif
- }
-}
-
-/* --------------------------------------------------------------------------
- * Kind checking of groups of type constructors and classes:
- * ------------------------------------------------------------------------*/
-
-Void kindTCGroup(tcs) /* find kinds for mutually rec. gp */
-List tcs; { /* of tycons and classes */
- typeChecker(RESET);
- mapProc(initTCKind,tcs);
- mapProc(kindTC,tcs);
- mapProc(genTC,tcs);
- fixKinds();
- typeChecker(RESET);
-}
-
-static Void local initTCKind(c) /* build initial kind/arity for c */
-Cell c; {
- if (isTycon(c)) { /* Initial kind of tycon is: */
- Int beta = newKindvars(1); /* v1 -> ... -> vn -> vn+1 */
- varKind(tycon(c).arity); /* where n is the arity of c. */
- bindTv(beta,typeIs,typeOff); /* For data definitions, vn+1 == * */
- switch (whatIs(tycon(c).what)) {
- case NEWTYPE :
- case DATATYPE : bindTv(typeOff+tycon(c).arity,STAR,0);
- }
- tycon(c).kind = mkInt(beta);
- }
- else
- cclass(c).sig = mkInt(newKindvars(1));
-}
-
-static Void local kindTC(c) /* check each part of a tycon/class*/
-Cell c; { /* is well-kinded */
- if (isTycon(c)) {
- static String cfun = "constructor function";
- static String tsyn = "synonym definition";
- Int line = tycon(c).line;
-
- locCVars = tyvar(intOf(tycon(c).kind))->offs;
- switch (whatIs(tycon(c).what)) {
- case NEWTYPE :
- case DATATYPE : { List cs = tycon(c).defn;
- if (whatIs(cs)==QUAL) {
- map1Proc(kindPred,line,fst(snd(cs)));
- tycon(c).defn = cs = snd(snd(cs));
- }
- for (; hasCfun(cs); cs=tl(cs))
- kindType(line,cfun,name(hd(cs)).type);
- break;
- }
-
- default : checkKind(line,tycon(c).defn,NIL,
- tsyn,var,locCVars+tycon(c).arity);
- }
- }
- else { /* scan type exprs in class defn to*/
- List ms = cclass(c).members; /* determine the class signature */
- List scs = cclass(c).supers;
-
- for (; nonNull(scs); scs=tl(scs))
- if (!kunify(cclass(hd(scs)).sig,0,cclass(c).sig,0)) {
- ERRMSG(cclass(c).line)
- "Kind of class \"%s\" does not match superclass \"%s\"",
- textToStr(cclass(c).text), textToStr(cclass(hd(scs)).text)
- EEND;
- }
-
- for (; nonNull(ms); ms=tl(ms)) {
- Int line = intOf(fst3(hd(ms)));
- Type type = thd3(hd(ms));
- kindType(line,"member function type signature",type);
- }
- }
-}
-
-static Void local genTC(c) /* generalise kind inferred for */
-Cell c; { /* given tycon/class */
- if (isTycon(c)) {
- tycon(c).kind = copyKindvar(intOf(tycon(c).kind));
-#ifdef DEBUG_KINDS
- Printf("%s :: ",textToStr(tycon(c).text));
- printKind(stdout,tycon(c).kind);
- Putchar('\n');
-#endif
- }
- else {
- cclass(c).sig = copyKindvar(intOf(cclass(c).sig));
-#ifdef DEBUG_KINDS
- Printf("%s :: ",textToStr(cclass(c).text));
- printKind(stdout,cclass(c).sig);
- Putchar('\n');
-#endif
- }
-}
-
-static Kind local copyKindvar(vn) /* build kind attatched to variable*/
-Int vn; {
- Tyvar *tyv = tyvar(vn);
- if (tyv->bound)
- return copyKind(tyv->bound,tyv->offs);
- return STAR; /* any unbound variable defaults to*/
-} /* the kind of all types */
-
-static Kind local copyKind(k,o) /* build kind expression from */
-Kind k; /* given skeleton */
-Int o; {
- switch (whatIs(k)) {
- case AP : { Kind l = copyKind(fst(k),o); /* ensure correct */
- Kind r = copyKind(snd(k),o); /* eval. order */
- return ap(l,r);
- }
- case OFFSET : return copyKindvar(o+offsetOf(k));
- case INTCELL : return copyKindvar(intOf(k));
- }
- return k;
-}
-
-/* --------------------------------------------------------------------------
- * Kind checking of instance declaration headers:
- * ------------------------------------------------------------------------*/
-
-Void kindInst(in,h) /* check predicates in instance */
-Inst in;
-Cell h; {
- typeChecker(RESET);
- locCVars = newKindvars(inst(in).arity);
- kindPred(inst(in).line,h);
- map1Proc(kindPred,inst(in).line,inst(in).specifics);
- typeChecker(RESET);
-}
-
-/* --------------------------------------------------------------------------
- * Kind checking of individual type signatures:
- * ------------------------------------------------------------------------*/
-
-Void kindSigType(line,type) /* check that type is well-kinded */
-Int line;
-Type type; {
- typeChecker(RESET);
- kindType(line,"type expression",type);
- fixKinds();
- typeChecker(RESET);
-}
-
-/* --------------------------------------------------------------------------
- * Kind checking of default types:
- * ------------------------------------------------------------------------*/
-
-Void kindDefaults(line,ts) /* check that list of types are */
-Int line; /* well-kinded */
-List ts; {
- typeChecker(RESET);
- map2Proc(kindType,line,"default type",ts);
- fixKinds();
- typeChecker(RESET);
-}
-
-/* --------------------------------------------------------------------------
- * Support for `kind preserving substitutions' from unification:
- * ------------------------------------------------------------------------*/
-
-static Bool local eqKind(k1,k2) /* check that two (mono)kinds are */
-Kind k1, k2; { /* equal */
- return k1==k2
- || (isPair(k1) && isPair(k2)
- && eqKind(fst(k1),fst(k2))
- && eqKind(snd(k1),snd(k2)));
-}
-
-static Kind local getKind(c,o) /* Find kind of constr during type */
-Cell c; /* checking process */
-Int o; {
- if (isAp(c)) /* application */
- return snd(getKind(fst(c),o));
- switch (whatIs(c)) {
- case TUPLE : return simpleKind(tupleOf(c)); /* (,) :: * -> * -> * */
- case OFFSET : return tyvar(o+offsetOf(c))->kind;
- case INTCELL: return tyvar(intOf(c))->kind;
- case TYCON : return tycon(c).kind;
-#if TREX
- case EXT : return extKind;
-#endif
- }
-#ifdef DEBUG_KINDS
- Printf("getKind c = %d, whatIs=%d\n",c,whatIs(c));
-#endif
- internal("getKind");
- return STAR;/* not reached */
-}
-
-/* --------------------------------------------------------------------------
- * Two forms of kind expression are used quite frequently:
- * * -> * -> ... -> * -> * for kinds of ->, [], ->, (,) etc...
- * v1 -> v2 -> ... -> vn -> vn+1 skeletons for constructor kinds
- * Expressions of these forms are produced by the following functions which
- * use a cache to avoid repeated construction of commonly used values.
- * A similar approach is used to store the types of tuple constructors in the
- * main type checker.
- * ------------------------------------------------------------------------*/
-
-#define MAXKINDFUN 10
-static Kind simpleKindCache[MAXKINDFUN];
-static Kind varKindCache[MAXKINDFUN];
-
-static Kind local makeSimpleKind(n) /* construct * -> ... -> * (n args)*/
-Int n; {
- Kind k = STAR;
- while (n-- > 0)
- k = ap(STAR,k);
- return k;
-}
-
-static Kind local simpleKind(n) /* return (possibly cached) simple */
-Int n; { /* function kind */
- if (n>=MAXKINDFUN)
- return makeSimpleKind(n);
- else if (nonNull(simpleKindCache[n]))
- return simpleKindCache[n];
- else if (n==0)
- return simpleKindCache[0] = STAR;
- else
- return simpleKindCache[n] = ap(STAR,simpleKind(n-1));
-}
-
-static Kind local makeVarKind(n) /* construct v0 -> .. -> vn */
-Int n; {
- Kind k = mkOffset(n);
- while (n-- > 0)
- k = ap(mkOffset(n),k);
- return k;
-}
-
-static Void local varKind(n) /* return (possibly cached) var */
-Int n; { /* function kind */
- typeOff = newKindvars(n+1);
- if (n>=MAXKINDFUN)
- typeIs = makeVarKind(n);
- else if (nonNull(varKindCache[n]))
- typeIs = varKindCache[n];
- else
- typeIs = varKindCache[n] = makeVarKind(n);
-}
-
-/*-------------------------------------------------------------------------*/
+++ /dev/null
-/* -*- mode: hugs-c; -*- */
-extern List liftBinds( List binds );
-extern Void liftControl ( Int what );
+++ /dev/null
-/* -*- mode: hugs-c; -*- */
-/*---------------------------------------------------------------------------
- * Interrupting execution (signals, allowBreak):
- *-------------------------------------------------------------------------*/
-
-extern Bool breakOn Args((Bool));
-
-extern Bool broken; /* indicates interrupt received */
-
-#ifndef SIGBREAK /* Sigh, not defined in cygwin32 beta release 16 */
-# define SIGBREAK 21
-#endif
-
-/* allowBreak: call to allow user to interrupt computation
- * ctrlbrk: set control break handler
- */
-
-#if HUGS_FOR_WINDOWS
-# 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); }
-#endif /* !HUGS_FOR_WINDOWS */
-
-/*---------------------------------------------------------------------------
- * Environment variables and the registry
- *-------------------------------------------------------------------------*/
-
-/* On Win32 we can use the registry to supplement info in environment
- * variables.
- */
-#define USE_REGISTRY (HAVE_WINDOWS_H && !__MSDOS__)
-
-#ifdef USE_REGISTRY
-Bool writeRegString Args((String var, String val));
-String readRegString Args((String var, String def));
-Int readRegInt Args((String var, Int def));
-Bool writeRegInt Args((String var, Int val));
-#endif
-
-/*---------------------------------------------------------------------------
- * File operations:
- *-------------------------------------------------------------------------*/
-
-#if HAVE_UNISTD_H
-# include <sys/types.h>
-# include <unistd.h>
-#elif !HUGS_FOR_WINDOWS
-extern int chdir Args((const char*));
-#endif
-
-#if HAVE_STDLIB_H
-# include <stdlib.h>
-#else
-extern int system Args((const char *));
-extern double atof Args((const char *));
-extern void exit Args((int));
-#endif
-
-#ifndef FILENAME_MAX /* should already be defined in an ANSI compiler*/
-#define FILENAME_MAX 256
-#else
-#if FILENAME_MAX < 256
-#undef FILENAME_MAX
-#define FILENAME_MAX 256
-#endif
-#endif
-
-/* Hack, hack: if you have dos.h, you probably have a DOS filesystem */
-#define DOS_FILENAMES HAVE_DOS_H
-/* ToDo: can we replace this with a feature test? */
-#define MAC_FILENAMES SYMANTEC_C
-
-#define CASE_INSENSITIVE_FILENAMES (DOS_FILENAMES | RISCOS)
-
-#if CASE_INSENSITIVE_FILENAMES
-# if HAVE_STRCASECMP
-# define filenamecmp(s1,s2) strcasecmp(s1,s2)
-# elif HAVE__STRICMP
-# define filenamecmp(s1,s2) _stricmp(s1,s2)
-# elif HAVE_STRICMP
-# define filenamecmp(s1,s2) stricmp(s1,s2)
-# elif HAVE_STRCMPI
-# define filenamecmp(s1,s2) strcmpi(s1,s2)
-# endif
-#else
-# define filenamecmp(s1,s2) strcmp(s1,s2)
-#endif
-
-/*---------------------------------------------------------------------------
- * Pipe-related operations:
- *
- * On Windows, many standard Unix names acquire a leading underscore.
- * Irritating, but easy to work around.
- *-------------------------------------------------------------------------*/
-
-#if !defined(HAVE_POPEN) && defined(HAVE__POPEN)
-#define popen(x,y) _popen(x,y)
-#endif
-#if !defined(HAVE_PCLOSE) && defined(HAVE__PCLOSE)
-#define pclose(x) _pclose(x)
-#endif
-
-/*---------------------------------------------------------------------------
- * Bit manipulation:
- *-------------------------------------------------------------------------*/
-
-#define bitArraySize(n) ((n)/bitsPerWord + 1)
-#define placeInSet(n) ((-(n)-1)>>wordShift)
-#define maskInSet(n) (1<<((-(n)-1)&wordMask))
-
-/*---------------------------------------------------------------------------
- * Function prototypes for code in machdep.c
- *-------------------------------------------------------------------------*/
-
-#if RISCOS
-typedef struct { unsigned hi, lo; } Time;
-#define timeChanged(now,thn) (now.hi!=thn.hi || now.lo!=thn.lo)
-#define timeSet(var,tm) var.hi = tm.hi; var.lo = tm.lo
-#else
-typedef time_t Time;
-#define timeChanged(now,thn) (now!=thn)
-#define timeSet(var,tm) var = tm
-#endif
-
-extern Void getFileInfo Args((String, Time *, Long *));
-extern int pathCmp Args((String, String));
-extern String substPath Args((String,String));
-extern Bool startEdit Args((Int,String));
-
-extern String findPathname Args((String,String));
-extern String findMPathname Args((String,String));
-
-extern Int shellEsc Args((String));
-extern Int getTerminalWidth Args((Void));
-extern Void normalTerminal Args((Void));
-extern Void noechoTerminal Args((Void));
-extern Int readTerminalChar Args((Void));
-extern Void gcStarted Args((Void));
-extern Void gcScanning Args((Void));
-extern Void gcRecovered Args((Int));
-extern Void gcCStack Args((Void));
-
-/*-------------------------------------------------------------------------*/
+++ /dev/null
-/* -*- mode: hugs-c; -*- */
-/* --------------------------------------------------------------------------
- * Import-Export processing for Hugs
- *
- * 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
- *
- * $RCSfile: modules.c,v $
- * $Revision: 1.2 $
- * $Date: 1998/12/02 13:22:21 $
- * ------------------------------------------------------------------------*/
-
-#include "prelude.h"
-#include "storage.h"
-#include "static.h"
-#include "errors.h"
-#include "link.h"
-#include "modules.h"
-
-/* --------------------------------------------------------------------------
- * local function prototypes:
- * ------------------------------------------------------------------------*/
-
-static Name local lookupName Args((Text,List));
-static List local checkSubentities Args((List,List,List,String,Text));
-static List local checkExportTycon Args((List,Text,Cell,Tycon));
-static List local checkExportClass Args((List,Text,Cell,Class));
-static List local checkExport Args((List,Text,Cell));
-static List local checkImportEntity Args((List,Module,Cell));
-static List local resolveImportList Args((Module,Cell));
-
-static Void local importName Args((Module,Name));
-static Void local importTycon Args((Module,Tycon));
-static Void local importClass Args((Module,Class));
-
-/* --------------------------------------------------------------------------
- * Static analysis of modules:
- * ------------------------------------------------------------------------*/
-
-Void startModule(nm) /* switch to a new module */
-Cell nm; {
- Module m;
- if (!isCon(nm)) internal("startModule");
- if (isNull(m = findModule(textOf(nm)))) {
- m = newModule(textOf(nm));
- } else if (m != modulePreludeHugs) {
- ERRMSG(0) "Module \"%s\" already loaded", textToStr(textOf(nm))
- EEND;
- }
- setCurrModule(m);
-}
-
-Void setExportList(exps) /* Add export list to current module */
-List exps; {
- module(currentModule).exports = exps;
-}
-
-Void addQualImport(orig,new) /* Add to qualified import list */
-Cell orig; /* Original name of module */
-Cell new; { /* Name module is called within this module (or NIL) */
- module(currentModule).qualImports =
- cons(pair(isNull(new)?orig:new,orig),module(currentModule).qualImports);
-}
-
-Void addUnqualImport(mod,entities) /* Add to unqualified import list */
-Cell mod; /* Name of module */
-List entities; { /* List of entity names */
- unqualImports = cons(pair(mod,entities),unqualImports);
-}
-
-Void checkQualImport(i) /* Process qualified import */
-Pair i; {
- Module m = findModid(snd(i));
- if (isNull(m)) {
- ERRMSG(0) "Module \"%s\" not previously loaded",
- textToStr(textOf(snd(i)))
- EEND;
- }
- snd(i)=m;
-}
-
-Void checkUnqualImport(i) /* Process unqualified import */
-Pair i; {
- Module m = findModid(fst(i));
- if (isNull(m)) {
- ERRMSG(0) "Module \"%s\" not previously loaded",
- textToStr(textOf(fst(i)))
- EEND;
- }
- fst(i)=m;
-}
-
-static Name local lookupName(t,nms) /* find text t in list of Names */
-Text t;
-List nms; { /* :: [Name] */
- for(; nonNull(nms); nms=tl(nms)) {
- if (t == name(hd(nms)).text)
- return hd(nms);
- }
- return NIL;
-}
-
-static List local checkSubentities(imports,named,wanted,description,textParent)
-List imports;
-List named; /* :: [ Q?(Var|Con)(Id|Op) ] */
-List wanted; /* :: [Name] */
-String description; /* "<constructor>|<member> of <type>|<class>" */
-Text textParent; {
- for(; nonNull(named); named=tl(named)) {
- Pair x = hd(named);
- /* ToDo: ignores qualifier; doesn't check that entity is in scope */
- Text t = isPair(snd(x)) ? qtextOf(x) : textOf(x);
- Name n = lookupName(t,wanted);
- if (isNull(n)) {
- ERRMSG(0) "Entity \"%s\" is not a %s \"%s\"",
- textToStr(t),
- description,
- textToStr(textParent)
- EEND;
- }
- imports = cons(n,imports);
- }
- return imports;
-}
-
-static List local checkImportEntity(imports,exporter,entity)
-List imports; /* Accumulated list of things to import */
-Module exporter;
-Cell entity; { /* Entry from import list */
- List oldImports = imports;
- Text t = isIdent(entity) ? textOf(entity) : textOf(fst(entity));
- List es = module(exporter).exports;
- for(; nonNull(es); es=tl(es)) {
- Cell e = hd(es); /* :: Entity | (Entity, NIL|DOTDOT) */
- if (isPair(e)) {
- Cell f = fst(e);
- if (isTycon(f)) {
- if (tycon(f).text == t) {
- imports = cons(f,imports);
- if (!isIdent(entity)) {
- switch (tycon(f).what) {
- case NEWTYPE:
- case DATATYPE:
- if (DOTDOT == snd(entity)) {
- imports=revDupOnto(tycon(f).defn,imports);
- } else {
- imports=checkSubentities(imports,snd(entity),tycon(f).defn,"constructor of type",t);
- }
- break;
- default:;
- /* deliberate fall thru */
- }
- }
- }
- } else if (isClass(f)) {
- if (cclass(f).text == t) {
- imports = cons(f,imports);
- if (!isIdent(entity)) {
- if (DOTDOT == snd(entity)) {
- return revDupOnto(cclass(f).members,imports);
- } else {
- return checkSubentities(imports,snd(entity),cclass(f).members,"member of class",t);
- }
- }
- }
- } else {
- internal("checkImportEntity2");
- }
- } else if (isName(e)) {
- if (isIdent(entity) && name(e).text == t) {
- imports = cons(e,imports);
- }
- } else {
- internal("checkImportEntity3");
- }
- }
- if (imports == oldImports) {
- ERRMSG(0) "Unknown entity \"%s\" imported from module \"%s\"",
- textToStr(t),
- textToStr(module(exporter ).text)
- EEND;
- }
- return imports;
-}
-
-static List local resolveImportList(m,impList)
-Module m; /* exporting module */
-Cell impList; {
- List imports = NIL;
- if (DOTDOT == impList) {
- List es = module(m).exports;
- for(; nonNull(es); es=tl(es)) {
- Cell e = hd(es);
- if (isName(e)) {
- imports = cons(e,imports);
- } else {
- Cell c = fst(e);
- List subentities = NIL;
- imports = cons(c,imports);
- if (isTycon(c)
- && (tycon(c).what == DATATYPE
- || tycon(c).what == NEWTYPE))
- subentities = tycon(c).defn;
- else if (isClass(c))
- subentities = cclass(c).members;
- if (DOTDOT == snd(e)) {
- imports = revDupOnto(subentities,imports);
- }
- }
- }
- } else {
- map1Accum(checkImportEntity,imports,m,impList);
- }
- return imports;
-}
-
-Void checkImportList(thisModule,importSpec) /* Import a module unqualified */
-Module thisModule;
-Pair importSpec; {
- Module m = fst(importSpec);
- Cell impList = snd(importSpec);
-
- List imports = NIL; /* entities we want to import */
- List hidden = NIL; /* entities we want to hide */
-
- if (m == thisModule) {
- ERRMSG(0) "Module \"%s\" recursively imports itself",
- textToStr(module(m).text)
- EEND;
- }
- if (isPair(impList) && HIDDEN == fst(impList)) {
- /* Somewhat inefficient - but obviously correct:
- * imports = importsOf("module Foo") `setDifference` hidden;
- */
- hidden = resolveImportList(m, snd(impList));
- imports = resolveImportList(m, DOTDOT);
- } else {
- imports = resolveImportList(m, impList);
- }
- for(; nonNull(imports); imports=tl(imports)) {
- Cell e = hd(imports);
- if (!cellIsMember(e,hidden))
- importEntity(m,e);
- }
- /* ToDo: hang onto the imports list for processing export list entries
- * of the form "module Foo"
- */
-}
-
-Void importEntity(source,e)
-Module source;
-Cell e; {
- switch (whatIs(e)) {
- case NAME : importName(source,e);
- break;
- case TYCON : importTycon(source,e);
- break;
- case CLASS : importClass(source,e);
- break;
- default: internal("importEntity");
- }
-}
-
-static Void local importName(source,n)
-Module source;
-Name n; {
- Name clash = addName(n);
- if (nonNull(clash) && clash!=n) {
- ERRMSG(0) "Entity \"%s\" imported from module \"%s\" already defined in module \"%s\"",
- textToStr(name(n).text),
- textToStr(module(source).text),
- textToStr(module(name(clash).mod).text)
- EEND;
- }
-}
-
-static Void local importTycon(source,tc)
-Module source;
-Tycon tc; {
- Tycon clash=addTycon(tc);
- if (nonNull(clash) && clash!=tc) {
- ERRMSG(0) "Tycon \"%s\" imported from \"%s\" already defined in module \"%s\"",
- textToStr(tycon(tc).text),
- textToStr(module(source).text),
- textToStr(module(tycon(clash).mod).text)
- EEND;
- }
- if (nonNull(findClass(tycon(tc).text))) {
- ERRMSG(0) "Import of type constructor \"%s\" clashes with class in module \"%s\"",
- textToStr(tycon(tc).text),
- textToStr(module(tycon(tc).mod).text)
- EEND;
- }
-}
-
-static Void local importClass(source,c)
-Module source;
-Class c; {
- Class clash=addClass(c);
- if (nonNull(clash) && clash!=c) {
- ERRMSG(0) "Class \"%s\" imported from \"%s\" already defined in module \"%s\"",
- textToStr(cclass(c).text),
- textToStr(module(source).text),
- textToStr(module(cclass(clash).mod).text)
- EEND;
- }
- if (nonNull(findTycon(cclass(c).text))) {
- ERRMSG(0) "Import of class \"%s\" clashes with type constructor in module \"%s\"",
- textToStr(cclass(c).text),
- textToStr(module(source).text)
- EEND;
- }
-}
-
-static List local checkExportTycon(exports,mt,spec,tc)
-List exports;
-Text mt;
-Cell spec;
-Tycon tc; {
- if (DOTDOT == spec || SYNONYM == tycon(tc).what) {
- return cons(pair(tc,DOTDOT), exports);
- } else {
- return cons(pair(tc,NIL), exports);
- }
-}
-
-static List local checkExportClass(exports,mt,spec,cl)
-List exports;
-Text mt;
-Class cl;
-Cell spec; {
- if (DOTDOT == spec) {
- return cons(pair(cl,DOTDOT), exports);
- } else {
- return cons(pair(cl,NIL), exports);
- }
-}
-
-static List local checkExport(exports,mt,e) /* Process entry in export list*/
-List exports;
-Text mt;
-Cell e; {
- if (isIdent(e)) {
- Cell export = NIL;
- List origExports = exports;
- if (nonNull(export=findQualName(0,e))) {
- exports=cons(export,exports);
- }
- if (isQCon(e) && nonNull(export=findQualTycon(e))) {
- exports = checkExportTycon(exports,mt,NIL,export);
- }
- if (isQCon(e) && nonNull(export=findQualClass(e))) {
- /* opaque class export */
- exports = checkExportClass(exports,mt,NIL,export);
- }
- if (exports == origExports) {
- ERRMSG(0) "Unknown entity \"%s\" exported from module \"%s\"",
- identToStr(e),
- textToStr(mt)
- EEND;
- }
- return exports;
- } else if (MODULEENT == fst(e)) {
- Module m = findModid(snd(e));
- /* ToDo: shouldn't allow export of module we didn't import */
- if (isNull(m)) {
- ERRMSG(0) "Unknown module \"%s\" exported from module \"%s\"",
- textToStr(textOf(snd(e))),
- textToStr(mt)
- EEND;
- }
- if (m == currentModule) {
- /* Exporting the current module exports local definitions */
- List xs;
- for(xs=module(m).classes; nonNull(xs); xs=tl(xs)) {
- if (cclass(hd(xs)).mod==m)
- exports = checkExportClass(exports,mt,DOTDOT,hd(xs));
- }
- for(xs=module(m).tycons; nonNull(xs); xs=tl(xs)) {
- if (tycon(hd(xs)).mod==m)
- exports = checkExportTycon(exports,mt,DOTDOT,hd(xs));
- }
- for(xs=module(m).names; nonNull(xs); xs=tl(xs)) {
- if (name(hd(xs)).mod==m)
- exports = cons(hd(xs),exports);
- }
- } else {
- /* Exporting other modules imports all things imported
- * unqualified from it.
- * ToDo: we reexport everything exported by a module -
- * whether we imported it or not. This gives the wrong
- * result for "module M(module N) where import N(x)"
- */
- exports = revDupOnto(module(m).exports,exports);
- }
- return exports;
- } else {
- Cell ident = fst(e); /* class name or type name */
- Cell parts = snd(e); /* members or constructors */
- Cell nm;
- if (isQCon(ident) && nonNull(nm=findQualTycon(ident))) {
- switch (tycon(nm).what) {
- case SYNONYM:
- if (DOTDOT!=parts) {
- ERRMSG(0) "Explicit constructor list given for type synonym \"%s\" in export list of module \"%s\"",
- identToStr(ident),
- textToStr(mt)
- EEND;
- }
- return cons(pair(nm,DOTDOT),exports);
- case RESTRICTSYN:
- ERRMSG(0) "Transparent export of restricted type synonym \"%s\" in export list of module \"%s\"",
- identToStr(ident),
- textToStr(mt)
- EEND;
- return exports; /* Not reached */
- case NEWTYPE:
- case DATATYPE:
- if (DOTDOT==parts) {
- return cons(pair(nm,DOTDOT),exports);
- } else {
- exports = checkSubentities(exports,parts,tycon(nm).defn,
- "constructor of type",
- tycon(nm).text);
- return cons(pair(nm,DOTDOT), exports);
- }
- default:
- internal("checkExport1");
- }
- } else if (isQCon(ident) && nonNull(nm=findQualClass(ident))) {
- if (DOTDOT == parts) {
- return cons(pair(nm,DOTDOT),exports);
- } else {
- exports = checkSubentities(exports,parts,cclass(nm).members,
- "member of class",cclass(nm).text);
- return cons(pair(nm,DOTDOT), exports);
- }
- } else {
- ERRMSG(0) "Explicit export list given for non-class/datatype \"%s\" in export list of module \"%s\"",
- identToStr(ident),
- textToStr(mt)
- EEND;
- }
- }
-}
-
-List checkExports(thisModule,exports)
-Module thisModule;
-List exports; {
- Text mt = module(thisModule).text;
- List es = NIL;
-
- map1Accum(checkExport,es,mt,exports);
-
-#if DEBUG_MODULES
- for(xs=es; nonNull(xs); xs=tl(xs)) {
- printf(" %s", textToStr(textOfEntity(hd(xs))));
- }
-#endif
- return es;
-}
-
-/*-------------------------------------------------------------------------*/
-
+++ /dev/null
-/* -*- mode: hugs-c; -*- */
-Void checkQualImport Args((Pair));
-Void checkUnqualImport Args((Triple));
-Void checkImportList Args((Module,Pair));
-List checkExports Args((Module,List));
-
-Void importEntity Args((Module,Cell));
-
-
+++ /dev/null
-/* -*- mode: hugs-c; -*- */
-extern Void optimiseBind Args((StgVar));
+++ /dev/null
-extern Void printExp Args((FILE *,Cell));
-extern Void printType Args((FILE *,Cell));
-extern Void printContext Args((FILE *,List));
-extern Void printPred Args((FILE *,Cell));
-extern Void printKind Args((FILE *,Kind));
-extern Void printKinds Args((FILE *,Kinds));
-
+++ /dev/null
-/* -*- mode: hugs-c; -*- */
-/* --------------------------------------------------------------------------
- * Desugarer
- *
- * 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
- *
- * $RCSfile: pat.c,v $
- * $Revision: 1.2 $
- * $Date: 1998/12/02 13:22:28 $
- * ------------------------------------------------------------------------*/
-
-#include "prelude.h"
-#include "storage.h"
-#include "connect.h"
-#include "errors.h"
-#include "link.h"
-
-#include "pat.h"
-#include "desugar.h"
-
-/* --------------------------------------------------------------------------
- * Local function prototypes:
- * ------------------------------------------------------------------------*/
-
-static Cell local refutePat Args((Cell));
-static Cell local refutePatAp Args((Cell));
-static Cell local matchPat Args((Cell));
-static List local remPat1 Args((Cell,Cell,List));
-
-/* --------------------------------------------------------------------------
- * Elimination of pattern bindings:
- *
- * The following code adopts the definition of failure free patterns as given
- * in the Haskell 1.3 report; the term "irrefutable" is also used there for
- * a subset of the failure free patterns described here, but has no useful
- * role in this implementation. Basically speaking, the failure free patterns
- * are: variable, wildcard, ~apat
- * var@apat, if apat is failure free
- * C apat1 ... apatn if C is a product constructor
- * (i.e. an only constructor) and
- * apat1,...,apatn are failure free
- * Note that the last case automatically covers the case where C comes from
- * a newtype construction.
- * ------------------------------------------------------------------------*/
-
-Bool failFree(pat) /* is pattern failure free? (do we need */
-Cell pat; { /* a conformality check?) */
- Cell c = getHead(pat);
-
- switch (whatIs(c)) {
- case ASPAT : return failFree(snd(snd(pat)));
-
- case NAME : if (!isCfun(c) || cfunOf(c)!=0)
- return FALSE;
- /*intentional fall-thru*/
- case TUPLE : for (; isAp(pat); pat=fun(pat))
- if (!failFree(arg(pat)))
- return FALSE;
- /*intentional fall-thru*/
- case LAZYPAT :
- case VAROPCELL :
- case VARIDCELL :
- case DICTVAR :
- case WILDCARD : return TRUE;
-
-#if TREX
- case EXT : return failFree(extField(pat)) &&
- failFree(extRow(pat));
-#endif
-
- case CONFLDS : if (cfunOf(fst(snd(c)))==0) {
- List fs = snd(snd(c));
- for (; nonNull(fs); fs=tl(fs))
- if (!failFree(snd(hd(fs))))
- return FALSE;
- return TRUE;
- }
- /*intentional fall-thru*/
- default : return FALSE;
- }
-}
-
-static Cell local refutePat(pat) /* find pattern to refute in conformality*/
-Cell pat; { /* test with pat. */
- /* e.g. refPat (x:y) == (_:_) */
- /* refPat ~(x:y) == _ etc.. */
-
- switch (whatIs(pat)) {
- case ASPAT : return refutePat(snd(snd(pat)));
-
- case FINLIST : { Cell ys = snd(pat);
- Cell xs = NIL;
- for (; nonNull(ys); ys=tl(ys)) {
- xs = ap2(nameCons,refutePat(hd(ys)),xs);
- }
- return revOnto(xs,nameNil);
- }
-
- case CONFLDS : { Cell ps = NIL;
- Cell fs = snd(snd(pat));
- for (; nonNull(fs); fs=tl(fs)) {
- Cell p = refutePat(snd(hd(fs)));
- ps = cons(pair(fst(hd(fs)),p),ps);
- }
- return pair(CONFLDS,pair(fst(snd(pat)),rev(ps)));
- }
-
- case VAROPCELL :
- case VARIDCELL :
- case DICTVAR :
- case WILDCARD :
- case LAZYPAT : return WILDCARD;
-
- case STRCELL :
- case CHARCELL :
-#if NPLUSK
- case ADDPAT :
-#endif
- case TUPLE :
- case NAME : return pat;
-
- case AP : return refutePatAp(pat);
-
- default : internal("refutePat");
- return NIL; /*NOTREACHED*/
- }
-}
-
-static Cell local refutePatAp(p) /* find pattern to refute in conformality*/
-Cell p; {
- Cell h = getHead(p);
- if (h==nameFromInt || h==nameFromInteger || h==nameFromDouble)
- return p;
-#if NPLUSK
- else if (whatIs(h)==ADDPAT)
- return ap(fun(p),refutePat(arg(p)));
-#endif
-#if TREX
- else if (isExt(h)) {
- Cell pf = refutePat(extField(p));
- Cell pr = refutePat(extRow(p));
- return ap2(fun(fun(p)),pf,pr);
- }
-#endif
- else {
- List as = getArgs(p);
- mapOver(refutePat,as);
- return applyToArgs(h,as);
- }
-}
-
-static Cell local matchPat(pat) /* find pattern to match against */
-Cell pat; { /* replaces parts of pattern that do not */
- /* include variables with wildcards */
- switch (whatIs(pat)) {
- case ASPAT : { Cell p = matchPat(snd(snd(pat)));
- return (p==WILDCARD) ? fst(snd(pat))
- : ap(ASPAT,
- pair(fst(snd(pat)),p));
- }
-
- case FINLIST : { Cell ys = snd(pat);
- Cell xs = NIL;
- for (; nonNull(ys); ys=tl(ys))
- xs = cons(matchPat(hd(ys)),xs);
- while (nonNull(xs) && hd(xs)==WILDCARD)
- xs = tl(xs);
- for (ys=nameNil; nonNull(xs); xs=tl(xs))
- ys = ap2(nameCons,hd(xs),ys);
- return ys;
- }
-
- case CONFLDS : { Cell ps = NIL;
- Name c = fst(snd(pat));
- Cell fs = snd(snd(pat));
- Bool avar = FALSE;
- for (; nonNull(fs); fs=tl(fs)) {
- Cell p = matchPat(snd(hd(fs)));
- ps = cons(pair(fst(hd(fs)),p),ps);
- if (p!=WILDCARD)
- avar = TRUE;
- }
- return avar ? pair(CONFLDS,pair(c,rev(ps)))
- : WILDCARD;
- }
-
- case VAROPCELL :
- case VARIDCELL :
- case DICTVAR : return pat;
-
- case LAZYPAT : { Cell p = matchPat(snd(pat));
- return (p==WILDCARD) ? WILDCARD : ap(LAZYPAT,p);
- }
-
- case WILDCARD :
- case STRCELL :
- case CHARCELL : return WILDCARD;
-
- case TUPLE :
- case NAME :
- case AP : { Cell h = getHead(pat);
- if (h==nameFromInt ||
- h==nameFromInteger || h==nameFromDouble)
- return WILDCARD;
-#if NPLUSK
- else if (whatIs(h)==ADDPAT)
- return pat;
-#endif
-#if TREX
- else if (isExt(h)) {
- Cell pf = matchPat(extField(pat));
- Cell pr = matchPat(extRow(pat));
- return (pf==WILDCARD && pr==WILDCARD)
- ? WILDCARD
- : ap2(fun(fun(pat)),pf,pr);
- }
-#endif
- else {
- List args = NIL;
- Bool avar = FALSE;
- for (; isAp(pat); pat=fun(pat)) {
- Cell p = matchPat(arg(pat));
- if (p!=WILDCARD)
- avar = TRUE;
- args = cons(p,args);
- }
- return avar ? applyToArgs(pat,args)
- : WILDCARD;
- }
- }
-
- default : internal("matchPat");
- return NIL; /*NOTREACHED*/
- }
-}
-
-#define addEqn(v,val,lds) cons(pair(v,singleton(pair(NIL,val))),lds)
-
-List remPat(pat,expr,lds)
-Cell pat; /* Produce list of definitions for eqn */
-Cell expr; /* pat = expr, including a conformality */
-List lds; { /* check if required. */
-
- /* Conformality test (if required):
- * pat = expr ==> nv = LETREC confCheck nv@pat = nv
- * IN confCheck expr
- * remPat1(pat,nv,.....);
- */
-
- if (!failFree(pat)) {
- Cell confVar = inventVar();
- Cell nv = inventVar();
- Cell locfun = pair(confVar, /* confVar [([nv@refPat],nv)] */
- singleton(pair(singleton(ap(ASPAT,
- pair(nv,
- refutePat(pat)))),
- nv)));
-
- if (whatIs(expr)==GUARDED) { /* A spanner ... special case */
- lds = addEqn(nv,expr,lds); /* for guarded pattern binding*/
- expr = nv;
- nv = inventVar();
- }
-
- if (whatIs(pat)==ASPAT) { /* avoid using new variable if*/
- nv = fst(snd(pat)); /* a variable is already given*/
- pat = snd(snd(pat)); /* by an as-pattern */
- }
-
- lds = addEqn(nv, /* nv = */
- ap(LETREC,pair(singleton(locfun), /* LETREC [locfun] */
- ap(confVar,expr))), /* IN confVar expr */
- lds);
-
- return remPat1(matchPat(pat),nv,lds);
- }
-
- return remPat1(matchPat(pat),expr,lds);
-}
-
-static List local remPat1(pat,expr,lds)
-Cell pat; /* Add definitions for: pat = expr to */
-Cell expr; /* list of local definitions in lds. */
-List lds; {
- Cell c;
-
- switch (whatIs(c=getHead(pat))) {
- case WILDCARD :
- case STRCELL :
- case CHARCELL : break;
-
- case ASPAT : return remPat1(snd(snd(pat)), /* v@pat = expr */
- fst(snd(pat)),
- addEqn(fst(snd(pat)),expr,lds));
-
- case LAZYPAT : { Cell nv;
-
- if (isVar(expr) || isName(expr))
- nv = expr;
- else {
- nv = inventVar();
- lds = addEqn(nv,expr,lds);
- }
-
- return remPat(snd(pat),nv,lds);
- }
-
-#if NPLUSK
- case ADDPAT : return remPat1(arg(pat), /* n + k = expr */
- ap3(namePmSub, arg(fun(pat)), snd(c),
- expr),
- lds);
-#endif
-
- case FINLIST : return remPat1(mkConsList(snd(pat)),expr,lds);
-
- case CONFLDS : { Name h = fst(snd(pat));
- Int m = name(h).arity;
- Cell p = h;
- List fs = snd(snd(pat));
- Int i = m;
- while (0<i--)
- p = ap(p,WILDCARD);
- for (; nonNull(fs); fs=tl(fs)) {
- Cell r = p;
- for (i=m-sfunPos(fst(hd(fs)),h); i>0; i--)
- r = fun(r);
- arg(r) = snd(hd(fs));
- }
- return remPat1(p,expr,lds);
- }
-
- case DICTVAR : /* shouldn't really occur */
- assert(0); /* so let's test for it then! ADR */
- case VARIDCELL :
- case VAROPCELL : return addEqn(pat,expr,lds);
-
- case NAME : if (c==nameFromInt || c==nameFromInteger
- || c==nameFromDouble) {
- if (argCount==2)
- arg(fun(pat)) = translate(arg(fun(pat)));
- break;
- }
-
- if (argCount==1 && isCfun(c) /* for newtype */
- && cfunOf(c)==0 && name(c).defn==nameId)
- return remPat1(arg(pat),expr,lds);
-
- /* intentional fall-thru */
- case TUPLE : { List ps = getArgs(pat);
-
- if (nonNull(ps)) {
- Cell nv, sel;
- Int i;
-
- if (isVar(expr) || isName(expr))
- nv = expr;
- else {
- nv = inventVar();
- lds = addEqn(nv,expr,lds);
- }
-
- sel = ap2(nameSel,c,nv);
- for (i=1; nonNull(ps); ++i, ps=tl(ps))
- lds = remPat1(hd(ps),
- ap(sel,mkInt(i)),
- lds);
- }
- }
- break;
-
-#if TREX
- case EXT : { Cell nv = inventVar();
- arg(fun(fun(pat)))
- = translate(arg(fun(fun(pat))));
- lds = addEqn(nv,
- ap2(nameRecBrk,
- arg(fun(fun(pat))),
- expr),
- lds);
- lds = remPat1(extField(pat),ap(nameFst,nv),lds);
- lds = remPat1(extRow(pat),ap(nameSnd,nv),lds);
- }
- break;
-#endif
-
- default : internal("remPat1");
- break;
- }
- return lds;
-}
-
-/* --------------------------------------------------------------------------
- * Pattern control:
- * ------------------------------------------------------------------------*/
-
-Void patControl( Int what )
-{
- switch (what) {
- case INSTALL :
- /* Fall through */
- case RESET : break;
- case MARK : break;
- }
-}
-
-/*-------------------------------------------------------------------------*/
+++ /dev/null
-/* -*- mode: hugs-c; -*- */
-extern Void patControl Args((Int what));
-extern List remPat Args((Cell,Cell,List));
-extern Cell mkConsList Args((List));
-extern Bool failFree Args((Cell));
+++ /dev/null
-/* -*- mode: hugs-c; -*- */
-/* --------------------------------------------------------------------------
- * Pattern matching Compiler
- *
- * 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
- *
- * $RCSfile: pmc.c,v $
- * $Revision: 1.2 $
- * $Date: 1998/12/02 13:22:29 $
- * ------------------------------------------------------------------------*/
-
-#include "prelude.h"
-#include "storage.h"
-#include "connect.h"
-#include "errors.h"
-#include "link.h"
-
-#include "desugar.h"
-#include "pat.h"
-#include "pmc.h"
-
-/* --------------------------------------------------------------------------
- * Eliminate pattern matching in function definitions -- pattern matching
- * compiler:
- *
- * The original Gofer/Hugs pattern matching compiler was based on Wadler's
- * algorithms described in `Implementation of functional programming
- * languages'. That should still provide a good starting point for anyone
- * wanting to understand this part of the system. However, the original
- * algorithm has been generalized and restructured in order to implement
- * new features added in Haskell 1.3.
- *
- * During the translation, in preparation for later stages of compilation,
- * all local and bound variables are replaced by suitable offsets, and
- * locally defined function symbols are given new names (which will
- * eventually be their names when lifted to make top level definitions).
- * ------------------------------------------------------------------------*/
-
-/* --------------------------------------------------------------------------
- * Local function prototypes:
- * ------------------------------------------------------------------------*/
-
-static Cell local pmcPair Args((Int,List,Pair));
-static Cell local pmcTriple Args((Int,List,Triple));
-static Cell local pmcVar Args((List,Text));
-static Void local pmcLetrec Args((Int,List,Pair));
-static Cell local pmcVarDef Args((Int,List,List));
-static Void local pmcFunDef Args((Int,List,Triple));
-static Cell local joinMas Args((Int,List));
-static Bool local canFail Args((Cell));
-static List local addConTable Args((Cell,Cell,List));
-static Void local advance Args((Int,Int,Cell));
-static Bool local emptyMatch Args((Cell));
-static Cell local maDiscr Args((Cell));
-static Bool local isNumDiscr Args((Cell));
-static Bool local eqNumDiscr Args((Cell,Cell));
-#if TREX
-static Bool local isExtDiscr Args((Cell));
-static Bool local eqExtDiscr Args((Cell,Cell));
-#endif
-
-/* --------------------------------------------------------------------------
- *
- * ------------------------------------------------------------------------*/
-
-Cell pmcTerm(co,sc,e) /* apply pattern matching compiler */
-Int co; /* co = current offset */
-List sc; /* sc = scope */
-Cell e; { /* e = expr to transform */
- switch (whatIs(e)) {
- case GUARDED : map2Over(pmcPair,co,sc,snd(e));
- break;
-
- case LETREC : pmcLetrec(co,sc,snd(e));
- break;
-
- case VARIDCELL:
- case VAROPCELL:
- case DICTVAR : return pmcVar(sc,textOf(e));
-
- case COND : return ap(COND,pmcTriple(co,sc,snd(e)));
-
- case AP : return pmcPair(co,sc,e);
-
-#if NPLUSK
- case ADDPAT :
-#endif
-#if TREX
- case EXT :
-#endif
- case TUPLE :
- case NAME :
- case CHARCELL :
- case INTCELL :
- case BIGCELL :
- case FLOATCELL:
- case STRCELL : break;
-
- default : internal("pmcTerm");
- break;
- }
- return e;
-}
-
-static Cell local pmcPair(co,sc,pr) /* apply pattern matching compiler */
-Int co; /* to a pair of exprs */
-List sc;
-Pair pr; {
- return pair(pmcTerm(co,sc,fst(pr)),
- pmcTerm(co,sc,snd(pr)));
-}
-
-static Cell local pmcTriple(co,sc,tr) /* apply pattern matching compiler */
-Int co; /* to a triple of exprs */
-List sc;
-Triple tr; {
- return triple(pmcTerm(co,sc,fst3(tr)),
- pmcTerm(co,sc,snd3(tr)),
- pmcTerm(co,sc,thd3(tr)));
-}
-
-static Cell local pmcVar(sc,t) /* find translation of variable */
-List sc; /* in current scope */
-Text t; {
- List xs;
- Name n;
-
- for (xs=sc; nonNull(xs); xs=tl(xs)) {
- Cell x = hd(xs);
- if (t==textOf(fst(x)))
- if (isOffset(snd(x))) { /* local variable ... */
- return snd(x);
- }
- else { /* local function ... */
- return fst3(snd(x));
- }
- }
-
- n = findName(t);
- assert(nonNull(n));
- return n;
-}
-
-static Void local pmcLetrec(co,sc,e) /* apply pattern matching compiler */
-Int co; /* to LETREC, splitting decls into */
-List sc; /* two sections */
-Pair e; {
- List fs = NIL; /* local function definitions */
- List vs = NIL; /* local variable definitions */
- List ds;
-
- for (ds=fst(e); nonNull(ds); ds=tl(ds)) { /* Split decls into two */
- Cell v = fst(hd(ds));
- Int arity = length(fst(hd(snd(hd(ds)))));
-
- if (arity==0) { /* Variable declaration */
- vs = cons(snd(hd(ds)),vs);
- sc = cons(pair(v,mkOffset(++co)),sc);
- }
- else { /* Function declaration */
- fs = cons(triple(inventVar(),mkInt(arity),snd(hd(ds))),fs);
- sc = cons(pair(v,hd(fs)),sc);
- }
- }
- vs = rev(vs); /* Put declaration lists back in */
- fs = rev(fs); /* original order */
- fst(e) = pair(vs,fs); /* Store declaration lists */
- map2Over(pmcVarDef,co,sc,vs); /* Translate variable definitions */
- map2Proc(pmcFunDef,co,sc,fs); /* Translate function definitions */
- snd(e) = pmcTerm(co,sc,snd(e)); /* Translate LETREC body */
-}
-
-static Cell local pmcVarDef(co,sc,vd) /* apply pattern matching compiler */
-Int co; /* to variable definition */
-List sc;
-List vd; { /* vd :: [ ([], rhs) ] */
- Cell d = snd(hd(vd));
- if (nonNull(tl(vd)) && canFail(d))
- return ap(FATBAR,pair(pmcTerm(co,sc,d),
- pmcVarDef(co,sc,tl(vd))));
- return pmcTerm(co,sc,d);
-}
-
-static Void local pmcFunDef(co,sc,fd) /* apply pattern matching compiler */
-Int co; /* to function definition */
-List sc;
-Triple fd; { /* fd :: (Var, Arity, [Alt]) */
- Int arity = intOf(snd3(fd));
- Cell temp = altsMatch(co+1,arity,sc,thd3(fd));
- Cell xs;
-
- temp = match(co+arity,temp);
- thd3(fd) = triple(NIL,NIL,temp); /* used to be freevar info */
-
-}
-
-/* ---------------------------------------------------------------------------
- * Main part of pattern matching compiler: convert [Alt] to case constructs
- *
- * This section of Hugs has been almost completely rewritten to be more
- * general, in particular, to allow pattern matching in orders other than the
- * strictly left-to-right approach of the previous version. This is needed
- * for the implementation of the so-called Haskell 1.3 `record' syntax.
- *
- * At each stage, the different branches for the cases to be considered
- * are represented by a list of values of type:
- * Match ::= { maPats :: [Pat], patterns to match
- * maOffs :: [Offs], offsets of corresponding values
- * maSc :: Scope, mapping from vars to offsets
- * maRhs :: Rhs } right hand side
- * [Implementation uses nested pairs, ((pats,offs),(sc,rhs)).]
- *
- * The Scope component has type:
- * Scope ::= [(Var,Expr)]
- * and provides a mapping from variable names to offsets used in the matching
- * process.
- *
- * Matches can be normalized by reducing them to a form in which the list
- * of patterns is empty (in which case the match itself is described as an
- * empty match), or in which the list is non-empty and the first pattern is
- * one that requires either a CASE or NUMCASE (or EXTCASE) to decompose.
- * ------------------------------------------------------------------------*/
-
-#define mkMatch(ps,os,sc,r) pair(pair(ps,os),pair(sc,r))
-#define maPats(ma) fst(fst(ma))
-#define maOffs(ma) snd(fst(ma))
-#define maSc(ma) fst(snd(ma))
-#define maRhs(ma) snd(snd(ma))
-#define extSc(v,o,ma) maSc(ma) = cons(pair(v,o),maSc(ma))
-
-List altsMatch(co,n,sc,as) /* Make a list of matches from list*/
-Int co; /* of Alts, with initial offsets */
-Int n; /* reverse (take n [co..]) */
-List sc;
-List as; {
- List mas = NIL;
- List us = NIL;
- for (; n>0; n--)
- us = cons(mkOffset(co++),us);
- for (; nonNull(as); as=tl(as)) /* Each Alt is ([Pat], Rhs) */
- mas = cons(mkMatch(fst(hd(as)),us,sc,snd(hd(as))),mas);
- return rev(mas);
-}
-
-Cell match(co,mas) /* Generate case statement for Matches mas */
-Int co; /* at current offset co */
-List mas; { /* N.B. Assumes nonNull(mas). */
- Cell srhs = NIL; /* Rhs for selected matches */
- List smas = mas; /* List of selected matches */
- mas = tl(mas);
- tl(smas) = NIL;
-
- if (emptyMatch(hd(smas))) { /* The case for empty matches: */
- while (nonNull(mas) && emptyMatch(hd(mas))) {
- List temp = tl(mas);
- tl(mas) = smas;
- smas = mas;
- mas = temp;
- }
- srhs = joinMas(co,rev(smas));
- }
- else { /* Non-empty match */
- Int o = offsetOf(hd(maOffs(hd(smas))));
- Cell d = maDiscr(hd(smas));
- if (isNumDiscr(d)) { /* Numeric match */
- Int da = discrArity(d);
- Cell d1 = pmcTerm(co,maSc(hd(smas)),d);
- while (nonNull(mas) && !emptyMatch(hd(mas))
- && o==offsetOf(hd(maOffs(hd(mas))))
- && isNumDiscr(d=maDiscr(hd(mas)))
- && eqNumDiscr(d,d1)) {
- List temp = tl(mas);
- tl(mas) = smas;
- smas = mas;
- mas = temp;
- }
- smas = rev(smas);
- map2Proc(advance,co,da,smas);
- srhs = ap(NUMCASE,triple(mkOffset(o),d1,match(co+da,smas)));
- }
-#if TREX
- else if (isExtDiscr(d)) { /* Record match */
- Int da = discrArity(d);
- Cell d1 = pmcTerm(co,maSc(hd(smas)),d);
- while (nonNull(mas) && !emptyMatch(hd(mas))
- && o==offsetOf(hd(maOffs(hd(mas))))
- && isExtDiscr(d=maDiscr(hd(mas)))
- && eqExtDiscr(d,d1)) {
- List temp = tl(mas);
- tl(mas) = smas;
- smas = mas;
- mas = temp;
- }
- smas = rev(smas);
- map2Proc(advance,co,da,smas);
- srhs = ap(EXTCASE,triple(mkOffset(o),d1,match(co+da,smas)));
- }
-#endif
- else { /* Constructor match */
- List tab = addConTable(d,hd(smas),NIL);
- Int da;
- while (nonNull(mas) && !emptyMatch(hd(mas))
- && o==offsetOf(hd(maOffs(hd(mas))))
- && !isNumDiscr(d=maDiscr(hd(mas)))) {
- tab = addConTable(d,hd(mas),tab);
- mas = tl(mas);
- }
- for (tab=rev(tab); nonNull(tab); tab=tl(tab)) {
- d = fst(hd(tab));
- smas = snd(hd(tab));
- da = discrArity(d);
- map2Proc(advance,co,da,smas);
- srhs = cons(pair(d,match(co+da,smas)),srhs);
- }
- srhs = ap(CASE,pair(mkOffset(o),srhs));
- }
- }
- return nonNull(mas) ? ap(FATBAR,pair(srhs,match(co,mas))) : srhs;
-}
-
-static Cell local joinMas(co,mas) /* Combine list of matches into rhs*/
-Int co; /* using FATBARs as necessary */
-List mas; { /* Non-empty list of empty matches */
- Cell ma = hd(mas);
- Cell rhs = pmcTerm(co,maSc(ma),maRhs(ma));
- if (nonNull(tl(mas)) && canFail(rhs))
- return ap(FATBAR,pair(rhs,joinMas(co,tl(mas))));
- else
- return rhs;
-}
-
-static Bool local canFail(rhs) /* Determine if expression (as rhs) */
-Cell rhs; { /* might ever be able to fail */
- switch (whatIs(rhs)) {
- case LETREC : return canFail(snd(snd(rhs)));
- case GUARDED : return TRUE; /* could get more sophisticated ..? */
- default : return FALSE;
- }
-}
-
-/* type Table a b = [(a, [b])]
- *
- * addTable :: a -> b -> Table a b -> Table a b
- * addTable x y [] = [(x,[y])]
- * addTable x y (z@(n,sws):zs)
- * | n == x = (n,sws++[y]):zs
- * | otherwise = (n,sws):addTable x y zs
- */
-
-static List local addConTable(x,y,tab) /* add element (x,y) to table */
-Cell x, y;
-List tab; {
- if (isNull(tab))
- return singleton(pair(x,singleton(y)));
- else if (fst(hd(tab))==x)
- snd(hd(tab)) = appendOnto(snd(hd(tab)),singleton(y));
- else
- tl(tab) = addConTable(x,y,tl(tab));
-
- return tab;
-}
-
-static Void local advance(co,a,ma) /* Advance non-empty match by */
-Int co; /* processing head pattern */
-Int a; /* discriminator arity */
-Cell ma; {
- Cell p = hd(maPats(ma));
- List ps = tl(maPats(ma));
- List us = tl(maOffs(ma));
- if (whatIs(p)==CONFLDS) { /* Special case for record syntax */
- Name c = fst(snd(p));
- List fs = snd(snd(p));
- List qs = NIL;
- List vs = NIL;
- for (; nonNull(fs); fs=tl(fs)) {
- vs = cons(mkOffset(co+a+1-sfunPos(fst(hd(fs)),c)),vs);
- qs = cons(snd(hd(fs)),qs);
- }
- ps = revOnto(qs,ps);
- us = revOnto(vs,us);
- }
- else /* Normally just spool off patterns*/
- for (; a>0; --a) { /* and corresponding offsets ... */
- us = cons(mkOffset(++co),us);
- ps = cons(arg(p),ps);
- p = fun(p);
- }
-
- maPats(ma) = ps;
- maOffs(ma) = us;
-}
-
-/* --------------------------------------------------------------------------
- * Normalize and test for empty match:
- * ------------------------------------------------------------------------*/
-
-static Bool local emptyMatch(ma)/* Normalize and test to see if a given */
-Cell ma; { /* match, ma, is empty. */
-
- while (nonNull(maPats(ma))) {
- Cell p;
-tidyHd: switch (whatIs(p=hd(maPats(ma)))) {
- case LAZYPAT : { Cell nv = inventVar();
- maRhs(ma) = ap(LETREC,
- pair(remPat(snd(p),nv,NIL),
- maRhs(ma)));
- p = nv;
- }
- /* intentional fall-thru */
- case VARIDCELL :
- case VAROPCELL :
- case DICTVAR : extSc(p,hd(maOffs(ma)),ma);
- case WILDCARD : maPats(ma) = tl(maPats(ma));
- maOffs(ma) = tl(maOffs(ma));
- continue;
-
- /* So-called "as-patterns"are really just pattern intersections:
- * (p1@p2:ps, o:os, sc, e) ==> (p1:p2:ps, o:o:os, sc, e)
- * (But the input grammar probably doesn't let us take
- * advantage of this, so we stick with the special case
- * when p1 is a variable.)
- */
- case ASPAT : extSc(fst(snd(p)),hd(maOffs(ma)),ma);
- hd(maPats(ma)) = snd(snd(p));
- goto tidyHd;
-
- case FINLIST : hd(maPats(ma)) = mkConsList(snd(p));
- return FALSE;
-
- case STRCELL : { String s = textToStr(textOf(p));
- for (p=NIL; *s!='\0'; ++s) {
- if (*s!='\\' || *++s=='\\') {
- p = ap2(nameCons,mkChar(*s),p);
- } else {
- p = ap2(nameCons,mkChar('\0'),p);
- }
- }
- hd(maPats(ma)) = revOnto(p,nameNil);
- }
- return FALSE;
-
- case AP : if (isName(fun(p)) && isCfun(fun(p))
- && cfunOf(fun(p))==0
- && name(fun(p)).defn==nameId) {
- hd(maPats(ma)) = arg(p);
- goto tidyHd;
- }
- /* intentional fall-thru */
- case CHARCELL :
-#if !OVERLOADED_CONSTANTS
- case INTCELL :
- case BIGCELL :
- case FLOATCELL :
-#endif
- case NAME :
- case CONFLDS :
- return FALSE;
-
- default : internal("emptyMatch");
- }
- }
- return TRUE;
-}
-
-/* --------------------------------------------------------------------------
- * Discriminators:
- * ------------------------------------------------------------------------*/
-
-static Cell local maDiscr(ma) /* Get the discriminator for a non-empty */
-Cell ma; { /* match, ma. */
- Cell p = hd(maPats(ma));
- Cell h = getHead(p);
- switch (whatIs(h)) {
- case CONFLDS : return fst(snd(p));
-#if NPLUSK
- case ADDPAT : arg(fun(p)) = translate(arg(fun(p)));
- return fun(p);
-#endif
-#if TREX
- case EXT : h = fun(fun(p));
- arg(h) = translate(arg(h));
- return h;
-#endif
-#if OVERLOADED_CONSTANTS
- case NAME : if (h==nameFromInt || h==nameFromInteger
- || h==nameFromDouble) {
- if (argCount==2)
- arg(fun(p)) = translate(arg(fun(p)));
- return p;
- }
-#endif
- }
- return h;
-}
-
-static Bool local isNumDiscr(d) /* TRUE => numeric discriminator */
-Cell d; {
- switch (whatIs(d)) {
- case NAME :
- case TUPLE :
- case CHARCELL : return FALSE;
-#if OVERLOADED_CONSTANTS
-#if TREX
- case AP : return !isExt(fun(d));
-#else
- case AP : return TRUE; /* must be a literal or (n+k) */
-#endif
-#else
- case INTCELL :
- case BIGCELL :
- case FLOATCELL:
- return TRUE;
-#endif
- }
- internal("isNumDiscr");
- return 0;/*NOTREACHED*/
-}
-
-Int discrArity(d) /* Find arity of discriminator */
-Cell d; {
- switch (whatIs(d)) {
- case NAME : return name(d).arity;
- case TUPLE : return tupleOf(d);
- case CHARCELL : return 0;
-#if !OVERLOADED_CONSTANTS
- case INTCELL :
- case BIGCELL :
- case FLOATCELL : return 0;
-#endif /* !OVERLOADED_CONSTANTS */
-
-#if TREX
- case AP : switch (whatIs(fun(d))) {
-#if NPLUSK
- case ADDPAT : return 1;
-#endif
- case EXT : return 2;
- default : return 0;
- }
-#else
-#if NPLUSK
- case AP : return (whatIs(fun(d))==ADDPAT) ? 1 : 0;
-#else
- case AP : return 0; /* must be an Int or Float lit */
-#endif
-#endif
- }
- internal("discrArity");
- return 0;/*NOTREACHED*/
-}
-
-static Bool local eqNumDiscr(d1,d2) /* Determine whether two numeric */
-Cell d1, d2; { /* descriptors have same value */
-#if NPLUSK
- if (whatIs(fun(d1))==ADDPAT)
- return whatIs(fun(d2))==ADDPAT && bignumEq(snd(fun(d1)),snd(fun(d2)));
-#endif
-#if OVERLOADED_CONSTANTS
- d1 = arg(d1);
- d2 = arg(d2);
-#endif
- if (isInt(d1))
- return isInt(d2) && intEq(d1,d2);
- if (isFloat(d1))
- return isFloat(d2) && floatEq(d1,d2);
- if (isBignum(d1))
- return isBignum(d2) && bignumEq(d1,d2);
- internal("eqNumDiscr");
- return FALSE;/*NOTREACHED*/
-}
-
-#if TREX
-static Bool local isExtDiscr(d) /* Test of extension discriminator */
-Cell d; {
- return isAp(d) && isExt(fun(d));
-}
-
-static Bool local eqExtDiscr(d1,d2) /* Determine whether two extension */
-Cell d1, d2; { /* discriminators have same label */
- return fun(d1)==fun(d2);
-}
-#endif
-
-/*-------------------------------------------------------------------------*/
+++ /dev/null
-/* -*- mode: hugs-c; -*- */
-extern Cell pmcTerm Args((Int,List,Cell));
-extern List altsMatch Args((Int,Int,List,List));
-extern Cell match Args((Int,List));
-extern Int discrArity Args((Cell));
-
+++ /dev/null
-/* -*- mode: hugs-c; -*- */
-/* --------------------------------------------------------------------------
- * Pretty printer for stg code:
- * ------------------------------------------------------------------------*/
-
-Void printStg( FILE *fp, StgVar b);
-
-#if DEBUG_PRINTER
-extern Void ppStg ( StgVar v );
-extern Void ppStgExpr ( StgExpr e );
-extern Void ppStgRhs ( StgRhs rhs );
-extern Void ppStgAlts ( List alts );
-extern Void ppStgPrimAlts( List alts );
-extern Void ppStgVars ( List vs );
-#endif
-
+++ /dev/null
-extern List unqualImports; /* unqualified import list */
-
-#if DERIVE_SHOW | DERIVE_READ
-extern List cfunSfuns;
-#endif
-extern Void startModule Args((Cell));
-extern Void setExportList Args((List));
-extern Void setExports Args((List));
-extern Void addQualImport Args((Text,Text));
-extern Void addUnqualImport Args((Text,List));
-extern Void tyconDefn Args((Int,Cell,Cell,Cell));
-extern Void setTypeIns Args((List));
-extern Void clearTypeIns Args((Void));
-extern Type fullExpand Args((Type));
-extern Bool isAmbiguous Args((Type));
-extern Void ambigError Args((Int,String,Cell,Type));
-extern Void classDefn Args((Int,Cell,Cell));
-extern Void instDefn Args((Int,Cell,Cell));
-extern Void addTupInst Args((Class,Int));
-#if TREX
-extern Inst addRecShowInst Args((Class,Ext));
-extern Inst addRecEqInst Args((Class,Ext));
-#endif
-extern Void addEvalInst Args((Int,Cell,Int,List));
-extern Void foreignImport Args((Cell,Pair,Cell,Cell));
-extern Void foreignExport Args((Cell,Cell,Cell,Cell));
-extern Void defaultDefn Args((Int,List));
-extern Void checkExp Args((Void));
-extern Void checkDefns Args((Void));
-
+++ /dev/null
-/* -*- mode: hugs-c; -*- */
-/* --------------------------------------------------------------------------
- * STG syntax
- *
- * 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
- *
- * $RCSfile: stg.h,v $
- * $Revision: 1.2 $
- * $Date: 1998/12/02 13:22:39 $
- * ------------------------------------------------------------------------*/
-
-/* --------------------------------------------------------------------------
- * STG Syntax:
- *
- * Rhs -> STGCON (Con, [Atom])
- * | STGAPP (Var, [Atom]) -- delayed application
- * | Expr
- *
- * Expr -> LETREC ([Var],Expr) -- Vars contain their bound value
- * | LAMBDA ([Var],Expr) -- all vars bound to NIL
- * | CASE (Expr,[Alt])
- * | PRIMCASE (Expr,[PrimAlt])
- * | STGPRIM (Prim,[Atom])
- * | STGAPP (Var, [Atom]) -- tail call
- * | Var -- Abbreviation for STGAPP(Var,[])
- *
- * Atom -> Var
- * | CHAR -- unboxed
- * | INT -- unboxed
- * | BIGNUM -- unboxed
- * | FLOAT -- unboxed
- * | ADDR -- unboxed
- * | STRING -- boxed
- *
- * Var -> STGVAR (Rhs,StgRep,info) -- let, case or lambda bound
- * | Name -- let-bound (effectively)
- * -- always unboxed (PTR_REP)
- *
- * Alt -> (Pat,Expr)
- * Pat -> Var -- bound to a constructor, a tuple or unbound
- * PrimAlt -> ([PrimPat],Expr)
- * PrimPat -> Var -- bound to int or unbound
- *
- * We use pointer equality to distinguish variables.
- * The info field of a Var is used as follows in various phases:
- *
- * Translation: unused (set to NIL on output)
- * Freevar analysis: list of free vars after
- * Lambda lifting: freevar list or UNIT on input, discarded after
- * Code generation: unused
- * ------------------------------------------------------------------------*/
-
-typedef Cell StgRhs;
-typedef Cell StgExpr;
-typedef Cell StgAtom;
-typedef Cell StgVar; /* Could be a Name or an STGVAR */
-typedef Pair StgCaseAlt;
-typedef StgVar StgPat;
-typedef Cell StgDiscr;
-typedef Pair StgPrimAlt;
-typedef StgVar StgPrimPat;
-typedef Cell StgRep; /* PTR_REP | .. DOUBLE_REP */
-
-#define mkStgLet(binds,body) ap(LETREC,pair(binds,body))
-#define stgLetBinds(e) fst(snd(e))
-#define stgLetBody(e) snd(snd(e))
-
-#define mkStgPrimVar(rhs,rep,info) ap(STGVAR,triple(rhs,rep,info))
-#define stgVarBody(e) fst3(snd(e))
-#define stgVarRep(e) snd3(snd(e))
-#define stgVarInfo(e) thd3(snd(e))
-
-#define mkStgCase(scrut,alts) ap(CASE,pair(scrut,alts))
-#define stgCaseScrut(e) fst(snd(e))
-#define stgCaseAlts(e) snd(snd(e))
-
-#define mkStgCaseAlt(discr,vs,e) pair(mkStgVar(mkStgCon(discr,vs),NIL),e)
-#define stgCaseAltPat(alt) fst(alt)
-#define stgCaseAltBody(alt) snd(alt)
-
-#define stgPatDiscr(pat) stgConCon(stgVarBody(pat))
-#define stgPatVars(pat) stgConArgs(stgVarBody(pat))
-
-#define isDefaultPat(pat) (isNull(stgVarBody(pat)))
-#define isStgDefault(alt) (isDefaultPat(stgCaseAltPat(alt)))
-#define mkStgDefault(v,e) pair(v,e)
-
-#define mkStgPrimCase(scrut,alts) ap(PRIMCASE,pair(scrut,alts))
-#define stgPrimCaseScrut(e) fst(snd(e))
-#define stgPrimCaseAlts(e) snd(snd(e))
-
-#define mkStgPrimAlt(vs,body) pair(vs,body)
-#define stgPrimAltPats(alt) fst(alt)
-#define stgPrimAltBody(alt) snd(alt)
-
-#define mkStgApp(fun,args) ap(STGAPP,pair(fun,args))
-#define stgAppFun(e) fst(snd(e))
-#define stgAppArgs(e) snd(snd(e))
-
-#define mkStgPrim(op,args) ap(STGPRIM,pair(op,args))
-#define stgPrimOp(e) fst(snd(e))
-#define stgPrimArgs(e) snd(snd(e))
-
-#define mkStgCon(con,args) ap(STGCON,pair(con,args))
-#define stgConCon(e) fst(snd(e))
-#define stgConArgs(e) snd(snd(e))
-
-#define mkStgLambda(args,body) ap(LAMBDA,pair(args,body))
-#define stgLambdaArgs(e) fst(snd(e))
-#define stgLambdaBody(e) snd(snd(e))
-
-extern int stgConTag ( StgDiscr d );
-extern void* stgConInfo ( StgDiscr d );
-extern int stgDiscrTag( StgDiscr d );
-
-/* --------------------------------------------------------------------------
- * Utility functions for manipulating STG syntax trees.
- * ------------------------------------------------------------------------*/
-
-extern List makeArgs ( Int );
-extern StgExpr makeStgLambda ( List args, StgExpr body );
-extern StgExpr makeStgApp ( StgVar fun, List args );
-extern StgExpr makeStgLet ( List binds, StgExpr body );
-extern StgExpr makeStgIf ( StgExpr cond, StgExpr e1, StgExpr e2 );
-extern Bool isStgVar ( StgRhs rhs );
-extern Bool isAtomic ( StgRhs rhs );
-
-extern StgVar mkStgVar ( StgRhs rhs, Cell info );
-
-#define mkSeq(x,y) mkStgCase(mkStgApp(nameForce,singleton(x)),singleton(mkStgDefault(mkStgVar(NIL,NIL),y)))
-
-
-#define mkStgRep(c) mkChar(c)
-
-/*-------------------------------------------------------------------------*/
-
-
-
-
+++ /dev/null
-/* -*- mode: hugs-c; -*- */
-extern StgExpr substExpr ( List sub, StgExpr e );
+++ /dev/null
-extern Void stgDefn Args(( Name n, Int arity, Cell e ));
-
-extern Void implementForeignImport Args((Name));
-extern Void implementForeignExport Args((Name));
-extern Void implementCfun Args((Name, List));
-extern Void implementConToTag Args((Tycon));
-extern Void implementTagToCon Args((Tycon));
-extern Void implementPrim Args((Name));
-extern Void implementTuple Args((Int));
-#if TREX
-extern Name implementRecShw Args((Text));
-extern Name implementRecEq Args((Text));
-#endif
-
-/* Association list storing globals assigned to dictionaries, tuples, etc */
-extern List stgGlobals;
-
-
+++ /dev/null
-extern Type typeCheckExp Args((Bool));
-extern Void typeCheckDefns Args((Void));
-extern Cell provePred Args((Kinds,List,Cell));
-extern List simpleContext Args((List,Int));
-extern Cell rhsExpr Args((Cell));
-extern Int rhsLine Args((Cell));
-extern List offsetTyvarsIn Args((Type,List));
-extern Type primType Args((Int/*AsmMonad*/,String,String));
-extern Type conToTagType Args((Tycon));
-extern Type tagToConType Args((Tycon));
-extern Void mkTypes Args((Void));
-
projects / ghc-hetmet.git / commitdiff