/[svn]/typing/typer.ml

Diff of /typing/typer.ml

Parent Directory | Revision Log | View Patch Patch

-revision 5 by abate,
Tue Jul 10 16:57:03 2007 UTC
+revision 6 by abate,
Tue Jul 10 16:57:08 2007 UTC
 Line 253
  (* II. Build skeleton *)
+ module Fv = StringSet
  let rec expr { loc = loc; descr = d } =
-   let td =
+   let (fv,td) =
      match d with
-       | Var s -> Typed.Var s
+       | Var s -> (Fv.singleton s, Typed.Var s)
-       | Apply (e1,e2) -> Typed.Apply (expr e1, expr e2)
+       | Apply (e1,e2) ->
+           let (fv1,e1) = expr e1 and (fv2,e2) = expr e2 in
+           (Fv.union fv1 fv2, Typed.Apply (e1,e2))
        | Abstraction a ->
+           let iface = List.map (fun (t1,t2) -> (typ t1, typ t2)) a.fun_iface in
+           let t = List.fold_left
+                     (fun accu (t1,t2) -> Types.cap accu (Types.arrow t1 t2))
+                     Types.any iface in
+           let (fv0,body) = branches a.fun_body in
+           let fv = match a.fun_name with
+             | None -> fv0
+             | Some f -> Fv.remove f fv0 in
+           (fv,
            Typed.Abstraction
              { Typed.fun_name = a.fun_name;
-               Typed.fun_iface =
+                Typed.fun_iface = iface;
-                 List.map (fun (t1,t2) -> (typ t1, typ t2)) a.fun_iface;
+                Typed.fun_body = body;
-               Typed.fun_body =
+                Typed.fun_typ = t;
-                 branches a.fun_body
+                Typed.fun_fv = Fv.elements fv0
              }
-       | Cst c -> Typed.Cst c
+           )
-       | Pair (e1,e2) -> Typed.Pair (expr e1, expr e2)
+       | Cst c -> (Fv.empty, Typed.Cst c)
-       | RecordLitt r -> Typed.RecordLitt (List.map (fun (l,e) -> (l, expr e)) r)
+       | Pair (e1,e2) ->
-       | Op (o,e) -> Typed.Op (o, expr e)
+           let (fv1,e1) = expr e1 and (fv2,e2) = expr e2 in
-       | Match (e,b) -> Typed.Match (expr e, branches b)
+           (Fv.union fv1 fv2, Typed.Pair (e1,e2))
-       | Map (e,b) -> Typed.Map (expr e, branches b)
+       | RecordLitt r ->
+           (* XXX TODO: check that no label appears twice *)
+           let fv = ref Fv.empty in
+           let r = List.map
+                     (fun (l,e) ->
+                        let (fv2,e) = expr e in
+                        fv := Fv.union !fv fv2;
+                        (l,e)
+                     ) r in
+           (!fv, Typed.RecordLitt r)
+       | Op (o,e) ->
+           let (fv,e) = expr e in (fv, Typed.Op (o,e))
+       | Match (e,b) ->
+           let (fv1,e) = expr e
+           and (fv2,b) = branches b in
+           (Fv.union fv1 fv2, Typed.Match (e, b))
+       | Map (e,b) ->
+           let (fv1,e) = expr e
+           and (fv2,b) = branches b in
+           (Fv.union fv1 fv2, Typed.Map (e, b))
    in
-   { Typed.loc = loc;
+   fv,
+   { Typed.exp_loc = loc;
      Typed.exp_typ = Types.empty;
      Typed.exp_descr = td;
-     Typed.fv = []  (* XXX TODO *)
    }
-   and branches b = List.map branch b
+   and branches b =
-   and branch (p,e) =
+     let fv = ref Fv.empty in
-     { Typed.used = false;
+     let b = List.map
+               (fun (p,e) ->
+                  let (fv2,e) = expr e in
+                  fv := Fv.union !fv fv2;
+                  { Typed.br_used = false;
        Typed.br_typ = Types.empty;
        Typed.br_pat = pat p;
-       Typed.br_body = expr e }
+                    Typed.br_body = e }
+               ) b in
+     (!fv,b)
+ module Env = StringMap
+ open Typed
+ let rec compute_type env e =
+   let d = compute_type' e.exp_loc env e.exp_descr in
+   e.exp_typ <- Types.cup e.exp_typ d;
+   d
+ and compute_type' loc env = function
+   | Var s -> Env.find s env
+   | Apply (e1,e2) ->
+       let t1 = compute_type env e1 and t2 = compute_type env e2 in
+       Types.apply t1 t2
+   | Abstraction a ->
+       let env = match a.fun_name with
+         | None -> env
+         | Some f -> Env.add f a.fun_typ env in
+       List.iter (fun (t1,t2) ->
+                    let t = type_branches env (Types.descr t1) a.fun_body in
+                    if not (Types.subtype t (Types.descr t2)) then
+                      failwith "Constraint not satisfied"
+                 ) a.fun_iface;
+       a.fun_typ
+   | Cst c -> Types.constant c
+   | Pair (e1,e2) ->
+       let t1 = compute_type env e1 and t2 = compute_type env e2 in
+       let t1 = Types.cons t1 and t2 = Types.cons t2 in
+       Types.times t1 t2
+   | RecordLitt r ->
+       List.fold_left
+         (fun accu (l,e) ->
+            let t = compute_type env e in
+            let t = Types.record l false (Types.cons t) in
+            Types.cap accu t
+         ) Types.Record.any r
+   | Op (op,e) -> assert false
+   | Match (e,b) ->
+       let t = compute_type env e in
+       type_branches env t b
+   | Map (e,b) -> assert false
+ and type_branches env targ branches =
+   if Types.is_empty targ then Types.empty
+   else branches_aux env targ Types.empty branches
+ and branches_aux env targ tres = function
+   | [] -> failwith "Non-exhaustive pattern matching"
+   | b :: rem ->
+       let p = b.br_pat in
+       let acc = Types.descr (Patterns.accept p) in
+       let targ' = Types.cap targ acc in
+       if Types.is_empty targ'
+       then branches_aux env targ tres rem
+       else
+         ( b.br_used <- true;
+           let res = Patterns.filter targ' p in
+           let env' = List.fold_left
+                        (fun env (x,t) -> Env.add x (Types.descr t) env)
+                        env res in
+           let t = compute_type env' b.br_body in
+           branches_aux env (Types.diff targ acc) (Types.cup t tres) rem
+         )
- let compute_type t = failwith "Not yet implemented"

 Legend:



Removed from v.5
 


changed lines


 
Added in v.6
 Legend:



Removed from v.5
 


changed lines


 
Added in v.6
-Removed from v.5
+Added in v.6

CVS Admin">CVS Admin	ViewVC Help
Powered by ViewVC 1.1.5