ghc/interpreter/pat.c

   1 /* -*- mode: hugs-c; -*- */
   2 /* --------------------------------------------------------------------------
   3  * Desugarer
   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: pat.c,v $
  10  * $Revision: 1.2 $
  11  * $Date: 1998/12/02 13:22:28 $
  12  * ------------------------------------------------------------------------*/
  13
  14 #include "prelude.h"
  15 #include "storage.h"
  16 #include "connect.h"
  17 #include "errors.h"
  18 #include "link.h"
  19
  20 #include "pat.h"
  21 #include "desugar.h"
  22
  23 /* --------------------------------------------------------------------------
  24  * Local function prototypes:
  25  * ------------------------------------------------------------------------*/
  26
  27 static Cell local refutePat             Args((Cell));
  28 static Cell local refutePatAp           Args((Cell));
  29 static Cell local matchPat              Args((Cell));
  30 static List local remPat1               Args((Cell,Cell,List));
  31
  32 /* --------------------------------------------------------------------------
  33  * Elimination of pattern bindings:
  34  *
  35  * The following code adopts the definition of failure free patterns as given
  36  * in the Haskell 1.3 report; the term "irrefutable" is also used there for
  37  * a subset of the failure free patterns described here, but has no useful
  38  * role in this implementation.  Basically speaking, the failure free patterns
  39  * are:         variable, wildcard, ~apat
  40  *              var@apat,               if apat is failure free
  41  *              C apat1 ... apatn       if C is a product constructor
  42  *                                      (i.e. an only constructor) and
  43  *                                      apat1,...,apatn are failure free
  44  * Note that the last case automatically covers the case where C comes from
  45  * a newtype construction.
  46  * ------------------------------------------------------------------------*/
  47
  48 Bool failFree(pat)                /* is pattern failure free? (do we need  */
  49 Cell pat; {                       /* a conformality check?)                */
  50     Cell c = getHead(pat);
  51
  52     switch (whatIs(c)) {
  53         case ASPAT     : return failFree(snd(snd(pat)));
  54
  55         case NAME      : if (!isCfun(c) || cfunOf(c)!=0)
  56                              return FALSE;
  57                          /*intentional fall-thru*/
  58         case TUPLE     : for (; isAp(pat); pat=fun(pat))
  59                              if (!failFree(arg(pat)))
  60                                 return FALSE;
  61                          /*intentional fall-thru*/
  62         case LAZYPAT   :
  63         case VAROPCELL :
  64         case VARIDCELL :
  65         case DICTVAR   :
  66         case WILDCARD  : return TRUE;
  67
  68 #if TREX
  69         case EXT       : return failFree(extField(pat)) &&
  70                                 failFree(extRow(pat));
  71 #endif
  72
  73         case CONFLDS   : if (cfunOf(fst(snd(c)))==0) {
  74                              List fs = snd(snd(c));
  75                              for (; nonNull(fs); fs=tl(fs))
  76                                  if (!failFree(snd(hd(fs))))
  77                                      return FALSE;
  78                              return TRUE;
  79                          }
  80                          /*intentional fall-thru*/
  81         default        : return FALSE;
  82     }
  83 }
  84
  85 static Cell local refutePat(pat)  /* find pattern to refute in conformality*/
  86 Cell pat; {                       /* test with pat.                        */
  87                                   /* e.g. refPat  (x:y) == (_:_)           */
  88                                   /*      refPat ~(x:y) == _      etc..    */
  89
  90     switch (whatIs(pat)) {
  91         case ASPAT     : return refutePat(snd(snd(pat)));
  92
  93         case FINLIST   : {   Cell ys = snd(pat);
  94                              Cell xs = NIL;
  95                              for (; nonNull(ys); ys=tl(ys)) {
  96                                  xs = ap2(nameCons,refutePat(hd(ys)),xs);
  97                              }
  98                              return revOnto(xs,nameNil);
  99                          }
 100
 101         case CONFLDS   : {   Cell ps = NIL;
 102                              Cell fs = snd(snd(pat));
 103                              for (; nonNull(fs); fs=tl(fs)) {
 104                                  Cell p = refutePat(snd(hd(fs)));
 105                                  ps     = cons(pair(fst(hd(fs)),p),ps);
 106                              }
 107                              return pair(CONFLDS,pair(fst(snd(pat)),rev(ps)));
 108                          }
 109
 110         case VAROPCELL :
 111         case VARIDCELL :
 112         case DICTVAR   :
 113         case WILDCARD  :
 114         case LAZYPAT   : return WILDCARD;
 115
 116         case STRCELL   :
 117         case CHARCELL  :
 118 #if NPLUSK
 119         case ADDPAT    :
 120 #endif
 121         case TUPLE     :
 122         case NAME      : return pat;
 123
 124         case AP        : return refutePatAp(pat);
 125
 126         default        : internal("refutePat");
 127                          return NIL; /*NOTREACHED*/
 128     }
 129 }
 130
 131 static Cell local refutePatAp(p)  /* find pattern to refute in conformality*/
 132 Cell p; {
 133     Cell h = getHead(p);
 134     if (h==nameFromInt || h==nameFromInteger || h==nameFromDouble)
 135         return p;
 136 #if NPLUSK
 137     else if (whatIs(h)==ADDPAT)
 138         return ap(fun(p),refutePat(arg(p)));
 139 #endif
 140 #if TREX
 141     else if (isExt(h)) {
 142         Cell pf = refutePat(extField(p));
 143         Cell pr = refutePat(extRow(p));
 144         return ap2(fun(fun(p)),pf,pr);
 145     }
 146 #endif
 147     else {
 148         List as = getArgs(p);
 149         mapOver(refutePat,as);
 150         return applyToArgs(h,as);
 151     }
 152 }
 153
 154 static Cell local matchPat(pat) /* find pattern to match against           */
 155 Cell pat; {                     /* replaces parts of pattern that do not   */
 156                                 /* include variables with wildcards        */
 157     switch (whatIs(pat)) {
 158         case ASPAT     : {   Cell p = matchPat(snd(snd(pat)));
 159                              return (p==WILDCARD) ? fst(snd(pat))
 160                                                   : ap(ASPAT,
 161                                                        pair(fst(snd(pat)),p));
 162                          }
 163
 164         case FINLIST   : {   Cell ys = snd(pat);
 165                              Cell xs = NIL;
 166                              for (; nonNull(ys); ys=tl(ys))
 167                                  xs = cons(matchPat(hd(ys)),xs);
 168                              while (nonNull(xs) && hd(xs)==WILDCARD)
 169                                  xs = tl(xs);
 170                              for (ys=nameNil; nonNull(xs); xs=tl(xs))
 171                                  ys = ap2(nameCons,hd(xs),ys);
 172                              return ys;
 173                          }
 174
 175         case CONFLDS   : {   Cell ps   = NIL;
 176                              Name c    = fst(snd(pat));
 177                              Cell fs   = snd(snd(pat));
 178                              Bool avar = FALSE;
 179                              for (; nonNull(fs); fs=tl(fs)) {
 180                                  Cell p = matchPat(snd(hd(fs)));
 181                                  ps     = cons(pair(fst(hd(fs)),p),ps);
 182                                  if (p!=WILDCARD)
 183                                      avar = TRUE;
 184                              }
 185                              return avar ? pair(CONFLDS,pair(c,rev(ps)))
 186                                          : WILDCARD;
 187                          }
 188
 189         case VAROPCELL :
 190         case VARIDCELL :
 191         case DICTVAR   : return pat;
 192
 193         case LAZYPAT   : {   Cell p = matchPat(snd(pat));
 194                              return (p==WILDCARD) ? WILDCARD : ap(LAZYPAT,p);
 195                          }
 196
 197         case WILDCARD  :
 198         case STRCELL   :
 199         case CHARCELL  : return WILDCARD;
 200
 201         case TUPLE     :
 202         case NAME      :
 203         case AP        : {   Cell h = getHead(pat);
 204                              if (h==nameFromInt     ||
 205                                  h==nameFromInteger || h==nameFromDouble)
 206                                  return WILDCARD;
 207 #if NPLUSK
 208                              else if (whatIs(h)==ADDPAT)
 209                                  return pat;
 210 #endif
 211 #if TREX
 212                              else if (isExt(h)) {
 213                                  Cell pf = matchPat(extField(pat));
 214                                  Cell pr = matchPat(extRow(pat));
 215                                  return (pf==WILDCARD && pr==WILDCARD)
 216                                           ? WILDCARD
 217                                           : ap2(fun(fun(pat)),pf,pr);
 218                              }
 219 #endif
 220                              else {
 221                                  List args = NIL;
 222                                  Bool avar = FALSE;
 223                                  for (; isAp(pat); pat=fun(pat)) {
 224                                      Cell p = matchPat(arg(pat));
 225                                      if (p!=WILDCARD)
 226                                          avar = TRUE;
 227                                      args = cons(p,args);
 228                                  }
 229                                  return avar ? applyToArgs(pat,args)
 230                                              : WILDCARD;
 231                              }
 232                          }
 233
 234         default        : internal("matchPat");
 235                          return NIL; /*NOTREACHED*/
 236     }
 237 }
 238
 239 #define addEqn(v,val,lds)  cons(pair(v,singleton(pair(NIL,val))),lds)
 240
 241 List remPat(pat,expr,lds)
 242 Cell pat;                         /* Produce list of definitions for eqn   */
 243 Cell expr;                        /* pat = expr, including a conformality  */
 244 List lds; {                       /* check if required.                    */
 245
 246     /* Conformality test (if required):
 247      *   pat = expr  ==>    nv = LETREC confCheck nv@pat = nv
 248      *                           IN confCheck expr
 249      *                      remPat1(pat,nv,.....);
 250      */
 251
 252     if (!failFree(pat)) {
 253         Cell confVar = inventVar();
 254         Cell nv      = inventVar();
 255         Cell locfun  = pair(confVar,         /* confVar [([nv@refPat],nv)] */
 256                             singleton(pair(singleton(ap(ASPAT,
 257                                                         pair(nv,
 258                                                              refutePat(pat)))),
 259                                            nv)));
 260
 261         if (whatIs(expr)==GUARDED) {         /* A spanner ... special case */
 262             lds  = addEqn(nv,expr,lds);      /* for guarded pattern binding*/
 263             expr = nv;
 264             nv   = inventVar();
 265         }
 266
 267         if (whatIs(pat)==ASPAT) {            /* avoid using new variable if*/
 268             nv   = fst(snd(pat));            /* a variable is already given*/
 269             pat  = snd(snd(pat));            /* by an as-pattern           */
 270         }
 271
 272         lds = addEqn(nv,                                /* nv =            */
 273                      ap(LETREC,pair(singleton(locfun),  /* LETREC [locfun] */
 274                                     ap(confVar,expr))), /* IN confVar expr */
 275                      lds);
 276
 277         return remPat1(matchPat(pat),nv,lds);
 278     }
 279
 280     return remPat1(matchPat(pat),expr,lds);
 281 }
 282
 283 static List local remPat1(pat,expr,lds)
 284 Cell pat;                         /* Add definitions for: pat = expr to    */
 285 Cell expr;                        /* list of local definitions in lds.     */
 286 List lds; {
 287     Cell c;
 288
 289     switch (whatIs(c=getHead(pat))) {
 290         case WILDCARD  :
 291         case STRCELL   :
 292         case CHARCELL  : break;
 293
 294         case ASPAT     : return remPat1(snd(snd(pat)),     /* v@pat = expr */
 295                                         fst(snd(pat)),
 296                                         addEqn(fst(snd(pat)),expr,lds));
 297
 298         case LAZYPAT   : {   Cell nv;
 299
 300                              if (isVar(expr) || isName(expr))
 301                                  nv  = expr;
 302                              else {
 303                                  nv  = inventVar();
 304                                  lds = addEqn(nv,expr,lds);
 305                              }
 306
 307                              return remPat(snd(pat),nv,lds);
 308                          }
 309
 310 #if NPLUSK
 311         case ADDPAT    : return remPat1(arg(pat),       /* n + k = expr */
 312                                         ap3(namePmSub, arg(fun(pat)), snd(c),
 313                                             expr),
 314                                         lds);
 315 #endif
 316
 317         case FINLIST   : return remPat1(mkConsList(snd(pat)),expr,lds);
 318
 319         case CONFLDS   : {   Name h  = fst(snd(pat));
 320                              Int  m  = name(h).arity;
 321                              Cell p  = h;
 322                              List fs = snd(snd(pat));
 323                              Int  i  = m;
 324                              while (0<i--)
 325                                  p = ap(p,WILDCARD);
 326                              for (; nonNull(fs); fs=tl(fs)) {
 327                                  Cell r = p;
 328                                  for (i=m-sfunPos(fst(hd(fs)),h); i>0; i--)
 329                                      r = fun(r);
 330                                  arg(r) = snd(hd(fs));
 331                              }
 332                              return remPat1(p,expr,lds);
 333                          }
 334
 335         case DICTVAR   : /* shouldn't really occur */
 336                          assert(0); /* so let's test for it then! ADR */
 337         case VARIDCELL :
 338         case VAROPCELL : return addEqn(pat,expr,lds);
 339
 340         case NAME      : if (c==nameFromInt || c==nameFromInteger
 341                                             || c==nameFromDouble) {
 342                              if (argCount==2)
 343                                  arg(fun(pat)) = translate(arg(fun(pat)));
 344                              break;
 345                          }
 346
 347                          if (argCount==1 && isCfun(c)       /* for newtype */
 348                              && cfunOf(c)==0 && name(c).defn==nameId)
 349                              return remPat1(arg(pat),expr,lds);
 350
 351                          /* intentional fall-thru */
 352         case TUPLE     : {   List ps = getArgs(pat);
 353
 354                              if (nonNull(ps)) {
 355                                  Cell nv, sel;
 356                                  Int  i;
 357
 358                                  if (isVar(expr) || isName(expr))
 359                                      nv  = expr;
 360                                  else {
 361                                      nv  = inventVar();
 362                                      lds = addEqn(nv,expr,lds);
 363                                  }
 364
 365                                  sel = ap2(nameSel,c,nv);
 366                                  for (i=1; nonNull(ps); ++i, ps=tl(ps))
 367                                       lds = remPat1(hd(ps),
 368                                                     ap(sel,mkInt(i)),
 369                                                     lds);
 370                              }
 371                          }
 372                          break;
 373
 374 #if TREX
 375         case EXT       : {   Cell nv = inventVar();
 376                              arg(fun(fun(pat)))
 377                                  = translate(arg(fun(fun(pat))));
 378                              lds = addEqn(nv,
 379                                           ap2(nameRecBrk,
 380                                               arg(fun(fun(pat))),
 381                                               expr),
 382                                           lds);
 383                              lds = remPat1(extField(pat),ap(nameFst,nv),lds);
 384                              lds = remPat1(extRow(pat),ap(nameSnd,nv),lds);
 385                          }
 386                          break;
 387 #endif
 388
 389         default        : internal("remPat1");
 390                          break;
 391     }
 392     return lds;
 393 }
 394
 395 /* --------------------------------------------------------------------------
 396  * Pattern control:
 397  * ------------------------------------------------------------------------*/
 398
 399 Void patControl( Int what )
 400 {
 401     switch (what) {
 402         case INSTALL :
 403                 /* Fall through */
 404         case RESET   : break;
 405         case MARK    : break;
 406     }
 407 }
 408
 409 /*-------------------------------------------------------------------------*/