ajout des annotations pour variables et appels terminaux

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@8232 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

.depend

@@ -52,12 +52,13 @@ parsing/printast.cmx: parsing/parsetree.cmi parsing/longident.cmx \
     parsing/location.cmx parsing/asttypes.cmi parsing/printast.cmi 
 parsing/syntaxerr.cmo: parsing/location.cmi parsing/syntaxerr.cmi 
 parsing/syntaxerr.cmx: parsing/location.cmx parsing/syntaxerr.cmi 
+typing/annot.cmi: parsing/location.cmi 
 typing/btype.cmi: typing/types.cmi typing/path.cmi parsing/asttypes.cmi 
 typing/ctype.cmi: typing/types.cmi typing/path.cmi typing/ident.cmi \
     typing/env.cmi parsing/asttypes.cmi 
 typing/datarepr.cmi: typing/types.cmi typing/path.cmi parsing/asttypes.cmi 
 typing/env.cmi: typing/types.cmi typing/path.cmi parsing/longident.cmi \
-    typing/ident.cmi utils/consistbl.cmi 
+    typing/ident.cmi utils/consistbl.cmi typing/annot.cmi 
 typing/includeclass.cmi: typing/types.cmi typing/typedtree.cmi typing/env.cmi \
     typing/ctype.cmi 
 typing/includecore.cmi: typing/types.cmi typing/typedtree.cmi \
@@ -74,14 +75,14 @@ typing/path.cmi: typing/ident.cmi
 typing/predef.cmi: typing/types.cmi typing/path.cmi typing/ident.cmi 
 typing/printtyp.cmi: typing/types.cmi typing/path.cmi typing/outcometree.cmi \
     parsing/longident.cmi typing/ident.cmi 
-typing/stypes.cmi: typing/typedtree.cmi parsing/location.cmi 
+typing/stypes.cmi: typing/typedtree.cmi parsing/location.cmi typing/annot.cmi 
 typing/subst.cmi: typing/types.cmi typing/path.cmi typing/ident.cmi 
 typing/typeclass.cmi: typing/types.cmi typing/typedtree.cmi \
     parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \
     typing/ident.cmi typing/env.cmi typing/ctype.cmi parsing/asttypes.cmi 
 typing/typecore.cmi: typing/types.cmi typing/typedtree.cmi typing/path.cmi \
     parsing/parsetree.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/annot.cmi 
 typing/typedecl.cmi: typing/types.cmi typing/path.cmi parsing/parsetree.cmi \
     parsing/longident.cmi parsing/location.cmi typing/ident.cmi \
     typing/env.cmi 
@@ -112,11 +113,13 @@ typing/datarepr.cmx: typing/types.cmx typing/predef.cmx utils/misc.cmx \
 typing/env.cmo: typing/types.cmi utils/tbl.cmi typing/subst.cmi \
     typing/predef.cmi typing/path.cmi utils/misc.cmi parsing/longident.cmi \
     typing/ident.cmi typing/datarepr.cmi utils/consistbl.cmi utils/config.cmi \
-    utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi typing/env.cmi 
+    utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi typing/annot.cmi \
+    typing/env.cmi 
 typing/env.cmx: typing/types.cmx utils/tbl.cmx typing/subst.cmx \
     typing/predef.cmx typing/path.cmx utils/misc.cmx parsing/longident.cmx \
     typing/ident.cmx typing/datarepr.cmx utils/consistbl.cmx utils/config.cmx \
-    utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi typing/env.cmi 
+    utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi typing/annot.cmi \
+    typing/env.cmi 
 typing/ident.cmo: typing/ident.cmi 
 typing/ident.cmx: typing/ident.cmi 
 typing/includeclass.cmo: typing/types.cmi typing/printtyp.cmi \
@@ -174,9 +177,9 @@ typing/printtyp.cmx: typing/types.cmx typing/primitive.cmx typing/predef.cmx \
     utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \
     typing/printtyp.cmi 
 typing/stypes.cmo: typing/typedtree.cmi typing/printtyp.cmi \
-    parsing/location.cmi utils/clflags.cmi typing/stypes.cmi 
+    parsing/location.cmi utils/clflags.cmi typing/annot.cmi typing/stypes.cmi 
 typing/stypes.cmx: typing/typedtree.cmx typing/printtyp.cmx \
-    parsing/location.cmx utils/clflags.cmx typing/stypes.cmi 
+    parsing/location.cmx utils/clflags.cmx typing/annot.cmi typing/stypes.cmi 
 typing/subst.cmo: typing/types.cmi utils/tbl.cmi typing/path.cmi \
     utils/misc.cmi typing/ident.cmi typing/btype.cmi typing/subst.cmi 
 typing/subst.cmx: typing/types.cmx utils/tbl.cmx typing/path.cmx \
@@ -203,14 +206,14 @@ typing/typecore.cmo: utils/warnings.cmi typing/typetexp.cmi typing/types.cmi \
     parsing/parsetree.cmi typing/parmatch.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/typecore.cmi 
+    parsing/asttypes.cmi typing/annot.cmi typing/typecore.cmi 
 typing/typecore.cmx: utils/warnings.cmx typing/typetexp.cmx typing/types.cmx \
     typing/typedtree.cmx typing/stypes.cmx typing/printtyp.cmx \
     typing/primitive.cmx typing/predef.cmx typing/path.cmx \
     parsing/parsetree.cmi typing/parmatch.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/typecore.cmi 
+    parsing/asttypes.cmi typing/annot.cmi typing/typecore.cmi 
 typing/typedecl.cmo: typing/typetexp.cmi typing/types.cmi \
     typing/typedtree.cmi typing/subst.cmi typing/printtyp.cmi \
     typing/primitive.cmi typing/predef.cmi typing/path.cmi \
@@ -237,7 +240,7 @@ typing/typemod.cmo: typing/types.cmi typing/typedtree.cmi typing/typedecl.cmi \
     parsing/parsetree.cmi typing/mtype.cmi utils/misc.cmi \
     parsing/longident.cmi parsing/location.cmi typing/includemod.cmi \
     typing/ident.cmi typing/env.cmi typing/ctype.cmi utils/config.cmi \
-    utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi \
+    utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi typing/annot.cmi \
     typing/typemod.cmi 
 typing/typemod.cmx: typing/types.cmx typing/typedtree.cmx typing/typedecl.cmx \
     typing/typecore.cmx typing/typeclass.cmx typing/subst.cmx \
@@ -245,7 +248,7 @@ typing/typemod.cmx: typing/types.cmx typing/typedtree.cmx typing/typedecl.cmx \
     parsing/parsetree.cmi typing/mtype.cmx utils/misc.cmx \
     parsing/longident.cmx parsing/location.cmx typing/includemod.cmx \
     typing/ident.cmx typing/env.cmx typing/ctype.cmx utils/config.cmx \
-    utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \
+    utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi typing/annot.cmi \
     typing/typemod.cmi 
 typing/types.cmo: typing/primitive.cmi typing/path.cmi utils/misc.cmi \
     typing/ident.cmi parsing/asttypes.cmi typing/types.cmi 
@@ -290,14 +293,14 @@ bytecomp/translmod.cmi: typing/typedtree.cmi parsing/location.cmi \
 bytecomp/translobj.cmi: bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi 
 bytecomp/typeopt.cmi: typing/typedtree.cmi typing/path.cmi \
     bytecomp/lambda.cmi 
-bytecomp/bytegen.cmo: typing/types.cmi bytecomp/switch.cmi \
+bytecomp/bytegen.cmo: typing/types.cmi bytecomp/switch.cmi typing/stypes.cmi \
     typing/primitive.cmi utils/misc.cmi bytecomp/lambda.cmi \
     bytecomp/instruct.cmi typing/ident.cmi utils/config.cmi \
-    parsing/asttypes.cmi bytecomp/bytegen.cmi 
+    parsing/asttypes.cmi typing/annot.cmi bytecomp/bytegen.cmi 
-bytecomp/bytegen.cmx: typing/types.cmx bytecomp/switch.cmx \
+bytecomp/bytegen.cmx: typing/types.cmx bytecomp/switch.cmx typing/stypes.cmx \
     typing/primitive.cmx utils/misc.cmx bytecomp/lambda.cmx \
     bytecomp/instruct.cmx typing/ident.cmx utils/config.cmx \
-    parsing/asttypes.cmi bytecomp/bytegen.cmi 
+    parsing/asttypes.cmi typing/annot.cmi bytecomp/bytegen.cmi 
 bytecomp/bytelibrarian.cmo: utils/misc.cmi utils/config.cmi \
     bytecomp/cmo_format.cmi utils/clflags.cmi bytecomp/bytelink.cmi \
     bytecomp/bytelibrarian.cmi 
@@ -622,10 +625,8 @@ asmcomp/proc.cmx: asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \
     asmcomp/arch.cmx asmcomp/proc.cmi 
 asmcomp/reg.cmo: asmcomp/cmm.cmi asmcomp/reg.cmi 
 asmcomp/reg.cmx: asmcomp/cmm.cmx asmcomp/reg.cmi 
-asmcomp/reload.cmo: asmcomp/reloadgen.cmi asmcomp/reg.cmi asmcomp/mach.cmi \
+asmcomp/reload.cmo: asmcomp/reloadgen.cmi asmcomp/reload.cmi 
-    asmcomp/cmm.cmi asmcomp/arch.cmo asmcomp/reload.cmi 
+asmcomp/reload.cmx: asmcomp/reloadgen.cmx asmcomp/reload.cmi 
-asmcomp/reload.cmx: asmcomp/reloadgen.cmx asmcomp/reg.cmx asmcomp/mach.cmx \
-    asmcomp/cmm.cmx asmcomp/arch.cmx asmcomp/reload.cmi 
 asmcomp/reloadgen.cmo: asmcomp/reg.cmi utils/misc.cmi asmcomp/mach.cmi \
     asmcomp/reloadgen.cmi 
 asmcomp/reloadgen.cmx: asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \
@@ -636,20 +637,20 @@ asmcomp/schedgen.cmo: asmcomp/reg.cmi utils/misc.cmi asmcomp/mach.cmi \
 asmcomp/schedgen.cmx: asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \
     asmcomp/linearize.cmx asmcomp/cmm.cmx asmcomp/arch.cmx \
     asmcomp/schedgen.cmi 
-asmcomp/scheduling.cmo: asmcomp/schedgen.cmi asmcomp/scheduling.cmi 
+asmcomp/scheduling.cmo: asmcomp/schedgen.cmi asmcomp/mach.cmi \
-asmcomp/scheduling.cmx: asmcomp/schedgen.cmx asmcomp/scheduling.cmi 
+    asmcomp/arch.cmo asmcomp/scheduling.cmi 
+asmcomp/scheduling.cmx: asmcomp/schedgen.cmx asmcomp/mach.cmx \
+    asmcomp/arch.cmx asmcomp/scheduling.cmi 
 asmcomp/selectgen.cmo: utils/tbl.cmi asmcomp/reg.cmi asmcomp/proc.cmi \
     utils/misc.cmi asmcomp/mach.cmi typing/ident.cmi asmcomp/debuginfo.cmi \
     asmcomp/cmm.cmi asmcomp/arch.cmo asmcomp/selectgen.cmi 
 asmcomp/selectgen.cmx: utils/tbl.cmx asmcomp/reg.cmx asmcomp/proc.cmx \
     utils/misc.cmx asmcomp/mach.cmx typing/ident.cmx asmcomp/debuginfo.cmx \
     asmcomp/cmm.cmx asmcomp/arch.cmx asmcomp/selectgen.cmi 
-asmcomp/selection.cmo: asmcomp/selectgen.cmi asmcomp/reg.cmi asmcomp/proc.cmi \
+asmcomp/selection.cmo: asmcomp/selectgen.cmi asmcomp/reg.cmi utils/misc.cmi \
-    utils/misc.cmi asmcomp/mach.cmi asmcomp/debuginfo.cmi asmcomp/cmm.cmi \
+    asmcomp/mach.cmi asmcomp/cmm.cmi asmcomp/arch.cmo asmcomp/selection.cmi 
-    asmcomp/arch.cmo asmcomp/selection.cmi 
+asmcomp/selection.cmx: asmcomp/selectgen.cmx asmcomp/reg.cmx utils/misc.cmx \
-asmcomp/selection.cmx: asmcomp/selectgen.cmx asmcomp/reg.cmx asmcomp/proc.cmx \
+    asmcomp/mach.cmx asmcomp/cmm.cmx asmcomp/arch.cmx asmcomp/selection.cmi 
-    utils/misc.cmx asmcomp/mach.cmx asmcomp/debuginfo.cmx asmcomp/cmm.cmx \
-    asmcomp/arch.cmx asmcomp/selection.cmi 
 asmcomp/spill.cmo: asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi \
     asmcomp/mach.cmi asmcomp/spill.cmi 
 asmcomp/spill.cmx: asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx \
@@ -662,18 +663,18 @@ driver/compile.cmi: typing/env.cmi
 driver/optcompile.cmi: typing/env.cmi 
 driver/compile.cmo: utils/warnings.cmi typing/unused_var.cmi \
     typing/typemod.cmi typing/typedtree.cmi bytecomp/translmod.cmi \
-    bytecomp/simplif.cmi typing/printtyp.cmi bytecomp/printlambda.cmi \
+    typing/stypes.cmi bytecomp/simplif.cmi typing/printtyp.cmi \
-    bytecomp/printinstr.cmi parsing/printast.cmi driver/pparse.cmi \
+    bytecomp/printlambda.cmi bytecomp/printinstr.cmi parsing/printast.cmi \
-    parsing/parse.cmi utils/misc.cmi typing/ident.cmi typing/env.cmi \
+    driver/pparse.cmi parsing/parse.cmi utils/misc.cmi typing/ident.cmi \
-    bytecomp/emitcode.cmi utils/config.cmi utils/clflags.cmi utils/ccomp.cmi \
+    typing/env.cmi bytecomp/emitcode.cmi utils/config.cmi utils/clflags.cmi \
-    bytecomp/bytegen.cmi driver/compile.cmi 
+    utils/ccomp.cmi bytecomp/bytegen.cmi driver/compile.cmi 
 driver/compile.cmx: utils/warnings.cmx typing/unused_var.cmx \
     typing/typemod.cmx typing/typedtree.cmx bytecomp/translmod.cmx \
-    bytecomp/simplif.cmx typing/printtyp.cmx bytecomp/printlambda.cmx \
+    typing/stypes.cmx bytecomp/simplif.cmx typing/printtyp.cmx \
-    bytecomp/printinstr.cmx parsing/printast.cmx driver/pparse.cmx \
+    bytecomp/printlambda.cmx bytecomp/printinstr.cmx parsing/printast.cmx \
-    parsing/parse.cmx utils/misc.cmx typing/ident.cmx typing/env.cmx \
+    driver/pparse.cmx parsing/parse.cmx utils/misc.cmx typing/ident.cmx \
-    bytecomp/emitcode.cmx utils/config.cmx utils/clflags.cmx utils/ccomp.cmx \
+    typing/env.cmx bytecomp/emitcode.cmx utils/config.cmx utils/clflags.cmx \
-    bytecomp/bytegen.cmx driver/compile.cmi 
+    utils/ccomp.cmx bytecomp/bytegen.cmx driver/compile.cmi 
 driver/errors.cmo: utils/warnings.cmi typing/typetexp.cmi typing/typemod.cmi \
     typing/typedecl.cmi typing/typecore.cmi typing/typeclass.cmi \
     bytecomp/translmod.cmi bytecomp/translcore.cmi bytecomp/translclass.cmi \

asmcomp/closure.ml

@@ -492,7 +492,7 @@ let rec close fenv cenv = function
       end
   | Lfunction(kind, params, body) as funct ->
       close_one_function fenv cenv (Ident.create "fun") funct
-  | Lapply(funct, args) ->
+  | Lapply(funct, args, loc) ->
       let nargs = List.length args in
       begin match (close fenv cenv funct, close_list fenv cenv args) with
         ((ufunct, Value_closure(fundesc, approx_res)),

bytecomp/bytegen.ml

@@ -414,13 +414,15 @@ let rec comp_expr env exp sz cont =
       end
   | Lconst cst ->
       Kconst cst :: cont
-  | Lapply(func, args) ->
+  | Lapply(func, args, loc) ->
       let nargs = List.length args in
-      if is_tailcall cont then
+      if is_tailcall cont then begin
+        Stypes.record (Stypes.An_call (loc, Annot.Tail));
         comp_args env args sz
           (Kpush :: comp_expr env func (sz + nargs)
             (Kappterm(nargs, sz + nargs) :: discard_dead_code cont))
-      else
+      end else begin
+        Stypes.record (Stypes.An_call (loc, Annot.Stack));
         if nargs < 4 then
           comp_args env args sz
             (Kpush :: comp_expr env func (sz + nargs) (Kapply nargs :: cont))
@@ -431,6 +433,7 @@ let rec comp_expr env exp sz cont =
             (Kpush :: comp_expr env func (sz + 3 + nargs)
                       (Kapply nargs :: cont1))
         end
+      end
   | Lsend(kind, met, obj, args) ->
       let args = if kind = Cached then List.tl args else args in
       let nargs = List.length args + 1 in
@@ -746,7 +749,7 @@ let rec comp_expr env exp sz cont =
       | Lev_after ty ->
           let info =
             match lam with
-              Lapply(_, args)   -> Event_return (List.length args)
+              Lapply(_, args, _)   -> Event_return (List.length args)
             | Lsend(_, _, _, args) -> Event_return (List.length args + 1)
             | _                 -> Event_other
           in

bytecomp/lambda.ml

@@ -124,7 +124,7 @@ type shared_code = (int * int) list
 type lambda =
     Lvar of Ident.t
   | Lconst of structured_constant
-  | Lapply of lambda * lambda list
+  | Lapply of lambda * lambda list * Location.t
   | Lfunction of function_kind * Ident.t list * lambda
   | Llet of let_kind * Ident.t * lambda * lambda
   | Lletrec of (Ident.t * lambda) list * lambda
@@ -170,7 +170,7 @@ let rec same l1 l2 =
       Ident.same v1 v2
   | Lconst c1, Lconst c2 ->
       c1 = c2
-  | Lapply(a1, bl1), Lapply(a2, bl2) ->
+  | Lapply(a1, bl1, _), Lapply(a2, bl2, _) ->
       same a1 a2 && samelist same bl1 bl2
   | Lfunction(k1, idl1, a1), Lfunction(k2, idl2, a2) ->
       k1 = k2 && samelist Ident.same idl1 idl2 && same a1 a2
@@ -240,7 +240,7 @@ let name_lambda_list args fn =
 let rec iter f = function
     Lvar _
   | Lconst _ -> ()
-  | Lapply(fn, args) ->
+  | Lapply(fn, args, _) ->
       f fn; List.iter f args
   | Lfunction(kind, params, body) ->
       f body
@@ -374,7 +374,7 @@ let subst_lambda s lam =
     Lvar id as l ->
       begin try Ident.find_same id s with Not_found -> l end
   | Lconst sc as l -> l
-  | Lapply(fn, args) -> Lapply(subst fn, List.map subst args)
+  | Lapply(fn, args, loc) -> Lapply(subst fn, List.map subst args, loc)
   | Lfunction(kind, params, body) -> Lfunction(kind, params, subst body)
   | Llet(str, id, arg, body) -> Llet(str, id, subst arg, subst body)
   | Lletrec(decl, body) -> Lletrec(List.map subst_decl decl, subst body)

bytecomp/lambda.mli

@@ -133,7 +133,7 @@ type shared_code = (int * int) list     (* stack size -> code label *)
 type lambda =
     Lvar of Ident.t
   | Lconst of structured_constant
-  | Lapply of lambda * lambda list
+  | Lapply of lambda * lambda list * Location.t
   | Lfunction of function_kind * Ident.t list * lambda
   | Llet of let_kind * Ident.t * lambda * lambda
   | Lletrec of (Ident.t * lambda) list * lambda

bytecomp/printlambda.ml

@@ -185,7 +185,7 @@ let rec lam ppf = function
       Ident.print ppf id
   | Lconst cst ->
       struct_const ppf cst
-  | Lapply(lfun, largs) ->
+  | Lapply(lfun, largs, _) ->
       let lams ppf largs =
         List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
       fprintf ppf "@[<2>(apply@ %a%a)@]" lam lfun lams largs

bytecomp/simplif.ml

@@ -26,8 +26,8 @@ let rec eliminate_ref id = function
     Lvar v as lam ->
       if Ident.same v id then raise Real_reference else lam
   | Lconst cst as lam -> lam
-  | Lapply(e1, el) -> 
+  | Lapply(e1, el, loc) -> 
-      Lapply(eliminate_ref id e1, List.map (eliminate_ref id) el)
+      Lapply(eliminate_ref id e1, List.map (eliminate_ref id) el, loc)
   | Lfunction(kind, params, body) as lam ->
       if IdentSet.mem id (free_variables lam)
       then raise Real_reference
@@ -104,7 +104,7 @@ let simplify_exits lam =
   
   let rec count = function
   | (Lvar _| Lconst _) -> ()
-  | Lapply(l1, ll) -> count l1; List.iter count ll
+  | Lapply(l1, ll, _) -> count l1; List.iter count ll
   | Lfunction(kind, params, l) -> count l
   | Llet(str, v, l1, l2) ->
       count l2; count l1
@@ -185,7 +185,7 @@ let simplify_exits lam =
 
   let rec simplif = function
   | (Lvar _|Lconst _) as l -> l
-  | Lapply(l1, ll) -> Lapply(simplif l1, List.map simplif ll)
+  | Lapply(l1, ll, loc) -> Lapply(simplif l1, List.map simplif ll, loc)
   | Lfunction(kind, params, l) -> Lfunction(kind, params, simplif l)
   | Llet(kind, v, l1, l2) -> Llet(kind, v, simplif l1, simplif l2)
   | Lletrec(bindings, body) ->
@@ -276,7 +276,7 @@ let simplify_lets lam =
   let rec count = function
   | Lvar v -> incr_var v
   | Lconst cst -> ()
-  | Lapply(l1, ll) -> count l1; List.iter count ll
+  | Lapply(l1, ll, _) -> count l1; List.iter count ll
   | Lfunction(kind, params, l) -> count l
   | Llet(str, v, Lvar w, l2) when not !Clflags.debug ->
       (* v will be replaced by w in l2, so each occurrence of v in l2
@@ -346,7 +346,7 @@ let simplify_lets lam =
         l
       end
   | Lconst cst as l -> l
-  | Lapply(l1, ll) -> Lapply(simplif l1, List.map simplif ll)
+  | Lapply(l1, ll, loc) -> Lapply(simplif l1, List.map simplif ll, loc)
   | Lfunction(kind, params, l) -> Lfunction(kind, params, simplif l)
   | Llet(str, v, Lvar w, l2) when not !Clflags.debug ->
       Hashtbl.add subst v (simplif (Lvar w));

bytecomp/translclass.ml

@@ -34,12 +34,14 @@ let lfunction params body =
   |  _ ->
       Lfunction (Curried, params, body)
 
-let lapply func args =
+let lapply func args loc =
   match func with
-    Lapply(func', args') ->
+    Lapply(func', args', _) ->
-      Lapply(func', args' @ args)
+      Lapply(func', args' @ args, loc)
   | _ ->
-      Lapply(func, args)
+      Lapply(func, args, loc)
+
+let mkappl (func, args) = Lapply (func, args, Location.none);;
 
 let lsequence l1 l2 =
   if l2 = lambda_unit then l1 else Lsequence(l1, l2)
@@ -68,7 +70,7 @@ let copy_inst_var obj id expr templ offset =
                                                     Lvar offset])])]))
 
 let transl_val tbl create name =
-  Lapply (oo_prim (if create then "new_variable" else "get_variable"),
+  mkappl (oo_prim (if create then "new_variable" else "get_variable"),
           [Lvar tbl; transl_label name])
 
 let transl_vals tbl create vals rem =
@@ -82,7 +84,7 @@ let meths_super tbl meths inh_meths =
     (fun (nm, id) rem ->
        try
          (nm, id,
-          Lapply(oo_prim "get_method", [Lvar tbl; Lvar (Meths.find nm meths)]))
+          mkappl(oo_prim "get_method", [Lvar tbl; Lvar (Meths.find nm meths)]))
          :: rem
        with Not_found -> rem)
     inh_meths []
@@ -97,16 +99,16 @@ let create_object cl obj init =
   let (inh_init, obj_init, has_init) = init obj' in
   if obj_init = lambda_unit then
     (inh_init,
-     Lapply (oo_prim (if has_init then "create_object_and_run_initializers"
+     mkappl (oo_prim (if has_init then "create_object_and_run_initializers"
                       else"create_object_opt"),
              [obj; Lvar cl]))
   else begin
    (inh_init,
     Llet(Strict, obj',
-            Lapply (oo_prim "create_object_opt", [obj; Lvar cl]),
+            mkappl (oo_prim "create_object_opt", [obj; Lvar cl]),
          Lsequence(obj_init,
                    if not has_init then Lvar obj' else
-                   Lapply (oo_prim "run_initializers_opt",
+                   mkappl (oo_prim "run_initializers_opt",
                            [obj; Lvar obj'; Lvar cl]))))
   end
 
@@ -120,7 +122,7 @@ let rec build_object_init cl_table obj params inh_init obj_init cl =
         | Some envs -> [Lprim(Pfield (List.length inh_init + 1), [Lvar envs])]
       in
       ((envs, (obj_init, path)::inh_init),
-       Lapply(Lvar obj_init, env @ [obj]))
+       mkappl(Lvar obj_init, env @ [obj]))
   | Tclass_structure str ->
       create_object cl_table obj (fun obj ->
         let (inh_init, obj_init, has_init) =
@@ -177,7 +179,7 @@ let rec build_object_init cl_table obj params inh_init obj_init cl =
       let (inh_init, obj_init) =
         build_object_init cl_table obj params inh_init obj_init cl
       in
-      (inh_init, transl_apply obj_init oexprs)
+      (inh_init, transl_apply obj_init oexprs Location.none)
   | Tclass_let (rec_flag, defs, vals, cl) ->
       let (inh_init, obj_init) =
         build_object_init cl_table obj (vals @ params) inh_init obj_init cl
@@ -203,7 +205,7 @@ let rec build_object_init_0 cl_table params cl copy_env subst_env top ids =
 
 
 let bind_method tbl lab id cl_init =
-  Llet(StrictOpt, id, Lapply (oo_prim "get_method_label",
+  Llet(StrictOpt, id, mkappl (oo_prim "get_method_label",
                               [Lvar tbl; transl_label lab]),
        cl_init)
 
@@ -219,7 +221,7 @@ let bind_methods tbl meths vals cl_init =
     "new_methods_variables", [transl_meth_list (List.map fst vals)]
   in
   Llet(StrictOpt, ids,
-       Lapply (oo_prim getter,
+       mkappl (oo_prim getter,
                [Lvar tbl; transl_meth_list (List.map fst methl)] @ names),
        List.fold_right
          (fun (lab,id) lam -> decr i; Llet(StrictOpt, id, lfield ids !i, lam))
@@ -229,9 +231,9 @@ let output_methods tbl methods lam =
   match methods with
     [] -> lam
   | [lab; code] ->
-      lsequence (Lapply(oo_prim "set_method", [Lvar tbl; lab; code])) lam
+      lsequence (mkappl(oo_prim "set_method", [Lvar tbl; lab; code])) lam
   | _ ->
-      lsequence (Lapply(oo_prim "set_methods",
+      lsequence (mkappl(oo_prim "set_methods",
                         [Lvar tbl; Lprim(Pmakeblock(0,Immutable), methods)]))
         lam
 
@@ -254,7 +256,7 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl =
           let lpath = transl_path path in
           (inh_init,
            Llet (Strict, obj_init,
-                 Lapply(Lprim(Pfield 1, [lpath]), Lvar cla ::
+                 mkappl(Lprim(Pfield 1, [lpath]), Lvar cla ::
                         if top then [Lprim(Pfield 3, [lpath])] else []),
                  bind_super cla super cl_init))
       | _ ->
@@ -295,7 +297,7 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl =
                 (inh_init, cl_init, methods, vals @ values)
             | Cf_init exp ->
                 (inh_init,
-                 Lsequence(Lapply (oo_prim "add_initializer",
+                 Lsequence(mkappl (oo_prim "add_initializer",
                                    Lvar cla :: msubst false (transl_exp exp)),
                            cl_init),
                  methods, values))
@@ -348,7 +350,7 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl =
               cl_init valids in
           (inh_init,
            Llet (Strict, inh,
-                 Lapply(oo_prim "inherits", narrow_args @
+                 mkappl(oo_prim "inherits", narrow_args @
                         [lpath; Lconst(Const_pointer(if top then 1 else 0))]),
                  Llet(StrictOpt, obj_init, lfield inh 0, cl_init)))
       | _ ->
@@ -357,10 +359,11 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl =
           in
           if cstr then core cl_init else
           let (inh_init, cl_init) =
-            core (Lsequence (Lapply (oo_prim "widen", [Lvar cla]), cl_init))
+            core (Lsequence (mkappl (oo_prim "widen", [Lvar cla]), cl_init))
           in
           (inh_init,
-           Lsequence(Lapply (oo_prim "narrow", narrow_args), cl_init))
+           Lsequence(mkappl (oo_prim "narrow", narrow_args),
+                     cl_init))
       end
 
 let rec build_class_lets cl =
@@ -407,7 +410,7 @@ let rec transl_class_rebind obj_init cl vf =
        | rem                              -> build [] rem)
   | Tclass_apply (cl, oexprs) ->
       let path, obj_init = transl_class_rebind obj_init cl vf in
-      (path, transl_apply obj_init oexprs)
+      (path, transl_apply obj_init oexprs Location.none)
   | Tclass_let (rec_flag, defs, vals, cl) ->
       let path, obj_init = transl_class_rebind obj_init cl vf in
       (path, Translcore.transl_let rec_flag defs obj_init)
@@ -435,7 +438,7 @@ let transl_class_rebind ids cl vf =
   try
     let obj_init = Ident.create "obj_init"
     and self = Ident.create "self" in
-    let obj_init0 = lapply (Lvar obj_init) [Lvar self] in
+    let obj_init0 = lapply (Lvar obj_init) [Lvar self] Location.none in
     let path, obj_init' = transl_class_rebind_0 self obj_init0 cl vf in
     if not (Translcore.check_recursive_lambda ids obj_init') then
       raise(Error(cl.cl_loc, Illegal_class_expr));
@@ -452,13 +455,13 @@ let transl_class_rebind ids cl vf =
     Llet(
     Alias, cla, transl_path path,
     Lprim(Pmakeblock(0, Immutable),
-          [Lapply(Lvar new_init, [lfield cla 0]);
+          [mkappl(Lvar new_init, [lfield cla 0]);
            lfunction [table]
              (Llet(Strict, env_init,
-                   Lapply(lfield cla 1, [Lvar table]),
+                   mkappl(lfield cla 1, [Lvar table]),
                    lfunction [envs]
-                     (Lapply(Lvar new_init,
+                     (mkappl(Lvar new_init,
-                             [Lapply(Lvar env_init, [Lvar envs])]))));
+                             [mkappl(Lvar env_init, [Lvar envs])]))));
            lfield cla 2;
            lfield cla 3])))
   with Exit ->
@@ -497,12 +500,12 @@ let rec builtin_meths self env env2 body =
   match body with
   | Llet(_, s', Lvar s, body) when List.mem s self ->
       builtin_meths (s'::self) env env2 body
-  | Lapply(f, [arg]) when const_path f ->
+  | Lapply(f, [arg], _) when const_path f ->
       let s, args = conv arg in ("app_"^s, f :: args)
-  | Lapply(f, [arg; p]) when const_path f && const_path p ->
+  | Lapply(f, [arg; p], _) when const_path f && const_path p ->
       let s, args = conv arg in
       ("app_"^s^"_const", f :: args @ [p])
-  | Lapply(f, [p; arg]) when const_path f && const_path p ->
+  | Lapply(f, [p; arg], _) when const_path f && const_path p ->
       let s, args = conv arg in
       ("app_const_"^s, f :: p :: args)
   | Lsend(Self, Lvar n, Lvar s, [arg]) when List.mem s self ->
@@ -533,7 +536,7 @@ module M = struct
   open CamlinternalOO
   let builtin_meths self env env2 body =
     let builtin, args = builtin_meths self env env2 body in
-    (* if not arr then [Lapply(oo_prim builtin, args)] else *)
+    (* if not arr then [mkappl(oo_prim builtin, args)] else *)
     let tag = match builtin with
       "get_const" -> GetConst
     | "get_var"   -> GetVar
@@ -680,11 +683,11 @@ let transl_class ids cl_id arity pub_meths cl vflag =
     tags pub_meths;
   let ltable table lam =
     Llet(Strict, table,
-         Lapply (oo_prim "create_table", [transl_meth_list pub_meths]), lam)
+         mkappl (oo_prim "create_table", [transl_meth_list pub_meths]), lam)
   and ldirect obj_init =
     Llet(Strict, obj_init, cl_init,
-         Lsequence(Lapply (oo_prim "init_class", [Lvar cla]),
+         Lsequence(mkappl (oo_prim "init_class", [Lvar cla]),
-                   Lapply(Lvar obj_init, [lambda_unit])))
+                   mkappl (Lvar obj_init, [lambda_unit])))
   in
   (* Simplest case: an object defined at toplevel (ids=[]) *)
   if top && ids = [] then llets (ltable cla (ldirect obj_init)) else
@@ -695,16 +698,16 @@ let transl_class ids cl_id arity pub_meths cl vflag =
     Llet(Strict, class_init, cl_init, lam (free_variables cl_init))
   and lbody fv =
     if List.for_all (fun id -> not (IdentSet.mem id fv)) ids then
-      Lapply (oo_prim "make_class",[transl_meth_list pub_meths;
+      mkappl (oo_prim "make_class",[transl_meth_list pub_meths;
                                     Lvar class_init])
     else
       ltable table (
       Llet(
-      Strict, env_init, Lapply(Lvar class_init, [Lvar table]),
+      Strict, env_init, mkappl (Lvar class_init, [Lvar table]),
       Lsequence(
-      Lapply (oo_prim "init_class", [Lvar table]),
+      mkappl (oo_prim "init_class", [Lvar table]),
       Lprim(Pmakeblock(0, Immutable),
-            [Lapply(Lvar env_init, [lambda_unit]);
+            [mkappl (Lvar env_init, [lambda_unit]);
              Lvar class_init; Lvar env_init; lambda_unit]))))
   and lbody_virt lenvs =
     Lprim(Pmakeblock(0, Immutable),
@@ -740,7 +743,7 @@ let transl_class ids cl_id arity pub_meths cl vflag =
          lam)
   and def_ids cla lam =
     Llet(StrictOpt, env2,
-         Lapply (oo_prim "new_variable", [Lvar cla; transl_label ""]),
+         mkappl (oo_prim "new_variable", [Lvar cla; transl_label ""]),
          lam)
   in
   let inh_paths =
@@ -754,7 +757,7 @@ let transl_class ids cl_id arity pub_meths cl vflag =
   and lcache lam =
     if inh_keys = [] then Llet(Alias, cached, Lvar tables, lam) else
     Llet(Strict, cached,
-         Lapply(oo_prim "lookup_tables",
+         mkappl (oo_prim "lookup_tables",
                 [Lvar tables; Lprim(Pmakeblock(0, Immutable), inh_keys)]),
          lam)
   and lset cached i lam =
@@ -763,7 +766,7 @@ let transl_class ids cl_id arity pub_meths cl vflag =
   let ldirect () =
     ltable cla
       (Llet(Strict, env_init, def_ids cla cl_init,
-            Lsequence(Lapply (oo_prim "init_class", [Lvar cla]),
+            Lsequence(mkappl (oo_prim "init_class", [Lvar cla]),
                       lset cached 0 (Lvar env_init))))
   and lclass_virt () =
     lset cached 0 (Lfunction(Curried, [cla], def_ids cla cl_init))
@@ -775,14 +778,14 @@ let transl_class ids cl_id arity pub_meths cl vflag =
               if ids = [] then ldirect () else
               if not concrete then lclass_virt () else
               lclass (
-              Lapply (oo_prim "make_class_store",
+              mkappl (oo_prim "make_class_store",
                       [transl_meth_list pub_meths;
                        Lvar class_init; Lvar cached]))),
   make_envs (
-  if ids = [] then Lapply(lfield cached 0, [lenvs]) else
+  if ids = [] then mkappl (lfield cached 0, [lenvs]) else
   Lprim(Pmakeblock(0, Immutable),
         if concrete then
-          [Lapply(lfield cached 0, [lenvs]);
+          [mkappl (lfield cached 0, [lenvs]);
            lfield cached 1;
            lfield cached 0;
            lenvs]

bytecomp/translcore.ml

@@ -569,7 +569,10 @@ and transl_exp0 e =
     && List.for_all (fun (arg,_) -> arg <> None) args ->
       let args, args' = cut p.prim_arity args in
       let wrap f =
-        event_after e (if args' = [] then f else transl_apply f args') in
+        if args' = []
+        then event_after e f
+        else event_after e (transl_apply f args' e.exp_loc)
+      in
       let wrap0 f =
         if args' = [] then f else wrap f in
       let args = List.map (function Some x, _ -> x | _ -> assert false) args in
@@ -594,7 +597,7 @@ and transl_exp0 e =
             if primitive_is_ccall prim then wrap p else wrap0 p
       end
   | Texp_apply(funct, oargs) ->
-      event_after e (transl_apply (transl_exp funct) oargs)
+      event_after e (transl_apply (transl_exp funct) oargs e.exp_loc)
   | Texp_match({exp_desc = Texp_tuple argl}, pat_expr_list, partial) ->
       Matching.for_multiple_match e.exp_loc
         (transl_list argl) (transl_cases pat_expr_list) partial
@@ -705,7 +708,7 @@ and transl_exp0 e =
       in
       event_after e lam
   | Texp_new (cl, _) ->
-      Lapply(Lprim(Pfield 0, [transl_path cl]), [lambda_unit])
+      Lapply(Lprim(Pfield 0, [transl_path cl]), [lambda_unit], Location.none)
   | Texp_instvar(path_self, path) ->
       Lprim(Parrayrefu Paddrarray, [transl_path path_self; transl_path path])
   | Texp_setinstvar(path_self, path, expr) ->
@@ -713,7 +716,8 @@ and transl_exp0 e =
   | Texp_override(path_self, modifs) ->
       let cpy = Ident.create "copy" in
       Llet(Strict, cpy,
-           Lapply(Translobj.oo_prim "copy", [transl_path path_self]),
+           Lapply(Translobj.oo_prim "copy", [transl_path path_self],
+                  Location.none),
            List.fold_right
              (fun (path, expr) rem ->
                 Lsequence(transl_setinstvar (Lvar cpy) path expr, rem))
@@ -748,17 +752,17 @@ and transl_cases pat_expr_list =
 and transl_tupled_cases patl_expr_list =
   List.map (fun (patl, expr) -> (patl, transl_exp expr)) patl_expr_list
 
-and transl_apply lam sargs =
+and transl_apply lam sargs loc =
   let lapply funct args =
     match funct with
       Lsend(k, lmet, lobj, largs) ->
         Lsend(k, lmet, lobj, largs @ args)
     | Levent(Lsend(k, lmet, lobj, largs), _) ->
         Lsend(k, lmet, lobj, largs @ args)
-    | Lapply(lexp, largs) ->
+    | Lapply(lexp, largs, _) ->
-        Lapply(lexp, largs @ args)
+        Lapply(lexp, largs @ args, loc)
     | lexp ->
-        Lapply(lexp, args)
+        Lapply(lexp, args, loc)
   in
   let rec build_apply lam args = function
       (None, optional) :: l ->

bytecomp/translcore.mli

@@ -23,7 +23,8 @@ open Lambda
 val name_pattern: string -> (pattern * 'a) list -> Ident.t
 
 val transl_exp: expression -> lambda
-val transl_apply: lambda -> (expression option * optional) list -> lambda
+val transl_apply: lambda -> (expression option * optional) list
+                  -> Location.t -> lambda
 val transl_let:
       rec_flag -> (pattern * expression) list -> lambda -> lambda
 val transl_primitive: Primitive.description -> lambda

bytecomp/translmod.ml

@@ -47,7 +47,8 @@ let rec apply_coercion restr arg =
       name_lambda arg (fun id ->
         Lfunction(Curried, [param],
           apply_coercion cc_res
-            (Lapply(Lvar id, [apply_coercion cc_arg (Lvar param)]))))
+            (Lapply(Lvar id, [apply_coercion cc_arg (Lvar param)],
+                    Location.none))))
   | Tcoerce_primitive p ->
       transl_primitive p
 
@@ -202,7 +203,7 @@ let eval_rec_bindings bindings cont =
   | (id, None, rhs) :: rem ->
       bind_inits rem
   | (id, Some(loc, shape), rhs) :: rem ->
-      Llet(Strict, id, Lapply(mod_prim "init_mod", [loc; shape]),
+      Llet(Strict, id, Lapply(mod_prim "init_mod", [loc; shape], Location.none),
            bind_inits rem)
   and bind_strict = function
     [] ->
@@ -217,7 +218,8 @@ let eval_rec_bindings bindings cont =
   | (id, None, rhs) :: rem ->
       patch_forwards rem
   | (id, Some(loc, shape), rhs) :: rem ->
-      Lsequence(Lapply(mod_prim "update_mod", [shape; Lvar id; rhs]),
+      Lsequence(Lapply(mod_prim "update_mod", [shape; Lvar id; rhs],
+                       Location.none),
                 patch_forwards rem)
   in
     bind_inits bindings
@@ -258,7 +260,7 @@ let rec transl_module cc rootpath mexp =
       oo_wrap mexp.mod_env true
         (apply_coercion cc)
         (Lapply(transl_module Tcoerce_none None funct,
-                [transl_module ccarg None arg]))
+                [transl_module ccarg None arg], mexp.mod_loc))
   | Tmod_constraint(arg, mty, ccarg) ->
       transl_module (compose_coercions cc ccarg) rootpath arg
 
@@ -556,12 +558,14 @@ let toplevel_name id =
 let toploop_getvalue id =
   Lapply(Lprim(Pfield toploop_getvalue_pos,
                  [Lprim(Pgetglobal toploop_ident, [])]),
-         [Lconst(Const_base(Const_string (toplevel_name id)))])
+         [Lconst(Const_base(Const_string (toplevel_name id)))],
+         Location.none)
 
 let toploop_setvalue id lam =
   Lapply(Lprim(Pfield toploop_setvalue_pos,
                  [Lprim(Pgetglobal toploop_ident, [])]),
-         [Lconst(Const_base(Const_string (toplevel_name id))); lam])
+         [Lconst(Const_base(Const_string (toplevel_name id))); lam],
+         Location.none)
 
 let toploop_setvalue_id id = toploop_setvalue id (Lvar id)
 

driver/compile.ml

@@ -111,12 +111,14 @@ let implementation ppf sourcefile outputprefix =
       ++ print_if ppf Clflags.dump_instr Printinstr.instrlist
       ++ Emitcode.to_file oc modulename;
       Warnings.check_fatal ();
-      Pparse.remove_preprocessed inputfile;
       close_out oc;
+      Pparse.remove_preprocessed inputfile;
+      Stypes.dump (outputprefix ^ ".annot");
     with x ->
       close_out oc;
       remove_file objfile;
       Pparse.remove_preprocessed_if_ast inputfile;
+      Stypes.dump (outputprefix ^ ".annot");
       raise x
   end
 

driver/main.ml

@@ -89,6 +89,7 @@ module Options = Main_args.Make_options (struct
   let set r () = r := true
   let unset r () = r := false
   let _a = set make_archive
+  let _annot = set annotations
   let _c = set compile_only
   let _cc s = c_compiler := s; c_linker := s
   let _cclib s = ccobjs := Misc.rev_split_words s @ !ccobjs
@@ -97,7 +98,6 @@ module Options = Main_args.Make_options (struct
   let _custom = set custom_runtime
   let _dllib s = dllibs := Misc.rev_split_words s @ !dllibs
   let _dllpath s = dllpaths := !dllpaths @ [s]
-  let _dtypes = set save_types
   let _g = set debug
   let _i () = print_types := true; compile_only := true
   let _I s = include_dirs := s :: !include_dirs

driver/main_args.ml

@@ -15,6 +15,7 @@
 module Make_options (F :
    sig
      val _a : unit -> unit
+     val _annot : unit -> unit
      val _c : unit -> unit
      val _cc : string -> unit
      val _cclib : string -> unit
@@ -23,7 +24,6 @@ module Make_options (F :
      val _custom : unit -> unit
      val _dllib : string -> unit
      val _dllpath : string -> unit
-     val _dtypes : unit -> unit
      val _g : unit -> unit
      val _i : unit -> unit
      val _I : string -> unit
@@ -65,6 +65,7 @@ module Make_options (F :
 struct
   let list = [
     "-a", Arg.Unit F._a, " Build a library";
+    "-annot", Arg.Unit F._annot, " Save information in <filename>.annot";
     "-c", Arg.Unit F._c, " Compile only (do not link)";
     "-cc", Arg.String F._cc,
            "<command>  Use <command> as the C compiler and linker";
@@ -78,7 +79,7 @@ struct
            "<lib>  Use the dynamically-loaded library <lib>";
     "-dllpath", Arg.String F._dllpath,
            "<dir>  Add <dir> to the run-time search path for shared libraries";
-    "-dtypes", Arg.Unit F._dtypes, " Save type information in <filename>.annot";
+    "-dtypes", Arg.Unit F._annot, " (deprecated) same as -annot";
      "-for-pack", Arg.String (fun s -> ()),
            "<ident>  Ignored (for compatibility with ocamlopt)";
     "-g", Arg.Unit F._g, " Save debugging information";

driver/main_args.mli

@@ -15,6 +15,7 @@
 module Make_options (F :
     sig
       val _a : unit -> unit
+      val _annot : unit -> unit
       val _c : unit -> unit
       val _cc : string -> unit
       val _cclib : string -> unit
@@ -23,7 +24,6 @@ module Make_options (F :
       val _custom : unit -> unit
       val _dllib : string -> unit
       val _dllpath : string -> unit
-      val _dtypes : unit -> unit
       val _g : unit -> unit
       val _i : unit -> unit
       val _I : string -> unit

driver/optmain.ml

@@ -97,6 +97,8 @@ let main () =
   try
     Arg.parse (Arch.command_line_options @ [
        "-a", Arg.Set make_archive, " Build a library";
+       "-annot", Arg.Set annotations,
+             " Save information in <filename>.annot";
        "-c", Arg.Set compile_only, " Compile only (do not link)";
        "-cc", Arg.String(fun s -> c_compiler := s; c_linker := s),
              "<comp>  Use <comp> as the C compiler and linker";
@@ -109,12 +111,13 @@ let main () =
              " Optimize code size rather than speed";
        "-config", Arg.Unit show_config,
              " print configuration values and exit";
-       "-dtypes", Arg.Set save_types,
+       "-dtypes", Arg.Set annotations,
-             " Save type information in <filename>.annot";
+             " (deprecated) same as -annot";
        "-for-pack", Arg.String (fun s -> for_package := Some s),
              "<ident>  Generate code that can later be `packed' with\n\
          \     ocamlopt -pack -o <ident>.cmx";
-       "-g", Arg.Set debug, " Record debugging information for exception backtrace";
+       "-g", Arg.Set debug,
+             " Record debugging information for exception backtrace";
        "-i", Arg.Unit (fun () -> print_types := true; compile_only := true),
              " Print inferred interface";
        "-I", Arg.String(fun dir -> include_dirs := dir :: !include_dirs),

emacs/caml-types.el

@@ -12,7 +12,7 @@
 
 ;(* $Id$ *)
 
-; An emacs-lisp complement to the "-dtypes" option of ocamlc and ocamlopt.
+; An emacs-lisp complement to the "-annot" option of ocamlc and ocamlopt.
 
 ;; XEmacs compatibility
 
@@ -25,15 +25,15 @@
 
 (defvar caml-types-location-re nil "Regexp to parse *.annot files.
 
-Annotation files *.annot may be generated with the \"-dtypes\" option 
+Annotation files *.annot may be generated with the \"-annot\" option
-of ocamlc and ocamlopt. 
+of ocamlc and ocamlopt.
 
 Their format is:
 
   file ::= block *
   block ::= position <SP> position <LF> annotation *
   position ::= filename <SP> num <SP> num <SP> num
-  annotation ::= keyword open-paren <LF> <SP> <SP> data <LF> close-paren
+  annotation ::= keyword open-paren <LF> <SP> <SP> data <LF> close-paren <LF>
 
   <SP> is a space character (ASCII 0x20)
   <LF> is a line-feed character (ASCII 0x0A)
@@ -52,38 +52,60 @@ Their format is:
 - the char number within the line is the difference between the third
   and second nums.
 
-For the moment, the only possible keyword is \"type\"."
+The current list of keywords is:
+type call ident"
 )
 
 (let* ((caml-types-filename-re "\"\\(\\([^\\\"]\\|\\\\.\\)*\\)\"")
-       (caml-types-number-re "\\([0-9]*\\)")
+       (caml-types-number-re "\\([0-9]*\\)"))
-       (caml-types-position-re
+  (setq caml-types-position-re
         (concat caml-types-filename-re " "
                 caml-types-number-re " "
                 caml-types-number-re " "
-                caml-types-number-re)))
+                caml-types-number-re))
   (setq caml-types-location-re
         (concat "^" caml-types-position-re " " caml-types-position-re)))
 
 (defvar caml-types-expr-ovl (make-overlay 1 1))
-
+(make-face 'caml-types-expr-face)
-(make-face 'caml-types-face)
+(set-face-doc-string 'caml-types-expr-face
-(set-face-doc-string 'caml-types-face
                      "face for hilighting expressions and types")
-(if (not (face-differs-from-default-p 'caml-types-face))
+(if (not (face-differs-from-default-p 'caml-types-expr-face))
-    (set-face-background 'caml-types-face "#88FF44"))
+    (set-face-background 'caml-types-expr-face "#88FF44"))
+(overlay-put caml-types-expr-ovl 'face 'caml-types-expr-face)
 
 (defvar caml-types-typed-ovl (make-overlay 1 1))
-
 (make-face 'caml-types-typed-face)
 (set-face-doc-string 'caml-types-typed-face
                      "face for hilighting typed expressions")
 (if (not (face-differs-from-default-p 'caml-types-typed-face))
     (set-face-background 'caml-types-typed-face "#FF8844"))
-
-(overlay-put caml-types-expr-ovl 'face 'caml-types-face)
 (overlay-put caml-types-typed-ovl 'face 'caml-types-typed-face)
 
+(defvar caml-types-scope-ovl (make-overlay 1 1))
+(make-face 'caml-types-scope-face)
+(set-face-doc-string 'caml-types-scope-face
+                     "face for hilighting variable scopes")
+(if (not (face-differs-from-default-p 'caml-types-scope-face))
+    (set-face-background 'caml-types-scope-face "#BBFFFF"))
+(overlay-put caml-types-scope-ovl 'face 'caml-types-scope-face)
+
+(defvar caml-types-def-ovl (make-overlay 1 1))
+(make-face 'caml-types-def-face)
+(set-face-doc-string 'caml-types-def-face
+                     "face for hilighting binding occurrences")
+(if (not (face-differs-from-default-p 'caml-types-def-face))
+    (set-face-background 'caml-types-def-face "#FF4444"))
+(overlay-put caml-types-def-ovl 'face 'caml-types-def-face)
+
+(defvar caml-types-occ-ovl (make-overlay 1 1))
+(make-face 'caml-types-occ-face)
+(set-face-doc-string 'caml-types-occ-face
+                     "face for hilighting variable occurrences")
+(if (not (face-differs-from-default-p 'caml-types-occ-face))
+    (set-face-background 'caml-types-occ-face "#44FF44"))
+(overlay-put caml-types-occ-ovl 'face 'caml-types-occ-face)
+
 
 (defvar caml-types-annotation-tree nil)
 (defvar caml-types-annotation-date nil)
@@ -130,7 +152,7 @@ See `caml-types-location-re' for annotation file format.
     (caml-types-preprocess type-file)
     (setq caml-types-buffer (get-buffer-create caml-types-buffer-name))
     (let* ((targ-loc (vector target-file target-line target-bol target-cnum))
-           (node (caml-types-find-location targ-loc ()
+           (node (caml-types-find-location targ-loc "type" ()
                                            caml-types-annotation-tree)))
       (cond
        ((null node)
@@ -139,7 +161,7 @@ See `caml-types-location-re' for annotation file format.
        (t
         (let ((left (caml-types-get-pos target-buf (elt node 0)))
               (right (caml-types-get-pos target-buf (elt node 1)))
-              (type (elt node 2)))
+              (type (cdr (assoc "type" (elt node 2)))))
           (move-overlay caml-types-expr-ovl left right target-buf)
           (with-current-buffer caml-types-buffer
             (erase-buffer)
@@ -154,6 +176,153 @@ See `caml-types-location-re' for annotation file format.
       (delete-overlay caml-types-expr-ovl)
       )))
 
+(defun caml-types-show-call (arg)
+  "Show the kind of call at point.
+   The smallest function call that contains point is
+   temporarily highlighted.  Its kind is highlighted in the .annot
+   file and the mark is set to the beginning of the kind.
+   The kind is also displayed in the mini-buffer.
+
+The kind is also displayed in the buffer *caml-types*, which is
+displayed when the command is called with Prefix argument 4. 
+
+See `caml-types-location-re' for annotation file format.
+"
+  (interactive "p")
+  (let* ((target-buf (current-buffer))
+         (target-file (file-name-nondirectory (buffer-file-name)))
+         (target-line (1+ (count-lines (point-min)
+                                       (caml-line-beginning-position))))
+         (target-bol (caml-line-beginning-position))
+         (target-cnum (point))
+         (type-file (concat (file-name-sans-extension (buffer-file-name))
+                            ".annot")))
+    (caml-types-preprocess type-file)
+    (setq caml-types-buffer (get-buffer-create caml-types-buffer-name))
+    (let* ((targ-loc (vector target-file target-line target-bol target-cnum))
+           (node (caml-types-find-location targ-loc "call" ()
+                                           caml-types-annotation-tree)))
+      (cond
+       ((null node)
+         (delete-overlay caml-types-expr-ovl)
+         (message "Point is not within a function call."))
+       (t
+        (let ((left (caml-types-get-pos target-buf (elt node 0)))
+              (right (caml-types-get-pos target-buf (elt node 1)))
+              (kind (cdr (assoc "call" (elt node 2)))))
+          (move-overlay caml-types-expr-ovl left right target-buf)
+          (with-current-buffer caml-types-buffer
+            (erase-buffer)
+            (insert kind)
+            (message (format "%s call" kind)))
+          ))))
+    (if (and (= arg 4)
+             (not (window-live-p (get-buffer-window caml-types-buffer))))
+        (display-buffer caml-types-buffer))
+    (unwind-protect
+        (caml-sit-for 60)
+      (delete-overlay caml-types-expr-ovl)
+      )))
+
+(defun caml-types-show-ident (arg)
+  "Show the kind of call at point.
+   The smallest function call that contains point is
+   temporarily highlighted.  Its kind is highlighted in the .annot
+   file and the mark is set to the beginning of the kind.
+   The kind is also displayed in the mini-buffer.
+
+The kind is also displayed in the buffer *caml-types*, which is
+displayed when the command is called with Prefix argument 4. 
+
+See `caml-types-location-re' for annotation file format.
+"
+  (interactive "p")
+  (let* ((target-buf (current-buffer))
+         (target-file (file-name-nondirectory (buffer-file-name)))
+         (target-line (1+ (count-lines (point-min)
+                                       (caml-line-beginning-position))))
+         (target-bol (caml-line-beginning-position))
+         (target-cnum (point))
+         (type-file (concat (file-name-sans-extension (buffer-file-name))
+                            ".annot")))
+    (caml-types-preprocess type-file)
+    (setq caml-types-buffer (get-buffer-create caml-types-buffer-name))
+    (let* ((targ-loc (vector target-file target-line target-bol target-cnum))
+           (node (caml-types-find-location targ-loc "ident" ()
+                                           caml-types-annotation-tree)))
+      (cond
+       ((null node)
+         (delete-overlay caml-types-expr-ovl)
+         (message "Point is not within an identifier."))
+       (t
+        (let ((left (caml-types-get-pos target-buf (elt node 0)))
+              (right (caml-types-get-pos target-buf (elt node 1)))
+              (kind (cdr (assoc "ident" (elt node 2)))))
+          (move-overlay caml-types-expr-ovl left right target-buf)
+          (let* ((loc-re (concat caml-types-position-re " "
+                                 caml-types-position-re))
+                 (end-re (concat caml-types-position-re " --"))
+                 (def-re (concat "def " loc-re))
+                 (def-end-re (concat "def " end-re))
+                 (internal-re (concat "internal_ref " loc-re))
+                 (external-re "external_ref \\(.*\\)"))
+            (cond
+             ((string-match def-re kind)
+              (let ((l-file (file-name-nondirectory (match-string 1 kind)))
+                    (l-line (string-to-int (match-string 3 kind)))
+                    (l-bol (string-to-int (match-string 4 kind)))
+                    (l-cnum (string-to-int (match-string 5 kind)))
+                    (r-file (file-name-nondirectory (match-string 6 kind)))
+                    (r-line (string-to-int (match-string 8 kind)))
+                    (r-bol (string-to-int (match-string 9 kind)))
+                    (r-cnum (string-to-int (match-string 10 kind))))
+                (let* ((lpos (vector l-file l-line l-bol l-cnum))
+                       (rpos (vector r-file r-line r-bol r-cnum))
+                       (left (caml-types-get-pos target-buf lpos))
+                       (right (caml-types-get-pos target-buf rpos)))
+                  (move-overlay caml-types-scope-ovl left right target-buf))))
+             ((string-match def-end-re kind)
+              (let ((l-file (file-name-nondirectory (match-string 1 kind)))
+                    (l-line (string-to-int (match-string 3 kind)))
+                    (l-bol (string-to-int (match-string 4 kind)))
+                    (l-cnum (string-to-int (match-string 5 kind))))
+                (let* ((lpos (vector l-file l-line l-bol l-cnum))
+                       (left (caml-types-get-pos target-buf lpos))
+                       (right (buffer-size target-buf)))
+                  (move-overlay caml-types-scope-ovl left right target-buf))))
+             ((string-match internal-re kind)
+              (let ((l-file (file-name-nondirectory (match-string 1 kind)))
+                    (l-line (string-to-int (match-string 3 kind)))
+                    (l-bol (string-to-int (match-string 4 kind)))
+                    (l-cnum (string-to-int (match-string 5 kind)))
+                    (r-file (file-name-nondirectory (match-string 6 kind)))
+                    (r-line (string-to-int (match-string 8 kind)))
+                    (r-bol (string-to-int (match-string 9 kind)))
+                    (r-cnum (string-to-int (match-string 10 kind))))
+                (let* ((lpos (vector l-file l-line l-bol l-cnum))
+                       (rpos (vector r-file r-line r-bol r-cnum))
+                       (left (caml-types-get-pos target-buf lpos))
+                       (right (caml-types-get-pos target-buf rpos)))
+                  (move-overlay caml-types-def-ovl left right target-buf)
+                  (message (format "this variable is bound at line %d char %d"
+                                   l-line (- l-cnum l-bol))))))
+             ((string-match external-re kind)
+              (let ((fullname (match-string 1 kind)))
+                (with-current-buffer caml-types-buffer
+                  (erase-buffer)
+                  (insert fullname)
+                  (message (format "external ident: %s" fullname)))))))
+          ))))
+    (if (and (= arg 4)
+             (not (window-live-p (get-buffer-window caml-types-buffer))))
+        (display-buffer caml-types-buffer))
+    (unwind-protect
+        (caml-sit-for 60)
+      (delete-overlay caml-types-expr-ovl)
+      (delete-overlay caml-types-def-ovl)
+      (delete-overlay caml-types-scope-ovl)
+      )))
+
 (defun caml-types-preprocess (type-file)
   (let* ((type-date (nth 5 (file-attributes type-file)))
          (target-file (file-name-nondirectory (buffer-file-name)))
@@ -173,7 +342,7 @@ See `caml-types-location-re' for annotation file format.
         (setq caml-types-annotation-tree tree
               caml-types-annotation-date type-date)
         (kill-buffer type-buf)
-        (message ""))
+        (message "done"))
       )))
 
 (defun caml-types-date< (date1 date2)
@@ -191,18 +360,26 @@ See `caml-types-location-re' for annotation file format.
   (symbol-name (intern elem table)))
 
 
+(defun next-annotation ()
+  (forward-char 1)
+  (if (re-search-forward "^[a-z\"]" () t)
+      (forward-char -1)
+    (goto-char (point-max)))
+  (looking-at "[a-z]")
+)
+
 ; tree of intervals
 ; each node is a vector
-; [ pos-left pos-right type-info child child child... ]
+; [ pos-left pos-right annotation child child child... ]
-; type-info =
+; annotation is a list of:
-;  () if this node does not correspond to an annotated interval
+;   (kind . info) where kind = "type" "call" etc.
-;  (type-start . type-end)  address of the annotation in the .annot file
+;                 and info = the contents of the annotation
 
 (defun caml-types-build-tree (target-file)
   (let ((stack ())
         (accu ())
         (table (caml-types-make-hash-table))
-        (type-info ()))
+        (annotation ()))
     (while (re-search-forward caml-types-location-re () t)
       (let ((l-file (file-name-nondirectory (match-string 1)))
             (l-line (string-to-int (match-string 3)))
@@ -213,14 +390,13 @@ See `caml-types-location-re' for annotation file format.
             (r-bol (string-to-int (match-string 9)))
             (r-cnum (string-to-int (match-string 10))))
         (unless (caml-types-not-in-file l-file r-file target-file)
-          (while (and (re-search-forward "^" () t)
+          (setq annotation ())
-                      (not (looking-at "type"))
+          (while (next-annotation)
-                      (not (looking-at "\\\"")))
+            (cond ((looking-at
-            (forward-char 1))
+                    "^\\([a-z]+\\)(\n  \\(\\([^\n)]\\|.)\\|\n[^)]\\)*\\)\n)")
-          (setq type-info
+                   (let ((kind (caml-types-hcons (match-string 1) table))
-                (if (looking-at
+                         (info (caml-types-hcons (match-string 2) table)))
-                     "^type(\n\\(  \\([^\n)]\\|.)\\|\n[^)]\\)*\\)\n)")
+                     (setq annotation (cons (cons kind info) annotation))))))
-                    (caml-types-hcons (match-string 1) table)))
           (setq accu ())
           (while (and stack
                       (caml-types-pos-contains l-cnum r-cnum (car stack)))
@@ -228,7 +404,7 @@ See `caml-types-location-re' for annotation file format.
             (setq stack (cdr stack)))
           (let* ((left-pos (vector l-file l-line l-bol l-cnum))
                  (right-pos (vector r-file r-line r-bol r-cnum))
-                 (node (caml-types-make-node left-pos right-pos type-info
+                 (node (caml-types-make-node left-pos right-pos annotation
                                              accu)))
             (setq stack (cons node stack))))))
     (if (null stack)
@@ -245,12 +421,12 @@ See `caml-types-location-re' for annotation file format.
       (and (not (string= r-file target-file))
            (not (string= r-file "")))))
 
-(defun caml-types-make-node (left-pos right-pos type-info children)
+(defun caml-types-make-node (left-pos right-pos annotation children)
   (let ((result (make-vector (+ 3 (length children)) ()))
         (i 3))
     (aset result 0 left-pos)
     (aset result 1 right-pos)
-    (aset result 2 type-info)
+    (aset result 2 annotation)
     (while children
       (aset result i (car children))
       (setq children (cdr children))
@@ -261,15 +437,15 @@ See `caml-types-location-re' for annotation file format.
   (and (<= l-cnum (elt (elt node 0) 3))
        (>= r-cnum (elt (elt node 1) 3))))
 
-(defun caml-types-find-location (targ-pos curr node)
+(defun caml-types-find-location (targ-pos kind curr node)
   (if (not (caml-types-pos-inside targ-pos node))
       curr
-    (if (elt node 2)
+    (if (and (elt node 2) (assoc kind (elt node 2)))
         (setq curr node))
     (let ((i (caml-types-search node targ-pos)))
       (if (and (> i 3)
                (caml-types-pos-inside targ-pos (elt node (1- i))))
-          (caml-types-find-location targ-pos curr (elt node (1- i)))
+          (caml-types-find-location targ-pos kind curr (elt node (1- i)))
         curr))))
 
 ; trouve le premier fils qui commence apres la position
@@ -377,7 +553,7 @@ See `caml-types-location-re' for annotation file format.
      (with-current-buffer buf (toggle-read-only 1))
      )
    (t
-    (error "No annotation file. You should compile with option \"-dtypes\"."))
+    (error "No annotation file. You should compile with option \"-annot\"."))
     )
   buf))
 
@@ -494,7 +670,7 @@ The function uses two overlays.
                            target-pos
                            (vector target-file target-line target-bol cnum))
                      (save-excursion
-                       (setq node (caml-types-find-location
+                       (setq node (caml-types-find-location "type"
                                    target-pos () target-tree))
                        (set-buffer caml-types-buffer)
                        (erase-buffer)
@@ -567,7 +743,7 @@ The function uses two overlays.
 (defun caml-types-version ()
   "internal version number of caml-types.el"
   (interactive)
-  (message "2")
+  (message "3")
 )
 
 (provide 'caml-types)

emacs/caml.el

@@ -297,6 +297,8 @@ have caml-electric-indent on, which see.")
 
   ;; caml-types
   (define-key caml-mode-map [?\C-c?\C-t] 'caml-types-show-type)
+  (define-key caml-mode-map [?\C-c?\C-s] 'caml-types-show-call)
+  (define-key caml-mode-map [?\C-c?\C-i] 'caml-types-show-ident)
   ;; must be a mouse-down event. Can be any button and any prefix
   (define-key caml-mode-map [?\C-c down-mouse-1] 'caml-types-explore)
   ;; caml-help

otherlibs/labltk/browser/.depend

@@ -1,19 +1,19 @@
-editor.cmo: fileselect.cmi jg_bind.cmi jg_button.cmo jg_menu.cmo \
+editor.cmo: viewer.cmi typecheck.cmi shell.cmi setpath.cmi searchpos.cmi \
-    jg_message.cmi jg_text.cmi jg_tk.cmo jg_toplevel.cmo lexical.cmi \
+    searchid.cmi mytypes.cmi lexical.cmi jg_toplevel.cmo jg_tk.cmo \
-    mytypes.cmi searchid.cmi searchpos.cmi setpath.cmi shell.cmi \
+    jg_text.cmi jg_message.cmi jg_menu.cmo jg_button.cmo jg_bind.cmi \
-    typecheck.cmi viewer.cmi editor.cmi 
+    fileselect.cmi editor.cmi 
-editor.cmx: fileselect.cmx jg_bind.cmx jg_button.cmx jg_menu.cmx \
+editor.cmx: viewer.cmx typecheck.cmx shell.cmx setpath.cmx searchpos.cmx \
-    jg_message.cmx jg_text.cmx jg_tk.cmx jg_toplevel.cmx lexical.cmx \
+    searchid.cmx mytypes.cmi lexical.cmx jg_toplevel.cmx jg_tk.cmx \
-    mytypes.cmi searchid.cmx searchpos.cmx setpath.cmx shell.cmx \
+    jg_text.cmx jg_message.cmx jg_menu.cmx jg_button.cmx jg_bind.cmx \
-    typecheck.cmx viewer.cmx editor.cmi 
+    fileselect.cmx editor.cmi 
-fileselect.cmo: jg_box.cmo jg_entry.cmo jg_memo.cmi jg_toplevel.cmo list2.cmo \
+fileselect.cmo: useunix.cmi setpath.cmi list2.cmo jg_toplevel.cmo jg_memo.cmi \
-    setpath.cmi useunix.cmi fileselect.cmi 
+    jg_entry.cmo jg_box.cmo fileselect.cmi 
-fileselect.cmx: jg_box.cmx jg_entry.cmx jg_memo.cmx jg_toplevel.cmx list2.cmx \
+fileselect.cmx: useunix.cmx setpath.cmx list2.cmx jg_toplevel.cmx jg_memo.cmx \
-    setpath.cmx useunix.cmx fileselect.cmi 
+    jg_entry.cmx jg_box.cmx fileselect.cmi 
 jg_bind.cmo: jg_bind.cmi 
 jg_bind.cmx: jg_bind.cmi 
-jg_box.cmo: jg_bind.cmi jg_completion.cmi 
+jg_box.cmo: jg_completion.cmi jg_bind.cmi 
-jg_box.cmx: jg_bind.cmx jg_completion.cmx 
+jg_box.cmx: jg_completion.cmx jg_bind.cmx 
 jg_completion.cmo: jg_completion.cmi 
 jg_completion.cmx: jg_completion.cmi 
 jg_config.cmo: jg_tk.cmo jg_config.cmi 
@@ -22,45 +22,45 @@ jg_entry.cmo: jg_bind.cmi
 jg_entry.cmx: jg_bind.cmx 
 jg_memo.cmo: jg_memo.cmi 
 jg_memo.cmx: jg_memo.cmi 
-jg_message.cmo: jg_bind.cmi jg_text.cmi jg_tk.cmo jg_toplevel.cmo \
+jg_message.cmo: jg_toplevel.cmo jg_tk.cmo jg_text.cmi jg_bind.cmi \
     jg_message.cmi 
-jg_message.cmx: jg_bind.cmx jg_text.cmx jg_tk.cmx jg_toplevel.cmx \
+jg_message.cmx: jg_toplevel.cmx jg_tk.cmx jg_text.cmx jg_bind.cmx \
     jg_message.cmi 
-jg_multibox.cmo: jg_bind.cmi jg_completion.cmi jg_multibox.cmi 
+jg_multibox.cmo: jg_completion.cmi jg_bind.cmi jg_multibox.cmi 
-jg_multibox.cmx: jg_bind.cmx jg_completion.cmx jg_multibox.cmi 
+jg_multibox.cmx: jg_completion.cmx jg_bind.cmx jg_multibox.cmi 
-jg_text.cmo: jg_bind.cmi jg_button.cmo jg_tk.cmo jg_toplevel.cmo jg_text.cmi 
+jg_text.cmo: jg_toplevel.cmo jg_tk.cmo jg_button.cmo jg_bind.cmi jg_text.cmi 
-jg_text.cmx: jg_bind.cmx jg_button.cmx jg_tk.cmx jg_toplevel.cmx jg_text.cmi 
+jg_text.cmx: jg_toplevel.cmx jg_tk.cmx jg_button.cmx jg_bind.cmx jg_text.cmi 
 lexical.cmo: jg_tk.cmo lexical.cmi 
 lexical.cmx: jg_tk.cmx lexical.cmi 
-main.cmo: editor.cmi jg_config.cmi searchid.cmi searchpos.cmi shell.cmi \
+main.cmo: viewer.cmi shell.cmi searchpos.cmi searchid.cmi jg_config.cmi \
-    viewer.cmi 
+    editor.cmi 
-main.cmx: editor.cmx jg_config.cmx searchid.cmx searchpos.cmx shell.cmx \
+main.cmx: viewer.cmx shell.cmx searchpos.cmx searchid.cmx jg_config.cmx \
-    viewer.cmx 
+    editor.cmx 
 searchid.cmo: list2.cmo searchid.cmi 
 searchid.cmx: list2.cmx searchid.cmi 
-searchpos.cmo: jg_bind.cmi jg_memo.cmi jg_message.cmi jg_text.cmi jg_tk.cmo \
+searchpos.cmo: searchid.cmi lexical.cmi jg_tk.cmo jg_text.cmi jg_message.cmi \
-    lexical.cmi searchid.cmi searchpos.cmi 
+    jg_memo.cmi jg_bind.cmi searchpos.cmi 
-searchpos.cmx: jg_bind.cmx jg_memo.cmx jg_message.cmx jg_text.cmx jg_tk.cmx \
+searchpos.cmx: searchid.cmx lexical.cmx jg_tk.cmx jg_text.cmx jg_message.cmx \
-    lexical.cmx searchid.cmx searchpos.cmi 
+    jg_memo.cmx jg_bind.cmx searchpos.cmi 
-setpath.cmo: jg_bind.cmi jg_box.cmo jg_button.cmo jg_toplevel.cmo list2.cmo \
+setpath.cmo: useunix.cmi list2.cmo jg_toplevel.cmo jg_button.cmo jg_box.cmo \
-    useunix.cmi setpath.cmi 
+    jg_bind.cmi setpath.cmi 
-setpath.cmx: jg_bind.cmx jg_box.cmx jg_button.cmx jg_toplevel.cmx list2.cmx \
+setpath.cmx: useunix.cmx list2.cmx jg_toplevel.cmx jg_button.cmx jg_box.cmx \
-    useunix.cmx setpath.cmi 
+    jg_bind.cmx setpath.cmi 
-shell.cmo: dummy.cmi fileselect.cmi jg_memo.cmi jg_menu.cmo jg_message.cmi \
+shell.cmo: list2.cmo lexical.cmi jg_toplevel.cmo jg_tk.cmo jg_text.cmi \
-    jg_text.cmi jg_tk.cmo jg_toplevel.cmo lexical.cmi list2.cmo shell.cmi 
+    jg_message.cmi jg_menu.cmo jg_memo.cmi fileselect.cmi dummy.cmi shell.cmi 
-shell.cmx: dummy.cmi fileselect.cmx jg_memo.cmx jg_menu.cmx jg_message.cmx \
+shell.cmx: list2.cmx lexical.cmx jg_toplevel.cmx jg_tk.cmx jg_text.cmx \
-    jg_text.cmx jg_tk.cmx jg_toplevel.cmx lexical.cmx list2.cmx shell.cmi 
+    jg_message.cmx jg_menu.cmx jg_memo.cmx fileselect.cmx dummy.cmi shell.cmi 
-typecheck.cmo: jg_message.cmi jg_text.cmi jg_tk.cmo mytypes.cmi typecheck.cmi 
+typecheck.cmo: mytypes.cmi jg_tk.cmo jg_text.cmi jg_message.cmi typecheck.cmi 
-typecheck.cmx: jg_message.cmx jg_text.cmx jg_tk.cmx mytypes.cmi typecheck.cmi 
+typecheck.cmx: mytypes.cmi jg_tk.cmx jg_text.cmx jg_message.cmx typecheck.cmi 
 useunix.cmo: useunix.cmi 
 useunix.cmx: useunix.cmi 
-viewer.cmo: help.cmo jg_bind.cmi jg_box.cmo jg_button.cmo jg_completion.cmi \
+viewer.cmo: useunix.cmi shell.cmi setpath.cmi searchpos.cmi searchid.cmi \
-    jg_entry.cmo jg_menu.cmo jg_message.cmi jg_multibox.cmi jg_text.cmi \
+    mytypes.cmi jg_toplevel.cmo jg_tk.cmo jg_text.cmi jg_multibox.cmi \
-    jg_tk.cmo jg_toplevel.cmo mytypes.cmi searchid.cmi searchpos.cmi \
+    jg_message.cmi jg_menu.cmo jg_entry.cmo jg_completion.cmi jg_button.cmo \
-    setpath.cmi shell.cmi useunix.cmi viewer.cmi 
+    jg_box.cmo jg_bind.cmi help.cmo viewer.cmi 
-viewer.cmx: help.cmx jg_bind.cmx jg_box.cmx jg_button.cmx jg_completion.cmx \
+viewer.cmx: useunix.cmx shell.cmx setpath.cmx searchpos.cmx searchid.cmx \
-    jg_entry.cmx jg_menu.cmx jg_message.cmx jg_multibox.cmx jg_text.cmx \
+    mytypes.cmi jg_toplevel.cmx jg_tk.cmx jg_text.cmx jg_multibox.cmx \
-    jg_tk.cmx jg_toplevel.cmx mytypes.cmi searchid.cmx searchpos.cmx \
+    jg_message.cmx jg_menu.cmx jg_entry.cmx jg_completion.cmx jg_button.cmx \
-    setpath.cmx shell.cmx useunix.cmx viewer.cmi 
+    jg_box.cmx jg_bind.cmx help.cmx viewer.cmi 
 mytypes.cmi: shell.cmi 
 typecheck.cmi: mytypes.cmi 

otherlibs/labltk/browser/Makefile

@@ -60,5 +60,6 @@ dummy.mli:
 	ln -s dummyUnix.mli $@
 shell.cmo: dummy.cmi
 setpath.cmo fileselect.cmo lexical.cmi searchid.cmi typecheck.cmi: $(TOPDIR)/toplevel/toplevellib.cma
+mytypes.cmi searchpos.cmi searchpos.cmo typecheck.cmo: $(TOPDIR)/typing/stypes.cmi
 
 include	.depend

otherlibs/labltk/browser/mytypes.mli

@@ -23,7 +23,7 @@ type edit_window =
     modified: Textvariable.textVariable;
     mutable shell: (string * Shell.shell) option;
     mutable structure: Typedtree.structure;
-    mutable type_info: Stypes.type_info list;
+    mutable type_info: Stypes.annotation list;
     mutable signature: Types.signature;
     mutable psignature: Parsetree.signature;
     number: string }

otherlibs/labltk/browser/searchpos.ml

@@ -871,6 +871,7 @@ let search_pos_ti ~pos = function
   | Ti_expr e  -> search_pos_expr ~pos e
   | Ti_class c -> search_pos_class_expr ~pos c
   | Ti_mod m   -> search_pos_module_expr ~pos m
+  | _ -> ()
 
 let rec search_pos_info ~pos = function
     [] -> []

otherlibs/labltk/browser/searchpos.mli

@@ -67,7 +67,7 @@ val search_pos_structure :
     pos:int -> Typedtree.structure_item list ->
     (fkind * Env.t * Location.t) list
 val search_pos_info :
-    pos:int -> Stypes.type_info list -> (fkind * Env.t * Location.t) list
+    pos:int -> Stypes.annotation list -> (fkind * Env.t * Location.t) list
 val view_type : fkind -> env:Env.t -> unit
 val view_type_menu : fkind -> env:Env.t -> parent:'a widget -> menu widget
 

otherlibs/labltk/browser/typecheck.ml

@@ -92,7 +92,7 @@ let f txt =
   txt.signature <- [];
   txt.psignature <- [];
   ignore (Stypes.get_info ());
-  Clflags.save_types := true;
+  Clflags.annotations := true;
 
   begin try
 
@@ -109,7 +109,7 @@ let f txt =
     List.iter psl ~f:
     begin function
       Ptop_def pstr ->
-        let str, sign, env' = Typemod.type_structure !env pstr in
+        let str, sign, env' = Typemod.type_structure !env pstr Location.none in
         txt.structure <- txt.structure @ str;
         txt.signature <- txt.signature @ sign;
         env := env'

tools/ocamlcp.ml

@@ -43,6 +43,7 @@ let incompatible o =
 
 module Options = Main_args.Make_options (struct
   let _a () = make_archive := true; option "-a" ()
+  let _annot = option "-annot"
   let _c = option "-c"
   let _cc s = option_with_arg "-cc" s
   let _cclib s = option_with_arg "-cclib" s

toplevel/toploop.ml

@@ -218,7 +218,8 @@ let execute_phrase print_outcome ppf phr =
       let oldenv = !toplevel_env in
       let _ = Unused_var.warn ppf sstr in
       Typecore.reset_delayed_checks ();
-      let (str, sg, newenv) = Typemod.type_structure oldenv sstr in
+      let (str, sg, newenv) = Typemod.type_structure oldenv sstr Location.none
+      in
       Typecore.force_delayed_checks ();
       let lam = Translmod.transl_toplevel_definition str in
       Warnings.check_fatal ();

typing/annot.mli

@@ -0,0 +1,23 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*          Damien Doligez, projet Gallium, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 2007 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(* Data types for annotations (Stypes.ml) *)
+
+type call = Tail | Stack | Inline;;
+
+type ident =
+  | Iref_internal of Location.t (* defining occurrence *)
+  | Iref_external of string     (* fully qualified name *)
+  | Idef of Location.t          (* scope *)
+;;

typing/env.ml

@@ -44,6 +44,7 @@ type summary =
 
 type t = {
   values: (Path.t * value_description) Ident.tbl;
+  annotations: (Path.t * Annot.ident) Ident.tbl;
   constrs: constructor_description Ident.tbl;
   labels: label_description Ident.tbl;
   types: (Path.t * type_declaration) Ident.tbl;
@@ -63,6 +64,7 @@ and module_components_repr =
 
 and structure_components = {
   mutable comp_values: (string, (value_description * int)) Tbl.t;
+  mutable comp_annotations: (string, (Annot.ident * int)) Tbl.t;
   mutable comp_constrs: (string, (constructor_description * int)) Tbl.t;
   mutable comp_labels: (string, (label_description * int)) Tbl.t;
   mutable comp_types: (string, (type_declaration * int)) Tbl.t;
@@ -83,7 +85,7 @@ and functor_components = {
 }
 
 let empty = {
-  values = Ident.empty; constrs = Ident.empty;
+  values = Ident.empty; annotations = Ident.empty; constrs = Ident.empty;
   labels = Ident.empty; types = Ident.empty;
   modules = Ident.empty; modtypes = Ident.empty;
   components = Ident.empty; classes = Ident.empty;
@@ -388,6 +390,13 @@ let lookup_simple proj1 proj2 lid env =
 
 let lookup_value =
   lookup (fun env -> env.values) (fun sc -> sc.comp_values)
+let lookup_annot id e =
+  let (path, annot) =
+    lookup (fun env -> env.annotations) (fun sc -> sc.comp_annotations) id e
+  in
+  match annot with
+  | Annot.Iref_external "" -> (path, Annot.Iref_external (Path.name path))
+  | _ -> (path, annot)
 and lookup_constructor =
   lookup_simple (fun env -> env.constrs) (fun sc -> sc.comp_constrs)
 and lookup_label =
@@ -478,7 +487,8 @@ let rec components_of_module env sub path mty =
   lazy(match scrape_modtype mty env with
     Tmty_signature sg ->
       let c =
-        { comp_values = Tbl.empty; comp_constrs = Tbl.empty;
+        { comp_values = Tbl.empty; comp_annotations = Tbl.empty;
+          comp_constrs = Tbl.empty;
           comp_labels = Tbl.empty; comp_types = Tbl.empty;
           comp_modules = Tbl.empty; comp_modtypes = Tbl.empty;
           comp_components = Tbl.empty; comp_classes = Tbl.empty;
@@ -492,6 +502,11 @@ let rec components_of_module env sub path mty =
             let decl' = Subst.value_description sub decl in
             c.comp_values <-
               Tbl.add (Ident.name id) (decl', !pos) c.comp_values;
+            if !Clflags.annotations then begin
+              c.comp_annotations <-
+                Tbl.add (Ident.name id) (Annot.Iref_external "", !pos)
+                        c.comp_annotations;
+            end;
             begin match decl.val_kind with
               Val_prim _ -> () | _ -> incr pos
             end
@@ -552,7 +567,8 @@ let rec components_of_module env sub path mty =
           fcomp_cache = Hashtbl.create 17 }
   | Tmty_ident p ->
         Structure_comps {
-          comp_values = Tbl.empty; comp_constrs = Tbl.empty;
+          comp_values = Tbl.empty; comp_annotations = Tbl.empty;
+          comp_constrs = Tbl.empty;
           comp_labels = Tbl.empty; comp_types = Tbl.empty;
           comp_modules = Tbl.empty; comp_modtypes = Tbl.empty;
           comp_components = Tbl.empty; comp_classes = Tbl.empty;
@@ -565,6 +581,12 @@ and store_value id path decl env =
     values = Ident.add id (path, decl) env.values;
     summary = Env_value(env.summary, id, decl) }
 
+and store_annot id path annot env =
+  if !Clflags.annotations then
+    { env with
+      annotations = Ident.add id (path, annot) env.annotations }
+  else env
+
 and store_type id path info env =
   { env with
     constrs =
@@ -645,6 +667,9 @@ let _ =
 let add_value id desc env =
   store_value id (Pident id) desc env
 
+let add_annot id annot env =
+  store_annot id (Pident id) annot env
+
 and add_type id info env =
   store_type id (Pident id) info env
 
@@ -704,8 +729,9 @@ let open_signature root sg env =
       (fun env item p ->
         match item with
           Tsig_value(id, decl) ->
-            store_value (Ident.hide id) p
+            let e1 = store_value (Ident.hide id) p
                         (Subst.value_description sub decl) env
+            in store_annot (Ident.hide id) p (Annot.Iref_external "") e1
         | Tsig_type(id, decl, _) ->
             store_type (Ident.hide id) p
                        (Subst.type_declaration sub decl) env

typing/env.mli

@@ -37,6 +37,7 @@ val find_modtype_expansion: Path.t -> t -> Types.module_type
 (* Lookup by long identifiers *)
 
 val lookup_value: Longident.t -> t -> Path.t * value_description
+val lookup_annot: Longident.t -> t -> Path.t * Annot.ident
 val lookup_constructor: Longident.t -> t -> constructor_description
 val lookup_label: Longident.t -> t -> label_description
 val lookup_type: Longident.t -> t -> Path.t * type_declaration
@@ -48,6 +49,7 @@ val lookup_cltype: Longident.t -> t -> Path.t * cltype_declaration
 (* Insertion by identifier *)
 
 val add_value: Ident.t -> value_description -> t -> t
+val add_annot: Ident.t -> Annot.ident -> t -> t
 val add_type: Ident.t -> type_declaration -> t -> t
 val add_exception: Ident.t -> exception_declaration -> t -> t
 val add_module: Ident.t -> module_type -> t -> t

typing/stypes.ml

@@ -21,16 +21,19 @@
   interesting in case of errors.
 *)
 
+open Annot;;
 open Format;;
 open Lexing;;
 open Location;;
 open Typedtree;;
 
-type type_info =
+type annotation =
-    Ti_pat   of pattern
+  | Ti_pat   of pattern
   | Ti_expr  of expression
   | Ti_class of class_expr
   | Ti_mod   of module_expr
+  | An_call of Location.t * Annot.call
+  | An_ident of Location.t * Annot.ident
 ;;
 
 let get_location ti =
@@ -39,18 +42,20 @@ let get_location ti =
   | Ti_expr e  -> e.exp_loc
   | Ti_class c -> c.cl_loc
   | Ti_mod m   -> m.mod_loc
+  | An_call (l, k) -> l
+  | An_ident (l, k) -> l
 ;;
 
-let type_info = ref ([] : type_info list);;
+let annotations = ref ([] : annotation list);;
 let phrases = ref ([] : Location.t list);;
 
 let record ti =
-  if !Clflags.save_types && not (get_location ti).Location.loc_ghost then
+  if !Clflags.annotations && not (get_location ti).Location.loc_ghost then
-    type_info := ti :: !type_info
+    annotations := ti :: !annotations
 ;;
 
 let record_phrase loc =
-  if !Clflags.save_types then phrases := loc :: !phrases;
+  if !Clflags.annotations then phrases := loc :: !phrases;
 ;;
 
 (* comparison order:
@@ -67,7 +72,17 @@ let cmp_ti_inner_first ti1 ti2 =
 ;;
 
 let print_position pp pos =
-  fprintf pp "%S %d %d %d" pos.pos_fname pos.pos_lnum pos.pos_bol pos.pos_cnum;
+  if pos = dummy_pos then
+    fprintf pp "--"
+  else
+    fprintf pp "%S %d %d %d" pos.pos_fname pos.pos_lnum pos.pos_bol
+                             pos.pos_cnum;
+;;
+
+let print_location pp loc =
+  print_position pp loc.loc_start;
+  fprintf pp " ";
+  print_position pp loc.loc_end;
 ;;
 
 let sort_filter_phrases () =
@@ -93,38 +108,60 @@ let rec printtyp_reset_maybe loc =
   | _ -> ()
 ;;
 
+let call_kind_string k =
+  match k with
+  | Tail -> "tail"
+  | Stack -> "stack"
+  | Inline -> "inline"
+;;
+
+let print_ident_annot pp k =
+  match k with
+  | Idef l -> fprintf pp "def %a@." print_location l;
+  | Iref_internal l -> fprintf pp "internal_ref %a@." print_location l;
+  | Iref_external s -> fprintf pp "external_ref %s@." s;
+;;
 
 (* The format of the annotation file is documented in emacs/caml-types.el. *)
 
-let print_info pp ti =
+let print_info pp prev_loc ti =
   match ti with
-  | Ti_class _ | Ti_mod _ -> ()
+  | Ti_class _ | Ti_mod _ -> prev_loc
   | Ti_pat  {pat_loc = loc; pat_type = typ}
   | Ti_expr {exp_loc = loc; exp_type = typ} ->
-      print_position pp loc.loc_start;
+      if loc <> prev_loc then fprintf pp "%a@." print_location loc;
-      fprintf pp " ";
+      fprintf pp "type(@.  ";
-      print_position pp loc.loc_end;
-      fprintf pp "@.type(@.  ";
       printtyp_reset_maybe loc;
       Printtyp.mark_loops typ;
       Printtyp.type_sch pp typ;
       fprintf pp "@.)@.";
+      loc
+  | An_call (loc, k) ->
+      if loc <> prev_loc then fprintf pp "%a@." print_location loc;
+      fprintf pp "call(@.  %s@.)@." (call_kind_string k);
+      loc
+  | An_ident (loc, k) ->
+      if loc <> prev_loc then fprintf pp "%a@." print_location loc;
+      fprintf pp "ident(@.  ";
+      print_ident_annot pp k;
+      fprintf pp ")@.";
+      loc
 ;;
 
 let get_info () =
-  let info = List.fast_sort cmp_ti_inner_first !type_info in
+  let info = List.fast_sort cmp_ti_inner_first !annotations in
-  type_info := [];
+  annotations := [];
   info
 ;;
 
 let dump filename =
-  if !Clflags.save_types then begin
+  if !Clflags.annotations then begin
     let info = get_info () in
     let pp = formatter_of_out_channel (open_out filename) in
     sort_filter_phrases ();
-    List.iter (print_info pp) info;
+    ignore (List.fold_left (print_info pp) Location.none info);
     phrases := [];
   end else begin
-    type_info := [];
+    annotations := [];
   end;
 ;;

typing/stypes.mli

@@ -18,16 +18,18 @@
 
 open Typedtree;;
 
-type type_info =
+type annotation =
-    Ti_pat   of pattern
+  | Ti_pat   of pattern
   | Ti_expr  of expression
   | Ti_class of class_expr
   | Ti_mod   of module_expr
+  | An_call of Location.t * Annot.call
+  | An_ident of Location.t * Annot.ident
 ;;
 
-val record : type_info -> unit;;
+val record : annotation -> unit;;
 val record_phrase : Location.t -> unit;;
 val dump : string -> unit;;
 
-val get_location : type_info -> Location.t;;
+val get_location : annotation -> Location.t;;
-val get_info : unit -> type_info list;;
+val get_info : unit -> annotation list;;

typing/typeclass.ml

@@ -561,7 +561,7 @@ let rec class_field cl_num self_type meths vars
   | Pcf_let (rec_flag, sdefs, loc) ->
       let (defs, val_env) =
         try
-          Typecore.type_let val_env rec_flag sdefs
+          Typecore.type_let val_env rec_flag sdefs None
         with Ctype.Unify [(ty, _)] ->
           raise(Error(loc, Make_nongen_seltype ty))
       in
@@ -910,7 +910,7 @@ and class_expr cl_num val_env met_env scl =
   | Pcl_let (rec_flag, sdefs, scl') ->
       let (defs, val_env) =
         try
-          Typecore.type_let val_env rec_flag sdefs
+          Typecore.type_let val_env rec_flag sdefs None
         with Ctype.Unify [(ty, _)] ->
           raise(Error(scl.pcl_loc, Make_nongen_seltype ty))
       in

typing/typecore.ml

@@ -188,22 +188,29 @@ let has_variants p =
 
 
 (* pattern environment *)
-let pattern_variables = ref ([]: (Ident.t * type_expr) list)
+let pattern_variables = ref ([]: (Ident.t * type_expr * Location.t) list)
 let pattern_force = ref ([] : (unit -> unit) list)
-let reset_pattern () =
+let pattern_scope = ref (None : Annot.ident option);;
+let reset_pattern scope =
   pattern_variables := [];
-  pattern_force := []
+  pattern_force := [];
+  pattern_scope := scope;
+;;
 
 let enter_variable loc name ty =
-  if List.exists (fun (id, _) -> Ident.name id = name) !pattern_variables
+  if List.exists (fun (id, _, _) -> Ident.name id = name) !pattern_variables
   then raise(Error(loc, Multiply_bound_variable));
   let id = Ident.create name in
-  pattern_variables := (id, ty) :: !pattern_variables;
+  pattern_variables := (id, ty, loc) :: !pattern_variables;
+  begin match !pattern_scope with
+  | None -> ()
+  | Some s -> Stypes.record (Stypes.An_ident (loc, s));
+  end;
   id
 
 let sort_pattern_variables vs =
   List.sort
-    (fun (x,_) (y,_) -> Pervasives.compare (Ident.name x) (Ident.name y))
+    (fun (x,_,_) (y,_,_) -> Pervasives.compare (Ident.name x) (Ident.name y))
     vs
 
 let enter_orpat_variables loc env  p1_vs p2_vs =
@@ -213,7 +220,7 @@ let enter_orpat_variables loc env  p1_vs p2_vs =
   and p2_vs = sort_pattern_variables p2_vs in
 
   let rec unify_vars p1_vs p2_vs = match p1_vs, p2_vs with
-      | (x1,t1)::rem1, (x2,t2)::rem2 when Ident.equal x1 x2 ->
+      | (x1,t1,l1)::rem1, (x2,t2,l2)::rem2 when Ident.equal x1 x2 ->
           if x1==x2 then
             unify_vars rem1 rem2
           else begin
@@ -226,9 +233,9 @@ let enter_orpat_variables loc env  p1_vs p2_vs =
           (x2,x1)::unify_vars rem1 rem2
           end
       | [],[] -> []
-      | (x,_)::_, [] -> raise (Error (loc, Orpat_vars x))
+      | (x,_,_)::_, [] -> raise (Error (loc, Orpat_vars x))
-      | [],(x,_)::_  -> raise (Error (loc, Orpat_vars x))
+      | [],(x,_,_)::_  -> raise (Error (loc, Orpat_vars x))
-      | (x,_)::_, (y,_)::_ ->
+      | (x,_,_)::_, (y,_,_)::_ ->
           let min_var =
             if Ident.name x < Ident.name y then x
             else y in
@@ -517,24 +524,26 @@ let get_ref r =
 let add_pattern_variables env =
   let pv = get_ref pattern_variables in
   List.fold_right
-    (fun (id, ty) env ->
+    (fun (id, ty, loc) env ->
-       Env.add_value id {val_type = ty; val_kind = Val_reg} env)
+       let e1 = Env.add_value id {val_type = ty; val_kind = Val_reg} env in
+       Env.add_annot id (Annot.Iref_internal loc) e1;
+    )
     pv env
 
-let type_pattern env spat =
+let type_pattern env spat scope =
-  reset_pattern ();
+  reset_pattern scope;
   let pat = type_pat env spat in
   let new_env = add_pattern_variables env in
   (pat, new_env, get_ref pattern_force)
 
-let type_pattern_list env spatl =
+let type_pattern_list env spatl scope =
-  reset_pattern ();
+  reset_pattern scope;
   let patl = List.map (type_pat env) spatl in
   let new_env = add_pattern_variables env in
   (patl, new_env, get_ref pattern_force)
 
 let type_class_arg_pattern cl_num val_env met_env l spat =
-  reset_pattern ();
+  reset_pattern None;
   let pat = type_pat val_env spat in
   if has_variants pat then begin
     Parmatch.pressure_variants val_env [pat];
@@ -544,7 +553,7 @@ let type_class_arg_pattern cl_num val_env met_env l spat =
   if is_optional l then unify_pat val_env pat (type_option (newvar ()));
   let (pv, met_env) =
     List.fold_right
-      (fun (id, ty) (pv, env) ->
+      (fun (id, ty, loc) (pv, env) ->
          let id' = Ident.create (Ident.name id) in
          ((id', id, ty)::pv,
           Env.add_value id' {val_type = ty;
@@ -562,7 +571,7 @@ let type_self_pattern cl_num privty val_env met_env par_env spat =
     mkpat (Ppat_alias (mkpat(Ppat_alias (spat, "selfpat-*")),
                        "selfpat-" ^ cl_num))
   in
-  reset_pattern ();
+  reset_pattern None;
   let pat = type_pat val_env spat in
   List.iter (fun f -> f()) (get_ref pattern_force);
   let meths = ref Meths.empty in
@@ -571,7 +580,7 @@ let type_self_pattern cl_num privty val_env met_env par_env spat =
   pattern_variables := [];
   let (val_env, met_env, par_env) =
     List.fold_right
-      (fun (id, ty) (val_env, met_env, par_env) ->
+      (fun (id, ty, loc) (val_env, met_env, par_env) ->
          (Env.add_value id {val_type = ty; val_kind = Val_unbound} val_env,
           Env.add_value id {val_type = ty;
                             val_kind = Val_self (meths, vars, cl_num, privty)}
@@ -900,6 +909,11 @@ let rec type_exp env sexp =
   match sexp.pexp_desc with
     Pexp_ident lid ->
       begin try
+        if !Clflags.annotations then begin
+          try let (path, annot) = Env.lookup_annot lid env in
+              Stypes.record (Stypes.An_ident (sexp.pexp_loc, annot));
+          with _ -> ()
+        end;
         let (path, desc) = Env.lookup_value lid env in
         re {
           exp_desc =
@@ -932,7 +946,13 @@ let rec type_exp env sexp =
         exp_type = type_constant cst;
         exp_env = env }
   | Pexp_let(rec_flag, spat_sexp_list, sbody) ->
-      let (pat_exp_list, new_env) = type_let env rec_flag spat_sexp_list in
+      let scp =
+        match rec_flag with
+        | Recursive -> Some (Annot.Idef sexp.pexp_loc)
+        | Nonrecursive -> Some (Annot.Idef sbody.pexp_loc)
+        | Default -> None
+      in
+      let (pat_exp_list, new_env) = type_let env rec_flag spat_sexp_list scp in
       let body = type_exp new_env sbody in
       re {
         exp_desc = Texp_let(rec_flag, pat_exp_list, body);
@@ -1759,7 +1779,7 @@ and type_expect ?in_function env sexp ty_expected =
   | Pexp_construct(lid, sarg, explicit_arity) ->
       type_construct env sexp.pexp_loc lid sarg explicit_arity ty_expected
   | Pexp_let(rec_flag, spat_sexp_list, sbody) ->
-      let (pat_exp_list, new_env) = type_let env rec_flag spat_sexp_list in
+      let (pat_exp_list, new_env) = type_let env rec_flag spat_sexp_list None in
       let body = type_expect new_env sbody ty_expected in
       re {
         exp_desc = Texp_let(rec_flag, pat_exp_list, body);
@@ -1902,7 +1922,8 @@ and type_cases ?in_function env ty_arg ty_res partial_loc caselist =
     List.map
       (fun (spat, sexp) ->
         if !Clflags.principal then begin_def ();
-        let (pat, ext_env, force) = type_pattern env spat in
+        let scope = Some (Annot.Idef sexp.pexp_loc) in
+        let (pat, ext_env, force) = type_pattern env spat scope in
         pattern_force := force @ !pattern_force;
         let pat =
           if !Clflags.principal then begin
@@ -1942,12 +1963,11 @@ and type_cases ?in_function env ty_arg ty_res partial_loc caselist =
 
 (* Typing of let bindings *)
 
-and type_let env rec_flag spat_sexp_list =
+and type_let env rec_flag spat_sexp_list scope =
   begin_def();
   if !Clflags.principal then begin_def ();
-  let (pat_list, new_env, force) =
+  let spatl = List.map (fun (spat, sexp) -> spat) spat_sexp_list in
-    type_pattern_list env (List.map (fun (spat, sexp) -> spat) spat_sexp_list)
+  let (pat_list, new_env, force) = type_pattern_list env spatl scope in
-  in
   if rec_flag = Recursive then
     List.iter2
       (fun pat (_, sexp) -> unify_pat env pat (type_approx env sexp))
@@ -1993,9 +2013,9 @@ and type_let env rec_flag spat_sexp_list =
 
 (* Typing of toplevel bindings *)
 
-let type_binding env rec_flag spat_sexp_list =
+let type_binding env rec_flag spat_sexp_list scope =
   Typetexp.reset_type_variables();
-  type_let env rec_flag spat_sexp_list
+  type_let env rec_flag spat_sexp_list scope
 
 (* Typing of toplevel expressions *)
 

typing/typecore.mli

@@ -23,10 +23,12 @@ val is_nonexpansive: Typedtree.expression -> bool
 val type_binding:
         Env.t -> rec_flag ->
           (Parsetree.pattern * Parsetree.expression) list -> 
+          Annot.ident option ->
           (Typedtree.pattern * Typedtree.expression) list * Env.t
 val type_let:
         Env.t -> rec_flag ->
-          (Parsetree.pattern * Parsetree.expression) list -> 
+          (Parsetree.pattern * Parsetree.expression) list ->
+          Annot.ident option ->
           (Typedtree.pattern * Typedtree.expression) list * Env.t
 val type_expression:
         Env.t -> Parsetree.expression -> Typedtree.expression

typing/typemod.ml

@@ -503,7 +503,7 @@ let rec type_module anchor env smod =
            mod_env = env;
            mod_loc = smod.pmod_loc }
   | Pmod_structure sstr ->
-      let (str, sg, finalenv) = type_structure anchor env sstr in
+      let (str, sg, finalenv) = type_structure anchor env sstr smod.pmod_loc in
       rm { mod_desc = Tmod_structure str;
            mod_type = Tmty_signature sg;
            mod_env = env;
@@ -558,7 +558,7 @@ let rec type_module anchor env smod =
            mod_env = env;
            mod_loc = smod.pmod_loc }
 
-and type_structure anchor env sstr =
+and type_structure anchor env sstr scope =
   let type_names = ref StringSet.empty
   and module_names = ref StringSet.empty
   and modtype_names = ref StringSet.empty in
@@ -571,9 +571,20 @@ and type_structure anchor env sstr =
         let expr = Typecore.type_expression env sexpr in
         let (str_rem, sig_rem, final_env) = type_struct env srem in
         (Tstr_eval expr :: str_rem, sig_rem, final_env)
-    | {pstr_desc = Pstr_value(rec_flag, sdefs)} :: srem ->
+    | {pstr_desc = Pstr_value(rec_flag, sdefs); pstr_loc = loc} :: srem ->
+        let scope =
+          match rec_flag with
+          | Recursive -> Some (Annot.Idef {scope with
+                                 Location.loc_start = loc.Location.loc_start})
+          | Nonrecursive ->
+              let start = match srem with
+                | [] -> scope.Location.loc_end
+                | {pstr_loc = loc2} :: _ -> loc2.Location.loc_start
+              in Some (Annot.Idef {scope with Location.loc_start = start})
+          | Default -> None
+        in
         let (defs, newenv) =
-          Typecore.type_binding env rec_flag sdefs in
+          Typecore.type_binding env rec_flag sdefs scope in
         let (str_rem, sig_rem, final_env) = type_struct newenv srem in
         let bound_idents = let_bound_idents defs in
         let make_sig_value id =
@@ -723,7 +734,7 @@ and type_structure anchor env sstr =
          sg @ sig_rem,
          final_env)
   in
-  if !Clflags.save_types
+  if !Clflags.annotations
   then List.iter (function {pstr_loc = l} -> Stypes.record_phrase l) sstr;
   type_struct env sstr
 
@@ -784,10 +795,7 @@ and simplify_signature sg =
 
 let type_implementation sourcefile outputprefix modulename initial_env ast =
   Typecore.reset_delayed_checks ();
-  let (str, sg, finalenv) =
+  let (str, sg, finalenv) = type_structure initial_env ast Location.none in
-    Misc.try_finally (fun () -> type_structure initial_env ast)
-                     (fun () -> Stypes.dump (outputprefix ^ ".annot"))
-  in
   Typecore.force_delayed_checks ();
   if !Clflags.print_types then begin
     fprintf std_formatter "%a@." Printtyp.signature (simplify_signature sg);

typing/typemod.mli

@@ -20,7 +20,8 @@ open Format
 val type_module:
         Env.t -> Parsetree.module_expr -> Typedtree.module_expr
 val type_structure:
-        Env.t -> Parsetree.structure -> Typedtree.structure * signature * Env.t
+        Env.t -> Parsetree.structure -> Location.t ->
+          Typedtree.structure * signature * Env.t
 val type_implementation:
         string -> string -> string -> Env.t -> Parsetree.structure ->
                                Typedtree.structure * Typedtree.module_coercion

utils/clflags.ml

@@ -33,7 +33,7 @@ and ccopts = ref ([] : string list)     (* -ccopt *)
 and classic = ref false                 (* -nolabels *)
 and nopervasives = ref false            (* -nopervasives *)
 and preprocessor = ref(None : string option) (* -pp *)
-let save_types = ref false              (* -stypes *)
+let annotations = ref false             (* -annot *)
 and use_threads = ref false             (* -thread *)
 and use_vmthreads = ref false           (* -vmthread *)
 and noassert = ref false                (* -noassert *)

utils/clflags.mli

@@ -30,7 +30,7 @@ val ccopts : string list ref
 val classic : bool ref
 val nopervasives : bool ref
 val preprocessor : string option ref
-val save_types : bool ref
+val annotations : bool ref
 val use_threads : bool ref
 val use_vmthreads : bool ref
 val noassert : bool ref