summaryrefslogtreecommitdiffstats
path: root/stdlib
diff options
context:
space:
mode:
Diffstat (limited to 'stdlib')
-rw-r--r--stdlib/format.ml11
-rw-r--r--stdlib/map.mli4
-rw-r--r--stdlib/parsing.ml12
-rw-r--r--stdlib/pervasives.mli32
-rw-r--r--stdlib/printf.ml43
-rw-r--r--stdlib/scanf.ml19
6 files changed, 84 insertions, 37 deletions
diff --git a/stdlib/format.ml b/stdlib/format.ml
index 4e732a818..62e81b46e 100644
--- a/stdlib/format.ml
+++ b/stdlib/format.ml
@@ -1048,9 +1048,9 @@ let get_buffer_out b =
s
;;
-(* [ppf] is supposed to be a pretty-printer that outputs in buffer [b]:
- to extract contents of [ppf] as a string we flush [ppf] and get the string
- out of [b]. *)
+(* [ppf] is supposed to be a pretty-printer that outputs to buffer [b]:
+ to extract the contents of [ppf] as a string we flush [ppf] and get the
+ string out of [b]. *)
let string_out b ppf =
pp_flush_queue ppf false;
get_buffer_out b
@@ -1319,7 +1319,10 @@ let kbprintf k b =
mkprintf false (fun _ -> formatter_of_buffer b) k
;;
-let bprintf b = kbprintf ignore b;;
+let bprintf b =
+ let k ppf = pp_flush_queue ppf false in
+ kbprintf k b
+;;
let ksprintf k =
let b = Buffer.create 512 in
diff --git a/stdlib/map.mli b/stdlib/map.mli
index ca8241303..af1d4d37b 100644
--- a/stdlib/map.mli
+++ b/stdlib/map.mli
@@ -73,9 +73,7 @@ module type S =
(** [iter f m] applies [f] to all bindings in map [m].
[f] receives the key as first argument, and the associated value
as second argument. The bindings are passed to [f] in increasing
- order with respect to the ordering over the type of the keys.
- Only current bindings are presented to [f]:
- bindings hidden by more recent bindings are not passed to [f]. *)
+ order with respect to the ordering over the type of the keys. *)
val map: ('a -> 'b) -> 'a t -> 'b t
(** [map f m] returns a map with same domain as [m], where the
diff --git a/stdlib/parsing.ml b/stdlib/parsing.ml
index 2b4d93ddb..44c7fb271 100644
--- a/stdlib/parsing.ml
+++ b/stdlib/parsing.ml
@@ -180,9 +180,15 @@ let peek_val env n =
Obj.magic env.v_stack.(env.asp - n)
let symbol_start_pos () =
- if env.rule_len > 0
- then env.symb_start_stack.(env.asp - env.rule_len + 1)
- else env.symb_end_stack.(env.asp)
+ let rec loop i =
+ if i <= 0 then env.symb_end_stack.(env.asp)
+ else begin
+ let st = env.symb_start_stack.(env.asp - i + 1) in
+ let en = env.symb_end_stack.(env.asp - i + 1) in
+ if st <> en then st else loop (i - 1)
+ end
+ in
+ loop env.rule_len
;;
let symbol_end_pos () = env.symb_end_stack.(env.asp);;
let rhs_start_pos n = env.symb_start_stack.(env.asp - (env.rule_len - n));;
diff --git a/stdlib/pervasives.mli b/stdlib/pervasives.mli
index 72567af00..b8e0e71de 100644
--- a/stdlib/pervasives.mli
+++ b/stdlib/pervasives.mli
@@ -24,6 +24,7 @@
name, without prefixing them by [Pervasives].
*)
+
(** {6 Exceptions} *)
external raise : exn -> 'a = "%raise"
@@ -42,7 +43,6 @@ exception Exit
(** {6 Comparisons} *)
-
external ( = ) : 'a -> 'a -> bool = "%equal"
(** [e1 = e2] tests for structural equality of [e1] and [e2].
Mutable structures (e.g. references and arrays) are equal
@@ -100,8 +100,7 @@ val max : 'a -> 'a -> 'a
external ( == ) : 'a -> 'a -> bool = "%eq"
(** [e1 == e2] tests for physical equality of [e1] and [e2].
- On integers and characters, physical equality is identical to structural
- equality. On mutable structures, [e1 == e2] is true if and only if
+ On mutable structures, [e1 == e2] is true if and only if
physical modification of [e1] also affects [e2].
On non-mutable structures, the behavior of [(==)] is
implementation-dependent; however, it is guaranteed that
@@ -113,7 +112,6 @@ external ( != ) : 'a -> 'a -> bool = "%noteq"
(** {6 Boolean operations} *)
-
external not : bool -> bool = "%boolnot"
(** The boolean negation. *)
@@ -186,10 +184,8 @@ val min_int : int
(** The smallest representable integer. *)
-
(** {7 Bitwise operations} *)
-
external ( land ) : int -> int -> int = "%andint"
(** Bitwise logical and. *)
@@ -250,10 +246,10 @@ external ( /. ) : float -> float -> float = "%divfloat"
(** Floating-point division. *)
external ( ** ) : float -> float -> float = "caml_power_float" "pow" "float"
-(** Exponentiation *)
+(** Exponentiation. *)
external sqrt : float -> float = "caml_sqrt_float" "sqrt" "float"
-(** Square root *)
+(** Square root. *)
external exp : float -> float = "caml_exp_float" "exp" "float"
(** Exponential. *)
@@ -282,15 +278,15 @@ external tan : float -> float = "caml_tan_float" "tan" "float"
(** Tangent. Argument is in radians. *)
external acos : float -> float = "caml_acos_float" "acos" "float"
-(** Arc cosine. The argument must fall within the range [[-1.0, 1.0]].
+(** Arc cosine. The argument must fall within the range [[-1.0, 1.0]].
Result is in radians and is between [0.0] and [pi]. *)
external asin : float -> float = "caml_asin_float" "asin" "float"
-(** Arc sine. The argument must fall within the range [[-1.0, 1.0]].
+(** Arc sine. The argument must fall within the range [[-1.0, 1.0]].
Result is in radians and is between [-pi/2] and [pi/2]. *)
external atan : float -> float = "caml_atan_float" "atan" "float"
-(** Arc tangent.
+(** Arc tangent.
Result is in radians and is between [-pi/2] and [pi/2]. *)
external atan2 : float -> float -> float = "caml_atan2_float" "atan2" "float"
@@ -299,13 +295,13 @@ external atan2 : float -> float -> float = "caml_atan2_float" "atan2" "float"
Result is in radians and is between [-pi] and [pi]. *)
external cosh : float -> float = "caml_cosh_float" "cosh" "float"
-(** Hyperbolic cosine. *)
+(** Hyperbolic cosine. Argument is in radians. *)
external sinh : float -> float = "caml_sinh_float" "sinh" "float"
-(** Hyperbolic sine. *)
+(** Hyperbolic sine. Argument is in radians. *)
external tanh : float -> float = "caml_tanh_float" "tanh" "float"
-(** Hyperbolic tangent. *)
+(** Hyperbolic tangent. Argument is in radians. *)
external ceil : float -> float = "caml_ceil_float" "ceil" "float"
(** Round above to an integer value.
@@ -319,7 +315,7 @@ external floor : float -> float = "caml_floor_float" "floor" "float"
The result is returned as a float. *)
external abs_float : float -> float = "%absfloat"
-(** Return the absolute value of the argument. *)
+(** [abs_float f] returns the absolute value of [f]. *)
external mod_float : float -> float -> float = "caml_fmod_float" "fmod" "float"
(** [mod_float a b] returns the remainder of [a] with respect to
@@ -456,7 +452,6 @@ external float_of_string : string -> float = "caml_float_of_string"
if the given string is not a valid representation of a float. *)
-
(** {6 Pair operations} *)
external fst : 'a * 'b -> 'a = "%field0"
@@ -558,8 +553,8 @@ val read_float : unit -> float
The result is unspecified if the line read is not a valid
representation of a floating-point number. *)
-(** {7 General output functions} *)
+(** {7 General output functions} *)
type open_flag =
Open_rdonly (** open for reading. *)
@@ -785,6 +780,7 @@ val set_binary_mode_in : in_channel -> bool -> unit
This function has no effect under operating systems that
do not distinguish between text mode and binary mode. *)
+
(** {7 Operations on large files} *)
module LargeFile :
@@ -803,6 +799,7 @@ module LargeFile :
regular integers (type [int]), these alternate functions allow
operating on files whose sizes are greater than [max_int]. *)
+
(** {6 References} *)
type 'a ref = { mutable contents : 'a }
@@ -867,7 +864,6 @@ val ( ^^ ) :
(** {6 Program termination} *)
-
val exit : int -> 'a
(** Terminate the process, returning the given status code
to the operating system: usually 0 to indicate no errors,
diff --git a/stdlib/printf.ml b/stdlib/printf.ml
index ce6ca98f3..d9bb45335 100644
--- a/stdlib/printf.ml
+++ b/stdlib/printf.ml
@@ -142,7 +142,8 @@ let extract_format fmt start stop widths =
| ('*', []) ->
assert false (* should not happen *)
| (c, _) ->
- Buffer.add_char b c; fill_format (succ i) widths in
+ Buffer.add_char b c;
+ fill_format (succ i) widths in
fill_format start (List.rev widths);
Buffer.contents b
;;
@@ -156,6 +157,15 @@ let extract_format_int conv fmt start stop widths =
| _ -> sfmt
;;
+let extract_format_float conv fmt start stop widths =
+ let sfmt = extract_format fmt start stop widths in
+ match conv with
+ | 'F' ->
+ sfmt.[String.length sfmt - 1] <- 'f';
+ sfmt
+ | _ -> sfmt
+;;
+
(* Returns the position of the next character following the meta format
string, starting from position [i], inside a given format [fmt].
According to the character [conv], the meta format string is
@@ -418,6 +428,31 @@ let get_index spec n =
| Spec_index p -> p
;;
+(* Format a float argument as a valid Caml lexem. *)
+let format_float_lexem =
+ let valid_float_lexem sfmt s =
+ let l = String.length s in
+ if l = 0 then "nan" else
+ let add_dot sfmt s =
+ if s.[0] = ' ' || s.[0] = '+' || s.[0] = '0'
+ then String.sub s 1 (l - 1) ^ "."
+ else String.sub s 0 (l - 1) ^ "." in
+
+ let rec loop i =
+ if i >= l then add_dot sfmt s else
+ match s.[i] with
+ | '.' -> s
+ | _ -> loop (i + 1) in
+
+ loop 0 in
+
+ (fun sfmt x ->
+ let s = format_float sfmt x in
+ match classify_float x with
+ | FP_normal | FP_subnormal | FP_zero -> valid_float_lexem sfmt s
+ | FP_nan | FP_infinite -> s)
+;;
+
(* Decode a format string and act on it.
[fmt] is the [printf] format string, and [pos] points to a [%] character in
the format string.
@@ -486,9 +521,11 @@ let scan_format fmt args n pos cont_s cont_a cont_t cont_f cont_m =
let (x : float) = get_arg spec n in
let s = format_float (extract_format fmt pos i widths) x in
cont_s (next_index spec n) s (succ i)
- | 'F' ->
+ | 'F' as conv ->
let (x : float) = get_arg spec n in
- cont_s (next_index spec n) (string_of_float x) (succ i)
+ let s =
+ format_float_lexem (extract_format_float conv fmt pos i widths) x in
+ cont_s (next_index spec n) s (succ i)
| 'B' | 'b' ->
let (x : bool) = get_arg spec n in
cont_s (next_index spec n) (string_of_bool x) (succ i)
diff --git a/stdlib/scanf.ml b/stdlib/scanf.ml
index 5ea7abc3f..da67cb5ba 100644
--- a/stdlib/scanf.ml
+++ b/stdlib/scanf.ml
@@ -1280,22 +1280,29 @@ let scanf fmt = bscanf Scanning.stdib fmt;;
let bscanf_format ib fmt f =
let fmt = Sformat.unsafe_to_string fmt in
- let fmt1 = ignore (scan_String max_int ib); token_string ib in
+ let fmt1 =
+ ignore (scan_String max_int ib);
+ token_string ib in
if not (compatible_format_type fmt1 fmt) then
format_mismatch fmt1 fmt else
f (string_to_format fmt1)
;;
-let sscanf_format s fmt f = bscanf_format (Scanning.from_string s) fmt f;;
+let sscanf_format s fmt = bscanf_format (Scanning.from_string s) fmt;;
-let quote_string s =
- let b = Buffer.create (String.length s + 2) in
+let string_to_String s =
+ let l = String.length s in
+ let b = Buffer.create (l + 2) in
Buffer.add_char b '\"';
- Buffer.add_string b s;
+ for i = 0 to l - 1 do
+ let c = s.[i] in
+ if c = '\"' then Buffer.add_char b '\\';
+ Buffer.add_char b c;
+ done;
Buffer.add_char b '\"';
Buffer.contents b
;;
let format_from_string s fmt =
- sscanf_format (quote_string s) fmt (fun x -> x)
+ sscanf_format (string_to_String s) fmt (fun x -> x)
;;
generated by cgit v1.2.3-70-g09d2 (git 2.46.0) at 2025-03-23 06:52:21 +0000