ghc/interpreter/static.c

   1 /* -*- mode: hugs-c; -*- */
   2 /* --------------------------------------------------------------------------
   3  * Static Analysis for Hugs
   4  *
   5  * Copyright (c) The University of Nottingham and Yale University, 1994-1997.
   6  * All rights reserved. See NOTICE for details and conditions of use etc...
   7  * Hugs version 1.4, December 1997
   8  *
   9  * $RCSfile: static.c,v $
  10  * $Revision: 1.2 $
  11  * $Date: 1998/12/02 13:22:35 $
  12  * ------------------------------------------------------------------------*/
  13
  14 #include "prelude.h"
  15 #include "storage.h"
  16 #include "connect.h"
  17 #include "input.h"
  18 #include "type.h"
  19 #include "static.h"
  20 #include "translate.h"
  21 #include "hugs.h"  /* for target */
  22 #include "errors.h"
  23 #include "subst.h"
  24 #include "link.h"
  25 #include "modules.h"
  26 #include "derive.h"
  27
  28 /* --------------------------------------------------------------------------
  29  * local function prototypes:
  30  * ------------------------------------------------------------------------*/
  31
  32 static Module thisModule = 0;           /* module currently being processed*/
  33
  34 static Void  local kindError         Args((Int,Constr,Constr,String,Kind,Int));
  35
  36 static Void  local checkTyconDefn    Args((Tycon));
  37 static Void  local depConstrs        Args((Tycon,List,Cell));
  38 static List  local addSels           Args((Int,Name,List,List));
  39 static List  local selectCtxt        Args((List,List));
  40 static Void  local checkSynonyms     Args((List));
  41 static List  local visitSyn          Args((List,Tycon,List));
  42 #if EVAL_INSTANCES
  43 static Void  local deriveEval        Args((List));
  44 static List  local calcEvalContexts  Args((Tycon,List,List));
  45 #endif
  46 static Void  local checkBanged       Args((Name,Kinds,List,Type));
  47 static Type  local instantiateSyn    Args((Type,Type));
  48
  49 static Void  local checkClassDefn    Args((Class));
  50 static Void  local depPredExp        Args((Int,List,Cell));
  51 static Void  local checkMems         Args((Class,List,Cell));
  52 static Void  local addMembers        Args((Class));
  53 static Name  local newMember         Args((Int,Int,Cell,Type));
  54 static Name  local newDSel           Args((Class,Int));
  55 static Name  local newDBuild         Args((Class));
  56 static Text  local generateText      Args((String, Class));
  57 static Int   local visitClass        Args((Class));
  58
  59 static List  local classBindings     Args((String,Class,List));
  60 static Name  local memberName        Args((Class,Text));
  61 static List  local numInsert         Args((Int,Cell,List));
  62
  63 static List  local typeVarsIn        Args((Cell,List,List));
  64 static List  local maybeAppendVar    Args((Cell,List));
  65
  66 static Type  local checkSigType      Args((Int,String,Cell,Type));
  67 static Type  local depTopType        Args((Int,List,Type));
  68 static Type  local depCompType       Args((Int,List,Type));
  69 static Type  local depTypeExp        Args((Int,List,Type));
  70 static Type  local depTypeVar        Args((Int,List,Text));
  71 static Void  local kindConstr        Args((Int,Int,Int,Constr));
  72 static Kind  local kindAtom          Args((Int,Constr));
  73 static Void  local kindPred          Args((Int,Int,Int,Cell));
  74 static Void  local kindType          Args((Int,String,Type));
  75 static Void  local fixKinds          Args((Void));
  76
  77 static Void  local kindTCGroup       Args((List));
  78 static Void  local initTCKind        Args((Cell));
  79 static Void  local kindTC            Args((Cell));
  80 static Void  local genTC             Args((Cell));
  81
  82 static Void  local checkInstDefn     Args((Inst));
  83 static Void  local insertInst        Args((Inst));
  84 static Bool  local instCompare       Args((Inst,Inst));
  85 static Name  local newInstImp        Args((Inst));
  86 static Void  local kindInst          Args((Inst,Int));
  87 static Void  local checkDerive       Args((Tycon,List,List,Cell));
  88 static Void  local addDerInst        Args((Int,Class,List,List,Type,Int));
  89
  90 static Void  local deriveContexts    Args((List));
  91 static Void  local initDerInst       Args((Inst));
  92 static Void  local calcInstPreds     Args((Inst));
  93 static Void  local maybeAddPred      Args((Cell,Int,Int,List));
  94 static Cell  local copyAdj           Args((Cell,Int,Int));
  95 static Void  local tidyDerInst       Args((Inst));
  96
  97 static Void  local addDerivImp       Args((Inst));
  98
  99 static Void  local checkDefaultDefns Args((Void));
 100
 101 static Void  local checkForeignImport Args((Name));
 102 static Void  local checkForeignExport Args((Name));
 103
 104 static Cell  local checkPat          Args((Int,Cell));
 105 static Cell  local checkMaybeCnkPat  Args((Int,Cell));
 106 static Cell  local checkApPat        Args((Int,Int,Cell));
 107 static Void  local addPatVar         Args((Int,Cell));
 108 static Name  local conDefined        Args((Int,Cell));
 109 static Void  local checkIsCfun       Args((Int,Name));
 110 static Void  local checkCfunArgs     Args((Int,Cell,Int));
 111 static Cell  local applyBtyvs        Args((Cell));
 112 static Cell  local bindPat           Args((Int,Cell));
 113 static Void  local bindPats          Args((Int,List));
 114
 115 static List  local extractSigdecls   Args((List));
 116 static List  local extractBindings   Args((List));
 117 static List  local eqnsToBindings    Args((List));
 118 static Void  local notDefined        Args((Int,List,Cell));
 119 static Cell  local findBinding       Args((Text,List));
 120 static Void  local addSigDecl        Args((List,Cell));
 121 static Void  local setType           Args((Int,Cell,Cell,List));
 122
 123 static List  local dependencyAnal    Args((List));
 124 static List  local topDependAnal     Args((List));
 125 static Void  local addDepField       Args((Cell));
 126 static Void  local remDepField       Args((List));
 127 static Void  local remDepField1      Args((Cell));
 128 static Void  local clearScope        Args((Void));
 129 static Void  local withinScope       Args((List));
 130 static Void  local leaveScope        Args((Void));
 131
 132 static Void  local depBinding        Args((Cell));
 133 static Void  local depDefaults       Args((Class));
 134 static Void  local depInsts          Args((Inst));
 135 static Void  local depClassBindings  Args((List));
 136 static Void  local depAlt            Args((Cell));
 137 static Void  local depRhs            Args((Cell));
 138 static Void  local depGuard          Args((Cell));
 139 static Cell  local depExpr           Args((Int,Cell));
 140 static Void  local depPair           Args((Int,Cell));
 141 static Void  local depTriple         Args((Int,Cell));
 142 static Void  local depComp           Args((Int,Cell,List));
 143 static Void  local depCaseAlt        Args((Int,Cell));
 144 static Cell  local depVar            Args((Int,Cell));
 145 static Cell  local depQVar           Args((Int,Cell));
 146 static Void  local depConFlds        Args((Int,Cell,Bool));
 147 static Void  local depUpdFlds        Args((Int,Cell));
 148 static List  local depFields         Args((Int,Cell,List,Bool));
 149 #if TREX
 150 static Cell  local depRecord         Args((Int,Cell));
 151 #endif
 152
 153 static List  local tcscc             Args((List,List));
 154 static List  local bscc              Args((List));
 155
 156 static Void  local addRSsigdecls     Args((Pair));
 157 static Void  local opDefined         Args((List,Cell));
 158 static Void  local allNoPrevDef      Args((Cell));
 159 static Void  local noPrevDef         Args((Int,Cell));
 160 static Void  local duplicateError       Args((Int,Module,Text,String));
 161 static Void  local checkTypeIn       Args((Pair));
 162
 163 /* --------------------------------------------------------------------------
 164  * The code in this file is arranged in roughly the following order:
 165  *  - Kind inference preliminaries
 166  *  - Type declarations (data, type, newtype, type in)
 167  *  - Class declarations
 168  *  - Type signatures
 169  *  - Instance declarations
 170  *  - Default declarations
 171  *  - Patterns
 172  *  - Value definitions
 173  *  - Top-level static analysis and control
 174  * ------------------------------------------------------------------------*/
 175
 176 /* --------------------------------------------------------------------------
 177  * Kind checking preliminaries:
 178  * ------------------------------------------------------------------------*/
 179
 180 Bool kindExpert = FALSE;                /* TRUE => display kind errors in  */
 181                                         /*         full detail             */
 182
 183 static Void local kindError(l,c,in,wh,k,o)
 184 Int    l;                               /* line number near constuctor exp */
 185 Constr c;                               /* constructor                     */
 186 Constr in;                              /* context (if any)                */
 187 String wh;                              /* place in which error occurs     */
 188 Kind   k;                               /* expected kind (k,o)             */
 189 Int    o; {                             /* inferred kind (typeIs,typeOff)  */
 190     clearMarks();
 191
 192     if (!kindExpert) {                  /* for those with a fear of kinds  */
 193         ERRMSG(l) "Illegal type" ETHEN
 194         if (nonNull(in)) {
 195             ERRTEXT " \"" ETHEN ERRTYPE(in);
 196             ERRTEXT "\""  ETHEN
 197         }
 198         ERRTEXT " in %s\n", wh
 199         EEND;
 200     }
 201
 202     ERRMSG(l) "Kind error in %s", wh ETHEN
 203     if (nonNull(in)) {
 204         ERRTEXT "\n*** expression     : " ETHEN ERRTYPE(in);
 205     }
 206     ERRTEXT "\n*** constructor    : " ETHEN ERRTYPE(c);
 207     ERRTEXT "\n*** kind           : " ETHEN ERRKIND(copyType(typeIs,typeOff));
 208     ERRTEXT "\n*** does not match : " ETHEN ERRKIND(copyType(k,o));
 209     if (unifyFails) {
 210         ERRTEXT "\n*** because        : %s", unifyFails ETHEN
 211     }
 212     ERRTEXT "\n"
 213     EEND;
 214 }
 215
 216 #define shouldKind(l,c,in,wh,k,o)       if (!kunify(typeIs,typeOff,k,o)) \
 217                                             kindError(l,c,in,wh,k,o)
 218 #define checkKind(l,a,m,c,in,wh,k,o)    kindConstr(l,a,m,c); \
 219                                         shouldKind(l,c,in,wh,k,o)
 220 #define inferKind(k,o)                  typeIs=k; typeOff=o
 221
 222 static List unkindTypes;                /* types in need of kind annotation*/
 223 #if TREX
 224 Kind   extKind;                         /* Kind of extension, *->row->row  */
 225 #endif
 226
 227 /* --------------------------------------------------------------------------
 228  * Static analysis of type declarations:
 229  *
 230  * Type declarations come in two forms:
 231  * - data declarations - define new constructed data types
 232  * - type declarations - define new type synonyms
 233  *
 234  * A certain amount of work is carried out as the declarations are
 235  * read during parsing.  In particular, for each type constructor
 236  * definition encountered:
 237  * - check that there is no previous definition of constructor
 238  * - ensure type constructor not previously used as a class name
 239  * - make a new entry in the type constructor table
 240  * - record line number of declaration
 241  * - Build separate lists of newly defined constructors for later use.
 242  * ------------------------------------------------------------------------*/
 243
 244 Void tyconDefn(line,lhs,rhs,what)       /* process new type definition     */
 245 Int  line;                              /* definition line number          */
 246 Cell lhs;                               /* left hand side of definition    */
 247 Cell rhs;                               /* right hand side of definition   */
 248 Cell what; {                            /* SYNONYM/DATATYPE/etc...         */
 249     Text t = textOf(getHead(lhs));
 250
 251     if (nonNull(findTycon(t))) {
 252         ERRMSG(line) "Repeated definition of type constructor \"%s\"",
 253                      textToStr(t)
 254         EEND;
 255     }
 256     else if (nonNull(findClass(t))) {
 257         ERRMSG(line) "\"%s\" used as both class and type constructor",
 258                      textToStr(t)
 259         EEND;
 260     }
 261     else {
 262         Tycon nw        = newTycon(t);
 263         tyconDefns      = cons(nw,tyconDefns);
 264         tycon(nw).line  = line;
 265         tycon(nw).arity = argCount;
 266         tycon(nw).what  = what;
 267         if (what==RESTRICTSYN) {
 268             typeInDefns = cons(pair(nw,snd(rhs)),typeInDefns);
 269             rhs         = fst(rhs);
 270         }
 271         tycon(nw).defn  = pair(lhs,rhs);
 272     }
 273 }
 274
 275 Void setTypeIns(bs)                     /* set local synonyms for given    */
 276 List bs; {                              /* binding group                   */
 277     List cvs = typeInDefns;
 278     for (; nonNull(cvs); cvs=tl(cvs)) {
 279         Tycon c  = fst(hd(cvs));
 280         List  vs = snd(hd(cvs));
 281         for (tycon(c).what = RESTRICTSYN; nonNull(vs); vs=tl(vs)) {
 282             if (nonNull(findBinding(textOf(hd(vs)),bs))) {
 283                 tycon(c).what = SYNONYM;
 284                 break;
 285             }
 286         }
 287     }
 288 }
 289
 290 Void clearTypeIns() {                   /* clear list of local synonyms    */
 291     for (; nonNull(typeInDefns); typeInDefns=tl(typeInDefns))
 292         tycon(fst(hd(typeInDefns))).what = RESTRICTSYN;
 293 }
 294
 295 /* --------------------------------------------------------------------------
 296  * Further analysis of Type declarations:
 297  *
 298  * In order to allow the definition of mutually recursive families of
 299  * data types, the static analysis of the right hand sides of type
 300  * declarations cannot be performed until all of the type declarations
 301  * have been read.
 302  *
 303  * Once parsing is complete, we carry out the following:
 304  *
 305  * - check format of lhs, extracting list of bound vars and ensuring that
 306  *   there are no repeated variables and no Skolem variables.
 307  * - run dependency analysis on rhs to check that only bound type vars
 308  *   appear in type and that all constructors are defined.
 309  *   Replace type variables by offsets, constructors by Tycons.
 310  * - use list of dependents to sort into strongly connected components.
 311  * - ensure that there is not more than one synonym in each group.
 312  * - kind-check each group of type definitions.
 313  *
 314  * - check that there are no previous definitions for constructor
 315  *   functions in data type definitions.
 316  * - install synonym expansions and constructor definitions.
 317  * ------------------------------------------------------------------------*/
 318
 319 static List tcDeps = NIL;               /* list of dependent tycons/classes*/
 320
 321 static Void local checkTyconDefn(d)     /* validate type constructor defn  */
 322 Tycon d; {
 323     Cell lhs    = fst(tycon(d).defn);
 324     Cell rhs    = snd(tycon(d).defn);
 325     Int  line   = tycon(d).line;
 326     List tyvars = getArgs(lhs);
 327     List temp;
 328                                         /* check for repeated tyvars on lhs*/
 329     for (temp=tyvars; nonNull(temp); temp=tl(temp))
 330         if (nonNull(varIsMember(textOf(hd(temp)),tl(temp)))) {
 331             ERRMSG(line) "Repeated type variable \"%s\" on left hand side",
 332                          textToStr(textOf(hd(temp)))
 333             EEND;
 334         }
 335
 336     tcDeps = NIL;                       /* find dependents                 */
 337     switch (whatIs(tycon(d).what)) {
 338         case RESTRICTSYN :
 339         case SYNONYM     : rhs = depTypeExp(line,tyvars,rhs);
 340                            if (cellIsMember(d,tcDeps)) {
 341                                ERRMSG(line) "Recursive type synonym \"%s\"",
 342                                             textToStr(tycon(d).text)
 343                                EEND;
 344                            }
 345                            break;
 346
 347         case DATATYPE    :
 348         case NEWTYPE     : depConstrs(d,tyvars,rhs);
 349                            rhs = fst(rhs);
 350                            break;
 351
 352         default          : internal("checkTyconDefn");
 353                            break;
 354     }
 355
 356     tycon(d).defn = rhs;
 357     tycon(d).kind = tcDeps;
 358     tcDeps        = NIL;
 359 }
 360
 361 static Void local depConstrs(t,tyvars,cd)
 362 Tycon t;                                /* Define constructor functions and*/
 363 List  tyvars;                           /* do dependency analysis for data */
 364 Cell  cd; {                             /* definitions (w or w/o deriving) */
 365     Int  line      = tycon(t).line;
 366     List ctxt      = NIL;
 367     Int  conNo     = 1;
 368     Type lhs       = t;
 369     List cs        = fst(cd);
 370     List derivs    = snd(cd);
 371     List compTypes = NIL;
 372     List sels      = NIL;
 373     Int  ntvs      = length(tyvars);
 374     Int  i;
 375
 376     for (i=0; i<tycon(t).arity; ++i)    /* build representation for tycon  */
 377         lhs = ap(lhs,mkOffset(i));      /* applied to full comp. of args   */
 378
 379     if (whatIs(cs)==QUAL) {             /* allow for possible context      */
 380         ctxt = fst(snd(cs));
 381         cs   = snd(snd(cs));
 382         map2Proc(depPredExp,line,tyvars,ctxt);
 383     }
 384
 385     if (nonNull(cs) && isNull(tl(cs)))  /* Single constructor datatype?    */
 386         conNo = 0;
 387
 388     for (; nonNull(cs); cs=tl(cs)) {    /* For each constructor function:  */
 389         Cell con   = hd(cs);
 390         List sig   = typeVarsIn(con,NIL,dupList(tyvars));
 391         Int  etvs  = length(sig);
 392         List ctxt1 = ctxt;              /* constructor function context    */
 393         List scs   = NIL;               /* strict components               */
 394         List fs    = NONE;              /* selector names                  */
 395         Type type  = lhs;               /* constructor function type       */
 396         Int  arity = 0;                 /* arity of constructor function   */
 397         Int  nr2   = 0;                 /* Number of rank 2 args           */
 398         Name n;                         /* name for constructor function   */
 399
 400         if (whatIs(con)==LABC) {        /* Skeletize constr components     */
 401             Cell fls = snd(snd(con));   /* get field specifications        */
 402             con      = fst(snd(con));
 403             fs       = NIL;
 404             for (; nonNull(fls); fls=tl(fls)) { /* for each field spec:    */
 405                 List vs     = fst(hd(fls));
 406                 Type t      = snd(hd(fls));     /* - scrutinize type       */
 407                 Bool banged = whatIs(t)==BANG;
 408                 t           = depCompType(line,sig,(banged ? arg(t) : t));
 409                 while (nonNull(vs)) {           /* - add named components  */
 410                     Cell us = tl(vs);
 411                     tl(vs)  = fs;
 412                     fs      = vs;
 413                     vs      = us;
 414                     con     = ap(con,t);
 415                     arity++;
 416                     if (banged)
 417                         scs = cons(mkInt(arity),scs);
 418                 }
 419             }
 420             fs  = rev(fs);
 421             scs = rev(scs);             /* put strict comps in ascend ord  */
 422         }
 423         else {                          /* Non-labelled constructor        */
 424             Cell c = con;
 425             Int  compNo;
 426             for (; isAp(c); c=fun(c))
 427                 arity++;
 428             for (compNo=arity, c=con; isAp(c); c=fun(c)) {
 429                 Type t = arg(c);
 430                 if (whatIs(t)==BANG) {
 431                     scs = cons(mkInt(compNo),scs);
 432                     t   = arg(t);
 433                 }
 434                 compNo--;
 435                 arg(c) = depCompType(line,sig,t);
 436             }
 437         }
 438
 439         if (nonNull(ctxt1))             /* Extract relevant part of context*/
 440             ctxt1 = selectCtxt(ctxt1,offsetTyvarsIn(con,NIL));
 441
 442         for (i=arity; isAp(con); i--) { /* Calculate type of constructor   */
 443             Type t   = fun(con);
 444             Type cmp = arg(con);
 445             fun(con) = typeArrow;
 446             if (isPolyType(cmp)) {
 447                 if (nonNull(derivs)) {
 448                     ERRMSG(line) "Cannot derive instances for types" ETHEN
 449                     ERRTEXT      " with polymorphic components"
 450                     EEND;
 451                 }
 452                 if (nr2==0)
 453                     nr2 = i;
 454             }
 455             if (nonNull(derivs))        /* and build list of components    */
 456                 compTypes = cons(cmp,compTypes);
 457             type     = ap(con,type);
 458             con      = t;
 459         }
 460
 461         if (nr2>0)                      /* Add rank 2 annotation           */
 462             type = ap(RANK2,pair(mkInt(nr2),type));
 463
 464         if (etvs>ntvs) {                /* Add existential annotation      */
 465             if (nonNull(derivs)) {
 466                 ERRMSG(line) "Cannot derive instances for types" ETHEN
 467                 ERRTEXT      " with existentially typed components"
 468                 EEND;
 469             }
 470             if (fs!=NONE) {
 471                 ERRMSG(line)
 472                    "Cannot use selectors with existentially typed components"
 473                 EEND;
 474             }
 475             type = ap(EXIST,pair(mkInt(etvs-ntvs),type));
 476         }
 477         if (nonNull(ctxt1)) {           /* Add context part to type        */
 478             type = ap(QUAL,pair(ctxt1,type));
 479         }
 480         if (nonNull(sig)) {             /* Add quantifiers to type         */
 481             List ts1 = sig;
 482             for (; nonNull(ts1); ts1=tl(ts1)) {
 483                 hd(ts1) = NIL;
 484             }
 485             type = mkPolyType(sig,type);
 486         }
 487
 488         n = findName(textOf(con));      /* Allocate constructor fun name   */
 489         if (isNull(n)) {
 490             n = newName(textOf(con));
 491         } else if (name(n).defn!=PREDEFINED) {
 492             duplicateError(line,name(n).mod,name(n).text,
 493                            "constructor function");
 494         }
 495         name(n).arity  = arity;         /* Save constructor fun details    */
 496         name(n).line   = line;
 497         name(n).number = cfunNo(conNo++);
 498         name(n).type   = type;
 499         if (tycon(t).what==NEWTYPE) {
 500             name(n).defn = nameId;
 501         } else {
 502             implementCfun(n,scs);
 503         }
 504         hd(cs) = n;
 505         if (fs!=NONE) {
 506             sels = addSels(line,n,fs,sels);
 507         }
 508     }
 509
 510     if (nonNull(sels)) {
 511         sels     = rev(sels);
 512         fst(cd)  = appendOnto(fst(cd),sels);
 513         selDefns = cons(sels,selDefns);
 514     }
 515
 516     if (nonNull(derivs)) {              /* Generate derived instances      */
 517         map3Proc(checkDerive,t,ctxt,compTypes,derivs);
 518     }
 519 }
 520
 521 static List local addSels(line,c,fs,ss) /* Add fields to selector list     */
 522 Int  line;                              /* line number of constructor      */
 523 Name c;                                 /* corresponding constr function   */
 524 List fs;                                /* list of fields (varids)         */
 525 List ss; {                              /* list of existing selectors      */
 526     Int sn    = 1;
 527 #if DERIVE_SHOW | DERIVE_READ
 528     cfunSfuns = cons(pair(c,fs),cfunSfuns);
 529 #endif
 530     for (; nonNull(fs); fs=tl(fs), ++sn) {
 531         List ns = ss;
 532         Text t  = textOf(hd(fs));
 533
 534         if (nonNull(varIsMember(t,tl(fs)))) {
 535             ERRMSG(line) "Repeated field name \"%s\" for constructor \"%s\"",
 536                          textToStr(t), textToStr(name(c).text)
 537             EEND;
 538         }
 539
 540         while (nonNull(ns) && t!=name(hd(ns)).text) {
 541             ns = tl(ns);
 542         }
 543         if (nonNull(ns)) {
 544             name(hd(ns)).defn = cons(pair(c,mkInt(sn)),name(hd(ns)).defn);
 545         } else {
 546             Name n = findName(t);
 547             if (nonNull(n)) {
 548                 ERRMSG(line) "Repeated definition for selector \"%s\"",
 549                              textToStr(t)
 550                 EEND;
 551             }
 552             n              = newName(t);
 553             name(n).line   = line;
 554             name(n).number = SELNAME;
 555             name(n).defn   = singleton(pair(c,mkInt(sn)));
 556             ss             = cons(n,ss);
 557         }
 558     }
 559     return ss;
 560 }
 561
 562 static List local selectCtxt(ctxt,vs)   /* calculate subset of context     */
 563 List ctxt;
 564 List vs; {
 565     if (isNull(vs)) {
 566         return NIL;
 567     } else {
 568         List ps = NIL;
 569         for (; nonNull(ctxt); ctxt=tl(ctxt)) {
 570             List us = offsetTyvarsIn(hd(ctxt),NIL);
 571             for (; nonNull(us) && cellIsMember(hd(us),vs); us=tl(us)) {
 572             }
 573             if (isNull(us)) {
 574                 ps = cons(hd(ctxt),ps);
 575             }
 576         }
 577         return rev(ps);
 578     }
 579 }
 580
 581 static Void local checkSynonyms(ts)     /* Check for mutually recursive    */
 582 List ts; {                              /* synonyms                        */
 583     List syns = NIL;
 584     for (; nonNull(ts); ts=tl(ts)) {    /* build list of all synonyms      */
 585         Tycon t = hd(ts);
 586         switch (whatIs(tycon(t).what)) {
 587             case SYNONYM     :
 588             case RESTRICTSYN : syns = cons(t,syns);
 589                                break;
 590         }
 591     }
 592     while (nonNull(syns)) {             /* then visit each synonym         */
 593         syns = visitSyn(NIL,hd(syns),syns);
 594     }
 595 }
 596
 597 static List local visitSyn(path,t,syns) /* visit synonym definition to look*/
 598 List  path;                             /* for cycles                      */
 599 Tycon t;
 600 List  syns; {
 601     if (cellIsMember(t,path)) {         /* every elt in path depends on t  */
 602         ERRMSG(tycon(t).line)
 603             "Type synonyms \"%s\" and \"%s\" are mutually recursive",
 604             textToStr(tycon(t).text), textToStr(tycon(hd(path)).text)
 605         EEND;
 606     } else {
 607         List ds    = tycon(t).kind;
 608         List path1 = NIL;
 609         for (; nonNull(ds); ds=tl(ds)) {
 610             if (cellIsMember(hd(ds),syns)) {
 611                 if (isNull(path1))
 612                     path1 = cons(t,path);
 613                 syns = visitSyn(path1,hd(ds),syns);
 614             }
 615         }
 616     }
 617     tycon(t).defn = fullExpand(tycon(t).defn);
 618     return removeCell(t,syns);
 619 }
 620
 621 /* --------------------------------------------------------------------------
 622  * The following code is used in calculating contexts for the automatically
 623  * derived Eval instances for newtype and restricted type synonyms.  This is
 624  * ugly code, resulting from an ugly feature in the language, and I hope that
 625  * the feature, and hence the code, will be removed in the not too distant
 626  * future.
 627  * ------------------------------------------------------------------------*/
 628
 629 #if EVAL_INSTANCES
 630 static Void local deriveEval(tcs)       /* Derive instances of Eval        */
 631 List tcs; {
 632     List ts1 = tcs;
 633     List ts  = NIL;
 634     for (; nonNull(ts1); ts1=tl(ts1)) { /* Build list of rsyns and newtypes*/
 635         Tycon t = hd(ts1);              /* and derive instances for data   */
 636         switch (whatIs(tycon(t).what)) {
 637             case DATATYPE    : addEvalInst(tycon(t).line,t,tycon(t).arity,NIL);
 638                                break;
 639             case NEWTYPE     :
 640             case RESTRICTSYN : ts = cons(t,ts);
 641                                break;
 642         }
 643     }
 644     emptySubstitution();                /* then derive other instances     */
 645     while (nonNull(ts)) {
 646         ts = calcEvalContexts(hd(ts),tl(ts),NIL);
 647     }
 648     emptySubstitution();
 649
 650     for (; nonNull(tcs); tcs=tl(tcs)) { /* Check any banged components     */
 651         Tycon t = hd(tcs);
 652         if (whatIs(tycon(t).what)==DATATYPE) {
 653             List cs = tycon(t).defn;
 654             for (; hasCfun(cs); cs=tl(cs)) {
 655                 Name c = hd(cs);
 656                 if (isPair(name(c).defn)) {
 657                     Type  t    = name(c).type;
 658                     List  scs  = fst(name(c).defn);
 659                     Kinds ks   = NIL;
 660                     List  ctxt = NIL;
 661                     Int   n    = 1;
 662                     if (isPolyType(t)) {
 663                         ks = polySigOf(t);
 664                         t  = monotypeOf(t);
 665                     }
 666                     if (whatIs(t)==QUAL) {
 667                         ctxt = fst(snd(t));
 668                         t    = snd(snd(t));
 669                     }
 670                     for (; nonNull(scs); scs=tl(scs)) {
 671                         Int i = intOf(hd(scs));
 672                         for (; n<i; n++) {
 673                             t = arg(t);
 674                         }
 675                         checkBanged(c,ks,ctxt,arg(fun(t)));
 676                     }
 677                 }
 678             }
 679         }
 680     }
 681 }
 682
 683 static List local calcEvalContexts(tc,ts,ps)
 684 Tycon tc;                               /* Worker code for deriveEval      */
 685 List  ts;                               /* ts = not visited, ps = visiting */
 686 List  ps; {
 687     Cell ctxt = NIL;
 688     Int  o    = newKindedVars(tycon(tc).kind);
 689     Type t    = tycon(tc).defn;
 690     Int  i;
 691
 692     if (whatIs(tycon(tc).what)==NEWTYPE) {
 693         t = name(hd(t)).type;
 694         if (isPolyType(t)) {
 695             t = monotypeOf(t);
 696         }
 697         if (whatIs(t)==QUAL) {
 698             t = snd(snd(t));
 699         }
 700         if (whatIs(t)==EXIST) {         /* No instance if existentials used*/
 701             return ts;
 702         }
 703         if (whatIs(t)==RANK2) {         /* No instance if arg is poly/qual */
 704             return ts;
 705         }
 706         t = arg(fun(t));
 707     }
 708
 709     clearMarks();                       /* Make sure generics are marked   */
 710     for (i=0; i<tycon(tc).arity; i++) { /* in the correct order.           */
 711         copyTyvar(o+i);
 712     }
 713
 714     for (;;) {
 715         Type h = getDerefHead(t,o);
 716         if (isSynonym(h) && argCount>=tycon(h).arity) {
 717             expandSyn(h,argCount,&t,&o);
 718         } else if (isOffset(h)) {               /* Stop if var at head     */
 719             ctxt = singleton(ap(classEval,copyType(t,o)));
 720             break;
 721         } else if (isTuple(h)                   /* Check for tuples ...    */
 722                 || h==tc                        /* ... direct recursion    */
 723                 || cellIsMember(h,ps)           /* ... mutual recursion    */
 724                 || tycon(h).what==DATATYPE) {   /* ... or datatype.        */
 725             break;                              /* => empty context        */
 726         } else {
 727             Cell pi = ap(classEval,t);
 728             Inst in;
 729
 730             if (cellIsMember(h,ts)) {           /* Not yet visited?        */
 731                 ts = calcEvalContexts(h,removeCell(h,ts),cons(h,ts));
 732             }
 733             if (nonNull(in=findInstFor(pi,o))) {/* Look for Eval instance  */
 734                 List qs = inst(in).specifics;
 735                 Int  o1 = typeOff;
 736                 if (isNull(qs)) {               /* No context there        */
 737                     break;                      /* => empty context here   */
 738                 }
 739                 if (isNull(tl(qs)) && classEval==fun(hd(qs))) {
 740                     t = arg(hd(qs));
 741                     o = o1;
 742                     continue;
 743                 }
 744             }
 745             return ts;                          /* No instance, so give up */
 746         }
 747     }
 748     addEvalInst(tycon(tc).line,tc,tycon(tc).arity,ctxt);
 749     return ts;
 750 }
 751
 752 static Void local checkBanged(c,ks,ps,ty)
 753 Name  c;                                /* Check that banged component of c*/
 754 Kinds ks;                               /* with type ty is an instance of  */
 755 List  ps;                               /* Eval under the predicates in ps.*/
 756 Type  ty; {                             /* (All types using ks)            */
 757     Cell pi = ap(classEval,ty);
 758     if (isNull(provePred(ks,ps,pi))) {
 759         ERRMSG(name(c).line) "Illegal datatype strictness annotation:" ETHEN
 760         ERRTEXT "\n*** Constructor : "  ETHEN ERREXPR(c);
 761         ERRTEXT "\n*** Context     : "  ETHEN ERRCONTEXT(ps);
 762         ERRTEXT "\n*** Required    : "  ETHEN ERRPRED(pi);
 763         ERRTEXT "\n"
 764         EEND;
 765     }
 766 }
 767 #endif
 768
 769 /* --------------------------------------------------------------------------
 770  * Expanding out all type synonyms in a type expression:
 771  * ------------------------------------------------------------------------*/
 772
 773 Type fullExpand(t)                      /* find full expansion of type exp */
 774 Type t; {                               /* assuming that all relevant      */
 775     Cell h = t;                         /* synonym defns of lower rank have*/
 776     Int  n = 0;                         /* already been fully expanded     */
 777     List args;
 778     for (args=NIL; isAp(h); h=fun(h), n++) {
 779         args = cons(fullExpand(arg(h)),args);
 780     }
 781     t = applyToArgs(h,args);
 782     if (isSynonym(h) && n>=tycon(h).arity) {
 783         if (n==tycon(h).arity) {
 784             t = instantiateSyn(tycon(h).defn,t);
 785         } else {
 786             Type p = t;
 787             while (--n > tycon(h).arity) {
 788                 p = fun(p);
 789             }
 790             fun(p) = instantiateSyn(tycon(h).defn,fun(p));
 791         }
 792     }
 793     return t;
 794 }
 795
 796 static Type local instantiateSyn(t,env) /* instantiate type according using*/
 797 Type t;                                 /* env to determine appropriate    */
 798 Type env; {                             /* values for OFFSET type vars     */
 799     switch (whatIs(t)) {
 800         case AP      : return ap(instantiateSyn(fun(t),env),
 801                                  instantiateSyn(arg(t),env));
 802
 803         case OFFSET  : return nthArg(offsetOf(t),env);
 804
 805         default      : return t;
 806     }
 807 }
 808
 809 /* --------------------------------------------------------------------------
 810  * Static analysis of class declarations:
 811  *
 812  * Performed in a similar manner to that used for type declarations.
 813  *
 814  * The first part of the static analysis is performed as the declarations
 815  * are read during parsing.  The parser ensures that:
 816  * - the class header and all superclass predicates are of the form
 817  *   ``Class var''
 818  *
 819  * The classDefn() function:
 820  * - ensures that there is no previous definition for class
 821  * - checks that class name has not previously been used as a type constr.
 822  * - make new entry in class table
 823  * - record line number of declaration
 824  * - build list of classes defined in current script for use in later
 825  *   stages of static analysis.
 826  * ------------------------------------------------------------------------*/
 827
 828 Void classDefn(line,head,ms)            /* process new class definition    */
 829 Int  line;                              /* definition line number          */
 830 Cell head;                              /* class header :: ([Supers],Class)*/
 831 List ms; {                              /* class definition body           */
 832     Text ct   = textOf(getHead(snd(head)));
 833     Int arity = argCount;
 834
 835     if (nonNull(findClass(ct))) {
 836         ERRMSG(line) "Repeated definition of class \"%s\"",
 837                      textToStr(ct)
 838         EEND;
 839     } else if (nonNull(findTycon(ct))) {
 840         ERRMSG(line) "\"%s\" used as both class and type constructor",
 841                      textToStr(ct)
 842         EEND;
 843     } else {
 844         Class nw           = newClass(ct);
 845         cclass(nw).line    = line;
 846         cclass(nw).arity   = arity;
 847         cclass(nw).head    = snd(head);
 848         cclass(nw).supers  = fst(head);
 849         cclass(nw).members = ms;
 850         cclass(nw).level   = 0;
 851         classDefns         = cons(nw,classDefns);
 852     }
 853 }
 854
 855 /* --------------------------------------------------------------------------
 856  * Further analysis of class declarations:
 857  *
 858  * Full static analysis of class definitions must be postponed until the
 859  * complete script has been read and all static analysis on type definitions
 860  * has been completed.
 861  *
 862  * Once this has been achieved, we carry out the following checks on each
 863  * class definition:
 864  * - check that variables in header are distinct
 865  * - replace head by skeleton
 866  * - check superclass declarations, replace by skeltons
 867  * - split body of class into members and declarations
 868  * - make new name entry for each member function
 869  * - record member function number (eventually an offset into dictionary!)
 870  * - no member function has a previous definition ...
 871  * - no member function is mentioned more than once in the list of members
 872  * - each member function type is valid, replace vars by offsets
 873  * - qualify each member function type by class header
 874  * - only bindings for members appear in defaults
 875  * - only function bindings appear in defaults
 876  * - check that extended class hierarchy does not contain any cycles
 877  * ------------------------------------------------------------------------*/
 878
 879 static Void local checkClassDefn(c)     /* validate class definition       */
 880 Class c; {
 881     List tyvars = NIL;
 882     Int  args   = cclass(c).arity - 1;
 883     Cell temp   = cclass(c).head;
 884
 885     for (; isAp(temp); temp=fun(temp)) {
 886         if (!isVar(arg(temp))) {
 887             ERRMSG(cclass(c).line) "Type variable required in class head"
 888             EEND;
 889         }
 890         if (nonNull(varIsMember(textOf(arg(temp)),tyvars))) {
 891             ERRMSG(cclass(c).line)
 892                 "Repeated type variable \"%s\" in class head",
 893                 textToStr(textOf(arg(temp)))
 894             EEND;
 895         }
 896         tyvars = cons(arg(temp),tyvars);
 897     }
 898
 899     for (temp=cclass(c).head; args>0; temp=fun(temp), args--) {
 900         arg(temp) = mkOffset(args);
 901     }
 902     arg(temp) = mkOffset(0);
 903     fun(temp) = c;
 904
 905     tcDeps              = NIL;          /* find dependents                 */
 906     map2Proc(depPredExp,cclass(c).line,tyvars,cclass(c).supers);
 907     cclass(c).numSupers = length(cclass(c).supers);
 908     cclass(c).defaults  = extractBindings(cclass(c).members);   /* defaults*/
 909     cclass(c).members   = extractSigdecls(cclass(c).members);
 910     map2Proc(checkMems,c,tyvars,cclass(c).members);
 911     cclass(c).kinds     = tcDeps;
 912     tcDeps              = NIL;
 913 }
 914
 915 static Void local depPredExp(line,tyvars,pred)
 916 Int  line;
 917 List tyvars;
 918 Cell pred; {
 919     Int  args = 1;                      /* parser guarantees >=1 args      */
 920     Cell h    = fun(pred);
 921     for (; isAp(h); args++) {
 922         arg(pred) = depTypeExp(line,tyvars,arg(pred));
 923         pred      = h;
 924         h         = fun(pred);
 925     }
 926     arg(pred) = depTypeExp(line,tyvars,arg(pred));
 927
 928     if (isQCon(h)) {                    /* standard class constraint       */
 929         Class c = findQualClass(h);
 930         if (isNull(c)) {
 931             ERRMSG(line) "Undefined class \"%s\"", identToStr(h)
 932             EEND;
 933         }
 934         fun(pred) = c;
 935         if (args!=cclass(c).arity) {
 936             ERRMSG(line) "Wrong number of arguments for class \"%s\"",
 937                         textToStr(cclass(c).text)
 938             EEND;
 939         }
 940         if (cellIsMember(c,classDefns) && !cellIsMember(c,tcDeps))
 941             tcDeps = cons(c,tcDeps);
 942     }
 943 #if TREX
 944     else if (isExt(h)) {                /* Lacks predicate                 */
 945         if (args!=1) {                  /* parser shouldn't let this happen*/
 946             ERRMSG(line) "Wrong number of arguments for lacks predicate"
 947             EEND;
 948         }
 949     }
 950 #endif
 951     else {                              /* check for other kinds of pred   */
 952         internal("depPredExp");         /* ... but there aren't any!       */
 953     }
 954 }
 955
 956 static Void local checkMems(c,tyvars,m) /* check member function details   */
 957 Class c;
 958 List  tyvars;
 959 Cell  m; {
 960     Int  line = intOf(fst3(m));
 961     List vs   = snd3(m);
 962     Type t    = thd3(m);
 963     List sig  = NIL;
 964     List tvs  = NIL;
 965
 966     tyvars    = typeVarsIn(t,NIL,tyvars);/* Look for extra type vars.      */
 967
 968     if (whatIs(t)==QUAL) {              /* Overloaded member signatures?   */
 969         map2Proc(depPredExp,line,tyvars,fst(snd(t)));
 970     } else {
 971         t = ap(QUAL,pair(NIL,t));
 972     }
 973
 974     fst(snd(t)) = cons(cclass(c).head,fst(snd(t)));/* Add main predicate   */
 975     snd(snd(t)) = depTopType(line,tyvars,snd(snd(t)));
 976
 977     for (tvs=tyvars; nonNull(tvs); tvs=tl(tvs)) { /* Quantify              */
 978         sig = ap(NIL,sig);
 979     }
 980     t       = mkPolyType(sig,t);
 981     thd3(m) = t;                                /* Save type               */
 982     take(cclass(c).arity,tyvars);               /* Delete extra type vars  */
 983
 984     if (isAmbiguous(t)) {
 985         ambigError(line,"class declaration",hd(vs),t);
 986     }
 987 }
 988
 989 static Void local addMembers(c)         /* Add definitions of member funs  */
 990 Class c; {                              /* and other parts of class struct.*/
 991     List ms  = cclass(c).members;
 992     List ns  = NIL;                     /* List of names                   */
 993     Int  mno;                           /* Member function number          */
 994
 995     for (mno=0; mno<cclass(c).numSupers; mno++) {
 996         ns = cons(newDSel(c,mno),ns);
 997     }
 998     cclass(c).dsels = rev(ns);          /* Save dictionary selectors       */
 999
1000     for (mno=1, ns=NIL; nonNull(ms); ms=tl(ms)) {
1001         Int  line = intOf(fst3(hd(ms)));
1002         List vs   = rev(snd3(hd(ms)));
1003         Type t    = thd3(hd(ms));
1004         for (; nonNull(vs); vs=tl(vs)) {
1005             ns = cons(newMember(line,mno++,hd(vs),t),ns);
1006         }
1007     }
1008     cclass(c).members    = rev(ns);     /* Save list of members            */
1009     cclass(c).numMembers = length(cclass(c).members);
1010
1011 /*  Not actually needed just yet; for the time being, dictionary code will
1012     not be passed through the type checker.
1013
1014     cclass(c).dtycon    = addPrimTycon(generateText("Dict.%s",c),
1015                                        NIL,
1016                                        cclass(c).arity,
1017                                        DATATYPE,
1018                                        NIL);
1019 */
1020
1021     mno                  = cclass(c).numSupers + cclass(c).numMembers;
1022     cclass(c).dcon       = addPrimCfun(generateText("Make.%s",c),mno,0,0);
1023     implementCfun(cclass(c).dcon,NIL); /* ADR addition */
1024 #if USE_NEWTYPE_FOR_DICTS
1025     if (mno==1) {                       /* Single entry dicts use newtype  */
1026         name(cclass(c).dcon).defn = nameId;
1027         name(hd(cclass(c).members)).number = mfunNo(0);
1028     }
1029 #endif
1030     cclass(c).dbuild     = newDBuild(c);
1031     cclass(c).defaults   = classBindings("class",c,cclass(c).defaults);
1032 }
1033
1034 static Name local newMember(l,no,v,t)   /* Make definition for member fn   */
1035 Int  l;
1036 Int  no;
1037 Cell v;
1038 Type t; {
1039     Name m = findName(textOf(v));
1040
1041     if (isNull(m)) {
1042         m = newName(textOf(v));
1043     } else if (name(m).defn!=PREDEFINED) {
1044         ERRMSG(l) "Repeated definition for member function \"%s\"",
1045                   textToStr(name(m).text)
1046         EEND;
1047     }
1048
1049     name(m).line   = l;
1050     name(m).arity  = 1;
1051     name(m).number = mfunNo(no);
1052     name(m).type   = t;
1053     return m;
1054 }
1055
1056 static Name local newDSel(c,no)         /* Make definition for dict selectr*/
1057 Class c;
1058 Int   no; {
1059     Name s;
1060     char buf[16];
1061
1062     sprintf(buf,"sc%d.%s",no,"%s");
1063     s              = newName(generateText(buf,c));
1064     name(s).line   = cclass(c).line;
1065     name(s).arity  = 1;
1066     name(s).number = DFUNNAME;
1067     return s;
1068 }
1069
1070 static Name local newDBuild(c)          /* Make definition for builder     */
1071 Class c; {
1072     Name b         = newName(generateText("class.%s",c));
1073     name(b).line   = cclass(c).line;
1074     name(b).arity  = cclass(c).numSupers+1;
1075     return b;
1076 }
1077
1078 #define MAX_GEN  128
1079
1080 static Text local generateText(sk,c)    /* We need to generate names for   */
1081 String sk;                              /* certain objects corresponding   */
1082 Class  c; {                             /* to each class.                  */
1083     String cname = textToStr(cclass(c).text);
1084     char buffer[MAX_GEN+1];
1085
1086     if ((strlen(sk)+strlen(cname))>=MAX_GEN) {
1087         ERRMSG(0) "Please use a shorter name for class \"%s\"", cname
1088         EEND;
1089     }
1090     sprintf(buffer,sk,cname);
1091     return findText(buffer);
1092 }
1093
1094 static Int local visitClass(c)          /* visit class defn to check that  */
1095 Class c; {                              /* class hierarchy is acyclic      */
1096 #if TREX
1097     if (isExt(c)) {                     /* special case for lacks preds    */
1098         return 0;
1099     }
1100 #endif
1101     if (cclass(c).level < 0) {          /* already visiting this class?    */
1102         ERRMSG(cclass(c).line) "Class hierarchy for \"%s\" is not acyclic",
1103                                textToStr(cclass(c).text)
1104         EEND;
1105     } else if (cclass(c).level == 0) {   /* visiting class for first time   */
1106         List scs = cclass(c).supers;
1107         Int  lev = 0;
1108         cclass(c).level = (-1);
1109         for (; nonNull(scs); scs=tl(scs)) {
1110             Int l = visitClass(getHead(hd(scs)));
1111             if (l>lev) lev=l;
1112         }
1113         cclass(c).level = 1+lev;        /* level = 1 + max level of supers */
1114     }
1115     return cclass(c).level;
1116 }
1117
1118 /* --------------------------------------------------------------------------
1119  * Process class and instance declaration binding groups:
1120  * ------------------------------------------------------------------------*/
1121
1122 static List local classBindings(where,c,bs)
1123 String where;                           /*check validity of bindings bs for*/
1124 Class  c;                               /* class c (or an instance of c)   */
1125 List   bs; {                            /* sort into approp. member order  */
1126     List nbs = NIL;
1127
1128     for (; nonNull(bs); bs=tl(bs)) {
1129         Cell b = hd(bs);
1130         Name mnm;
1131
1132         if (!isVar(fst(b))) {           /* only allows function bindings   */
1133             ERRMSG(rhsLine(snd(snd(snd(b)))))
1134                "Pattern binding illegal in %s declaration", where
1135             EEND;
1136         }
1137
1138         if (isNull(mnm=memberName(c,textOf(fst(b))))) {
1139             ERRMSG(rhsLine(snd(hd(snd(snd(b))))))
1140                 "No member \"%s\" in class \"%s\"",
1141                 textToStr(textOf(fst(b))), textToStr(cclass(c).text)
1142             EEND;
1143         }
1144
1145         snd(b) = snd(snd(b));
1146         nbs = numInsert(mfunOf(mnm)-1,b,nbs);
1147     }
1148     return nbs;
1149 }
1150
1151 static Name local memberName(c,t)       /* return name of member function  */
1152 Class c;                                /* with name t in class c          */
1153 Text  t; {                              /* return NIL if not a member      */
1154     List ms = cclass(c).members;
1155     for (; nonNull(ms); ms=tl(ms)) {
1156         if (t==name(hd(ms)).text) {
1157             return hd(ms);
1158         }
1159     }
1160     return NIL;
1161 }
1162
1163 static List local numInsert(n,x,xs)     /* insert x at nth position in xs, */
1164 Int  n;                                 /* filling gaps with NIL           */
1165 Cell x;
1166 List xs; {
1167     List start = isNull(xs) ? cons(NIL,NIL) : xs;
1168
1169     for (xs=start; 0<n--; xs=tl(xs)) {
1170         if (isNull(tl(xs))) {
1171             tl(xs) = cons(NIL,NIL);
1172         }
1173     }
1174     hd(xs) = x;
1175     return start;
1176 }
1177
1178 /* --------------------------------------------------------------------------
1179  * Calculate set of variables appearing in a given type expression (possibly
1180  * qualified) as a list of distinct values.  The order in which variables
1181  * appear in the list is the same as the order in which those variables
1182  * occur in the type expression when read from left to right.
1183  * ------------------------------------------------------------------------*/
1184
1185 static List local typeVarsIn(ty,us,vs)  /* Calculate list of type variables*/
1186 Cell ty;                                /* used in type expression, reading*/
1187 List us;                                /* from left to right ignoring any */
1188 List vs; {                              /* listed in us.                   */
1189     switch (whatIs(ty)) {
1190         case AP        : return typeVarsIn(snd(ty),us,
1191                                            typeVarsIn(fst(ty),us,vs));
1192
1193         case VARIDCELL :
1194         case VAROPCELL : if (nonNull(findBtyvs(textOf(ty)))
1195                              || varIsMember(textOf(ty),us)) {
1196                              return vs;
1197                           } else {
1198                              return maybeAppendVar(ty,vs);
1199                           }
1200         case POLYTYPE  : return typeVarsIn(monotypeOf(ty),polySigOf(ty),vs);
1201
1202         case QUAL      : {   List qs = fst(snd(ty));
1203                              for (; nonNull(qs); qs=tl(qs)) {
1204                                  vs = typeVarsIn(hd(qs),us,vs);
1205                              }
1206                              return typeVarsIn(snd(snd(ty)),us,vs);
1207                          }
1208
1209         case BANG      : return typeVarsIn(snd(ty),us,vs);
1210
1211         case LABC      : {   List fs = snd(snd(ty));
1212                              for (; nonNull(fs); fs=tl(fs)) {
1213                                 vs = typeVarsIn(snd(hd(fs)),us,vs);
1214                              }
1215                              return vs;
1216                          }
1217     }
1218     return vs;
1219 }
1220
1221 static List local maybeAppendVar(v,vs)  /* append variable to list if not  */
1222 Cell v;                                 /* already included                */
1223 List vs; {
1224     Text t = textOf(v);
1225     List p = NIL;
1226     List c = vs;
1227
1228     while (nonNull(c)) {
1229         if (textOf(hd(c))==t) {
1230             return vs;
1231         }
1232         p = c;
1233         c = tl(c);
1234     }
1235
1236     if (nonNull(p)) {
1237         tl(p) = cons(v,NIL);
1238     } else {
1239         vs    = cons(v,NIL);
1240     }
1241     return vs;
1242 }
1243
1244 /* --------------------------------------------------------------------------
1245  * Static analysis for type expressions is required to:
1246  *   - ensure that each type constructor or class used has been defined.
1247  *   - replace type variables by offsets, constructor names by Tycons.
1248  *   - ensure that the type is well-kinded.
1249  * ------------------------------------------------------------------------*/
1250
1251 static Type local checkSigType(line,where,e,type)
1252 Int    line;                            /* Check validity of type expr in  */
1253 String where;                           /* explicit type signature         */
1254 Cell   e;
1255 Type   type; {
1256     List tvs  = typeVarsIn(type,NIL,NIL);
1257     Int  n    = length(tvs);
1258     List sunk = unkindTypes;
1259
1260     if (whatIs(type)==QUAL) {
1261         map2Proc(depPredExp,line,tvs,fst(snd(type)));
1262         snd(snd(type)) = depTopType(line,tvs,snd(snd(type)));
1263
1264         if (isAmbiguous(type)) {
1265             ambigError(line,where,e,type);
1266         }
1267     } else {
1268         type = depTopType(line,tvs,type);
1269     }
1270     if (n>0) {
1271         if (n>=NUM_OFFSETS) {
1272             ERRMSG(line) "Too many type variables in %s\n", where
1273             EEND;
1274         } else {
1275             List ts = tvs;
1276             for (; nonNull(ts); ts=tl(ts)) {
1277                 hd(ts) = NIL;
1278             }
1279             type    = mkPolyType(tvs,type);
1280         }
1281     }
1282
1283     unkindTypes = NIL;
1284     kindType(line,"type expression",type);
1285     fixKinds();
1286     unkindTypes = sunk;
1287     return type;
1288 }
1289
1290 static Type local depTopType(l,tvs,t)   /* Check top-level of type sig     */
1291 Int  l;
1292 List tvs;
1293 Type t; {
1294     Type prev = NIL;
1295     Type t1   = t;
1296     Int  nr2  = 0;
1297     Int  i    = 1;
1298     for (; getHead(t1)==typeArrow; ++i) {
1299         arg(fun(t1)) = depCompType(l,tvs,arg(fun(t1)));
1300         if (isPolyType(arg(fun(t1)))) {
1301             nr2 = i;
1302         }
1303         prev = t1;
1304         t1   = arg(t1);
1305     }
1306     if (nonNull(prev)) {
1307         arg(prev) = depTypeExp(l,tvs,t1);
1308     } else {
1309         t = depTypeExp(l,tvs,t1);
1310     }
1311     if (nr2>0) {
1312         t = ap(RANK2,pair(mkInt(nr2),t));
1313     }
1314     return t;
1315 }
1316
1317 static Type local depCompType(l,tvs,t)  /* Check component type for constr */
1318 Int  l;
1319 List tvs;
1320 Type t; {
1321     if (isPolyType(t)) {
1322         Int  ntvs = length(tvs);
1323         List nfr  = NIL;
1324         if (isPolyType(t)) {
1325             List vs  = fst(snd(t));
1326             List bvs = typeVarsIn(monotypeOf(t),NIL,NIL);
1327             List us  = vs;
1328             for (; nonNull(us); us=tl(us)) {
1329                 Text u = textOf(hd(us));
1330                 if (varIsMember(u,tl(us))) {
1331                     ERRMSG(l) "Duplicated quantified variable %s",
1332                               textToStr(u)
1333                     EEND;
1334                 }
1335                 if (varIsMember(u,tvs)) {
1336                     ERRMSG(l) "Local quantifier for %s hides an outer use",
1337                               textToStr(u)
1338                     EEND;
1339                 }
1340                 if (!varIsMember(u,bvs)) {
1341                     ERRMSG(l) "Locally quantified variable %s is not used",
1342                               textToStr(u)
1343                     EEND;
1344                 }
1345             }
1346             nfr = replicate(length(vs),NIL);
1347             tvs = appendOnto(tvs,vs);
1348             t   = monotypeOf(t);
1349         }
1350         if (whatIs(t)==QUAL) {
1351             map2Proc(depPredExp,l,tvs,fst(snd(t)));
1352             snd(snd(t)) = depTypeExp(l,tvs,snd(snd(t)));
1353             if (isAmbiguous(t))
1354                 ambigError(l,"type component",NIL,t);
1355         } else {
1356             t = depTypeExp(l,tvs,t);
1357         }
1358         if (isNull(nfr)) {
1359             return t;
1360         }
1361         take(ntvs,tvs);
1362         return mkPolyType(nfr,t);
1363     } else {
1364         return depTypeExp(l,tvs,t);
1365     }
1366 }
1367
1368 static Type local depTypeExp(line,tyvars,type)
1369 Int  line;
1370 List tyvars;
1371 Type type; {
1372     switch (whatIs(type)) {
1373         case AP         : fst(type) = depTypeExp(line,tyvars,fst(type));
1374                           snd(type) = depTypeExp(line,tyvars,snd(type));
1375                           break;
1376
1377         case VARIDCELL  : return depTypeVar(line,tyvars,textOf(type));
1378
1379         case QUALIDENT  : if (isQVar(type)) {
1380                               ERRMSG(line) "Qualified type variables not allowed"
1381                               EEND;
1382                           }
1383                           /* deliberate fall through */
1384         case CONIDCELL  : {   Tycon tc = findQualTycon(type);
1385                               if (isNull(tc)) {
1386                                   ERRMSG(line)
1387                                       "Undefined type constructor \"%s\"",
1388                                       identToStr(type)
1389                                   EEND;
1390                               }
1391                               if (cellIsMember(tc,tyconDefns) &&
1392                                   !cellIsMember(tc,tcDeps)) {
1393                                   tcDeps = cons(tc,tcDeps);
1394                               }
1395                               return tc;
1396                           }
1397
1398 #if TREX
1399         case EXT        :
1400 #endif
1401         case TYCON      :
1402         case TUPLE      : break;
1403
1404         default         : internal("depTypeExp");
1405     }
1406     return type;
1407 }
1408
1409 static Type local depTypeVar(line,tyvars,tv)
1410 Int  line;
1411 List tyvars;
1412 Text tv; {
1413     Int  offset = 0;
1414     Cell vt     = findBtyvs(tv);
1415
1416     if (nonNull(vt)) {
1417         return fst(vt);
1418     }
1419     for (; nonNull(tyvars) && tv!=textOf(hd(tyvars)); offset++) {
1420         tyvars = tl(tyvars);
1421     }
1422     if (isNull(tyvars)) {
1423         ERRMSG(line) "Undefined type variable \"%s\"", textToStr(tv)
1424         EEND;
1425     }
1426     return mkOffset(offset);
1427 }
1428
1429 /* --------------------------------------------------------------------------
1430  * Check for ambiguous types:
1431  * A type  Preds => type  is ambiguous if not (TV(P) `subset` TV(type))
1432  * ------------------------------------------------------------------------*/
1433
1434 Bool isAmbiguous(type)                  /* Determine whether type is       */
1435 Type type; {                            /* ambiguous                       */
1436     if (isPolyType(type)) {
1437         type = monotypeOf(type);
1438     }
1439     if (whatIs(type)==QUAL) {           /* only qualified types can be     */
1440         List tvps = offsetTyvarsIn(fst(snd(type)),NIL); /* ambiguous       */
1441         List tvts = offsetTyvarsIn(snd(snd(type)),NIL);
1442         while (nonNull(tvps) && cellIsMember(hd(tvps),tvts)) {
1443             tvps = tl(tvps);
1444         }
1445         return nonNull(tvps);
1446     }
1447     return FALSE;
1448 }
1449
1450 Void ambigError(line,where,e,type)      /* produce error message for       */
1451 Int    line;                            /* ambiguity                       */
1452 String where;
1453 Cell   e;
1454 Type   type; {
1455     ERRMSG(line) "Ambiguous type signature in %s", where ETHEN
1456     ERRTEXT      "\n*** ambiguous type : " ETHEN ERRTYPE(type);
1457     if (nonNull(e)) {
1458         ERRTEXT  "\n*** assigned to    : " ETHEN ERREXPR(e);
1459     }
1460     ERRTEXT      "\n"
1461     EEND;
1462 }
1463
1464 /* --------------------------------------------------------------------------
1465  * Kind inference for simple types:
1466  * ------------------------------------------------------------------------*/
1467
1468 static Void local kindConstr(line,alpha,m,c)
1469 Int  line;                              /* Determine kind of constructor   */
1470 Int  alpha;
1471 Int  m;
1472 Cell c; {
1473     Cell h = getHead(c);
1474     Int  n = argCount;
1475
1476 #ifdef DEBUG_KINDS
1477     printf("kindConstr: alpha=%d, m=%d, c=",alpha,m);
1478     printType(stdout,c);
1479     printf("\n");
1480 #endif
1481
1482     switch (whatIs(h)) {
1483         case POLYTYPE : if (n!=0) {
1484                             internal("kindConstr1");
1485                         } else {
1486                             static String pt = "polymorphic type";
1487                             Type  t  = dropRank1(c,alpha,m);
1488                             Kinds ks = polySigOf(t);
1489                             Int   m1 = 0;
1490                             Int   beta;
1491                             for (; isAp(ks); ks=tl(ks))
1492                                 m1++;
1493                             beta        = newKindvars(m1);
1494                             unkindTypes = cons(pair(mkInt(beta),t),unkindTypes);
1495                             checkKind(line,beta,m1,monotypeOf(t),NIL,pt,STAR,0);
1496                         }
1497                         return;
1498
1499         case QUAL     : if (n!=0) {
1500                             internal("kindConstr2");
1501                         }
1502                         map3Proc(kindPred,line,alpha,m,fst(snd(c)));
1503                         kindConstr(line,alpha,m,snd(snd(c)));
1504                         return;
1505
1506         case EXIST    :
1507         case RANK2    : kindConstr(line,alpha,m,snd(snd(c)));
1508                         return;
1509
1510 #if TREX
1511         case EXT      : if (n!=2) {
1512                             ERRMSG(line)
1513                                 "Illegal use of row in " ETHEN ERRTYPE(c);
1514                             ERRTEXT "\n"
1515                             EEND;
1516                         }
1517                         break;
1518 #endif
1519
1520         case TYCON    : if (isSynonym(h) && n<tycon(h).arity) {
1521                             ERRMSG(line)
1522                               "Not enough arguments for type synonym \"%s\"",
1523                               textToStr(tycon(h).text)
1524                             EEND;
1525                         }
1526                         break;
1527     }
1528
1529     if (n==0) {                         /* trivial case, no arguments      */
1530         typeIs = kindAtom(alpha,c);
1531     } else {                              /* non-trivial application         */
1532         static String app = "constructor application";
1533         Cell   a = c;
1534         Int    i;
1535         Kind   k;
1536         Int    beta;
1537
1538         varKind(n);
1539         beta   = typeOff;
1540         k      = typeIs;
1541
1542         typeIs = kindAtom(alpha,h);     /* h  :: v1 -> ... -> vn -> w      */
1543         shouldKind(line,h,c,app,k,beta);
1544
1545         for (i=n; i>0; --i) {           /* ci :: vi for each 1 <- 1..n     */
1546             checkKind(line,alpha,m,arg(a),c,app,aVar,beta+i-1);
1547             a = fun(a);
1548         }
1549         tyvarType(beta+n);              /* inferred kind is w              */
1550     }
1551 }
1552
1553 static Kind local kindAtom(alpha,c)     /* Find kind of atomic constructor */
1554 Int  alpha;
1555 Cell c; {
1556     switch (whatIs(c)) {
1557         case TUPLE     : return simpleKind(tupleOf(c)); /*(,)::* -> * -> * */
1558         case OFFSET    : return mkInt(alpha+offsetOf(c));
1559         case TYCON     : return tycon(c).kind;
1560         case INTCELL   : return c;
1561         case VARIDCELL :
1562         case VAROPCELL : {   Cell vt = findBtyvs(textOf(c));
1563                              if (nonNull(vt)) {
1564                                  return snd(vt);
1565                              }
1566                          }
1567 #if TREX
1568         case EXT       : return extKind;
1569 #endif
1570     }
1571 #if DEBUG_KINDS
1572     printf("kindAtom(%d,whatIs(%d)) on ",alpha,whatIs(c));
1573     printType(stdout,c);
1574     printf("\n");
1575 #endif
1576     internal("kindAtom");
1577     return STAR;/* not reached */
1578 }
1579
1580 static Void local kindPred(l,alpha,m,pi)/* Check kinds of arguments in pred*/
1581 Int  l;
1582 Int  alpha;
1583 Int  m;
1584 Cell pi; {
1585 #if TREX
1586     if (isExt(fun(pi))) {
1587         static String lackspred = "lacks predicate";
1588         checkKind(l,alpha,m,arg(pi),NIL,lackspred,ROW,0);
1589         return;
1590     }
1591 #endif
1592     {   static String predicate = "class constraint";
1593         Class c  = getHead(pi);
1594         List  as = getArgs(pi);
1595         Kinds ks = cclass(c).kinds;
1596
1597         while (nonNull(ks)) {
1598             checkKind(l,alpha,m,hd(as),NIL,predicate,hd(ks),0);
1599             ks = tl(ks);
1600             as = tl(as);
1601         }
1602     }
1603 }
1604
1605 static Void local kindType(line,wh,type)/* check that (poss qualified) type*/
1606 Int    line;                            /* is well-kinded                  */
1607 String wh;
1608 Type   type; {
1609     checkKind(line,0,0,type,NIL,wh,STAR,0);
1610 }
1611
1612 static Void local fixKinds() {          /* add kind annotations to types   */
1613     for (; nonNull(unkindTypes); unkindTypes=tl(unkindTypes)) {
1614         Pair pr   = hd(unkindTypes);
1615         Int  beta = intOf(fst(pr));
1616         Cell qts  = polySigOf(snd(pr));
1617         for (;;) {
1618             if (isNull(hd(qts))) {
1619                 hd(qts) = copyKindvar(beta++);
1620             } else {
1621                 internal("fixKinds");
1622             }
1623             if (nonNull(tl(qts))) {
1624                 qts = tl(qts);
1625             } else {
1626                 tl(qts) = STAR;
1627                 break;
1628             }
1629         }
1630 #ifdef DEBUG_KINDS
1631         printf("Type expression: ");
1632         printType(stdout,snd(pr));
1633         printf(" :: ");
1634         printKind(stdout,polySigOf(snd(pr)));
1635         printf("\n");
1636 #endif
1637     }
1638 }
1639
1640 /* --------------------------------------------------------------------------
1641  * Kind checking of groups of type constructors and classes:
1642  * ------------------------------------------------------------------------*/
1643
1644 static Void local kindTCGroup(tcs)      /* find kinds for mutually rec. gp */
1645 List tcs; {                             /* of tycons and classes           */
1646     emptySubstitution();
1647     unkindTypes = NIL;
1648     mapProc(initTCKind,tcs);
1649     mapProc(kindTC,tcs);
1650     mapProc(genTC,tcs);
1651     fixKinds();
1652     emptySubstitution();
1653 }
1654
1655 static Void local initTCKind(c)         /* build initial kind/arity for c  */
1656 Cell c; {
1657     if (isTycon(c)) {                   /* Initial kind of tycon is:       */
1658         Int beta = newKindvars(1);      /*    v1 -> ... -> vn -> vn+1      */
1659         varKind(tycon(c).arity);        /* where n is the arity of c.      */
1660         bindTv(beta,typeIs,typeOff);    /* For data definitions, vn+1 == * */
1661         switch (whatIs(tycon(c).what)) {
1662             case NEWTYPE  :
1663             case DATATYPE : bindTv(typeOff+tycon(c).arity,STAR,0);
1664         }
1665         tycon(c).kind = mkInt(beta);
1666     } else {
1667         Int n    = cclass(c).arity;
1668         Int beta = newKindvars(n);
1669         cclass(c).kinds = NIL;
1670         do {
1671             n--;
1672             cclass(c).kinds = pair(mkInt(beta+n),cclass(c).kinds);
1673         } while (n>0);
1674     }
1675 }
1676
1677 static Void local kindTC(c)             /* check each part of a tycon/class*/
1678 Cell c; {                               /* is well-kinded                  */
1679     if (isTycon(c)) {
1680         static String cfun = "constructor function";
1681         static String tsyn = "synonym definition";
1682         Int line = tycon(c).line;
1683         Int beta = tyvar(intOf(tycon(c).kind))->offs;
1684         Int m    = tycon(c).arity;
1685         switch (whatIs(tycon(c).what)) {
1686             case NEWTYPE     :
1687             case DATATYPE    : {   List cs = tycon(c).defn;
1688                                    if (whatIs(cs)==QUAL) {
1689                                        map3Proc(kindPred,line,beta,m,
1690                                                                 fst(snd(cs)));
1691                                        tycon(c).defn = cs = snd(snd(cs));
1692                                    }
1693                                    for (; hasCfun(cs); cs=tl(cs)) {
1694                                        kindType(line,cfun,name(hd(cs)).type);
1695                                    }
1696                                    break;
1697                                }
1698
1699             default          : checkKind(line,beta,m,tycon(c).defn,NIL,
1700                                                         tsyn,aVar,beta+m);
1701         }
1702     }
1703     else {                              /* scan type exprs in class defn to*/
1704         List ms   = cclass(c).members;  /* determine the class signature   */
1705         Int  m    = cclass(c).arity;
1706         Int  beta = newKindvars(m);
1707         kindPred(cclass(c).line,beta,m,cclass(c).head);
1708         map3Proc(kindPred,cclass(c).line,beta,m,cclass(c).supers);
1709         for (; nonNull(ms); ms=tl(ms)) {
1710             Int  line = intOf(fst3(hd(ms)));
1711             Type type = thd3(hd(ms));
1712             kindType(line,"member function type signature",type);
1713         }
1714     }
1715 }
1716
1717 static Void local genTC(c)              /* generalise kind inferred for    */
1718 Cell c; {                               /* given tycon/class               */
1719     if (isTycon(c)) {
1720         tycon(c).kind = copyKindvar(intOf(tycon(c).kind));
1721 #ifdef DEBUG_KINDS
1722         printf("%s :: ",textToStr(tycon(c).text));
1723         printKind(stdout,tycon(c).kind);
1724         putchar('\n');
1725 #endif
1726     } else {
1727         Kinds ks = cclass(c).kinds;
1728         for (; nonNull(ks); ks=tl(ks)) {
1729             hd(ks) = copyKindvar(intOf(hd(ks)));
1730         }
1731 #ifdef DEBUG_KINDS
1732         printf("%s :: ",textToStr(cclass(c).text));
1733         printKinds(stdout,cclass(c).kinds);
1734         putchar('\n');
1735 #endif
1736     }
1737 }
1738
1739 /* --------------------------------------------------------------------------
1740  * Static analysis of instance declarations:
1741  *
1742  * The first part of the static analysis is performed as the declarations
1743  * are read during parsing:
1744  * - make new entry in instance table
1745  * - record line number of declaration
1746  * - build list of instances defined in current script for use in later
1747  *   stages of static analysis.
1748  * ------------------------------------------------------------------------*/
1749
1750 Void instDefn(line,head,ms)             /* process new instance definition */
1751 Int  line;                              /* definition line number          */
1752 Cell head;                              /* inst header :: (context,Class)  */
1753 List ms; {                              /* instance members                */
1754     Inst nw             = newInst();
1755     inst(nw).line       = line;
1756     inst(nw).specifics  = fst(head);
1757     inst(nw).head       = snd(head);
1758     inst(nw).implements = ms;
1759     instDefns           = cons(nw,instDefns);
1760 }
1761
1762 /* --------------------------------------------------------------------------
1763  * Further static analysis of instance declarations:
1764  *
1765  * Makes the following checks:
1766  * - Class part of header has form C (T a1 ... an) where C is a known
1767  *   class, and T is a known datatype constructor (or restricted synonym),
1768  *   and there is no previous C-T instance, and (T a1 ... an) has a kind
1769  *   appropriate for the class C.
1770  * - Each element of context is a valid class expression, with type vars
1771  *   drawn from a1, ..., an.
1772  * - All bindings are function bindings
1773  * - All bindings define member functions for class C
1774  * - Arrange bindings into appropriate order for member list
1775  * - No top level type signature declarations
1776  * ------------------------------------------------------------------------*/
1777
1778 Bool allowOverlap = FALSE;              /* TRUE => allow overlapping insts */
1779
1780 static Void local checkInstDefn(in)     /* Validate instance declaration   */
1781 Inst in; {
1782     Int  line   = inst(in).line;
1783     List tyvars = typeVarsIn(inst(in).head,NIL,NIL);
1784
1785     depPredExp(line,tyvars,inst(in).head);
1786     map2Proc(depPredExp,line,tyvars,inst(in).specifics);
1787     inst(in).numSpecifics = length(inst(in).specifics);
1788     inst(in).c            = getHead(inst(in).head);
1789     if (!isClass(inst(in).c)) {
1790         ERRMSG(line) "Illegal predicate in instance declaration"
1791         EEND;
1792     }
1793 #if EVAL_INSTANCES
1794     if (inst(in).c==classEval) {
1795         ERRMSG(line) "Instances of class \"%s\" are generated automatically",
1796                      textToStr(cclass(inst(in).c).text)
1797         EEND;
1798     }
1799 #endif
1800     kindInst(in,length(tyvars));
1801     insertInst(in);
1802
1803     if (nonNull(extractSigdecls(inst(in).implements))) {
1804         ERRMSG(line) "Type signature decls not permitted in instance decl"
1805         EEND;
1806     }
1807     inst(in).implements = classBindings("instance",
1808                                         inst(in).c,
1809                                         extractBindings(inst(in).implements));
1810     inst(in).builder    = newInstImp(in);
1811 }
1812
1813 static Void local insertInst(in)        /* Insert instance into class      */
1814 Inst in; {
1815     Class c    = inst(in).c;
1816     List  ins  = cclass(c).instances;
1817     List  prev = NIL;
1818
1819     substitution(RESET);
1820     while (nonNull(ins)) {              /* Look for overlap w/ other insts */
1821         Int alpha = newKindedVars(inst(in).kinds);
1822         Int beta  = newKindedVars(inst(hd(ins)).kinds);
1823         if (unifyPred(inst(in).head,alpha,inst(hd(ins)).head,beta)) {
1824             Cell pi  = copyPred(inst(in).head,alpha);
1825             if (allowOverlap) {         /* So long as one is more specific */
1826                 Bool bef = instCompare(in,hd(ins));
1827                 Bool aft = instCompare(hd(ins),in);
1828                 if (bef && !aft) {      /* in comes strictly before hd(ins)*/
1829                     break;
1830                 }
1831                 if (aft && !bef) {      /* in comes strictly after hd(ins) */
1832                     prev = ins;
1833                     ins  = tl(ins);
1834                     continue;
1835                 }
1836             }
1837             ERRMSG(inst(in).line) "Overlapping instances for class \"%s\"",
1838                                   textToStr(cclass(c).text)
1839             ETHEN
1840             ERRTEXT "\n*** This instance   : " ETHEN ERRPRED(inst(in).head);
1841             ERRTEXT "\n*** Overlaps with   : " ETHEN
1842                                                ERRPRED(inst(hd(ins)).head);
1843             ERRTEXT "\n*** Common instance : " ETHEN
1844                                                ERRPRED(pi);
1845             ERRTEXT "\n"
1846             EEND;
1847         }
1848         prev = ins;                     /* No overlap detected, so move on */
1849         ins  = tl(ins);                 /* to next instance                */
1850     }
1851     substitution(RESET);
1852
1853     if (nonNull(prev)) {                /* Insert instance at this point   */
1854         tl(prev) = cons(in,ins);
1855     } else {
1856         cclass(c).instances = cons(in,ins);
1857     }
1858 }
1859
1860 static Bool local instCompare(ia,ib)    /* See if ia is an instance of ib  */
1861 Inst ia, ib;{
1862     Int alpha = newKindedVars(inst(ia).kinds);
1863     Int beta  = newKindedVars(inst(ib).kinds);
1864     return matchPred(inst(ia).head,alpha,inst(ib).head,beta);
1865 }
1866
1867 static Name local newInstImp(in)        /* Make definition for inst builder*/
1868 Inst in; {
1869     Name b         = newName(inventText());
1870     name(b).line   = inst(in).line;
1871     name(b).arity  = inst(in).numSpecifics;
1872     name(b).number = DFUNNAME;
1873     return b;
1874 }
1875
1876 /* --------------------------------------------------------------------------
1877  * Kind checking of instance declaration headers:
1878  * ------------------------------------------------------------------------*/
1879
1880 static Void local kindInst(in,freedom)  /* check predicates in instance    */
1881 Inst in;
1882 Int  freedom; {
1883     Int beta;
1884
1885     emptySubstitution();
1886     beta = newKindvars(freedom);
1887     kindPred(inst(in).line,beta,freedom,inst(in).head);
1888     if (whatIs(inst(in).specifics)!=DERIVE) {
1889         map3Proc(kindPred,inst(in).line,beta,freedom,inst(in).specifics);
1890     }
1891     for (inst(in).kinds = NIL; 0<freedom--; ) {
1892         inst(in).kinds = cons(copyKindvar(beta+freedom),inst(in).kinds);
1893     }
1894 #ifdef DEBUG_KINDS
1895     printf("instance ");
1896     printPred(stdout,inst(in).head);
1897     printf(" :: ");
1898     printKinds(stdout,inst(in).kinds);
1899     putchar('\n');
1900 #endif
1901     emptySubstitution();
1902 }
1903
1904 /* --------------------------------------------------------------------------
1905  * Process derived instance requests:
1906  * ------------------------------------------------------------------------*/
1907
1908 static List derivedInsts;               /* list of derived instances       */
1909
1910 static Void local checkDerive(t,p,ts,ct)/* verify derived instance request */
1911 Tycon t;                                /* for tycon t, with explicit      */
1912 List  p;                                /* context p, component types ts   */
1913 List  ts;                               /* and named class ct              */
1914 Cell  ct; {
1915     Int   line = tycon(t).line;
1916     Class c    = findClass(textOf(ct));
1917     if (isNull(c)) {
1918         ERRMSG(line) "Unknown class \"%s\" in derived instance",
1919                      textToStr(textOf(ct))
1920         EEND;
1921     }
1922     addDerInst(line,c,p,dupList(ts),t,tycon(t).arity);
1923 }
1924
1925 static Void local addDerInst(line,c,p,cts,t,a)  /* Add a derived instance  */
1926 Int   line;
1927 Class c;
1928 List  p, cts;
1929 Type  t;
1930 Int   a; {
1931     Inst in;
1932     Cell head = t;                              /* Build instance head     */
1933     Int  i    = 0;
1934
1935     for (; i<a; i++) {
1936         head = ap(head,mkOffset(i));
1937     }
1938     head = ap(c,head);
1939
1940     in                  = newInst();
1941     inst(in).c          = c;
1942     inst(in).line       = line;
1943     inst(in).head       = head;
1944     inst(in).specifics  = ap(DERIVE,pair(dupList(p),cts));
1945     inst(in).implements = NIL;
1946     inst(in).kinds      = mkInt(a);
1947     derivedInsts        = cons(in,derivedInsts);
1948 }
1949
1950 Void addTupInst(c,n)                    /* Request derived instance of c   */
1951 Class c;                                /* for mkTuple(n) constructor      */
1952 Int   n; {
1953     Int  m   = n;
1954     List cts = NIL;
1955     while (0<m--) {
1956         cts = cons(mkOffset(m),cts);
1957     }
1958     cts = rev(cts);
1959     addDerInst(0,c,NIL,cts,mkTuple(n),n);
1960 }
1961
1962 #if EVAL_INSTANCES
1963 /* ADR addition */
1964 static List evalInsts = NIL;
1965
1966 Void addEvalInst(line,t,arity,ctxt)     /* Add dummy instance for Eval     */
1967 Int  line;
1968 Cell t;
1969 Int  arity;
1970 List ctxt; {
1971     Inst in   = newInst();
1972     Cell head = t;
1973     Int  i;
1974     for (i=0; i<arity; i++) {
1975         head = ap(head,mkOffset(i));
1976     }
1977     inst(in).line         = line;
1978     inst(in).c            = classEval;
1979     inst(in).head         = ap(classEval,head);
1980     inst(in).specifics    = ctxt;
1981     inst(in).builder      = newInstImp(in);
1982     inst(in).numSpecifics = length(ctxt);
1983     kindInst(in,arity);
1984     cclass(classEval).instances
1985              = appendOnto(cclass(classEval).instances,singleton(in));
1986     /* ADR addition */
1987     evalInsts             = cons(in,evalInsts);
1988 }
1989 #endif
1990
1991 #if TREX
1992 Inst addRecShowInst(c,e)                /* Generate instance for ShowRecRow*/
1993 Class c;                                /* c *must* be ShowRecRow          */
1994 Ext   e; {
1995     Inst in               = newInst();
1996     inst(in).c            = c;
1997     inst(in).head         = ap(c,ap2(e,mkOffset(0),mkOffset(1)));
1998     inst(in).kinds        = extKind;
1999     inst(in).specifics    = cons(ap(classShow,mkOffset(0)),
2000                                  cons(ap(e,mkOffset(1)),
2001                                       cons(ap(c,mkOffset(1)),NIL)));
2002     inst(in).numSpecifics = 3;
2003     inst(in).builder      = implementRecShw(extText(e));
2004     cclass(c).instances   = appendOnto(cclass(c).instances,singleton(in));
2005     return in;
2006 }
2007
2008 Inst addRecEqInst(c,e)                  /* Generate instance for EqRecRow  */
2009 Class c;                                /* c *must* be EqRecRow            */
2010 Ext   e; {
2011     Inst in               = newInst();
2012     inst(in).c            = c;
2013     inst(in).head         = ap(c,ap2(e,mkOffset(0),mkOffset(1)));
2014     inst(in).kinds        = extKind;
2015     inst(in).specifics    = cons(ap(classEq,mkOffset(0)),
2016                                  cons(ap(e,mkOffset(1)),
2017                                       cons(ap(c,mkOffset(1)),NIL)));
2018     inst(in).numSpecifics = 3;
2019     inst(in).builder      = implementRecEq(extText(e));
2020     cclass(c).instances   = appendOnto(cclass(c).instances,singleton(in));
2021     return in;
2022 }
2023 #endif
2024
2025 /* --------------------------------------------------------------------------
2026  * Calculation of contexts for derived instances:
2027  *
2028  * Allowing arbitrary types to appear in contexts makes it rather harder
2029  * to decide what the context for a derived instance should be.  For
2030  * example, given:
2031  *
2032  *    data T a = MkT [a] deriving Show,
2033  *
2034  * we could have either of the following:
2035  *
2036  *    instance (Show [a]) => Show (T a) where ...
2037  *    instance (Show a) => Show (T a) where ...
2038  *
2039  * (assuming, of course, that instance (Show a) => Show [a]).  For now, we
2040  * choose to reduce contexts in the hope of detecting errors at an earlier
2041  * stage---in contrast with value definitions, there is no way for a user
2042  * to provide something analogous to a `type signature' by which they might
2043  * be able to control this behaviour themselves.  We eliminate tautological
2044  * predicates, but only allow predicates to appear in the final result if
2045  * they have at least one argument with a variable at its head.
2046  *
2047  * In general, we have to deal with mutually recursive instance declarations.
2048  * We find a solution in the obvious way by iterating to find a fixed point.
2049  * Of course, without restrictions on the form of instance declarations, we
2050  * cannot be sure that this will always terminate!
2051  *
2052  * For each instance we maintain a pair of the form DERIVE (ctxt,ps).
2053  * Ctxt is a list giving the parts of the context that have been produced
2054  * so far in the form of predicate skeletons.  During the calculation of
2055  * derived instances, we attach a dummy NIL value to the end of the list
2056  * which acts as a kind of `variable': other parts of the system maintain
2057  * pointers to this variable, and use it to detect when the context has
2058  * been extended with new elements.  Meanwhile, ps is a list containing
2059  * predicates (pi,o) together with (delayed) substitutions of the form
2060  * (o,xs) where o is an offset and xs is one of the context variables
2061  * described above, which may have been partially instantiated.
2062  * ------------------------------------------------------------------------*/
2063
2064 static Bool instsChanged;
2065
2066 static Void local deriveContexts(is)    /* Calc contexts for derived insts */
2067 List is; {
2068     emptySubstitution();
2069     mapProc(initDerInst,is);            /* Prepare derived instances       */
2070
2071     do {                                /* Main calculation of contexts    */
2072         instsChanged = FALSE;
2073         mapProc(calcInstPreds,is);
2074     } while (instsChanged);
2075
2076     mapProc(tidyDerInst,is);            /* Tidy up results                 */
2077 #if DERIVE_SHOW | DERIVE_READ
2078     cfunSfuns = NIL;                    /* Only needed to derive Read/Show */
2079 #endif
2080 }
2081
2082 static Void local initDerInst(in)       /* Prepare instance for calculation*/
2083 Inst in; {                              /* of derived instance context     */
2084     Cell spcs = inst(in).specifics;
2085     Int  beta = newKindedVars(inst(in).kinds);
2086     if (whatIs(spcs)!=DERIVE) {
2087         internal("initDerInst");
2088     }
2089     fst(snd(spcs)) = appendOnto(fst(snd(spcs)),singleton(NIL));
2090     for (spcs=snd(snd(spcs)); nonNull(spcs); spcs=tl(spcs)) {
2091         hd(spcs) = ap2(inst(in).c,hd(spcs),mkInt(beta));
2092     }
2093     inst(in).numSpecifics = beta;
2094
2095 #ifdef DEBUG_DERIVING
2096     printf("initDerInst: ");
2097     printPred(stdout,inst(in).head);
2098     printf("\n");
2099     printContext(stdout,snd(snd(inst(in).specifics)));
2100     printf("\n");
2101 #endif
2102 }
2103
2104 static Void local calcInstPreds(in)     /* Calculate next approximation    */
2105 Inst in; {                              /* of the context for a derived    */
2106     List retain = NIL;                  /* instance                        */
2107     List ps     = snd(snd(inst(in).specifics));
2108     List spcs   = fst(snd(inst(in).specifics));
2109     Int  beta   = inst(in).numSpecifics;
2110
2111 #ifdef DEBUG_DERIVING
2112     printf("calcInstPreds: ");
2113     printPred(stdout,inst(in).head);
2114     printf("\n");
2115 #endif
2116
2117     while (nonNull(ps)) {
2118         Cell p = hd(ps);
2119         ps     = tl(ps);
2120         if (isInt(fst(p))) {                    /* Delayed substitution?   */
2121             List qs = snd(p);
2122             for (; nonNull(hd(qs)); qs=tl(qs)) {
2123                 ps = cons(pair(hd(qs),fst(p)),ps);
2124             }
2125             retain = cons(pair(fst(p),qs),retain);
2126         }
2127 #if TREX
2128         else if (isExt(fun(fst(p)))) {          /* Lacks predicate         */
2129             Text   l = extText(fun(fst(p)));
2130             Type   t = arg(fst(p));
2131             Int    o = intOf(snd(p));
2132             Type   h;
2133             Tyvar *tyv;
2134
2135             deRef(tyv,t,o);
2136             h = getDerefHead(t,o);
2137             while (isExt(h) && argCount==2 && l!=extText(h)) {
2138                 t = arg(t);
2139                 deRef(tyv,t,o);
2140                 h = getDerefHead(t,o);
2141             }
2142             if (argCount==0 && isOffset(h)) {
2143                 maybeAddPred(ap(fun(fun(p)),h),o,beta,spcs);
2144             } else if (argCount!=0 || h!=typeNoRow) {
2145                 Cell bpi = inst(in).head;
2146                 Cell pi  = copyPred(fun(p),intOf(snd(p)));
2147                 ERRMSG(inst(in).line) "Cannot derive " ETHEN ERRPRED(bpi);
2148                 ERRTEXT " because predicate " ETHEN ERRPRED(pi);
2149                 ERRTEXT " does not hold\n"
2150                 EEND;
2151             }
2152         }
2153 #endif
2154         else {                                  /* Class predicate         */
2155             Cell pi  = fst(p);
2156             Int  o   = intOf(snd(p));
2157             Inst in1 = findInstFor(pi,o);
2158             if (nonNull(in1)) {
2159                 List qs  = inst(in1).specifics;
2160                 Int  off = mkInt(typeOff);
2161                 if (whatIs(qs)==DERIVE) {       /* Still being derived     */
2162                     for (qs=fst(snd(qs)); nonNull(hd(qs)); qs=tl(qs))
2163                         ps = cons(pair(hd(qs),off),ps);
2164                     retain = cons(pair(off,qs),retain);
2165                 } else {                        /* Previously def'd inst   */
2166                     for (; nonNull(qs); qs=tl(qs)) {
2167                         ps = cons(pair(hd(qs),off),ps);
2168                     }
2169                 }
2170             } else {                            /* No matching instance    */
2171                 Cell qi = pi;
2172                 while (isAp(qi) && isOffset(getDerefHead(arg(qi),o))) {
2173                     qi = fun(qi);
2174                 }
2175                 if (isAp(qi)) {
2176                     Cell bpi = inst(in).head;
2177                     pi       = copyPred(pi,o);
2178                     ERRMSG(inst(in).line) "An instance of " ETHEN ERRPRED(pi);
2179                     ERRTEXT " is required to derive "       ETHEN ERRPRED(bpi);
2180                     ERRTEXT "\n"
2181                     EEND;
2182                 } else {
2183                     maybeAddPred(pi,o,beta,spcs);
2184                 }
2185             }
2186         }
2187     }
2188     snd(snd(inst(in).specifics)) = retain;
2189 }
2190
2191 static Void local maybeAddPred(pi,o,beta,ps)
2192 Cell pi;                                /* Add predicate pi to the list ps,*/
2193 Int  o;                                 /* setting the instsChanged flag if*/
2194 Int  beta;                              /* pi is not already a member and  */
2195 List ps; {                              /* using beta to adjust vars       */
2196     Cell c = getHead(pi);
2197     for (; nonNull(ps); ps=tl(ps)) {
2198         if (isNull(hd(ps))) {           /* reached the `dummy' end of list?*/
2199             hd(ps)       = copyAdj(pi,o,beta);
2200             tl(ps)       = pair(NIL,NIL);
2201             instsChanged = TRUE;
2202             return;
2203         } else if (c==getHead(hd(ps)) && samePred(pi,o,hd(ps),beta)) {
2204             return;
2205         }
2206     }
2207 }
2208
2209 static Cell local copyAdj(c,o,beta)     /* Copy (c,o), replacing vars with */
2210 Cell c;                                 /* offsets relative to beta.       */
2211 Int  o;
2212 Int  beta; {
2213     switch (whatIs(c)) {
2214         case AP     : {   Cell l = copyAdj(fst(c),o,beta);
2215                           Cell r = copyAdj(snd(c),o,beta);
2216                           return ap(l,r);
2217                       }
2218
2219         case OFFSET : {   Int   vn   = o+offsetOf(c);
2220                           Tyvar *tyv = tyvar(vn);
2221                           if (isBound(tyv)) {
2222                               return copyAdj(tyv->bound,tyv->offs,beta);
2223                           }
2224                           vn -= beta;
2225                           if (vn<0 || vn>=NUM_OFFSETS) {
2226                               internal("copyAdj");
2227                           }
2228                           return mkOffset(vn);
2229                       }
2230     }
2231     return c;
2232 }
2233
2234 static Void local tidyDerInst(in)       /* Tidy up results of derived inst */
2235 Inst in; {                              /* calculations                    */
2236     Int  o  = inst(in).numSpecifics;
2237     List ps = tl(rev(fst(snd(inst(in).specifics))));
2238     clearMarks();
2239     copyPred(inst(in).head,o);
2240     inst(in).specifics    = simpleContext(ps,o);
2241     inst(in).numSpecifics = length(inst(in).specifics);
2242
2243 #ifdef DEBUG_DERIVING
2244     printf("Derived instance: ");
2245     printContext(stdout,inst(in).specifics);
2246     printf(" ||- ");
2247     printPred(stdout,inst(in).head);
2248     printf("\n");
2249 #endif
2250 }
2251
2252 /* --------------------------------------------------------------------------
2253  * Generate code for derived instances:
2254  * ------------------------------------------------------------------------*/
2255
2256 static Void local addDerivImp(in)
2257 Inst in; {
2258     List  imp = NIL;
2259     Type  t   = getHead(arg(inst(in).head));
2260     Class c   = inst(in).c;
2261 #if DERIVE_EQ
2262     if (c==classEq)
2263         imp = deriveEq(t);
2264     else
2265 #endif
2266 #if DERIVE_ORD
2267     if (c==classOrd)
2268         imp = deriveOrd(t);
2269     else
2270 #endif
2271 #if DERIVE_ENUM
2272     if (c==classEnum)
2273         imp = deriveEnum(t);
2274     else
2275 #endif
2276 #if DERIVE_IX
2277     if (c==classIx)
2278         imp = deriveIx(t);
2279     else
2280 #endif
2281 #if DERIVE_SHOW
2282     if (c==classShow)
2283         imp = deriveShow(t);
2284     else
2285 #endif
2286 #if DERIVE_READ
2287     if (c==classRead)
2288         imp = deriveRead(t);
2289     else
2290 #endif
2291 #if DERIVE_BOUNDED
2292     if (c==classBounded)
2293         imp = deriveBounded(t);
2294     else
2295 #endif
2296     {
2297         ERRMSG(inst(in).line) "Cannot derive instances of class \"%s\"",
2298                               textToStr(cclass(inst(in).c).text)
2299         EEND;
2300     }
2301
2302     kindInst(in,intOf(inst(in).kinds));
2303     insertInst(in);
2304     inst(in).builder    = newInstImp(in);
2305     inst(in).implements = classBindings("derived instance",
2306                                         inst(in).c,
2307                                         imp);
2308 }
2309
2310 /* --------------------------------------------------------------------------
2311  * Default definitions; only one default definition is permitted in a
2312  * given script file.  If no default is supplied, then a standard system
2313  * default will be used where necessary.
2314  * ------------------------------------------------------------------------*/
2315
2316 Void defaultDefn(line,defs)             /* Handle default types definition */
2317 Int  line;
2318 List defs; {
2319     if (defaultLine!=0) {
2320         ERRMSG(line) "Multiple default declarations are not permitted in" ETHEN
2321         ERRTEXT     "a single script file.\n"
2322         EEND;
2323     }
2324     defaultDefns = defs;
2325     defaultLine  = line;
2326 }
2327
2328 static Void local checkDefaultDefns() { /* check that default types are    */
2329     List ds = NIL;                      /* well-kinded instances of Num    */
2330
2331     if (defaultLine!=0) {
2332         map2Over(depTypeExp,defaultLine,NIL,defaultDefns);
2333         emptySubstitution();
2334         unkindTypes = NIL;
2335         map2Proc(kindType,defaultLine,"default type",defaultDefns);
2336         fixKinds();
2337         emptySubstitution();
2338         mapOver(fullExpand,defaultDefns);
2339     } else {
2340         defaultDefns = stdDefaults;
2341     }
2342     for (ds=defaultDefns; nonNull(ds); ds=tl(ds)) {
2343         if (isNull(provePred(NIL,NIL,ap(classNum,hd(ds))))) {
2344             ERRMSG(defaultLine)
2345                 "Default types must be instances of the Num class"
2346             EEND;
2347         }
2348     }
2349 }
2350
2351 /* --------------------------------------------------------------------------
2352  * Foreign import declarations are Hugs' equivalent of GHC's ccall mechanism.
2353  * They are used to "import" C functions into a module.
2354  * They are usually not written by hand but, rather, generated automatically
2355  * by GreenCard, IDL compilers or whatever.
2356  *
2357  * Foreign export declarations generate C wrappers for Hugs functions.
2358  * Hugs only provides "foreign export dynamic" because it's not obvious
2359  * what "foreign export static" would mean in an interactive setting.
2360  * ------------------------------------------------------------------------*/
2361
2362 Void foreignImport(line,extName,intName,type) /* Handle foreign imports    */
2363 Cell line;
2364 Pair extName;
2365 Cell intName;
2366 Cell type; {
2367     Text t = textOf(intName);
2368     Name n = findName(t);
2369     Int  l = intOf(line);
2370
2371     if (isNull(n)) {
2372         n = newName(t);
2373     } else if (name(n).defn!=PREDEFINED) {
2374         ERRMSG(l) "Redeclaration of foreign \"%s\"", textToStr(t)
2375         EEND;
2376     }
2377     name(n).line = l;
2378     name(n).defn = extName;
2379     name(n).type = type;
2380     foreignImports = cons(n,foreignImports);
2381 }
2382
2383 static Void local checkForeignImport(p)   /* Check foreign import          */
2384 Name p; {
2385     emptySubstitution();
2386     name(p).type = checkSigType(name(p).line,
2387                                 "foreign import declaration",
2388                                 p,
2389                                 name(p).type);
2390     /* We don't expand synonyms here because we don't want the IO
2391      * part to be expanded.
2392      * name(p).type = fullExpand(name(p).type);
2393      */
2394     implementForeignImport(p);
2395 }
2396
2397 Void foreignExport(line,extName,intName,type)/* Handle foreign exports    */
2398 Cell line;
2399 Cell extName;
2400 Cell intName;
2401 Cell type; {
2402     Text t = textOf(intName);
2403     Name n = findName(t);
2404     Int  l = intOf(line);
2405
2406     if (isNull(n)) {
2407         n = newName(t);
2408     } else if (name(n).defn!=PREDEFINED) {
2409         ERRMSG(l) "Redeclaration of foreign \"%s\"", textToStr(t)
2410         EEND;
2411     }
2412     name(n).line = l;
2413     name(n).defn = NIL;  /* nothing to say */
2414     name(n).type = type;
2415     foreignExports = cons(n,foreignExports);
2416 }
2417
2418 static Void local checkForeignExport(p)       /* Check foreign export      */
2419 Name p; {
2420     emptySubstitution();
2421     name(p).type = checkSigType(name(p).line,
2422                                 "foreign export declaration",
2423                                 p,
2424                                 name(p).type);
2425     implementForeignExport(p);
2426 }
2427
2428 /* --------------------------------------------------------------------------
2429  * Static analysis of patterns:
2430  *
2431  * Patterns are parsed as ordinary (atomic) expressions.  Static analysis
2432  * makes the following checks:
2433  *  - Patterns are well formed (according to pattern syntax), including the
2434  *    special case of (n+k) patterns.
2435  *  - All constructor functions have been defined and are used with the
2436  *    correct number of arguments.
2437  *  - No variable name is used more than once in a pattern.
2438  *
2439  * The list of pattern variables occuring in each pattern is accumulated in
2440  * a global list `patVars', which must be initialised to NIL at appropriate
2441  * points before using these routines to check for valid patterns.  This
2442  * mechanism enables the pattern checking routine to be mapped over a list
2443  * of patterns, ensuring that no variable occurs more than once in the
2444  * complete pattern list (as is required on the lhs of a function defn).
2445  * ------------------------------------------------------------------------*/
2446
2447 static List patVars;                    /* List of vars bound in pattern   */
2448
2449 static Cell local checkPat(line,p)      /* Check valid pattern syntax      */
2450 Int  line;
2451 Cell p; {
2452     switch (whatIs(p)) {
2453         case VARIDCELL :
2454         case VAROPCELL : addPatVar(line,p);
2455                          break;
2456
2457         case AP        : return checkMaybeCnkPat(line,p);
2458
2459         case NAME      :
2460         case QUALIDENT :
2461         case CONIDCELL :
2462         case CONOPCELL : return checkApPat(line,0,p);
2463
2464         case WILDCARD  :
2465         case STRCELL   :
2466         case CHARCELL  :
2467         case INTCELL   :
2468         case BIGCELL   :
2469         case FLOATCELL : break;
2470
2471         case ASPAT     : addPatVar(line,fst(snd(p)));
2472                          snd(snd(p)) = checkPat(line,snd(snd(p)));
2473                          break;
2474
2475         case LAZYPAT   : snd(p) = checkPat(line,snd(p));
2476                          break;
2477
2478         case FINLIST   : map1Over(checkPat,line,snd(p));
2479                          break;
2480
2481         case CONFLDS   : depConFlds(line,p,TRUE);
2482                          break;
2483
2484         case ESIGN     : {   Type t   = snd(snd(p));
2485                              List tvs = typeVarsIn(t,NIL,NIL);
2486                              for (; nonNull(tvs); tvs=tl(tvs)) {
2487                                  Int beta    = newKindvars(1);
2488                                  hd(btyvars) = cons(pair(hd(tvs),mkInt(beta)),
2489                                                     hd(btyvars));
2490                              }
2491                              t = checkSigType(line,
2492                                               "pattern type",
2493                                               fst(snd(p)),
2494                                               t);
2495                              if (isPolyType(t)
2496                                  || whatIs(t)==QUAL
2497                                  || whatIs(t)==RANK2) {
2498                                  ERRMSG(line)
2499                                   "Illegal type in pattern annotation"
2500                                  EEND;
2501                              }
2502                              snd(snd(p)) = t;
2503                              fst(snd(p)) = checkPat(line,fst(snd(p)));
2504                          }
2505                          break;
2506
2507         default        : ERRMSG(line) "Illegal pattern syntax"
2508                          EEND;
2509     }
2510     return p;
2511 }
2512
2513 static Cell local checkMaybeCnkPat(l,p) /* Check applicative pattern with  */
2514 Int  l;                                 /* the possibility of n+k pattern  */
2515 Cell p; {
2516 #if NPLUSK
2517     Cell h = getHead(p);
2518
2519     if (argCount==2 && isVar(h) && textOf(h)==textPlus) {       /* n+k     */
2520         Cell v = arg(fun(p));
2521         if (!isInt(arg(p)) && !isBignum(arg(p))) {
2522                 ERRMSG(l) "Second argument in (n+k) pattern must be an integer"
2523                 EEND;
2524         }
2525 #if 0 /* can't call intOf - it might be a bignum */
2526         if (intOf(arg(p))<=0) {
2527                 ERRMSG(l) "Integer k in (n+k) pattern must be > 0"
2528                 EEND;
2529         }
2530 #endif
2531         overwrite2(fun(p),ADDPAT,arg(p));
2532         arg(p)           = checkPat(l,v);
2533         return p;
2534     }
2535 #endif
2536     return checkApPat(l,0,p);
2537 }
2538
2539 static Cell local checkApPat(line,args,p)
2540 Int  line;                              /* check validity of application   */
2541 Int  args;                              /* of constructor to arguments     */
2542 Cell p; {
2543     switch (whatIs(p)) {
2544         case AP        : fun(p) = checkApPat(line,args+1,fun(p));
2545                          arg(p) = checkPat(line,arg(p));
2546                          break;
2547
2548         case TUPLE     : if (tupleOf(p)!=args) {
2549                              ERRMSG(line) "Illegal tuple pattern"
2550                              EEND;
2551                          }
2552                          break;
2553
2554 #if TREX
2555         case EXT       : if (args!=2) {
2556                              ERRMSG(line) "Illegal record pattern"
2557                              EEND;
2558                          }
2559                          break;
2560 #endif
2561
2562         case QUALIDENT :
2563                 if (!isQCon(p)) {
2564                     ERRMSG(line) "Illegal use of qualified variable in pattern"
2565                     EEND;
2566                 }
2567                 /* deliberate fall through */
2568         case CONIDCELL :
2569         case CONOPCELL : p = conDefined(line,p);
2570                          checkCfunArgs(line,p,args);
2571                          break;
2572
2573         case NAME      : checkIsCfun(line,p);
2574                          checkCfunArgs(line,p,args);
2575                          break;
2576
2577         default        : ERRMSG(line) "Illegal pattern syntax"
2578                          EEND;
2579     }
2580     return p;
2581 }
2582
2583 static Void local addPatVar(line,v)     /* add variable v to list of vars  */
2584 Int  line;                              /* in current pattern, checking for*/
2585 Cell v; {                               /* repeated variables.             */
2586      Text t = textOf(v);
2587      List p = NIL;
2588      List n = patVars;
2589
2590      for (; nonNull(n); p=n, n=tl(n)) {
2591          if (textOf(hd(n))==t) {
2592              ERRMSG(line) "Repeated variable \"%s\" in pattern",
2593                           textToStr(t)
2594              EEND;
2595          }
2596      }
2597      if (isNull(p)) {
2598          patVars = cons(v,NIL);
2599      } else {
2600          tl(p)   = cons(v,NIL);
2601      }
2602 }
2603
2604 static Name local conDefined(line,nm)   /* check that nm is the name of a  */
2605 Int  line;                              /* previously defined constructor  */
2606 Cell nm; {                              /* function.                       */
2607     Cell c=findQualName(line,nm);
2608     if (isNull(c)) {
2609         ERRMSG(line) "Undefined constructor function \"%s\"", identToStr(nm)
2610         EEND;
2611     }
2612     checkIsCfun(line,c);
2613     return c;
2614 }
2615
2616 static Void local checkIsCfun(line,c)   /* Check that c is a constructor fn*/
2617 Int  line;
2618 Name c; {
2619     if (!isCfun(c)) {
2620         ERRMSG(line) "\"%s\" is not a constructor function",
2621                      textToStr(name(c).text)
2622         EEND;
2623     }
2624 }
2625
2626 static Void local checkCfunArgs(line,c,args)
2627 Int  line;                              /* Check constructor applied with  */
2628 Cell c;                                 /* correct number of arguments     */
2629 Int  args; {
2630     if (name(c).arity!=args) {
2631         ERRMSG(line) "Constructor function \"%s\" needs %d args in pattern",
2632                      textToStr(name(c).text), name(c).arity
2633         EEND;
2634     }
2635 }
2636
2637 static Cell local applyBtyvs(pat)       /* Record bound type vars in pat   */
2638 Cell pat; {
2639     List bts = hd(btyvars);
2640     btyvars  = tl(btyvars);
2641     if (nonNull(bts)) {
2642         pat = ap(BIGLAM,pair(bts,pat));
2643         for (; nonNull(bts); bts=tl(bts)) {
2644             snd(hd(bts)) = copyKindvar(intOf(snd(hd(bts))));
2645         }
2646     }
2647     return pat;
2648 }
2649
2650 /* --------------------------------------------------------------------------
2651  * Maintaining lists of bound variables and local definitions, for
2652  * dependency and scope analysis.
2653  * ------------------------------------------------------------------------*/
2654
2655 static List bounds;                     /* list of lists of bound vars     */
2656 static List bindings;                   /* list of lists of binds in scope */
2657 static List depends;                    /* list of lists of dependents     */
2658
2659 #define saveBvars()      hd(bounds)     /* list of bvars in current scope  */
2660 #define restoreBvars(bs) hd(bounds)=bs  /* restore list of bound variables */
2661
2662 static Cell local bindPat(line,p)       /* add new bound vars for pattern  */
2663 Int  line;
2664 Cell p; {
2665     patVars    = NIL;
2666     p          = checkPat(line,p);
2667     hd(bounds) = revOnto(patVars,hd(bounds));
2668     return p;
2669 }
2670
2671 static Void local bindPats(line,ps)     /* add new bound vars for patterns */
2672 Int  line;
2673 List ps; {
2674     patVars    = NIL;
2675     map1Over(checkPat,line,ps);
2676     hd(bounds) = revOnto(patVars,hd(bounds));
2677 }
2678
2679 /* --------------------------------------------------------------------------
2680  * Before processing value and type signature declarations, all data and
2681  * type definitions have been processed so that:
2682  * - all valid type constructors (with their arities) are known.
2683  * - all valid constructor functions (with their arities and types) are
2684  *   known.
2685  *
2686  * The result of parsing a list of value declarations is a list of Eqns:
2687  *       Eqn ::= (SIGDECL,(Line,[Var],type))  |  (Expr,Rhs)
2688  * The ordering of the equations in this list is the reverse of the original
2689  * ordering in the script parsed.  This is a consequence of the structure of
2690  * the parser ... but also turns out to be most convenient for the static
2691  * analysis.
2692  *
2693  * As the first stage of the static analysis of value declarations, each
2694  * list of Eqns is converted to a list of Bindings.  As part of this
2695  * process:
2696  * - The ordering of the list of Bindings produced is the same as in the
2697  *   original script.
2698  * - When a variable (function) is defined over a number of lines, all
2699  *   of the definitions should appear together and each should give the
2700  *   same arity to the variable being defined.
2701  * - No variable can have more than one definition.
2702  * - For pattern bindings:
2703  *   - Each lhs is a valid pattern/function lhs, all constructor functions
2704  *     have been defined and are used with the correct number of arguments.
2705  *   - Each lhs contains no repeated pattern variables.
2706  *   - Each equation defines at least one variable (e.g. True = False is
2707  *     not allowed).
2708  * - Types appearing in type signatures are well formed:
2709  *    - Type constructors used are defined and used with correct number
2710  *      of arguments.
2711  *    - type variables are replaced by offsets, type constructor names
2712  *      by Tycons.
2713  * - Every variable named in a type signature declaration is defined by
2714  *   one or more equations elsewhere in the script.
2715  * - No variable has more than one type declaration.
2716  *
2717  * ------------------------------------------------------------------------*/
2718
2719 #define bindingType(b) fst(snd(b))      /* type (or types) for binding     */
2720 #define fbindAlts(b)   snd(snd(b))      /*alternatives for function binding*/
2721
2722 static List local extractSigdecls(es)   /* extract the SIGDECLS from list  */
2723 List es; {                              /* of equations                    */
2724     List sigDecls  = NIL;               /* :: [(Line,[Var],Type)]          */
2725
2726     for(; nonNull(es); es=tl(es)) {
2727         if (fst(hd(es))==SIGDECL) {                  /* type-declaration?  */
2728             Pair sig  = snd(hd(es));
2729             Int  line = intOf(fst3(sig));
2730             List vs   = snd3(sig);
2731             for(; nonNull(vs); vs=tl(vs)) {
2732                 if (isQualIdent(hd(vs))) {
2733                     ERRMSG(line) "Type signature for qualified variable \"%s\" is not allowed",
2734                                  identToStr(hd(vs))
2735                     EEND;
2736                 }
2737             }
2738             sigDecls = cons(sig,sigDecls);          /* discard SIGDECL tag */
2739         }
2740     }
2741     return sigDecls;
2742 }
2743
2744 static List local extractBindings(es)   /* extract untyped bindings from   */
2745 List es; {                              /* given list of equations         */
2746     Cell lastVar   = NIL;               /* = var def'd in last eqn (if any)*/
2747     Int  lastArity = 0;                 /* = number of args in last defn   */
2748     List bs        = NIL;               /* :: [Binding]                    */
2749
2750     for(; nonNull(es); es=tl(es)) {
2751         Cell e = hd(es);
2752
2753         if (fst(e)!=SIGDECL) {
2754             Int  line    = rhsLine(snd(e));
2755             Cell lhsHead = getHead(fst(e));
2756
2757             switch (whatIs(lhsHead)) {
2758                 case VARIDCELL :
2759                 case VAROPCELL : {                    /* function-binding? */
2760                     Cell newAlt = pair(getArgs(fst(e)), snd(e));
2761                     if (nonNull(lastVar) && textOf(lhsHead)==textOf(lastVar)) {
2762                         if (argCount!=lastArity) {
2763                             ERRMSG(line)
2764                                 "Equations give different arities for \"%s\"",
2765                                 textToStr(textOf(lhsHead))
2766                             EEND;
2767                         }
2768                         fbindAlts(hd(bs)) = cons(newAlt,fbindAlts(hd(bs)));
2769                     }
2770                     else {
2771                         lastVar   = lhsHead;
2772                         lastArity = argCount;
2773                         notDefined(line,bs,lhsHead);
2774                         bs        = cons(pair(lhsHead,
2775                                               pair(NIL,
2776                                                    singleton(newAlt))),
2777                                          bs);
2778                     }
2779                 }
2780                 break;
2781
2782             case QUALIDENT: if (isQVar(lhsHead)) {
2783             ERRMSG(line) "Binding for qualified variable \"%s\" not allowed",
2784                          identToStr(lhsHead)
2785             EEND;
2786         }
2787         break;
2788         /* deliberate fall through */
2789 #if TREX
2790                 case EXT       :
2791 #endif
2792                 case CONFLDS   :
2793                 case CONOPCELL :
2794                 case CONIDCELL :
2795                 case FINLIST   :
2796                 case TUPLE     :
2797                 case NAME      :
2798                 case LAZYPAT   :
2799                 case ASPAT     : lastVar = NIL;       /* pattern-binding?  */
2800                                  patVars = NIL;
2801                                  enterBtyvs();
2802                                  fst(e)  = checkPat(line,fst(e));
2803                                  if (isNull(patVars)) {
2804                                      ERRMSG(line)
2805                                        "No variables defined in lhs pattern"
2806                                      EEND;
2807                                  }
2808                                  map2Proc(notDefined,line,bs,patVars);
2809                                  bs = cons(pair(patVars,pair(NIL,e)),bs);
2810                                  if (nonNull(hd(btyvars))) {
2811                                      ERRMSG(line)
2812                                       "Sorry, no type variables are allowed in pattern binding type annotations"
2813                                      EEND;
2814                                  }
2815                                  leaveBtyvs();
2816                                  break;
2817
2818                 default        : ERRMSG(line) "Improper left hand side"
2819                                  EEND;
2820             }
2821         }
2822     }
2823     return bs;
2824 }
2825
2826 static List local eqnsToBindings(es)    /*Convert list of equations to list*/
2827 List es; {                              /*of typed bindings                */
2828     List bs = extractBindings(es);
2829     map1Proc(addSigDecl,bs,extractSigdecls(es));
2830     return bs;
2831 }
2832
2833 static Void local notDefined(line,bs,v) /* check if name already defined in*/
2834 Int  line;                              /* list of bindings                */
2835 List bs;
2836 Cell v; {
2837     if (nonNull(findBinding(textOf(v),bs))) {
2838         ERRMSG(line) "\"%s\" multiply defined", textToStr(textOf(v))
2839         EEND;
2840     }
2841 }
2842
2843 static Cell local findBinding(t,bs)     /* look for binding for variable t */
2844 Text t;                                 /* in list of bindings bs          */
2845 List bs; {
2846     for (; nonNull(bs); bs=tl(bs)) {
2847         if (isVar(fst(hd(bs)))) {                     /* function-binding? */
2848             if (textOf(fst(hd(bs)))==t) {
2849                 return hd(bs);
2850             }
2851         } else if (nonNull(varIsMember(t,fst(hd(bs))))) { /* pattern-binding?  */
2852             return hd(bs);
2853         }
2854     }
2855     return NIL;
2856 }
2857
2858 static Void local addSigDecl(bs,sigDecl)/* add type information to bindings*/
2859 List bs;                                /* :: [Binding]                    */
2860 Cell sigDecl; {                         /* :: (Line,[Var],Type)            */
2861     Int  line = intOf(fst3(sigDecl));
2862     Cell vs   = snd3(sigDecl);
2863     Cell type = checkSigType(line,"type declaration",hd(vs),thd3(sigDecl));
2864
2865     map3Proc(setType,line,type,bs,vs);
2866 }
2867
2868 static Void local setType(line,type,bs,v)
2869 Int  line;                              /* Set type of variable            */
2870 Cell type;
2871 Cell v;
2872 List bs; {
2873     Text t = textOf(v);
2874     Cell b = findBinding(t,bs);
2875
2876     if (isNull(b)) {
2877         ERRMSG(line) "Type declaration for variable \"%s\" with no body",
2878                      textToStr(t)
2879         EEND;
2880     }
2881
2882     if (isVar(fst(b))) {                              /* function-binding? */
2883         if (isNull(bindingType(b))) {
2884             bindingType(b) = type;
2885             return;
2886         }
2887     } else {                                          /* pattern-binding?  */
2888         List vs = fst(b);
2889         List ts = bindingType(b);
2890
2891         if (isNull(ts)) {
2892             bindingType(b) = ts = replicate(length(vs),NIL);
2893         }
2894         while (nonNull(vs) && t!=textOf(hd(vs))) {
2895             vs = tl(vs);
2896             ts = tl(ts);
2897         }
2898
2899         if (nonNull(vs) && isNull(hd(ts))) {
2900             hd(ts) = type;
2901             return;
2902         }
2903     }
2904
2905     ERRMSG(line) "Repeated type declaration for \"%s\"", textToStr(t)
2906     EEND;
2907 }
2908
2909 /* --------------------------------------------------------------------------
2910  * To facilitate dependency analysis, lists of bindings are temporarily
2911  * augmented with an additional field, which is used in two ways:
2912  * - to build the `adjacency lists' for the dependency graph. Represented by
2913  *   a list of pointers to other bindings in the same list of bindings.
2914  * - to hold strictly positive integer values (depth first search numbers) of
2915  *   elements `on the stack' during the strongly connected components search
2916  *   algorithm, or a special value mkInt(0), once the binding has been added
2917  *   to a particular strongly connected component.
2918  *
2919  * Using this extra field, the type of each list of declarations during
2920  * dependency analysis is [Binding'] where:
2921  *
2922  *    Binding' ::= (Var, (Dep, (Type, [Alt])))         -- function binding
2923  *              |  ([Var], (Dep, ([Type], (Pat,Rhs)))) -- pattern binding
2924  *
2925  * ------------------------------------------------------------------------*/
2926
2927 #define depVal(d) (fst(snd(d)))         /* Access to dependency information*/
2928
2929 static List local dependencyAnal(bs)    /* Separate lists of bindings into */
2930 List bs; {                              /* mutually recursive groups in    */
2931                                         /* order of dependency             */
2932
2933     mapProc(addDepField,bs);            /* add extra field for dependents  */
2934     mapProc(depBinding,bs);             /* find dependents of each binding */
2935     bs = bscc(bs);                      /* sort to strongly connected comps*/
2936     mapProc(remDepField,bs);            /* remove dependency info field    */
2937     return bs;
2938 }
2939
2940 static List local topDependAnal(bs)     /* Like dependencyAnal(), but at   */
2941 List bs; {                              /* top level, reporting on progress*/
2942     List xs;
2943     Int  i = 0;
2944
2945     setGoal("Dependency analysis",(Target)(length(bs)));
2946     mapProc(addDepField,bs);            /* add extra field for dependents  */
2947     for (xs=bs; nonNull(xs); xs=tl(xs)) {
2948         emptySubstitution();
2949         depBinding(hd(xs));
2950         soFar((Target)(i++));
2951     }
2952     bs = bscc(bs);                      /* sort to strongly connected comps*/
2953     mapProc(remDepField,bs);            /* remove dependency info field    */
2954     done();
2955     return bs;
2956 }
2957
2958 static Void local addDepField(b)        /* add extra field to binding to   */
2959 Cell b; {                               /* hold list of dependents         */
2960     snd(b) = pair(NIL,snd(b));
2961 }
2962
2963 static Void local remDepField(bs)       /* remove dependency field from    */
2964 List bs; {                              /* list of bindings                */
2965     mapProc(remDepField1,bs);
2966 }
2967
2968 static Void local remDepField1(b)       /* remove dependency field from    */
2969 Cell b; {                               /* single binding                  */
2970     snd(b) = snd(snd(b));
2971 }
2972
2973 static Void local clearScope() {        /* initialise dependency scoping   */
2974     bounds   = NIL;
2975     bindings = NIL;
2976     depends  = NIL;
2977 }
2978
2979 static Void local withinScope(bs)       /* enter scope of bindings bs      */
2980 List bs; {
2981     bounds   = cons(NIL,bounds);
2982     bindings = cons(bs,bindings);
2983     depends  = cons(NIL,depends);
2984 }
2985
2986 static Void local leaveScope() {        /* leave scope of last withinScope */
2987     bounds   = tl(bounds);
2988     bindings = tl(bindings);
2989     depends  = tl(depends);
2990 }
2991
2992 /* --------------------------------------------------------------------------
2993  * As a side effect of the dependency analysis we also make the following
2994  * checks:
2995  * - Each lhs is a valid pattern/function lhs, all constructor functions
2996  *   have been defined and are used with the correct number of arguments.
2997  * - No lhs contains repeated pattern variables.
2998  * - Expressions used on the rhs of an eqn should be well formed.  This
2999  *   includes:
3000  *   - Checking for valid patterns (including repeated vars) in lambda,
3001  *     case, and list comprehension expressions.
3002  *   - Recursively checking local lists of equations.
3003  * - No free (i.e. unbound) variables are used in the declaration list.
3004  * ------------------------------------------------------------------------*/
3005
3006 static Void local depBinding(b)         /* find dependents of binding      */
3007 Cell b; {
3008     Cell defpart = snd(snd(snd(b)));    /* definition part of binding      */
3009
3010     hd(depends) = NIL;
3011
3012     if (isVar(fst(b))) {                /* function-binding?               */
3013         mapProc(depAlt,defpart);
3014         if (isNull(fst(snd(snd(b))))) { /* Save dep info for implicitly    */
3015             fst(snd(snd(b))) = ap(IMPDEPS,hd(depends)); /* typed var binds */
3016         }
3017     } else {                            /* pattern-binding?                */
3018         depRhs(snd(defpart));
3019     }
3020     depVal(b) = hd(depends);
3021 }
3022
3023 static Void local depDefaults(c)        /* dependency analysis on defaults */
3024 Class c; {                              /* from class definition           */
3025     depClassBindings(cclass(c).defaults);
3026 }
3027
3028 static Void local depInsts(in)          /* dependency analysis on instance */
3029 Inst in; {                              /* bindings                        */
3030     depClassBindings(inst(in).implements);
3031 }
3032
3033 static Void local depClassBindings(bs)  /* dependency analysis on list of  */
3034 List bs; {                              /* bindings, possibly containing   */
3035     for (; nonNull(bs); bs=tl(bs)) {    /* NIL bindings ...                */
3036         if (nonNull(hd(bs))) {          /* No need to add extra field for  */
3037            mapProc(depAlt,snd(hd(bs))); /* dependency information ...      */
3038         }
3039     }
3040 }
3041
3042 static Void local depAlt(a)             /* Find dependents of alternative  */
3043 Cell a; {
3044     List obvs = saveBvars();            /* Save list of bound variables    */
3045     enterBtyvs();
3046     bindPats(rhsLine(snd(a)),fst(a));   /* add new bound vars for patterns */
3047     depRhs(snd(a));                     /* find dependents of rhs          */
3048     fst(a)    = applyBtyvs(fst(a));
3049     restoreBvars(obvs);                 /* restore original list of bvars  */
3050 }
3051
3052 static Void local depRhs(r)             /* Find dependents of rhs          */
3053 Cell r; {
3054     switch (whatIs(r)) {
3055         case GUARDED : mapProc(depGuard,snd(r));
3056                        break;
3057
3058         case LETREC  : fst(snd(r)) = eqnsToBindings(fst(snd(r)));
3059                        withinScope(fst(snd(r)));
3060                        fst(snd(r)) = dependencyAnal(fst(snd(r)));
3061                        hd(depends) = fst(snd(r));
3062                        depRhs(snd(snd(r)));
3063                        leaveScope();
3064                        break;
3065
3066         default      : snd(r) = depExpr(intOf(fst(r)),snd(r));
3067                        break;
3068     }
3069 }
3070
3071 static Void local depGuard(g)           /*find dependents of single guarded*/
3072 Cell g; {                               /* expression                      */
3073     depPair(intOf(fst(g)),snd(g));
3074 }
3075
3076 static Cell local depExpr(line,e)       /* find dependents of expression   */
3077 Int  line;
3078 Cell e; {
3079     switch (whatIs(e)) {
3080
3081         case VARIDCELL  :
3082         case VAROPCELL  : return depVar(line,e);
3083
3084         case CONIDCELL  :
3085         case CONOPCELL  : return conDefined(line,e);
3086
3087         case QUALIDENT  : if (isQVar(e)) {
3088                               return depQVar(line,e);
3089                           } else { /* QConOrConOp */
3090                               return conDefined(line,e);
3091                           }
3092
3093 #if TREX
3094         case RECSEL     : break;
3095
3096         case AP         : if (isAp(e) && isAp(fun(e)) && isExt(fun(fun(e)))) {
3097                               return depRecord(line,e);
3098                           } else {
3099                               Cell nx = e;
3100                               Cell a;
3101                               do {
3102                                   a      = nx;
3103                                   arg(a) = depExpr(line,arg(a));
3104                                   nx     = fun(a);
3105                               } while (isAp(nx));
3106                               fun(a) = depExpr(line,fun(a));
3107                           }
3108                           break;
3109 #else
3110         case AP         : depPair(line,e);
3111                           break;
3112 #endif
3113
3114         case NAME       :
3115         case TUPLE      :
3116         case STRCELL    :
3117         case CHARCELL   :
3118         case INTCELL    :
3119         case BIGCELL    :
3120         case FLOATCELL  : break;
3121
3122         case COND       : depTriple(line,snd(e));
3123                           break;
3124
3125         case FINLIST    : map1Over(depExpr,line,snd(e));
3126                           break;
3127
3128         case LETREC     : fst(snd(e)) = eqnsToBindings(fst(snd(e)));
3129                           withinScope(fst(snd(e)));
3130                           fst(snd(e)) = dependencyAnal(fst(snd(e)));
3131                           hd(depends) = fst(snd(e));
3132                           snd(snd(e)) = depExpr(line,snd(snd(e)));
3133                           leaveScope();
3134                           break;
3135
3136         case LAMBDA     : depAlt(snd(e));
3137                           break;
3138
3139         case DOCOMP     : /* fall-thru */
3140         case COMP       : depComp(line,snd(e),snd(snd(e)));
3141                           break;
3142
3143         case ESIGN      : fst(snd(e)) = depExpr(line,fst(snd(e)));
3144                           snd(snd(e)) = checkSigType(line,
3145                                                      "expression",
3146                                                      fst(snd(e)),
3147                                                      snd(snd(e)));
3148                           break;
3149
3150         case CASE       : fst(snd(e)) = depExpr(line,fst(snd(e)));
3151                           map1Proc(depCaseAlt,line,snd(snd(e)));
3152                           break;
3153
3154         case CONFLDS    : depConFlds(line,e,FALSE);
3155                           break;
3156
3157         case UPDFLDS    : depUpdFlds(line,e);
3158                           break;
3159
3160         case ASPAT      : ERRMSG(line) "Illegal `@' in expression"
3161                           EEND;
3162
3163         case LAZYPAT    : ERRMSG(line) "Illegal `~' in expression"
3164                           EEND;
3165
3166         case WILDCARD   : ERRMSG(line) "Illegal `_' in expression"
3167                           EEND;
3168
3169 #if TREX
3170         case EXT        : ERRMSG(line) "Illegal application of record"
3171                           EEND;
3172 #endif
3173
3174         default         : internal("in depExpr");
3175    }
3176    return e;
3177 }
3178
3179 static Void local depPair(line,e)       /* find dependents of pair of exprs*/
3180 Int  line;
3181 Cell e; {
3182     fst(e) = depExpr(line,fst(e));
3183     snd(e) = depExpr(line,snd(e));
3184 }
3185
3186 static Void local depTriple(line,e)     /* find dependents of triple exprs */
3187 Int  line;
3188 Cell e; {
3189     fst3(e) = depExpr(line,fst3(e));
3190     snd3(e) = depExpr(line,snd3(e));
3191     thd3(e) = depExpr(line,thd3(e));
3192 }
3193
3194 static Void local depComp(l,e,qs)       /* find dependents of comprehension*/
3195 Int  l;
3196 Cell e;
3197 List qs; {
3198     if (isNull(qs))
3199         fst(e) = depExpr(l,fst(e));
3200     else {
3201         Cell q   = hd(qs);
3202         List qs1 = tl(qs);
3203         switch (whatIs(q)) {
3204             case FROMQUAL : {   List obvs   = saveBvars();
3205                                 snd(snd(q)) = depExpr(l,snd(snd(q)));
3206                                 enterBtyvs();
3207                                 fst(snd(q)) = bindPat(l,fst(snd(q)));
3208                                 depComp(l,e,qs1);
3209                                 fst(snd(q)) = applyBtyvs(fst(snd(q)));
3210                                 restoreBvars(obvs);
3211                             }
3212                             break;
3213
3214             case QWHERE   : snd(q)      = eqnsToBindings(snd(q));
3215                             withinScope(snd(q));
3216                             snd(q)      = dependencyAnal(snd(q));
3217                             hd(depends) = snd(q);
3218                             depComp(l,e,qs1);
3219                             leaveScope();
3220                             break;
3221
3222             case DOQUAL   : /* fall-thru */
3223             case BOOLQUAL : snd(q) = depExpr(l,snd(q));
3224                             depComp(l,e,qs1);
3225                             break;
3226         }
3227     }
3228 }
3229
3230 static Void local depCaseAlt(line,a)    /* Find dependents of case altern. */
3231 Int  line;
3232 Cell a; {
3233     List obvs = saveBvars();            /* Save list of bound variables    */
3234     enterBtyvs();
3235     fst(a)    = bindPat(line,fst(a));   /* Add new bound vars for pats     */
3236     depRhs(snd(a));                     /* Find dependents of rhs          */
3237     fst(a)    = applyBtyvs(fst(a));
3238     restoreBvars(obvs);                 /* Restore original list of bvars  */
3239 }
3240
3241 static Cell local depVar(line,e)        /* Register occurrence of variable */
3242 Int line;
3243 Cell e; {
3244     List bounds1   = bounds;
3245     List bindings1 = bindings;
3246     List depends1  = depends;
3247     Text t         = textOf(e);
3248     Cell n;
3249
3250     while (nonNull(bindings1)) {
3251         n = varIsMember(t,hd(bounds1));   /* look for t in bound variables */
3252         if (nonNull(n)) {
3253             return n;
3254         }
3255         n = findBinding(t,hd(bindings1)); /* look for t in var bindings    */
3256         if (nonNull(n)) {
3257            if (!cellIsMember(n,hd(depends1)))
3258                hd(depends1) = cons(n,hd(depends1));
3259            return (isVar(fst(n)) ? fst(n) : e);
3260         }
3261
3262         bounds1   = tl(bounds1);
3263         bindings1 = tl(bindings1);
3264         depends1  = tl(depends1);
3265     }
3266
3267     if (isNull(n=findName(t))) {               /* check global definitions */
3268         ERRMSG(line) "Undefined variable \"%s\"", textToStr(t)
3269         EEND;
3270     }
3271
3272     if (name(n).mod != thisModule) {
3273         return n;
3274     }
3275     /* Later phases of the system cannot cope if we resolve references
3276      * to unprocessed objects too early.  This is the main reason that
3277      * we cannot cope with recursive modules at the moment.
3278      */
3279     return n;
3280 }
3281
3282 static Cell local depQVar(line,e)/* register occurrence of qualified variable */
3283 Int line;
3284 Cell e; {
3285     Cell n = findQualName(line,e);
3286     if (isNull(n)) {                            /* check global definitions */
3287         ERRMSG(line) "Undefined qualified variable \"%s\"", identToStr(e)
3288         EEND;
3289     }
3290     if (name(n).mod != currentModule) {
3291         return n;
3292     }
3293     if (fst(e) == VARIDCELL) {
3294         e = mkVar(qtextOf(e));
3295     } else {
3296         e = mkVarop(qtextOf(e));
3297     }
3298     return depVar(line,e);
3299 }
3300
3301 static Void local depConFlds(line,e,isP)/* check construction using fields */
3302 Int  line;
3303 Cell e;
3304 Bool isP; {
3305     Name c = conDefined(line,fst(snd(e)));
3306     if (isNull(snd(snd(e))) ||
3307         nonNull(cellIsMember(c,depFields(line,e,snd(snd(e)),isP)))) {
3308         fst(snd(e)) = c;
3309     } else {
3310         ERRMSG(line) "Constructor \"%s\" does not have selected fields in ",
3311                      textToStr(name(c).text)
3312         ETHEN ERREXPR(e);
3313         ERRTEXT "\n"
3314         EEND;
3315     }
3316     if (!isP && isPair(name(c).defn)) { /* Check that banged fields defined*/
3317         List scs = fst(name(c).defn);   /* List of strict components       */
3318         Type t   = name(c).type;
3319         Int  a   = name(c).arity;
3320         List fs  = snd(snd(e));
3321         List ss;
3322         if (isPolyType(t)) {            /* Find tycon that c belongs to    */
3323             t = monotypeOf(t);
3324         }
3325         if (whatIs(t)==QUAL) {
3326             t = snd(snd(t));
3327         }
3328         while (0<a--) {
3329             t = arg(t);
3330         }
3331         while (isAp(t)) {
3332             t = fun(t);
3333         }
3334         for (ss=tycon(t).defn; hasCfun(ss); ss=tl(ss)) {
3335         }
3336         /* Now we know the tycon t that c belongs to, and the corresponding
3337          * list of selectors for that type, ss.  Now we have to check that
3338          * each of the fields identified by scs appears in fs, using ss to
3339          * cross reference, and convert integers to selector names.
3340          */
3341         for (; nonNull(scs); scs=tl(scs)) {
3342             Int  i   = intOf(hd(scs));
3343             List ss1 = ss;
3344             for (; nonNull(ss1); ss1=tl(ss1)) {
3345                 List cns = name(hd(ss1)).defn;
3346                 for (; nonNull(cns); cns=tl(cns)) {
3347                     if (fst(hd(cns))==c) {
3348                         break;
3349                     }
3350                 }
3351                 if (nonNull(cns) && intOf(snd(hd(cns)))==i) {
3352                     break;
3353                 }
3354             }
3355             if (isNull(ss1)) {
3356                 internal("depConFlds");
3357             } else {
3358                 Name s   = hd(ss1);
3359                 List fs1 = fs;
3360                 for (; nonNull(fs1) && s!=fst(hd(fs1)); fs1=tl(fs1)) {
3361                 }
3362                 if (isNull(fs1)) {
3363                     ERRMSG(line) "Construction does not define strict field"
3364                     ETHEN
3365                     ERRTEXT      "\nExpression : " ETHEN ERREXPR(e);
3366                     ERRTEXT      "\nField      : " ETHEN ERREXPR(s);
3367                     ERRTEXT      "\n"
3368                     EEND;
3369                 }
3370             }
3371         }
3372     }
3373 }
3374
3375 static Void local depUpdFlds(line,e)    /* check update using fields       */
3376 Int  line;
3377 Cell e; {
3378     if (isNull(thd3(snd(e)))) {
3379         ERRMSG(line) "Empty field list in update"
3380         EEND;
3381     }
3382     fst3(snd(e)) = depExpr(line,fst3(snd(e)));
3383     snd3(snd(e)) = depFields(line,e,thd3(snd(e)),FALSE);
3384 }
3385
3386 static List local depFields(l,e,fs,isP) /* check field binding list        */
3387 Int  l;
3388 Cell e;
3389 List fs;
3390 Bool isP; {
3391     List cs = NIL;
3392     List ss = NIL;
3393
3394     for (; nonNull(fs); fs=tl(fs)) {    /* for each field binding          */
3395         Cell fb = hd(fs);
3396         Name s;
3397
3398         if (isVar(fb)) {                /* expand  var  to  var = var      */
3399             fb = hd(fs) = pair(fb,fb);
3400         }
3401         s = findQualName(l,fst(fb));    /* check for selector              */
3402         if (nonNull(s) && isSfun(s)) {
3403             fst(fb) = s;
3404         } else {
3405             ERRMSG(l) "\"%s\" is not a selector function/field name",
3406                       textToStr(textOf(fst(fb)))
3407             EEND;
3408         }
3409
3410         if (isNull(ss)) {               /* for first named selector        */
3411             List scs = name(s).defn;    /* calculate list of constructors  */
3412             for (; nonNull(scs); scs=tl(scs))
3413                 cs = cons(fst(hd(scs)),cs);
3414             ss = singleton(s);          /* initialize selector list        */
3415         } else {                        /* for subsequent selectors        */
3416             List ds = cs;               /* intersect constructor lists     */
3417             for (cs=NIL; nonNull(ds); ) {
3418                 List scs = name(s).defn;
3419                 while (nonNull(scs) && fst(hd(scs))!=hd(ds)) {
3420                     scs = tl(scs);
3421                 }
3422                 if (isNull(scs)) {
3423                     ds = tl(ds);
3424                 } else {
3425                     List next = tl(ds);
3426                     tl(ds)    = cs;
3427                     cs        = ds;
3428                     ds        = next;
3429                 }
3430             }
3431
3432             if (cellIsMember(s,ss)) {   /* check for repeated uses         */
3433                 ERRMSG(l) "Repeated field name \"%s\" in field list",
3434                           textToStr(name(s).text)
3435                 EEND;
3436             }
3437             ss = cons(s,ss);
3438         }
3439
3440         if (isNull(cs)) {               /* Are there any matching constrs? */
3441             ERRMSG(l) "No constructor has all of the fields specified in "
3442             ETHEN ERREXPR(e);
3443             ERRTEXT "\n"
3444             EEND;
3445         }
3446
3447         snd(fb) = (isP ? checkPat(l,snd(fb)) : depExpr(l,snd(fb)));
3448     }
3449     return cs;
3450 }
3451
3452 #if TREX
3453 static Cell local depRecord(line,e)     /* find dependents of record and   */
3454 Int  line;                              /* sort fields into approp. order  */
3455 Cell e; {                               /* to make construction and update */
3456     List exts = NIL;                    /* more efficient.                 */
3457     Cell r    = e;
3458
3459     do {                                /* build up list of extensions     */
3460         Text   t    = extText(fun(fun(r)));
3461         String s    = textToStr(t);
3462         List   prev = NIL;
3463         List   nx   = exts;
3464         while (nonNull(nx) && strcmp(textToStr(extText(fun(fun(nx)))),s)>0) {
3465             prev = nx;
3466             nx   = extRow(nx);
3467         }
3468         if (nonNull(nx) && t==extText(fun(fun(nx)))) {
3469             ERRMSG(line) "Repeated label \"%s\" in record ", s
3470             ETHEN ERREXPR(e);
3471             ERRTEXT "\n"
3472             EEND;
3473         }
3474         if (isNull(prev)) {
3475             exts = cons(fun(r),exts);
3476         } else {
3477             tl(prev) = cons(fun(r),nx);
3478         }
3479         extField(r) = depExpr(line,extField(r));
3480         r           = extRow(r);
3481     } while (isAp(r) && isAp(fun(r)) && isExt(fun(fun(r))));
3482     r = depExpr(line,r);
3483     return revOnto(exts,r);
3484 }
3485 #endif
3486
3487 /* --------------------------------------------------------------------------
3488  * Several parts of this program require an algorithm for sorting a list
3489  * of values (with some added dependency information) into a list of strongly
3490  * connected components in which each value appears before its dependents.
3491  *
3492  * Each of these algorithms is obtained by parameterising a standard
3493  * algorithm in "scc.c" as shown below.
3494  * ------------------------------------------------------------------------*/
3495
3496 #define  SCC2            tcscc          /* make scc algorithm for Tycons   */
3497 #define  LOWLINK         tclowlink
3498 #define  DEPENDS(c)      (isTycon(c) ? tycon(c).kind : cclass(c).kinds)
3499 #define  SETDEPENDS(c,v) if(isTycon(c))tycon(c).kind=v;else cclass(c).kinds=v
3500 #include "scc.c"
3501 #undef   SETDEPENDS
3502 #undef   DEPENDS
3503 #undef   LOWLINK
3504 #undef   SCC2
3505
3506 #define  SCC             bscc           /* make scc algorithm for Bindings */
3507 #define  LOWLINK         blowlink
3508 #define  DEPENDS(t)      depVal(t)
3509 #define  SETDEPENDS(c,v) depVal(c)=v
3510 #include "scc.c"
3511 #undef   SETDEPENDS
3512 #undef   DEPENDS
3513 #undef   LOWLINK
3514 #undef   SCC
3515
3516 /* --------------------------------------------------------------------------
3517  * Main static analysis:
3518  * ------------------------------------------------------------------------*/
3519
3520 Void checkExp() {                       /* Top level static check on Expr  */
3521     staticAnalysis(RESET);
3522     clearScope();                       /* Analyse expression in the scope */
3523     withinScope(NIL);                   /* of no local bindings            */
3524     inputExpr = depExpr(0,inputExpr);
3525     leaveScope();
3526     staticAnalysis(RESET);
3527 }
3528
3529 Void checkDefns() {                     /* Top level static analysis       */
3530     staticAnalysis(RESET);
3531     thisModule = lastModule();
3532     setCurrModule(thisModule);
3533
3534     /* Resolve module references */
3535     mapProc(checkQualImport,  module(thisModule).qualImports);
3536     mapProc(checkUnqualImport,unqualImports);
3537
3538     /* Add implicit import declarations - if Prelude has been loaded */
3539     {
3540         Module modulePrelude = findModule(findText("Prelude"));
3541         if (nonNull(modulePrelude)) {
3542             /* Add "import Prelude" if there`s no explicit import */
3543             if (thisModule != modulePrelude
3544                 && isNull(cellAssoc(modulePrelude,unqualImports))
3545                 && isNull(cellRevAssoc(modulePrelude,module(thisModule).qualImports))) {
3546                 unqualImports = cons(pair(modulePrelude,DOTDOT),unqualImports);
3547             }
3548             /* Add "import qualified Prelude" */
3549             module(thisModule).qualImports=cons(pair(conPrelude,modulePrelude),
3550                                                 module(thisModule).qualImports);
3551         }
3552     }
3553     map1Proc(checkImportList, thisModule, unqualImports);
3554
3555     linkPreludeTC();                    /* Get prelude tycons and classes  */
3556     setCurrModule(thisModule);
3557
3558     mapProc(checkTyconDefn,tyconDefns); /* validate tycon definitions      */
3559     checkSynonyms(tyconDefns);          /* check synonym definitions       */
3560     mapProc(checkClassDefn,classDefns); /* process class definitions       */
3561     mapProc(kindTCGroup,tcscc(tyconDefns,classDefns)); /* attach kinds     */
3562     mapProc(addMembers,classDefns);     /* add definitions for member funs */
3563     mapProc(visitClass,classDefns);     /* check class hierarchy           */
3564
3565     instDefns = rev(instDefns);         /* process instance definitions    */
3566     mapProc(checkInstDefn,instDefns);
3567
3568     linkPreludeCM();                    /* Get prelude cfuns and mfuns     */
3569     setCurrModule(thisModule);
3570
3571     mapProc(addDerivImp,derivedInsts);  /* Add impls for derived instances */
3572     deriveContexts(derivedInsts);       /* Calculate derived inst contexts */
3573 #if EVAL_INSTANCES
3574     deriveEval(tyconDefns);             /* Derive instances of Eval        */
3575 #endif
3576     tyconDefns = NIL;
3577     instDefns  = appendOnto(instDefns,derivedInsts);
3578 #if EVAL_INSTANCES
3579     instDefns  = appendOnto(evalInsts,instDefns); /* ADR addition */
3580 #endif
3581     checkDefaultDefns();                /* validate default definitions    */
3582
3583     mapProc(addRSsigdecls,typeInDefns); /* add sigdecls for RESTRICTSYN    */
3584     valDefns = eqnsToBindings(valDefns);/* translate value equations       */
3585     map1Proc(opDefined,valDefns,opDefns);/*check all declared ops bound    */
3586     mapProc(allNoPrevDef,valDefns);     /* check against previous defns    */
3587
3588     linkPreludeNames();         /* Get prelude names           */
3589     setCurrModule(thisModule);
3590
3591     mapProc(checkForeignImport,foreignImports); /* check foreign imports   */
3592     mapProc(checkForeignExport,foreignExports); /* check foreign exports   */
3593     foreignImports = NIL;
3594     foreignExports = NIL;
3595
3596     /* Every top-level name has now been created - so we can build the     */
3597     /* export list.  Note that this has to happen before dependency        */
3598     /* analysis so that references to Prelude.foo will be resolved         */
3599     /* when compiling the prelude.                                         */
3600     /* Note too that this is just a little too late to catch the use of    */
3601     /* qualified tycons (for the current module) in data declarations      */
3602     module(thisModule).exports = checkExports(thisModule,module(thisModule).exports);
3603
3604     mapProc(checkTypeIn,typeInDefns);   /* check restricted synonym defns  */
3605
3606     clearScope();
3607     withinScope(valDefns);
3608     valDefns = topDependAnal(valDefns); /* top level dependency ordering   */
3609     mapProc(depDefaults,classDefns);    /* dep. analysis on class defaults */
3610     mapProc(depInsts,instDefns);        /* dep. analysis on inst defns     */
3611     leaveScope();
3612
3613     /* ToDo: evalDefaults should match current evaluation module */
3614     evalDefaults = defaultDefns;        /* Set defaults for evaluator      */
3615
3616     staticAnalysis(RESET);
3617 }
3618
3619 static Void local addRSsigdecls(pr)     /* add sigdecls from TYPE ... IN ..*/
3620 Pair pr; {
3621     List vs = snd(pr);                  /* get list of variables           */
3622     for (; nonNull(vs); vs=tl(vs)) {
3623         if (fst(hd(vs))==SIGDECL) {     /* find a sigdecl                  */
3624             valDefns = cons(hd(vs),valDefns);   /* add to valDefns         */
3625             hd(vs)   = hd(snd3(snd(hd(vs))));   /* and replace with var    */
3626         }
3627     }
3628 }
3629
3630 static Void local opDefined(bs,op)      /* check that op bound in bs       */
3631 List bs;                                /* (or in current module for       */
3632 Cell op; {                              /* constructor functions etc...)   */
3633     Name n;
3634
3635     if (isNull(findBinding(textOf(op),bs))
3636            && (isNull(n=findName(textOf(op))) || name(n).mod != thisModule)) {
3637         ERRMSG(0) "No top level definition for operator symbol \"%s\"",
3638                   textToStr(textOf(op))
3639         EEND;
3640     }
3641 }
3642
3643 static Void local allNoPrevDef(b)       /* ensure no previous bindings for */
3644 Cell b; {                               /* variables in new binding        */
3645     if (isVar(fst(b))) {
3646         noPrevDef(rhsLine(snd(hd(snd(snd(b))))),fst(b));
3647     } else {
3648         Int line = rhsLine(snd(snd(snd(b))));
3649         map1Proc(noPrevDef,line,fst(b));
3650     }
3651 }
3652
3653 static Void local noPrevDef(line,v)     /* ensure no previous binding for  */
3654 Int  line;                              /* new variable                    */
3655 Cell v; {
3656     Name n = findName(textOf(v));
3657
3658     if (isNull(n)) {
3659         n            = newName(textOf(v));
3660         name(n).defn = PREDEFINED;
3661     } else if (name(n).defn!=PREDEFINED) {
3662         ERRMSG(line) "Attempt to redefine variable \"%s\"",
3663                      textToStr(name(n).text)
3664         EEND;
3665     }
3666     name(n).line = line;
3667 }
3668
3669 static Void local duplicateError(line,mod,t,kind)/* report duplicate defn */
3670 Int    line;
3671 Module mod;
3672 Text   t;
3673 String kind; {
3674     if (mod == currentModule) {
3675         ERRMSG(line) "Repeated definition for %s \"%s\"", kind,
3676             textToStr(t)
3677         EEND;
3678     } else {
3679         ERRMSG(line) "Definition of %s \"%s\" clashes with import", kind,
3680             textToStr(t)
3681         EEND;
3682     }
3683 }
3684
3685 static Void local checkTypeIn(cvs)      /* Check that vars in restricted   */
3686 Pair cvs; {                             /* synonym are defined             */
3687     Tycon c  = fst(cvs);
3688     List  vs = snd(cvs);
3689
3690     for (; nonNull(vs); vs=tl(vs)) {
3691         if (isNull(findName(textOf(hd(vs))))) {
3692             ERRMSG(tycon(c).line)
3693                 "No top level binding of \"%s\" for restricted synonym \"%s\"",
3694                 textToStr(textOf(hd(vs))), textToStr(tycon(c).text)
3695             EEND;
3696         }
3697     }
3698 }
3699
3700 /* --------------------------------------------------------------------------
3701  * Static Analysis control:
3702  * ------------------------------------------------------------------------*/
3703
3704 Void staticAnalysis(what)
3705 Int what; {
3706     switch (what) {
3707         case RESET   : daSccs       = NIL;
3708                        patVars      = NIL;
3709                        bounds       = NIL;
3710                        bindings     = NIL;
3711                        depends      = NIL;
3712                        tcDeps       = NIL;
3713                        derivedInsts = NIL;
3714 #if EVAL_INSTANCES
3715                        evalInsts    = NIL;
3716 #endif
3717                        unkindTypes  = NIL;
3718                        thisModule   = 0;
3719                        break;
3720
3721         case MARK    : mark(daSccs);
3722                        mark(patVars);
3723                        mark(bounds);
3724                        mark(bindings);
3725                        mark(depends);
3726                        mark(tcDeps);
3727                        mark(derivedInsts);
3728 #if EVAL_INSTANCES
3729                        mark(evalInsts);
3730 #endif
3731                        mark(unkindTypes);
3732 #if TREX
3733                        mark(extKind);
3734 #endif
3735                        break;
3736
3737         case INSTALL : staticAnalysis(RESET);
3738 #if TREX
3739                        extKind = pair(STAR,pair(ROW,ROW));
3740 #endif
3741                        break;
3742     }
3743 }
3744
3745 /*-------------------------------------------------------------------------*/