camlspotter avatar camlspotter committed 4f42860 Merge

version string fix

Comments (0)

Files changed (19)

 typing/primitive.cmx : utils/misc.cmx typing/primitive.cmi
 typing/printtyp.cmo : typing/types.cmi typing/primitive.cmi \
     typing/predef.cmi typing/path.cmi typing/outcometree.cmi \
-    typing/oprint.cmi utils/misc.cmi parsing/longident.cmi typing/ident.cmi \
-    typing/env.cmi typing/ctype.cmi utils/clflags.cmi typing/btype.cmi \
-    parsing/asttypes.cmi typing/printtyp.cmi
+    typing/oprint.cmi utils/misc.cmi parsing/longident.cmi \
+    parsing/location.cmi typing/ident.cmi typing/env.cmi typing/ctype.cmi \
+    utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi \
+    typing/printtyp.cmi
 typing/printtyp.cmx : typing/types.cmx typing/primitive.cmx \
     typing/predef.cmx typing/path.cmx typing/outcometree.cmi \
-    typing/oprint.cmx utils/misc.cmx parsing/longident.cmx typing/ident.cmx \
-    typing/env.cmx typing/ctype.cmx utils/clflags.cmx typing/btype.cmx \
-    parsing/asttypes.cmi typing/printtyp.cmi
+    typing/oprint.cmx utils/misc.cmx parsing/longident.cmx \
+    parsing/location.cmx typing/ident.cmx typing/env.cmx typing/ctype.cmx \
+    utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \
+    typing/printtyp.cmi
 typing/printtyped.cmo : typing/typedtree.cmi typing/path.cmi \
     parsing/longident.cmi parsing/location.cmi typing/ident.cmi \
     parsing/asttypes.cmi typing/printtyped.cmi

File contents unchanged.

-4.00.0+dev20_2012-06-04+camlp4-lexer-plug+annot+p4_expand_directory
+4.00.0+dev20_2012-06-04+camlp4-lexer-plug+annot+p4-expand-directory+typeloc
 
 # The version string is the first line of this file.
 # It must be in the format described in stdlib/sys.mli

Binary file modified.

Binary file modified.

Binary file modified.

File contents unchanged.

ocamldoc/odoc_print.ml

     | Types.Cty_signature cs ->
         (* on vire les vals et methods pour ne pas qu'elles soient imprimées
            quand on affichera le type *)
-        let tnil = { Types.desc = Types.Tnil ; Types.level = 0; Types.id = 0 } in
+        let tnil = { Types.desc = Types.Tnil ; Types.level = 0; Types.id = 0; tyloc = None } in
         Types.Cty_signature { Types.cty_self = { cs.Types.cty_self with
                                                   Types.desc = Types.Tobject (tnil, ref None) };
                                Types.cty_vars = Types.Vars.empty ;

File contents unchanged.

File contents unchanged.

 let new_id = ref (-1)
 
 let newty2 level desc  =
-  incr new_id; { desc; level; id = !new_id }
+  incr new_id; { desc; level; id = !new_id; tyloc = None }
 let newgenty desc      = newty2 generic_level desc
 let newgenvar ?name () = newgenty (Tvar name)
 (*
   | Ccommu of commutable ref * commutable
   | Cuniv of type_expr option ref * type_expr option
   | Ctypeset of TypeSet.t ref * TypeSet.t
+  | Ctyloc of type_expr * Location.t option
 
 let undo_change = function
     Ctype  (ty, desc) -> ty.desc <- desc
   | Ccommu (r, v) -> r := v
   | Cuniv  (r, v) -> r := v
   | Ctypeset (r, v) -> r := v
+  | Ctyloc (ty, loc) -> ty.tyloc <- loc
 
 type changes =
     Change of change * changes ref
 
 let log_type ty =
   if ty.id <= !last_snapshot then log_change (Ctype (ty, ty.desc))
+
+let log_tyloc ty =
+  if ty.id <= !last_snapshot then log_change (Ctyloc (ty, ty.tyloc))
+
+let printtyp_type_expr = ref (fun _ -> assert false : Format.formatter -> type_expr -> unit)
+
+let unify_tyloc t1 t2 =
+  let loc =  match t1.tyloc, t2.tyloc with
+    | None, None -> None
+    | None, (Some _ as v) -> v
+    | (Some _) as v, None -> v
+    | (Some a) as v, Some b -> v
+  in
+  if t1.tyloc <> loc then begin log_tyloc t1; t1.tyloc <- loc end;
+  if t2.tyloc <> loc then begin log_tyloc t2; t2.tyloc <- loc end
+
 let link_type ty ty' =
+  unify_tyloc ty ty';
   log_type ty;
   let desc = ty.desc in
   ty.desc <- Tlink ty';
            not already backtracked to a previous snapshot.
            Calls [cleanup_abbrev] internally *)
 
+val printtyp_type_expr : (Format.formatter -> type_expr -> unit) ref
+
 (* Functions to use when modifying a type (only Ctype?) *)
+val unify_tyloc : Types.type_expr -> Types.type_expr -> unit
 val link_type: type_expr -> type_expr -> unit
         (* Set the desc field of [t1] to [Tlink t2], logging the old
            value if there is an active snapshot *)
   | (Tfield _, Tfield _) -> (* special case for GADTs *)
       unify_fields env t1' t2'
   | _ ->
+    let loc1 = t1'.tyloc and loc2 = t2'.tyloc in
     begin match !umode with
     | Expression ->
         occur !env t1' t2';
         | _ ->
             () (* t2 has already been expanded by update_level *)
     with Unify trace ->
+      t1'.tyloc <- loc1;
+      t2'.tyloc <- loc2;
       t1'.desc <- d1;
       raise (Unify trace)
   end

typing/datarepr.ml

     cstr_normal = -1;
     cstr_generalized = false }
 
-let none = {desc = Ttuple []; level = -1; id = -1}
+let none = {desc = Ttuple []; level = -1; id = -1; tyloc = None}
                                         (* Clearly ill-formed type *)
 let dummy_label =
   { lbl_name = ""; lbl_res = none; lbl_arg = none; lbl_mut = Immutable;

typing/printtyp.ml

 
 and type_scheme ppf ty = reset_and_mark_loops ty; typexp true 0 ppf ty
 
+let _ = Btype.printtyp_type_expr := type_expr
+
 (* Maxence *)
 let type_scheme_max ?(b_reset_names=true) ppf ty =
   if b_reset_names then reset_names () ;
 (* Print an unification error *)
 
 let type_expansion t ppf t' =
-  if t == t' then type_expr ppf t else
-  let t' = if proxy t == proxy t' then unalias t' else t' in
-  fprintf ppf "@[<2>%a@ =@ %a@]" type_expr t type_expr t'
+  (if t == t' then type_expr ppf t else
+   let t' = if proxy t == proxy t' then unalias t' else t' in
+   fprintf ppf "@[<2>%a@ =@ %a@]" type_expr t type_expr t');
+  match t.tyloc with
+  | Some loc -> fprintf ppf " introduced at %a" Location.print loc
+  | _ -> ()
 
 let rec trace fst txt ppf = function
   | (t1, t1') :: (t2, t2') :: rem ->
 
 let newpersty desc =
   decr new_id;
-  { desc = desc; level = generic_level; id = !new_id }
+  { desc = desc; level = generic_level; id = !new_id; tyloc = None }
 
 (* Similar to [Ctype.nondep_type_rec]. *)
 let rec typexp s ty =

typing/typecore.ml

   node
 ;;
 
+let add_loc loc ty = 
+  (* Adding a location to a type must dupe the type!
+     Otherwise one [add_loc loc <int>] to <int> changes all the <int>s with [loc]!
+  *)
+  { ty with tyloc = Some loc }
+
 
 let snd3 (_,x,_) = x
 let thd4 (_,_, x,_) = x
         pat_type = q.pat_type;
         pat_env = !env }
   | Ppat_constant cst ->
-      unify_pat_types loc !env (type_constant cst) expected_ty;
+      unify_pat_types loc !env (add_loc loc (type_constant cst)) expected_ty;
       rp {
         pat_desc = Tpat_constant cst;
         pat_loc = loc; pat_extra=[];
         pat_env = !env }
   | Ppat_tuple spl ->
       let spl_ann = List.map (fun p -> (p,newvar ())) spl in
-      let ty = newty (Ttuple(List.map snd spl_ann)) in
+      let ty = add_loc loc (newty (Ttuple(List.map snd spl_ann))) in
       unify_pat_types loc !env ty expected_ty;
       let pl = List.map (fun (p,t) -> type_pat p t) spl_ann in
       rp {
       let (ty_args, ty_res) =
         instance_constructor ~in_pattern:(env, get_newtype_level ()) constr
       in
+      let ty_res = add_loc loc ty_res in
       if constr.cstr_generalized && mode = Normal then
         unify_pat_types_gadt loc env ty_res expected_ty
       else
         begin_def ();
         let (vars, ty_arg, ty_res) = instance_label false label in
         if vars = [] then end_def ();
+        let ty_res = add_loc loc ty_res in
         begin try
           unify_pat_types loc !env ty_res expected_ty
         with Unify trace ->
   | Ppat_array spl ->
       let ty_elt = newvar() in
       unify_pat_types
-        loc !env (instance_def (Predef.type_array ty_elt)) expected_ty;
+        loc !env (add_loc loc (instance_def (Predef.type_array ty_elt))) expected_ty;
       let spl_ann = List.map (fun p -> (p,newvar())) spl in
       let pl = List.map (fun (p,t) -> type_pat p ty_elt) spl_ann in
       rp {
         pat_env = !env }
   | Ppat_lazy sp1 ->
       let nv = newvar () in
-      unify_pat_types loc !env (instance_def (Predef.type_lazy_t nv))
+      unify_pat_types loc !env (add_loc loc (instance_def (Predef.type_lazy_t nv)))
         expected_ty;
       let p1 = type_pat sp1 nv in
       rp {
           instance !env ty, instance !env ty
         end else ty, ty
       in
+      (* let ty = add_loc loc ty in *) (* CR jfuruse: fails at Camlp4.ml *)
       unify_pat_types loc !env ty expected_ty;
       let p = type_pat sp expected_ty' in
       (*Format.printf "%a@.%a@."
       else p
   | Ppat_type lid ->
       let (path, p,ty) = build_or_pat !env loc lid.txt in
+      let ty = add_loc loc ty in
       unify_pat_types loc !env ty expected_ty;
       { p with pat_extra = (Tpat_type (path, lid), loc) :: p.pat_extra }
 
            ty_ureader; ty_uresult; ty_result; ],
          ref Mnil)) in
 
-  type_in_format fmt
+  add_loc loc (type_in_format fmt)
 
 (* Approximate the type of an expression, for better recursion *)
 
 let rec approx_type env sty =
+  let loc = sty.ptyp_loc in
+  let add_loc = add_loc loc in
   match sty.ptyp_desc with
     Ptyp_arrow (p, _, sty) ->
       let ty1 = if is_optional p then type_option (newvar ()) else newvar () in
-      newty (Tarrow (p, ty1, approx_type env sty, Cok))
+      add_loc (newty (Tarrow (p, ty1, approx_type env sty, Cok)))
   | Ptyp_tuple args ->
-      newty (Ttuple (List.map (approx_type env) args))
+      add_loc (newty (Ttuple (List.map (approx_type env) args)))
   | Ptyp_constr (lid, ctl) ->
       begin try
         let (path, decl) = Env.lookup_type lid.txt env in
         if List.length ctl <> decl.type_arity then raise Not_found;
         let tyl = List.map (approx_type env) ctl in
-        newconstr path tyl
+        add_loc (newconstr path tyl)
       with Not_found -> newvar ()
       end
   | Ptyp_poly (_, sty) ->
   | _ -> newvar ()
 
 let rec type_approx env sexp =
+  let add_loc = add_loc sexp.pexp_loc in 
   match sexp.pexp_desc with
     Pexp_let (_, _, e) -> type_approx env e
   | Pexp_function (p,_,(_,e)::_) when is_optional p ->
-       newty (Tarrow(p, type_option (newvar ()), type_approx env e, Cok))
+      add_loc (newty (Tarrow(p, type_option (newvar ()), type_approx env e, Cok)))
   | Pexp_function (p,_,(_,e)::_) ->
-       newty (Tarrow(p, newvar (), type_approx env e, Cok))
+      add_loc (newty (Tarrow(p, newvar (), type_approx env e, Cok)))
   | Pexp_match (_, (_,e)::_) -> type_approx env e
   | Pexp_try (e, _) -> type_approx env e
-  | Pexp_tuple l -> newty (Ttuple(List.map (type_approx env) l))
+  | Pexp_tuple l -> add_loc (newty (Ttuple(List.map (type_approx env) l)))
   | Pexp_ifthenelse (_,e,_) -> type_approx env e
   | Pexp_sequence (_,e) -> type_approx env e
   | Pexp_constraint (e, sty1, sty2) ->
         exp_desc = Texp_constant cst;
         exp_loc = loc; exp_extra = [];
         exp_type =
-        (* Terrible hack for format strings *)
-           begin match (repr (expand_head env ty_expected)).desc with
-             Tconstr(path, _, _) when Path.same path Predef.path_format6 ->
-               type_format loc s
-           | _ -> instance_def Predef.type_string
-           end;
+          add_loc loc begin
+            (* Terrible hack for format strings *)
+            match (repr (expand_head env ty_expected)).desc with
+              Tconstr(path, _, _) when Path.same path Predef.path_format6 ->
+                type_format loc s
+            | _ -> instance_def Predef.type_string
+          end;
         exp_env = env }
   | Pexp_constant cst ->
       rue {
         exp_desc = Texp_constant cst;
         exp_loc = loc; exp_extra = [];
-        exp_type = type_constant cst;
+        exp_type = add_loc loc (type_constant cst);
         exp_env = env }
   | Pexp_let(Nonrecursive, [spat, sval], sbody) when contains_gadt env spat ->
       type_expect ?in_function env
       re {
         exp_desc = Texp_function(l,cases, partial);
         exp_loc = loc; exp_extra = [];
-        exp_type = instance env (newgenty (Tarrow(l, ty_arg, ty_res, Cok)));
+        exp_type = add_loc loc (instance env (newgenty (Tarrow(l, ty_arg, ty_res, Cok))));
         exp_env = env }
   | Pexp_apply(sfunct, sargs) ->
       begin_def (); (* one more level for non-returning functions *)
   | Pexp_try(sbody, caselist) ->
       let body = type_expect env sbody ty_expected in
       let cases, _ =
-        type_cases env Predef.type_exn ty_expected false loc caselist in
+        type_cases env (add_loc loc Predef.type_exn) ty_expected false loc caselist in
       re {
         exp_desc = Texp_try(body, cases);
         exp_loc = loc; exp_extra = [];
         exp_env = env }
   | Pexp_tuple sexpl ->
       let subtypes = List.map (fun _ -> newgenvar ()) sexpl in
-      let to_unify = newgenty (Ttuple subtypes) in
+      let to_unify = add_loc loc (newgenty (Ttuple subtypes)) in
       unify_exp_types loc env to_unify ty_expected;
       let expl =
         List.map2 (fun body ty -> type_expect env body ty) sexpl subtypes
         exp_env = env }
   | Pexp_array(sargl) ->
       let ty = newgenvar() in
-      let to_unify = Predef.type_array ty in
+      let to_unify = add_loc loc (Predef.type_array ty) in
       unify_exp_types loc env to_unify ty_expected;
       let argl = List.map (fun sarg -> type_expect env sarg ty) sargl in
       re {
         exp_type = instance env ty_expected;
         exp_env = env }
   | Pexp_ifthenelse(scond, sifso, sifnot) ->
-      let cond = type_expect env scond Predef.type_bool in
+      let cond = type_expect env scond (add_loc scond.pexp_loc Predef.type_bool) in
       begin match sifnot with
         None ->
-          let ifso = type_expect env sifso Predef.type_unit in
+          let ifso = type_expect env sifso (add_loc sifso.pexp_loc Predef.type_unit) in
           rue {
             exp_desc = Texp_ifthenelse(cond, ifso, None);
             exp_loc = loc; exp_extra = [];
         exp_type = exp2.exp_type;
         exp_env = env }
   | Pexp_while(scond, sbody) ->
-      let cond = type_expect env scond Predef.type_bool in
+      let cond = type_expect env scond (add_loc scond.pexp_loc Predef.type_bool) in
       let body = type_statement env sbody in
       rue {
         exp_desc = Texp_while(cond, body);
         exp_loc = loc; exp_extra = [];
-        exp_type = instance_def Predef.type_unit;
+        exp_type = add_loc loc (instance_def Predef.type_unit);
         exp_env = env }
   | Pexp_for(param, slow, shigh, dir, sbody) ->
-      let low = type_expect env slow Predef.type_int in
-      let high = type_expect env shigh Predef.type_int in
+      let low = type_expect env slow (add_loc param.loc Predef.type_int) in
+      let high = type_expect env shigh (add_loc param.loc Predef.type_int) in
       let (id, new_env) =
-        Env.enter_value param.txt {val_type = instance_def Predef.type_int;
+        Env.enter_value param.txt {val_type = add_loc param.loc (instance_def Predef.type_int);
           val_kind = Val_reg; Types.val_loc = loc; } env
           ~check:(fun s -> Warnings.Unused_for_index s)
       in
       rue {
         exp_desc = Texp_for(id, param, low, high, dir, body);
         exp_loc = loc; exp_extra = [];
-        exp_type = instance_def Predef.type_unit;
+        exp_type = add_loc loc (instance_def Predef.type_unit);
         exp_env = env }
   | Pexp_constraint(sarg, sty, sty') ->
 
       rue {
         exp_desc = arg.exp_desc;
         exp_loc = arg.exp_loc;
-        exp_type = ty';
+        exp_type = (* add_loc arg.exp_loc *) ty';
         exp_env = env;
         exp_extra = (Texp_constraint (cty, cty'), loc) :: arg.exp_extra;
       }
   | Pexp_when(scond, sbody) ->
-      let cond = type_expect env scond Predef.type_bool in
+      let cond = type_expect env scond (add_loc scond.pexp_loc Predef.type_bool) in
       let body = type_expect env sbody ty_expected in
       re {
         exp_desc = Texp_when(cond, body);
         exp_type = ty;
         exp_env = env }
   | Pexp_assert (e) ->
-      let cond = type_expect env e Predef.type_bool in
+      let cond = type_expect env e (add_loc e.pexp_loc Predef.type_bool) in
       rue {
         exp_desc = Texp_assert (cond);
         exp_loc = loc; exp_extra = [];
-        exp_type = instance_def Predef.type_unit;
+        exp_type = add_loc loc (instance_def Predef.type_unit);
         exp_env = env;
       }
   | Pexp_assertfalse ->
       re {
         exp_desc = Texp_assertfalse;
         exp_loc = loc; exp_extra = [];
-        exp_type = instance env ty_expected;
+        exp_type = add_loc loc (instance env ty_expected);
         exp_env = env;
       }
   | Pexp_lazy e ->
       let ty = newgenvar () in
-      let to_unify = Predef.type_lazy_t ty in
+      let to_unify = add_loc loc (Predef.type_lazy_t ty) in
       unify_exp_types loc env to_unify ty_expected;
       let arg = type_expect env e ty in
       re {
   let exp = type_exp env sexp in
   end_def();
   if !Clflags.strict_sequence then
-    let expected_ty = instance_def Predef.type_unit in
+    let expected_ty = add_loc loc (instance_def Predef.type_unit) in
     unify_exp env exp expected_ty;
     exp else
   let ty = expand_head env exp.exp_type and tv = newvar() in
 type type_expr =
   { mutable desc: type_desc;
     mutable level: int;
-    mutable id: int }
+    mutable id: int;
+    mutable tyloc: Location.t option;
+  }
 
 and type_desc =
     Tvar of string option
 type type_expr =
   { mutable desc: type_desc;
     mutable level: int;
-    mutable id: int }
+    mutable id: int;
+    mutable tyloc: Location.t option;
+  }
 
 and type_desc =
     Tvar of string option
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.