diff options
40 files changed, 608 insertions, 283 deletions
@@ -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 -bytecomp/bytegen.cmx: typing/types.cmx bytecomp/switch.cmx \ + parsing/asttypes.cmi typing/annot.cmi bytecomp/bytegen.cmi +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/cmm.cmi asmcomp/arch.cmo 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/reload.cmo: asmcomp/reloadgen.cmi asmcomp/reload.cmi +asmcomp/reload.cmx: asmcomp/reloadgen.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.cmx: asmcomp/schedgen.cmx asmcomp/scheduling.cmi +asmcomp/scheduling.cmo: asmcomp/schedgen.cmi asmcomp/mach.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 \ - utils/misc.cmi asmcomp/mach.cmi asmcomp/debuginfo.cmi asmcomp/cmm.cmi \ - asmcomp/arch.cmo asmcomp/selection.cmi -asmcomp/selection.cmx: asmcomp/selectgen.cmx asmcomp/reg.cmx asmcomp/proc.cmx \ - utils/misc.cmx asmcomp/mach.cmx asmcomp/debuginfo.cmx asmcomp/cmm.cmx \ - asmcomp/arch.cmx asmcomp/selection.cmi +asmcomp/selection.cmo: asmcomp/selectgen.cmi asmcomp/reg.cmi utils/misc.cmi \ + asmcomp/mach.cmi asmcomp/cmm.cmi asmcomp/arch.cmo asmcomp/selection.cmi +asmcomp/selection.cmx: asmcomp/selectgen.cmx asmcomp/reg.cmx utils/misc.cmx \ + asmcomp/mach.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 \ - bytecomp/printinstr.cmi parsing/printast.cmi driver/pparse.cmi \ - parsing/parse.cmi utils/misc.cmi typing/ident.cmi typing/env.cmi \ - bytecomp/emitcode.cmi utils/config.cmi utils/clflags.cmi utils/ccomp.cmi \ - bytecomp/bytegen.cmi driver/compile.cmi + typing/stypes.cmi bytecomp/simplif.cmi typing/printtyp.cmi \ + bytecomp/printlambda.cmi bytecomp/printinstr.cmi parsing/printast.cmi \ + driver/pparse.cmi parsing/parse.cmi utils/misc.cmi typing/ident.cmi \ + typing/env.cmi bytecomp/emitcode.cmi utils/config.cmi utils/clflags.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 \ - bytecomp/printinstr.cmx parsing/printast.cmx driver/pparse.cmx \ - parsing/parse.cmx utils/misc.cmx typing/ident.cmx typing/env.cmx \ - bytecomp/emitcode.cmx utils/config.cmx utils/clflags.cmx utils/ccomp.cmx \ - bytecomp/bytegen.cmx driver/compile.cmi + typing/stypes.cmx bytecomp/simplif.cmx typing/printtyp.cmx \ + bytecomp/printlambda.cmx bytecomp/printinstr.cmx parsing/printast.cmx \ + driver/pparse.cmx parsing/parse.cmx utils/misc.cmx typing/ident.cmx \ + typing/env.cmx bytecomp/emitcode.cmx utils/config.cmx utils/clflags.cmx \ + 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 \ diff --git a/asmcomp/closure.ml b/asmcomp/closure.ml index 15dc67986..c2635a467 100644 --- a/asmcomp/closure.ml +++ b/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)), diff --git a/boot/ocamlc b/boot/ocamlc Binary files differindex cd40f1c39..86de11891 100755 --- a/boot/ocamlc +++ b/boot/ocamlc diff --git a/boot/ocamllex b/boot/ocamllex Binary files differindex 90fc434a2..1a03b93fc 100755 --- a/boot/ocamllex +++ b/boot/ocamllex diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml index 2cd0c65b0..45df057e1 100644 --- a/bytecomp/bytegen.ml +++ b/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 diff --git a/bytecomp/lambda.ml b/bytecomp/lambda.ml index b66378c9e..c6017d918 100644 --- a/bytecomp/lambda.ml +++ b/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) diff --git a/bytecomp/lambda.mli b/bytecomp/lambda.mli index 6a9c75fd8..cf8152a9a 100644 --- a/bytecomp/lambda.mli +++ b/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 diff --git a/bytecomp/printlambda.ml b/bytecomp/printlambda.ml index 3f42f7e1e..a67642b2e 100644 --- a/bytecomp/printlambda.ml +++ b/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 diff --git a/bytecomp/simplif.ml b/bytecomp/simplif.ml index ee59cab74..f7381d962 100644 --- a/bytecomp/simplif.ml +++ b/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(eliminate_ref id e1, List.map (eliminate_ref id) el) + | Lapply(e1, el, loc) -> + 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)); diff --git a/bytecomp/translclass.ml b/bytecomp/translclass.ml index fd2b91de0..7ea71185e 100644 --- a/bytecomp/translclass.ml +++ b/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' @ args) + Lapply(func', 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, - [Lapply(Lvar env_init, [Lvar envs])])))); + (mkappl(Lvar new_init, + [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]), - Lapply(Lvar obj_init, [lambda_unit]))) + Lsequence(mkappl (oo_prim "init_class", [Lvar cla]), + 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] diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml index be60ef5bb..4ab167c84 100644 --- a/bytecomp/translcore.ml +++ b/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 @ args) + | Lapply(lexp, largs, _) -> + Lapply(lexp, largs @ args, loc) | lexp -> - Lapply(lexp, args) + Lapply(lexp, args, loc) in let rec build_apply lam args = function (None, optional) :: l -> diff --git a/bytecomp/translcore.mli b/bytecomp/translcore.mli index 8148f9b8a..baac05567 100644 --- a/bytecomp/translcore.mli +++ b/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 diff --git a/bytecomp/translmod.ml b/bytecomp/translmod.ml index 4e52eb71a..00d08e475 100644 --- a/bytecomp/translmod.ml +++ b/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) diff --git a/driver/compile.ml b/driver/compile.ml index 5adaae787..a847dcab4 100644 --- a/driver/compile.ml +++ b/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 diff --git a/driver/main.ml b/driver/main.ml index 5782869d1..1420c98d2 100644 --- a/driver/main.ml +++ b/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 diff --git a/driver/main_args.ml b/driver/main_args.ml index f5fcea23e..bb72b7945 100644 --- a/driver/main_args.ml +++ b/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"; diff --git a/driver/main_args.mli b/driver/main_args.mli index b8afff0f7..1e4cb4944 100644 --- a/driver/main_args.mli +++ b/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 diff --git a/driver/optmain.ml b/driver/optmain.ml index 06b4aadfe..ac28b7618 100644 --- a/driver/optmain.ml +++ b/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, - " Save type information in <filename>.annot"; + "-dtypes", Arg.Set annotations, + " (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), diff --git a/emacs/caml-types.el b/emacs/caml-types.el index 74ec5be9e..4c42574d2 100644 --- a/emacs/caml-types.el +++ b/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 -of ocamlc and ocamlopt. +Annotation files *.annot may be generated with the \"-annot\" option +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-position-re + (caml-types-number-re "\\([0-9]*\\)")) + (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-face) -(set-face-doc-string 'caml-types-face +(make-face 'caml-types-expr-face) +(set-face-doc-string 'caml-types-expr-face "face for hilighting expressions and types") -(if (not (face-differs-from-default-p 'caml-types-face)) - (set-face-background 'caml-types-face "#88FF44")) +(if (not (face-differs-from-default-p 'caml-types-expr-face)) + (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... ] -; type-info = -; () if this node does not correspond to an annotated interval -; (type-start . type-end) address of the annotation in the .annot file +; [ pos-left pos-right annotation child child child... ] +; annotation is a list of: +; (kind . info) where kind = "type" "call" etc. +; 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) - (not (looking-at "type")) - (not (looking-at "\\\""))) - (forward-char 1)) - (setq type-info - (if (looking-at - "^type(\n\\( \\([^\n)]\\|.)\\|\n[^)]\\)*\\)\n)") - (caml-types-hcons (match-string 1) table))) + (setq annotation ()) + (while (next-annotation) + (cond ((looking-at + "^\\([a-z]+\\)(\n \\(\\([^\n)]\\|.)\\|\n[^)]\\)*\\)\n)") + (let ((kind (caml-types-hcons (match-string 1) table)) + (info (caml-types-hcons (match-string 2) table))) + (setq annotation (cons (cons kind info) annotation)))))) (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) diff --git a/emacs/caml.el b/emacs/caml.el index 17aaa52da..965cc788f 100644 --- a/emacs/caml.el +++ b/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 diff --git a/otherlibs/labltk/browser/.depend b/otherlibs/labltk/browser/.depend index 558ccdd26..491201163 100644 --- a/otherlibs/labltk/browser/.depend +++ b/otherlibs/labltk/browser/.depend @@ -1,19 +1,19 @@ -editor.cmo: fileselect.cmi jg_bind.cmi jg_button.cmo jg_menu.cmo \ - jg_message.cmi jg_text.cmi jg_tk.cmo jg_toplevel.cmo lexical.cmi \ - mytypes.cmi searchid.cmi searchpos.cmi setpath.cmi shell.cmi \ - typecheck.cmi viewer.cmi editor.cmi -editor.cmx: fileselect.cmx jg_bind.cmx jg_button.cmx jg_menu.cmx \ - jg_message.cmx jg_text.cmx jg_tk.cmx jg_toplevel.cmx lexical.cmx \ - mytypes.cmi searchid.cmx searchpos.cmx setpath.cmx shell.cmx \ - typecheck.cmx viewer.cmx editor.cmi -fileselect.cmo: jg_box.cmo jg_entry.cmo jg_memo.cmi jg_toplevel.cmo list2.cmo \ - setpath.cmi useunix.cmi fileselect.cmi -fileselect.cmx: jg_box.cmx jg_entry.cmx jg_memo.cmx jg_toplevel.cmx list2.cmx \ - setpath.cmx useunix.cmx fileselect.cmi +editor.cmo: viewer.cmi typecheck.cmi shell.cmi setpath.cmi searchpos.cmi \ + searchid.cmi mytypes.cmi lexical.cmi jg_toplevel.cmo jg_tk.cmo \ + jg_text.cmi jg_message.cmi jg_menu.cmo jg_button.cmo jg_bind.cmi \ + fileselect.cmi editor.cmi +editor.cmx: viewer.cmx typecheck.cmx shell.cmx setpath.cmx searchpos.cmx \ + searchid.cmx mytypes.cmi lexical.cmx jg_toplevel.cmx jg_tk.cmx \ + jg_text.cmx jg_message.cmx jg_menu.cmx jg_button.cmx jg_bind.cmx \ + fileselect.cmx editor.cmi +fileselect.cmo: useunix.cmi setpath.cmi list2.cmo jg_toplevel.cmo jg_memo.cmi \ + jg_entry.cmo jg_box.cmo fileselect.cmi +fileselect.cmx: useunix.cmx setpath.cmx list2.cmx jg_toplevel.cmx jg_memo.cmx \ + 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.cmx: jg_bind.cmx jg_completion.cmx +jg_box.cmo: jg_completion.cmi jg_bind.cmi +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.cmx: jg_bind.cmx jg_completion.cmx jg_multibox.cmi -jg_text.cmo: jg_bind.cmi jg_button.cmo jg_tk.cmo jg_toplevel.cmo jg_text.cmi -jg_text.cmx: jg_bind.cmx jg_button.cmx jg_tk.cmx jg_toplevel.cmx jg_text.cmi +jg_multibox.cmo: jg_completion.cmi jg_bind.cmi jg_multibox.cmi +jg_multibox.cmx: jg_completion.cmx jg_bind.cmx jg_multibox.cmi +jg_text.cmo: jg_toplevel.cmo jg_tk.cmo jg_button.cmo jg_bind.cmi 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 \ - viewer.cmi -main.cmx: editor.cmx jg_config.cmx searchid.cmx searchpos.cmx shell.cmx \ - viewer.cmx +main.cmo: viewer.cmi shell.cmi searchpos.cmi searchid.cmi jg_config.cmi \ + editor.cmi +main.cmx: viewer.cmx shell.cmx searchpos.cmx searchid.cmx jg_config.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 \ - lexical.cmi searchid.cmi searchpos.cmi -searchpos.cmx: jg_bind.cmx jg_memo.cmx jg_message.cmx jg_text.cmx jg_tk.cmx \ - lexical.cmx searchid.cmx searchpos.cmi -setpath.cmo: jg_bind.cmi jg_box.cmo jg_button.cmo jg_toplevel.cmo list2.cmo \ - useunix.cmi setpath.cmi -setpath.cmx: jg_bind.cmx jg_box.cmx jg_button.cmx jg_toplevel.cmx list2.cmx \ - useunix.cmx setpath.cmi -shell.cmo: dummy.cmi fileselect.cmi jg_memo.cmi jg_menu.cmo jg_message.cmi \ - jg_text.cmi jg_tk.cmo jg_toplevel.cmo lexical.cmi list2.cmo shell.cmi -shell.cmx: dummy.cmi fileselect.cmx jg_memo.cmx jg_menu.cmx jg_message.cmx \ - jg_text.cmx jg_tk.cmx jg_toplevel.cmx lexical.cmx list2.cmx shell.cmi -typecheck.cmo: jg_message.cmi jg_text.cmi jg_tk.cmo mytypes.cmi typecheck.cmi -typecheck.cmx: jg_message.cmx jg_text.cmx jg_tk.cmx mytypes.cmi typecheck.cmi +searchpos.cmo: searchid.cmi lexical.cmi jg_tk.cmo jg_text.cmi jg_message.cmi \ + jg_memo.cmi jg_bind.cmi searchpos.cmi +searchpos.cmx: searchid.cmx lexical.cmx jg_tk.cmx jg_text.cmx jg_message.cmx \ + jg_memo.cmx jg_bind.cmx searchpos.cmi +setpath.cmo: useunix.cmi list2.cmo jg_toplevel.cmo jg_button.cmo jg_box.cmo \ + jg_bind.cmi setpath.cmi +setpath.cmx: useunix.cmx list2.cmx jg_toplevel.cmx jg_button.cmx jg_box.cmx \ + jg_bind.cmx setpath.cmi +shell.cmo: list2.cmo lexical.cmi jg_toplevel.cmo jg_tk.cmo jg_text.cmi \ + jg_message.cmi jg_menu.cmo jg_memo.cmi fileselect.cmi dummy.cmi shell.cmi +shell.cmx: list2.cmx lexical.cmx jg_toplevel.cmx jg_tk.cmx jg_text.cmx \ + jg_message.cmx jg_menu.cmx jg_memo.cmx fileselect.cmx dummy.cmi shell.cmi +typecheck.cmo: mytypes.cmi jg_tk.cmo jg_text.cmi jg_message.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 \ - jg_entry.cmo jg_menu.cmo jg_message.cmi jg_multibox.cmi jg_text.cmi \ - jg_tk.cmo jg_toplevel.cmo mytypes.cmi searchid.cmi searchpos.cmi \ - setpath.cmi shell.cmi useunix.cmi viewer.cmi -viewer.cmx: help.cmx jg_bind.cmx jg_box.cmx jg_button.cmx jg_completion.cmx \ - jg_entry.cmx jg_menu.cmx jg_message.cmx jg_multibox.cmx jg_text.cmx \ - jg_tk.cmx jg_toplevel.cmx mytypes.cmi searchid.cmx searchpos.cmx \ - setpath.cmx shell.cmx useunix.cmx viewer.cmi +viewer.cmo: useunix.cmi shell.cmi setpath.cmi searchpos.cmi searchid.cmi \ + mytypes.cmi jg_toplevel.cmo jg_tk.cmo jg_text.cmi jg_multibox.cmi \ + jg_message.cmi jg_menu.cmo jg_entry.cmo jg_completion.cmi jg_button.cmo \ + jg_box.cmo jg_bind.cmi help.cmo viewer.cmi +viewer.cmx: useunix.cmx shell.cmx setpath.cmx searchpos.cmx searchid.cmx \ + mytypes.cmi jg_toplevel.cmx jg_tk.cmx jg_text.cmx jg_multibox.cmx \ + jg_message.cmx jg_menu.cmx jg_entry.cmx jg_completion.cmx jg_button.cmx \ + jg_box.cmx jg_bind.cmx help.cmx viewer.cmi mytypes.cmi: shell.cmi typecheck.cmi: mytypes.cmi diff --git a/otherlibs/labltk/browser/Makefile b/otherlibs/labltk/browser/Makefile index c1daed946..b611622a2 100644 --- a/otherlibs/labltk/browser/Makefile +++ b/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 diff --git a/otherlibs/labltk/browser/mytypes.mli b/otherlibs/labltk/browser/mytypes.mli index 6703ff101..6db120adc 100644 --- a/otherlibs/labltk/browser/mytypes.mli +++ b/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 } diff --git a/otherlibs/labltk/browser/searchpos.ml b/otherlibs/labltk/browser/searchpos.ml index 7cadb4eda..e9c1ffad0 100644 --- a/otherlibs/labltk/browser/searchpos.ml +++ b/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 [] -> [] diff --git a/otherlibs/labltk/browser/searchpos.mli b/otherlibs/labltk/browser/searchpos.mli index 1da1a877a..cea3b4602 100644 --- a/otherlibs/labltk/browser/searchpos.mli +++ b/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 diff --git a/otherlibs/labltk/browser/typecheck.ml b/otherlibs/labltk/browser/typecheck.ml index 8199e4610..89366baa1 100644 --- a/otherlibs/labltk/browser/typecheck.ml +++ b/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' diff --git a/tools/ocamlcp.ml b/tools/ocamlcp.ml index d22d2f1a6..25e591c9d 100644 --- a/tools/ocamlcp.ml +++ b/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 diff --git a/toplevel/toploop.ml b/toplevel/toploop.ml index 7502fa020..6094b12e7 100644 --- a/toplevel/toploop.ml +++ b/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 (); diff --git a/typing/annot.mli b/typing/annot.mli new file mode 100644 index 000000000..79100c558 --- /dev/null +++ b/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 *) +;; diff --git a/typing/env.ml b/typing/env.ml index 3d7f04164..46bb2efd9 100644 --- a/typing/env.ml +++ b/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 diff --git a/typing/env.mli b/typing/env.mli index b88bf5073..e27dcfcee 100644 --- a/typing/env.mli +++ b/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 diff --git a/typing/stypes.ml b/typing/stypes.ml index d762b576c..a0f7aa3c8 100644 --- a/typing/stypes.ml +++ b/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 = - Ti_pat of pattern +type annotation = + | 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 - type_info := ti :: !type_info + if !Clflags.annotations && not (get_location ti).Location.loc_ghost then + 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; - fprintf pp " "; - print_position pp loc.loc_end; - fprintf pp "@.type(@. "; + if loc <> prev_loc then fprintf pp "%a@." print_location loc; + 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 - type_info := []; + let info = List.fast_sort cmp_ti_inner_first !annotations in + 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; ;; diff --git a/typing/stypes.mli b/typing/stypes.mli index ed5fa9149..399c04131 100644 --- a/typing/stypes.mli +++ b/typing/stypes.mli @@ -18,16 +18,18 @@ open Typedtree;; -type type_info = - Ti_pat of pattern +type annotation = + | 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_info : unit -> type_info list;; +val get_location : annotation -> Location.t;; +val get_info : unit -> annotation list;; diff --git a/typing/typeclass.ml b/typing/typeclass.ml index 947f4271a..6111c4c4c 100644 --- a/typing/typeclass.ml +++ b/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 diff --git a/typing/typecore.ml b/typing/typecore.ml index 379abb899..232bf2286 100644 --- a/typing/typecore.ml +++ b/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,_)::_, (y,_)::_ -> + | (x,_,_)::_, [] -> raise (Error (loc, Orpat_vars x)) + | [],(x,_,_)::_ -> raise (Error (loc, Orpat_vars x)) + | (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 -> - Env.add_value id {val_type = ty; val_kind = Val_reg} env) + (fun (id, ty, loc) 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 = - reset_pattern (); +let type_pattern env spat scope = + 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 = - reset_pattern (); +let type_pattern_list env spatl scope = + 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) = - type_pattern_list env (List.map (fun (spat, sexp) -> spat) spat_sexp_list) - in + let spatl = List.map (fun (spat, sexp) -> spat) spat_sexp_list in + let (pat_list, new_env, force) = type_pattern_list env spatl scope 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 *) diff --git a/typing/typecore.mli b/typing/typecore.mli index ac8b5ebb6..d860f0a85 100644 --- a/typing/typecore.mli +++ b/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 diff --git a/typing/typemod.ml b/typing/typemod.ml index 91b8c80ba..9989a257d 100644 --- a/typing/typemod.ml +++ b/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) = - Misc.try_finally (fun () -> type_structure initial_env ast) - (fun () -> Stypes.dump (outputprefix ^ ".annot")) - in + let (str, sg, finalenv) = type_structure initial_env ast Location.none in Typecore.force_delayed_checks (); if !Clflags.print_types then begin fprintf std_formatter "%a@." Printtyp.signature (simplify_signature sg); diff --git a/typing/typemod.mli b/typing/typemod.mli index 72823ac08..2f452d3ea 100644 --- a/typing/typemod.mli +++ b/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 diff --git a/utils/clflags.ml b/utils/clflags.ml index 516ea8f29..cda46bd2e 100644 --- a/utils/clflags.ml +++ b/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 *) diff --git a/utils/clflags.mli b/utils/clflags.mli index 0dcbaddf9..728cd285c 100644 --- a/utils/clflags.mli +++ b/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 |