1 /* -*- mode: hugs-c; -*- */
2 /* --------------------------------------------------------------------------
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
9 * $RCSfile: desugar.c,v $
11 * $Date: 1998/12/02 13:22:05 $
12 * ------------------------------------------------------------------------*/
23 /* --------------------------------------------------------------------------
24 * Local function prototypes:
25 * ------------------------------------------------------------------------*/
27 static Void local transPair Args((Pair));
28 static Void local transTriple Args((Triple));
29 static Void local transCase Args((Cell));
30 static Cell local transRhs Args((Cell));
31 static Cell local expandLetrec Args((Cell));
32 static Cell local transComp Args((Cell,List,Cell));
33 static Cell local transDo Args((Cell,Cell,Cell,List));
34 static Cell local transConFlds Args((Cell,List));
35 static Cell local transUpdFlds Args((Cell,List,List));
37 /* --------------------------------------------------------------------------
38 * Translation: Convert input expressions into a less complex language
39 * of terms using only LETREC, AP, constants and vars.
40 * Also remove pattern definitions on lhs of eqns.
41 * ------------------------------------------------------------------------*/
43 Cell translate(e) /* Translate expression: */
46 case LETREC : snd(snd(e)) = translate(snd(snd(e)));
47 return expandLetrec(e);
49 case COND : transTriple(snd(e));
52 case AP : fst(e) = translate(fst(e));
54 if (fst(e)==nameId || fst(e)==nameInd)
55 return translate(snd(e));
56 #if USE_NEWTYPE_FOR_DICTS
60 return translate(snd(e));
62 snd(e) = translate(snd(e));
65 case NAME : if (e==nameOtherwise)
68 if (isName(name(e).defn))
70 if (isPair(name(e).defn))
71 return snd(name(e).defn);
76 case RECSEL : return nameRecSel;
88 case CHARCELL : return e;
90 case FINLIST : mapOver(translate,snd(e));
91 return mkConsList(snd(e));
93 case DOCOMP : { Cell m = translate(fst(fst(snd(e))));
94 Cell m0 = snd(fst(snd(e)));
95 Cell r = translate(fst(snd(snd(e))));
98 return transDo(m,m0,r,snd(snd(snd(e))));
101 case COMP : return transComp(translate(fst(snd(e))),
105 case CONFLDS : return transConFlds(fst(snd(e)),snd(snd(e)));
107 case UPDFLDS : return transUpdFlds(fst3(snd(e)),
111 case CASE : { Cell nv = inventVar();
112 mapProc(transCase,snd(snd(e)));
114 pair(singleton(pair(nv,snd(snd(e)))),
115 ap(nv,translate(fst(snd(e))))));
118 case LAMBDA : { Cell nv = inventVar();
127 default : internal("translate");
132 static Void local transPair(pr) /* Translate each component in a */
133 Pair pr; { /* pair of expressions. */
134 fst(pr) = translate(fst(pr));
135 snd(pr) = translate(snd(pr));
138 static Void local transTriple(tr) /* Translate each component in a */
139 Triple tr; { /* triple of expressions. */
140 fst3(tr) = translate(fst3(tr));
141 snd3(tr) = translate(snd3(tr));
142 thd3(tr) = translate(thd3(tr));
145 Void transAlt(e) /* Translate alt: */
146 Cell e; { /* ([Pat], Rhs) ==> ([Pat], Rhs') */
147 snd(e) = transRhs(snd(e));
150 static Void local transCase(c) /* Translate case: */
151 Cell c; { /* (Pat, Rhs) ==> ([Pat], Rhs') */
152 fst(c) = singleton(fst(c));
153 snd(c) = transRhs(snd(c));
156 List transBinds(bs) /* Translate list of bindings: */
157 List bs; { /* eliminating pattern matching on */
158 List newBinds=NIL; /* lhs of bindings. */
159 for (; nonNull(bs); bs=tl(bs)) {
160 if (isVar(fst(hd(bs)))) {
161 mapProc(transAlt,snd(hd(bs)));
162 newBinds = cons(hd(bs),newBinds);
165 newBinds = remPat(fst(snd(hd(bs))),
166 snd(snd(hd(bs)))=transRhs(snd(snd(hd(bs)))),
172 static Cell local transRhs(rhs) /* Translate rhs: removing line nos */
174 switch (whatIs(rhs)) {
175 case LETREC : snd(snd(rhs)) = transRhs(snd(snd(rhs)));
176 return expandLetrec(rhs);
178 case GUARDED : mapOver(snd,snd(rhs)); /* discard line number */
179 mapProc(transPair,snd(rhs));
182 default : return translate(snd(rhs)); /* discard line number */
186 Cell mkConsList(es) /* Construct expression for list es */
187 List es; { /* using nameNil and nameCons */
191 return ap2(nameCons,hd(es),mkConsList(tl(es)));
194 static Cell local expandLetrec(root) /* translate LETREC with list of */
195 Cell root; { /* groups of bindings (from depend. */
196 Cell e = snd(snd(root)); /* analysis) to use nested LETRECs */
197 List bss = fst(snd(root));
200 if (isNull(bss)) /* should never happen, but just in */
201 return e; /* case: LETREC [] IN e ==> e */
203 mapOver(transBinds,bss); /* translate each group of bindings */
205 for (temp=root; nonNull(tl(bss)); bss=tl(bss)) {
206 fst(snd(temp)) = hd(bss);
207 snd(snd(temp)) = ap(LETREC,pair(NIL,e));
208 temp = snd(snd(temp));
210 fst(snd(temp)) = hd(bss);
215 /* --------------------------------------------------------------------------
216 * Translation of list comprehensions is based on the description in
217 * `The Implementation of Functional Programming Languages':
219 * [ e | qs ] ++ l => transComp e qs l
220 * transComp e [] l => e : l
221 * transComp e ((p<-xs):qs) l => LETREC _h [] = l
222 * _h (p:_xs) = transComp e qs (_h _xs)
223 * _h (_:_xs) = _h _xs --if p !failFree
225 * transComp e (b:qs) l => if b then transComp e qs l else l
226 * transComp e (decls:qs) l => LETREC decls IN transComp e qs l
227 * ------------------------------------------------------------------------*/
229 static Cell local transComp(e,qs,l) /* Translate [e | qs] ++ l */
238 case FROMQUAL : { Cell ld = NIL;
239 Cell hVar = inventVar();
240 Cell xsVar = inventVar();
242 if (!failFree(fst(snd(q))))
243 ld = cons(pair(singleton(
250 ld = cons(pair(singleton(
258 ld = cons(pair(singleton(nameNil),
263 pair(singleton(pair(hVar,
266 translate(snd(snd(q))))));
270 expandLetrec(ap(LETREC,
272 transComp(e,qs1,l))));
274 case BOOLQUAL : return ap(COND,
275 triple(translate(snd(q)),
281 return ap2(nameCons,e,l);
284 /* --------------------------------------------------------------------------
285 * Translation of monad comprehensions written using do-notation:
288 * do { p <- exp; qs } => LETREC _h p = do { qs }
289 * _h _ = zero{m0} -- if monad with 0
291 * do { LET decls; qs } => LETREC decls IN do { qs }
292 * do { IF guard; qs } => if guard then do { qs } else zero{m0}
293 * do { e; qs } => LETREC _h _ = [ e | qs ] in bind m exp _h
295 * where m :: Monad f, m0 :: Monad0 f
296 * ------------------------------------------------------------------------*/
298 static Cell local transDo(m,m0,e,qs) /* Translate do { qs ; e } */
308 case FROMQUAL : { Cell ld = NIL;
309 Cell hVar = inventVar();
311 if (!failFree(fst(snd(q))) && nonNull(m0))
312 ld = cons(pair(singleton(WILDCARD),
313 ap(nameZero,m0)),ld);
315 ld = cons(pair(singleton(fst(snd(q))),
316 transDo(m,m0,e,qs1)),
320 pair(singleton(pair(hVar,ld)),
323 translate(snd(snd(q))),
327 case DOQUAL : { Cell hVar = inventVar();
328 Cell ld = cons(pair(singleton(WILDCARD),
329 transDo(m,m0,e,qs1)),
332 pair(singleton(pair(hVar,ld)),
340 expandLetrec(ap(LETREC,
342 transDo(m,m0,e,qs1))));
344 case BOOLQUAL : return ap(COND,
345 triple(translate(snd(q)),
353 /* --------------------------------------------------------------------------
354 * Translation of named field construction and update:
356 * Construction is implemented using the following transformation:
358 * C{x1=e1, ..., xn=en} = C v1 ... vm
360 * vi = e1, if the ith component of C is labelled with x1
362 * = en, if the ith component of C is labelled with xn
363 * = undefined, otherwise
365 * Update is implemented using the following transformation:
367 * e{x1=e1, ..., xn=en}
368 * = let nv (C a1 ... am) v1 ... vn = C a1' .. am'
369 * nv (D b1 ... bk) v1 ... vn = D b1' .. bk
371 * nv _ v1 ... vn = error "failed update"
374 * nv, v1, ..., vn, a1, ..., am, b1, ..., bk, ... are new variables,
375 * C,D,... = { K | K is a constr fun s.t. {x1,...,xn} subset of sels(K)}
377 * ai' = v1, if the ith component of C is labelled with x1
379 * = vn, if the ith component of C is labelled with xn
383 * The error case may be omitted if C,D,... is an enumeration of all of the
384 * constructors for the datatype concerned. Strictly speaking, error case
385 * isn't needed at all -- the only benefit of including it is that the user
386 * will get a "failed update" message rather than a cryptic {v354 ...}.
387 * So, for now, we'll go with the second option!
389 * For the time being, code for each update operation is generated
390 * independently of any other updates. However, if updates are used
391 * frequently, then we might want to consider changing the implementation
392 * at a later stage to cache definitions of functions like nv above. This
393 * would create a shared library of update functions, indexed by a set of
394 * constructors {C,D,...}.
395 * ------------------------------------------------------------------------*/
397 static Cell local transConFlds(c,flds) /* Translate C{flds} */
401 Int m = name(c).arity;
404 e = ap(e,nameUndefined);
405 for (; nonNull(flds); flds=tl(flds)) {
407 for (i=m-sfunPos(fst(hd(flds)),c); i>0; i--)
409 arg(a) = translate(snd(hd(flds)));
414 static Cell local transUpdFlds(e,cs,flds)/* Translate e{flds} */
415 Cell e; /* (cs is corresp list of constrs) */
418 Cell nv = inventVar();
419 Cell body = ap(nv,translate(e));
424 for (; nonNull(fs); fs=tl(fs)) { /* body = nv e1 ... en */
425 Cell b = hd(fs); /* args = [v1, ..., vn] */
426 body = ap(body,translate(snd(b)));
427 args = cons(inventVar(),args);
430 for (; nonNull(cs); cs=tl(cs)) { /* Loop through constructors to */
431 Cell c = hd(cs); /* build up list of alts. */
435 Int m = name(c).arity;
438 for (i=m; i>0; i--) { /* pat = C a1 ... am */
439 Cell a = inventVar(); /* rhs = C a1 ... am */
444 for (fs=flds; nonNull(fs); fs=tl(fs), as=tl(as)) {
445 Name s = fst(hd(fs)); /* Replace approp ai in rhs with */
446 Cell r = rhs; /* vars from [v1,...,vn] */
447 for (i=m-sfunPos(s,c); i>0; i--)
452 alts = cons(pair(cons(pat,args),rhs),alts);
454 return ap(LETREC,pair(singleton(pair(nv,alts)),body));
457 /* --------------------------------------------------------------------------
459 * ------------------------------------------------------------------------*/
461 Void desugarControl(what)
472 /*-------------------------------------------------------------------------*/