![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to mc.sml CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Research Unix] / researchv10no / cmd / sml / src / translate|
Return to mc.sml CVS log | Up to [Research Unix] / researchv10no / cmd / sml / src / translate |
1.1 root 1: (* Copyright 1989 by AT&T Bell Laboratories *)
2: signature MC = sig
3: structure A : BAREABSYN
4: structure L : LAMBDA
5: val matchCompile : (A.pat * L.lexp) list -> L.lexp
6: val bindCompile : (A.pat * L.lexp) list -> L.lexp
7: end
8:
9: structure MC : MC = struct
10:
11: structure A : BAREABSYN = BareAbsyn
12: structure L : LAMBDA = Lambda
13:
14: open A L
15: open Access Basics ErrorMsg
16:
17: val printDepth = System.Control.Print.printDepth
18:
19: val patsUsed : int list ref = ref []
20: val maybeUsed : int list ref = ref []
21: val results : (lvar * lvar list) list ref = ref []
22:
23: fun mark(taglist,tag : int) =
24: let fun newtag[] = [tag]
25: | newtag(taglist as (t::more)) =
26: if tag = t then taglist
27: else if tag < t then tag :: taglist
28: else t :: newtag more
29: in taglist := newtag (!taglist)
30: end
31:
32: fun unused rules =
33: let fun find([],[],_) = []
34: | find([],_::r,i) = i :: find([],r,i+1)
35: | find(taglist as tag::tags,_::r,i) =
36: if tag = i
37: then find(tags,r,i+1)
38: else i :: find(taglist,r,i+1)
39: | find _ = ErrorMsg.impossible "unused in mc"
40: in find(!patsUsed,rules,0)
41: end
42: fun redundant rules =
43: if length rules = length (!patsUsed) then []
44: else unused rules
45: fun areNotRedundant () =
46: case !maybeUsed of
47: [] => ()
48: | (tag::_) => (mark(patsUsed,tag); maybeUsed := [])
49: fun areRedundant () = maybeUsed := []
50:
51: fun bind(x,v,(bindings,tag)) = ((v,x)::bindings,tag)
52:
53: fun layer (x,CONSTRAINTpat(pat,_),rhs) = layer(x,pat,rhs)
54: | layer (x,VARpat(VALvar{access=LVAR v,...}),rhs) = bind(x,v,rhs)
55: | layer _ = impossible "bad layered pattern in mc"
56:
57: fun convert(bindings,tag) =
58: let val (f,free) = nth(!results,tag)
59: fun order [] = []
60: | order (v::tl) =
61: let fun f [] = ErrorMsg.impossible "convert in translate/mc.sml"
62: | f ((w,z)::tl) = if v=w then z else f tl
63: in f bindings :: order tl
64: end
65: val args = order free
66: in mark(patsUsed,tag); APP(VAR f,RECORD(map VAR args))
67: end
68: fun convertDefault(bindings,tag) =
69: let val (f,free) = nth(!results,tag)
70: fun order [] = []
71: | order (v::tl) =
72: let fun f [] = ErrorMsg.impossible "convertD in translate/mc.sml"
73: | f ((w,z)::tl) = if v=w then z else f tl
74: in f bindings :: order tl
75: end
76: val args = order free
77: in mark(maybeUsed,tag); APP(VAR f,RECORD(map VAR args))
78: end
79:
80: val rec freevars =
81: fn VARpat(VALvar{access=LVAR v,...}) => [v]
82: | RECORDpat{pats=ref pats,...} => SortedList.foldmerge(map freevars pats)
83: | APPpat(_,pat) => freevars pat
84: | CONSTRAINTpat(pat,_) => freevars pat
85: | LAYEREDpat(l,r) => SortedList.merge(freevars l,freevars r)
86: | _ => []
87:
88: fun setup rules =
89: let val arg = mkLvar()
90: fun t(i,(pat,result)::more) =
91: let val (header,r) = t(i+1,more)
92: val record = mkLvar()
93: val returnit = mkLvar()
94: val free = freevars pat
95: fun f(_,[]) = result
96: | f(i,v::tl) = APP(FN(v,f(i+1,tl)),SELECT(i,VAR record))
97: in results := (returnit,free) :: !results;
98: (fn l => header(APP(FN(returnit,l),FN(record,f(0,free)))),
99: (pat,([],i)) :: r)
100: end
101: | t _ = (fn x => x,[])
102: in patsUsed := []; maybeUsed := [];
103: let val (header,r) = t(0,rules)
104: in (fn l => FN(arg,header(APP(l,VAR arg))),r)
105: end
106: end
107:
108: fun bindfields(record,fields,e)=
109: let fun select(i, []) = e
110: | select(i, x::xs) = APP(FN(x,select(i+1,xs)),SELECT(i,VAR record))
111: in select(0,fields)
112: end
113:
114: fun andSwitch x =
115: let
116: fun andS [] = ([],[])
117: | andS ((p::fields,rhs)::more) =
118: (case p of
119: INTpat i =>
120: let val (cases,default) = andS more
121: fun addto ((switch as (INTcon j,pats))::more) =
122: if i = j then ((INTcon i,(fields,rhs)::pats)::more)
123: else switch :: addto more
124: | addto [] = [(INTcon i,(fields,rhs)::default)]
125: | addto _ = impossible "983 type error in match compiler"
126: in (addto cases,default)
127: end
128: | REALpat r =>
129: let val (cases,default) = andS more
130: fun addto ((switch as (REALcon s,pats))::more) =
131: if r = s then ((REALcon r,(fields,rhs)::pats)::more)
132: else switch :: addto more
133: | addto [] = [(REALcon r,(fields,rhs)::default)]
134: | addto _ = impossible "48 type error in match compiler"
135: in (addto cases,default)
136: end
137: | STRINGpat s =>
138: let val (cases,default) = andS more
139: fun addto ((switch as (STRINGcon t,pats))::more) =
140: if s = t then ((STRINGcon s,(fields,rhs)::pats)::more)
141: else switch :: addto more
142: | addto [] = [(STRINGcon s,(fields,rhs)::default)]
143: | addto _ = impossible "482 type error in match compiler"
144: in (addto cases,default)
145: end
146: | CONpat(dcon as DATACON{name=r1,...}) =>
147: let val (cases,default) = andS more
148: fun addto ((switch as (DATAcon(DATACON {name=r2,...}),pats))::more) =
149: if Symbol.eq(r1,r2)
150: then (DATAcon dcon,(fields,rhs)::pats)::more
151: else switch :: addto more
152: | addto [] = [(DATAcon dcon,(fields,rhs)::default)]
153: | addto _ = impossible "87 type error in match compiler"
154: in (addto cases,default)
155: end
156: | APPpat(dcon as DATACON{name=r1,...},p) =>
157: let val (cases,default) = andS more
158: fun addto ((switch as (DATAcon(DATACON {name=r2,...}),pats))::more) =
159: if Symbol.eq(r1,r2)
160: then ((DATAcon dcon,(p::fields,rhs)::pats)::more)
161: else switch :: addto more
162: | addto [] =
163: let fun addwild (fields,rhs) = (WILDpat::fields,rhs)
164: in [(DATAcon dcon,(p::fields,rhs)::(map addwild default))]
165: end
166: | addto _ = impossible "444 type error in match compiler"
167: in (addto cases,default)
168: end
169: | WILDpat =>
170: let val (cases,default) = andS more
171: fun addto (((con as DATAcon(DATACON{const=false,...})),pats)::more) =
172: (con,(WILDpat::fields,rhs)::pats) :: addto more
173: | addto ((con,pats)::more) =
174: (con,(fields,rhs)::pats) :: addto more
175: | addto [] = []
176: in (addto cases,(fields,rhs)::default)
177: end
178: | VARpat(VALvar{access=LVAR v,...}) =>
179: andS ((WILDpat::fields,bind(x,v,rhs))::more)
180: | LAYEREDpat(v,p) => andS((p::fields,layer(x,v,rhs))::more)
181: | CONSTRAINTpat(p,_) => andS((p::fields,rhs)::more)
182: | _ => impossible "andS in mc")
183: | andS _ = impossible "andS2 in mc"
184: in andS
185: end
186:
187: fun orSwitch x =
188: let fun diffPats samefn =
189: let fun diff [] = []
190: | diff ((hd as (p,rhs))::more) =
191: case p of
192: WILDpat => [hd]
193: | VARpat(VALvar{access=LVAR v,...}) => [(WILDpat,bind(x,v,rhs))]
194: | LAYEREDpat(v,p) =>
195: diff ((p,layer(x,v,rhs))::more)
196: | CONSTRAINTpat(p,_) =>
197: diff ((p,rhs)::more)
198: | _ => (if samefn p then diff more else hd::diff more)
199: handle Match =>
200: impossible "orS.diff: type error in match compiler"
201: in diff
202: end
203: fun orS [] = impossible "orSwitch [] in mc"
204: | orS (arg as (p,rhs)::more) =
205: case p of
206: INTpat i =>
207: let val (cases,default) = orS (diffPats (fn INTpat j => i=j) arg)
208: in ((INTcon i,convert rhs)::cases,default)
209: end
210: | REALpat r =>
211: let val (cases,default) = orS (diffPats (fn REALpat s => r=s) arg)
212: in ((REALcon r,convert rhs)::cases,default)
213: end
214: | STRINGpat s =>
215: let val (cases,default) = orS (diffPats (fn STRINGpat t => s=t) arg)
216: in ((STRINGcon s,convert rhs)::cases,default)
217: end
218: | WILDpat => ([],SOME(convert rhs))
219: | VARpat(VALvar{access=LVAR v,...}) => ([],SOME(convert(bind(x,v,rhs))))
220: | CONSTRAINTpat(p,_) => orS ((p,rhs)::more)
221: | LAYEREDpat(v,p) => orS ((p,layer(x,v,rhs))::more)
222: | _ => impossible "orS in mc"
223: in orS
224: end
225:
226: fun mcand (arg as ([_],_)::_,[x]) =
227: let val singlelist = fn ([pat],rhs) => (pat,rhs)
228: | _ => impossible "singlelist in match compiler"
229: in APP(mcor (map singlelist arg), VAR x)
230: end
231: | mcand (arg as (p::fields,rhs)::more,xl as x::xs) =
232: let fun mconto (con as DATAcon(con1 as DATACON{const = false,...}),pats) =
233: let val new = mkLvar ()
234: in (con,APP(FN(new,mcand (MCopt.opt (pats,new::xs))),DECON (con1,VAR x)))
235: end
236: | mconto (con as DATAcon(DATACON {const = true,...}),pats) =
237: (con,mcand (MCopt.opt (pats,xs)))
238: | mconto _ = impossible "mconto in mc"
239: in
240: case p of
241: WILDpat => mcand([(fields,rhs)],xs)
242: | VARpat(VALvar{access=LVAR v,...}) => mcand([(fields,bind(x,v,rhs))],xs)
243: | LAYEREDpat(v,p) => mcand(((p::fields,layer(x,v,rhs))::more),xl)
244: | CONSTRAINTpat(p,_) => mcand((p::fields,rhs)::more,xl)
245: | APPpat(DATACON{sign = [_],...},_) =>
246: let val newx = mkLvar()
247: val ([(DATAcon dcon,list)],_) = andSwitch x arg
248: in APP(FN(newx,mcand(MCopt.opt(list,newx::xs))),DECON(dcon,VAR x))
249: end
250: | APPpat(DATACON{sign,...},_) =>
251: let val (cases,default) = andSwitch x arg
252: in SWITCH(VAR x,
253: map mconto cases,
254: if length cases = length sign then NONE
255: else SOME (mcand (MCopt.opt (default,xs))))
256: end
257: | CONpat(DATACON{sign=[_],...}) => mcand([(fields,rhs)],xs)
258: | CONpat(DATACON{sign,...}) =>
259: let val (cases,default) = andSwitch x arg
260: in SWITCH(VAR x,
261: map mconto cases,
262: if length cases = length sign then NONE
263: else SOME (mcand (MCopt.opt (default,xs))))
264: end
265: | RECORDpat{pats=ref [],...} => mcand([(fields,rhs)],xs)
266: | RECORDpat{pats,...} =>
267: let val newfields = map (fn _ => mkLvar()) (!pats)
268: val wild = map (fn _ => WILDpat) newfields
269: fun expand [] = []
270: | expand ((p::fields,rhs)::more) =
271: (case p of
272: RECORDpat{pats,...} => (!pats@fields,rhs) :: expand more
273: | LAYEREDpat(v,p) => expand ((p::fields,layer(x,v,rhs))::more)
274: | CONSTRAINTpat(p,_) => expand ((p::fields,rhs)::more)
275: | WILDpat => (wild@fields,rhs) :: expand more
276: | VARpat(VALvar{access=LVAR v,...}) =>
277: (wild@fields,bind(x,v,rhs)) :: expand more
278: | _ => impossible "mcand.expand in mc")
279: | expand _ = impossible "mcand.expand2 in mc"
280: in bindfields(x,newfields,mcand(MCopt.opt(expand arg,newfields@xs)))
281: end
282: | _ => (* INTpat,REALpat,STRINGpat; possibly bad VARpats *)
283: let val (cases,default) = andSwitch x arg
284: in SWITCH(VAR x,
285: map (fn (con,pats) => (con,mcand(MCopt.opt(pats,xs)))) cases,
286: SOME(mcand(MCopt.opt(default,xs))))
287: end
288: end
289: | mcand _ = impossible "mcand in mc"
290:
291: and conSwitch x =
292: let
293: fun conS [] = ([],NONE)
294: | conS (arg as (p,rhs)::more) =
295: case p of
296: CONpat(dcon as DATACON{name=r1,...}) =>
297: let fun diff [] = []
298: | diff ((hd as (p,rhs))::more) =
299: case p of
300: CONpat(DATACON{name=r2,...}) =>
301: if Symbol.eq(r1,r2) then diff more
302: else (hd::diff more)
303: | APPpat (_,_) => hd::diff more
304: | WILDpat => [hd]
305: | VARpat _ => [hd]
306: | CONSTRAINTpat(p,_) => diff ((p,rhs)::more)
307: | LAYEREDpat(v,p) => diff ((p,layer(x,v,rhs))::more)
308: | _ => impossible "conS.diff: type error in match compiler"
309: val (cases,default) = conS (diff more)
310: in ((DATAcon dcon,convert rhs)::cases,default)
311: end
312: | APPpat(dcon as DATACON{name=r1,...},_) =>
313: let fun divide [] = ([],[])
314: | divide ((hd as (p,rhs))::more) =
315: case p of
316: CONpat _ =>
317: let val (same,diff) = divide more
318: in (same,hd::diff)
319: end
320: | APPpat(DATACON{name=r2,...},p) =>
321: let val (same,diff) = divide more
322: in if Symbol.eq(r1,r2)
323: then ((p,rhs)::same,diff)
324: else (same,hd::diff)
325: end
326: | WILDpat => ([hd],[hd])
327: | VARpat(VALvar{access=LVAR v,...}) =>
328: ([(WILDpat,bind(x,v,rhs))],[hd])
329: | CONSTRAINTpat(p,_) => divide ((p,rhs)::more)
330: | LAYEREDpat(v,p) => divide ((p,layer(x,v,rhs))::more)
331: | _ => impossible "conS.divide: type error in match compiler"
332: val con = DATAcon dcon
333: val (same,diff) = divide arg
334: val lexp = mcor same (* Order imp. here: side- *)
335: val (cases,default) = conS diff (* effects in redund. chk. *)
336: in ((con,APP(lexp,DECON(dcon,VAR x)))::cases,default)
337: end
338: | WILDpat => ([],SOME(convertDefault rhs))
339: | VARpat(VALvar{access=LVAR v,...}) =>
340: ([],SOME(convertDefault(bind(x,v,rhs))))
341: | LAYEREDpat(v,p) => conS ((p,layer(x,v,rhs))::more)
342: | CONSTRAINTpat(p,_) => conS ((p,rhs)::more)
343: | _ => impossible "conS: type error in match compiler"
344: in conS
345: end
346:
347: and mcor [] = impossible "mcor.[] in mc"
348: | mcor (arg as (p,rhs)::more) =
349: let val x = mkLvar()
350: in case p of
351: CONpat(DATACON{sign=[],...}) => (* exception *)
352: let val (cases,default) = conSwitch x arg
353: in areNotRedundant();
354: FN(x,SWITCH(VAR x,cases,default))
355: end
356: | APPpat (DATACON{sign=[],...},_) => (* exn *)
357: let val (cases,default) = conSwitch x arg
358: in areNotRedundant();
359: FN(x,SWITCH(VAR x,cases,default))
360: end
361: | CONpat(DATACON{sign=[_],...}) => FN(x, convert rhs)
362: | CONpat(DATACON{sign,...}) =>
363: let val (cases,default) = conSwitch x arg
364: in FN(x,SWITCH(VAR x, cases,
365: (if length cases = length sign
366: then (areRedundant(); NONE)
367: else (areNotRedundant(); default))))
368: end
369: | APPpat(DATACON{sign=[_],...},_) =>
370: let val ([(con,lexp)],_) = conSwitch x arg
371: in areRedundant();
372: FN(x,lexp)
373: end
374: | APPpat(DATACON{sign,...},_) =>
375: let val (cases,default) = conSwitch x arg
376: in FN(x,SWITCH(VAR x, cases,
377: (if length cases = length sign
378: then (areRedundant(); NONE)
379: else (areNotRedundant(); default))))
380: end
381: | INTpat _ =>
382: let val (cases,default) = orSwitch x arg
383: in FN(x,SWITCH(VAR x,cases,default))
384: end
385: | REALpat _ =>
386: let val (cases,default) = orSwitch x arg
387: in FN(x,SWITCH(VAR x,cases,default))
388: end
389: | STRINGpat _ =>
390: let val (cases,default) = orSwitch x arg
391: in FN(x,SWITCH(VAR x,cases,default))
392: end
393: | RECORDpat{pats=ref [],...} => FN(x, convert rhs)
394: | RECORDpat{pats,...} =>
395: let val newfields = map (fn _ => mkLvar()) (!pats)
396: val wild = map (fn _ => WILDpat) newfields
397: fun expand [] = []
398: | expand ((p,rhs)::more) =
399: case p of
400: RECORDpat{pats,...} => (!pats,rhs) :: expand more
401: | LAYEREDpat(v,p) => expand ((p,layer(x,v,rhs))::more)
402: | CONSTRAINTpat(p,_) => expand ((p,rhs)::more)
403: | WILDpat => [(wild,rhs)]
404: | VARpat(VALvar{access=LVAR v,...}) =>
405: [(wild,bind(x,v,rhs))]
406: | _ => impossible "mcor.expand in mc"
407: in FN(x,bindfields(x,newfields,mcand(MCopt.opt(expand arg,newfields))))
408: end
409: | WILDpat => FN(x, convert rhs)
410: | VARpat(VALvar{access=LVAR v,...}) => FN(x,convert(bind(x,v,rhs)))
411: | LAYEREDpat(v,p) => FN(x,APP(mcor((p,layer(x,v,rhs))::more),VAR x))
412: | CONSTRAINTpat(p,_) => mcor((p,rhs)::more)
413: | _ => impossible "mcor: type error in match compiler"
414: end (* fun mcor *)
415:
416: open PrintUtil
417: fun matchPrint [] _ _ = ()
418: | matchPrint [(pat,_)] _ _ = () (* never print last rule *)
419: | matchPrint ((pat,_)::more) [] _ =
420: (print " "; PrintAbsyn.printPat(pat,!printDepth); print " => ...\n";
421: matchPrint more [] 0)
422: | matchPrint ((pat,_)::more) (taglist as (tag::tags)) i =
423: if i = tag
424: then (print " --> "; PrintAbsyn.printPat(pat,!printDepth);
425: print " => ...\n"; matchPrint more tags (i+1))
426: else (print " "; PrintAbsyn.printPat(pat,!printDepth);
427: print " => ...\n"; matchPrint more taglist (i+1))
428:
429: fun bindPrint ((pat,_)::_) =
430: (print " "; PrintAbsyn.printPat(pat,!printDepth); print " = ...\n")
431: | bindPrint _ = impossible "bindPrint in mc"
432:
433: fun noVarsIn ((pat,_)::_) =
434: let fun var WILDpat = true (* might want to flag this *)
435: | var (VARpat _) = true
436: | var (LAYEREDpat _) = true
437: | var (CONSTRAINTpat(p,_)) = var p
438: | var (APPpat(_,p)) = var p
439: | var (RECORDpat{pats=ref patlist,...}) = exists var patlist
440: | var _ = false
441: in not(var pat)
442: end
443: | noVarsIn _ = impossible "noVarsIn in mc"
444:
445: open System.Control.MC
446:
447: fun genCompile(flag1,warning1,flag2,test,warning2,printer) rules =
448: let val (header,rules') = setup rules
449: val match = header(mcor rules')
450: val unused = redundant rules
451: val last = length rules - 1
452: val printit = if !flag1 andalso not(exists (fn i => i=last) unused)
453: then (warn(warning1 ^ " not exhaustive"); true)
454: else false
455: val printit = if !flag2 andalso test(rules,unused,last)
456: then (warn warning2; true)
457: else printit
458: in if !printArgs
459: then (warn "MC called with:"; MCprint.printMatch rules)
460: else ();
461: if printit
462: then printer(rules,unused)
463: else ();
464: if !printRet
465: then (print "MC: returns with\n"; MCprint.printLexp match; newline())
466: else ();
467: match
468: end handle Syntax => (warn "MC called with:"; MCprint.printMatch rules;
469: raise Syntax)
470:
471: val bindCompile =
472: genCompile(bindExhaustive,
473: "binding",
474: bindContainsVar,
475: fn (rules,unused,last) => noVarsIn rules,
476: "binding contains no variables",
477: fn(rules,unused) => bindPrint rules)
478:
479: val matchCompile =
480: genCompile(matchExhaustive,
481: "match",
482: matchRedundant,
483: fn(rules,unused,last) => exists (fn i => i<last) unused,
484: "redundant patterns in match",
485: fn(rules,unused) => matchPrint rules unused 0)
486:
487: end (* struct MC *)
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.