Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /archive/mlsave.11/translate/mc.sml
ViewVC logotype

Annotation of /archive/mlsave.11/translate/mc.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 4054 - (view) (download)

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

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0