/[svn]/typing/typer.ml

Diff of /typing/typer.ml

Parent Directory | Revision Log | View Patch Patch

-revision 47 by abate,
Tue Jul 10 17:00:52 2007 UTC
+revision 139 by abate,
Tue Jul 10 17:09:49 2007 UTC
 Line 4
  open Location
  open Ast
- exception Pattern of string
  exception NonExhaustive of Types.descr
  exception MultipleLabel of Types.label
  exception Constraint of Types.descr * Types.descr * string
-Line 32
+Line 31
     | `And of ti * ti
     | `Diff of ti * ti
     | `Times of ti * ti
+    | `Xml of ti * ti
     | `Arrow of ti * ti
     | `Record of Types.label * bool * ti
     | `Capture of Patterns.capture
 Line 44
  module StringMap = Map.Make(S)
  module StringSet = Set.Make(S)
+ type glb = ti StringMap.t
  let mk' =
    let counter = ref 0 in
    fun loc ->
-Line 73
+Line 75
  *)
  module Regexp = struct
-   let memo = Hashtbl.create 51
    let defs = ref []
    let name =
      let c = ref 0 in
-Line 87
+Line 88
      | Star r | WeakStar r -> seq_vars accu r
      | SeqCapture (v,r) -> seq_vars (StringSet.add v accu) r
-   let rec propagate vars = function
+   let uniq_id = let r = ref 0 in fun () -> incr r; !r
+   type flat = [ `Epsilon
+               | `Elem of int * Ast.ppat  (* the int arg is used to
+                                             to stop generic comparison *)
+               | `Seq of flat * flat
+               | `Alt of flat * flat
+               | `Star of flat
+               | `WeakStar of flat ]
+   let re_loc = ref noloc
+   let rec propagate vars : regexp -> flat = function
      | Epsilon -> `Epsilon
-     | Elem x -> `Elem (vars,x)
+     | Elem x -> let p = vars x in `Elem (uniq_id (),p)
      | Seq (r1,r2) -> `Seq (propagate vars r1,propagate vars r2)
      | Alt (r1,r2) -> `Alt (propagate vars r1, propagate vars r2)
      | Star r -> `Star (propagate vars r)
      | WeakStar r -> `WeakStar (propagate vars r)
-     | SeqCapture (v,x) -> propagate (StringSet.add v vars) x
+     | SeqCapture (v,x) ->
+         let v= mk !re_loc (Capture v) in
+         propagate (fun p -> mk !re_loc (And (vars p,v))) x
    let cup r1 r2 =
      match (r1,r2) with
        | (_, `Empty) -> r1
        | (`Empty, _) -> r2
-       | (`Res t1, `Res t2) -> `Res (mk noloc (Or (t1,t2)))
+       | (`Res t1, `Res t2) -> `Res (mk !re_loc (Or (t1,t2)))
+ (*TODO: review this compilation schema to avoid explosion when
+   coding (Optional x) by  (Or(Epsilon,x)); memoization ... *)
+   module Memo = Map.Make(struct type t = flat list let compare = compare end)
+   module Coind = Set.Make(struct type t = flat list let compare = compare end)
+   let memo = ref Memo.empty
    let rec compile fin e seq : [`Res of Ast.ppat | `Empty] =
-     if List.mem seq e then `Empty
+     if Coind.mem seq !e then `Empty
-     else
+     else (
-       let e = seq :: e in
+       e := Coind.add seq !e;
        match seq with
          | [] ->
              `Res fin
          | `Epsilon :: rest ->
              compile fin e rest
-         | `Elem (vars,x) :: rest ->
+         | `Elem (_,p) :: rest ->
-             let capt = StringSet.fold
+             `Res (mk !re_loc (Prod (p, guard_compile fin rest)))
-                          (fun v t -> mk noloc (And (t, (mk noloc (Capture v)))))
-                          vars x in
-             `Res (mk noloc (Prod (capt, guard_compile fin rest)))
          | `Seq (r1,r2) :: rest ->
              compile fin e (r1 :: r2 :: rest)
          | `Alt (r1,r2) :: rest ->
              cup (compile fin e (r1::rest)) (compile fin e (r2::rest))
-         | `Star r :: rest -> cup (compile fin e (r::seq)) (compile fin e rest)
+         | `Star r :: rest ->
-         | `WeakStar r :: rest -> cup (compile fin e rest) (compile fin e (r::seq))
+             cup (compile fin e (r::seq)) (compile fin e rest)
+         | `WeakStar r :: rest ->
+             cup (compile fin e rest) (compile fin e (r::seq))
+     )
    and guard_compile fin seq =
-     try Hashtbl.find memo seq
+     try Memo.find seq !memo
      with
          Not_found ->
            let n = name () in
-           let v = mk noloc (PatVar n) in
+           let v = mk !re_loc (PatVar n) in
-           Hashtbl.add memo seq v;
+           memo := Memo.add seq v !memo;
-           let d = compile fin [] seq in
+           let d = compile fin (ref Coind.empty) seq in
            (match d with
               | `Empty -> assert false
               | `Res d -> defs := (n,d) :: !defs);
            v
-   let atom_nil = Types.mk_atom "nil"
    let constant_nil v t =
-     mk noloc (And (t, (mk noloc (Constant (v, Types.Atom atom_nil)))))
+     mk !re_loc
+       (And (t, (mk !re_loc (Constant (v, Types.Atom Sequence.nil_atom)))))
-   let compile regexp queue : ppat =
+   let compile loc regexp queue : ppat =
+     re_loc := loc;
      let vars = seq_vars StringSet.empty regexp in
      let fin = StringSet.fold constant_nil vars queue in
-     let n = guard_compile fin [propagate StringSet.empty regexp] in
+     let n = guard_compile fin [propagate (fun p -> p) regexp] in
-     Hashtbl.clear memo;
+     memo := Memo.empty;
      let d = !defs in
      defs := [];
-     mk noloc (Recurs (n,d))
+     mk !re_loc (Recurs (n,d))
  end
- let compile_regexp = Regexp.compile
+ let compile_regexp = Regexp.compile noloc
  let rec compile env { loc = loc; descr = d } : ti =
-Line 159
+Line 181
    | PatVar s ->
        (try StringMap.find s env
         with Not_found ->
-          raise_loc loc (Pattern ("Undefined type variable " ^ s))
+          raise_loc_generic loc ("Undefined type variable " ^ s)
        )
    | Recurs (t, b) -> compile (compile_many env b) t
-   | Regexp (r,q) -> compile env (Regexp.compile r q)
+   | Regexp (r,q) -> compile env (Regexp.compile loc r q)
    | Internal t -> cons loc (`Type t)
    | Or (t1,t2) -> cons loc (`Or (compile env t1, compile env t2))
    | And (t1,t2) -> cons loc (`And (compile env t1, compile env t2))
    | Diff (t1,t2) -> cons loc (`Diff (compile env t1, compile env t2))
    | Prod (t1,t2) -> cons loc (`Times (compile env t1, compile env t2))
+   | XmlT (t1,t2) -> cons loc (`Xml (compile env t1, compile env t2))
    | Arrow (t1,t2) -> cons loc (`Arrow (compile env t1, compile env t2))
    | Record (l,o,t) -> cons loc (`Record (l,o,compile env t))
    | Constant (x,v) -> cons loc (`Constant (x,v))
-Line 180
+Line 203
    List.iter (fun (v,t,x) -> x.descr' <- `Alias (v, compile env t)) b;
    env
+ let comp_fv_seen = ref []
- let rec comp_fv seen s =
+ let comp_fv_res = ref []
+ let rec comp_fv s =
+   if List.memq s !comp_fv_seen then ()
+   else (
+     comp_fv_seen := s :: !comp_fv_seen;
    match s.fv with
-     | Some l -> l
+       | Some fv -> comp_fv_res := List.rev_append fv !comp_fv_res
      | None ->
-         let l =
+           (match s.descr' with
-           match s.descr' with
+              | `Alias (_,x) -> comp_fv x
-             | `Alias (_,x) -> if List.memq s seen then [] else comp_fv (s :: seen) x
              | `Or (s1,s2)
              | `And (s1,s2)
              | `Diff (s1,s2)
-             | `Times (s1,s2)
+              | `Times (s1,s2) | `Xml (s1,s2)
-             | `Arrow (s1,s2) -> SortedList.cup (comp_fv seen s1) (comp_fv seen s2)
+              | `Arrow (s1,s2) -> comp_fv s1; comp_fv s2
-             | `Record (l,opt,s) -> comp_fv seen s
+              | `Record (l,opt,s) -> comp_fv s
-             | `Type _ -> []
+              | `Type _ -> ()
              | `Capture x
-             | `Constant (x,_) -> [x]
+              | `Constant (x,_) -> comp_fv_res := x :: !comp_fv_res
-         in
+           )
-         if seen = [] then s.fv <- Some l;
+   )
-         l
- let fv = comp_fv []
+ let fv s =
+   match s.fv with
+     | Some l -> l
+     | None ->
+         comp_fv s;
+         let l = SortedList.from_list !comp_fv_res in
+         comp_fv_res := [];
+         comp_fv_seen := [];
+         s.fv <- Some l;
+         l
  let rec typ seen s : Types.descr =
    match s.descr' with
      | `Alias (v,x) ->
          if List.memq s seen then
-           raise_loc s.loc'
+           raise_loc_generic s.loc'
-             (Pattern
+             ("Unguarded recursion on variable " ^ v ^ " in this type")
-                ("Unguarded recursion on variable " ^ v ^ " in this type"))
          else typ (s :: seen) x
      | `Type t -> t
      | `Or (s1,s2) -> Types.cup (typ seen s1) (typ seen s2)
      | `And (s1,s2) ->  Types.cap (typ seen s1) (typ seen s2)
      | `Diff (s1,s2) -> Types.diff (typ seen s1) (typ seen s2)
      | `Times (s1,s2) -> Types.times (typ_node s1) (typ_node s2)
+     | `Xml (s1,s2) ->   Types.xml (typ_node s1) (typ_node s2)
      | `Arrow (s1,s2) -> Types.arrow (typ_node s1) (typ_node s2)
      | `Record (l,o,s) -> Types.record l o (typ_node s)
-     | `Capture _ | `Constant _ -> assert false
+     | `Capture x | `Constant (x,_) -> assert false
  and typ_node s : Types.node =
    match s.type_node with
-Line 231
+Line 266
          Types.define x t;
          x
- let type_node s = Types.internalize (typ_node s)
+ let type_node s =
+   let s = typ_node s in
+   let s = Types.internalize s in
+ (*  Types.define s (Types.normalize (Types.descr s)); *)
+   s
  let rec pat seen s : Patterns.descr =
-   if fv s = [] then Patterns.constr (type_node s) else
+   if fv s = [] then Patterns.constr (Types.descr (type_node s)) else
-   match s.descr' with
+     try pat_aux seen s
+     with Patterns.Error e -> raise_loc_generic s.loc' e
+       | Location (loc,exn) when loc = noloc -> raise (Location (s.loc', exn))
+ and pat_aux seen s = match s.descr' with
      | `Alias (v,x) ->
-         if List.memq s seen then
+       if List.memq s seen
-           raise_loc s.loc'
+       then raise
-             (Pattern
+         (Patterns.Error
-                ("Unguarded recursion on variable " ^ v ^ " in this pattern"))
+            ("Unguarded recursion on variable " ^ v ^ " in this pattern"));
-         else pat (s :: seen) x
+       pat (s :: seen) x
      | `Or (s1,s2) -> Patterns.cup (pat seen s1) (pat seen s2)
      | `And (s1,s2) -> Patterns.cap (pat seen s1) (pat seen s2)
      | `Diff (s1,s2) when fv s2 = [] ->
-         let s2 = Types.cons (Types.neg (Types.descr (type_node s2)))in
+       let s2 = Types.neg (Types.descr (type_node s2)) in
          Patterns.cap (pat seen s1) (Patterns.constr s2)
      | `Diff _ ->
-         raise_loc s.loc' (Pattern "Difference not allowed in patterns")
+       raise (Patterns.Error "Difference not allowed in patterns")
      | `Times (s1,s2) -> Patterns.times (pat_node s1) (pat_node s2)
+   | `Xml (s1,s2) -> Patterns.xml (pat_node s1) (pat_node s2)
      | `Record (l,false,s) -> Patterns.record l (pat_node s)
      | `Record _ ->
-         raise_loc s.loc'
+       raise (Patterns.Error "Optional field not allowed in record patterns")
-           (Pattern "Optional field not allowed in record patterns")
      | `Capture x ->  Patterns.capture x
      | `Constant (x,c) -> Patterns.constant x c
      | `Arrow _ ->
-         raise_loc s.loc' (Pattern "Arrow not allowed in patterns")
+       raise (Patterns.Error "Arrow not allowed in patterns")
      | `Type _ -> assert false
  and pat_node s : Patterns.node =
-Line 270
+Line 314
          Patterns.define x t;
          x
- let global_types = ref StringMap.empty
  let mk_typ e =
    if fv e = [] then type_node e
-   else raise_loc e.loc' (Pattern "Capture variables are not allowed in types")
+   else raise_loc_generic e.loc' "Capture variables are not allowed in types"
- let typ e =
+ let typ glb e =
-   mk_typ (compile !global_types e)
+   mk_typ (compile glb e)
+ let pat glb e =
+   pat_node (compile glb e)
+ let register_global_types glb b =
+   let env' = compile_many glb b in
+   List.fold_left
+     (fun glb (v,{ loc = loc }) ->
+        let t = StringMap.find v env' in
+        let d = Types.descr (mk_typ t) in
+        (*              let d = Types.normalize d in*)
+        Types.Print.register_global v d;
+        if StringMap.mem v glb
+        then raise_loc_generic loc ("Multiple definition for type " ^ v);
+        StringMap.add v t glb
+     ) glb b
- let pat e =
-   let e = compile !global_types e in
-   pat_node e
- let register_global_types b =
-   let env = compile_many !global_types b in
-   List.iter (fun (v,_) ->
-                let d = Types.descr (mk_typ (StringMap.find v env)) in
-                let d = Types.normalize d in
-                Types.Print.register_global v d
-             ) b;
-   global_types := env
  (* II. Build skeleton *)
  module Fv = StringSet
- let rec expr { loc = loc; descr = d } =
+ (* IDEA: introduce a node Loc in the AST to override nolocs
+    in sub-expressions *)
+ let rec expr loc' glb { loc = loc; descr = d } =
+   let loc =  if loc = noloc then loc' else loc in
    let (fv,td) =
      match d with
-       | DebugTyper t -> (Fv.empty, Typed.DebugTyper (typ t))
+       | Forget (e,t) ->
+           let (fv,e) = expr loc glb e and t = typ glb t in
+           (fv, Typed.Forget (e,t))
        | Var s -> (Fv.singleton s, Typed.Var s)
        | Apply (e1,e2) ->
-           let (fv1,e1) = expr e1 and (fv2,e2) = expr e2 in
+           let (fv1,e1) = expr loc glb e1 and (fv2,e2) = expr loc glb 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 iface = List.map (fun (t1,t2) -> (typ glb t1, typ glb 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 iface = List.map
                          (fun (t1,t2) -> (Types.descr t1, Types.descr t2))
                          iface in
-           let (fv0,body) = branches a.fun_body in
+           let (fv0,body) = branches loc glb a.fun_body in
            let fv = match a.fun_name with
              | None -> fv0
              | Some f -> Fv.remove f fv0 in
-Line 324
+Line 377
                 Typed.fun_iface = iface;
                 Typed.fun_body = body;
                 Typed.fun_typ = t;
-                Typed.fun_fv = Fv.elements fv0
+                Typed.fun_fv = Fv.elements fv
               }
            )
        | Cst c -> (Fv.empty, Typed.Cst c)
        | Pair (e1,e2) ->
-           let (fv1,e1) = expr e1 and (fv2,e2) = expr e2 in
+           let (fv1,e1) = expr loc glb e1 and (fv2,e2) = expr loc glb e2 in
            (Fv.union fv1 fv2, Typed.Pair (e1,e2))
+       | Xml (e1,e2) ->
+           let (fv1,e1) = expr loc glb e1 and (fv2,e2) = expr loc glb e2 in
+           (Fv.union fv1 fv2, Typed.Xml (e1,e2))
        | Dot (e,l) ->
-           let (fv,e) = expr e in
+           let (fv,e) = expr loc glb e in
            (fv,  Typed.Dot (e,l))
        | RecordLitt r ->
            let fv = ref Fv.empty in
            let r  = List.sort (fun (l1,_) (l2,_) -> compare l1 l2) r in
            let r = List.map
                      (fun (l,e) ->
-                        let (fv2,e) = expr e in fv := Fv.union !fv fv2; (l,e))
+                        let (fv2,e) = expr loc glb e
+                        in fv := Fv.union !fv fv2; (l,e))
                      r in
            let rec check = function
              | (l1,_) :: (l2,_) :: _ when l1 = l2 ->
-Line 349
+Line 406
            check r;
            (!fv, Typed.RecordLitt r)
        | Op (op,le) ->
-           let (fvs,ltes) = List.split (List.map expr le) in
+           let (fvs,ltes) = List.split (List.map (expr loc glb) le) in
            let fv = List.fold_left Fv.union Fv.empty fvs in
            (fv, Typed.Op (op,ltes))
        | Match (e,b) ->
-           let (fv1,e) = expr e
+           let (fv1,e) = expr loc glb e
-           and (fv2,b) = branches b in
+           and (fv2,b) = branches loc glb b in
            (Fv.union fv1 fv2, Typed.Match (e, b))
        | Map (e,b) ->
-           let (fv1,e) = expr e
+           let (fv1,e) = expr loc glb e
-           and (fv2,b) = branches b in
+           and (fv2,b) = branches loc glb b in
            (Fv.union fv1 fv2, Typed.Map (e, b))
+       | Try (e,b) ->
+           let (fv1,e) = expr loc glb e
+           and (fv2,b) = branches loc glb b in
+           (Fv.union fv1 fv2, Typed.Try (e, b))
    in
    fv,
    { Typed.exp_loc = loc;
-Line 367
+Line 428
      Typed.exp_descr = td;
    }
-   and branches b =
+   and branches loc glb b =
      let fv = ref Fv.empty in
      let accept = ref Types.empty in
      let b = List.map
                (fun (p,e) ->
-                  let (fv2,e) = expr e in
+                  let (fv2,e) = expr loc glb e in
+                  let p = pat glb p in
+                  let fv2 = List.fold_right Fv.remove (Patterns.fv p) fv2 in
                   fv := Fv.union !fv fv2;
-                  let p = pat p in
                   accept := Types.cup !accept (Types.descr (Patterns.accept p));
                   { Typed.br_used = false;
                     Typed.br_pat = p;
-Line 389
+Line 451
       }
      )
+ let expr = expr noloc
+ let let_decl glb p e =
+   let (_,e) = expr glb e in
+   { Typed.let_pat = pat glb p;
+     Typed.let_body = e;
+     Typed.let_compiled = None }
+ (* III. Type-checks *)
  module Env = StringMap
+ type env = Types.descr Env.t
  open Typed
+ let warning loc msg =
+   Format.fprintf !Location.warning_ppf "Warning %a:@\n%a%s@\n"
+     Location.print_loc loc
+     Location.html_hilight loc
+     msg
  let check loc t s msg =
    if not (Types.subtype t s) then raise_loc loc (Constraint (t, s, msg))
-Line 406
+Line 484
    d
  and type_check' loc env e constr precise = match e with
+   | Forget (e,t) ->
+       let t = Types.descr t in
+       ignore (type_check env e t false);
+       t
    | Abstraction a ->
        let t =
          try Types.Arrow.check_strenghten a.fun_typ constr
-Line 422
+Line 504
             ignore (type_check_branches loc env t1 a.fun_body t2 false)
          ) a.fun_iface;
        t
    | Match (e,b) ->
        let t = type_check env e b.br_accept true in
        type_check_branches loc env t b constr precise
-   | Pair (e1,e2) ->
+   | Try (e,b) ->
-       let rects = Types.Product.get constr in
+       let te = type_check env e constr precise in
-       if Types.Product.is_empty rects then
+       let tb = type_check_branches loc env Types.any b constr precise in
-         raise_loc loc (ShouldHave (constr,"but it is a pair."));
+       Types.cup te tb
-       let pi1 = Types.Product.pi1 rects in
-       let t1 = type_check env e1 (Types.Product.pi1 rects)
-                  (precise || (Types.Product.need_second rects))in
-       let rects = Types.Product.restrict_1 rects t1 in
-       let t2 = type_check env e2 (Types.Product.pi2 rects) precise in
-       if precise then
-         Types.times (Types.cons t1) (Types.cons t2)
-       else
-         constr
+   | Pair (e1,e2) ->
+       type_check_pair loc env e1 e2 constr precise
+   | Xml (e1,e2) ->
+       type_check_pair ~kind:`XML loc env e1 e2 constr precise
    | RecordLitt r ->
        let rconstr = Types.Record.get constr in
        if Types.Record.is_empty rconstr then
          raise_loc loc (ShouldHave (constr,"but it is a record."));
+ (* Completely buggy !  Need to check at the end that all required labels
+    are present ...A better to do it without precise = true ? *)
+       let precise = true in
        let (rconstr,res) =
          List.fold_left
            (fun (rconstr,res) (l,e) ->
-Line 455
+Line 536
                 raise_loc loc
                   (ShouldHave (constr,(Printf.sprintf
                                          "Field %s is not allowed here."
-                                         (Types.label_name l)
+                                         (Types.LabelPool.value l)
                                       )
                               ));
               let t = type_check env e pi true in
-Line 468
+Line 549
               (rconstr,res)
            ) (rconstr, if precise then Types.Record.any else constr) r
        in
+ (*      check loc res constr ""; *)
        res
    | Map (e,b) ->
-Line 475
+Line 557
        let constr' = Sequence.approx (Types.cap Sequence.any constr) in
        let exact = Types.subtype (Sequence.star constr') constr in
-       if exact then (
-         (* Note: typing mail fail because of the approx on t *)
-         let res = type_check_branches loc env (Sequence.approx t)
-                     b constr' precise in
-         if precise then Sequence.star res else constr
-       )
-       else
          (* Note:
             - could be more precise by integrating the decomposition
             of constr inside Sequence.map.
          *)
          let res =
            Sequence.map
-             (fun t -> type_check_branches loc env t b constr' true)
+           (fun t ->
+              type_check_branches loc env t b constr' (precise || (not exact)))
              t in
          if not exact then check loc res constr "";
          if precise then res else constr
-Line 510
+Line 585
          let res = Sequence.concat t1 t2 in
          check loc res constr "";
          if precise then res else constr
+   | Apply (e1,e2) ->
+ (*
+       let constr' = Sequence.star
+                       (Sequence.approx (Types.cap Sequence.any constr)) in
+       let t1 = type_check env e1 (Types.cup Types.Arrow.any constr') true in
+       let t1_fun = Types.Arrow.get t1 in
+       let has_fun = not (Types.Arrow.is_empty t1_fun)
+       and has_seq = not (Types.subtype t1 Types.Arrow.any) in
+       let constr' =
+         Types.cap
+           (if has_fun then Types.Arrow.domain t1_fun else Types.any)
+           (if has_seq then constr' else Types.any)
+       in
+       let need_arg = has_fun && Types.Arrow.need_arg t1_fun in
+       let precise  = need_arg || has_seq in
+       let t2 = type_check env e2 constr' precise in
+       let res = Types.cup
+                   (if has_fun then
+                      if need_arg then Types.Arrow.apply t1_fun t2
+                      else Types.Arrow.apply_noarg t1_fun
+                    else Types.empty)
+                   (if has_seq then Sequence.concat t1 t2
+                    else Types.empty)
+       in
+       check loc res constr "";
+       res
+ *)
+       let t1 = type_check env e1 Types.Arrow.any true in
+       let t1 = Types.Arrow.get t1 in
+       let dom = Types.Arrow.domain t1 in
+       let res =
+         if Types.Arrow.need_arg t1 then
+           let t2 = type_check env e2 dom true in
+           Types.Arrow.apply t1 t2
+         else
+           (ignore (type_check env e2 dom false); Types.Arrow.apply_noarg t1)
+       in
+       check loc res constr "";
+       res
    | Op ("flatten", [e]) ->
        let constr' = Sequence.star
                        (Sequence.approx (Types.cap Sequence.any constr)) in
-Line 528
+Line 644
        check loc t constr "";
        t
+ and type_check_pair ?(kind=`Normal) loc env e1 e2 constr precise =
+   let rects = Types.Product.get ~kind constr in
+   if Types.Product.is_empty rects then
+     (match kind with
+       | `Normal -> raise_loc loc (ShouldHave (constr,"but it is a pair."))
+       | `XML -> raise_loc loc (ShouldHave (constr,"but it is an XML element.")));
+   let pi1 = Types.Product.pi1 rects in
+   let t1 = type_check env e1 (Types.Product.pi1 rects)
+              (precise || (Types.Product.need_second rects))in
+   let rects = Types.Product.restrict_1 rects t1 in
+   let t2 = type_check env e2 (Types.Product.pi2 rects) precise in
+   if precise then
+     match kind with
+       | `Normal -> Types.times (Types.cons t1) (Types.cons t2)
+       | `XML -> Types.xml (Types.cons t1) (Types.cons t2)
+   else
+     constr
  and compute_type env e =
    type_check env e Types.any true
  and compute_type' loc env = function
-   | DebugTyper t -> Types.descr t
    | Var s ->
        (try Env.find s env
         with Not_found -> raise_loc loc (UnboundId s)
        )
-   | Apply (e1,e2) ->
-       let t1 = type_check env e1 Types.Arrow.any true in
-       let t1 = Types.Arrow.get t1 in
-       let dom = Types.Arrow.domain t1 in
-       if Types.Arrow.need_arg t1 then
-         let t2 = type_check env e2 dom true in
-         Types.Arrow.apply t1 t2
-       else
-         (ignore (type_check env e2 dom false); Types.Arrow.apply_noarg t1)
    | Cst c -> Types.constant c
    | Dot (e,l) ->
        let t = type_check env e Types.Record.any true in
-Line 610
+Line 736
              tres
          )
+ and type_let_decl env l =
+   let acc = Types.descr (Patterns.accept l.let_pat) in
+   let t = type_check env l.let_body acc true in
+   let res = Patterns.filter t l.let_pat in
+   List.map (fun (x,t) -> (x, Types.descr t)) res
+ and type_rec_funs env l =
+   let types =
+     List.fold_left
+       (fun accu -> function  {let_body={exp_descr=Abstraction a}} as l ->
+          let t = a.fun_typ in
+          let acc = Types.descr (Patterns.accept l.let_pat) in
+          if not (Types.subtype t acc) then
+            raise_loc l.let_body.exp_loc (NonExhaustive (Types.diff t acc));
+          let res = Patterns.filter t l.let_pat in
+          List.fold_left (fun accu (x,t) -> (x, Types.descr t)::accu) accu res
+          | _ -> assert false) [] l
+   in
+   let env' = List.fold_left (fun env (x,t) -> Env.add x t env) env types in
+   List.iter
+     (function  { let_body = { exp_descr = Abstraction a } } as l ->
+        ignore (type_check env' l.let_body Types.any false)
+        | _ -> assert false) l;
+   types
  and type_op loc op args =
    match (op,args) with
-     | ("+", [loc1,t1; loc2,t2]) ->
+     | "+", [loc1,t1; loc2,t2] ->
          type_int_binop Intervals.add loc1 t1 loc2 t2
-     | ("*", [loc1,t1; loc2,t2]) ->
+     | "-", [loc1,t1; loc2,t2] ->
+         type_int_binop Intervals.sub loc1 t1 loc2 t2
+     | ("*" | "/"), [loc1,t1; loc2,t2] ->
          type_int_binop (fun i1 i2 -> Intervals.any) loc1 t1 loc2 t2
-     | ("@", [loc1,t1; loc2,t2]) ->
+     | "@", [loc1,t1; loc2,t2] ->
          check loc1 t1 Sequence.any
            "The first argument of @ must be a sequence";
          Sequence.concat t1 t2
-     | ("flatten", [loc1,t1]) ->
+     | "flatten", [loc1,t1] ->
          check loc1 t1 Sequence.seqseq
            "The argument of flatten must be a sequence of sequences";
          Sequence.flatten t1
+     | "load_xml", [loc1,t1] ->
+         check loc1 t1 Sequence.string
+           "The argument of load_xml must be a string (filename)";
+         Types.any
+     | "raise", [loc1,t1] ->
+         Types.empty
+     | "print_xml", [loc1,t1] ->
+         Sequence.string
+     | "print", [loc1,t1] ->
+         check loc1 t1 Sequence.string
+           "The argument of print must be a string";
+         Sequence.nil_type
+     | "dump_to_file", [loc1,t1; loc2,t2] ->
+         check loc1 t1 Sequence.string
+           "The argument of dump_to_file must be a string (filename)";
+         check loc2 t2 Sequence.string
+           "The argument of dump_to_file must be a string (value to dump)";
+         Sequence.nil_type
+     | "int_of", [loc1,t1] ->
+         check loc1 t1 Sequence.string
+           "The argument of int_of must be a string";
+         if not (Types.subtype t1 Builtin.intstr) then
+           warning loc "This application of int_of may fail";
+         Types.interval Intervals.any
+     | "string_of", [loc1,t1] ->
+         Sequence.string
      | _ -> assert false
  and type_int_binop f loc1 t1 loc2 t2 =

 Legend:



Removed from v.47
 


changed lines


 
Added in v.139
 Legend:



Removed from v.47
 


changed lines


 
Added in v.139
-Removed from v.47
+Added in v.139

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