summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--.depend137
-rw-r--r--camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml7
-rw-r--r--camlp4/Camlp4/Struct/Grammar/Insert.ml4
-rw-r--r--driver/compile.ml1
-rw-r--r--driver/optcompile.ml2
-rw-r--r--otherlibs/labltk/browser/.depend31
-rw-r--r--toplevel/opttoploop.ml1
-rw-r--r--toplevel/toploop.ml1
-rw-r--r--typing/env.ml261
-rw-r--r--typing/env.mli16
-rw-r--r--typing/includecore.ml5
-rw-r--r--typing/includemod.ml2
-rw-r--r--typing/path.ml5
-rw-r--r--typing/path.mli2
-rw-r--r--typing/typeclass.ml46
-rw-r--r--typing/typecore.ml141
-rw-r--r--typing/typedecl.ml24
-rw-r--r--typing/typedtree.mli1
-rw-r--r--typing/typemod.ml18
-rw-r--r--typing/unused_var.ml11
-rw-r--r--typing/unused_var.mli3
-rw-r--r--utils/misc.ml4
-rw-r--r--utils/misc.mli4
-rw-r--r--utils/warnings.ml30
-rw-r--r--utils/warnings.mli6
25 files changed, 563 insertions, 200 deletions
diff --git a/.depend b/.depend
index ee61e2f7d..e6c68ebc0 100644
--- a/.depend
+++ b/.depend
@@ -38,6 +38,8 @@ parsing/lexer.cmo: utils/warnings.cmi parsing/parser.cmi utils/misc.cmi \
parsing/location.cmi parsing/lexer.cmi
parsing/lexer.cmx: utils/warnings.cmx parsing/parser.cmx utils/misc.cmx \
parsing/location.cmx parsing/lexer.cmi
+parsing/linenum.cmo: utils/misc.cmi
+parsing/linenum.cmx: utils/misc.cmx
parsing/location.cmo: utils/warnings.cmi utils/terminfo.cmi \
parsing/location.cmi
parsing/location.cmx: utils/warnings.cmx utils/terminfo.cmx \
@@ -65,8 +67,9 @@ typing/btype.cmi: typing/types.cmi typing/path.cmi parsing/asttypes.cmi
typing/ctype.cmi: typing/types.cmi typing/path.cmi parsing/longident.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/annot.cmi
+typing/env.cmi: utils/warnings.cmi typing/types.cmi typing/path.cmi \
+ parsing/longident.cmi parsing/location.cmi typing/ident.cmi \
+ utils/consistbl.cmi typing/annot.cmi
typing/ident.cmi:
typing/includeclass.cmi: typing/types.cmi typing/typedtree.cmi typing/env.cmi \
typing/ctype.cmi
@@ -122,16 +125,18 @@ typing/datarepr.cmo: typing/types.cmi typing/predef.cmi utils/misc.cmi \
typing/btype.cmi parsing/asttypes.cmi typing/datarepr.cmi
typing/datarepr.cmx: typing/types.cmx typing/predef.cmx utils/misc.cmx \
typing/btype.cmx parsing/asttypes.cmi typing/datarepr.cmi
-typing/env.cmo: typing/types.cmi utils/tbl.cmi typing/subst.cmi \
- typing/predef.cmi typing/path.cmi utils/misc.cmi parsing/longident.cmi \
- parsing/location.cmi typing/ident.cmi typing/datarepr.cmi \
- utils/consistbl.cmi utils/config.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 \
- parsing/location.cmx typing/ident.cmx typing/datarepr.cmx \
- utils/consistbl.cmx utils/config.cmx utils/clflags.cmx typing/btype.cmx \
- parsing/asttypes.cmi typing/annot.cmi typing/env.cmi
+typing/env.cmo: utils/warnings.cmi typing/types.cmi utils/tbl.cmi \
+ typing/subst.cmi typing/predef.cmi typing/path.cmi utils/misc.cmi \
+ parsing/longident.cmi parsing/location.cmi typing/ident.cmi \
+ typing/datarepr.cmi utils/consistbl.cmi utils/config.cmi \
+ utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi typing/annot.cmi \
+ typing/env.cmi
+typing/env.cmx: utils/warnings.cmx typing/types.cmx utils/tbl.cmx \
+ typing/subst.cmx typing/predef.cmx typing/path.cmx utils/misc.cmx \
+ parsing/longident.cmx parsing/location.cmx typing/ident.cmx \
+ typing/datarepr.cmx utils/consistbl.cmx utils/config.cmx \
+ 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 \
@@ -139,11 +144,13 @@ typing/includeclass.cmo: typing/types.cmi typing/printtyp.cmi \
typing/includeclass.cmx: typing/types.cmx typing/printtyp.cmx \
typing/ctype.cmx typing/includeclass.cmi
typing/includecore.cmo: typing/types.cmi typing/typedtree.cmi \
- typing/predef.cmi typing/path.cmi utils/misc.cmi typing/ctype.cmi \
- typing/btype.cmi parsing/asttypes.cmi typing/includecore.cmi
+ typing/predef.cmi typing/path.cmi utils/misc.cmi typing/ident.cmi \
+ typing/env.cmi typing/ctype.cmi typing/btype.cmi parsing/asttypes.cmi \
+ typing/includecore.cmi
typing/includecore.cmx: typing/types.cmx typing/typedtree.cmx \
- typing/predef.cmx typing/path.cmx utils/misc.cmx typing/ctype.cmx \
- typing/btype.cmx parsing/asttypes.cmi typing/includecore.cmi
+ typing/predef.cmx typing/path.cmx utils/misc.cmx typing/ident.cmx \
+ typing/env.cmx typing/ctype.cmx typing/btype.cmx parsing/asttypes.cmi \
+ typing/includecore.cmi
typing/includemod.cmo: typing/types.cmi typing/typedtree.cmi utils/tbl.cmi \
typing/subst.cmi typing/printtyp.cmi typing/path.cmi typing/mtype.cmi \
utils/misc.cmi parsing/location.cmi typing/includecore.cmi \
@@ -725,20 +732,20 @@ driver/optcompile.cmi: typing/env.cmi
driver/opterrors.cmi:
driver/optmain.cmi:
driver/pparse.cmi:
-driver/compile.cmo: utils/warnings.cmi typing/unused_var.cmi \
- typing/typemod.cmi typing/typedtree.cmi bytecomp/translmod.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 parsing/location.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 \
- 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 parsing/location.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/compile.cmo: utils/warnings.cmi typing/typemod.cmi \
+ typing/typedtree.cmi bytecomp/translmod.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 parsing/location.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/typemod.cmx \
+ typing/typedtree.cmx bytecomp/translmod.cmx 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 parsing/location.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 \
@@ -763,20 +770,20 @@ driver/main.cmx: utils/warnings.cmx utils/misc.cmx driver/main_args.cmx \
bytecomp/bytelink.cmx bytecomp/bytelibrarian.cmx driver/main.cmi
driver/main_args.cmo: utils/warnings.cmi driver/main_args.cmi
driver/main_args.cmx: utils/warnings.cmx driver/main_args.cmi
-driver/optcompile.cmo: utils/warnings.cmi typing/unused_var.cmi \
- typing/typemod.cmi typing/typedtree.cmi bytecomp/translmod.cmi \
- typing/stypes.cmi bytecomp/simplif.cmi typing/printtyp.cmi \
- bytecomp/printlambda.cmi parsing/printast.cmi driver/pparse.cmi \
- parsing/parse.cmi utils/misc.cmi parsing/location.cmi typing/ident.cmi \
- typing/env.cmi utils/config.cmi asmcomp/compilenv.cmi utils/clflags.cmi \
- utils/ccomp.cmi asmcomp/asmgen.cmi driver/optcompile.cmi
-driver/optcompile.cmx: utils/warnings.cmx typing/unused_var.cmx \
- typing/typemod.cmx typing/typedtree.cmx bytecomp/translmod.cmx \
- typing/stypes.cmx bytecomp/simplif.cmx typing/printtyp.cmx \
- bytecomp/printlambda.cmx parsing/printast.cmx driver/pparse.cmx \
- parsing/parse.cmx utils/misc.cmx parsing/location.cmx typing/ident.cmx \
- typing/env.cmx utils/config.cmx asmcomp/compilenv.cmx utils/clflags.cmx \
- utils/ccomp.cmx asmcomp/asmgen.cmx driver/optcompile.cmi
+driver/optcompile.cmo: utils/warnings.cmi typing/typemod.cmi \
+ typing/typedtree.cmi bytecomp/translmod.cmi typing/stypes.cmi \
+ bytecomp/simplif.cmi typing/printtyp.cmi bytecomp/printlambda.cmi \
+ parsing/printast.cmi driver/pparse.cmi parsing/parse.cmi utils/misc.cmi \
+ parsing/location.cmi typing/ident.cmi typing/env.cmi utils/config.cmi \
+ asmcomp/compilenv.cmi utils/clflags.cmi utils/ccomp.cmi \
+ asmcomp/asmgen.cmi driver/optcompile.cmi
+driver/optcompile.cmx: utils/warnings.cmx typing/typemod.cmx \
+ typing/typedtree.cmx bytecomp/translmod.cmx typing/stypes.cmx \
+ bytecomp/simplif.cmx typing/printtyp.cmx bytecomp/printlambda.cmx \
+ parsing/printast.cmx driver/pparse.cmx parsing/parse.cmx utils/misc.cmx \
+ parsing/location.cmx typing/ident.cmx typing/env.cmx utils/config.cmx \
+ asmcomp/compilenv.cmx utils/clflags.cmx utils/ccomp.cmx \
+ asmcomp/asmgen.cmx driver/optcompile.cmi
driver/opterrors.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 \
@@ -843,22 +850,22 @@ toplevel/opttopdirs.cmx: utils/warnings.cmx typing/types.cmx \
utils/misc.cmx parsing/longident.cmx typing/ident.cmx typing/env.cmx \
typing/ctype.cmx utils/config.cmx utils/clflags.cmx asmcomp/asmlink.cmx \
toplevel/opttopdirs.cmi
-toplevel/opttoploop.cmo: utils/warnings.cmi typing/unused_var.cmi \
- typing/types.cmi typing/typemod.cmi typing/typedtree.cmi \
- typing/typecore.cmi bytecomp/translmod.cmi bytecomp/simplif.cmi \
- typing/printtyp.cmi bytecomp/printlambda.cmi parsing/printast.cmi \
- typing/predef.cmi typing/path.cmi parsing/parsetree.cmi parsing/parse.cmi \
+toplevel/opttoploop.cmo: utils/warnings.cmi typing/types.cmi \
+ typing/typemod.cmi typing/typedtree.cmi typing/typecore.cmi \
+ bytecomp/translmod.cmi bytecomp/simplif.cmi typing/printtyp.cmi \
+ bytecomp/printlambda.cmi parsing/printast.cmi typing/predef.cmi \
+ typing/path.cmi parsing/parsetree.cmi parsing/parse.cmi \
typing/outcometree.cmi driver/opterrors.cmi driver/optcompile.cmi \
typing/oprint.cmi utils/misc.cmi parsing/longident.cmi \
parsing/location.cmi parsing/lexer.cmi bytecomp/lambda.cmi \
typing/ident.cmi toplevel/genprintval.cmi typing/env.cmi utils/config.cmi \
asmcomp/compilenv.cmi utils/clflags.cmi typing/btype.cmi \
asmcomp/asmlink.cmi asmcomp/asmgen.cmi toplevel/opttoploop.cmi
-toplevel/opttoploop.cmx: utils/warnings.cmx typing/unused_var.cmx \
- typing/types.cmx typing/typemod.cmx typing/typedtree.cmx \
- typing/typecore.cmx bytecomp/translmod.cmx bytecomp/simplif.cmx \
- typing/printtyp.cmx bytecomp/printlambda.cmx parsing/printast.cmx \
- typing/predef.cmx typing/path.cmx parsing/parsetree.cmi parsing/parse.cmx \
+toplevel/opttoploop.cmx: utils/warnings.cmx typing/types.cmx \
+ typing/typemod.cmx typing/typedtree.cmx typing/typecore.cmx \
+ bytecomp/translmod.cmx bytecomp/simplif.cmx typing/printtyp.cmx \
+ bytecomp/printlambda.cmx parsing/printast.cmx typing/predef.cmx \
+ typing/path.cmx parsing/parsetree.cmi parsing/parse.cmx \
typing/outcometree.cmi driver/opterrors.cmx driver/optcompile.cmx \
typing/oprint.cmx utils/misc.cmx parsing/longident.cmx \
parsing/location.cmx parsing/lexer.cmx bytecomp/lambda.cmx \
@@ -887,24 +894,22 @@ toplevel/topdirs.cmx: utils/warnings.cmx typing/types.cmx toplevel/trace.cmx \
parsing/longident.cmx typing/ident.cmx typing/env.cmx bytecomp/dll.cmx \
typing/ctype.cmx utils/consistbl.cmx utils/config.cmx \
bytecomp/cmo_format.cmi utils/clflags.cmx toplevel/topdirs.cmi
-toplevel/toploop.cmo: utils/warnings.cmi typing/unused_var.cmi \
- typing/types.cmi typing/typemod.cmi typing/typedtree.cmi \
- typing/typecore.cmi bytecomp/translmod.cmi bytecomp/symtable.cmi \
- bytecomp/simplif.cmi typing/printtyp.cmi bytecomp/printlambda.cmi \
- bytecomp/printinstr.cmi parsing/printast.cmi typing/predef.cmi \
- typing/path.cmi parsing/parsetree.cmi parsing/parse.cmi \
+toplevel/toploop.cmo: utils/warnings.cmi typing/types.cmi typing/typemod.cmi \
+ typing/typedtree.cmi typing/typecore.cmi bytecomp/translmod.cmi \
+ bytecomp/symtable.cmi bytecomp/simplif.cmi typing/printtyp.cmi \
+ bytecomp/printlambda.cmi bytecomp/printinstr.cmi parsing/printast.cmi \
+ typing/predef.cmi typing/path.cmi parsing/parsetree.cmi parsing/parse.cmi \
typing/outcometree.cmi typing/oprint.cmi utils/misc.cmi bytecomp/meta.cmi \
parsing/longident.cmi parsing/location.cmi parsing/lexer.cmi \
typing/ident.cmi toplevel/genprintval.cmi driver/errors.cmi \
typing/env.cmi bytecomp/emitcode.cmi bytecomp/dll.cmi utils/consistbl.cmi \
utils/config.cmi driver/compile.cmi utils/clflags.cmi \
bytecomp/bytegen.cmi typing/btype.cmi toplevel/toploop.cmi
-toplevel/toploop.cmx: utils/warnings.cmx typing/unused_var.cmx \
- typing/types.cmx typing/typemod.cmx typing/typedtree.cmx \
- typing/typecore.cmx bytecomp/translmod.cmx bytecomp/symtable.cmx \
- bytecomp/simplif.cmx typing/printtyp.cmx bytecomp/printlambda.cmx \
- bytecomp/printinstr.cmx parsing/printast.cmx typing/predef.cmx \
- typing/path.cmx parsing/parsetree.cmi parsing/parse.cmx \
+toplevel/toploop.cmx: utils/warnings.cmx typing/types.cmx typing/typemod.cmx \
+ typing/typedtree.cmx typing/typecore.cmx bytecomp/translmod.cmx \
+ bytecomp/symtable.cmx bytecomp/simplif.cmx typing/printtyp.cmx \
+ bytecomp/printlambda.cmx bytecomp/printinstr.cmx parsing/printast.cmx \
+ typing/predef.cmx typing/path.cmx parsing/parsetree.cmi parsing/parse.cmx \
typing/outcometree.cmi typing/oprint.cmx utils/misc.cmx bytecomp/meta.cmx \
parsing/longident.cmx parsing/location.cmx parsing/lexer.cmx \
typing/ident.cmx toplevel/genprintval.cmx driver/errors.cmx \
diff --git a/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml b/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml
index 9e3a83ddb..0200d1896 100644
--- a/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml
+++ b/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml
@@ -880,13 +880,6 @@ value varify_constructors var_names =
in
let vars = id_to_string vs in
let ampersand_vars = List.map (fun x -> "&" ^ x) vars in
- let rec merge_quoted_vars lst =
- match lst with
- [
- [x] -> x
- | [x::y] -> <:ctyp<$x$ $merge_quoted_vars y$ >>
- | [] -> assert False ]
- in
let ty' = varify_constructors vars (ctyp ty) in
let mkexp = mkexp _loc in
let mkpat = mkpat _loc in
diff --git a/camlp4/Camlp4/Struct/Grammar/Insert.ml b/camlp4/Camlp4/Struct/Grammar/Insert.ml
index 551ce95ec..24deb01f5 100644
--- a/camlp4/Camlp4/Struct/Grammar/Insert.ml
+++ b/camlp4/Camlp4/Struct/Grammar/Insert.ml
@@ -256,10 +256,6 @@ module Make (Structure : Structure.S) = struct
Some t
| None -> None ]
| LocAct _ _ | DeadEnd -> None ]
- and insert_new =
- fun
- [ [s :: sl] -> Node {node = s; son = insert_new sl; brother = DeadEnd}
- | [] -> LocAct action [] ]
in
insert gsymbols tree
;
diff --git a/driver/compile.ml b/driver/compile.ml
index 33a198ed8..a27ffaa19 100644
--- a/driver/compile.ml
+++ b/driver/compile.ml
@@ -126,7 +126,6 @@ let implementation ppf sourcefile outputprefix =
try
Pparse.file ppf inputfile Parse.implementation ast_impl_magic_number
++ print_if ppf Clflags.dump_parsetree Printast.implementation
- ++ Unused_var.warn ppf
++ Typemod.type_implementation sourcefile outputprefix modulename env
++ Translmod.transl_implementation modulename
++ print_if ppf Clflags.dump_rawlambda Printlambda.lambda
diff --git a/driver/optcompile.ml b/driver/optcompile.ml
index ada7d9f71..1e6ab0ce3 100644
--- a/driver/optcompile.ml
+++ b/driver/optcompile.ml
@@ -119,12 +119,10 @@ let implementation ppf sourcefile outputprefix =
if !Clflags.print_types then ignore(
Pparse.file ppf inputfile Parse.implementation ast_impl_magic_number
++ print_if ppf Clflags.dump_parsetree Printast.implementation
- ++ Unused_var.warn ppf
++ Typemod.type_implementation sourcefile outputprefix modulename env)
else begin
Pparse.file ppf inputfile Parse.implementation ast_impl_magic_number
++ print_if ppf Clflags.dump_parsetree Printast.implementation
- ++ Unused_var.warn ppf
++ Typemod.type_implementation sourcefile outputprefix modulename env
++ Translmod.transl_store_implementation modulename
+++ print_if ppf Clflags.dump_rawlambda Printlambda.lambda
diff --git a/otherlibs/labltk/browser/.depend b/otherlibs/labltk/browser/.depend
index 4438a1dd8..5e3e2a2b8 100644
--- a/otherlibs/labltk/browser/.depend
+++ b/otherlibs/labltk/browser/.depend
@@ -10,10 +10,14 @@ 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
+help.cmo:
+help.cmx:
jg_bind.cmo: jg_bind.cmi
jg_bind.cmx: jg_bind.cmi
jg_box.cmo: jg_completion.cmi jg_bind.cmi
jg_box.cmx: jg_completion.cmx jg_bind.cmx
+jg_button.cmo:
+jg_button.cmx:
jg_completion.cmo: jg_completion.cmi
jg_completion.cmx: jg_completion.cmi
jg_config.cmo: jg_tk.cmo jg_config.cmi
@@ -22,6 +26,8 @@ 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_menu.cmo:
+jg_menu.cmx:
jg_message.cmo: jg_toplevel.cmo jg_tk.cmo jg_text.cmi jg_bind.cmi \
jg_message.cmi
jg_message.cmx: jg_toplevel.cmx jg_tk.cmx jg_text.cmx jg_bind.cmx \
@@ -30,8 +36,14 @@ 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
+jg_tk.cmo:
+jg_tk.cmx:
+jg_toplevel.cmo:
+jg_toplevel.cmx:
lexical.cmo: jg_tk.cmo lexical.cmi
lexical.cmx: jg_tk.cmx lexical.cmi
+list2.cmo:
+list2.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 \
@@ -62,5 +74,24 @@ 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
+dummy.cmi:
+dummyUnix.cmi:
+dummyWin.cmi:
+editor.cmi:
+fileselect.cmi:
+jg_bind.cmi:
+jg_completion.cmi:
+jg_config.cmi:
+jg_memo.cmi:
+jg_message.cmi:
+jg_multibox.cmi:
+jg_text.cmi:
+lexical.cmi:
mytypes.cmi: shell.cmi
+searchid.cmi:
+searchpos.cmi:
+setpath.cmi:
+shell.cmi:
typecheck.cmi: mytypes.cmi
+useunix.cmi:
+viewer.cmi:
diff --git a/toplevel/opttoploop.ml b/toplevel/opttoploop.ml
index aa40840f0..1fa5a3fd0 100644
--- a/toplevel/opttoploop.ml
+++ b/toplevel/opttoploop.ml
@@ -225,7 +225,6 @@ let execute_phrase print_outcome ppf phr =
incr phrase_seqid;
phrase_name := Printf.sprintf "TOP%i" !phrase_seqid;
Compilenv.reset ?packname:None !phrase_name;
- let _ = Unused_var.warn ppf sstr in
Typecore.reset_delayed_checks ();
let (str, sg, newenv) = Typemod.type_structure oldenv sstr Location.none
in
diff --git a/toplevel/toploop.ml b/toplevel/toploop.ml
index c7c626169..3d2f72f20 100644
--- a/toplevel/toploop.ml
+++ b/toplevel/toploop.ml
@@ -217,7 +217,6 @@ let execute_phrase print_outcome ppf phr =
match phr with
| Ptop_def sstr ->
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 Location.none
in
diff --git a/typing/env.ml b/typing/env.ml
index 08597341e..64a8963e1 100644
--- a/typing/env.ml
+++ b/typing/env.ml
@@ -22,6 +22,17 @@ open Path
open Types
open Btype
+let add_delayed_check_forward = ref (fun _ -> assert false)
+
+let value_declarations : ((string * Location.t), (unit -> unit)) Hashtbl.t = Hashtbl.create 16
+ (* This table is used to usage of value declarations. A declaration is
+ identified with its name and location. The callback attached to a declaration
+ is called whenever the value is used explicitly (lookup_value) or implicitly
+ (inclusion test between signatures, cf Includemod.value_descriptions). *)
+
+let type_declarations = Hashtbl.create 16
+
+let used_constructors : (string * Location.t * string, (unit -> unit)) Hashtbl.t = Hashtbl.create 16
type error =
Not_an_interface of string
@@ -44,18 +55,53 @@ type summary =
| Env_cltype of summary * Ident.t * cltype_declaration
| Env_open of summary * Path.t
+module EnvTbl =
+ struct
+ (* A table indexed by identifier, with an extra slot to record usage. *)
+ type 'a t = 'a Ident.tbl * bool ref Ident.tbl
+
+ let empty = (Ident.empty, Ident.empty)
+ let current_slot = ref (ref true)
+
+ let add id x (tbl, slots) =
+ let slot = !current_slot in
+ let slots = if !slot then slots else Ident.add id slot slots in
+ Ident.add id x tbl, slots
+
+ let find_same_not_using id (tbl, _) =
+ Ident.find_same id tbl
+
+ let find_same id (tbl, slots) =
+ (try Ident.find_same id slots := true with Not_found -> ());
+ Ident.find_same id tbl
+
+ let find_name s (tbl, slots) =
+ (try Ident.find_name s slots := true with Not_found -> ());
+ Ident.find_name s tbl
+
+ let with_slot slot f x =
+ let old_slot = !current_slot in
+ current_slot := slot;
+ try_finally
+ (fun () -> f x)
+ (fun () -> current_slot := old_slot)
+
+ let keys (tbl, _) =
+ Ident.keys tbl
+ end
+
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;
- constrs_by_path: (Path.t * (constructor_description list)) Ident.tbl;
- types: (Path.t * type_declaration) Ident.tbl;
- modules: (Path.t * module_type) Ident.tbl;
- modtypes: (Path.t * modtype_declaration) Ident.tbl;
- components: (Path.t * module_components) Ident.tbl;
- classes: (Path.t * class_declaration) Ident.tbl;
- cltypes: (Path.t * cltype_declaration) Ident.tbl;
+ values: (Path.t * value_description) EnvTbl.t;
+ annotations: (Path.t * Annot.ident) EnvTbl.t;
+ constrs: constructor_description EnvTbl.t;
+ labels: label_description EnvTbl.t;
+ constrs_by_path: (Path.t * (constructor_description list)) EnvTbl.t;
+ types: (Path.t * type_declaration) EnvTbl.t;
+ modules: (Path.t * module_type) EnvTbl.t;
+ modtypes: (Path.t * modtype_declaration) EnvTbl.t;
+ components: (Path.t * module_components) EnvTbl.t;
+ classes: (Path.t * class_declaration) EnvTbl.t;
+ cltypes: (Path.t * cltype_declaration) EnvTbl.t;
summary: summary;
local_constraints: bool;
gadt_instances: (int * TypeSet.t ref) list;
@@ -92,20 +138,20 @@ and functor_components = {
}
let empty = {
- values = Ident.empty; annotations = Ident.empty; constrs = Ident.empty;
- labels = Ident.empty; types = Ident.empty;
- constrs_by_path = Ident.empty;
- modules = Ident.empty; modtypes = Ident.empty;
- components = Ident.empty; classes = Ident.empty;
- cltypes = Ident.empty;
+ values = EnvTbl.empty; annotations = EnvTbl.empty; constrs = EnvTbl.empty;
+ labels = EnvTbl.empty; types = EnvTbl.empty;
+ constrs_by_path = EnvTbl.empty;
+ modules = EnvTbl.empty; modtypes = EnvTbl.empty;
+ components = EnvTbl.empty; classes = EnvTbl.empty;
+ cltypes = EnvTbl.empty;
summary = Env_empty; local_constraints = false; gadt_instances = [] }
let diff_keys is_local tbl1 tbl2 =
- let keys2 = Ident.keys tbl2 in
+ let keys2 = EnvTbl.keys tbl2 in
List.filter
(fun id ->
- is_local (Ident.find_same id tbl2) &&
- try ignore (Ident.find_same id tbl1); false with Not_found -> true)
+ is_local (EnvTbl.find_same_not_using id tbl2) &&
+ try ignore (EnvTbl.find_same_not_using id tbl1); false with Not_found -> true)
keys2
let is_ident = function
@@ -224,7 +270,9 @@ let find_pers_struct name =
let reset_cache () =
current_unit := "";
Hashtbl.clear persistent_structures;
- Consistbl.clear crc_units
+ Consistbl.clear crc_units;
+ Hashtbl.clear value_declarations;
+ Hashtbl.clear type_declarations
let set_unit_name name =
current_unit := name
@@ -235,7 +283,7 @@ let rec find_module_descr path env =
match path with
Pident id ->
begin try
- let (p, desc) = Ident.find_same id env.components
+ let (p, desc) = EnvTbl.find_same id env.components
in desc
with Not_found ->
if Ident.persistent id
@@ -261,7 +309,7 @@ let rec find_module_descr path env =
let find proj1 proj2 path env =
match path with
Pident id ->
- let (p, data) = Ident.find_same id (proj1 env)
+ let (p, data) = EnvTbl.find_same id (proj1 env)
in data
| Pdot(p, s, pos) ->
begin match Lazy.force(find_module_descr p env) with
@@ -323,7 +371,7 @@ let find_module path env =
match path with
Pident id ->
begin try
- let (p, data) = Ident.find_same id env.modules
+ let (p, data) = EnvTbl.find_same id env.modules
in data
with Not_found ->
if Ident.persistent id then
@@ -347,7 +395,7 @@ let rec lookup_module_descr lid env =
match lid with
Lident s ->
begin try
- Ident.find_name s env.components
+ EnvTbl.find_name s env.components
with Not_found ->
if s = !current_unit then raise Not_found;
let ps = find_pers_struct s in
@@ -377,7 +425,7 @@ and lookup_module lid env =
match lid with
Lident s ->
begin try
- Ident.find_name s env.modules
+ EnvTbl.find_name s env.modules
with Not_found ->
if s = !current_unit then raise Not_found;
let ps = find_pers_struct s in
@@ -408,7 +456,7 @@ and lookup_module lid env =
let lookup proj1 proj2 lid env =
match lid with
Lident s ->
- Ident.find_name s (proj1 env)
+ EnvTbl.find_name s (proj1 env)
| Ldot(l, s) ->
let (p, desc) = lookup_module_descr l env in
begin match Lazy.force desc with
@@ -424,7 +472,7 @@ let lookup proj1 proj2 lid env =
let lookup_simple proj1 proj2 lid env =
match lid with
Lident s ->
- Ident.find_name s (proj1 env)
+ EnvTbl.find_name s (proj1 env)
| Ldot(l, s) ->
let (p, desc) = lookup_module_descr l env in
begin match Lazy.force desc with
@@ -456,6 +504,82 @@ and lookup_class =
and lookup_cltype =
lookup (fun env -> env.cltypes) (fun sc -> sc.comp_cltypes)
+let mark_value_used name vd =
+ try Hashtbl.find value_declarations (name, vd.val_loc) ()
+ with Not_found -> ()
+
+let mark_type_used name vd =
+ try Hashtbl.find type_declarations (name, vd.type_loc) ()
+ with Not_found -> ()
+
+let mark_constructor_used name vd constr =
+ try Hashtbl.find used_constructors (name, vd.type_loc, constr) ()
+ with Not_found -> ()
+
+let set_value_used_callback name vd callback =
+ let key = (name, vd.val_loc) in
+ try
+ let old = Hashtbl.find value_declarations key in
+ Hashtbl.replace value_declarations key (fun () -> old (); callback ())
+ (* this is to support cases like:
+ let x = let x = 1 in x in x
+ where the two declarations have the same location
+ (e.g. resulting from Camlp4 expansion of grammar entries) *)
+ with Not_found ->
+ Hashtbl.add value_declarations key callback
+
+let set_type_used_callback name td callback =
+ let old = try Hashtbl.find type_declarations (name, td.type_loc) with Not_found -> assert false in
+ Hashtbl.replace type_declarations (name, td.type_loc) (fun () -> callback old)
+
+let lookup_value lid env =
+ let (_, desc) as r = lookup_value lid env in
+ mark_value_used (Longident.last lid) desc;
+ r
+
+let lookup_type lid env =
+ let (_, desc) as r = lookup_type lid env in
+ mark_type_used (Longident.last lid) desc;
+ r
+
+let mark_type_path env path =
+ let decl = try find_type path env with Not_found -> assert false in
+ mark_type_used (Path.last path) decl
+
+let ty_path = function
+ | {desc=Tconstr(path, _, _)} -> path
+ | _ -> assert false
+
+let lookup_constructor lid env =
+ let desc = lookup_constructor lid env in
+ mark_type_path env (ty_path desc.cstr_res);
+ desc
+
+let mark_constructor env name desc =
+ let ty_path = ty_path desc.cstr_res in
+ let ty_decl = try find_type ty_path env with Not_found -> assert false in
+ let ty_name = Path.last ty_path in
+ mark_constructor_used ty_name ty_decl name
+
+let lookup_label lid env =
+ let desc = lookup_label lid env in
+ mark_type_path env (ty_path desc.lbl_res);
+ desc
+
+let lookup_class lid env =
+ let (_, desc) as r = lookup_class lid env in
+ (* special support for Typeclass.unbound_class *)
+ if Path.name desc.cty_path = "" then ignore (lookup_type lid env)
+ else mark_type_path env desc.cty_path;
+ r
+
+let lookup_cltype lid env =
+ let (_, desc) as r = lookup_cltype lid env in
+ if Path.name desc.clty_path = "" then ignore (lookup_type lid env)
+ else mark_type_path env desc.clty_path;
+ mark_type_path env desc.clty_path;
+ r
+
(* GADT instance tracking *)
let add_gadt_instance_level lv env =
@@ -676,38 +800,71 @@ let rec components_of_module env sub path mty =
(* Insertion of bindings by identifier + path *)
-and store_value id path decl env =
+and check_usage loc id warn tbl =
+ if not loc.Location.loc_ghost && Warnings.is_active (warn "") then begin
+ let name = Ident.name id in
+ let key = (name, loc) in
+ if Hashtbl.mem tbl key then ()
+ else let used = ref false in
+ Hashtbl.add tbl key (fun () -> used := true);
+ if not (name = "" || name.[0] = '_' || name.[0] = '#')
+ then
+ !add_delayed_check_forward
+ (fun () -> if not !used then Location.prerr_warning loc (warn name))
+ end;
+
+and store_value ?check id path decl env =
+ begin match check with Some f -> check_usage decl.val_loc id f value_declarations | None -> () end;
{ env with
- values = Ident.add id (path, decl) env.values;
+ values = EnvTbl.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 }
+ annotations = EnvTbl.add id (path, annot) env.annotations }
else env
and store_type id path info env =
+ let loc = info.type_loc in
+ check_usage loc id (fun s -> Warnings.Unused_type_declaration s) type_declarations;
let constructors = constructors_of_type path info in
- let labels = labels_of_type path info in
+ let labels = labels_of_type path info in
+
+ if not loc.Location.loc_ghost && Warnings.is_active (Warnings.Unused_constructor "") then begin
+ let ty = Ident.name id in
+ List.iter
+ (fun (c, _) ->
+ let k = (ty, loc, c) in
+ if not (Hashtbl.mem used_constructors k) then
+ let used = ref false in
+ Hashtbl.add used_constructors k (fun () -> used := true);
+ !add_delayed_check_forward
+ (fun () ->
+ if not !used then
+ Location.prerr_warning loc (Warnings.Unused_constructor c)
+ )
+ )
+ constructors
+ end;
{ env with
constrs =
List.fold_right
(fun (name, descr) constrs ->
- Ident.add (Ident.create name) descr constrs)
+ EnvTbl.add (Ident.create name) descr constrs)
constructors
env.constrs;
constrs_by_path =
- Ident.add id
+ EnvTbl.add id
(path,List.map snd constructors) env.constrs_by_path;
labels =
List.fold_right
(fun (name, descr) labels ->
- Ident.add (Ident.create name) descr labels)
+ EnvTbl.add (Ident.create name) descr labels)
labels
env.labels;
- types = Ident.add id (path, info) env.types;
+ types = EnvTbl.add id (path, info) env.types;
summary = Env_type(env.summary, id, info) }
and store_type_infos id path info env =
@@ -717,35 +874,35 @@ and store_type_infos id path info env =
keep track of type abbreviations (e.g. type t = float) in the
computation of label representations. *)
{ env with
- types = Ident.add id (path, info) env.types;
+ types = EnvTbl.add id (path, info) env.types;
summary = Env_type(env.summary, id, info) }
and store_exception id path decl env =
{ env with
- constrs = Ident.add id (Datarepr.exception_descr path decl) env.constrs;
+ constrs = EnvTbl.add id (Datarepr.exception_descr path decl) env.constrs;
summary = Env_exception(env.summary, id, decl) }
and store_module id path mty env =
{ env with
- modules = Ident.add id (path, mty) env.modules;
+ modules = EnvTbl.add id (path, mty) env.modules;
components =
- Ident.add id (path, components_of_module env Subst.identity path mty)
+ EnvTbl.add id (path, components_of_module env Subst.identity path mty)
env.components;
summary = Env_module(env.summary, id, mty) }
and store_modtype id path info env =
{ env with
- modtypes = Ident.add id (path, info) env.modtypes;
+ modtypes = EnvTbl.add id (path, info) env.modtypes;
summary = Env_modtype(env.summary, id, info) }
and store_class id path desc env =
{ env with
- classes = Ident.add id (path, desc) env.classes;
+ classes = EnvTbl.add id (path, desc) env.classes;
summary = Env_class(env.summary, id, desc) }
and store_cltype id path desc env =
{ env with
- cltypes = Ident.add id (path, desc) env.cltypes;
+ cltypes = EnvTbl.add id (path, desc) env.cltypes;
summary = Env_cltype(env.summary, id, desc) }
(* Compute the components of a functor application in a path. *)
@@ -770,8 +927,8 @@ let _ =
(* Insertion of bindings by identifier *)
-let add_value id desc env =
- store_value id (Pident id) desc env
+let add_value ?check id desc env =
+ store_value ?check id (Pident id) desc env
let add_annot id annot env =
store_annot id (Pident id) annot env
@@ -808,7 +965,7 @@ let add_local_constraint id info elv env =
let enter store_fun name data env =
let id = Ident.create name in (id, store_fun id (Pident id) data env)
-let enter_value = enter store_value
+let enter_value ?check = enter (store_value ?check)
and enter_type = enter store_type
and enter_exception = enter store_exception
and enter_module = enter store_module
@@ -873,6 +1030,18 @@ let open_pers_signature name env =
let ps = find_pers_struct name in
open_signature (Pident(Ident.create_persistent name)) ps.ps_sig env
+let open_signature ?(loc = Location.none) root sg env =
+ if not loc.Location.loc_ghost && Warnings.is_active (Warnings.Unused_open "") then begin
+ let used = ref false in
+ !add_delayed_check_forward
+ (fun () ->
+ if not !used then
+ Location.prerr_warning loc (Warnings.Unused_open (Path.name root))
+ );
+ EnvTbl.with_slot used (open_signature root sg) env
+ end else
+ open_signature root sg env
+
(* Read a signature from a file *)
let read_signature modname filename =
diff --git a/typing/env.mli b/typing/env.mli
index 4e822de83..9323047c3 100644
--- a/typing/env.mli
+++ b/typing/env.mli
@@ -60,7 +60,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_value: ?check:(string -> Warnings.t) -> 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
@@ -78,12 +78,12 @@ val add_signature: signature -> t -> t
(* Insertion of all fields of a signature, relative to the given path.
Used to implement open. *)
-val open_signature: Path.t -> signature -> t -> t
+val open_signature: ?loc:Location.t -> Path.t -> signature -> t -> t
val open_pers_signature: string -> t -> t
(* Insertion by name *)
-val enter_value: string -> value_description -> t -> Ident.t * t
+val enter_value: ?check:(string -> Warnings.t) -> string -> value_description -> t -> Ident.t * t
val enter_type: string -> type_declaration -> t -> Ident.t * t
val enter_exception: string -> exception_declaration -> t -> Ident.t * t
val enter_module: string -> module_type -> t -> Ident.t * t
@@ -152,6 +152,16 @@ open Format
val report_error: formatter -> error -> unit
+val mark_value_used: string -> value_description -> unit
+val mark_type_used: string -> type_declaration -> unit
+val mark_constructor_used: string -> type_declaration -> string -> unit
+val mark_constructor: t -> string -> constructor_description -> unit
+
+val set_value_used_callback: string -> value_description -> (unit -> unit) -> unit
+val set_type_used_callback: string -> type_declaration -> ((unit -> unit) -> unit) -> unit
+
(* Forward declaration to break mutual recursion with Includemod. *)
val check_modtype_inclusion:
(t -> module_type -> Path.t -> module_type -> unit) ref
+(* Forward declaration to break mutual recursion with Typecore. *)
+val add_delayed_check_forward: ((unit -> unit) -> unit) ref
diff --git a/typing/includecore.ml b/typing/includecore.ml
index 78348eb40..7f319af1f 100644
--- a/typing/includecore.ml
+++ b/typing/includecore.ml
@@ -206,6 +206,11 @@ let type_declarations env id decl1 decl2 =
let err = match (decl1.type_kind, decl2.type_kind) with
(_, Type_abstract) -> []
| (Type_variant cstrs1, Type_variant cstrs2) ->
+ let name = Ident.name id in
+ if decl1.type_private = Private || decl2.type_private = Public then
+ List.iter
+ (fun (c, _, _) -> Env.mark_constructor_used name decl1 c)
+ cstrs1;
compare_variants env decl1 decl2 1 cstrs1 cstrs2
| (Type_record(labels1,rep1), Type_record(labels2,rep2)) ->
let err = compare_records env decl1 decl2 1 labels1 labels2 in
diff --git a/typing/includemod.ml b/typing/includemod.ml
index 70112c7b2..644a4d9a1 100644
--- a/typing/includemod.ml
+++ b/typing/includemod.ml
@@ -51,6 +51,7 @@ exception Error of error list
(* Inclusion between value descriptions *)
let value_descriptions env cxt subst id vd1 vd2 =
+ Env.mark_value_used (Ident.name id) vd1;
let vd2 = Subst.value_description subst vd2 in
try
Includecore.value_descriptions env vd1 vd2
@@ -60,6 +61,7 @@ let value_descriptions env cxt subst id vd1 vd2 =
(* Inclusion between type declarations *)
let type_declarations env cxt subst id decl1 decl2 =
+ Env.mark_type_used (Ident.name id) decl1;
let decl2 = Subst.type_declaration subst decl2 in
let err = Includecore.type_declarations env id decl1 decl2 in
if err <> [] then raise(Error[cxt, Type_declarations(id, decl1, decl2, err)])
diff --git a/typing/path.ml b/typing/path.ml
index b4c1b16ad..7dc821a1e 100644
--- a/typing/path.ml
+++ b/typing/path.ml
@@ -49,3 +49,8 @@ let rec head = function
Pident id -> id
| Pdot(p, s, pos) -> head p
| Papply(p1, p2) -> assert false
+
+let rec last = function
+ | Pident id -> Ident.name id
+ | Pdot(_, s, _) -> s
+ | Papply(_, p) -> last p
diff --git a/typing/path.mli b/typing/path.mli
index a76f7e1a9..bdcc6ccab 100644
--- a/typing/path.mli
+++ b/typing/path.mli
@@ -28,3 +28,5 @@ val nopos: int
val name: ?paren:(string -> bool) -> t -> string
(* [paren] tells whether a path suffix needs parentheses *)
val head: t -> Ident.t
+
+val last: t -> string
diff --git a/typing/typeclass.ml b/typing/typeclass.ml
index 0364de9bf..512f7cf8b 100644
--- a/typing/typeclass.ml
+++ b/typing/typeclass.ml
@@ -192,13 +192,13 @@ let rc node =
(* Enter a value in the method environment only *)
-let enter_met_env lab kind ty val_env met_env par_env =
+let enter_met_env ?check loc lab kind ty val_env met_env par_env =
let (id, val_env) =
- Env.enter_value lab {val_type = ty; val_kind = Val_unbound; val_loc = Location.none} val_env
+ Env.enter_value lab {val_type = ty; val_kind = Val_unbound; val_loc = loc} val_env
in
(id, val_env,
- Env.add_value id {val_type = ty; val_kind = kind; val_loc = Location.none} met_env,
- Env.add_value id {val_type = ty; val_kind = Val_unbound; val_loc = Location.none} par_env)
+ Env.add_value ?check id {val_type = ty; val_kind = kind; val_loc = loc} met_env,
+ Env.add_value id {val_type = ty; val_kind = Val_unbound; val_loc = loc} par_env)
(* Enter an instance variable in the environment *)
let enter_val cl_num vars inh lab mut virt ty val_env met_env par_env loc =
@@ -218,7 +218,7 @@ let enter_val cl_num vars inh lab mut virt ty val_env met_env par_env loc =
let (id, _, _, _) as result =
match id with Some id -> (id, val_env, met_env, par_env)
| None ->
- enter_met_env lab (Val_ivar (mut, cl_num)) ty val_env met_env par_env
+ enter_met_env Location.none lab (Val_ivar (mut, cl_num)) ty val_env met_env par_env
in
vars := Vars.add lab (id, mut, virt, ty) !vars;
result
@@ -462,7 +462,8 @@ let rec class_field cl_num self_type meths vars
(val_env, met_env, par_env)
| Some name ->
let (id, val_env, met_env, par_env) =
- enter_met_env name (Val_anc (inh_meths, cl_num)) self_type
+ enter_met_env ~check:(fun s -> Warnings.Unused_ancestor s)
+ sparent.pcl_loc name (Val_anc (inh_meths, cl_num)) self_type
val_env met_env par_env
in
(val_env, met_env, par_env)
@@ -772,10 +773,16 @@ and class_expr cl_num val_env met_env scl =
let pv =
List.map
(function (id, id', ty) ->
+ let path = Pident id' in
+ let vd = Env.find_value path val_env' (* do not mark the value as being used *) in
(id,
- Typecore.type_exp val_env'
- {pexp_desc = Pexp_ident (Longident.Lident (Ident.name id));
- pexp_loc = Location.none}))
+ {
+ exp_desc = Texp_ident(path, vd);
+ exp_loc = Location.none;
+ exp_type = Ctype.instance val_env' vd.val_type;
+ exp_env = val_env'
+ })
+ )
pv
in
let rec not_function = function
@@ -900,18 +907,23 @@ and class_expr cl_num val_env met_env scl =
let (vals, met_env) =
List.fold_right
(fun id (vals, met_env) ->
+ let path = Pident id in
+ let vd = Env.find_value path val_env in (* do not mark the value as used *)
Ctype.begin_def ();
let expr =
- Typecore.type_exp val_env
- {pexp_desc = Pexp_ident (Longident.Lident (Ident.name id));
- pexp_loc = Location.none}
+ {
+ exp_desc = Texp_ident(path, vd);
+ exp_loc = Location.none;
+ exp_type = Ctype.instance val_env vd.val_type;
+ exp_env = val_env;
+ }
in
Ctype.end_def ();
Ctype.generalize expr.exp_type;
let desc =
{val_type = expr.exp_type; val_kind = Val_ivar (Immutable,
cl_num);
- val_loc = Location.none;
+ val_loc = vd.val_loc;
}
in
let id' = Ident.create (Ident.name id) in
@@ -981,7 +993,7 @@ let rec approx_description ct =
(*******************************)
-let temp_abbrev env id arity =
+let temp_abbrev loc env id arity =
let params = ref [] in
for i = 1 to arity do
params := Ctype.newvar () :: !params
@@ -996,7 +1008,7 @@ let temp_abbrev env id arity =
type_manifest = Some ty;
type_variance = List.map (fun _ -> true, true, true) !params;
type_newtype_level = None;
- type_loc = Location.none;
+ type_loc = loc;
}
env
in
@@ -1006,8 +1018,8 @@ let rec initial_env define_class approx
(res, env) (cl, id, ty_id, obj_id, cl_id) =
(* Temporary abbreviations *)
let arity = List.length (fst cl.pci_params) in
- let (obj_params, obj_ty, env) = temp_abbrev env obj_id arity in
- let (cl_params, cl_ty, env) = temp_abbrev env cl_id arity in
+ let (obj_params, obj_ty, env) = temp_abbrev cl.pci_loc env obj_id arity in
+ let (cl_params, cl_ty, env) = temp_abbrev cl.pci_loc env cl_id arity in
(* Temporary type for the class constructor *)
let constr_type = approx cl.pci_expr in
diff --git a/typing/typecore.ml b/typing/typecore.ml
index 1db16e0c9..9a7a1d849 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -242,7 +242,7 @@ let has_variants p =
(* pattern environment *)
-let pattern_variables = ref ([]: (Ident.t * type_expr * Location.t) list)
+let pattern_variables = ref ([]: (Ident.t * type_expr * Location.t * bool (* as-variable *)) list)
let pattern_force = ref ([] : (unit -> unit) list)
let pattern_scope = ref (None : Annot.ident option);;
let allow_modules = ref false
@@ -255,11 +255,11 @@ let reset_pattern scope allow =
module_variables := [];
;;
-let enter_variable ?(is_module=false) loc name ty =
- if List.exists (fun (id, _, _) -> Ident.name id = name) !pattern_variables
+let enter_variable ?(is_module=false) ?(is_as_variable=false) loc name ty =
+ if List.exists (fun (id, _, _, _) -> Ident.name id = name) !pattern_variables
then raise(Error(loc, Multiply_bound_variable name));
let id = Ident.create name in
- pattern_variables := (id, ty, loc) :: !pattern_variables;
+ pattern_variables := (id, ty, loc, is_as_variable) :: !pattern_variables;
if is_module then begin
(* Note: unpack patterns enter a variable of the same name *)
if not !allow_modules then raise (Error (loc, Modules_not_allowed));
@@ -273,7 +273,7 @@ let enter_variable ?(is_module=false) loc name ty =
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 =
@@ -283,7 +283,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,l1)::rem1, (x2,t2,l2)::rem2 when Ident.equal x1 x2 ->
+ | (x1,t1,l1,a1)::rem1, (x2,t2,l2,a2)::rem2 when Ident.equal x1 x2 ->
if x1==x2 then
unify_vars rem1 rem2
else begin
@@ -296,9 +296,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
@@ -537,7 +537,7 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty =
let ty_var = build_as_type !env q in
end_def ();
generalize ty_var;
- let id = enter_variable loc name ty_var in
+ let id = enter_variable ~is_as_variable:true loc name ty_var in
rp {
pat_desc = Tpat_alias(q, id);
pat_loc = loc;
@@ -735,15 +735,12 @@ let rec iter3 f lst1 lst2 lst3 =
| _ ->
assert false
-let get_ref r =
- let v = !r in
- r := []; v
-
-let add_pattern_variables env =
+let add_pattern_variables ?check ?check_as env =
let pv = get_ref pattern_variables in
(List.fold_right
- (fun (id, ty, loc) env ->
- let e1 = Env.add_value id {val_type = ty; val_kind = Val_reg; val_loc = loc} env in
+ (fun (id, ty, loc, as_var) env ->
+ let check = if as_var then check_as else check in
+ let e1 = Env.add_value ?check id {val_type = ty; val_kind = Val_reg; val_loc = loc} env in
Env.add_annot id (Annot.Iref_internal loc) e1
)
pv env,
@@ -753,7 +750,7 @@ let type_pattern ~lev env spat scope expected_ty =
reset_pattern scope true;
let new_env = ref env in
let pat = type_pat ~allow_existentials:true ~lev new_env spat expected_ty in
- let new_env, unpacks = add_pattern_variables !new_env in
+ let new_env, unpacks = add_pattern_variables ~check:(fun s -> Warnings.Unused_var_strict s) ~check_as:(fun s -> Warnings.Unused_var s) !new_env in
(pat, new_env, get_ref pattern_force, unpacks)
let type_pattern_list env spatl scope expected_tys allow =
@@ -775,13 +772,14 @@ 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, loc) (pv, env) ->
+ (fun (id, ty, loc, as_var) (pv, env) ->
+ let check s = if as_var then Warnings.Unused_var s else Warnings.Unused_var_strict s in
let id' = Ident.create (Ident.name id) in
((id', id, ty)::pv,
Env.add_value id' {val_type = ty;
val_kind = Val_ivar (Immutable, cl_num);
val_loc = loc;
- }
+ } ~check
env))
!pattern_variables ([], met_env)
in
@@ -805,7 +803,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, loc) (val_env, met_env, par_env) ->
+ (fun (id, ty, loc, as_var) (val_env, met_env, par_env) ->
(Env.add_value id {val_type = ty;
val_kind = Val_unbound;
val_loc = loc;
@@ -814,6 +812,7 @@ let type_self_pattern cl_num privty val_env met_env par_env spat =
val_kind = Val_self (meths, vars, cl_num, privty);
val_loc = loc;
}
+ ~check:(fun s -> if as_var then Warnings.Unused_var s else Warnings.Unused_var_strict s)
met_env,
Env.add_value id {val_type = ty; val_kind = Val_unbound;
val_loc = loc;
@@ -1282,6 +1281,7 @@ let duplicate_ident_types loc caselist env =
List.fold_left
(fun env s ->
try
+ (* XXX This will mark the value as being used; I don't think this is what we want *)
let (path, desc) = Typetexp.find_value env loc (Longident.Lident s) in
match path with
Path.Pident id ->
@@ -1708,7 +1708,9 @@ and type_expect ?in_function env sexp ty_expected =
Env.enter_value param {val_type = instance_def Predef.type_int;
val_kind = Val_reg;
val_loc = loc;
- } env in
+ } env
+ ~check:(fun s -> Warnings.Unused_for_index s)
+ in
let body = type_statement new_env sbody in
rue {
exp_desc = Texp_for(id, low, high, dir, body);
@@ -2437,6 +2439,7 @@ and type_application env funct sargs =
and type_construct env loc lid sarg explicit_arity ty_expected =
let constr = Typetexp.find_constructor env loc lid in
+ Env.mark_constructor env (Longident.last lid) constr;
let sargs =
match sarg with
None -> []
@@ -2612,9 +2615,19 @@ and type_cases ?in_function env ty_arg ty_res partial_flag loc caselist =
(* Typing of let bindings *)
-and type_let env rec_flag spat_sexp_list scope allow =
+and type_let ?(check = fun s -> Warnings.Unused_var s) ?(check_strict = fun s -> Warnings.Unused_var_strict s) env rec_flag spat_sexp_list scope allow =
begin_def();
if !Clflags.principal then begin_def ();
+
+ let is_fake_let =
+ match spat_sexp_list with
+ | [_, {pexp_desc=Pexp_match({pexp_desc=Pexp_ident(Longident.Lident "*opt*")},_)}] ->
+ true (* the fake let-declaration introduced by fun ?(x = e) -> ... *)
+ | _ ->
+ false
+ in
+ let check = if is_fake_let then check_strict else check in
+
let spatl =
List.map
(fun (spat, sexp) ->
@@ -2633,7 +2646,8 @@ and type_let env rec_flag spat_sexp_list scope allow =
let nvs = List.map (fun _ -> newvar ()) spatl in
let (pat_list, new_env, force, unpacks) =
type_pattern_list env spatl scope nvs allow in
- if rec_flag = Recursive then
+ let is_recursive = (rec_flag = Recursive) in
+ if is_recursive then
List.iter2
(fun pat (_, sexp) ->
let pat =
@@ -2664,12 +2678,67 @@ and type_let env rec_flag spat_sexp_list scope allow =
(* Only bind pattern variables after generalizing *)
List.iter (fun f -> f()) force;
let exp_env =
- match rec_flag with Nonrecursive | Default -> env | Recursive -> new_env in
+ if is_recursive then new_env else env in
+
+ let current_slot = ref None in
+ let warn_unused = Warnings.is_active (check "") || Warnings.is_active (check_strict "") in
+ let pat_slot_list =
+ (* Algorithm to detect unused declarations in recursive bindings:
+ - During type checking of the definitions, we capture the 'value_used'
+ events on the bound identifiers and record them in a slot corresponding
+ to the current definition (!current_slot). In effect, this creates a dependency
+ graph between definitions.
+
+ - After type checking the definition (!current_slot = Mone), when one of the bound identifier is
+ effectively used, we trigger again all the events recorded in the corresponding
+ slot. The effect is to traverse the transitive closure of the graph created
+ in the first step.
+
+ We also keep track of whether *all* variables in a given pattern are unused.
+ If this is the case, for local declarations, the issued warning is 26, not 27.
+ *)
+ List.map
+ (fun pat ->
+ if not warn_unused then pat, None
+ else
+ let some_used = ref false in (* has one of the identifier of this pattern been used? *)
+ let slot = ref [] in
+ List.iter
+ (fun id ->
+ let vd = Env.find_value (Path.Pident id) new_env in (* note: Env.find_value does not trigger the value_used event *)
+ let name = Ident.name id in
+ let used = ref false in
+ if not (name = "" || name.[0] = '_' || name.[0] = '#') then
+ add_delayed_check
+ (fun () ->
+ if not !used then
+ Location.prerr_warning vd.val_loc
+ ((if !some_used then check_strict else check) name)
+ );
+ Env.set_value_used_callback
+ name vd
+ (fun () ->
+ match !current_slot with
+ | Some slot -> slot := (name, vd) :: !slot
+ | None ->
+ List.iter
+ (fun (name, vd) -> Env.mark_value_used name vd)
+ (get_ref slot);
+ used := true;
+ some_used := true
+ )
+ )
+ (Typedtree.pat_bound_idents pat);
+ pat, Some slot
+ )
+ pat_list
+ in
let exp_list =
List.map2
- (fun (spat, sexp) pat ->
+ (fun (spat, sexp) (pat, slot) ->
let sexp =
if rec_flag = Recursive then wrap_unpacks sexp unpacks else sexp in
+ if is_recursive then current_slot := slot;
match pat.pat_type.desc with
| Tpoly (ty, tl) ->
begin_def ();
@@ -2684,7 +2753,8 @@ and type_let env rec_flag spat_sexp_list scope allow =
check_univars env true "definition" exp pat.pat_type vars;
{exp with exp_type = instance env exp.exp_type}
| _ -> type_expect exp_env sexp pat.pat_type)
- spat_sexp_list pat_list in
+ spat_sexp_list pat_slot_list in
+ current_slot := None;
List.iter2
(fun pat exp -> ignore(Parmatch.check_partial pat.pat_loc [pat, exp]))
pat_list exp_list;
@@ -2701,15 +2771,21 @@ and type_let env rec_flag spat_sexp_list scope allow =
(* Typing of toplevel bindings *)
+let type_binding env rec_flag spat_sexp_list scope =
+ Typetexp.reset_type_variables();
+ let (pat_exp_list, new_env, unpacks) =
+ type_let
+ ~check:(fun s -> Warnings.Unused_value_declaration s)
+ ~check_strict:(fun s -> Warnings.Unused_value_declaration s)
+ env rec_flag spat_sexp_list scope false
+ in
+ (pat_exp_list, new_env)
+
let type_let env rec_flag spat_sexp_list scope =
let (pat_exp_list, new_env, unpacks) =
type_let env rec_flag spat_sexp_list scope false in
(pat_exp_list, new_env)
-let type_binding env rec_flag spat_sexp_list scope =
- Typetexp.reset_type_variables();
- type_let env rec_flag spat_sexp_list scope
-
(* Typing of toplevel expressions *)
let type_expression env sexp =
@@ -2897,3 +2973,6 @@ let report_error ppf = function
| Unexpected_existential ->
fprintf ppf
"Unexpected existential"
+
+let () =
+ Env.add_delayed_check_forward := add_delayed_check
diff --git a/typing/typedecl.ml b/typing/typedecl.ml
index 7929a6143..315e066d1 100644
--- a/typing/typedecl.ml
+++ b/typing/typedecl.ml
@@ -749,8 +749,28 @@ let transl_type_decl env name_sdecl_list =
(* Enter types. *)
let temp_env = List.fold_left2 enter_type env name_sdecl_list id_list in
(* Translate each declaration. *)
- let decls =
- List.map2 (transl_declaration temp_env) name_sdecl_list id_list in
+ let current_slot = ref None in
+ let warn_unused = Warnings.is_active (Warnings.Unused_type_declaration "") in
+ let id_slots id =
+ if not warn_unused then id, None
+ else
+ (* See typecore.ml for a description of the algorithm used
+ to detect unused declarations in a set of recursive definitions. *)
+ let slot = ref [] in
+ let td = Env.find_type (Path.Pident id) temp_env in
+ let name = Ident.name id in
+ Env.set_type_used_callback
+ name td
+ (fun old_callback ->
+ match !current_slot with
+ | Some slot -> slot := (name, td) :: !slot
+ | None -> List.iter (fun (name, d) -> Env.mark_type_used name d) (get_ref slot); old_callback ()
+ );
+ id, Some slot
+ in
+ let transl_declaration name_sdecl (id, slot) = current_slot := slot; transl_declaration temp_env name_sdecl id in
+ let decls = List.map2 transl_declaration name_sdecl_list (List.map id_slots id_list) in
+ current_slot := None;
(* Check for duplicates *)
check_duplicates name_sdecl_list;
(* Build the final env. *)
diff --git a/typing/typedtree.mli b/typing/typedtree.mli
index dc87885a2..0c5efa8ea 100644
--- a/typing/typedtree.mli
+++ b/typing/typedtree.mli
@@ -161,6 +161,7 @@ val map_pattern_desc : (pattern -> pattern) -> pattern_desc -> pattern_desc
val let_bound_idents: (pattern * expression) list -> Ident.t list
val rev_let_bound_idents: (pattern * expression) list -> Ident.t list
+val pat_bound_idents: pattern -> Ident.t list
(* Alpha conversion of patterns *)
val alpha_pat : (Ident.t * Ident.t) list -> pattern -> pattern
diff --git a/typing/typemod.ml b/typing/typemod.ml
index f29c6bffb..506784865 100644
--- a/typing/typemod.ml
+++ b/typing/typemod.ml
@@ -62,7 +62,7 @@ let extract_sig_open env loc mty =
let type_open env loc lid =
let (path, mty) = Typetexp.find_module env loc lid in
let sg = extract_sig_open env loc mty in
- Env.open_signature path sg env
+ Env.open_signature ~loc path sg env
(* Record a module type *)
let rm node =
@@ -382,7 +382,7 @@ and transl_signature env sg =
match item.psig_desc with
| Psig_value(name, sdesc) ->
let desc = Typedecl.transl_value_decl env item.psig_loc sdesc in
- let (id, newenv) = Env.enter_value name desc env in
+ let (id, newenv) = Env.enter_value ~check:(fun s -> Warnings.Unused_value_declaration s) name desc env in
let rem = transl_sig newenv srem in
if List.exists (Ident.equal id) (get_values rem) then rem
else Tsig_value(id, desc) :: rem
@@ -816,6 +816,8 @@ and type_structure funct_body anchor env sstr scope =
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
+ (* Note: Env.find_value does not trigger the value_used event. Values
+ will be marked as being used during the signature inclusion test. *)
let make_sig_value id =
Tsig_value(id, Env.find_value (Pident id) newenv) in
(Tstr_value(rec_flag, defs) :: str_rem,
@@ -823,7 +825,7 @@ and type_structure funct_body anchor env sstr scope =
final_env)
| {pstr_desc = Pstr_primitive(name, sdesc); pstr_loc = loc} :: srem ->
let desc = Typedecl.transl_value_decl env loc sdesc in
- let (id, newenv) = Env.enter_value name desc env in
+ let (id, newenv) = Env.enter_value ~check:(fun s -> Warnings.Unused_value_declaration s) name desc env in
let (str_rem, sig_rem, final_env) = type_struct newenv srem in
(Tstr_primitive(id, desc) :: str_rem,
Tsig_value(id, desc) :: sig_rem,
@@ -1085,7 +1087,6 @@ let type_implementation sourcefile outputprefix modulename initial_env ast =
Typecore.reset_delayed_checks ();
let (str, sg, finalenv) = type_structure initial_env ast Location.none in
let simple_sg = simplify_signature sg in
- Typecore.force_delayed_checks ();
if !Clflags.print_types then begin
fprintf std_formatter "%a@." Printtyp.signature simple_sg;
(str, Tcoerce_none) (* result is ignored by Compile.implementation *)
@@ -1100,6 +1101,10 @@ let type_implementation sourcefile outputprefix modulename initial_env ast =
raise(Error(Location.none, Interface_not_compiled sourceintf)) in
let dclsig = Env.read_signature modulename intf_file in
let coercion = Includemod.compunit sourcefile sg intf_file dclsig in
+ Typecore.force_delayed_checks ();
+ (* It is important to run these checks after the inclusion test above,
+ so that value declarations which are not used internally but exported
+ are not reported as being unused. *)
(str, coercion)
end else begin
check_nongen_schemes finalenv str;
@@ -1107,6 +1112,11 @@ let type_implementation sourcefile outputprefix modulename initial_env ast =
let coercion =
Includemod.compunit sourcefile sg
"(inferred signature)" simple_sg in
+ Typecore.force_delayed_checks ();
+ (* See comment above. Here the target signature contains all
+ the value being exported. We can still capture unused
+ declarations like "let x = true;; let x = 1;;", because in this
+ case, the inferred signature contains only the last declaration. *)
if not !Clflags.dont_write_files then
Env.save_signature simple_sg modulename (outputprefix ^ ".cmi");
(str, coercion)
diff --git a/typing/unused_var.ml b/typing/unused_var.ml
index 21f731743..3a6eeaeb5 100644
--- a/typing/unused_var.ml
+++ b/typing/unused_var.ml
@@ -14,6 +14,8 @@
open Parsetree
+(* TODO: simpler implementation for free_idents *)
+
let silent v = String.length v > 0 && v.[0] = '_';;
let add_vars tbl (vll1, vll2) =
@@ -275,15 +277,6 @@ and class_field ppf tbl cf =
| Pcf_init e -> expression ppf tbl e;
;;
-let warn ppf ast =
- if Warnings.is_active (w_suspicious "") || Warnings.is_active (w_strict "")
- then begin
- let tbl = Hashtbl.create 97 in
- structure (Ppf ppf) tbl ast;
- end;
- ast
-;;
-
let free_idents e =
let tbl = Hashtbl.create 7 in
let idents = ref [] in
diff --git a/typing/unused_var.mli b/typing/unused_var.mli
index dc8137aef..957fac5d9 100644
--- a/typing/unused_var.mli
+++ b/typing/unused_var.mli
@@ -12,8 +12,5 @@
(* $Id$ *)
-val warn : Format.formatter -> Parsetree.structure -> Parsetree.structure;;
-(* Warn on unused variables; return the second argument. *)
-
val free_idents : Parsetree.expression -> string list
(* Conservatively approximate the free variables of an expression. *)
diff --git a/utils/misc.ml b/utils/misc.ml
index 0eab66dc5..c75ac3130 100644
--- a/utils/misc.ml
+++ b/utils/misc.ml
@@ -195,3 +195,7 @@ let rev_split_words s =
| _ -> split2 res i (j+1)
end
in split1 [] 0
+
+let get_ref r =
+ let v = !r in
+ r := []; v
diff --git a/utils/misc.mli b/utils/misc.mli
index fdb492656..f1b869086 100644
--- a/utils/misc.mli
+++ b/utils/misc.mli
@@ -102,3 +102,7 @@ val search_substring: string -> string -> int -> int
val rev_split_words: string -> string list
(* [rev_split_words s] splits [s] in blank-separated words, and return
the list of words in reverse order. *)
+
+val get_ref: 'a list ref -> 'a list
+ (* [get_ref lr] returns the content of the list reference [lr] and reset
+ its content to the empty list. *)
diff --git a/utils/warnings.ml b/utils/warnings.ml
index bcd5a3ce5..1f99b63c8 100644
--- a/utils/warnings.ml
+++ b/utils/warnings.ml
@@ -51,6 +51,12 @@ type t =
| Eol_in_string (* 29 *)
| Duplicate_definitions of string * string * string * string (*30 *)
| Multiple_definition of string * string * string (* 31 *)
+ | Unused_value_declaration of string (* 32 *)
+ | Unused_open of string (* 33 *)
+ | Unused_type_declaration of string (* 34 *)
+ | Unused_for_index of string (* 35 *)
+ | Unused_ancestor of string (* 36 *)
+ | Unused_constructor of string (* 37 *)
;;
(* If you remove a warning, leave a hole in the numbering. NEVER change
@@ -91,9 +97,15 @@ let number = function
| Eol_in_string -> 29
| Duplicate_definitions _ -> 30
| Multiple_definition _ -> 31
+ | Unused_value_declaration _ -> 32
+ | Unused_open _ -> 33
+ | Unused_type_declaration _ -> 34
+ | Unused_for_index _ -> 35
+ | Unused_ancestor _ -> 36
+ | Unused_constructor _ -> 37
;;
-let last_warning_number = 31;;
+let last_warning_number = 37;;
(* Must be the max number returned by the [number] function. *)
let letter = function
@@ -188,7 +200,7 @@ let parse_opt flags s =
let parse_options errflag s = parse_opt (if errflag then error else active) s;;
(* If you change these, don't forget to change them in man/ocamlc.m *)
-let defaults_w = "+a-4-6-7-9-27-29";;
+let defaults_w = "+a-4-6-7-9-27-29-32-33-34-35-36-37";;
let defaults_warn_error = "-a";;
let () = parse_options false defaults_w;;
@@ -266,6 +278,12 @@ let message = function
Printf.sprintf
"files %s and %s both define a module named %s"
file1 file2 modname
+ | Unused_value_declaration v -> "unused value " ^ v ^ "."
+ | Unused_open s -> "unused open " ^ s ^ "."
+ | Unused_type_declaration s -> "unused type " ^ s ^ "."
+ | Unused_for_index s -> "unused for-loop index " ^ s ^ "."
+ | Unused_ancestor s -> "unused ancestor variable " ^ s ^ "."
+ | Unused_constructor s -> "unused constructor " ^ s ^ "."
;;
let nerrors = ref 0;;
@@ -340,7 +358,13 @@ let descriptions =
29, "Unescaped end-of-line in a string constant (non-portable code).";
30, "Two labels or constructors of the same name are defined in two\n\
\ mutually recursive types.";
- 31, "A module is linked twice in the same executable";
+ 31, "A module is linked twice in the same executable.";
+ 32, "Unused value declaration.";
+ 33, "Unused open statement.";
+ 34, "Unused type declaration.";
+ 35, "Unused for-loop index.";
+ 36, "Unused ancestor variable.";
+ 37, "Unused constructor.";
]
;;
diff --git a/utils/warnings.mli b/utils/warnings.mli
index d9bd4a034..99c153ffd 100644
--- a/utils/warnings.mli
+++ b/utils/warnings.mli
@@ -46,6 +46,12 @@ type t =
| Eol_in_string (* 29 *)
| Duplicate_definitions of string * string * string * string (*30 *)
| Multiple_definition of string * string * string (* 31 *)
+ | Unused_value_declaration of string (* 32 *)
+ | Unused_open of string (* 33 *)
+ | Unused_type_declaration of string (* 34 *)
+ | Unused_for_index of string (* 35 *)
+ | Unused_ancestor of string (* 36 *)
+ | Unused_constructor of string (* 37 *)
;;
val parse_options : bool -> string -> unit;;
generated by cgit v1.2.3-70-g09d2 (git 2.46.0) at 2025-03-16 20:15:19 +0000