summaryrefslogtreecommitdiffstats
path: root/utils
diff options
context:
space:
mode:
Diffstat (limited to 'utils')
-rw-r--r--utils/clflags.ml7
-rw-r--r--utils/clflags.mli8
-rw-r--r--utils/config.mlbuild6
-rw-r--r--utils/config.mlp20
-rw-r--r--utils/consistbl.ml12
-rw-r--r--utils/consistbl.mli7
-rw-r--r--utils/misc.ml39
-rw-r--r--utils/misc.mli9
-rw-r--r--utils/warnings.ml92
-rw-r--r--utils/warnings.mli5
10 files changed, 115 insertions, 90 deletions
diff --git a/utils/clflags.ml b/utils/clflags.ml
index 829393a00..57834ccf9 100644
--- a/utils/clflags.ml
+++ b/utils/clflags.ml
@@ -43,12 +43,14 @@ and noprompt = ref false (* -noprompt *)
and nopromptcont = ref false (* -nopromptcont *)
and init_file = ref (None : string option) (* -init *)
and noinit = ref false (* -noinit *)
+and open_modules = ref [] (* -open *)
and use_prims = ref "" (* -use-prims ... *)
and use_runtime = ref "" (* -use-runtime ... *)
and principal = ref false (* -principal *)
and real_paths = ref true (* -short-paths *)
and recursive_types = ref false (* -rectypes *)
and strict_sequence = ref false (* -strict-sequence *)
+and strict_formats = ref false (* -strict-formats *)
and applicative_functors = ref true (* -no-app-funct *)
and make_runtime = ref false (* -make-runtime *)
and gprofile = ref false (* -p *)
@@ -58,6 +60,7 @@ and dllpaths = ref ([] : string list) (* -dllpath *)
and make_package = ref false (* -pack *)
and for_package = ref (None: string option) (* -for-pack *)
and error_size = ref 500 (* -error-size *)
+and float_const_prop = ref true (* -no-float-const-prop *)
and transparent_modules = ref false (* -trans-mod *)
let dump_source = ref false (* -dsource *)
let dump_parsetree = ref false (* -dparsetree *)
@@ -69,9 +72,11 @@ and dump_instr = ref false (* -dinstr *)
let keep_asm_file = ref false (* -S *)
let optimize_for_speed = ref true (* -compact *)
+and opaque = ref false (* -opaque *)
and dump_cmm = ref false (* -dcmm *)
let dump_selection = ref false (* -dsel *)
+let dump_cse = ref false (* -dcse *)
let dump_live = ref false (* -dlive *)
let dump_spill = ref false (* -dspill *)
let dump_split = ref false (* -dsplit *)
@@ -83,7 +88,6 @@ let dump_scheduling = ref false (* -dscheduling *)
let dump_linear = ref false (* -dlinear *)
let keep_startup_file = ref false (* -dstartup *)
let dump_combine = ref false (* -dcombine *)
-
let native_code = ref false (* set to true under ocamlopt *)
let inline_threshold = ref 10
let force_slash = ref false (* for ocamldep *)
@@ -105,3 +109,4 @@ let dlcode = ref true (* not -nodynlink *)
let runtime_variant = ref "";; (* -runtime-variant *)
let keep_locs = ref false (* -keep-locs *)
+let unsafe_string = ref true;; (* -safe-string / -unsafe-string *)
diff --git a/utils/clflags.mli b/utils/clflags.mli
index 876776acd..7e51cf33d 100644
--- a/utils/clflags.mli
+++ b/utils/clflags.mli
@@ -23,11 +23,12 @@ val debug : bool ref
val fast : bool ref
val link_everything : bool ref
val custom_runtime : bool ref
-val bytecode_compatible_32: bool ref
+val bytecode_compatible_32 : bool ref
val output_c_object : bool ref
val all_ccopts : string list ref
val classic : bool ref
val nopervasives : bool ref
+val open_modules : string list ref
val preprocessor : string option ref
val all_ppx : string list ref
val annotations : bool ref
@@ -46,6 +47,7 @@ val principal : bool ref
val real_paths : bool ref
val recursive_types : bool ref
val strict_sequence : bool ref
+val strict_formats : bool ref
val applicative_functors : bool ref
val make_runtime : bool ref
val gprofile : bool ref
@@ -55,6 +57,7 @@ val dllpaths : string list ref
val make_package : bool ref
val for_package : string option ref
val error_size : int ref
+val float_const_prop : bool ref
val transparent_modules : bool ref
val dump_source : bool ref
val dump_parsetree : bool ref
@@ -67,6 +70,7 @@ val keep_asm_file : bool ref
val optimize_for_speed : bool ref
val dump_cmm : bool ref
val dump_selection : bool ref
+val dump_cse : bool ref
val dump_live : bool ref
val dump_spill : bool ref
val dump_split : bool ref
@@ -88,3 +92,5 @@ val dlcode : bool ref
val runtime_variant : string ref
val force_slash : bool ref
val keep_locs : bool ref
+val unsafe_string : bool ref
+val opaque : bool ref
diff --git a/utils/config.mlbuild b/utils/config.mlbuild
index 524558b16..c887ac2b4 100644
--- a/utils/config.mlbuild
+++ b/utils/config.mlbuild
@@ -60,10 +60,10 @@ let mkdll = C.mkdll
let mkexe = C.mkexe
let mkmaindll = C.mkmaindll
-let exec_magic_number = "Caml1999X010"
+let exec_magic_number = "Caml1999X011"
and cmi_magic_number = "Caml1999I016"
-and cmo_magic_number = "Caml1999O008"
-and cma_magic_number = "Caml1999A009"
+and cmo_magic_number = "Caml1999O009"
+and cma_magic_number = "Caml1999A010"
and cmx_magic_number = "Caml1999Y011"
and cmxa_magic_number = "Caml1999Z010"
and ast_impl_magic_number = "Caml1999M016"
diff --git a/utils/config.mlp b/utils/config.mlp
index 867b19fc6..ce216cc1f 100644
--- a/utils/config.mlp
+++ b/utils/config.mlp
@@ -48,16 +48,16 @@ let mkdll = "%%MKDLL%%"
let mkexe = "%%MKEXE%%"
let mkmaindll = "%%MKMAINDLL%%"
-let exec_magic_number = "Caml1999X010"
-and cmi_magic_number = "Caml1999I017"
-and cmo_magic_number = "Caml1999O008"
-and cma_magic_number = "Caml1999A009"
-and cmx_magic_number = "Caml1999Y012"
-and cmxa_magic_number = "Caml1999Z011"
-and ast_impl_magic_number = "Caml1999M016"
-and ast_intf_magic_number = "Caml1999N015"
-and cmxs_magic_number = "Caml2007D001"
-and cmt_magic_number = "Caml2012T003"
+let exec_magic_number = "Caml1999X011"
+and cmi_magic_number = "Caml1999I018"
+and cmo_magic_number = "Caml1999O010"
+and cma_magic_number = "Caml1999A011"
+and cmx_magic_number = "Caml1999Y014"
+and cmxa_magic_number = "Caml1999Z013"
+and ast_impl_magic_number = "Caml1999M017"
+and ast_intf_magic_number = "Caml1999N016"
+and cmxs_magic_number = "Caml2007D002"
+and cmt_magic_number = "Caml2012T005"
let load_path = ref ([] : string list)
diff --git a/utils/consistbl.ml b/utils/consistbl.ml
index 4bc42dc5b..37f6a2b1e 100644
--- a/utils/consistbl.ml
+++ b/utils/consistbl.ml
@@ -40,8 +40,16 @@ let set tbl name crc source = Hashtbl.add tbl name (crc, source)
let source tbl name = snd (Hashtbl.find tbl name)
-let extract tbl =
- Hashtbl.fold (fun name (crc, auth) accu -> (name, crc) :: accu) tbl []
+let extract l tbl =
+ let l = List.sort_uniq String.compare l in
+ List.fold_left
+ (fun assc name ->
+ try
+ let (crc, _) = Hashtbl.find tbl name in
+ (name, Some crc) :: assc
+ with Not_found ->
+ (name, None) :: assc)
+ [] l
let filter p tbl =
let to_remove = ref [] in
diff --git a/utils/consistbl.mli b/utils/consistbl.mli
index d3f2afcec..012bd734f 100644
--- a/utils/consistbl.mli
+++ b/utils/consistbl.mli
@@ -40,9 +40,10 @@ val source: t -> string -> string
if the latter has an associated CRC in [tbl].
Raise [Not_found] otherwise. *)
-val extract: t -> (string * Digest.t) list
- (* Return all bindings ([name], [crc]) contained in the given
- table. *)
+val extract: string list -> t -> (string * Digest.t option) list
+ (* [extract tbl names] returns an associative list mapping each string
+ in [names] to the CRC associated with it in [tbl]. If no CRC is
+ associated with a name then it is mapped to [None]. *)
val filter: (string -> bool) -> t -> unit
(* [filter pred tbl] removes from [tbl] table all (name, CRC) pairs
diff --git a/utils/misc.ml b/utils/misc.ml
index 1a2a87139..898880cb0 100644
--- a/utils/misc.ml
+++ b/utils/misc.ml
@@ -124,14 +124,14 @@ let create_hashtable size init =
(* File copy *)
let copy_file ic oc =
- let buff = String.create 0x1000 in
+ let buff = Bytes.create 0x1000 in
let rec copy () =
let n = input ic buff 0 0x1000 in
if n = 0 then () else (output oc buff 0 n; copy())
in copy()
let copy_file_chunk ic oc len =
- let buff = String.create 0x1000 in
+ let buff = Bytes.create 0x1000 in
let rec copy n =
if n <= 0 then () else begin
let r = input ic buff 0 (min n 0x1000) in
@@ -141,23 +141,13 @@ let copy_file_chunk ic oc len =
let string_of_file ic =
let b = Buffer.create 0x10000 in
- let buff = String.create 0x1000 in
+ let buff = Bytes.create 0x1000 in
let rec copy () =
let n = input ic buff 0 0x1000 in
if n = 0 then Buffer.contents b else
- (Buffer.add_substring b buff 0 n; copy())
+ (Buffer.add_subbytes b buff 0 n; copy())
in copy()
-
-
-(* Reading from a channel *)
-
-let input_bytes ic n =
- let result = String.create n in
- really_input ic result 0 n;
- result
-;;
-
(* Integer operations *)
let rec log2 n =
@@ -226,26 +216,27 @@ let for4 (_,_,_,x) = x
module LongString = struct
- type t = string array
+ type t = bytes array
let create str_size =
let tbl_size = str_size / Sys.max_string_length + 1 in
- let tbl = Array.make tbl_size "" in
+ let tbl = Array.make tbl_size Bytes.empty in
for i = 0 to tbl_size - 2 do
- tbl.(i) <- String.create Sys.max_string_length;
+ tbl.(i) <- Bytes.create Sys.max_string_length;
done;
- tbl.(tbl_size - 1) <- String.create (str_size mod Sys.max_string_length);
+ tbl.(tbl_size - 1) <- Bytes.create (str_size mod Sys.max_string_length);
tbl
let length tbl =
let tbl_size = Array.length tbl in
- Sys.max_string_length * (tbl_size - 1) + String.length tbl.(tbl_size - 1)
+ Sys.max_string_length * (tbl_size - 1) + Bytes.length tbl.(tbl_size - 1)
let get tbl ind =
- tbl.(ind / Sys.max_string_length).[ind mod Sys.max_string_length]
+ Bytes.get tbl.(ind / Sys.max_string_length) (ind mod Sys.max_string_length)
let set tbl ind c =
- tbl.(ind / Sys.max_string_length).[ind mod Sys.max_string_length] <- c
+ Bytes.set tbl.(ind / Sys.max_string_length) (ind mod Sys.max_string_length)
+ c
let blit src srcoff dst dstoff len =
for i = 0 to len - 1 do
@@ -257,14 +248,14 @@ module LongString = struct
output_char oc (get tbl i)
done
- let unsafe_blit_to_string src srcoff dst dstoff len =
+ let unsafe_blit_to_bytes src srcoff dst dstoff len =
for i = 0 to len - 1 do
- String.unsafe_set dst (dstoff + i) (get src (srcoff + i))
+ Bytes.unsafe_set dst (dstoff + i) (get src (srcoff + i))
done
let input_bytes ic len =
let tbl = create len in
- Array.iter (fun str -> really_input ic str 0 (String.length str)) tbl;
+ Array.iter (fun str -> really_input ic str 0 (Bytes.length str)) tbl;
tbl
end
diff --git a/utils/misc.mli b/utils/misc.mli
index 67316365e..4a3c84b2d 100644
--- a/utils/misc.mli
+++ b/utils/misc.mli
@@ -66,11 +66,6 @@ val copy_file_chunk: in_channel -> out_channel -> int -> unit
val string_of_file: in_channel -> string
(* [string_of_file ic] reads the contents of file [ic] and copies
them to a string. It stops when encountering EOF on [ic]. *)
-val input_bytes : in_channel -> int -> string;;
- (* [input_bytes ic n] reads [n] bytes from [ic] and returns them
- in a new string. It raises [End_of_file] if EOF is encountered
- before all the bytes are read. *)
-
val log2: int -> int
(* [log2 n] returns [s] such that [n = 1 lsl s]
if [n] is a power of 2*)
@@ -124,14 +119,14 @@ val for4: 'a * 'b * 'c * 'd -> 'd
module LongString :
sig
- type t = string array
+ type t = bytes array
val create : int -> t
val length : t -> int
val get : t -> int -> char
val set : t -> int -> char -> unit
val blit : t -> int -> t -> int -> int -> unit
val output : out_channel -> t -> int -> int -> unit
- val unsafe_blit_to_string : t -> int -> string -> int -> int -> unit
+ val unsafe_blit_to_bytes : t -> int -> bytes -> int -> int -> unit
val input_bytes : in_channel -> int -> t
end
diff --git a/utils/warnings.ml b/utils/warnings.ml
index 58d275396..103789c4e 100644
--- a/utils/warnings.ml
+++ b/utils/warnings.ml
@@ -39,7 +39,7 @@ type t =
| Without_principality of string (* 19 *)
| Unused_argument (* 20 *)
| Nonreturning_statement (* 21 *)
- | Camlp4 of string (* 22 *)
+ | Preprocessor of string (* 22 *)
| Useless_record_with (* 23 *)
| Bad_module_name of string (* 24 *)
| All_clauses_guarded (* 25 *)
@@ -55,7 +55,7 @@ type t =
| Unused_for_index of string (* 35 *)
| Unused_ancestor of string (* 36 *)
| Unused_constructor of string * bool * bool (* 37 *)
- | Unused_exception of string * bool (* 38 *)
+ | Unused_extension of string * bool * bool (* 38 *)
| Unused_rec_flag (* 39 *)
| Name_out_of_scope of string * string list * bool (* 40 *)
| Ambiguous_name of string list * string list * bool (* 41 *)
@@ -66,6 +66,7 @@ type t =
| Bad_env_variable of string * string (* 46 *)
| Attribute_payload of string * string (* 47 *)
| Eliminated_optional_arguments of string list (* 48 *)
+ | No_cmi_file of string (* 49 *)
;;
(* If you remove a warning, leave a hole in the numbering. NEVER change
@@ -96,7 +97,7 @@ let number = function
| Without_principality _ -> 19
| Unused_argument -> 20
| Nonreturning_statement -> 21
- | Camlp4 _ -> 22
+ | Preprocessor _ -> 22
| Useless_record_with -> 23
| Bad_module_name _ -> 24
| All_clauses_guarded -> 25
@@ -112,7 +113,7 @@ let number = function
| Unused_for_index _ -> 35
| Unused_ancestor _ -> 36
| Unused_constructor _ -> 37
- | Unused_exception _ -> 38
+ | Unused_extension _ -> 38
| Unused_rec_flag -> 39
| Name_out_of_scope _ -> 40
| Ambiguous_name _ -> 41
@@ -123,9 +124,10 @@ let number = function
| Bad_env_variable _ -> 46
| Attribute_payload _ -> 47
| Eliminated_optional_arguments _ -> 48
+ | No_cmi_file _ -> 49
;;
-let last_warning_number = 48
+let last_warning_number = 49
(* Must be the max number returned by the [number] function. *)
let letter = function
@@ -160,21 +162,27 @@ let letter = function
| _ -> assert false
;;
-let active = Array.create (last_warning_number + 1) true;;
-let error = Array.create (last_warning_number + 1) false;;
+type state =
+ {
+ active: bool array;
+ error: bool array;
+ }
-type state = bool array * bool array
-let backup () = (Array.copy active, Array.copy error)
-let restore (a, e) =
- assert(Array.length a = Array.length active);
- assert(Array.length e = Array.length error);
- Array.blit a 0 active 0 (Array.length active);
- Array.blit e 0 error 0 (Array.length error)
+let current =
+ ref
+ {
+ active = Array.make (last_warning_number + 1) true;
+ error = Array.make (last_warning_number + 1) false;
+ }
-let is_active x = active.(number x);;
-let is_error x = error.(number x);;
+let backup () = !current
-let parse_opt flags s =
+let restore x = current := x
+
+let is_active x = (!current).active.(number x);;
+let is_error x = (!current).error.(number x);;
+
+let parse_opt error active flags s =
let set i = flags.(i) <- true in
let clear i = flags.(i) <- false in
let set_all i = active.(i) <- true; error.(i) <- true in
@@ -225,7 +233,11 @@ let parse_opt flags s =
loop 0
;;
-let parse_options errflag s = parse_opt (if errflag then error else active) s;;
+let parse_options errflag s =
+ let error = Array.copy (!current).error in
+ let active = Array.copy (!current).active in
+ parse_opt error active (if errflag then error else active) s;
+ current := {error; active}
(* If you change these, don't forget to change them in man/ocamlc.m *)
let defaults_w = "+a-4-6-7-9-27-29-32..39-41..42-44-45-48";;
@@ -237,7 +249,7 @@ let () = parse_options true defaults_warn_error;;
let message = function
| Comment_start -> "this is the start of a comment."
| Comment_not_end -> "this is not the end of a comment."
- | Deprecated s -> "deprecated feature: " ^ s
+ | Deprecated s -> "deprecated: " ^ s
| Fragile_match "" ->
"this pattern-matching is fragile."
| Fragile_match s ->
@@ -286,7 +298,7 @@ let message = function
| Unused_argument -> "this argument will not be used by the function."
| Nonreturning_statement ->
"this statement never returns (or has an unsound type.)"
- | Camlp4 s -> s
+ | Preprocessor s -> s
| Useless_record_with ->
"all the fields are explicitly listed in this record:\n\
the 'with' clause is useless."
@@ -320,12 +332,16 @@ let message = function
"constructor " ^ s ^
" is never used to build values.\n\
Its type is exported as a private type."
- | Unused_exception (s, false) ->
- "unused exception constructor " ^ s ^ "."
- | Unused_exception (s, true) ->
- "exception constructor " ^ s ^
- " is never raised or used to build values.\n\
+ | Unused_extension (s, false, false) ->
+ "unused extension constructor " ^ s ^ "."
+ | Unused_extension (s, true, _) ->
+ "extension constructor " ^ s ^
+ " is never used to build values.\n\
(However, this constructor appears in patterns.)"
+ | Unused_extension (s, false, true) ->
+ "extension constructor " ^ s ^
+ " is never used to build values.\n\
+ It is exported or rebound as a private extension."
| Unused_rec_flag ->
"unused rec flag."
| Name_out_of_scope (ty, [nm], false) ->
@@ -366,6 +382,8 @@ let message = function
Printf.sprintf "implicit elimination of optional argument%s %s"
(if List.length sl = 1 then "" else "s")
(String.concat ", " sl)
+ | No_cmi_file s ->
+ "no cmi file was found in path for module " ^ s
;;
let nerrors = ref 0;;
@@ -377,15 +395,14 @@ let print ppf w =
for i = 0 to String.length msg - 1 do
if msg.[i] = '\n' then incr newlines;
done;
- let (out, flush, newline, space) =
- Format.pp_get_all_formatter_output_functions ppf ()
- in
- let countnewline x = incr newlines; newline x in
- Format.pp_set_all_formatter_output_functions ppf out flush countnewline space;
+ let out_functions = Format.pp_get_formatter_out_functions ppf () in
+ let countnewline x = incr newlines; out_functions.Format.out_newline x in
+ Format.pp_set_formatter_out_functions ppf
+ {out_functions with Format.out_newline = countnewline};
Format.fprintf ppf "%d: %s" num msg;
Format.pp_print_flush ppf ();
- Format.pp_set_all_formatter_output_functions ppf out flush newline space;
- if error.(num) then incr nerrors;
+ Format.pp_set_formatter_out_functions ppf out_functions;
+ if (!current).error.(num) then incr nerrors;
!newlines
;;
@@ -426,7 +443,7 @@ let descriptions =
19, "Type without principality.";
20, "Unused function argument.";
21, "Non-returning statement.";
- 22, "Camlp4 warning.";
+ 22, "Proprocessor warning.";
23, "Useless record \"with\" clause.";
24, "Bad module name: the source file name is not a valid OCaml module \
name.";
@@ -449,7 +466,7 @@ let descriptions =
35, "Unused for-loop index.";
36, "Unused ancestor variable.";
37, "Unused constructor.";
- 38, "Unused exception constructor.";
+ 38, "Unused extension constructor.";
39, "Unused rec flag.";
40, "Constructor or label name used out of scope.";
41, "Ambiguous constructor or label name.";
@@ -457,9 +474,10 @@ let descriptions =
43, "Nonoptional label applied as optional.";
44, "Open statement shadows an already defined identifier.";
45, "Open statement shadows an already defined label or constructor.";
- 46, "Illegal environment variable";
- 47, "Illegal attribute payload";
- 48, "Implicit elimination of optional arguments";
+ 46, "Illegal environment variable.";
+ 47, "Illegal attribute payload.";
+ 48, "Implicit elimination of optional arguments.";
+ 49, "Absent cmi file when looking up module alias.";
]
;;
diff --git a/utils/warnings.mli b/utils/warnings.mli
index 05bf66bde..edfd732c3 100644
--- a/utils/warnings.mli
+++ b/utils/warnings.mli
@@ -34,7 +34,7 @@ type t =
| Without_principality of string (* 19 *)
| Unused_argument (* 20 *)
| Nonreturning_statement (* 21 *)
- | Camlp4 of string (* 22 *)
+ | Preprocessor of string (* 22 *)
| Useless_record_with (* 23 *)
| Bad_module_name of string (* 24 *)
| All_clauses_guarded (* 25 *)
@@ -50,7 +50,7 @@ type t =
| Unused_for_index of string (* 35 *)
| Unused_ancestor of string (* 36 *)
| Unused_constructor of string * bool * bool (* 37 *)
- | Unused_exception of string * bool (* 38 *)
+ | Unused_extension of string * bool * bool (* 38 *)
| Unused_rec_flag (* 39 *)
| Name_out_of_scope of string * string list * bool (* 40 *)
| Ambiguous_name of string list * string list * bool (* 41 *)
@@ -61,6 +61,7 @@ type t =
| Bad_env_variable of string * string (* 46 *)
| Attribute_payload of string * string (* 47 *)
| Eliminated_optional_arguments of string list (* 48 *)
+ | No_cmi_file of string (* 49 *)
;;
val parse_options : bool -> string -> unit;;
generated by cgit v1.2.3-70-g09d2 (git 2.46.0) at 2025-03-27 10:02:18 +0000