Commits

camlspotter committed 5974a1f

typeloc seems to be unsafe

Comments (0)

Files changed (63)

 typing/cmt_format.cmi : typing/types.cmi typing/typedtree.cmi \
     parsing/location.cmi typing/env.cmi typing/cmi_format.cmi
 typing/ctype.cmi : typing/types.cmi typing/path.cmi parsing/longident.cmi \
-    parsing/location.cmi typing/ident.cmi typing/env.cmi parsing/asttypes.cmi
+    typing/ident.cmi typing/env.cmi parsing/asttypes.cmi
 typing/datarepr.cmi : typing/types.cmi typing/path.cmi typing/ident.cmi \
     parsing/asttypes.cmi
 typing/env.cmi : utils/warnings.cmi typing/types.cmi typing/subst.cmi \
     parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \
     typing/env.cmi parsing/asttypes.cmi
 typing/btype.cmo : typing/types.cmi typing/path.cmi utils/misc.cmi \
-    parsing/location.cmi typing/btype.cmi
+    typing/btype.cmi
 typing/btype.cmx : typing/types.cmx typing/path.cmx utils/misc.cmx \
-    parsing/location.cmx typing/btype.cmi
+    typing/btype.cmi
 typing/cmi_format.cmo : typing/types.cmi utils/misc.cmi parsing/location.cmi \
     utils/config.cmi typing/cmi_format.cmi
 typing/cmi_format.cmx : typing/types.cmx utils/misc.cmx parsing/location.cmx \
 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 \
-    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/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/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 \
-    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/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/printtyped.cmo : typing/typedtree.cmi typing/path.cmi \
     parsing/longident.cmi parsing/location.cmi typing/ident.cmi \
     parsing/asttypes.cmi typing/printtyped.cmi
-.*\.(o|cmo|cmi|cmx|cma|cmx|cmxa|cmxs|a|so|output|3o|rej|orig|spot|spit|annot|bak|cmt|cmti)$
+.*\.(o|cm.*|a|so|output|3o|rej|orig|sp.t|annot|bak)$
 .*~$
 
 ^ocamlspot/ocamlspot$
 73079ded8dc97ba343854cf488f2264bc43e2990 ocaml-4.00.0-rc1-12755
 731b4b8013012de8e34bb9f0de16a0f510d05001 ocaml-4.00.0-12779
 a1487e7d929b5aa7086f476d6d1d31edbd55a9ce ocaml-4.00.1-12983
+72a6ec86f9a499184150a50951315eb6d14dcc38 annot-4.00.1-12983
 	cd stdlib; $(MAKE) install
 	cp lex/ocamllex $(BINDIR)/ocamllex$(EXE)
 	cp yacc/ocamlyacc$(EXE) $(BINDIR)/ocamlyacc$(EXE)
-	cp utils/*.cm* parsing/*.cm* typing/*.cm* bytecomp/*.cm* driver/*.cm* toplevel/*.cm* $(COMPLIBDIR)
+	cp utils/*.cmi parsing/*.cmi typing/*.cmi bytecomp/*.cmi driver/*.cmi toplevel/*.cmi $(COMPLIBDIR)
 	cp compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma compilerlibs/ocamltoplevel.cma $(BYTESTART) $(TOPLEVELSTART) $(COMPLIBDIR)
 	cp expunge $(LIBDIR)/expunge$(EXE)
 	cp toplevel/topdirs.cmi $(LIBDIR)
+=====================
+OCaml annot patch
+=====================
+
+This small modification to OCaml compiler introduces OCAML_ANNOT environment variable which enables annotation file creation by default without the compiler switch -annot and -bin-annot.
+
+For example::
+
+   OCAML_ANNOT=1 ocamlc hello.ml
+
+creates hello.annot and hello.cmt even without -annot or -bin-annot.
+
+

README.typeloc

-typeloc branch: An attempt to improve unification error report.
-=================================================================
-
-This typeloc branch tries to print additional information at type unification
-errors, to indicate which parts of the source code introduce the type 
-constructors caused the errors.
-
-This is inspired from the same idea implemented for Haskell type checker 
-by Lennart Augustsson.
-
-Current status 
----------------
-`Proof of concept' level implementation.
-4.00.1+camlp4-lexer-plug+annot+p4-expand-directory+typeloc
+4.00.1+camlp4-lexer-plug+annot+p4-expand-directory
 
 # The version string is the first line of this file.
 # It must be in the format described in stdlib/sys.mli
 
 # $Id: VERSION 12983 2012-10-03 15:11:00Z doligez $
+

camlp4/Camlp4/Sig.ml

     (** Token stream from string. *)
     value lex_string : gram -> Loc.t -> string -> not_filtered (Stream.t (Token.t * Loc.t));
 
-    value set_from_lexbuf : 
-      (?quotations: bool -> Lexing.lexbuf -> Stream.t (Token.t * Loc.t)) 
-    -> unit;
-      
     (** Filter a token stream using the {!Token.Filter} module *)
     value filter : gram -> not_filtered (Stream.t (Token.t * Loc.t)) -> token_stream;
 
     (** Token stream from string. *)
     value lex_string : Loc.t -> string -> not_filtered (Stream.t (Token.t * Loc.t));
 
-    value set_from_lexbuf : 
-      (?quotations: bool -> Lexing.lexbuf -> Stream.t (Token.t * Loc.t)) 
-    -> unit;
-
     (** Filter a token stream using the {!Token.Filter} module *)
     value filter : not_filtered (Stream.t (Token.t * Loc.t)) -> token_stream;
 
       The lexer do not use global (mutable) variables: instantiations
       of [Lexer.mk ()] do not perturb each other. *)
   value mk : unit -> (Loc.t -> Stream.t char -> Stream.t (Token.t * Loc.t));
-
-  value from_lexbuf : 
-    ?quotations: bool -> Lexing.lexbuf -> Stream.t (Token.t * Loc.t);
-
-  value set_from_lexbuf : 
-    (?quotations: bool -> Lexing.lexbuf -> Stream.t (Token.t * Loc.t)) -> unit;
 end;
 
 

camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml

           [ [(loc, ml, <:expr@sloc< $uid:s$ >>) :: l] ->
               let ca = constructors_arity () in
               (mkexp loc (Pexp_construct (mkli sloc (conv_con s) ml) None ca), l)
-          | [(loc, ml, <:expr@_sloc< $lid:s$ >>) :: l] ->
-              (mkexp loc (Pexp_ident (mkli loc s ml)), l)
+          | [(loc, ml, <:expr@sloc< $lid:s$ >>) :: l] ->
+              (mkexp loc (Pexp_ident (mkli sloc s ml)), l)
           | [(_, [], e) :: l] -> (expr e, l)
           | _ -> error loc "bad ast in expression" ]
         in

camlp4/Camlp4/Struct/Grammar/Dynamic.ml

  *)
 module Make (Lexer : Sig.Lexer)
 : Sig.Grammar.Dynamic with module Loc = Lexer.Loc
-                       and module Token = Lexer.Token
-                       and type   token_info = (Structure.MakeTokenInfo Lexer.Loc).t
+                         and module Token = Lexer.Token
 = struct
   module Structure = Structure.Make Lexer;
   module Delete    = Delete.Make    Structure;
 
   value lex_string g loc str = lex g loc (Stream.of_string str);
 
-  value set_from_lexbuf = Lexer.set_from_lexbuf;
-
   value filter g ts = Tools.keep_prev_loc (Token.Filter.filter g.gfilter ts);
 
   value parse_tokens_after_filter entry ts = Entry.parse_tokens_after_filter entry ts;

camlp4/Camlp4/Struct/Grammar/Static.ml

 
 module Make (Lexer : Sig.Lexer)
 : Sig.Grammar.Static with module Loc = Lexer.Loc
-                      and module Token = Lexer.Token
-                      and type   token_info = (Structure.MakeTokenInfo Lexer.Loc).t
+                        and module Token = Lexer.Token
 = struct
   module Structure = Structure.Make Lexer;
   module Delete = Delete.Make Structure;
 
   value lex_string loc str = lex loc (Stream.of_string str);
 
-  value set_from_lexbuf = Lexer.set_from_lexbuf;
-
   value filter ts = Tools.keep_prev_loc (Token.Filter.filter gram.gfilter ts);
 
   value parse_tokens_after_filter entry ts = Entry.E.parse_tokens_after_filter entry ts;

camlp4/Camlp4/Struct/Grammar/Structure.ml

 
 open Sig.Grammar;
 
-type token_abs_info 'loc =
-  { prev_loc : 'loc
-  ; cur_loc : 'loc
-  ; prev_loc_only : bool
-  };
-
-module MakeTokenInfo (Loc : Sig.Type) = struct
-  type t = token_abs_info Loc.t;
-end;
-
 module type S = sig
   module Loc          : Sig.Loc;
   module Token        : Sig.Token with module Loc = Loc;
       warning_verbose : ref bool;
       error_verbose   : ref bool };
 
-  type token_info = (MakeTokenInfo Loc).t;
+  type token_info = { prev_loc : Loc.t
+                    ; cur_loc : Loc.t
+                    ; prev_loc_only : bool
+                    };
 
   type token_stream = Stream.t (Token.t * token_info);
 
       warning_verbose : ref bool;
       error_verbose   : ref bool };
 
-  type token_info = (MakeTokenInfo Loc).t;
+  type token_info = { prev_loc : Loc.t
+                    ; cur_loc : Loc.t
+                    ; prev_loc_only : bool
+                    };
 
   type token_stream = Stream.t (Token.t * token_info);
 

camlp4/Camlp4/Struct/Grammar/Tools.ml

 (* PR#5090: don't do lookahead on get_prev_loc. *)
 value get_prev_loc_only = ref False;
 
-open Structure;
-
-module Make (GramStruct : Structure.S) = struct
-  open GramStruct;
+module Make (Structure : Structure.S) = struct
+  open Structure;
 
   value empty_entry ename _ =
     raise (Stream.Error ("entry [" ^ ename ^ "] is empty"));

camlp4/Camlp4/Struct/Lexer.mll

     in
     self 0 s
 
-  let from_context quotations lb =
-    let c = { (default_context lb) with
-              loc        = Loc.of_lexbuf lb;
-              antiquots  = !Camlp4_config.antiquotations;
-              quotations = quotations      }
-    in
+  let from_context c =
     let next _ =
       let tok = with_curr_loc token c in
       let loc = Loc.of_lexbuf c.lexbuf in
     in Stream.from next
 
   let from_lexbuf ?(quotations = true) lb =
-    from_context quotations lb
-
-  let from_lexbuf_ref = ref from_lexbuf
-
-  let set_from_lexbuf from_lexbuf = from_lexbuf_ref := from_lexbuf
-
-  let from_lexbuf ?(quotations = true) lb =
-    let zstream = lazy (!from_lexbuf_ref ~quotations lb) in
-    Stream.from (fun _ ->
-      try
-	Some (Stream.next (Lazy.force zstream))
-      with
-      | Stream.Failure -> None)
+    let c = { (default_context lb) with
+              loc        = Loc.of_lexbuf lb;
+              antiquots  = !Camlp4_config.antiquotations;
+              quotations = quotations      }
+    in from_context c
 
   let setup_loc lb loc =
     let start_pos = Loc.start_pos loc in

camlp4/Camlp4Top/Top.ml

 open Syntax;
 open Camlp4.Sig;
 module Ast2pt = Camlp4.Struct.Camlp4Ast2OCamlAst.Make Ast;
-(* module Lexer = Camlp4.Struct.Lexer.Make Token; *)
-module Lexer = PreCast.Lexer;
+module Lexer = Camlp4.Struct.Lexer.Make Token;
 
 external not_filtered : 'a -> Gram.not_filtered 'a = "%identity";
 

ocamldoc/odoc_print.ml

     | Types.Cty_signature cs ->
         (* on vire les vals et methods pour ne pas qu'elles soient imprimees
            quand on affichera le type *)
-        let tnil = { Types.desc = Types.Tnil ; Types.level = 0; Types.id = 0; tyloc = None } in
+        let tnil = { Types.desc = Types.Tnil ; Types.level = 0; Types.id = 0 } 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 ;

testsuite/typeloc/array.ml

-let _ = [ [||]; [] ] (* ok *)
-

testsuite/typeloc/array_pat.ml

-let _ = function
-  | [||] -> 1  (* ok *)
-  | [] -> 2
-
-

testsuite/typeloc/const_constant.ml

-let _ = [ [];  (* constructor use: ok *)
-          1    (* constant use: ok *)
-        ]

testsuite/typeloc/const_constant_pat.ml

-let _ = function
-  | [] -> 1  (* construct in pattern: ok *)
-  | 1 -> 2   (* const in pattern: ok *) 

testsuite/typeloc/constraint.ml

-let _ = (1 : float) (* ok *)
- 

testsuite/typeloc/constraint_pat.ml

-let f = function (1 : float) -> 2 (* ok *)
- 

testsuite/typeloc/exn.ml

-let _ = [Exit; 1]

testsuite/typeloc/exn_pat.ml

-let _ = function
-  | Exit -> 1
-  | 2 -> 2

testsuite/typeloc/for.ml

-let _ = for i = true to 10 do () done (* ok *)
-
-

testsuite/typeloc/for2.ml

-let _ = for i = 0 to true do () done (* ok *)
-
-

testsuite/typeloc/fun.ml

-let _ = [(fun x -> x); 1]

testsuite/typeloc/fun_app.ml

-let f = 1
-let _ = f 2 
-(* NG? : 
-File "fun_app.ml", line 2, characters 8-9:
-Error: This expression is not a function; it cannot be applied
-*)
-

testsuite/typeloc/ifthen.ml

-let _ = if true then 1 (* NG. Detected but the location is wrong *)
- 

testsuite/typeloc/ifthenelse.ml

-let f = if 1 then 1 else 2 (* ok *)
-

testsuite/typeloc/lazy.ml

-let _ = [lazy 1; 2] (* ok *)
-

testsuite/typeloc/lazy_pat.ml

-let _ = function
-  | lazy 1 -> 1 (* ok *)
-  | 2 -> 2

testsuite/typeloc/obj_meth_call.ml

-let f x = 
-  x#m;  (* ok *)
-  [x; 1]
-

testsuite/typeloc/obj_new.ml

-class t = object end
-let _ = [ new t;  (* ok *)
-          None ]

testsuite/typeloc/obj_new2.ml

-class t = object end
-type 'a u = X of 'a * 'a
-let _ = X (new t, (* ok *)
-           1)  

testsuite/typeloc/pvar.ml

-let _ = `A + 1  (* this is tricky! ok ? *)
-

testsuite/typeloc/pvar2.ml

-let x = `A
-
-let y = [x; `B] (* ok *)
-
-let z = [y; 1]
-

testsuite/typeloc/pvar_constraint.ml

-let x = `A
-
-let y = [x; `B] (* ok *)
-
-let f : [`B] -> [`B] = fun x -> x (* ok *)
-
-let _ = f y
-

testsuite/typeloc/pvar_pat.ml

-let _ = function
-  | `A -> ()  (* ok? *)
-  | 1 -> ()

testsuite/typeloc/rec_field.ml

-type t = { x : int }
-
-let f x = (x.x,  (* ok *)
-           x + 1)
-

testsuite/typeloc/rec_field_pat.ml

-type t = { x : int }
-
-let f = function
-  | { x = x } -> x  (* ok *)
-  | 1 -> 1
-

testsuite/typeloc/record.ml

-type t = { x : int; y : int }
-
-let _ = [ { x = 1; y = 2 };  (* ok *)
-          [] ]

testsuite/typeloc/record_pat.ml

-type t = { x : int; y : int }
-
-let _ = function
-  | { x = 1; y = 2 } -> 1  (* ok *)
-  | [] -> 2

testsuite/typeloc/seq.ml

-let _ = 1; () (* ok , with -strict-sequence *)
-

testsuite/typeloc/try.ml

-let _ = try 1 with 1 -> 1 (* ok, but loc is not sure ? *)
-

testsuite/typeloc/tuple.ml

-let _ = [ (1,2);  (* tuple ok *)
-          [] ]

testsuite/typeloc/tuple_pat.ml

-let x = function
-  | (1,2) -> 3 (* ok *)
-  | [] -> 4
- 

testsuite/typeloc/var.ml

-type t = Foo 
-
-let _ = [Foo;  (* ok *)
-         1]
- 

testsuite/typeloc/var_pat.ml

-type t = Foo
-
-let _ = function 
-  | Foo -> 1    (* ok *)
-  | [] -> 2

testsuite/typeloc/when.ml

-let _ = function _ when 1 -> 1 (* ok? but the location is cryptic *)
-

testsuite/typeloc/while.ml

-let _ = while 1 do () done (* ok? the bool introduction location is crypting *)
-
 let new_id = ref (-1)
 
 let newty2 level desc  =
-  incr new_id; { desc; level; id = !new_id; tyloc = None }
+  incr new_id; { desc; level; id = !new_id }
 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 *)
 open Types
 open Btype
 
-let typeloc_debug = try ignore (Sys.getenv "OCAML_TYPELOC_DEBUG"); true with _ -> false
-
 (*
    Type manipulation after type inference
    ======================================
 (* Re-export repr *)
 let repr = repr
 
-(* Type constructor introduction location *)
-let copy_with_loc loc ty = 
-  (* Adding a location to a type must dupe the type!
-     Otherwise one [copy_with_loc loc <int>] to <int> changes all the <int>s with [loc]!
-  *)
-  { ty with tyloc = Some loc }
-
-let set_loc loc ty = (repr ty).tyloc <- Some loc; ty
-  (* Use with great care. You should not use set_loc if copy_with_loc can solve your problem. *)
-
 (**** Type maps ****)
 
 module TypePairs =
 
 (* partial: we may not wish to copy the non generic types
    before we call type_pat *)
-(* CR jfuruse: keep_names is never used *)
 let rec copy ?env ?partial ?keep_names ty =
   let copy = copy ?env ?partial ?keep_names in
   let ty = repr ty in
           Tobject (copy ty1, ref None)
       | _ -> copy_type_desc ?keep_names copy desc
       end;
-    t.tyloc <- ty.tyloc;
     t
 
 (**** Variants of instantiations ****)
       with Not_found -> false
 
 let rec unify (env:Env.t ref) t1 t2 =
-  if typeloc_debug then
-    Format.eprintf "unify @[<v>%a@ %a@]@."
-      !Btype.print_raw t1
-      !Btype.print_raw t2;
-
   (* First step: special cases (optimizations) *)
   if unify_eq !env t1 t2 then () else
   let t1 = repr t1 in
 and unify3 env t1 t1' t2 t2' =
   (* Third step: truly unification *)
   (* Assumes either [t1 == t1'] or [t2 != t2'] *)
-  if typeloc_debug then
-    Format.eprintf "unify3 @[<v>%a@ %a@]@."
-      !Btype.print_raw t1
-      !Btype.print_raw t2;
-
   let d1 = t1'.desc and d2 = t2'.desc in
   let create_recursion = (t2 != t2') && (deep_occur t1' t2) in
 
   | (Tfield _, Tfield _) -> (* special case for GADTs *)
       unify_fields env t1' t2'
   | _ ->
-    (* typeloc: t1' and t2 are linked even if the unification might fail! *)  
-    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
 val none: type_expr
         (* A dummy type expression *)
 
-val copy_with_loc : Location.t -> type_expr -> type_expr
-  (* Copy the type with setting tyloc *)
-val set_loc : Location.t -> type_expr -> type_expr
-  (* Modify the tyloc and return the same type. Use with care. *)
-
 val repr: type_expr -> type_expr
         (* Return the canonical representative of a type. *)
 

typing/datarepr.ml

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

typing/printtyp.ml

   let ty = safe_repr [] ty in
   if List.memq ty !visited then fprintf ppf "{id=%d}" ty.id else begin
     visited := ty :: !visited;
-    fprintf ppf "@[<1>{id=%d;level=%d;desc=@,%a;@,tyloc=%a}@]" ty.id ty.level
+    fprintf ppf "@[<1>{id=%d;level=%d;desc=@,%a}@]" ty.id ty.level
       raw_type_desc ty.desc
-      (fun ppf loc -> match loc with None -> fprintf ppf "None" | Some l -> Location.print ppf l) ty.tyloc
   end
 and raw_type_list tl = raw_list raw_type tl
 and raw_type_desc ppf = function
 
 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');
-(*
-  match t.tyloc with
-  | Some loc -> fprintf ppf " introduced at %a" Location.print loc
-  | _ -> ()
-*)
-  ()
-
-let rec differing_types ppf = function
-  | [(t,_); (t',_)] ->
-      let typ ppf t = match t.tyloc with
-        | Some loc -> 
-            fprintf ppf "@[<v2>  %a : introduced at %a@]" 
-              type_expr t
-              Location.print_loc loc
-        | None -> 
-            fprintf ppf "@[<2>  %a : introduced at unknown place@]" 
-              type_expr t
-      in
-      fprintf ppf "@[<v>The differing types are:@ %a@ %a@]"
-        typ t
-        typ t'
-  | _::_::tr -> differing_types ppf tr
-  | _ -> assert false
+  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'
 
 let rec trace fst txt ppf = function
   | (t1, t1') :: (t2, t2') :: rem ->
   trace_same_names tr;
   let tr = List.map (fun (t, t') -> (t, hide_variant_name t')) tr in
   let mis = mismatch unif tr in
-  let tr0 = tr in
   match tr with
   | [] | _ :: [] -> assert false
   | t1 :: t2 :: tr ->
           @[%t@;<1 2>%a@ \
             %t@;<1 2>%a\
           @]%a%t\
-         @]\
-         @;%a"
+         @]"
         txt1 (type_expansion t1) t1'
         txt2 (type_expansion t2) t2'
         (trace false "is not compatible with type") tr
-        (explanation unif mis)
-        differing_types tr0; (* CR jfuruse: we must seek the last trace *)
+        (explanation unif mis);
       print_labels := true
     with exn ->
       print_labels := true;
 
 let newpersty desc =
   decr new_id;
-  { desc = desc; level = generic_level; id = !new_id; tyloc = None }
+  { desc = desc; level = generic_level; id = !new_id }
 
 (* Similar to [Ctype.nondep_type_rec]. *)
 let rec typexp s ty =
           Tlink (typexp s t2)
       | _ -> copy_type_desc (typexp s) desc
       end;
-    (match ty'.tyloc with None -> ty'.tyloc <- ty.tyloc | _ -> ());
     ty'
 
 (*

typing/typecore.ml

 open Btype
 open Ctype
 
-let typeloc_debug = try ignore (Sys.getenv "OCAML_TYPELOC_DEBUG"); true with _ -> false
-
 type error =
     Polymorphic_label of Longident.t
   | Constructor_arity_mismatch of Longident.t * int * int
   node
 ;;
 
+
 let snd3 (_,x,_) = x
 let thd4 (_,_, x,_) = x
 
   unify_vars p1_vs p2_vs
 
 let rec build_as_type env p =
-  let loc = p.pat_loc in
   match p.pat_desc with
     Tpat_alias(p1,_, _) -> build_as_type env p1
   | Tpat_tuple pl ->
       let tyl = List.map (build_as_type env) pl in
-      copy_with_loc loc (newty (Ttuple tyl))
+      newty (Ttuple tyl)
   | Tpat_construct(_, _, cstr, pl,_) ->
-      (* CR jfuruse: typeloc todo *)
       let keep = cstr.cstr_private = Private || cstr.cstr_existentials <> [] in
       if keep then p.pat_type else
       let tyl = List.map (build_as_type env) pl in
         (List.combine pl tyl) ty_args;
       ty_res
   | Tpat_variant(l, p', _) ->
-      (* CR jfuruse: typeloc todo *)
       let ty = may_map (build_as_type env) p' in
       newty (Tvariant{row_fields=[l, Rpresent ty]; row_more=newvar();
                       row_bound=(); row_name=None;
                       row_fixed=false; row_closed=false})
   | Tpat_record (lpl,_) ->
-      (* CR jfuruse: typeloc todo *)
       let lbl = thd4 (List.hd lpl) in
       if lbl.lbl_private = Private then p.pat_type else
       let ty = newvar () in
         pat_type = expected_ty;
         pat_env = !env }
   | Ppat_unpack name ->
-      (* CR jfuruse: typeloc todo *)
       let id = enter_variable loc name expected_ty ~is_module:true in
       rp {
         pat_desc = Tpat_var (id, name);
   | Ppat_constraint({ppat_desc=Ppat_var name; ppat_loc=lloc},
                     ({ptyp_desc=Ptyp_poly _} as sty)) ->
       (* explicitly polymorphic type *)
-      let cty, force = Typetexp.transl_simple_type_delayed !env sty in (* typeloc done *)
+      let cty, force = Typetexp.transl_simple_type_delayed !env sty in
       let ty = cty.ctyp_type in
       unify_pat_types lloc !env ty expected_ty;
       pattern_force := force :: !pattern_force;
         pat_type = q.pat_type;
         pat_env = !env }
   | Ppat_constant cst ->
-      unify_pat_types loc !env (copy_with_loc loc (type_constant cst)) expected_ty;
+      unify_pat_types loc !env (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 = copy_with_loc loc (newty (Ttuple(List.map snd spl_ann))) in
+      let ty = 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
-      (* CR jfuruse: typeloc todo for args. Probably unsafe (but why?) *)
-      let ty_res = copy_with_loc loc ty_res in (* CR jfuruse: world ok, but not checked yet *)
       if constr.cstr_generalized && mode = Normal then
         unify_pat_types_gadt loc env ty_res expected_ty
       else
         pat_type = expected_ty;
         pat_env = !env }
   | Ppat_variant(l, sarg) ->
-      (* CR jfuruse: typeloc todo for sarg *)
       let arg = may_map (fun p -> type_pat p (newvar())) sarg in
       let arg_type = match arg with None -> [] | Some arg -> [arg.pat_type]  in
       let row = { row_fields =
                   row_more = newvar ();
                   row_fixed = false;
                   row_name = None } in
-      unify_pat_types loc !env (copy_with_loc loc (newty (Tvariant row))) expected_ty;
+      unify_pat_types loc !env (newty (Tvariant row)) expected_ty;
       rp {
         pat_desc = Tpat_variant(l, arg, ref {row with row_more = newvar()});
         pat_loc = loc; pat_extra=[];
         pat_type =  expected_ty;
         pat_env = !env }
   | Ppat_record(lid_sp_list, closed) ->
-      (* CR jfuruse: typeloc todo check *)
       let type_label_pat (label_path, label_lid, label, sarg) =
         begin_def ();
         let (vars, ty_arg, ty_res) = instance_label false label in
-        let ty_res = copy_with_loc loc ty_res in
         if vars = [] then end_def ();
-        let ty_arg = copy_with_loc loc ty_arg 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 (copy_with_loc loc (instance_def (Predef.type_array ty_elt))) expected_ty;
+        loc !env (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 (copy_with_loc loc (instance_def (Predef.type_lazy_t nv)))
+      unify_pat_types loc !env (instance_def (Predef.type_lazy_t nv))
         expected_ty;
       let p1 = type_pat sp1 nv in
       rp {
       (* Separate when not already separated by !principal *)
       let separate = true in
       if separate then begin_def();
-      let cty, force = Typetexp.transl_simple_type_delayed !env sty in (* tyloc is done here *)
-
+      let cty, force = Typetexp.transl_simple_type_delayed !env sty in
       let ty = cty.ctyp_type in
       let ty, expected_ty' =
         if separate then begin
                 pat_extra = (Tpat_constraint cty,loc) :: p.pat_extra}
       else p
   | Ppat_type lid ->
-      (* CR jfuruse: typeloc todo check *)
       let (path, p,ty) = build_or_pat !env loc lid.txt in
-      let ty = copy_with_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
 
-  copy_with_loc loc (type_in_format fmt)
+  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
   match sty.ptyp_desc with
-    Ptyp_arrow (p, argty, sty) ->
-      let ty1 = if is_optional p then copy_with_loc argty.ptyp_loc (type_option (newvar ())) else newvar () in
-      copy_with_loc loc (newty (Tarrow (p, ty1, approx_type env sty, Cok)))
+    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))
   | Ptyp_tuple args ->
-      copy_with_loc loc (newty (Ttuple (List.map (approx_type env) args)))
+      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
-        copy_with_loc loc (newconstr path tyl)
+        newconstr path tyl
       with Not_found -> newvar ()
       end
   | Ptyp_poly (_, sty) ->
   | _ -> newvar ()
 
 let rec type_approx env sexp =
-  let copy_with_loc = copy_with_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 ->
-      copy_with_loc (newty (Tarrow(p, type_option (newvar ()), type_approx env e, Cok)))
+       newty (Tarrow(p, type_option (newvar ()), type_approx env e, Cok))
   | Pexp_function (p,_,(_,e)::_) ->
-      copy_with_loc (newty (Tarrow(p, newvar (), type_approx env e, Cok)))
+       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 -> copy_with_loc (newty (Ttuple(List.map (type_approx env) l)))
+  | Pexp_tuple l -> 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) ->
 let unify_exp env exp expected_ty =
   (* Format.eprintf "@[%a@ %a@]@." Printtyp.raw_type_expr exp.exp_type
     Printtyp.raw_type_expr expected_ty; *)
-  unify_exp_types exp.exp_loc env exp.exp_type expected_ty
+    unify_exp_types exp.exp_loc env exp.exp_type expected_ty
 
 let rec type_exp env sexp =
   (* We now delegate everything to type_expect *)
   let loc = sexp.pexp_loc in
   (* Record the expression type before unifying it with the expected type *)
   let rue exp =
-if typeloc_debug then Format.eprintf "@[<v>RUE: expected: %a@ RUE: exp: %a@]@." Printtyp.raw_type_expr ty_expected Printtyp.raw_type_expr exp.exp_type;
- 
     Cmt_format.add_saved_type (Cmt_format.Partial_expression exp);
     Stypes.record (Stypes.Ti_expr exp);
     unify_exp env exp (instance env ty_expected);
-
-if typeloc_debug then Format.eprintf "@[<v>RUE: unif exp: %a@]@." Printtyp.raw_type_expr exp.exp_type;
-
     exp
   in
   match sexp.pexp_desc with
   | Pexp_ident lid ->
-      (* CR jfuruse: typeloc todo *)
       begin
         if !Clflags.annotations then begin
           try let (path, annot) = Env.lookup_annot lid.txt env in
           with _ -> ()
         end;
         let (path, desc) = Typetexp.find_value env loc lid.txt in
-(*
-Format.eprintf "desc @[%a@]@." Printtyp.raw_type_expr desc.val_type;
-*)
         rue {
           exp_desc =
             begin match desc.val_kind with
         exp_desc = Texp_constant cst;
         exp_loc = loc; exp_extra = [];
         exp_type =
-          copy_with_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;
+        (* 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;
         exp_env = env }
   | Pexp_constant cst ->
       rue {
         exp_desc = Texp_constant cst;
         exp_loc = loc; exp_extra = [];
-        exp_type = copy_with_loc loc (type_constant cst);
+        exp_type = type_constant cst;
         exp_env = env }
   | Pexp_let(Nonrecursive, [spat, sval], sbody) when contains_gadt env spat ->
       type_expect ?in_function env
       if is_optional l && not_function ty_res then
         Location.prerr_warning (fst (List.hd cases)).pat_loc
           Warnings.Unerasable_optional_argument;
-      rue { (* need unification to have the same location *)
+      re {
         exp_desc = Texp_function(l,cases, partial);
         exp_loc = loc; exp_extra = [];
-        exp_type = copy_with_loc loc (instance env (newgenty (Tarrow(l, ty_arg, ty_res, Cok))));
+        exp_type = 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 *)
       end_def ();
       lower_args [] ty;
       begin_def ();
-      let (args, ty_res) = type_application env funct sargs in (* typeloc is done here *)
+      let (args, ty_res) = type_application env funct sargs in
       end_def ();
       unify_var env (newvar()) funct.exp_type;
       rue {
   | Pexp_try(sbody, caselist) ->
       let body = type_expect env sbody ty_expected in
       let cases, _ =
-        type_cases env (copy_with_loc loc Predef.type_exn) ty_expected false loc caselist in
+        type_cases env Predef.type_exn ty_expected false loc caselist in
       re {
         exp_desc = Texp_try(body, cases);
         exp_loc = loc; exp_extra = [];
         exp_type = body.exp_type;
         exp_env = env }
   | Pexp_tuple sexpl ->
-      (* typeloc: type_expected and the exp_type are different types, for some unknown reason.
-         So we need set loc twice. *)
       let subtypes = List.map (fun _ -> newgenvar ()) sexpl in
-      let to_unify = copy_with_loc loc (newgenty (Ttuple subtypes)) in
+      let to_unify = 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_desc = Texp_tuple expl;
         exp_loc = loc; exp_extra = [];
         (* Keep sharing *)
-        exp_type = copy_with_loc loc (newty (Ttuple (List.map (fun e -> e.exp_type) expl)));
+        exp_type = newty (Ttuple (List.map (fun e -> e.exp_type) expl));
         exp_env = env }
   | Pexp_construct(lid, sarg, explicit_arity) ->
       type_construct env loc lid sarg explicit_arity ty_expected
   | Pexp_variant(l, sarg) ->
-      (* CR jfuruse: tyloc todo for sarg *)
       (* Keep sharing *)
       let ty_expected0 = instance env ty_expected in
       begin try match
           begin match row_field_repr (List.assoc l row.row_fields),
           row_field_repr (List.assoc l row0.row_fields) with
             Rpresent (Some ty), Rpresent (Some ty0) ->
-              (* tyloc: l is already in the type, so no need of introduce tyloc *)
               let arg = type_argument env sarg ty ty0 in
               re { exp_desc = Texp_variant(l, Some arg);
                    exp_loc = loc; exp_extra = [];
         rue {
           exp_desc = Texp_variant(l, arg);
           exp_loc = loc; exp_extra = [];
-          exp_type= copy_with_loc loc 
-                    (newty (Tvariant{row_fields = [l, Rpresent arg_type];
+          exp_type= newty (Tvariant{row_fields = [l, Rpresent arg_type];
                                     row_more = newvar ();
                                     row_bound = ();
                                     row_closed = false;
                                     row_fixed = false;
-                                    row_name = None}));
+                                    row_name = None});
           exp_env = env }
       end
   | Pexp_record(lid_sexp_list, opt_sexp) ->
-      (* CR jfuruse: typeloc todo *)
       let lbl_exp_list =
         type_label_a_list env (type_label_exp true env loc ty_expected)
           lid_sexp_list in
       re {
         exp_desc = Texp_record(lbl_exp_list, opt_exp);
         exp_loc = loc; exp_extra = [];
-        exp_type = set_loc loc (instance env ty_expected); (* set_loc enforces loc unification *)
+        exp_type = instance env ty_expected;
         exp_env = env }
   | Pexp_field(sarg, lid) ->
-      (* CR jfuruse: typeloc todo *)
       let arg = type_exp env sarg in
       let (label_path,label) = Typetexp.find_label env loc lid.txt in
       let (_, ty_arg, ty_res) = instance_label false label in
-      let ty_res = copy_with_loc lid.Location.loc ty_res in
-(* WRONG
-      let ty_arg = copy_with_loc loc ty_arg 
-      in
-*)
       unify_exp env arg ty_res;
       rue {
         exp_desc = Texp_field(arg, label_path, lid, label);
         exp_type = ty_arg;
         exp_env = env }
   | Pexp_setfield(srecord, lid, snewval) ->
-      (* CR jfuruse: typeloc todo *)
       let record = type_exp env srecord in
       let (label_path, label) = Typetexp.find_label env loc lid.txt in
       let (label_path, label_loc, label, newval) =
         exp_env = env }
   | Pexp_array(sargl) ->
       let ty = newgenvar() in
-      let to_unify = copy_with_loc loc (Predef.type_array ty) in
+      let to_unify = 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 (copy_with_loc scond.pexp_loc Predef.type_bool) in
+      let cond = type_expect env scond Predef.type_bool in
       begin match sifnot with
         None ->
-          let ifso = type_expect env sifso (copy_with_loc sifso.pexp_loc Predef.type_unit) in
+          let ifso = type_expect env sifso 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 (copy_with_loc scond.pexp_loc Predef.type_bool) in
+      let cond = type_expect env scond 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 = copy_with_loc loc (instance_def Predef.type_unit);
+        exp_type = instance_def Predef.type_unit;
         exp_env = env }
   | Pexp_for(param, slow, shigh, dir, sbody) ->
-      let low = type_expect env slow (copy_with_loc param.loc Predef.type_int) in
-      let high = type_expect env shigh (copy_with_loc param.loc Predef.type_int) in
+      let low = type_expect env slow Predef.type_int in
+      let high = type_expect env shigh Predef.type_int in
       let (id, new_env) =
-        Env.enter_value param.txt {val_type = copy_with_loc param.loc (instance_def Predef.type_int);
+        Env.enter_value param.txt {val_type = 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 = copy_with_loc loc (instance_def Predef.type_unit);
+        exp_type = instance_def Predef.type_unit;
         exp_env = env }
   | Pexp_constraint(sarg, sty, sty') ->
 
             (arg, arg.exp_type,None,None)
         | (Some sty, None) ->
             if separate then begin_def ();
-            let cty = Typetexp.transl_simple_type env false sty in (* tyloc is done here *)
+            let cty = Typetexp.transl_simple_type env false sty in
             let ty = cty.ctyp_type in
             if separate then begin
               end_def ();
               (type_argument env sarg ty ty, ty, Some cty, None)
         | (None, Some sty') ->
             let (cty', force) =
-              Typetexp.transl_simple_type_delayed env sty' (* tyloc is done here *)
+              Typetexp.transl_simple_type_delayed env sty'
             in
             let ty' = cty'.ctyp_type in
             if separate then begin_def ();
         | (Some sty, Some sty') ->
             if separate then begin_def ();
             let (cty, force) =
-              Typetexp.transl_simple_type_delayed env sty (* tyloc is done here *)
+              Typetexp.transl_simple_type_delayed env sty
             and (cty', force') =
-              Typetexp.transl_simple_type_delayed env sty'(* tyloc is done here *)
+              Typetexp.transl_simple_type_delayed env sty'
             in
             let ty = cty.ctyp_type in
             let ty' = cty'.ctyp_type in
         exp_extra = (Texp_constraint (cty, cty'), loc) :: arg.exp_extra;
       }
   | Pexp_when(scond, sbody) ->
-      let cond = type_expect env scond (copy_with_loc loc Predef.type_bool) in (* CR jfuruse: bad location *)
+      let cond = type_expect env scond Predef.type_bool in
       let body = type_expect env sbody ty_expected in
       re {
         exp_desc = Texp_when(cond, body);
   | Pexp_send (e, met) ->
       if !Clflags.principal then begin_def ();
       let obj = type_exp env e in
-      (* tyloc: obj is required to have an object type *)
-      ignore (set_loc loc obj.exp_type);
       begin try
         let (meth, exp, typ) =
           match obj.exp_desc with
         raise(Error(e.pexp_loc, Undefined_method (obj.exp_type, met)))
       end
   | Pexp_new cl ->
-      (* CR jfuruse: typeloc *)
       let (cl_path, cl_decl) = Typetexp.find_class env loc cl.txt in
         begin match cl_decl.cty_new with
           None ->
             rue {
               exp_desc = Texp_new (cl_path, cl, cl_decl);
               exp_loc = loc; exp_extra = [];
-              exp_type = copy_with_loc loc (instance_def ty);
+              exp_type = instance_def ty;
               exp_env = env }
         end
   | Pexp_setinstvar (lab, snewval) ->
-      (* CR jfuruse: typeloc *)
       begin try
         let (path, desc) = Env.lookup_value (Longident.Lident lab.txt) env in
         match desc.val_kind with
           raise(Error(loc, Unbound_instance_variable lab.txt))
       end
   | Pexp_override lst ->
-      (* CR jfuruse: typeloc? *)
       let _ =
        List.fold_right
         (fun (lab, _) l ->
         exp_type = ty;
         exp_env = env }
   | Pexp_assert (e) ->
-      let cond = type_expect env e (copy_with_loc e.pexp_loc Predef.type_bool) in
+      let cond = type_expect env e Predef.type_bool in
       rue {
         exp_desc = Texp_assert (cond);
         exp_loc = loc; exp_extra = [];
-        exp_type = copy_with_loc loc (instance_def Predef.type_unit);
+        exp_type = instance_def Predef.type_unit;
         exp_env = env;
       }
   | Pexp_assertfalse ->
       }
   | Pexp_lazy e ->
       let ty = newgenvar () in
-      let to_unify = copy_with_loc loc (Predef.type_lazy_t ty) in
+      let to_unify = Predef.type_lazy_t ty in
       unify_exp_types loc env to_unify ty_expected;
       let arg = type_expect env e ty in
       re {
         exp_env = env;
       }
   | Pexp_poly(sbody, sty) ->
-      (* CR jfuruse: typeloc todo *)
       if !Clflags.principal then begin_def ();
       let ty, cty =
         match sty with None -> repr ty_expected, None
       rue { body with exp_loc = loc; exp_type = ety;
             exp_extra = (Texp_newtype name, loc) :: body.exp_extra }
   | Pexp_pack m ->
-      (* CR jfuruse: typeloc todo *)
       let (p, nl, tl) =
         match Ctype.expand_head env (instance env ty_expected) with
           {desc = Tpackage (p, nl, tl)} ->
   (* funct.exp_type may be generic *)
   let result_type omitted ty_fun =
     List.fold_left
-      (fun ty_fun (l,ty,lv) -> copy_with_loc funct.exp_loc (* CR jfuruse: not sure *) (newty2 lv (Tarrow(l,ty,ty_fun,Cok))))
+      (fun ty_fun (l,ty,lv) -> newty2 lv (Tarrow(l,ty,ty_fun,Cok)))
       ty_fun omitted
   in
   let has_label l ty_fun =
               in
               if ty_fun.level >= t1.level && not_identity funct.exp_desc then
                 Location.prerr_warning sarg1.pexp_loc Warnings.Unused_argument;
-              unify env ty_fun (copy_with_loc sarg1.pexp_loc (* CR jfuruse: not sure *) (newty (Tarrow(l1,t1,t2,Clink(ref Cunknown)))));
+              unify env ty_fun (newty (Tarrow(l1,t1,t2,Clink(ref Cunknown))));
               (t1, t2)
           | Tarrow (l,t1,t2,_) when l = l1
             || !Clflags.classic && l1 = "" && not (is_optional l) ->
         let arg1 () =
           let arg1 = type_expect env sarg1 ty1 in
           if optional = Optional then
-            unify_exp env arg1 (copy_with_loc arg1.exp_loc (type_option(newvar())));
+            unify_exp env arg1 (type_option(newvar()));
           arg1
         in
         type_unknown_args ((l1, Some arg1, optional) :: args) omitted ty2 sargl
   let separate = !Clflags.principal || Env.has_local_constraints env in
   if separate then (begin_def (); begin_def ());
   let (ty_args, ty_res) = instance_constructor constr in
-  (* CR jfuruse: todo how about the args? the following is not correct. *)
-  (* let ty_args = List.map (copy_with_loc loc) ty_args in *)
-  let ty_res = copy_with_loc loc ty_res in (* tyloc. this should be safe *)
   let texp =
     re {
       exp_desc = Texp_construct(path, lid, constr, [],explicit_arity);
   let exp = type_exp env sexp in
   end_def();
   if !Clflags.strict_sequence then
-    let expected_ty = copy_with_loc loc (instance_def Predef.type_unit) in
+    let expected_ty = 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
             {exp with exp_type = instance env exp.exp_type}
         | _ -> type_expect exp_env sexp pat.pat_type)
       spat_sexp_list pat_slot_list in
-
-(* TYLOC
-List.iter2 (fun p e -> 
-  Format.eprintf "@[%a /// %a@]@." 
-    Printtyp.raw_type_expr p.pat_type 
-    Printtyp.raw_type_expr e.exp_type) pat_list exp_list;
-*)
-
   current_slot := None;
   if is_recursive && not !rec_needed
   && Warnings.is_active Warnings.Unused_rec_flag then

typing/typemod.ml

           type_module true funct_body (anchor_submodule name.txt anchor) env
             smodl in
         let mty = enrich_module_type anchor name.txt modl.mod_type env in
-(*
-Format.eprintf "module :: %a@." Printtyp.modtype mty;
-*)
         let (id, newenv) = Env.enter_module name.txt mty env in
         let (str_rem, sig_rem, final_env) = type_struct newenv srem in
         (mkstr (Tstr_module(id, name, modl)) loc :: str_rem,
 type type_expr =
   { mutable desc: type_desc;
     mutable level: int;
-    mutable id: int;
-    mutable tyloc: Location.t option;
-  }
+    mutable id: int }
 
 and type_desc =
     Tvar of string option
 type type_expr =
   { mutable desc: type_desc;
     mutable level: int;
-    mutable id: int;
-    mutable tyloc: Location.t option;
-  }
+    mutable id: int }
 
 and type_desc =
     Tvar of string option

typing/typetexp.ml

   | Ptyp_arrow(l, st1, st2) ->
     let cty1 = transl_type env policy st1 in
     let cty2 = transl_type env policy st2 in
-    let ty = set_loc loc (newty (Tarrow(l, cty1.ctyp_type, cty2.ctyp_type, Cok))) in
+    let ty = newty (Tarrow(l, cty1.ctyp_type, cty2.ctyp_type, Cok)) in
     ctyp (Ttyp_arrow (l, cty1, cty2)) ty env loc
   | Ptyp_tuple stl ->
     let ctys = List.map (transl_type env policy) stl in
-    let ty = set_loc loc (newty (Ttuple (List.map (fun ctyp -> ctyp.ctyp_type) ctys))) in
+    let ty = newty (Ttuple (List.map (fun ctyp -> ctyp.ctyp_type) ctys)) in
     ctyp (Ttyp_tuple ctys) ty env loc
   | Ptyp_constr(lid, stl) ->
       let (path, decl) = find_type env styp.ptyp_loc lid.txt in
              raise (Error(sty.ptyp_loc, Type_mismatch (swap_list trace))))
         (List.combine stl args) params;
       let constr =
-        copy_with_loc loc (newconstr path (List.map (fun ctyp -> ctyp.ctyp_type) args)) in
+        newconstr path (List.map (fun ctyp -> ctyp.ctyp_type) args) in
       begin try
         Ctype.enforce_constraints env constr
       with Unify trace ->
             in
             { field_desc = desc; field_loc = pf.pfield_loc })
           fields in
-      let ty = copy_with_loc loc (newobj (transl_fields env policy [] fields)) in
+      let ty = newobj (transl_fields env policy [] fields) in
         ctyp (Ttyp_object fields) ty env loc
   | Ptyp_class(lid, stl, present) ->
       let (path, decl, is_variant) =
             else if policy <> Univars then row
             else { row with row_more = new_pre_univar () }
           in
-          copy_with_loc loc (newty (Tvariant row))
+          newty (Tvariant row)
       | Tobject (fi, _) ->
           let _, tv = flatten_fields fi in
           if policy = Univars then pre_univars := tv :: !pre_univars;
-          ty  (* CR jfuruse: typloc todo *)
+          ty
       | _ ->
           assert false
       in
         else if policy <> Univars then row
         else { row with row_more = new_pre_univar () }
       in
-      let ty = copy_with_loc loc (newty (Tvariant row)) in
+      let ty = newty (Tvariant row) in
       ctyp (Ttyp_variant (tfields, closed, present)) ty env loc
    | Ptyp_poly(vars, st) ->
       begin_def();
             end else tyl)
           [] new_univars
       in
-      (* CR jfuruse: tyloc not sure *)
-      let ty' = copy_with_loc loc (Btype.newgenty (Tpoly(ty, List.rev ty_list))) in
+      let ty' = Btype.newgenty (Tpoly(ty, List.rev ty_list)) in
       unify_var env (newvar()) ty';
       ctyp (Ttyp_poly (vars, cty)) ty' env loc
   | Ptyp_package (p, l) ->
                              s, transl_type env policy pty
                           ) l in
       let path = !transl_modtype_longident styp.ptyp_loc env p.txt in
-      let ty = copy_with_loc loc (newty (Tpackage (path,
-                                                   List.map (fun (s, pty) -> s.txt) l,
-                                                   List.map (fun (_,cty) -> cty.ctyp_type) ptys)))
+      let ty = newty (Tpackage (path,
+                       List.map (fun (s, pty) -> s.txt) l,
+                       List.map (fun (_,cty) -> cty.ctyp_type) ptys))
       in
         ctyp (Ttyp_package {
                 pack_name = path;
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.