Mercurial > urweb

comparison src/reduce.sml @ 930:51bc7681c47e

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Nullable columns *might* be working, but too much JS is generated for the page to load in finite time
author Adam Chlipala <adamc@hcoop.net>
date Sat, 12 Sep 2009 15:08:16 -0400
parents 8e540df3294d
children be6585b4058b
comparison
equal deleted inserted replaced
929:095df8f710e0 930:51bc7681c47e
98 | KnownK _ => [] 98 | KnownK _ => []
99 | Lift (nk, nc, ne) => List.tabulate (nk, fn _ => UnknownK) 99 | Lift (nk, nc, ne) => List.tabulate (nk, fn _ => UnknownK)
100 @ List.tabulate (nc, fn _ => UnknownC) 100 @ List.tabulate (nc, fn _ => UnknownC)
101 @ List.tabulate (ne, fn _ => UnknownE) 101 @ List.tabulate (ne, fn _ => UnknownE)
102 | x => [x]) 102 | x => [x])
103
104 datatype result = Yes of env | No | Maybe
105
106 fun match (env, p : pat, e : exp) =
107 case (#1 p, #1 e) of
108 (PWild, _) => Yes env
109 | (PVar (x, t), _) => Yes (KnownE e :: env)
110
111 | (PPrim p, EPrim p') =>
112 if Prim.equal (p, p') then
113 Yes env
114 else
115 No
116
117 | (PCon (_, PConVar n1, _, NONE), ECon (_, PConVar n2, _, NONE)) =>
118 if n1 = n2 then
119 Yes env
120 else
121 No
122
123 | (PCon (_, PConVar n1, _, SOME p), ECon (_, PConVar n2, _, SOME e)) =>
124 if n1 = n2 then
125 match (env, p, e)
126 else
127 No
128
129 | (PCon (_, PConFfi {mod = m1, con = con1, ...}, _, NONE),
130 ECon (_, PConFfi {mod = m2, con = con2, ...}, _, NONE)) =>
131 if m1 = m2 andalso con1 = con2 then
132 Yes env
133 else
134 No
135
136 | (PCon (_, PConFfi {mod = m1, con = con1, ...}, _, SOME ep),
137 ECon (_, PConFfi {mod = m2, con = con2, ...}, _, SOME e)) =>
138 if m1 = m2 andalso con1 = con2 then
139 match (env, p, e)
140 else
141 No
142
143 | (PRecord xps, ERecord xes) =>
144 if List.exists (fn ((CName _, _), _, _) => false
145 | _ => true) xes then
146 Maybe
147 else
148 let
149 fun consider (xps, env) =
150 case xps of
151 [] => Yes env
152 | (x, p, _) :: rest =>
153 case List.find (fn ((CName x', _), _, _) => x' = x
154 | _ => false) xes of
155 NONE => No
156 | SOME (_, e, _) =>
157 case match (env, p, e) of
158 No => No
159 | Maybe => Maybe
160 | Yes env => consider (rest, env)
161 in
162 consider (xps, env)
163 end
164
165 | _ => Maybe
103 166
104 fun kindConAndExp (namedC, namedE) = 167 fun kindConAndExp (namedC, namedE) =
105 let 168 let
106 fun kind env (all as (k, loc)) = 169 fun kind env (all as (k, loc)) =
107 case k of 170 case k of
688 | PVar (x, t) => (PVar (x, con env t), loc) 751 | PVar (x, t) => (PVar (x, con env t), loc)
689 | PPrim _ => all 752 | PPrim _ => all
690 | PCon (dk, pc, cs, po) => 753 | PCon (dk, pc, cs, po) =>
691 (PCon (dk, patCon pc, map (con env) cs, Option.map pat po), loc) 754 (PCon (dk, patCon pc, map (con env) cs, Option.map pat po), loc)
692 | PRecord xpts => (PRecord (map (fn (x, p, t) => (x, pat p, con env t)) xpts), loc) 755 | PRecord xpts => (PRecord (map (fn (x, p, t) => (x, pat p, con env t)) xpts), loc)
756
757 fun push () =
758 (ECase (exp env e,
759 map (fn (p, e) => (pat p,
760 exp (List.tabulate (patBinds p,
761 fn _ => UnknownE) @ env) e))
762 pes, {disc = con env disc, result = con env result}), loc)
763
764 fun search pes =
765 case pes of
766 [] => push ()
767 | (p, body) :: pes =>
768 case match (env, p, e) of
769 No => search pes
770 | Maybe => push ()
771 | Yes env' => exp env' body
693 in 772 in
694 (ECase (exp env e, 773 search pes
695 map (fn (p, e) => (pat p,
696 exp (List.tabulate (patBinds p, fn _ => UnknownE) @ env) e))
697 pes, {disc = con env disc, result = con env result}), loc)
698 end 774 end
699 775
700 | EWrite e => (EWrite (exp env e), loc) 776 | EWrite e => (EWrite (exp env e), loc)
701 | EClosure (n, es) => (EClosure (n, map (exp env) es), loc) 777 | EClosure (n, es) => (EClosure (n, map (exp env) es), loc)
702 778