Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Merge tag 4.03.0 into trunk.

master
Damien Doligez 2016-04-28 16:00:18 +02:00
parent 2c7c9b419f
commit 520fb2df50
68 changed files with 1505 additions and 1044 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
Changes
View File

@ -382,13 +382,15 @@ Runtime system:
- GPR#262: Multiple GC roots per compilation unit
(Pierre Chambart, Mark Shinwell, review by Damien Doligez)
- GPR#297: Several changes to improve the worst-case GC pause time.
(Damien Doligez, with help from Leo White and Francois Bobot)
* GPR#297: Several changes to improve the worst-case GC pause time.
Changes Gc.control and Gc.major_slice and adds functions to the Gc module.
(Damien Doligez, with help from Francois Bobot, Thomas Braibant, Leo White)
- GPR#325: Add v=0x400 flag to OCAMLRUNPARAM to display GC stats on exit
(Louis Gesbert, review by Alain Frisch)
Standard library:
=================
- PR#1460, GPR#230: Array.map2, Array.iter2
(John Christopher McAlpine)
@ -610,6 +612,10 @@ Other libraries:
"end of line" means for "^" and "$" regexps.
(Xavier Leroy, question by Fredrik Lindgren)
- PR#7209: do not run at_exit handlers in [Unix.create_process] and
similar functions when the [exec] call fails in the child process
(Jérémie Dimino)
OCamldep:
=========
@ -630,6 +636,9 @@ Manual:
- PR#6676: ongoing simplification of the "Language Extensions" section
(Alain Frisch, John Whitington)
- PR#6898: Update win32 support documentation of the Unix library
(Damien Doligez, report by Daniel Bünzli)
- PR#7092, GPR#379: Add missing documentation for new 4.03 features
(Florian Angeletti)
@ -748,7 +757,7 @@ Bug fixes:
- PR#6805: Duplicated expression in case of hole in a non-failing switch.
(Luc Maranget)
- PR#6808: the parsing of OCAMLRUNPARAM is too lax
* PR#6808: the parsing of OCAMLRUNPARAM is too lax
(Damien Doligez)
- PR#6874: Inefficient code generated for module function arguments
@ -882,9 +891,15 @@ Bug fixes:
- PR#7160: Type synonym definitions can weaken gadt constructor types
(Jacques Garrigue, report by Mikhail Mandrykin)
- PR#7181: Misleading error message with GADTs and polymorphic variants
(Jacques Garrigue, report by Pierre Chambart)
- PR#7182: Assertion failure with recursive modules and externals
(Jacques Garrigue, report by Jeremy Yallop)
- PR#7196: "let open" is not correctly pretty-printed to the left of a ';'
(Gabriel Scherer, report by Christophe Raffalli)
- PR#7214: Assertion failure in Env.add_gadt_instances
(Jacques Garrigue, report by Stephen Dolan)
@ -1074,6 +1089,11 @@ Features wishes:
GNU parallel tool to run tests in parallel.
(Gabriel Scherer)
- GPR#555: ensure that register typing constraints are respected at
join points in the control flow graph
(Mark Shinwell, debugging & test case by Arseniy Alekseyev and Leo White,
code review by Xavier Leroy)
Build system:
=============

2
VERSION
View File

@ -1,4 +1,4 @@
4.04.0+dev1-2016-04-18
4.04.0+dev2-2016-04-27
# The version string is the first line of this file.
# It must be in the format described in stdlib/sys.mli

50
asmcomp/cmm.ml
View File

@ -32,6 +32,56 @@ let size_component = function
| Int -> Arch.size_int
| Float -> Arch.size_float
(** [machtype_component]s are partially ordered as follows:
Addr Float
^
|
Val
^
|
Int
In particular, [Addr] must be above [Val], to ensure that if there is
a join point between a code path yielding [Addr] and one yielding [Val]
then the result is treated as a derived pointer into the heap (i.e. [Addr]).
(Such a result may not be live across any call site or a fatal compiler
error will result.)
*)
let lub_component comp1 comp2 =
match comp1, comp2 with
| Int, Int -> Int
| Int, Val -> Val
| Int, Addr -> Addr
| Val, Int -> Val
| Val, Val -> Val
| Val, Addr -> Addr
| Addr, Int -> Addr
| Addr, Addr -> Addr
| Addr, Val -> Addr
| Float, Float -> Float
| (Int | Addr | Val), Float
| Float, (Int | Addr | Val) ->
(* Float unboxing code must be sure to avoid this case. *)
assert false
let ge_component comp1 comp2 =
match comp1, comp2 with
| Int, Int -> true
| Int, Addr -> false
| Int, Val -> false
| Val, Int -> true
| Val, Val -> true
| Val, Addr -> false
| Addr, Int -> true
| Addr, Addr -> true
| Addr, Val -> true
| Float, Float -> true
| (Int | Addr | Val), Float
| Float, (Int | Addr | Val) ->
assert false
let size_machtype mty =
let size = ref 0 in
for i = 0 to Array.length mty - 1 do

14
asmcomp/cmm.mli
View File

@ -56,6 +56,20 @@ val typ_int: machtype
val typ_float: machtype
val size_component: machtype_component -> int
(** Least upper bound of two [machtype_component]s. *)
val lub_component
: machtype_component
-> machtype_component
-> machtype_component
(** Returns [true] iff the first supplied [machtype_component] is greater than
or equal to the second under the relation used by [lub_component]. *)
val ge_component
: machtype_component
-> machtype_component
-> bool
val size_machtype: machtype -> int
type comparison =

11
asmcomp/selectgen.ml
View File

@ -117,14 +117,19 @@ let join opt_r1 seq1 opt_r2 seq2 =
assert (l1 = Array.length r2);
let r = Array.make l1 Reg.dummy in
for i = 0 to l1-1 do
if Reg.anonymous r1.(i) then begin
if Reg.anonymous r1.(i)
&& Cmm.ge_component r1.(i).typ r2.(i).typ
then begin
r.(i) <- r1.(i);
seq2#insert_move r2.(i) r1.(i)
end else if Reg.anonymous r2.(i) then begin
end else if Reg.anonymous r2.(i)
&& Cmm.ge_component r2.(i).typ r1.(i).typ
then begin
r.(i) <- r2.(i);
seq1#insert_move r1.(i) r2.(i)
end else begin
r.(i) <- Reg.create r1.(i).typ;
let typ = Cmm.lub_component r1.(i).typ r2.(i).typ in
r.(i) <- Reg.create typ;
seq1#insert_move r1.(i) r.(i);
seq2#insert_move r2.(i) r.(i)
end

19
bytecomp/translmod.ml
View File

@ -557,13 +557,18 @@ let scan_used_globals lam =
in
scan lam; !globals
let wrap_globals body =
let wrap_globals ~flambda body =
let globals = scan_used_globals body in
let add_global id req =
if IdentSet.mem id globals then req else IdentSet.add id req in
if not flambda && IdentSet.mem id globals then
req
else
IdentSet.add id req
in
let required =
Hashtbl.fold (fun path _ -> add_global (Path.head path))
used_primitives IdentSet.empty
Hashtbl.fold
(fun path _ -> add_global (Path.head path)) used_primitives
(if flambda then globals else IdentSet.empty)
in
let required =
List.fold_right add_global (Env.get_required_globals ()) required
@ -571,7 +576,7 @@ let wrap_globals body =
Env.reset_required_globals ();
Hashtbl.clear used_primitives;
IdentSet.fold
(fun id expr -> Lsequence(Lprim(Pgetglobal id, []), expr))
(fun id expr -> Lsequence(Lprim(Popaque, [Lprim(Pgetglobal id, [])]), expr))
required body
(* Location.prerr_warning loc
(Warnings.Nonrequired_global (Ident.name (Path.head path),
@ -589,7 +594,7 @@ let transl_implementation_flambda module_name (str, cc) =
Translobj.transl_label_init
(fun () -> transl_struct [] cc (global_path module_id) str)
in
(module_id, size), wrap_globals body
(module_id, size), wrap_globals ~flambda:true body
let transl_implementation module_name (str, cc) =
let (module_id, _size), module_initializer =
@ -944,7 +949,7 @@ let transl_store_implementation module_name (str, restr) =
let (i, r) = transl_store_gen module_name (str, restr) false in
transl_store_subst := s;
{ Lambda.main_module_block_size = i;
code = wrap_globals r; }
code = wrap_globals ~flambda:false r; }
(* Compile a toplevel phrase *)

28
byterun/caml/minor_gc.h
View File

@ -38,7 +38,7 @@ extern int caml_in_minor_collection;
}
struct caml_ref_table CAML_TABLE_STRUCT(value *);
CAMLextern struct caml_ref_table caml_ref_table, caml_finalize_table;
CAMLextern struct caml_ref_table caml_ref_table;
struct caml_ephe_ref_elt {
value ephe; /* an ephemeron in major heap */
@ -48,6 +48,15 @@ struct caml_ephe_ref_elt {
struct caml_ephe_ref_table CAML_TABLE_STRUCT(struct caml_ephe_ref_elt);
CAMLextern struct caml_ephe_ref_table caml_ephe_ref_table;
struct caml_custom_elt {
value block; /* The finalized block in the minor heap. */
mlsize_t mem; /* The parameters for adjusting GC speed. */
mlsize_t max;
};
struct caml_custom_table CAML_TABLE_STRUCT(struct caml_custom_elt);
CAMLextern struct caml_custom_table caml_custom_table;
extern void caml_set_minor_heap_size (asize_t); /* size in bytes */
extern void caml_empty_minor_heap (void);
CAMLextern void caml_gc_dispatch (void);
@ -57,6 +66,9 @@ extern void caml_alloc_table (struct caml_ref_table *, asize_t, asize_t);
extern void caml_realloc_ephe_ref_table (struct caml_ephe_ref_table *);
extern void caml_alloc_ephe_table (struct caml_ephe_ref_table *,
asize_t, asize_t);
extern void caml_realloc_custom_table (struct caml_custom_table *);
extern void caml_alloc_custom_table (struct caml_custom_table *,
asize_t, asize_t);
extern void caml_oldify_one (value, value *);
extern void caml_oldify_mopup (void);
@ -90,4 +102,18 @@ static inline void add_to_ephe_ref_table (struct caml_ephe_ref_table *tbl,
Assert(ephe_ref->offset < Wosize_val(ephe_ref->ephe));
}
static inline void add_to_custom_table (struct caml_custom_table *tbl, value v,
mlsize_t mem, mlsize_t max)
{
struct caml_custom_elt *elt;
if (tbl->ptr >= tbl->limit){
CAMLassert (tbl->ptr == tbl->limit);
caml_realloc_custom_table (tbl);
}
elt = tbl->ptr++;
elt->block = v;
elt->mem = mem;
elt->max = max;
}
#endif /* CAML_MINOR_GC_H */

1
byterun/compact.c
View File

@ -405,6 +405,7 @@ void caml_compact_heap (void)
CAMLassert (caml_young_ptr == caml_young_alloc_end);
CAMLassert (caml_ref_table.ptr == caml_ref_table.base);
CAMLassert (caml_ephe_ref_table.ptr == caml_ephe_ref_table.base);
CAMLassert (caml_custom_table.ptr == caml_custom_table.base);
do_compaction ();
CAML_INSTR_TIME (tmr, "compact/main");

10
byterun/custom.c
View File

@ -34,13 +34,9 @@ CAMLexport value caml_alloc_custom(struct custom_operations * ops,
if (wosize <= Max_young_wosize) {
result = caml_alloc_small(wosize, Custom_tag);
Custom_ops_val(result) = ops;
if (ops->finalize != NULL) {
/* Remembered that the block has a finalizer */
if (caml_finalize_table.ptr >= caml_finalize_table.limit){
CAMLassert (caml_finalize_table.ptr == caml_finalize_table.limit);
caml_realloc_ref_table (&caml_finalize_table);
}
*caml_finalize_table.ptr++ = (value *)result;
if (ops->finalize != NULL || mem != 0) {
/* Remember that the block needs processing after minor GC. */
add_to_custom_table (&caml_custom_table, result, mem, max);
}
} else {
result = caml_alloc_shr(wosize, Custom_tag);

1
byterun/gc_ctrl.c
View File

@ -501,7 +501,6 @@ CAMLprim value caml_gc_major_slice (value v)
{
CAML_INSTR_SETUP (tmr, "");
Assert (Is_long (v));
caml_empty_minor_heap ();
caml_major_collection_slice (Long_val (v));
CAML_INSTR_TIME (tmr, "explicit/gc_major_slice");
return Val_long (0);

8
byterun/intern.c
View File

@ -531,12 +531,8 @@ static void intern_rec(value *dest)
Custom_ops_val(v) = ops;
if (ops->finalize != NULL && Is_young(v)) {
/* Remembered that the block has a finalizer */
if (caml_finalize_table.ptr >= caml_finalize_table.limit){
CAMLassert (caml_finalize_table.ptr == caml_finalize_table.limit);
caml_realloc_ref_table (&caml_finalize_table);
}
*caml_finalize_table.ptr++ = (value *)v;
/* Remember that the block has a finalizer. */
add_to_custom_table (&caml_custom_table, v, 0, 1);
}
intern_dest += 1 + size;

4
byterun/major_gc.c
View File

@ -28,6 +28,7 @@
#include "caml/misc.h"
#include "caml/mlvalues.h"
#include "caml/roots.h"
#include "caml/signals.h"
#include "caml/weak.h"
#if defined (NATIVE_CODE) && defined (NO_NAKED_POINTERS)
@ -568,6 +569,7 @@ static void sweep_slice (intnat work)
++ caml_stat_major_collections;
work = 0;
caml_gc_phase = Phase_idle;
caml_request_minor_gc ();
}else{
caml_gc_sweep_hp = chunk;
limit = chunk + Chunk_size (chunk);
@ -753,7 +755,7 @@ void caml_major_collection_slice (intnat howmuch)
}
if (caml_gc_phase == Phase_mark || caml_gc_phase == Phase_clean){
computed_work = (intnat) (p * (caml_stat_heap_wsz * 250
computed_work = (intnat) (p * ((double) caml_stat_heap_wsz * 250
/ (100 + caml_percent_free)
+ caml_incremental_roots_count));
}else{

44
byterun/minor_gc.c
View File

@ -63,13 +63,16 @@ CAMLexport value *caml_young_ptr = NULL, *caml_young_limit = NULL;
CAMLexport value *caml_young_trigger = NULL;
CAMLexport struct caml_ref_table
caml_ref_table = { NULL, NULL, NULL, NULL, NULL, 0, 0},
caml_finalize_table = { NULL, NULL, NULL, NULL, NULL, 0, 0};
/* table of custom blocks containing finalizers in the minor heap */
caml_ref_table = { NULL, NULL, NULL, NULL, NULL, 0, 0};
CAMLexport struct caml_ephe_ref_table
caml_ephe_ref_table = { NULL, NULL, NULL, NULL, NULL, 0, 0};
CAMLexport struct caml_custom_table
caml_custom_table = { NULL, NULL, NULL, NULL, NULL, 0, 0};
/* Table of custom blocks in the minor heap that contain finalizers
or GC speed parameters. */
int caml_in_minor_collection = 0;
/* [sz] and [rsv] are numbers of entries */
@ -102,6 +105,13 @@ void caml_alloc_ephe_table (struct caml_ephe_ref_table *tbl, asize_t sz,
sizeof (struct caml_ephe_ref_elt));
}
void caml_alloc_custom_table (struct caml_custom_table *tbl, asize_t sz,
asize_t rsv)
{
alloc_generic_table ((struct generic_table *) tbl, sz, rsv,
sizeof (struct caml_custom_elt));
}
static void reset_table (struct generic_table *tbl)
{
tbl->size = 0;
@ -154,6 +164,7 @@ void caml_set_minor_heap_size (asize_t bsz)
reset_table ((struct generic_table *) &caml_ref_table);
reset_table ((struct generic_table *) &caml_ephe_ref_table);
reset_table ((struct generic_table *) &caml_custom_table);
}
static value oldify_todo_list = 0;
@ -319,6 +330,7 @@ void caml_oldify_mopup (void)
void caml_empty_minor_heap (void)
{
value **r;
struct caml_custom_elt *elt;
uintnat prev_alloc_words;
struct caml_ephe_ref_elt *re;
@ -354,11 +366,15 @@ void caml_empty_minor_heap (void)
}
}
/* Run custom block finalisation of dead minor values */
for (r = caml_finalize_table.base; r < caml_finalize_table.ptr; r++){
int hd = Hd_val ((value)*r);
if (hd != 0){ /* If not oldified the finalizer must be called */
void (*final_fun)(value) = Custom_ops_val((value)*r)->finalize;
final_fun((value)*r);
for (elt = caml_custom_table.base; elt < caml_custom_table.ptr; elt++){
value v = elt->block;
if (Hd_val (v) == 0){
/* Block was copied to the major heap: adjust GC speed numbers. */
caml_adjust_gc_speed(elt->mem, elt->max);
}else{
/* Block will be freed: call finalization function, if any. */
void (*final_fun)(value) = Custom_ops_val(v)->finalize;
if (final_fun != NULL) final_fun(v);
}
}
CAML_INSTR_TIME (tmr, "minor/update_weak");
@ -368,7 +384,7 @@ void caml_empty_minor_heap (void)
caml_young_ptr = caml_young_alloc_end;
clear_table ((struct generic_table *) &caml_ref_table);
clear_table ((struct generic_table *) &caml_ephe_ref_table);
clear_table ((struct generic_table *) &caml_finalize_table);
clear_table ((struct generic_table *) &caml_custom_table);
caml_gc_message (0x02, ">", 0);
caml_in_minor_collection = 0;
caml_final_empty_young ();
@ -517,3 +533,13 @@ void caml_realloc_ephe_ref_table (struct caml_ephe_ref_table *tbl)
"Growing ephe_ref_table to %" ARCH_INTNAT_PRINTF_FORMAT "dk bytes\n",
"Fatal error: ephe_ref_table overflow\n");
}
void caml_realloc_custom_table (struct caml_custom_table *tbl)
{
realloc_generic_table
((struct generic_table *) tbl, sizeof (struct caml_custom_elt),
"request_minor/realloc_custom_table@",
"custom_table threshold crossed\n",
"Growing custom_table to %" ARCH_INTNAT_PRINTF_FORMAT "dk bytes\n",
"Fatal error: custom_table overflow\n");
}

7
man/ocamlrun.m
View File

@ -211,6 +211,11 @@ The multiplier is
.BR M ,\ or
.BR G ,
for multiplication by 2^10, 2^20, and 2^30 respectively.
If the option letter is not recognized, the whole parameter is ignored;
if the equal sign or the number is missing, the value is taken as 1;
if the multiplier is not recognized, it is ignored.
For example, on a 32-bit machine under bash, the command
.B export OCAMLRUNPARAM='s=256k,v=1'
tells a subsequent
@ -220,7 +225,7 @@ a message at the start of each major GC cycle.
.TP
.B CAMLRUNPARAM
If OCAMLRUNPARAM is not found in the environment, then CAMLRUNPARAM
will be used instead. If CAMLRUNPARAM is not found, then the default
will be used instead. If CAMLRUNPARAM is also not found, then the default
values will be used.
.TP
.B PATH

10
manual/manual/cmds/runtime.etex
View File

@ -93,7 +93,8 @@ The following environment variables are also consulted:
\item["OCAMLRUNPARAM"] Set the runtime system options
and garbage collection parameters.
(If "OCAMLRUNPARAM" is not set, "CAMLRUNPARAM" will be used instead.)
This variable must be a sequence of parameter specifications.
This variable must be a sequence of parameter specifications separated
by commas.
A parameter specification is an option letter followed by an "="
sign, a decimal number (or an hexadecimal number prefixed by "0x"),
and an optional multiplier. The options are documented below;
@ -150,6 +151,11 @@ The following environment variables are also consulted:
\end{options}
The multiplier is "k", "M", or "G", for multiplication by $2^{10}$,
$2^{20}$, and $2^{30}$ respectively.
If the option letter is not recognized, the whole parameter is ignored;
if the equal sign or the number is missing, the value is taken as 1;
if the multiplier is not recognized, it is ignored.
For example, on a 32-bit machine, under "bash" the command
\begin{verbatim}
export OCAMLRUNPARAM='b,s=256k,v=0x015'
@ -161,7 +167,7 @@ The following environment variables are also consulted:
\item["CAMLRUNPARAM"] If "OCAMLRUNPARAM" is not found in the
environment, then "CAMLRUNPARAM" will be used instead. If
"CAMLRUNPARAM" is not found, then the default values will be used.
"CAMLRUNPARAM" is also not found, then the default values will be used.
\item["PATH"] List of directories searched to find the bytecode
executable file.

18
manual/manual/library/libunix.etex
View File

@ -64,8 +64,8 @@ fully implemented and behave as described previously in this chapter.
\entree{"getppid"}{not implemented (meaningless under Windows)}
\entree{"nice"}{not implemented}
\entree{"truncate", "ftruncate"}{not implemented}
\entree{"link", "symlink", "readlink"}{not implemented (no links under
Windows)}
\entree{"link"}{implemented (since 3.02)}
\entree{"symlink", "readlink"}{implemented (since 4.03.0)}
\entree{"access"}{execute permission "X_OK" cannot be tested,
it just tests for read permission instead}
\entree{"fchmod"}{not implemented}
@ -73,18 +73,20 @@ Windows)}
file system)}
\entree{"umask"}{not implemented}
\entree{"mkfifo"}{not implemented}
\entree{"kill", "pause"}{not implemented (no inter-process signals in Windows)}
\entree{"kill"}{partially implemented (since 4.00.0): only the "sigkill" signal
is implemented}
\entree{"pause"}{not implemented (no inter-process signals in Windows)}
\entree{"alarm"}{not implemented}
\entree{"times"}{partially implemented, will not report timings for child
processes}
\entree{"getitimer", "setitimer"}{not implemented}
\entree{"getuid", "getgid"}{always return 1}
\entree{"getgid", "getegid", "getgroups"}{not implemented}
\entree{"setuid", "setgid"}{not implemented}
\entree{"getuid", "geteuid", "getgid", "getegid"}{always return 1}
\entree{"getgroups"}{always returns "[|1|]" (since 2.00)}
\entree{"setuid", "setgid", "setgroups"}{not implemented}
\entree{"getpwnam", "getpwuid"}{always raise "Not_found"}
\entree{"getgrnam", "getgrgid"}{always raise "Not_found"}
\entree{type "socket_domain"}{the domains "PF_UNIX" and "PF_INET6"
are not supported; "PF_INET" is fully supported}
\entree{type "socket_domain"}{"PF_INET" is fully supported;
"PF_INET6" is fully supported (since 4.01.0); "PF_UNIX" is not supported }
\entree{"establish_server"}{not implemented; use threads}
\entree{terminal functions ("tc*")}{not implemented}
\end{tableau}

168
manual/manual/refman/exten.etex
View File

@ -2156,3 +2156,171 @@ expression, but nothing prevents exception values created with this
constructor from escaping this scope. Two executions of the definition
above result in two incompatible exception constructors (as for any
exception definition).
\section{Documentation comments}
(Introduced in OCaml 4.03)
Comments which start with "**" are treated specially by the
compiler. They are automatically converted during parsing into
attributes (see \ref{s:attributes}) to allow tools to process them as
documentation.
Such comments can take three forms: {\em floating comments}, {\em item
comments} and {\em label comments}. Any comment starting with "**" which
does not match one of these forms will cause the compiler to emit
warning 50.
Comments which start with "**" are also used by the ocamldoc
documentation generator (see \ref{c:ocamldoc}). The three comment forms
recognised by the compiler are a subset of the forms accepted by
ocamldoc (see \ref{s:ocamldoc-comments}).
\subsection{Floating comments}
Comments surrounded by blank lines that appear within structures,
signatures, classes or class types are converted into
@floating-attribute@s. For example:
\begin{verbatim}
type t = T
(** Now some definitions for [t] *)
let mkT = T
\end{verbatim}
will be converted to:
\begin{verbatim}
type t = T
[@@@ocaml.text " Now some definitions for [t] "]
let mkT = T
\end{verbatim}
\subsection{Item comments}
Comments which appear {\em immediately before} or {\em immediately
after} a structure item, signature item, class item or class type item
are converted into @item-attribute@s. Immediately before or immediately
after means that there must be no blank lines, ";;", or other
documentation comments between them. For example:
\begin{verbatim}
type t = T
(** A description of [t] *)
\end{verbatim}
or
\begin{verbatim}
(** A description of [t] *)
type t = T
\end{verbatim}
will be converted to:
\begin{verbatim}
type t = T
[@@ocaml.doc " A description of [t] "]
\end{verbatim}
Note that, if a comment appears immediately next to multiple items,
as in:
\begin{verbatim}
type t = T
(** An ambiguous comment *)
type s = S
\end{verbatim}
then it will be attached to both items:
\begin{verbatim}
type t = T
[@@ocaml.doc " An ambiguous comment "]
type s = S
[@@ocaml.doc " An ambiguous comment "]
\end{verbatim}
and the compiler will emit warning 50.
\subsection{Label comments}
Comments which appear {\em immediately after} a labelled argument,
record field, variant constructor, object method or polymorphic variant
constructor are are converted into @attribute@s. Immediately
after means that there must be no blank lines or other documentation
comments between them. For example:
\begin{verbatim}
type t1 = lbl:int (** Labelled argument *) -> unit
type t2 = {
fld: int; (** Record field *)
fld2: float;
}
type t3 =
| Cstr of string (** Variant constructor *)
| Cstr2 of string
type t4 = < meth: int * int; (** Object method *) >
type t5 = [
`PCstr (** Polymorphic variant constructor *)
]
\end{verbatim}
will be converted to:
\begin{verbatim}
type t1 = lbl:(int [@ocaml.doc " Labelled argument "]) -> unit
type t2 = {
fld: int [@ocaml.doc " Record field "];
fld2: float;
}
type t3 =
| Cstr of string [@ocaml.doc " Variant constructor "]
| Cstr2 of string
type t4 = < meth : int * int [@ocaml.doc " Object method "] >
type t5 = [
`PCstr [@ocaml.doc " Polymorphic variant constructor "]
]
\end{verbatim}
Note that label comments take precedence over item comments, so:
\begin{verbatim}
type t = T of string
(** Attaches to T not t *)
\end{verbatim}
will be converted to:
\begin{verbatim}
type t = T of string [@ocaml.doc " Attaches to T not t "]
\end{verbatim}
whilst:
\begin{verbatim}
type t = T of string
(** Attaches to T not t *)
(** Attaches to t *)
\end{verbatim}
will be converted to:
\begin{verbatim}
type t = T of string [@ocaml.doc " Attaches to T not t "]
[@@ocaml.doc " Attaches to t "]
\end{verbatim}

28
middle_end/inlining_decision.ml
View File

@ -43,7 +43,7 @@ let inline env r ~lhs_of_application
~self_call ~fun_cost ~inlining_threshold =
let toplevel = E.at_toplevel env in
let branch_depth = E.branch_depth env in
let always_inline, never_inline, env =
let unrolling, always_inline, never_inline, env =
let unrolling =
E.actively_unrolling env function_decls.set_of_closures_origin
in
@ -54,8 +54,8 @@ let inline env r ~lhs_of_application
E.continue_actively_unrolling
env function_decls.set_of_closures_origin
in
true, false, env
else false, true, env
true, true, false, env
else false, false, true, env
| None -> begin
let inline_annotation =
(* Merge call site annotation and function annotation.
@ -65,17 +65,17 @@ let inline env r ~lhs_of_application
| Default_inline -> function_decl.inline
in
match inline_annotation with
| Always_inline -> true, false, env
| Never_inline -> false, true, env
| Default_inline -> false, false, env
| Always_inline -> false, true, false, env
| Never_inline -> false, false, true, env
| Default_inline -> false, false, false, env
| Unroll count ->
if count > 0 then
let env =
E.start_actively_unrolling
env function_decls.set_of_closures_origin (count - 1)
in
true, false, env
else false, true, env
true, true, false, env
else false, false, true, env
end
in
let remaining_inlining_threshold : Inlining_cost.Threshold.t =
@ -83,16 +83,18 @@ let inline env r ~lhs_of_application
else Lazy.force fun_cost
in
let try_inlining =
if only_use_of_function || always_inline then
if unrolling then
Try_it
else if self_call then
Don't_try_it S.Not_inlined.Self_call
else if not (E.inlining_allowed env closure_id_being_applied) then
Don't_try_it S.Not_inlined.Unrolling_depth_exceeded
else if only_use_of_function || always_inline then
Try_it
else if never_inline then
Don't_try_it S.Not_inlined.Annotation
else if !Clflags.classic_inlining then
Don't_try_it S.Not_inlined.Classic_mode
else if self_call then
Don't_try_it S.Not_inlined.Self_call
else if not (E.inlining_allowed env closure_id_being_applied) then
Don't_try_it S.Not_inlined.Unrolling_depth_exceeded
else if not (E.unrolling_allowed env function_decls.set_of_closures_origin)
&& (Lazy.force recursive) then
Don't_try_it S.Not_inlined.Unrolling_depth_exceeded

50
otherlibs/systhreads/st_stubs.c
View File

@ -152,12 +152,10 @@ static void caml_thread_scan_roots(scanning_action action)
if (prev_scan_roots_hook != NULL) (*prev_scan_roots_hook)(action);
}
/* Hooks for enter_blocking_section and leave_blocking_section */
/* Saving and restoring runtime state in curr_thread */
static void caml_thread_enter_blocking_section(void)
static inline void caml_thread_save_runtime_state(void)
{
/* Save the stack-related global variables in the thread descriptor
of the current thread */
#ifdef NATIVE_CODE
curr_thread->bottom_of_stack = caml_bottom_of_stack;
curr_thread->last_retaddr = caml_last_return_address;
@ -176,18 +174,10 @@ static void caml_thread_enter_blocking_section(void)
curr_thread->backtrace_pos = backtrace_pos;
curr_thread->backtrace_buffer = backtrace_buffer;
curr_thread->backtrace_last_exn = backtrace_last_exn;
/* Tell other threads that the runtime is free */
st_masterlock_release(&caml_master_lock);
}
static void caml_thread_leave_blocking_section(void)
static inline void caml_thread_restore_runtime_state(void)
{
/* Wait until the runtime is free */
st_masterlock_acquire(&caml_master_lock);
/* Update curr_thread to point to the thread descriptor corresponding
to the thread currently executing */
curr_thread = st_tls_get(thread_descriptor_key);
/* Restore the stack-related global variables */
#ifdef NATIVE_CODE
caml_bottom_of_stack= curr_thread->bottom_of_stack;
caml_last_return_address = curr_thread->last_retaddr;
@ -208,6 +198,29 @@ static void caml_thread_leave_blocking_section(void)
backtrace_last_exn = curr_thread->backtrace_last_exn;
}
/* Hooks for enter_blocking_section and leave_blocking_section */
static void caml_thread_enter_blocking_section(void)
{
/* Save the current runtime state in the thread descriptor
of the current thread */
caml_thread_save_runtime_state();
/* Tell other threads that the runtime is free */
st_masterlock_release(&caml_master_lock);
}
static void caml_thread_leave_blocking_section(void)
{
/* Wait until the runtime is free */
st_masterlock_acquire(&caml_master_lock);
/* Update curr_thread to point to the thread descriptor corresponding
to the thread currently executing */
curr_thread = st_tls_get(thread_descriptor_key);
/* Restore the runtime state from the curr_thread descriptor */
caml_thread_restore_runtime_state();
}
static int caml_thread_try_leave_blocking_section(void)
{
/* Disable immediate processing of signals (PR#3659).
@ -293,7 +306,6 @@ static uintnat caml_thread_stack_usage(void)
static caml_thread_t caml_thread_new_info(void)
{
caml_thread_t th;
th = (caml_thread_t) malloc(sizeof(struct caml_thread_struct));
if (th == NULL) return NULL;
th->descr = Val_unit; /* filled later */
@ -459,11 +471,11 @@ CAMLprim value caml_thread_cleanup(value unit) /* ML */
static void caml_thread_stop(void)
{
#ifndef NATIVE_CODE
/* PR#5188: update curr_thread->stack_low because the stack may have
been reallocated since the last time we entered a blocking section */
curr_thread->stack_low = stack_low;
#endif
/* PR#5188, PR#7220: some of the global runtime state may have
changed as the thread was running, so we save it in the
curr_thread data to make sure that the cleanup logic
below uses accurate information. */
caml_thread_save_runtime_state();
/* Signal that the thread has terminated */
caml_threadstatus_terminate(Terminated(curr_thread->descr));
/* Remove th from the doubly-linked list of threads and free its info block */

35
otherlibs/unix/unix.ml
View File

@ -862,12 +862,14 @@ let rec waitpid_non_intr pid =
try waitpid [] pid
with Unix_error (EINTR, _, _) -> waitpid_non_intr pid
external sys_exit : int -> 'a = "caml_sys_exit"
let system cmd =
match fork() with
0 -> begin try
execv "/bin/sh" [| "/bin/sh"; "-c"; cmd |]
with _ ->
exit 127
sys_exit 127
end
| id -> snd(waitpid_non_intr id)
@ -902,7 +904,7 @@ let create_process cmd args new_stdin new_stdout new_stderr =
perform_redirections new_stdin new_stdout new_stderr;
execvp cmd args
with _ ->
exit 127
sys_exit 127
end
| id -> id
@ -913,7 +915,7 @@ let create_process_env cmd args env new_stdin new_stdout new_stderr =
perform_redirections new_stdin new_stdout new_stderr;
execvpe cmd args env
with _ ->
exit 127
sys_exit 127
end
| id -> id
@ -928,11 +930,12 @@ let popen_processes = (Hashtbl.create 7 : (popen_process, int) Hashtbl.t)
let open_proc cmd proc input output toclose =
let cloexec = List.for_all try_set_close_on_exec toclose in
match fork() with
0 -> if input <> stdin then begin dup2 input stdin; close input end;
if output <> stdout then begin dup2 output stdout; close output end;
if not cloexec then List.iter close toclose;
begin try execv "/bin/sh" [| "/bin/sh"; "-c"; cmd |]
with _ -> exit 127
0 -> begin try
if input <> stdin then begin dup2 input stdin; close input end;
if output <> stdout then begin dup2 output stdout; close output end;
if not cloexec then List.iter close toclose;
execv "/bin/sh" [| "/bin/sh"; "-c"; cmd |]
with _ -> sys_exit 127
end
| id -> Hashtbl.add popen_processes proc id
@ -984,12 +987,13 @@ let open_process cmd =
let open_proc_full cmd env proc input output error toclose =
let cloexec = List.for_all try_set_close_on_exec toclose in
match fork() with
0 -> dup2 input stdin; close input;
dup2 output stdout; close output;
dup2 error stderr; close error;
if not cloexec then List.iter close toclose;
begin try execve "/bin/sh" [| "/bin/sh"; "-c"; cmd |] env
with _ -> exit 127
0 -> begin try
dup2 input stdin; close input;
dup2 output stdout; close output;
dup2 error stderr; close error;
if not cloexec then List.iter close toclose;
execve "/bin/sh" [| "/bin/sh"; "-c"; cmd |] env
with _ -> sys_exit 127
end
| id -> Hashtbl.add popen_processes proc id
@ -1077,7 +1081,8 @@ let establish_server server_fun sockaddr =
(* The "double fork" trick, the process which calls server_fun will not
leave a zombie process *)
match fork() with
0 -> if fork() <> 0 then exit 0; (* The son exits, the grandson works *)
0 -> if fork() <> 0 then sys_exit 0;
(* The son exits, the grandson works *)
close sock;
ignore(try_set_close_on_exec s);
let inchan = in_channel_of_descr s in

16
parsing/ast_invariants.ml
View File

@ -55,7 +55,13 @@ let iterator =
| _ -> ()
in
let pat self pat =
super.pat self pat;
begin match pat.ppat_desc with
| Ppat_construct (_, Some ({ppat_desc = Ppat_tuple _} as p))
when Builtin_attributes.explicit_arity pat.ppat_attributes ->
super.pat self p (* allow unary tuple, see GPR#523. *)
| _ ->
super.pat self pat
end;
let loc = pat.ppat_loc in
match pat.ppat_desc with
| Ppat_tuple ([] | [_]) -> invalid_tuple loc
@ -66,7 +72,13 @@ let iterator =
| _ -> ()
in
let expr self exp =
super.expr self exp;
begin match exp.pexp_desc with
| Pexp_construct (_, Some ({pexp_desc = Pexp_tuple _} as e))
when Builtin_attributes.explicit_arity exp.pexp_attributes ->
super.expr self e (* allow unary tuple, see GPR#523. *)
| _ ->
super.expr self exp
end;
let loc = exp.pexp_loc in
match exp.pexp_desc with
| Pexp_tuple ([] | [_]) -> invalid_tuple loc

1
parsing/docstrings.ml
View File

@ -128,6 +128,7 @@ let add_info_attrs info attrs =
type text = docstring list
let empty_text = []
let empty_text_lazy = lazy []
let text_loc = {txt = "ocaml.text"; loc = Location.none}

1
parsing/docstrings.mli
View File

@ -117,6 +117,7 @@ val rhs_info : int -> info
type text = docstring list
val empty_text : text
val empty_text_lazy : text Lazy.t
val text_attr : docstring -> Parsetree.attribute

11
parsing/parser.mly
View File

@ -365,12 +365,13 @@ type let_bindings =
lbs_extension: string Asttypes.loc option;
lbs_loc: Location.t }
let mklb (p, e) attrs =
let mklb first (p, e) attrs =
{ lb_pattern = p;
lb_expression = e;
lb_attributes = attrs;
lb_docs = symbol_docs_lazy ();
lb_text = symbol_text_lazy ();
lb_text = if first then empty_text_lazy
else symbol_text_lazy ();
lb_loc = symbol_rloc (); }
let mklbs ext rf lb =
@ -1488,7 +1489,7 @@ simple_expr:
{ mkexp_attrs (Pexp_construct (mkloc (Lident "()") (symbol_rloc ()),
None)) $2 }
| BEGIN ext_attributes seq_expr error
{ unclosed "begin" 1 "end" 3 }
{ unclosed "begin" 1 "end" 4 }
| LPAREN seq_expr type_constraint RPAREN
{ mkexp_constraint $2 $3 }
| simple_expr DOT label_longident
@ -1640,11 +1641,11 @@ let_bindings:
let_binding:
LET ext_attributes rec_flag let_binding_body post_item_attributes
{ let (ext, attr) = $2 in
mklbs ext $3 (mklb $4 (attr@$5)) }
mklbs ext $3 (mklb true $4 (attr@$5)) }
;
and_let_binding:
AND attributes let_binding_body post_item_attributes
{ mklb $3 ($2@$4) }
{ mklb false $3 ($2@$4) }
;
fun_binding:
strict_binding

3
parsing/pprintast.ml
View File

@ -476,7 +476,8 @@ class printer ()= object(self:'self)
self#paren true self#reset#expression f x
| Pexp_ifthenelse _ | Pexp_sequence _ when ifthenelse ->
self#paren true self#reset#expression f x
| Pexp_let _ | Pexp_letmodule _ | Pexp_letexception _ when semi ->
| Pexp_let _ | Pexp_letmodule _ | Pexp_open _ | Pexp_letexception _
when semi ->
self#paren true self#reset#expression f x
| Pexp_fun (l, e0, p, e) ->
pp f "@[<2>fun@;%a@;->@;%a@]"

3
stdlib/Makefile.shared
View File

@ -20,7 +20,8 @@ TARGET_BINDIR ?= $(BINDIR)
COMPILER=../ocamlc
CAMLC=$(CAMLRUN) $(COMPILER)
COMPFLAGS=-strict-sequence -absname -w +a-4-9-41-42-44-45-48 -g -warn-error A -bin-annot -nostdlib \
COMPFLAGS=-strict-sequence -absname -w +a-4-9-41-42-44-45-48 \
-g -warn-error A -bin-annot -nostdlib \
-safe-string -strict-formats
ifeq "$(FLAMBDA)" "true"
OPTCOMPFLAGS=-O3

59
stdlib/arg.ml
View File

@ -46,7 +46,7 @@ type error =
| Missing of string
| Message of string
exception Stop of error;; (* used internally *)
exception Stop of error (* used internally *)
open Printf
@ -55,19 +55,19 @@ let rec assoc3 x l =
| [] -> raise Not_found
| (y1, y2, _) :: _ when y1 = x -> y2
| _ :: t -> assoc3 x t
;;
let split s =
let i = String.index s '=' in
let len = String.length s in
String.sub s 0 i, String.sub s (i+1) (len-(i+1))
;;
let make_symlist prefix sep suffix l =
match l with
| [] -> "<none>"
| h::t -> (List.fold_left (fun x y -> x ^ sep ^ y) (prefix ^ h) t) ^ suffix
;;
let print_spec buf (key, spec, doc) =
if String.length doc > 0 then
@ -76,9 +76,9 @@ let print_spec buf (key, spec, doc) =
bprintf buf " %s %s%s\n" key (make_symlist "{" "|" "}" l) doc
| _ ->
bprintf buf " %s %s\n" key doc
;;
let help_action () = raise (Stop (Unknown "-help"));;
let help_action () = raise (Stop (Unknown "-help"))
let add_help speclist =
let add1 =
@ -91,24 +91,24 @@ let add_help speclist =
["--help", Unit help_action, " Display this list of options"]
in
speclist @ (add1 @ add2)
;;
let usage_b buf speclist errmsg =
bprintf buf "%s\n" errmsg;
List.iter (print_spec buf) (add_help speclist);
;;
List.iter (print_spec buf) (add_help speclist)
let usage_string speclist errmsg =
let b = Buffer.create 200 in
usage_b b speclist errmsg;
Buffer.contents b;
;;
Buffer.contents b
let usage speclist errmsg =
eprintf "%s" (usage_string speclist errmsg);
;;
eprintf "%s" (usage_string speclist errmsg)
let current = ref 0;;
let current = ref 0
let bool_of_string_opt x =
try Some (bool_of_string x)
@ -247,28 +247,28 @@ let parse_argv_dynamic ?(current=current) argv speclist anonfun errmsg =
(try anonfun s with Bad m -> stop (Message m));
incr current;
end;
done;
;;
done
let parse_argv ?(current=current) argv speclist anonfun errmsg =
parse_argv_dynamic ~current:current argv (ref speclist) anonfun errmsg;
;;
parse_argv_dynamic ~current:current argv (ref speclist) anonfun errmsg
let parse l f msg =
try
parse_argv Sys.argv l f msg;
parse_argv Sys.argv l f msg
with
| Bad msg -> eprintf "%s" msg; exit 2;
| Help msg -> printf "%s" msg; exit 0;
;;
| Bad msg -> eprintf "%s" msg; exit 2
| Help msg -> printf "%s" msg; exit 0
let parse_dynamic l f msg =
try
parse_argv_dynamic Sys.argv l f msg;
parse_argv_dynamic Sys.argv l f msg
with
| Bad msg -> eprintf "%s" msg; exit 2;
| Help msg -> printf "%s" msg; exit 0;
;;
| Bad msg -> eprintf "%s" msg; exit 2
| Help msg -> printf "%s" msg; exit 0
let second_word s =
let len = String.length s in
@ -279,13 +279,13 @@ let second_word s =
in
try loop (String.index s ' ')
with Not_found -> len
;;
let max_arg_len cur (kwd, spec, doc) =
match spec with
| Symbol _ -> max cur (String.length kwd)
| _ -> max cur (String.length kwd + second_word doc)
;;
let add_padding len ksd =
match ksd with
@ -308,11 +308,10 @@ let add_padding len ksd =
let prefix = String.sub msg 0 cutcol in
let suffix = String.sub msg cutcol (String.length msg - cutcol) in
(kwd, spec, prefix ^ spaces ^ suffix)
;;
let align ?(limit=max_int) speclist =
let completed = add_help speclist in
let len = List.fold_left max_arg_len 0 completed in
let len = min len limit in
List.map (add_padding len) completed
;;

15
stdlib/array.ml
View File

@ -132,7 +132,6 @@ let to_list a =
let rec list_length accu = function
| [] -> accu
| _::t -> list_length (succ accu) t
;;
let of_list = function
[] -> [||]
@ -189,7 +188,7 @@ let memq x a =
else loop (succ i) in
loop 0
exception Bottom of int;;
exception Bottom of int
let sort cmp a =
let maxson l i =
let i31 = i+i+i+1 in
@ -236,10 +235,10 @@ let sort cmp a =
set a i (get a 0);
trickleup (bubble i 0) e;
done;
if l > 1 then (let e = (get a 1) in set a 1 (get a 0); set a 0 e);
;;
if l > 1 then (let e = (get a 1) in set a 1 (get a 0); set a 0 e)
let cutoff = 5;;
let cutoff = 5
let stable_sort cmp a =
let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
let src1r = src1ofs + src1len and src2r = src2ofs + src2len in
@ -289,7 +288,7 @@ let stable_sort cmp a =
sortto l1 t 0 l2;
sortto 0 a l2 l1;
merge l2 l1 t 0 l2 a 0;
end;
;;
end
let fast_sort = stable_sort;;
let fast_sort = stable_sort

16
stdlib/buffer.ml
View File

@ -34,7 +34,7 @@ let sub b ofs len =
if ofs < 0 || len < 0 || ofs > b.position - len
then invalid_arg "Buffer.sub"
else Bytes.sub_string b.buffer ofs len
;;
let blit src srcoff dst dstoff len =
if len < 0 || srcoff < 0 || srcoff > src.position - len
@ -42,13 +42,13 @@ let blit src srcoff dst dstoff len =
then invalid_arg "Buffer.blit"
else
Bytes.unsafe_blit src.buffer srcoff dst dstoff len
;;
let nth b ofs =
if ofs < 0 || ofs >= b.position then
invalid_arg "Buffer.nth"
else Bytes.unsafe_get b.buffer ofs
;;
let length b = b.position
@ -124,7 +124,7 @@ let output_buffer oc b =
let closing = function
| '(' -> ')'
| '{' -> '}'
| _ -> assert false;;
| _ -> assert false
(* opening and closing: open and close characters, typically ( and )
k: balance of opening and closing chars
@ -137,7 +137,7 @@ let advance_to_closing opening closing k s start =
if s.[i] = closing then
if k = 0 then i else advance (k - 1) (i + 1) lim
else advance k (i + 1) lim in
advance k start (String.length s);;
advance k start (String.length s)
let advance_to_non_alpha s start =
let rec advance i lim =
@ -145,7 +145,7 @@ let advance_to_non_alpha s start =
match s.[i] with
| 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' -> advance (i + 1) lim
| _ -> i in
advance start (String.length s);;
advance start (String.length s)
(* We are just at the beginning of an ident in s, starting at start. *)
let find_ident s start lim =
@ -159,7 +159,7 @@ let find_ident s start lim =
(* Regular ident *)
| _ ->
let stop = advance_to_non_alpha s (start + 1) in
String.sub s start (stop - start), stop;;
String.sub s start (stop - start), stop
(* Substitute $ident, $(ident), or ${ident} in s,
according to the function mapping f. *)
@ -187,4 +187,4 @@ let add_substitute b f s =
subst current (i + 1)
end else
if previous = '\\' then add_char b previous in
subst ' ' 0;;
subst ' ' 0

22
stdlib/bytes.ml
View File

@ -44,7 +44,7 @@ let init n f =
done;
s
let empty = create 0;;
let empty = create 0
let copy s =
let len = length s in
@ -122,7 +122,7 @@ let cat s1 s2 =
unsafe_blit s1 0 r 0 l1;
unsafe_blit s2 0 r l1 l2;
r
;;
external char_code: char -> int = "%identity"
external char_chr: int -> char = "%identity"
@ -217,27 +217,27 @@ let uncapitalize_ascii s = apply1 Char.lowercase_ascii s
let rec index_rec s lim i c =
if i >= lim then raise Not_found else
if unsafe_get s i = c then i else index_rec s lim (i + 1) c;;
if unsafe_get s i = c then i else index_rec s lim (i + 1) c
let index s c = index_rec s (length s) 0 c;;
let index s c = index_rec s (length s) 0 c
let index_from s i c =
let l = length s in
if i < 0 || i > l then invalid_arg "String.index_from / Bytes.index_from" else
index_rec s l i c;;
index_rec s l i c
let rec rindex_rec s i c =
if i < 0 then raise Not_found else
if unsafe_get s i = c then i else rindex_rec s (i - 1) c;;
if unsafe_get s i = c then i else rindex_rec s (i - 1) c
let rindex s c = rindex_rec s (length s - 1) c;;
let rindex s c = rindex_rec s (length s - 1) c
let rindex_from s i c =
if i < -1 || i >= length s then
invalid_arg "String.rindex_from / Bytes.rindex_from"
else
rindex_rec s i c
;;
let contains_from s i c =
let l = length s in
@ -245,16 +245,16 @@ let contains_from s i c =
invalid_arg "String.contains_from / Bytes.contains_from"
else
try ignore (index_rec s l i c); true with Not_found -> false
;;
let contains s c = contains_from s 0 c;;
let contains s c = contains_from s 0 c
let rcontains_from s i c =
if i < 0 || i >= length s then
invalid_arg "String.rcontains_from / Bytes.rcontains_from"
else
try ignore (rindex_rec s i c); true with Not_found -> false
;;
type t = bytes

4
stdlib/camlinternalFormatBasics.ml
View File

@ -107,11 +107,11 @@ position in the format tail (('u, .., 'f) fmt). This means that the
type of the expected format parameter depends of where the %(...%)
are in the format string:
# Printf.printf "%(%)";;
# Printf.printf "%(%)"
- : (unit, out_channel, unit, '_a, '_a, unit)
CamlinternalFormatBasics.format6 -> unit
= <fun>
# Printf.printf "%(%)%d";;
# Printf.printf "%(%)%d"
- : (int -> unit, out_channel, unit, '_a, '_a, int -> unit)
CamlinternalFormatBasics.format6 -> int -> unit
= <fun>

11
stdlib/camlinternalLazy.ml
View File

@ -15,9 +15,9 @@
(* Internals of forcing lazy values. *)
exception Undefined;;
exception Undefined
let raise_undefined = Obj.repr (fun () -> raise Undefined);;
let raise_undefined = Obj.repr (fun () -> raise Undefined)
(* Assume [blk] is a block with tag lazy *)
let force_lazy_block (blk : 'arg lazy_t) =
@ -32,7 +32,7 @@ let force_lazy_block (blk : 'arg lazy_t) =
with e ->
Obj.set_field (Obj.repr blk) 0 (Obj.repr (fun () -> raise e));
raise e
;;
(* Assume [blk] is a block with tag lazy *)
let force_val_lazy_block (blk : 'arg lazy_t) =
@ -43,7 +43,7 @@ let force_val_lazy_block (blk : 'arg lazy_t) =
Obj.set_field (Obj.repr blk) 0 (Obj.repr result);
Obj.set_tag (Obj.repr blk) (Obj.forward_tag);
result
;;
(* [force] is not used, since [Lazy.force] is declared as a primitive
whose code inlines the tag tests of its argument. This function is
@ -55,7 +55,7 @@ let force (lzv : 'arg lazy_t) =
if t = Obj.forward_tag then (Obj.obj (Obj.field x 0) : 'arg) else
if t <> Obj.lazy_tag then (Obj.obj x : 'arg)
else force_lazy_block lzv
;;
let force_val (lzv : 'arg lazy_t) =
let x = Obj.repr lzv in
@ -63,4 +63,3 @@ let force_val (lzv : 'arg lazy_t) =
if t = Obj.forward_tag then (Obj.obj (Obj.field x 0) : 'arg) else
if t <> Obj.lazy_tag then (Obj.obj x : 'arg)
else force_val_lazy_block lzv
;;

10
stdlib/camlinternalLazy.mli
View File

@ -17,11 +17,11 @@
All functions in this module are for system use only, not for the
casual user. *)
exception Undefined;;
exception Undefined
val force_lazy_block : 'a lazy_t -> 'a ;;
val force_lazy_block : 'a lazy_t -> 'a
val force_val_lazy_block : 'a lazy_t -> 'a ;;
val force_val_lazy_block : 'a lazy_t -> 'a
val force : 'a lazy_t -> 'a ;;
val force_val : 'a lazy_t -> 'a ;;
val force : 'a lazy_t -> 'a
val force_val : 'a lazy_t -> 'a

6
stdlib/filename.ml
View File

@ -74,7 +74,7 @@ module Unix = struct
let parent_dir_name = ".."
let dir_sep = "/"
let is_dir_sep s i = s.[i] = '/'
let is_relative n = String.length n < 1 || n.[0] <> '/';;
let is_relative n = String.length n < 1 || n.[0] <> '/'
let is_implicit n =
is_relative n
&& (String.length n < 2 || String.sub n 0 2 <> "./")
@ -210,12 +210,12 @@ let chop_extension name =
external open_desc: string -> open_flag list -> int -> int = "caml_sys_open"
external close_desc: int -> unit = "caml_sys_close"
let prng = lazy(Random.State.make_self_init ());;
let prng = lazy(Random.State.make_self_init ())
let temp_file_name temp_dir prefix suffix =
let rnd = (Random.State.bits (Lazy.force prng)) land 0xFFFFFF in
concat temp_dir (Printf.sprintf "%s%06x%s" prefix rnd suffix)
;;
let current_temp_dir_name = ref temp_dir_name

252
stdlib/format.ml
View File

@ -22,12 +22,12 @@
(* A devoted type for sizes to avoid confusion
between sizes and mere integers. *)
type size;;
type size
external size_of_int : int -> size = "%identity"
;;
external int_of_size : size -> int = "%identity"
;;
(* The pretty-printing boxes definition:
a pretty-printing box is either
@ -45,7 +45,7 @@ external int_of_size : size -> int = "%identity"
*)
type box_type = CamlinternalFormatBasics.block_type =
| Pp_hbox | Pp_vbox | Pp_hvbox | Pp_hovbox | Pp_box | Pp_fits
;;
(* The pretty-printing tokens definition:
are either text to print or pretty printing
@ -68,7 +68,7 @@ type pp_token =
and tag = string
and tbox = Pp_tbox of int list ref (* Tabulation box *)
;;
(* The pretty-printer queue definition:
pretty-printing material is not written in the output as soon as emitted;
@ -89,13 +89,13 @@ and 'a queue_cell = {
mutable head : 'a;
mutable tail : 'a queue_elem;
}
;;
type 'a queue = {
mutable insert : 'a queue_elem;
mutable body : 'a queue_elem;
}
;;
(* The pretty-printer queue: queue element definition.
The pretty-printer queue contains formatting elements to be printed.
@ -109,20 +109,20 @@ type pp_queue_elem = {
token : pp_token;
length : int;
}
;;
(* The pretty-printer queue definition. *)
type pp_queue = pp_queue_elem queue;;
type pp_queue = pp_queue_elem queue
(* The pretty-printer scanning stack. *)
(* The pretty-printer scanning stack: scanning element definition.
Each element is (left_total, queue element) where left_total
is the value of pp_left_total when the element has been enqueued. *)
type pp_scan_elem = Scan_elem of int * pp_queue_elem;;
type pp_scan_elem = Scan_elem of int * pp_queue_elem
(* The pretty-printer scanning stack definition. *)
type pp_scan_stack = pp_scan_elem list;;
type pp_scan_stack = pp_scan_elem list
(* The pretty-printer formatting stack:
the formatting stack contains the description of all the currently active
@ -131,13 +131,13 @@ type pp_scan_stack = pp_scan_elem list;;
(* The pretty-printer formatting stack: formatting stack element definition.
Each stack element describes a pretty-printing box. *)
type pp_format_elem = Format_elem of box_type * int;;
type pp_format_elem = Format_elem of box_type * int
(* The pretty-printer formatting stack definition. *)
type pp_format_stack = pp_format_elem list;;
type pp_format_stack = pp_format_elem list
(* The pretty-printer semantics tag stack definition. *)
type pp_tag_stack = tag list;;
type pp_tag_stack = tag list
(* The formatter definition.
Each formatter value is a pretty-printer instance with all its
@ -192,7 +192,7 @@ type formatter = {
(* The pretty-printer queue. *)
mutable pp_queue : pp_queue;
}
;;
(* The formatter specific tag handling functions. *)
type formatter_tag_functions = {
@ -201,7 +201,7 @@ type formatter_tag_functions = {
print_open_tag : tag -> unit;
print_close_tag : tag -> unit;
}
;;
(* The formatter functions to output material. *)
type formatter_out_functions = {
@ -210,7 +210,7 @@ type formatter_out_functions = {
out_newline : unit -> unit;
out_spaces : int -> unit;
}
;;
(*
@ -220,9 +220,9 @@ type formatter_out_functions = {
(* Queues auxiliaries. *)
let make_queue () = { insert = Nil; body = Nil; };;
let make_queue () = { insert = Nil; body = Nil; }
let clear_queue q = q.insert <- Nil; q.body <- Nil;;
let clear_queue q = q.insert <- Nil; q.body <- Nil
let add_queue x q =
let c = Cons { head = x; tail = Nil; } in
@ -232,14 +232,14 @@ let add_queue x q =
(* Invariant: when insert is Nil body should be Nil. *)
| { insert = Nil; body = _; } ->
q.insert <- c; q.body <- c
;;
exception Empty_queue;;
exception Empty_queue
let peek_queue = function
| { body = Cons { head = x; tail = _; }; _ } -> x
| { body = Nil; insert = _; } -> raise Empty_queue
;;
let take_queue = function
| { body = Cons { head = x; tail = tl; }; _ } as q ->
@ -247,18 +247,18 @@ let take_queue = function
if tl = Nil then q.insert <- Nil; (* Maintain the invariant. *)
x
| { body = Nil; insert = _; } -> raise Empty_queue
;;
(* Enter a token in the pretty-printer queue. *)
let pp_enqueue state ({ length = len; _} as token) =
state.pp_right_total <- state.pp_right_total + len;
add_queue token state.pp_queue
;;
let pp_clear_queue state =
state.pp_left_total <- 1; state.pp_right_total <- 1;
clear_queue state.pp_queue
;;
(* Pp_infinity: large value for default tokens size.
@ -280,7 +280,7 @@ let pp_clear_queue state =
+ 1 is in practice large enough, there is no need to attempt to set
pp_infinity to the theoretically maximum limit. It is not worth the
burden ! *)
let pp_infinity = 1000000010;;
let pp_infinity = 1000000010
(* Output functions for the formatter. *)
let pp_output_string state s = state.pp_out_string s 0 (String.length s)
@ -297,16 +297,16 @@ let break_new_line state offset width =
state.pp_current_indent <- real_indent;
state.pp_space_left <- state.pp_margin - state.pp_current_indent;
pp_output_spaces state state.pp_current_indent
;;
(* To force a line break inside a box: no offset is added. *)
let break_line state width = break_new_line state 0 width;;
let break_line state width = break_new_line state 0 width
(* To format a break that fits on the current line. *)
let break_same_line state width =
state.pp_space_left <- state.pp_space_left - width;
pp_output_spaces state width
;;
(* To indent no more than pp_max_indent, if one tries to open a box
beyond pp_max_indent, then the box is rejected on the left
@ -320,7 +320,7 @@ let pp_force_break_line state =
| Pp_vbox | Pp_hvbox | Pp_hovbox | Pp_box ->
break_line state width)
| [] -> pp_output_newline state
;;
(* To skip a token, if the previous line has been broken. *)
let pp_skip_token state =
@ -329,7 +329,7 @@ let pp_skip_token state =
| { elem_size = size; length = len; token = _; } ->
state.pp_left_total <- state.pp_left_total - len;
state.pp_space_left <- state.pp_space_left + int_of_size size
;;
(*
@ -455,7 +455,7 @@ let format_pp_token state size = function
state.pp_mark_stack <- tags
| [] -> () (* No more tag to close. *)
end
;;
(* Print if token size is known else printing is delayed.
Size is known when not negative.
@ -476,31 +476,31 @@ let rec advance_loop state =
state.pp_left_total <- len + state.pp_left_total;
advance_loop state
end
;;
let advance_left state =
try advance_loop state with
| Empty_queue -> ()
;;
(* To enqueue a token : try to advance. *)
let enqueue_advance state tok = pp_enqueue state tok; advance_left state;;
let enqueue_advance state tok = pp_enqueue state tok; advance_left state
(* Building pretty-printer queue elements. *)
let make_queue_elem size tok len =
{ elem_size = size; token = tok; length = len; }
;;
(* To enqueue strings. *)
let enqueue_string_as state size s =
let len = int_of_size size in
enqueue_advance state (make_queue_elem size (Pp_text s) len)
;;
let enqueue_string state s =
let len = String.length s in
enqueue_string_as state (size_of_int len) s
;;
(* Routines for scan stack
determine size of boxes. *)
@ -509,10 +509,10 @@ let enqueue_string state s =
let scan_stack_bottom =
let q_elem = make_queue_elem (size_of_int (-1)) (Pp_text "") 0 in
[Scan_elem (-1, q_elem)]
;;
(* Clearing the pretty-printer scanning stack. *)
let clear_scan_stack state = state.pp_scan_stack <- scan_stack_bottom;;
let clear_scan_stack state = state.pp_scan_stack <- scan_stack_bottom
(* Setting the size of boxes on scan stack:
if ty = true then size of break is set else size of box is set;
@ -550,7 +550,7 @@ let set_size state ty =
() (* scan_push is only used for breaks and boxes. *)
end
| [] -> () (* scan_stack is never empty. *)
;;
(* Push a token on pretty-printer scanning stack.
If b is true set_size is called. *)
@ -559,7 +559,7 @@ let scan_push state b tok =
if b then set_size state true;
state.pp_scan_stack <-
Scan_elem (state.pp_right_total, tok) :: state.pp_scan_stack
;;
(* To open a new box :
the user may set the depth bound pp_max_boxes
@ -575,10 +575,10 @@ let pp_open_box_gen state indent br_ty =
scan_push state false elem else
if state.pp_curr_depth = state.pp_max_boxes
then enqueue_string state state.pp_ellipsis
;;
(* The box which is always opened. *)
let pp_open_sys_box state = pp_open_box_gen state 0 Pp_hovbox;;
let pp_open_sys_box state = pp_open_box_gen state 0 Pp_hovbox
(* Close a box, setting sizes of its sub boxes. *)
let pp_close_box state () =
@ -592,7 +592,7 @@ let pp_close_box state () =
end;
state.pp_curr_depth <- state.pp_curr_depth - 1;
end
;;
(* Open a tag, pushing it on the tag stack. *)
let pp_open_tag state tag_name =
@ -607,7 +607,7 @@ let pp_open_tag state tag_name =
token = Pp_open_tag tag_name;
length = 0;
}
;;
(* Close a tag, popping it from the tag stack. *)
let pp_close_tag state () =
@ -625,15 +625,15 @@ let pp_close_tag state () =
state.pp_tag_stack <- tags
| _ -> () (* No more tag to close. *)
end
;;
let pp_set_print_tags state b = state.pp_print_tags <- b;;
let pp_set_mark_tags state b = state.pp_mark_tags <- b;;
let pp_get_print_tags state () = state.pp_print_tags;;
let pp_get_mark_tags state () = state.pp_mark_tags;;
let pp_set_print_tags state b = state.pp_print_tags <- b
let pp_set_mark_tags state b = state.pp_mark_tags <- b
let pp_get_print_tags state () = state.pp_print_tags
let pp_get_mark_tags state () = state.pp_mark_tags
let pp_set_tags state b =
pp_set_print_tags state b; pp_set_mark_tags state b
;;
(* Handling tag handling functions: get/set functions. *)
let pp_get_formatter_tag_functions state () = {
@ -642,7 +642,7 @@ let pp_get_formatter_tag_functions state () = {
print_open_tag = state.pp_print_open_tag;
print_close_tag = state.pp_print_close_tag;
}
;;
let pp_set_formatter_tag_functions state {
mark_open_tag = mot;
@ -654,7 +654,7 @@ let pp_set_formatter_tag_functions state {
state.pp_mark_close_tag <- mct;
state.pp_print_open_tag <- pot;
state.pp_print_close_tag <- pct
;;
(* Initialize pretty-printer. *)
let pp_rinit state =
@ -668,7 +668,7 @@ let pp_rinit state =
state.pp_curr_depth <- 0;
state.pp_space_left <- state.pp_margin;
pp_open_sys_box state
;;
(* Flushing pretty-printer queue. *)
let pp_flush_queue state b =
@ -679,7 +679,7 @@ let pp_flush_queue state b =
advance_left state;
if b then pp_output_newline state;
pp_rinit state
;;
(*
@ -691,29 +691,29 @@ let pp_flush_queue state b =
let pp_print_as_size state size s =
if state.pp_curr_depth < state.pp_max_boxes
then enqueue_string_as state size s
;;
let pp_print_as state isize s =
pp_print_as_size state (size_of_int isize) s
;;
let pp_print_string state s =
pp_print_as state (String.length s) s
;;
(* To format an integer. *)
let pp_print_int state i = pp_print_string state (string_of_int i);;
let pp_print_int state i = pp_print_string state (string_of_int i)
(* To format a float. *)
let pp_print_float state f = pp_print_string state (string_of_float f);;
let pp_print_float state f = pp_print_string state (string_of_float f)
(* To format a boolean. *)
let pp_print_bool state b = pp_print_string state (string_of_bool b);;
let pp_print_bool state b = pp_print_string state (string_of_bool b)
(* To format a char. *)
let pp_print_char state c =
pp_print_as state 1 (String.make 1 c)
;;
(* Opening boxes. *)
let pp_open_hbox state () = pp_open_box_gen state 0 Pp_hbox
@ -722,7 +722,7 @@ and pp_open_vbox state indent = pp_open_box_gen state indent Pp_vbox
and pp_open_hvbox state indent = pp_open_box_gen state indent Pp_hvbox
and pp_open_hovbox state indent = pp_open_box_gen state indent Pp_hovbox
and pp_open_box state indent = pp_open_box_gen state indent Pp_box
;;
(* Printing all queued text.
[print_newline] prints a new line after flushing the queue.
@ -731,19 +731,19 @@ let pp_print_newline state () =
pp_flush_queue state true; state.pp_out_flush ()
and pp_print_flush state () =
pp_flush_queue state false; state.pp_out_flush ()
;;
(* To get a newline when one does not want to close the current box. *)
let pp_force_newline state () =
if state.pp_curr_depth < state.pp_max_boxes then
enqueue_advance state (make_queue_elem (size_of_int 0) Pp_newline 0)
;;
(* To format something, only in case the line has just been broken. *)
let pp_print_if_newline state () =
if state.pp_curr_depth < state.pp_max_boxes then
enqueue_advance state (make_queue_elem (size_of_int 0) Pp_if_newline 0)
;;
(* Printing break hints:
A break hint indicates where a box may be broken.
@ -757,7 +757,7 @@ let pp_print_break state width offset =
(Pp_break (width, offset))
width in
scan_push state true elem
;;
(* Print a space :
a space is a break hint that prints a single space if the break does not
@ -766,7 +766,7 @@ let pp_print_break state width offset =
line. *)
let pp_print_space state () = pp_print_break state 1 0
and pp_print_cut state () = pp_print_break state 0 0
;;
(* Tabulation boxes. *)
let pp_open_tbox state () =
@ -775,7 +775,7 @@ let pp_open_tbox state () =
let elem =
make_queue_elem (size_of_int 0) (Pp_tbegin (Pp_tbox (ref []))) 0 in
enqueue_advance state elem
;;
(* Close a tabulation box. *)
let pp_close_tbox state () =
@ -786,7 +786,7 @@ let pp_close_tbox state () =
enqueue_advance state elem;
state.pp_curr_depth <- state.pp_curr_depth - 1
end
;;
(* Print a tabulation break. *)
let pp_print_tbreak state width offset =
@ -797,16 +797,16 @@ let pp_print_tbreak state width offset =
(Pp_tbreak (width, offset))
width in
scan_push state true elem
;;
let pp_print_tab state () = pp_print_tbreak state 0 0;;
let pp_print_tab state () = pp_print_tbreak state 0 0
let pp_set_tab state () =
if state.pp_curr_depth < state.pp_max_boxes then
let elem =
make_queue_elem (size_of_int 0) Pp_stab 0 in
enqueue_advance state elem
;;
(*
@ -815,22 +815,22 @@ let pp_set_tab state () =
*)
(* Set_max_boxes. *)
let pp_set_max_boxes state n = if n > 1 then state.pp_max_boxes <- n;;
let pp_set_max_boxes state n = if n > 1 then state.pp_max_boxes <- n
(* To know the current maximum number of boxes allowed. *)
let pp_get_max_boxes state () = state.pp_max_boxes;;
let pp_get_max_boxes state () = state.pp_max_boxes
let pp_over_max_boxes state () = state.pp_curr_depth = state.pp_max_boxes;;
let pp_over_max_boxes state () = state.pp_curr_depth = state.pp_max_boxes
(* Ellipsis. *)
let pp_set_ellipsis_text state s = state.pp_ellipsis <- s
and pp_get_ellipsis_text state () = state.pp_ellipsis
;;
(* To set the margin of pretty-printer. *)
let pp_limit n =
if n < pp_infinity then n else pred pp_infinity
;;
(* Internal pretty-printer functions. *)
let pp_set_min_space_left state n =
@ -839,16 +839,16 @@ let pp_set_min_space_left state n =
state.pp_min_space_left <- n;
state.pp_max_indent <- state.pp_margin - state.pp_min_space_left;
pp_rinit state
;;
(* Initially, we have :
pp_max_indent = pp_margin - pp_min_space_left, and
pp_space_left = pp_margin. *)
let pp_set_max_indent state n =
pp_set_min_space_left state (state.pp_margin - n)
;;
let pp_get_max_indent state () = state.pp_max_indent;;
let pp_get_max_indent state () = state.pp_max_indent
let pp_set_margin state n =
if n >= 1 then
@ -865,9 +865,9 @@ let pp_set_margin state n =
(state.pp_margin / 2)) 1 in
(* Rebuild invariants. *)
pp_set_max_indent state new_max_indent
;;
let pp_get_margin state () = state.pp_margin;;
let pp_get_margin state () = state.pp_margin
(* Setting a formatter basic output functions. *)
let pp_set_formatter_out_functions state {
@ -879,8 +879,8 @@ let pp_set_formatter_out_functions state {
state.pp_out_string <- f;
state.pp_out_flush <- g;
state.pp_out_newline <- h;
state.pp_out_spaces <- i;
;;
state.pp_out_spaces <- i
let pp_get_formatter_out_functions state () = {
out_string = state.pp_out_string;
@ -888,24 +888,24 @@ let pp_get_formatter_out_functions state () = {
out_newline = state.pp_out_newline;
out_spaces = state.pp_out_spaces;
}
;;
(* Setting a formatter basic string output and flush functions. *)
let pp_set_formatter_output_functions state f g =
state.pp_out_string <- f; state.pp_out_flush <- g
;;
let pp_get_formatter_output_functions state () =
(state.pp_out_string, state.pp_out_flush)
;;
let pp_flush_formatter state =
pp_flush_queue state false
(* The default function to output new lines. *)
let display_newline state () = state.pp_out_string "\n" 0 1;;
let display_newline state () = state.pp_out_string "\n" 0 1
(* The default function to output spaces. *)
let blank_line = String.make 80 ' ';;
let blank_line = String.make 80 ' '
let rec display_blanks state n =
if n > 0 then
if n <= 80 then state.pp_out_string blank_line 0 n else
@ -913,7 +913,7 @@ let rec display_blanks state n =
state.pp_out_string blank_line 0 80;
display_blanks state (n - 80)
end
;;
(* Setting a formatter basic output functions as printing to a given
[Pervasive.out_channel] value. *)
@ -921,8 +921,8 @@ let pp_set_formatter_out_channel state os =
state.pp_out_string <- output_substring os;
state.pp_out_flush <- (fun () -> flush os);
state.pp_out_newline <- display_newline state;
state.pp_out_spaces <- display_blanks state;
;;
state.pp_out_spaces <- display_blanks state
(*
@ -930,11 +930,11 @@ let pp_set_formatter_out_channel state os =
*)
let default_pp_mark_open_tag s = "<" ^ s ^ ">";;
let default_pp_mark_close_tag s = "</" ^ s ^ ">";;
let default_pp_mark_open_tag s = "<" ^ s ^ ">"
let default_pp_mark_close_tag s = "</" ^ s ^ ">"
let default_pp_print_open_tag = ignore;;
let default_pp_print_close_tag = ignore;;
let default_pp_print_open_tag = ignore
let default_pp_print_close_tag = ignore
(* Bulding a formatter given its basic output functions.
Other fields get reasonable default values. *)
@ -977,7 +977,7 @@ let pp_make_formatter f g h i =
pp_print_close_tag = default_pp_print_close_tag;
pp_queue = pp_queue;
}
;;
(* Make a formatter with default functions to output spaces and new lines. *)
let make_formatter output flush =
@ -985,33 +985,33 @@ let make_formatter output flush =
ppf.pp_out_newline <- display_newline ppf;
ppf.pp_out_spaces <- display_blanks ppf;
ppf
;;
(* Make a formatter writing to a given [Pervasive.out_channel] value. *)
let formatter_of_out_channel oc =
make_formatter (output_substring oc) (fun () -> flush oc)
;;
(* Make a formatter writing to a given [Buffer.t] value. *)
let formatter_of_buffer b =
make_formatter (Buffer.add_substring b) ignore
;;
(* Allocating buffer for pretty-printing purposes.
Default buffer size is pp_buffer_size or 512.
*)
let pp_buffer_size = 512;;
let pp_make_buffer () = Buffer.create pp_buffer_size;;
let pp_buffer_size = 512
let pp_make_buffer () = Buffer.create pp_buffer_size
(* The standard (shared) buffer. *)
let stdbuf = pp_make_buffer ();;
let stdbuf = pp_make_buffer ()
(* Predefined formatters standard formatter to print
to [Pervasives.stdout], [Pervasives.stderr], and {!stdbuf}. *)
let std_formatter = formatter_of_out_channel Pervasives.stdout
and err_formatter = formatter_of_out_channel Pervasives.stderr
and str_formatter = formatter_of_buffer stdbuf
;;
(* [flush_buffer_formatter buf ppf] flushes formatter [ppf],
then return the contents of buffer [buff] thst is reset.
@ -1022,10 +1022,10 @@ let flush_buffer_formatter buf ppf =
let s = Buffer.contents buf in
Buffer.reset buf;
s
;;
(* Flush [str_formatter] and get the contents of [stdbuf]. *)
let flush_str_formatter () = flush_buffer_formatter stdbuf str_formatter;;
let flush_str_formatter () = flush_buffer_formatter stdbuf str_formatter
(*
@ -1103,7 +1103,7 @@ and get_mark_tags =
pp_get_mark_tags std_formatter
and set_tags =
pp_set_tags std_formatter
;;
(* Convenience functions *)
@ -1253,10 +1253,10 @@ let kfprintf k ppf (Format (fmt, _)) =
and ikfprintf k ppf (Format (fmt, _)) =
make_iprintf k ppf fmt
let fprintf ppf = kfprintf ignore ppf;;
let ifprintf ppf = ikfprintf ignore ppf;;
let printf fmt = fprintf std_formatter fmt;;
let eprintf fmt = fprintf err_formatter fmt;;
let fprintf ppf = kfprintf ignore ppf
let ifprintf ppf = ikfprintf ignore ppf
let printf fmt = fprintf std_formatter fmt
let eprintf fmt = fprintf err_formatter fmt
let ksprintf k (Format (fmt, _)) =
let b = pp_make_buffer () in
@ -1265,9 +1265,9 @@ let ksprintf k (Format (fmt, _)) =
strput_acc ppf acc;
k (flush_buffer_formatter b ppf) in
make_printf k () End_of_acc fmt
;;
let sprintf fmt = ksprintf (fun s -> s) fmt;;
let sprintf fmt = ksprintf (fun s -> s) fmt
let kasprintf k (Format (fmt, _)) =
let b = pp_make_buffer () in
@ -1276,13 +1276,13 @@ let kasprintf k (Format (fmt, _)) =
output_acc ppf acc;
k (flush_buffer_formatter b ppf) in
make_printf k ppf End_of_acc fmt
;;
let asprintf fmt = kasprintf (fun s -> s) fmt;;
let asprintf fmt = kasprintf (fun s -> s) fmt
(* Output everything left in the pretty printer queue at end of execution. *)
at_exit print_flush
;;
let () = at_exit print_flush
(*
@ -1295,24 +1295,24 @@ let pp_set_all_formatter_output_functions state
~out:f ~flush:g ~newline:h ~spaces:i =
pp_set_formatter_output_functions state f g;
state.pp_out_newline <- h;
state.pp_out_spaces <- i;
;;
state.pp_out_spaces <- i
(* Deprecated : subsumed by pp_get_formatter_out_functions *)
let pp_get_all_formatter_output_functions state () =
(state.pp_out_string, state.pp_out_flush,
state.pp_out_newline, state.pp_out_spaces)
;;
(* Deprecated : subsumed by set_formatter_out_functions *)
let set_all_formatter_output_functions =
pp_set_all_formatter_output_functions std_formatter
;;
(* Deprecated : subsumed by get_formatter_out_functions *)
let get_all_formatter_output_functions =
pp_get_all_formatter_output_functions std_formatter
;;
(* Deprecated : error prone function, do not use it.
Define a formatter of your own writing to the buffer,
@ -1322,7 +1322,7 @@ let get_all_formatter_output_functions =
let bprintf b (Format (fmt, _) : ('a, formatter, unit) format) =
let k ppf acc = output_acc ppf acc; pp_flush_queue ppf false in
make_printf k (formatter_of_buffer b) End_of_acc fmt
;;
(* Deprecated : alias for ksprintf. *)
let kprintf = ksprintf;;
let kprintf = ksprintf

50
stdlib/gc.ml
View File

@ -30,7 +30,7 @@ type stat = {
compactions : int;
top_heap_words : int;
stack_size : int;
};;
}
type control = {
mutable minor_heap_size : int;
@ -41,24 +41,24 @@ type control = {
mutable stack_limit : int;
mutable allocation_policy : int;
window_size : int;
};;
}
external stat : unit -> stat = "caml_gc_stat";;
external quick_stat : unit -> stat = "caml_gc_quick_stat";;
external counters : unit -> (float * float * float) = "caml_gc_counters";;
external get : unit -> control = "caml_gc_get";;
external set : control -> unit = "caml_gc_set";;
external minor : unit -> unit = "caml_gc_minor";;
external major_slice : int -> int = "caml_gc_major_slice";;
external major : unit -> unit = "caml_gc_major";;
external full_major : unit -> unit = "caml_gc_full_major";;
external compact : unit -> unit = "caml_gc_compaction";;
external stat : unit -> stat = "caml_gc_stat"
external quick_stat : unit -> stat = "caml_gc_quick_stat"
external counters : unit -> (float * float * float) = "caml_gc_counters"
external get : unit -> control = "caml_gc_get"
external set : control -> unit = "caml_gc_set"
external minor : unit -> unit = "caml_gc_minor"
external major_slice : int -> int = "caml_gc_major_slice"
external major : unit -> unit = "caml_gc_major"
external full_major : unit -> unit = "caml_gc_full_major"
external compact : unit -> unit = "caml_gc_compaction"
external get_minor_free : unit -> int = "caml_get_minor_free" [@@noalloc]
external get_bucket : int -> int = "caml_get_major_bucket" [@@noalloc]
external get_credit : unit -> int = "caml_get_major_credit" [@@noalloc]
external huge_fallback_count : unit -> int = "caml_gc_huge_fallback_count"
open Printf;;
open Printf
let print_stat c =
let st = stat () in
@ -81,32 +81,32 @@ let print_stat c =
fprintf c "\n";
fprintf c "live_blocks: %d\n" st.live_blocks;
fprintf c "free_blocks: %d\n" st.free_blocks;
fprintf c "heap_chunks: %d\n" st.heap_chunks;
;;
fprintf c "heap_chunks: %d\n" st.heap_chunks
let allocated_bytes () =
let (mi, pro, ma) = counters () in
(mi +. ma -. pro) *. float_of_int (Sys.word_size / 8)
;;
external finalise : ('a -> unit) -> 'a -> unit = "caml_final_register";;
external finalise_release : unit -> unit = "caml_final_release";;
type alarm = bool ref;;
type alarm_rec = {active : alarm; f : unit -> unit};;
external finalise : ('a -> unit) -> 'a -> unit = "caml_final_register"
external finalise_release : unit -> unit = "caml_final_release"
type alarm = bool ref
type alarm_rec = {active : alarm; f : unit -> unit}
let rec call_alarm arec =
if !(arec.active) then begin
finalise call_alarm arec;
arec.f ();
end;
;;
end
let create_alarm f =
let arec = { active = ref true; f = f } in
finalise call_alarm arec;
arec.active
;;
let delete_alarm a = a := false;;
let delete_alarm a = a := false

7
stdlib/gc.mli
View File

@ -185,9 +185,8 @@ external major_slice : int -> int = "caml_gc_major_slice"
Do a minor collection and a slice of major collection. [n] is the
size of the slice: the GC will do enough work to free (on average)
[n] words of memory. If [n] = 0, the GC will try to do enough work
to ensure that the next slice has no work to do.
Return an approximation of the work that the next slice will have
to do. *)
to ensure that the next automatic slice has no work to do.
This function returns an unspecified integer (currently: 0). *)
external major : unit -> unit = "caml_gc_major"
(** Do a minor collection and finish the current major collection cycle. *)
@ -258,7 +257,7 @@ val finalise : ('a -> unit) -> 'a -> unit
Instead you should make sure that [v] is not in the closure of
the finalisation function by writing:
- [ let f = fun x -> ... ;; let v = ... in Gc.finalise f v ]
- [ let f = fun x -> ... let v = ... in Gc.finalise f v ]
The [f] function can use all features of OCaml, including

2
stdlib/hashtbl.mli
View File

@ -227,7 +227,7 @@ val stats : ('a, 'b) t -> statistics
module IntHashtbl = Hashtbl.Make(IntHash)
let h = IntHashtbl.create 17 in
IntHashtbl.add h 12 "hello";;
IntHashtbl.add h 12 "hello"
]}
This creates a new module [IntHashtbl], with a new type ['a

24
stdlib/lazy.ml
View File

@ -45,23 +45,23 @@
rules for the [lazy] keyword.
*)
type 'a t = 'a lazy_t;;
type 'a t = 'a lazy_t
exception Undefined = CamlinternalLazy.Undefined;;
exception Undefined = CamlinternalLazy.Undefined
external make_forward : 'a -> 'a lazy_t = "caml_lazy_make_forward";;
external make_forward : 'a -> 'a lazy_t = "caml_lazy_make_forward"
external force : 'a t -> 'a = "%lazy_force";;
external force : 'a t -> 'a = "%lazy_force"
(* let force = force;; *)
(* let force = force *)
let force_val = CamlinternalLazy.force_val;;
let force_val = CamlinternalLazy.force_val
let from_fun (f : unit -> 'arg) =
let x = Obj.new_block Obj.lazy_tag 1 in
Obj.set_field x 0 (Obj.repr f);
(Obj.obj x : 'arg t)
;;
let from_val (v : 'arg) =
let t = Obj.tag (Obj.repr v) in
@ -70,12 +70,12 @@ let from_val (v : 'arg) =
end else begin
(Obj.magic v : 'arg t)
end
;;
let is_val (l : 'arg t) = Obj.tag (Obj.repr l) <> Obj.lazy_tag;;
let lazy_from_fun = from_fun;;
let is_val (l : 'arg t) = Obj.tag (Obj.repr l) <> Obj.lazy_tag
let lazy_from_val = from_val;;
let lazy_from_fun = from_fun
let lazy_is_val = is_val;;
let lazy_from_val = from_val
let lazy_is_val = is_val

4
stdlib/lazy.mli
View File

@ -40,9 +40,9 @@ type 'a t = 'a lazy_t
*)
exception Undefined;;
exception Undefined
(* val force : 'a t -> 'a ;; *)
(* val force : 'a t -> 'a *)
external force : 'a t -> 'a = "%lazy_force"
(** [force x] forces the suspension [x] and returns its result.
If [x] has already been forced, [Lazy.force x] returns the

17
stdlib/lexing.ml
View File

@ -69,7 +69,7 @@ let engine tbl state buf =
with pos_cnum = buf.lex_abs_pos + buf.lex_curr_pos};
end;
result
;;
let new_engine tbl state buf =
let result = c_new_engine tbl state buf in
@ -79,7 +79,7 @@ let new_engine tbl state buf =
with pos_cnum = buf.lex_abs_pos + buf.lex_curr_pos};
end;
result
;;
let lex_refill read_fun aux_buffer lexbuf =
let read =
@ -143,7 +143,7 @@ let zero_pos = {
pos_lnum = 1;
pos_bol = 0;
pos_cnum = 0;
};;
}
let from_function f =
{ refill_buff = lex_refill f (Bytes.create 512);
@ -207,11 +207,11 @@ let sub_lexeme_char_opt lexbuf i =
let lexeme_char lexbuf i =
Bytes.get lexbuf.lex_buffer (lexbuf.lex_start_pos + i)
let lexeme_start lexbuf = lexbuf.lex_start_p.pos_cnum;;
let lexeme_end lexbuf = lexbuf.lex_curr_p.pos_cnum;;
let lexeme_start lexbuf = lexbuf.lex_start_p.pos_cnum
let lexeme_end lexbuf = lexbuf.lex_curr_p.pos_cnum
let lexeme_start_p lexbuf = lexbuf.lex_start_p;;
let lexeme_end_p lexbuf = lexbuf.lex_curr_p;;
let lexeme_start_p lexbuf = lexbuf.lex_start_p
let lexeme_end_p lexbuf = lexbuf.lex_curr_p
let new_line lexbuf =
let lcp = lexbuf.lex_curr_p in
@ -219,7 +219,7 @@ let new_line lexbuf =
pos_lnum = lcp.pos_lnum + 1;
pos_bol = lcp.pos_cnum;
}
;;
(* Discard data left in lexer buffer. *)
@ -229,4 +229,3 @@ let flush_input lb =
lb.lex_abs_pos <- 0;
lb.lex_curr_p <- {lb.lex_curr_p with pos_cnum = 0};
lb.lex_buffer_len <- 0;
;;

19
stdlib/list.ml
View File

@ -70,7 +70,7 @@ let rev_map f l =
| a::l -> rmap_f (f a :: accu) l
in
rmap_f [] l
;;
let rec iter f = function
[] -> ()
@ -106,7 +106,7 @@ let rev_map2 f l1 l2 =
| (_, _) -> invalid_arg "List.rev_map2"
in
rmap2_f [] l1 l2
;;
let rec iter2 f l1 l2 =
match (l1, l2) with
@ -218,7 +218,7 @@ let rec merge cmp l1 l2 =
if cmp h1 h2 <= 0
then h1 :: merge cmp t1 l2
else h2 :: merge cmp l1 t2
;;
let rec chop k l =
if k = 0 then l else begin
@ -226,7 +226,7 @@ let rec chop k l =
| _::t -> chop (k-1) t
| _ -> assert false
end
;;
let stable_sort cmp l =
let rec rev_merge l1 l2 accu =
@ -292,10 +292,10 @@ let stable_sort cmp l =
in
let len = length l in
if len < 2 then l else sort len l
;;
let sort = stable_sort;;
let fast_sort = stable_sort;;
let sort = stable_sort
let fast_sort = stable_sort
(* Note: on a list of length between about 100000 (depending on the minor
heap size and the type of the list) and Sys.max_array_size, it is
@ -320,13 +320,13 @@ let array_to_list_in_place a =
end
in
loop [] (l-1000) l
;;
let stable_sort cmp l =
let a = Array.of_list l in
Array.stable_sort cmp a;
array_to_list_in_place a
;;
*)
@ -430,4 +430,3 @@ let sort_uniq cmp l =
in
let len = length l in
if len < 2 then l else sort len l
;;

16
stdlib/parsing.ml
View File

@ -195,15 +195,15 @@ let symbol_start_pos () =
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));;
let rhs_end_pos n = env.symb_end_stack.(env.asp - (env.rule_len - n));;
let symbol_start () = (symbol_start_pos ()).pos_cnum;;
let symbol_end () = (symbol_end_pos ()).pos_cnum;;
let rhs_start n = (rhs_start_pos n).pos_cnum;;
let rhs_end n = (rhs_end_pos n).pos_cnum;;
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))
let rhs_end_pos n = env.symb_end_stack.(env.asp - (env.rule_len - n))
let symbol_start () = (symbol_start_pos ()).pos_cnum
let symbol_end () = (symbol_end_pos ()).pos_cnum
let rhs_start n = (rhs_start_pos n).pos_cnum
let rhs_end n = (rhs_end_pos n).pos_cnum
let is_current_lookahead tok =
(!current_lookahead_fun)(Obj.repr tok)

6
stdlib/pervasives.ml
View File

@ -256,9 +256,9 @@ let valid_float_lexem s =
| _ -> s
in
loop 0
;;
let string_of_float f = valid_float_lexem (format_float "%.12g" f);;
let string_of_float f = valid_float_lexem (format_float "%.12g" f)
external float_of_string : string -> float = "caml_float_of_string"
@ -438,7 +438,7 @@ external seek_in : in_channel -> int -> unit = "caml_ml_seek_in"
external pos_in : in_channel -> int = "caml_ml_pos_in"
external in_channel_length : in_channel -> int = "caml_ml_channel_size"
external close_in : in_channel -> unit = "caml_ml_close_channel"
let close_in_noerr ic = (try close_in ic with _ -> ());;
let close_in_noerr ic = (try close_in ic with _ -> ())
external set_binary_mode_in : in_channel -> bool -> unit
= "caml_ml_set_binary_mode"

9
stdlib/printexc.ml
View File

@ -13,11 +13,11 @@
(* *)
(**************************************************************************)
open Printf;;
open Printf
let printers = ref []
let locfmt = format_of_string "File \"%s\", line %d, characters %d-%d: %s";;
let locfmt = format_of_string "File \"%s\", line %d, characters %d-%d: %s"
let field x i =
let f = Obj.field x i in
@ -29,18 +29,17 @@ let field x i =
string_of_float (Obj.magic f : float)
else
"_"
;;
let rec other_fields x i =
if i >= Obj.size x then ""
else sprintf ", %s%s" (field x i) (other_fields x (i+1))
;;
let fields x =
match Obj.size x with
| 0 -> ""
| 1 -> ""
| 2 -> sprintf "(%s)" (field x 1)
| _ -> sprintf "(%s%s)" (field x 1) (other_fields x 2)
;;
let to_string x =
let rec conv = function

112
stdlib/random.ml
View File

@ -25,17 +25,17 @@
passes all the Diehard tests.
*)
external random_seed: unit -> int array = "caml_sys_random_seed";;
external random_seed: unit -> int array = "caml_sys_random_seed"
module State = struct
type t = { st : int array; mutable idx : int };;
type t = { st : int array; mutable idx : int }
let new_state () = { st = Array.make 55 0; idx = 0 };;
let new_state () = { st = Array.make 55 0; idx = 0 }
let assign st1 st2 =
Array.blit st2.st 0 st1.st 0 55;
st1.idx <- st2.idx;
;;
st1.idx <- st2.idx
let full_init s seed =
let combine accu x = Digest.string (accu ^ string_of_int x) in
@ -55,22 +55,22 @@ module State = struct
accu := combine !accu seed.(k);
s.st.(j) <- (s.st.(j) lxor extract !accu) land 0x3FFFFFFF; (* PR#5575 *)
done;
s.idx <- 0;
;;
s.idx <- 0
let make seed =
let result = new_state () in
full_init result seed;
result
;;
let make_self_init () = make (random_seed ());;
let make_self_init () = make (random_seed ())
let copy s =
let result = new_state () in
assign result s;
result
;;
(* Returns 30 random bits as an integer 0 <= x < 1073741824 *)
let bits s =
@ -81,18 +81,18 @@ module State = struct
let newval30 = newval land 0x3FFFFFFF in (* PR#5575 *)
s.st.(s.idx) <- newval30;
newval30
;;
let rec intaux s n =
let r = bits s in
let v = r mod n in
if r - v > 0x3FFFFFFF - n + 1 then intaux s n else v
;;
let int s bound =
if bound > 0x3FFFFFFF || bound <= 0
then invalid_arg "Random.int"
else intaux s bound
;;
let rec int32aux s n =
let b1 = Int32.of_int (bits s) in
@ -102,12 +102,12 @@ module State = struct
if Int32.sub r v > Int32.add (Int32.sub Int32.max_int n) 1l
then int32aux s n
else v
;;
let int32 s bound =
if bound <= 0l
then invalid_arg "Random.int32"
else int32aux s bound
;;
let rec int64aux s n =
let b1 = Int64.of_int (bits s) in
@ -118,18 +118,18 @@ module State = struct
if Int64.sub r v > Int64.add (Int64.sub Int64.max_int n) 1L
then int64aux s n
else v
;;
let int64 s bound =
if bound <= 0L
then invalid_arg "Random.int64"
else int64aux s bound
;;
let nativeint =
if Nativeint.size = 32
then fun s bound -> Nativeint.of_int32 (int32 s (Nativeint.to_int32 bound))
else fun s bound -> Int64.to_nativeint (int64 s (Int64.of_nativeint bound))
;;
(* Returns a float 0 <= x <= 1 with at most 60 bits of precision. *)
let rawfloat s =
@ -137,13 +137,13 @@ module State = struct
and r1 = Pervasives.float (bits s)
and r2 = Pervasives.float (bits s)
in (r1 /. scale +. r2) /. scale
;;
let float s bound = rawfloat s *. bound;;
let bool s = (bits s land 1 = 0);;
let float s bound = rawfloat s *. bound
end;;
let bool s = (bits s land 1 = 0)
end
(* This is the state you get with [init 27182818] and then applying
the "land 0x3FFFFFFF" filter to them. See #5575, #5793, #5977. *)
@ -161,24 +161,24 @@ let default = {
0x2fbf967a;
|];
State.idx = 0;
};;
}
let bits () = State.bits default;;
let int bound = State.int default bound;;
let int32 bound = State.int32 default bound;;
let nativeint bound = State.nativeint default bound;;
let int64 bound = State.int64 default bound;;
let float scale = State.float default scale;;
let bool () = State.bool default;;
let bits () = State.bits default
let int bound = State.int default bound
let int32 bound = State.int32 default bound
let nativeint bound = State.nativeint default bound
let int64 bound = State.int64 default bound
let float scale = State.float default scale
let bool () = State.bool default
let full_init seed = State.full_init default seed;;
let init seed = State.full_init default [| seed |];;
let self_init () = full_init (random_seed());;
let full_init seed = State.full_init default seed
let init seed = State.full_init default [| seed |]
let self_init () = full_init (random_seed())
(* Manipulating the current state. *)
let get_state () = State.copy default;;
let set_state s = State.assign default s;;
let get_state () = State.copy default
let set_state s = State.assign default s
(********************
@ -190,19 +190,19 @@ let set_state s = State.assign default s;;
Some results:
init 27182818; chisquare int 100000 1000;;
init 27182818; chisquare int 100000 100;;
init 27182818; chisquare int 100000 5000;;
init 27182818; chisquare int 1000000 1000;;
init 27182818; chisquare int 100000 1024;;
init 299792643; chisquare int 100000 1024;;
init 14142136; chisquare int 100000 1024;;
init 27182818; init_diff 1024; chisquare diff 100000 1024;;
init 27182818; init_diff 100; chisquare diff 100000 100;;
init 27182818; init_diff2 1024; chisquare diff2 100000 1024;;
init 27182818; init_diff2 100; chisquare diff2 100000 100;;
init 14142136; init_diff2 100; chisquare diff2 100000 100;;
init 299792643; init_diff2 100; chisquare diff2 100000 100;;
init 27182818; chisquare int 100000 1000
init 27182818; chisquare int 100000 100
init 27182818; chisquare int 100000 5000
init 27182818; chisquare int 1000000 1000
init 27182818; chisquare int 100000 1024
init 299792643; chisquare int 100000 1024
init 14142136; chisquare int 100000 1024
init 27182818; init_diff 1024; chisquare diff 100000 1024
init 27182818; init_diff 100; chisquare diff 100000 100
init 27182818; init_diff2 1024; chisquare diff2 100000 1024
init 27182818; init_diff2 100; chisquare diff2 100000 100
init 14142136; init_diff2 100; chisquare diff2 100000 100
init 299792643; init_diff2 100; chisquare diff2 100000 100
- : float * float * float = (936.754446796632465, 997.5, 1063.24555320336754)
# - : float * float * float = (80., 89.7400000000052387, 120.)
# - : float * float * float = (4858.57864376269, 5045.5, 5141.42135623731)
@ -225,7 +225,7 @@ let rec sumsq v i0 i1 =
if i0 >= i1 then 0.0
else if i1 = i0 + 1 then Pervasives.float v.(i0) *. Pervasives.float v.(i0)
else sumsq v i0 ((i0+i1)/2) +. sumsq v ((i0+i1)/2) i1
;;
let chisquare g n r =
if n <= 10 * r then invalid_arg "chisquare";
@ -239,12 +239,12 @@ let chisquare g n r =
and n = Pervasives.float n in
let sr = 2.0 *. sqrt r in
(r -. sr, (r *. t /. n) -. n, r +. sr)
;;
(* This is to test for linear dependencies between successive random numbers.
*)
let st = ref 0;;
let init_diff r = st := int r;;
let st = ref 0
let init_diff r = st := int r
let diff r =
let x1 = !st
and x2 = int r
@ -254,16 +254,16 @@ let diff r =
x1 - x2
else
r + x1 - x2
;;
let st1 = ref 0
and st2 = ref 0
;;
(* This is to test for quadratic dependencies between successive random
numbers.
*)
let init_diff2 r = st1 := int r; st2 := int r;;
let init_diff2 r = st1 := int r; st2 := int r
let diff2 r =
let x1 = !st1
and x2 = !st2
@ -272,6 +272,6 @@ let diff2 r =
st1 := x2;
st2 := x3;
(x3 - x2 - x2 + x1 + 2*r) mod r
;;
********************)

2
stdlib/random.mli
View File

@ -97,7 +97,7 @@ module State : sig
(** These functions are the same as the basic functions, except that they
use (and update) the given PRNG state instead of the default one.
*)
end;;
end
val get_state : unit -> State.t

314
stdlib/scanf.ml
View File

@ -25,129 +25,129 @@ open CamlinternalFormat
*)
type ('a, 'b, 'c, 'd, 'e, 'f) format6 =
('a, 'b, 'c, 'd, 'e, 'f) Pervasives.format6
;;
(* The run-time library for scanners. *)
(* Scanning buffers. *)
module type SCANNING = sig
type in_channel;;
type in_channel
type scanbuf = in_channel;;
type scanbuf = in_channel
type file_name = string;;
type file_name = string
val stdin : in_channel;;
val stdin : in_channel
(* The scanning buffer reading from [Pervasives.stdin].
[stdib] is equivalent to [Scanning.from_channel Pervasives.stdin]. *)
val stdib : in_channel;;
val stdib : in_channel
(* An alias for [Scanf.stdin], the scanning buffer reading from
[Pervasives.stdin]. *)
val next_char : scanbuf -> char;;
val next_char : scanbuf -> char
(* [Scanning.next_char ib] advance the scanning buffer for
one character.
If no more character can be read, sets a end of file condition and
returns '\000'. *)
val invalidate_current_char : scanbuf -> unit;;
val invalidate_current_char : scanbuf -> unit
(* [Scanning.invalidate_current_char ib] mark the current_char as already
scanned. *)
val peek_char : scanbuf -> char;;
val peek_char : scanbuf -> char
(* [Scanning.peek_char ib] returns the current char available in
the buffer or reads one if necessary (when the current character is
already scanned).
If no character can be read, sets an end of file condition and
returns '\000'. *)
val checked_peek_char : scanbuf -> char;;
val checked_peek_char : scanbuf -> char
(* Same as [Scanning.peek_char] above but always returns a valid char or
fails: instead of returning a null char when the reading method of the
input buffer has reached an end of file, the function raises exception
[End_of_file]. *)
val store_char : int -> scanbuf -> char -> int;;
val store_char : int -> scanbuf -> char -> int
(* [Scanning.store_char lim ib c] adds [c] to the token buffer
of the scanning buffer [ib]. It also advances the scanning buffer for
one character and returns [lim - 1], indicating the new limit for the
length of the current token. *)
val skip_char : int -> scanbuf -> int;;
val skip_char : int -> scanbuf -> int
(* [Scanning.skip_char lim ib] ignores the current character. *)
val ignore_char : int -> scanbuf -> int;;
val ignore_char : int -> scanbuf -> int
(* [Scanning.ignore_char ib lim] ignores the current character and
decrements the limit. *)
val token : scanbuf -> string;;
val token : scanbuf -> string
(* [Scanning.token ib] returns the string stored into the token
buffer of the scanning buffer: it returns the token matched by the
format. *)
val reset_token : scanbuf -> unit;;
val reset_token : scanbuf -> unit
(* [Scanning.reset_token ib] resets the token buffer of
the given scanning buffer. *)
val char_count : scanbuf -> int;;
val char_count : scanbuf -> int
(* [Scanning.char_count ib] returns the number of characters
read so far from the given buffer. *)
val line_count : scanbuf -> int;;
val line_count : scanbuf -> int
(* [Scanning.line_count ib] returns the number of new line
characters read so far from the given buffer. *)
val token_count : scanbuf -> int;;
val token_count : scanbuf -> int
(* [Scanning.token_count ib] returns the number of tokens read
so far from [ib]. *)
val eof : scanbuf -> bool;;
val eof : scanbuf -> bool
(* [Scanning.eof ib] returns the end of input condition
of the given buffer. *)
val end_of_input : scanbuf -> bool;;
val end_of_input : scanbuf -> bool
(* [Scanning.end_of_input ib] tests the end of input condition
of the given buffer (if no char has ever been read, an attempt to
read one is performed). *)
val beginning_of_input : scanbuf -> bool;;
val beginning_of_input : scanbuf -> bool
(* [Scanning.beginning_of_input ib] tests the beginning of input
condition of the given buffer. *)
val name_of_input : scanbuf -> string;;
val name_of_input : scanbuf -> string
(* [Scanning.name_of_input ib] returns the name of the character
source for input buffer [ib]. *)
val open_in : file_name -> in_channel;;
val open_in_bin : file_name -> in_channel;;
val from_file : file_name -> in_channel;;
val from_file_bin : file_name -> in_channel;;
val from_string : string -> in_channel;;
val from_function : (unit -> char) -> in_channel;;
val from_channel : Pervasives.in_channel -> in_channel;;
val open_in : file_name -> in_channel
val open_in_bin : file_name -> in_channel
val from_file : file_name -> in_channel
val from_file_bin : file_name -> in_channel
val from_string : string -> in_channel
val from_function : (unit -> char) -> in_channel
val from_channel : Pervasives.in_channel -> in_channel
val close_in : in_channel -> unit;;
val close_in : in_channel -> unit
val memo_from_channel : Pervasives.in_channel -> in_channel;;
val memo_from_channel : Pervasives.in_channel -> in_channel
(* Obsolete. *)
end
;;
module Scanning : SCANNING = struct
(* The run-time library for scanf. *)
type file_name = string;;
type file_name = string
type in_channel_name =
| From_channel of Pervasives.in_channel
| From_file of file_name * Pervasives.in_channel
| From_function
| From_string
;;
type in_channel = {
mutable ic_eof : bool;
@ -160,11 +160,11 @@ module Scanning : SCANNING = struct
ic_token_buffer : Buffer.t;
ic_input_name : in_channel_name;
}
;;
type scanbuf = in_channel;;
let null_char = '\000';;
type scanbuf = in_channel
let null_char = '\000'
(* Reads a new character from input buffer.
Next_char never fails, even in case of end of input:
@ -183,13 +183,13 @@ module Scanning : SCANNING = struct
ib.ic_current_char_is_valid <- false;
ib.ic_eof <- true;
c
;;
let peek_char ib =
if ib.ic_current_char_is_valid
then ib.ic_current_char
else next_char ib
;;
(* Returns a valid current char for the input buffer. In particular
no irrelevant null character (as set by [next_char] in case of end
@ -200,16 +200,16 @@ module Scanning : SCANNING = struct
let c = peek_char ib in
if ib.ic_eof then raise End_of_file;
c
;;
let end_of_input ib =
ignore (peek_char ib);
ib.ic_eof
;;
let eof ib = ib.ic_eof;;
let beginning_of_input ib = ib.ic_char_count = 0;;
let eof ib = ib.ic_eof
let beginning_of_input ib = ib.ic_char_count = 0
let name_of_input ib =
match ib.ic_input_name with
@ -217,19 +217,19 @@ module Scanning : SCANNING = struct
| From_file (fname, _ic) -> fname
| From_function -> "unnamed function"
| From_string -> "unnamed character string"
;;
let char_count ib =
if ib.ic_current_char_is_valid
then ib.ic_char_count - 1
else ib.ic_char_count
;;
let line_count ib = ib.ic_line_count;;
let reset_token ib = Buffer.reset ib.ic_token_buffer;;
let line_count ib = ib.ic_line_count
let invalidate_current_char ib = ib.ic_current_char_is_valid <- false;;
let reset_token ib = Buffer.reset ib.ic_token_buffer
let invalidate_current_char ib = ib.ic_current_char_is_valid <- false
let token ib =
let token_buffer = ib.ic_token_buffer in
@ -237,23 +237,23 @@ module Scanning : SCANNING = struct
Buffer.clear token_buffer;
ib.ic_token_count <- succ ib.ic_token_count;
tok
;;
let token_count ib = ib.ic_token_count;;
let token_count ib = ib.ic_token_count
let skip_char width ib =
invalidate_current_char ib;
width
;;
let ignore_char width ib = skip_char (width - 1) ib;;
let ignore_char width ib = skip_char (width - 1) ib
let store_char width ib c =
Buffer.add_char ib.ic_token_buffer c;
ignore_char width ib
;;
let default_token_buffer_size = 1024;;
let default_token_buffer_size = 1024
let create iname next = {
ic_eof = false;
@ -266,7 +266,7 @@ module Scanning : SCANNING = struct
ic_token_buffer = Buffer.create default_token_buffer_size;
ic_input_name = iname;
}
;;
let from_string s =
let i = ref 0 in
@ -277,9 +277,9 @@ module Scanning : SCANNING = struct
incr i;
c in
create From_string next
;;
let from_function = create From_function;;
let from_function = create From_function
(* Scanning from an input channel. *)
@ -322,14 +322,14 @@ module Scanning : SCANNING = struct
*)
(* Perform bufferized input to improve efficiency. *)
let file_buffer_size = ref 1024;;
let file_buffer_size = ref 1024
(* The scanner closes the input channel at end of input. *)
let scan_close_at_end ic = Pervasives.close_in ic; raise End_of_file;;
let scan_close_at_end ic = Pervasives.close_in ic; raise End_of_file
(* The scanner does not close the input channel at end of input:
it just raises [End_of_file]. *)
let scan_raise_at_end _ic = raise End_of_file;;
let scan_raise_at_end _ic = raise End_of_file
let from_ic scan_close_ic iname ic =
let len = !file_buffer_size in
@ -347,10 +347,10 @@ module Scanning : SCANNING = struct
end
end in
create iname next
;;
let from_ic_close_at_end = from_ic scan_close_at_end;;
let from_ic_raise_at_end = from_ic scan_raise_at_end;;
let from_ic_close_at_end = from_ic scan_close_at_end
let from_ic_raise_at_end = from_ic scan_raise_at_end
(* The scanning buffer reading from [Pervasives.stdin].
One could try to define [stdib] as a scanning buffer reading a character
@ -370,9 +370,9 @@ module Scanning : SCANNING = struct
let stdin =
from_ic scan_raise_at_end
(From_file ("-", Pervasives.stdin)) Pervasives.stdin
;;
let stdib = stdin;;
let stdib = stdin
let open_in_file open_in fname =
match fname with
@ -380,17 +380,17 @@ module Scanning : SCANNING = struct
| fname ->
let ic = open_in fname in
from_ic_close_at_end (From_file (fname, ic)) ic
;;
let open_in = open_in_file Pervasives.open_in;;
let open_in_bin = open_in_file Pervasives.open_in_bin;;
let from_file = open_in;;
let from_file_bin = open_in_bin;;
let open_in = open_in_file Pervasives.open_in
let open_in_bin = open_in_file Pervasives.open_in_bin
let from_file = open_in
let from_file_bin = open_in_bin
let from_channel ic =
from_ic_raise_at_end (From_channel ic) ic
;;
let close_in ib =
match ib.ic_input_name with
@ -398,7 +398,7 @@ module Scanning : SCANNING = struct
Pervasives.close_in ic
| From_file (_fname, ic) -> Pervasives.close_in ic
| From_function | From_string -> ()
;;
(*
Obsolete: a memo [from_channel] version to build a [Scanning.in_channel]
@ -424,28 +424,28 @@ module Scanning : SCANNING = struct
from_ic scan_close_ic (From_channel ic) ic in
memo := (ic, ib) :: !memo;
ib)
;;
(* Obsolete: see {!memo_from_ic} above. *)
let memo_from_channel = memo_from_ic scan_raise_at_end;;
let memo_from_channel = memo_from_ic scan_raise_at_end
end
;;
(* Formatted input functions. *)
type ('a, 'b, 'c, 'd) scanner =
('a, Scanning.in_channel, 'b, 'c, 'a -> 'd, 'd) format6 -> 'c
;;
(* Reporting errors. *)
exception Scan_failure of string;;
exception Scan_failure of string
let bad_input s = raise (Scan_failure s);;
let bad_input s = raise (Scan_failure s)
let bad_input_escape c =
bad_input (Printf.sprintf "illegal escape character %C" c)
;;
let bad_token_length message =
bad_input
@ -453,7 +453,7 @@ let bad_token_length message =
"scanning of %s failed: \
the specified length was too short for token"
message)
;;
let bad_end_of_input message =
bad_input
@ -461,23 +461,23 @@ let bad_end_of_input message =
"scanning of %s failed: \
premature end of file occurred before end of token"
message)
;;
let bad_float () =
bad_input "no dot or exponent part found in float token"
;;
let bad_hex_float () =
bad_input "not a valid float in hexadecimal notation"
;;
let character_mismatch_err c ci =
Printf.sprintf "looking for %C, found %C" c ci
;;
let character_mismatch c ci =
bad_input (character_mismatch_err c ci)
;;
let rec skip_whites ib =
let c = Scanning.peek_char ib in
@ -487,7 +487,7 @@ let rec skip_whites ib =
Scanning.invalidate_current_char ib; skip_whites ib
| _ -> ()
end
;;
(* Checking that [c] is indeed in the input, then skips it.
In this case, the character [c] has been explicitly specified in the
@ -520,20 +520,20 @@ and check_newline ib =
| '\n' -> Scanning.invalidate_current_char ib
| '\r' -> Scanning.invalidate_current_char ib; check_this_char ib '\n'
| _ -> character_mismatch '\n' ci
;;
(* Extracting tokens from the output token buffer. *)
let token_char ib = (Scanning.token ib).[0];;
let token_char ib = (Scanning.token ib).[0]
let token_string = Scanning.token;;
let token_string = Scanning.token
let token_bool ib =
match Scanning.token ib with
| "true" -> true
| "false" -> false
| s -> bad_input (Printf.sprintf "invalid boolean '%s'" s)
;;
(* The type of integer conversions. *)
type integer_conversion =
@ -543,7 +543,7 @@ type integer_conversion =
| O_conversion (* Unsigned octal conversion *)
| U_conversion (* Unsigned decimal conversion *)
| X_conversion (* Unsigned hexadecimal conversion *)
;;
let integer_conversion_of_char = function
| 'b' -> B_conversion
@ -553,7 +553,7 @@ let integer_conversion_of_char = function
| 'u' -> U_conversion
| 'x' | 'X' -> X_conversion
| _ -> assert false
;;
(* Extract an integer literal token.
Since the functions Pervasives.*int*_of_string do not accept a leading +,
@ -568,14 +568,14 @@ let token_int_literal conv ib =
| B_conversion -> "0b" ^ Scanning.token ib in
let l = String.length tok in
if l = 0 || tok.[0] <> '+' then tok else String.sub tok 1 (l - 1)
;;
(* All the functions that convert a string to a number raise the exception
Failure when the conversion is not possible.
This exception is then trapped in [kscanf]. *)
let token_int conv ib = int_of_string (token_int_literal conv ib);;
let token_int conv ib = int_of_string (token_int_literal conv ib)
let token_float ib = float_of_string (Scanning.token ib);;
let token_float ib = float_of_string (Scanning.token ib)
(* To scan native ints, int32 and int64 integers.
We cannot access to conversions to/from strings for those types,
@ -585,17 +585,17 @@ let token_float ib = float_of_string (Scanning.token ib);;
available in the runtime. *)
external nativeint_of_string : string -> nativeint
= "caml_nativeint_of_string"
;;
external int32_of_string : string -> int32
= "caml_int32_of_string"
;;
external int64_of_string : string -> int64
= "caml_int64_of_string"
;;
let token_nativeint conv ib = nativeint_of_string (token_int_literal conv ib);;
let token_int32 conv ib = int32_of_string (token_int_literal conv ib);;
let token_int64 conv ib = int64_of_string (token_int_literal conv ib);;
let token_nativeint conv ib = nativeint_of_string (token_int_literal conv ib)
let token_int32 conv ib = int32_of_string (token_int_literal conv ib)
let token_int64 conv ib = int64_of_string (token_int_literal conv ib)
(* Scanning numbers. *)
@ -622,7 +622,7 @@ let rec scan_decimal_digit_star width ib =
let width = Scanning.ignore_char width ib in
scan_decimal_digit_star width ib
| _ -> width
;;
let scan_decimal_digit_plus width ib =
if width = 0 then bad_token_length "decimal digits" else
@ -633,7 +633,7 @@ let scan_decimal_digit_plus width ib =
scan_decimal_digit_star width ib
| c ->
bad_input (Printf.sprintf "character %C is not a decimal digit" c)
;;
(* To scan numbers from other bases, we use a predicate argument to
scan digits. *)
@ -651,7 +651,7 @@ let scan_digit_star digitp width ib =
scan_digits width ib
| _ -> width in
scan_digits width ib
;;
let scan_digit_plus basis digitp width ib =
(* Ensure we have got enough width left,
@ -663,31 +663,31 @@ let scan_digit_plus basis digitp width ib =
scan_digit_star digitp width ib
else
bad_input (Printf.sprintf "character %C is not a valid %s digit" c basis)
;;
let is_binary_digit = function
| '0' .. '1' -> true
| _ -> false
;;
let scan_binary_int = scan_digit_plus "binary" is_binary_digit;;
let scan_binary_int = scan_digit_plus "binary" is_binary_digit
let is_octal_digit = function
| '0' .. '7' -> true
| _ -> false
;;
let scan_octal_int = scan_digit_plus "octal" is_octal_digit;;
let scan_octal_int = scan_digit_plus "octal" is_octal_digit
let is_hexa_digit = function
| '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' -> true
| _ -> false
;;
let scan_hexadecimal_int = scan_digit_plus "hexadecimal" is_hexa_digit;;
let scan_hexadecimal_int = scan_digit_plus "hexadecimal" is_hexa_digit
(* Scan a decimal integer. *)
let scan_unsigned_decimal_int = scan_decimal_digit_plus;;
let scan_unsigned_decimal_int = scan_decimal_digit_plus
let scan_sign width ib =
let c = Scanning.checked_peek_char ib in
@ -695,12 +695,12 @@ let scan_sign width ib =
| '+' -> Scanning.store_char width ib c
| '-' -> Scanning.store_char width ib c
| _ -> width
;;
let scan_optionally_signed_decimal_int width ib =
let width = scan_sign width ib in
scan_unsigned_decimal_int width ib
;;
(* Scan an unsigned integer that could be given in any (common) basis.
If digits are prefixed by one of 0x, 0X, 0o, or 0b, the number is
@ -719,12 +719,12 @@ let scan_unsigned_int width ib =
| 'b' -> scan_binary_int (Scanning.store_char width ib c) ib
| _ -> scan_decimal_digit_star width ib end
| _ -> scan_unsigned_decimal_int width ib
;;
let scan_optionally_signed_int width ib =
let width = scan_sign width ib in
scan_unsigned_int width ib
;;
let scan_int_conversion conv width ib =
match conv with
@ -734,7 +734,7 @@ let scan_int_conversion conv width ib =
| O_conversion -> scan_octal_int width ib
| U_conversion -> scan_unsigned_decimal_int width ib
| X_conversion -> scan_hexadecimal_int width ib
;;
(* Scanning floating point numbers. *)
@ -747,7 +747,7 @@ let scan_fractional_part width ib =
| '0' .. '9' as c ->
scan_decimal_digit_star (Scanning.store_char width ib c) ib
| _ -> width
;;
(* Exp part is optional and can be reduced to 0 digits. *)
let scan_exponent_part width ib =
@ -758,7 +758,7 @@ let scan_exponent_part width ib =
| 'e' | 'E' as c ->
scan_optionally_signed_decimal_int (Scanning.store_char width ib c) ib
| _ -> width
;;
(* Scan the integer part of a floating point number, (not using the
OCaml lexical convention since the integer part can be empty):
@ -767,7 +767,7 @@ let scan_exponent_part width ib =
let scan_integer_part width ib =
let width = scan_sign width ib in
scan_decimal_digit_star width ib
;;
(*
For the time being we have (as found in scanf.mli):
@ -813,7 +813,7 @@ let scan_float width precision ib =
scan_exponent_part width ib, precision
| _ ->
scan_exponent_part width ib, precision
;;
let check_case_insensitive_string width ib error str =
let lowercase c =
@ -830,7 +830,7 @@ let check_case_insensitive_string width ib error str =
width := Scanning.store_char !width ib c;
done;
!width
;;
let scan_hex_float width precision ib =
if width = 0 || Scanning.end_of_input ib then bad_hex_float ();
@ -874,7 +874,7 @@ let scan_hex_float width precision ib =
if width = 0 || Scanning.end_of_input ib then bad_hex_float ();
check_case_insensitive_string width ib bad_hex_float "nfinity"
| _ -> bad_hex_float ()
;;
let scan_caml_float_rest width precision ib =
if width = 0 || Scanning.end_of_input ib then bad_float ();
@ -899,7 +899,7 @@ let scan_caml_float_rest width precision ib =
| 'e' | 'E' ->
scan_exponent_part width ib
| _ -> bad_float ()
;;
let scan_caml_float width precision ib =
if width = 0 || Scanning.end_of_input ib then bad_float ();
@ -947,7 +947,7 @@ let scan_caml_float width precision ib =
| 'n' ->
*)
| _ -> bad_float ()
;;
(* Scan a regular string:
stops when encountering a space, if no scanning indication has been given;
@ -968,7 +968,7 @@ let scan_string stp width ib =
| ' ' | '\t' | '\n' | '\r' -> width
| _ -> loop (Scanning.store_char width ib c) in
loop width
;;
(* Scan a char: peek strictly one character in the input, whatsoever. *)
let scan_char width ib =
@ -976,7 +976,7 @@ let scan_char width ib =
calling scan_char, in the main scanning function.
if width = 0 then bad_token_length "a character" else *)
Scanning.store_char width ib (Scanning.checked_peek_char ib)
;;
let char_for_backslash = function
| 'n' -> '\010'
@ -984,11 +984,11 @@ let char_for_backslash = function
| 'b' -> '\008'
| 't' -> '\009'
| c -> c
;;
(* The integer value corresponding to the facial value of a valid
decimal digit character. *)
let decimal_value_of_char c = int_of_char c - int_of_char '0';;
let decimal_value_of_char c = int_of_char c - int_of_char '0'
let char_for_decimal_code c0 c1 c2 =
let c =
@ -1000,7 +1000,7 @@ let char_for_decimal_code c0 c1 c2 =
(Printf.sprintf
"bad character decimal encoding \\%c%c%c" c0 c1 c2) else
char_of_int c
;;
(* The integer value corresponding to the facial value of a valid
hexadecimal digit character. *)
@ -1016,7 +1016,7 @@ let hexadecimal_value_of_char c =
if d >= int_of_char 'A' then
d - 55 (* 10 + int_of_char c - int_of_char 'A' *) else
d - int_of_char '0'
;;
let char_for_hexadecimal_code c1 c2 =
let c =
@ -1026,7 +1026,7 @@ let char_for_hexadecimal_code c1 c2 =
bad_input
(Printf.sprintf "bad character hexadecimal encoding \\%c%c" c1 c2) else
char_of_int c
;;
(* Called in particular when encountering '\\' as starter of a char.
Stops before the corresponding '\''. *)
@ -1035,10 +1035,10 @@ let check_next_char message width ib =
let c = Scanning.peek_char ib in
if Scanning.eof ib then bad_end_of_input message else
c
;;
let check_next_char_for_char = check_next_char "a Char";;
let check_next_char_for_string = check_next_char "a String";;
let check_next_char_for_char = check_next_char "a Char"
let check_next_char_for_string = check_next_char "a String"
let scan_backslash_char width ib =
match check_next_char_for_char width ib with
@ -1065,7 +1065,7 @@ let scan_backslash_char width ib =
Scanning.store_char (width - 2) ib (char_for_hexadecimal_code c1 c2)
| c ->
bad_input_escape c
;;
(* Scan a character (an OCaml token). *)
let scan_caml_char width ib =
@ -1088,7 +1088,7 @@ let scan_caml_char width ib =
| c -> character_mismatch '\'' c in
find_start width
;;
(* Scan a delimited string (an OCaml token). *)
let scan_caml_string width ib =
@ -1121,7 +1121,7 @@ let scan_caml_string width ib =
| _ -> find_stop width in
find_start width
;;
(* Scan a boolean (an OCaml token). *)
let scan_bool ib =
@ -1134,7 +1134,7 @@ let scan_bool ib =
bad_input
(Printf.sprintf "the character %C cannot start a boolean" c) in
scan_string None m ib
;;
(* Scan a string containing elements in char_set and terminated by scan_indic
if provided. *)
@ -1155,7 +1155,7 @@ let scan_chars_in_char_set char_set scan_indic width ib =
if c = ci
then Scanning.invalidate_current_char ib
else character_mismatch c ci
;;
(* The global error report function for [Scanf]. *)
let scanf_bad_input ib = function
@ -1163,7 +1163,7 @@ let scanf_bad_input ib = function
let i = Scanning.char_count ib in
bad_input (Printf.sprintf "scanf: bad input at char number %i: %s" i s)
| x -> raise x
;;
(* Get the content of a counter from an input buffer. *)
let get_counter ib counter =
@ -1171,13 +1171,13 @@ let get_counter ib counter =
| Line_counter -> Scanning.line_count ib
| Char_counter -> Scanning.char_count ib
| Token_counter -> Scanning.token_count ib
;;
(* Compute the width of a padding option (see "%42{" and "%123("). *)
let width_of_pad_opt pad_opt = match pad_opt with
| None -> max_int
| Some width -> width
;;
let stopper_of_formatting_lit fmting =
if fmting = Escaped_percent then '%', "" else
@ -1185,7 +1185,7 @@ let stopper_of_formatting_lit fmting =
let stp = str.[1] in
let sub_str = String.sub str 2 (String.length str - 2) in
stp, sub_str
;;
(******************************************************************************)
(* Readers managment *)
@ -1404,7 +1404,7 @@ fun ib fmt readers -> match fmt with
are typed in the same way.
# Scanf.sscanf "\"%_r%d\"3" "%(%d%_r%)" ignore
(fun fmt n -> string_of_format fmt, n);;
(fun fmt n -> string_of_format fmt, n)
Exception: CamlinternalFormat.Type_mismatch.
We should properly catch this exception.
@ -1515,13 +1515,13 @@ let kscanf ib ef (Format (fmt, str)) =
(***)
let kbscanf = kscanf;;
let bscanf ib fmt = kbscanf ib scanf_bad_input fmt;;
let kbscanf = kscanf
let bscanf ib fmt = kbscanf ib scanf_bad_input fmt
let ksscanf s ef fmt = kbscanf (Scanning.from_string s) ef fmt;;
let sscanf s fmt = kbscanf (Scanning.from_string s) scanf_bad_input fmt;;
let ksscanf s ef fmt = kbscanf (Scanning.from_string s) ef fmt
let sscanf s fmt = kbscanf (Scanning.from_string s) scanf_bad_input fmt
let scanf fmt = kscanf Scanning.stdib scanf_bad_input fmt;;
let scanf fmt = kscanf Scanning.stdib scanf_bad_input fmt
(***)
@ -1536,13 +1536,13 @@ let bscanf_format :
try format_of_string_format str format
with Failure msg -> bad_input msg in
f fmt'
;;
let sscanf_format :
string -> ('a, 'b, 'c, 'd, 'e, 'f) format6 ->
(('a, 'b, 'c, 'd, 'e, 'f) format6 -> 'g) -> 'g =
fun s format f -> bscanf_format (Scanning.from_string s) format f
;;
let string_to_String s =
let l = String.length s in
@ -1555,16 +1555,16 @@ let string_to_String s =
done;
Buffer.add_char b '\"';
Buffer.contents b
;;
let format_from_string s fmt =
sscanf_format (string_to_String s) fmt (fun x -> x)
;;
let unescaped s =
sscanf ("\"" ^ s ^ "\"") "%S%!" (fun x -> x)
;;
(* Deprecated *)
let kfscanf ic ef fmt = kbscanf (Scanning.memo_from_channel ic) ef fmt;;
let fscanf ic fmt = kscanf (Scanning.memo_from_channel ic) scanf_bad_input fmt;;
let kfscanf ic ef fmt = kbscanf (Scanning.memo_from_channel ic) ef fmt
let fscanf ic fmt = kscanf (Scanning.memo_from_channel ic) scanf_bad_input fmt

53
stdlib/stream.ml
View File

@ -25,9 +25,9 @@ and 'a data =
and 'a gen = { mutable curr : 'a option option; func : int -> 'a option }
and buffio =
{ ic : in_channel; buff : bytes; mutable len : int; mutable ind : int }
;;
exception Failure;;
exception Error of string;;
exception Failure
exception Error of string
let count = function
| None -> 0
@ -38,7 +38,7 @@ let data = function
let fill_buff b =
b.len <- input b.ic b.buff 0 (Bytes.length b.buff); b.ind <- 0
;;
let rec get_data : type v. int -> v data -> v data = fun count d -> match d with
(* Returns either Sempty or Scons(a, _) even when d is a generator
@ -68,7 +68,7 @@ let rec get_data : type v. int -> v data -> v data = fun count d -> match d with
(* Warning: anyone using g thinks that an item has been read *)
b.ind <- succ b.ind; Scons(r, d)
| Slazy f -> get_data count (Lazy.force f)
;;
let rec peek_data : type v. v cell -> v option = fun s ->
(* consult the first item of s *)
@ -88,12 +88,12 @@ let rec peek_data : type v. v cell -> v option = fun s ->
if b.ind >= b.len then fill_buff b;
if b.len == 0 then begin s.data <- Sempty; None end
else Some (Bytes.unsafe_get b.buff b.ind)
;;
let peek = function
| None -> None
| Some s -> peek_data s
;;
let rec junk_data : type v. v cell -> unit = fun s ->
match s.data with
@ -104,7 +104,7 @@ let rec junk_data : type v. v cell -> unit = fun s ->
match peek_data s with
None -> ()
| Some _ -> junk_data s
;;
let junk = function
| None -> ()
@ -118,14 +118,14 @@ let rec nget_data n s =
junk_data s;
let (al, d, k) = nget_data (pred n) s in a :: al, Scons (a, d), succ k
| None -> [], s.data, 0
;;
let npeek_data n s =
let (al, d, len) = nget_data n s in
s.count <- (s.count - len);
s.data <- d;
al
;;
let npeek n = function
| None -> []
@ -135,13 +135,13 @@ let next s =
match peek s with
Some a -> junk s; a
| None -> raise Failure
;;
let empty s =
match peek s with
Some _ -> raise Failure
| None -> ()
;;
let iter f strm =
let rec do_rec () =
@ -150,15 +150,15 @@ let iter f strm =
| None -> ()
in
do_rec ()
;;
(* Stream building functions *)
let from f = Some {count = 0; data = Sgen {curr = None; func = f}};;
let from f = Some {count = 0; data = Sgen {curr = None; func = f}}
let of_list l =
Some {count = 0; data = List.fold_right (fun x l -> Scons (x, l)) l Sempty}
;;
let of_string s =
let count = ref 0 in
@ -173,7 +173,7 @@ let of_string s =
if c < String.length s
then (incr count; Some s.[c])
else None)
;;
let of_bytes s =
let count = ref 0 in
@ -182,27 +182,27 @@ let of_bytes s =
if c < Bytes.length s
then (incr count; Some (Bytes.get s c))
else None)
;;
let of_channel ic =
Some {count = 0;
data = Sbuffio {ic = ic; buff = Bytes.create 4096; len = 0; ind = 0}}
;;
(* Stream expressions builders *)
let iapp i s = Some {count = 0; data = Sapp (data i, data s)};;
let icons i s = Some {count = 0; data = Scons (i, data s)};;
let ising i = Some {count = 0; data = Scons (i, Sempty)};;
let iapp i s = Some {count = 0; data = Sapp (data i, data s)}
let icons i s = Some {count = 0; data = Scons (i, data s)}
let ising i = Some {count = 0; data = Scons (i, Sempty)}
let lapp f s =
Some {count = 0; data = Slazy (lazy(Sapp (data (f ()), data s)))}
;;
let lcons f s = Some {count = 0; data = Slazy (lazy(Scons (f (), data s)))};;
let lsing f = Some {count = 0; data = Slazy (lazy(Scons (f (), Sempty)))};;
let sempty = None;;
let slazy f = Some {count = 0; data = Slazy (lazy(data (f ())))};;
let lcons f s = Some {count = 0; data = Slazy (lazy(Scons (f (), data s)))}
let lsing f = Some {count = 0; data = Slazy (lazy(Scons (f (), Sempty)))}
let sempty = None
let slazy f = Some {count = 0; data = Slazy (lazy(data (f ())))}
(* For debugging use *)
@ -231,4 +231,3 @@ and dump_data : type v. (v -> unit) -> v data -> unit = fun f ->
| Slazy _ -> print_string "Slazy"
| Sgen _ -> print_string "Sgen"
| Sbuffio _ -> print_string "Sbuffio"
;;

4
stdlib/sys.mlp
View File

@ -38,7 +38,7 @@ let unix = unix ()
let win32 = win32 ()
let cygwin = cygwin ()
let max_array_length = max_wosize ()
let max_string_length = word_size / 8 * max_array_length - 1;;
let max_string_length = word_size / 8 * max_array_length - 1
external runtime_variant : unit -> string = "caml_runtime_variant"
external runtime_parameters : unit -> string = "caml_runtime_parameters"
@ -111,7 +111,7 @@ external runtime_warnings_enabled: unit -> bool =
(* The version string is found in file ../VERSION *)
let ocaml_version = "%%VERSION%%";;
let ocaml_version = "%%VERSION%%"
(* Optimization *)

89
stdlib/weak.ml
View File

@ -15,20 +15,20 @@
(** Weak array operations *)
type 'a t;;
type 'a t
external create : int -> 'a t = "caml_weak_create";;
external create : int -> 'a t = "caml_weak_create"
(** number of additional values in a weak pointer *)
let additional_values = 2
let length x = Obj.size(Obj.repr x) - additional_values;;
let length x = Obj.size(Obj.repr x) - additional_values
external set : 'a t -> int -> 'a option -> unit = "caml_weak_set";;
external get : 'a t -> int -> 'a option = "caml_weak_get";;
external get_copy : 'a t -> int -> 'a option = "caml_weak_get_copy";;
external check : 'a t -> int -> bool = "caml_weak_check";;
external blit : 'a t -> int -> 'a t -> int -> int -> unit = "caml_weak_blit";;
external set : 'a t -> int -> 'a option -> unit = "caml_weak_set"
external get : 'a t -> int -> 'a option = "caml_weak_get"
external get_copy : 'a t -> int -> 'a option = "caml_weak_get_copy"
external check : 'a t -> int -> bool = "caml_weak_check"
external blit : 'a t -> int -> 'a t -> int -> int -> unit = "caml_weak_blit"
(* blit: src srcoff dst dstoff len *)
let fill ar ofs len x =
@ -39,7 +39,7 @@ let fill ar ofs len x =
set ar i x
done
end
;;
(** Weak hash tables *)
@ -58,15 +58,15 @@ module type S = sig
val fold : (data -> 'a -> 'a) -> t -> 'a -> 'a
val count : t -> int
val stats : t -> int * int * int * int * int * int
end;;
end
module Make (H : Hashtbl.HashedType) : (S with type data = H.t) = struct
type 'a weak_t = 'a t;;
let weak_create = create;;
let emptybucket = weak_create 0;;
type 'a weak_t = 'a t
let weak_create = create
let emptybucket = weak_create 0
type data = H.t;;
type data = H.t
type t = {
mutable table : data weak_t array;
@ -74,12 +74,12 @@ module Make (H : Hashtbl.HashedType) : (S with type data = H.t) = struct
mutable limit : int; (* bucket size limit *)
mutable oversize : int; (* number of oversize buckets *)
mutable rover : int; (* for internal bookkeeping *)
};;
}
let get_index t h = (h land max_int) mod (Array.length t.table);;
let get_index t h = (h land max_int) mod (Array.length t.table)
let limit = 7;;
let over_limit = 2;;
let limit = 7
let over_limit = 2
let create sz =
let sz = if sz < 7 then 7 else sz in
@ -90,7 +90,7 @@ module Make (H : Hashtbl.HashedType) : (S with type data = H.t) = struct
limit = limit;
oversize = 0;
rover = 0;
};;
}
let clear t =
for i = 0 to Array.length t.table - 1 do
@ -98,8 +98,8 @@ module Make (H : Hashtbl.HashedType) : (S with type data = H.t) = struct
t.hashes.(i) <- [| |];
done;
t.limit <- limit;
t.oversize <- 0;
;;
t.oversize <- 0
let fold f t init =
let rec fold_bucket i b accu =
@ -109,7 +109,7 @@ module Make (H : Hashtbl.HashedType) : (S with type data = H.t) = struct
| None -> fold_bucket (i+1) b accu
in
Array.fold_right (fold_bucket 0) t.table init
;;
let iter f t =
let rec iter_bucket i b =
@ -119,7 +119,7 @@ module Make (H : Hashtbl.HashedType) : (S with type data = H.t) = struct
| None -> iter_bucket (i+1) b
in
Array.iter (iter_bucket 0) t.table
;;
let iter_weak f t =
let rec iter_bucket i j b =
@ -129,19 +129,19 @@ module Make (H : Hashtbl.HashedType) : (S with type data = H.t) = struct
| false -> iter_bucket (i+1) j b
in
Array.iteri (iter_bucket 0) t.table
;;
let rec count_bucket i b accu =
if i >= length b then accu else
count_bucket (i+1) b (accu + (if check b i then 1 else 0))
;;
let count t =
Array.fold_right (count_bucket 0) t.table 0
;;
let next_sz n = min (3 * n / 2 + 3) Sys.max_array_length;;
let prev_sz n = ((n - 3) * 2 + 2) / 3;;
let next_sz n = min (3 * n / 2 + 3) Sys.max_array_length
let prev_sz n = ((n - 3) * 2 + 2) / 3
let test_shrink_bucket t =
let bucket = t.table.(t.rover) in
@ -170,8 +170,8 @@ module Make (H : Hashtbl.HashedType) : (S with type data = H.t) = struct
end;
if len > t.limit && prev_len <= t.limit then t.oversize <- t.oversize - 1;
end;
t.rover <- (t.rover + 1) mod (Array.length t.table);
;;
t.rover <- (t.rover + 1) mod (Array.length t.table)
let rec resize t =
let oldlen = Array.length t.table in
@ -222,13 +222,13 @@ module Make (H : Hashtbl.HashedType) : (S with type data = H.t) = struct
hashes.(i) <- h;
end;
in
loop 0;
;;
loop 0
let add t d =
let h = H.hash d in
add_aux t set (Some d) h (get_index t h);
;;
add_aux t set (Some d) h (get_index t h)
let find_or t d ifnotfound =
let h = H.hash d in
@ -249,13 +249,14 @@ module Make (H : Hashtbl.HashedType) : (S with type data = H.t) = struct
end else loop (i + 1)
in
loop 0
;;
let merge t d =
find_or t d (fun h index -> add_aux t set (Some d) h index; d)
;;
let find t d = find_or t d (fun _h _index -> raise Not_found);;
let find t d = find_or t d (fun _h _index -> raise Not_found)
let find_shadow t d iffound ifnotfound =
let h = H.hash d in
@ -272,11 +273,13 @@ module Make (H : Hashtbl.HashedType) : (S with type data = H.t) = struct
end else loop (i + 1)
in
loop 0
;;
let remove t d = find_shadow t d (fun w i -> set w i None) ();;
let mem t d = find_shadow t d (fun _w _i -> true) false;;
let remove t d = find_shadow t d (fun w i -> set w i None) ()
let mem t d = find_shadow t d (fun _w _i -> true) false
let find_all t d =
let h = H.hash d in
@ -297,7 +300,7 @@ module Make (H : Hashtbl.HashedType) : (S with type data = H.t) = struct
end else loop (i + 1) accu
in
loop 0 []
;;
let stats t =
let len = Array.length t.table in
@ -305,6 +308,6 @@ module Make (H : Hashtbl.HashedType) : (S with type data = H.t) = struct
Array.sort compare lens;
let totlen = Array.fold_left ( + ) 0 lens in
(len, count t, totlen, lens.(0), lens.(len/2), lens.(len-1))
;;
end;;
end

4
testsuite/tests/asmcomp/Makefile
View File

@ -47,9 +47,9 @@ parsecmm.mli parsecmm.ml: parsecmm.mly
lexcmm.ml: lexcmm.mll
@$(OCAMLLEX) -q lexcmm.mll
MLCASES=optargs staticalloc bind_tuples is_static
MLCASES=optargs staticalloc bind_tuples is_static register_typing
ARGS_is_static=-I $(OTOPDIR)/byterun is_in_static_data.c
MLCASES_FLAMBDA=is_static_flambda
MLCASES_FLAMBDA=is_static_flambda unrolling_flambda
ARGS_is_static_flambda=-I $(OTOPDIR)/byterun is_in_static_data.c
CASES=fib tak quicksort quicksort2 soli \

20
testsuite/tests/asmcomp/register_typing.ml Normal file
View File

@ -0,0 +1,20 @@
type 'a typ = Int : int typ | Ptr : int list typ
let f (type a) (t : a typ) (p : int list) : a =
match t with
| Int -> 100
| Ptr -> p
let allocate_garbage () =
for i = 0 to 100 do
ignore (Array.make 200 0.0)
done
let g (t : int list typ) x =
Gc.minor ();
let x = f t ([x; x; x; x; x]) in
Gc.minor ();
allocate_garbage ();
ignore (String.length (String.concat " " (List.map string_of_int x)))
let () = g Ptr 5

7
testsuite/tests/asmcomp/unrolling_flambda.ml Normal file
View File

@ -0,0 +1,7 @@
let rec f x =
if x > 0 then f (x - 1)
else 0
[@@inline]
let _ = f 0

36
testsuite/tests/link-test/Makefile Normal file
View File

@ -0,0 +1,36 @@
#**************************************************************************
#* *
#* OCaml *
#* *
#* Thomas Refis, Jane Street Europe *
#* *
#* Copyright 2010 Institut National de Recherche en Informatique et *
#* en Automatique. *
#* Copyright 2016 Jane Street Group LLC *
#* *
#* All rights reserved. This file is distributed under the terms of *
#* the GNU Lesser General Public License version 2.1, with the *
#* special exception on linking described in the file LICENSE. *
#* *
#**************************************************************************
default:
printf " ... testing 'test.reference':"
@$(OCAMLOPT) -c submodule.ml
@$(OCAMLOPT) -c aliases.ml
@$(OCAMLOPT) -c test.ml
@$(OCAMLOPT) -a submodule.cmx aliases.cmx -o mylib.cmxa
@$(OCAMLOPT) mylib.cmxa test.cmx -o test.native
@./test.native > test.result
@$(DIFF) test.result test.reference >/dev/null \
&& echo " => passed" || echo " => failed"
promote: defaultpromote
clean: defaultclean
@rm -f *.result
@rm -f test.native
BASEDIR=../..
include $(BASEDIR)/makefiles/Makefile.common
COMPFLAGS = -no-alias-deps

1
testsuite/tests/link-test/aliases.ml Normal file
View File

@ -0,0 +1 @@
module Submodule = Submodule

2
testsuite/tests/link-test/submodule.ml Normal file
View File

@ -0,0 +1,2 @@
let () = print_endline "linked"; flush stdout
module M = struct end

1
testsuite/tests/link-test/test.ml Normal file
View File

@ -0,0 +1 @@
include Aliases.Submodule.M

1
testsuite/tests/link-test/test.reference Normal file
View File

@ -0,0 +1 @@
linked

741
testsuite/tests/translprim/comparison_table.ml.reference
View File

@ -1,364 +1,381 @@
(setglobal Comparison_table!
(let
(gen_cmp = (function x y (caml_compare x y))
int_cmp = (function x y (caml_int_compare x y))
bool_cmp =
(function x y (caml_int_compare x y))
intlike_cmp =
(function x y (caml_int_compare x y))
float_cmp =
(function x y (caml_float_compare x y))
string_cmp =
(function x y (caml_string_compare x y))
int32_cmp =
(function x y (caml_int32_compare x y))
int64_cmp =
(function x y (caml_int64_compare x y))
nativeint_cmp =
(function x y (caml_nativeint_compare x y))
gen_eq = (function x y (caml_equal x y))
int_eq = (function x y (== x y))
bool_eq = (function x y (== x y))
intlike_eq = (function x y (== x y))
float_eq = (function x y (==. x y))
string_eq =
(function x y (caml_string_equal x y))
int32_eq = (function x y (Int32.== x y))
int64_eq = (function x y (Int64.== x y))
nativeint_eq =
(function x y (Nativeint.== x y))
gen_ne = (function x y (caml_notequal x y))
int_ne = (function x y (!= x y))
bool_ne = (function x y (!= x y))
intlike_ne = (function x y (!= x y))
float_ne = (function x y (!=. x y))
string_ne =
(function x y (caml_string_notequal x y))
int32_ne = (function x y (Int32.!= x y))
int64_ne = (function x y (Int64.!= x y))
nativeint_ne =
(function x y (Nativeint.!= x y))
gen_lt = (function x y (caml_lessthan x y))
int_lt = (function x y (< x y))
bool_lt = (function x y (< x y))
intlike_lt = (function x y (< x y))
float_lt = (function x y (<. x y))
string_lt =
(function x y (caml_string_lessthan x y))
int32_lt = (function x y (Int32.< x y))
int64_lt = (function x y (Int64.< x y))
nativeint_lt = (function x y (Nativeint.< x y))
gen_gt = (function x y (caml_greaterthan x y))
int_gt = (function x y (> x y))
bool_gt = (function x y (> x y))
intlike_gt = (function x y (> x y))
float_gt = (function x y (>. x y))
string_gt =
(function x y (caml_string_greaterthan x y))
int32_gt = (function x y (Int32.> x y))
int64_gt = (function x y (Int64.> x y))
nativeint_gt = (function x y (Nativeint.> x y))
gen_le = (function x y (caml_lessequal x y))
int_le = (function x y (<= x y))
bool_le = (function x y (<= x y))
intlike_le = (function x y (<= x y))
float_le = (function x y (<=. x y))
string_le =
(function x y (caml_string_lessequal x y))
int32_le = (function x y (Int32.<= x y))
int64_le = (function x y (Int64.<= x y))
nativeint_le =
(function x y (Nativeint.<= x y))
gen_ge = (function x y (caml_greaterequal x y))
int_ge = (function x y (>= x y))
bool_ge = (function x y (>= x y))
intlike_ge = (function x y (>= x y))
float_ge = (function x y (>=. x y))
string_ge =
(function x y (caml_string_greaterequal x y))
int32_ge = (function x y (Int32.>= x y))
int64_ge = (function x y (Int64.>= x y))
nativeint_ge =
(function x y (Nativeint.>= x y))
eta_gen_cmp =
(function prim prim (caml_compare prim prim))
eta_int_cmp =
(function prim prim (caml_int_compare prim prim))
eta_bool_cmp =
(function prim prim (caml_int_compare prim prim))
eta_intlike_cmp =
(function prim prim (caml_int_compare prim prim))
eta_float_cmp =
(function prim prim
(caml_float_compare prim prim))
eta_string_cmp =
(function prim prim
(caml_string_compare prim prim))
eta_int32_cmp =
(function prim prim
(caml_int32_compare prim prim))
eta_int64_cmp =
(function prim prim
(caml_int64_compare prim prim))
eta_nativeint_cmp =
(function prim prim
(caml_nativeint_compare prim prim))
eta_gen_eq =
(function prim prim (caml_equal prim prim))
eta_int_eq =
(function prim prim (== prim prim))
eta_bool_eq =
(function prim prim (== prim prim))
eta_intlike_eq =
(function prim prim (== prim prim))
eta_float_eq =
(function prim prim (==. prim prim))
eta_string_eq =
(function prim prim (caml_string_equal prim prim))
eta_int32_eq =
(function prim prim (Int32.== prim prim))
eta_int64_eq =
(function prim prim (Int64.== prim prim))
eta_nativeint_eq =
(function prim prim (Nativeint.== prim prim))
eta_gen_ne =
(function prim prim (caml_notequal prim prim))
eta_int_ne =
(function prim prim (!= prim prim))
eta_bool_ne =
(function prim prim (!= prim prim))
eta_intlike_ne =
(function prim prim (!= prim prim))
eta_float_ne =
(function prim prim (!=. prim prim))
eta_string_ne =
(function prim prim
(caml_string_notequal prim prim))
eta_int32_ne =
(function prim prim (Int32.!= prim prim))
eta_int64_ne =
(function prim prim (Int64.!= prim prim))
eta_nativeint_ne =
(function prim prim (Nativeint.!= prim prim))
eta_gen_lt =
(function prim prim (caml_lessthan prim prim))
eta_int_lt = (function prim prim (< prim prim))
eta_bool_lt =
(function prim prim (< prim prim))
eta_intlike_lt =
(function prim prim (< prim prim))
eta_float_lt =
(function prim prim (<. prim prim))
eta_string_lt =
(function prim prim
(caml_string_lessthan prim prim))
eta_int32_lt =
(function prim prim (Int32.< prim prim))
eta_int64_lt =
(function prim prim (Int64.< prim prim))
eta_nativeint_lt =
(function prim prim (Nativeint.< prim prim))
eta_gen_gt =
(function prim prim (caml_greaterthan prim prim))
eta_int_gt = (function prim prim (> prim prim))
eta_bool_gt =
(function prim prim (> prim prim))
eta_intlike_gt =
(function prim prim (> prim prim))
eta_float_gt =
(function prim prim (>. prim prim))
eta_string_gt =
(function prim prim
(caml_string_greaterthan prim prim))
eta_int32_gt =
(function prim prim (Int32.> prim prim))
eta_int64_gt =
(function prim prim (Int64.> prim prim))
eta_nativeint_gt =
(function prim prim (Nativeint.> prim prim))
eta_gen_le =
(function prim prim (caml_lessequal prim prim))
eta_int_le =
(function prim prim (<= prim prim))
eta_bool_le =
(function prim prim (<= prim prim))
eta_intlike_le =
(function prim prim (<= prim prim))
eta_float_le =
(function prim prim (<=. prim prim))
eta_string_le =
(function prim prim
(caml_string_lessequal prim prim))
eta_int32_le =
(function prim prim (Int32.<= prim prim))
eta_int64_le =
(function prim prim (Int64.<= prim prim))
eta_nativeint_le =
(function prim prim (Nativeint.<= prim prim))
eta_gen_ge =
(function prim prim (caml_greaterequal prim prim))
eta_int_ge =
(function prim prim (>= prim prim))
eta_bool_ge =
(function prim prim (>= prim prim))
eta_intlike_ge =
(function prim prim (>= prim prim))
eta_float_ge =
(function prim prim (>=. prim prim))
eta_string_ge =
(function prim prim
(caml_string_greaterequal prim prim))
eta_int32_ge =
(function prim prim (Int32.>= prim prim))
eta_int64_ge =
(function prim prim (Int64.>= prim prim))
eta_nativeint_ge =
(function prim prim (Nativeint.>= prim prim))
int_vec = [0: [0: 1 1] [0: [0: 1 2] [0: [0: 2 1] 0a]]]
bool_vec = [0: [0: 0a 0a] [0: [0: 0a 1a] [0: [0: 1a 0a] 0a]]]
intlike_vec = [0: [0: 0a 0a] [0: [0: 0a 1a] [0: [0: 1a 0a] 0a]]]
float_vec = [0: [0: 1. 1.] [0: [0: 1. 2.] [0: [0: 2. 1.] 0a]]]
string_vec =
[0: [0: "1" "1"] [0: [0: "1" "2"] [0: [0: "2" "1"] 0a]]]
int32_vec = [0: [0: 1l 1l] [0: [0: 1l 2l] [0: [0: 2l 1l] 0a]]]
int64_vec = [0: [0: 1L 1L] [0: [0: 1L 2L] [0: [0: 2L 1L] 0a]]]
nativeint_vec = [0: [0: 1n 1n] [0: [0: 1n 2n] [0: [0: 2n 1n] 0a]]]
test_vec =
(function cmp eq ne lt gt le ge
vec
(let
(uncurry =
(function f param
(apply f (field 0 param) (field 1 param)))
map =
(function f l
(apply (field 12 (global List!)) (apply uncurry f)
l)))
(makeblock 0
(makeblock 0 (apply map gen_cmp vec)
(apply map cmp vec))
(apply map
(function gen spec
(makeblock 0 (apply map gen vec)
(apply map spec vec)))
(makeblock 0 (makeblock 0 gen_eq eq)
(makeblock 0 (makeblock 0 gen_ne ne)
(makeblock 0 (makeblock 0 gen_lt lt)
(makeblock 0 (makeblock 0 gen_gt gt)
(makeblock 0 (makeblock 0 gen_le le)
(makeblock 0 (makeblock 0 gen_ge ge) 0a)))))))))))
(seq
(apply test_vec int_cmp int_eq int_ne int_lt
int_gt int_le int_ge int_vec)
(apply test_vec bool_cmp bool_eq bool_ne
bool_lt bool_gt bool_le bool_ge bool_vec)
(apply test_vec intlike_cmp intlike_eq intlike_ne
intlike_lt intlike_gt intlike_le intlike_ge
intlike_vec)
(apply test_vec float_cmp float_eq float_ne
float_lt float_gt float_le float_ge
float_vec)
(apply test_vec string_cmp string_eq string_ne
string_lt string_gt string_le string_ge
string_vec)
(apply test_vec int32_cmp int32_eq int32_ne
int32_lt int32_gt int32_le int32_ge
int32_vec)
(apply test_vec int64_cmp int64_eq int64_ne
int64_lt int64_gt int64_le int64_ge
int64_vec)
(apply test_vec nativeint_cmp nativeint_eq
nativeint_ne nativeint_lt nativeint_gt
nativeint_le nativeint_ge nativeint_vec)
(let
(eta_test_vec =
(function cmp eq ne lt gt le ge
vec
(let
(uncurry =
(function f param
(apply f (field 0 param) (field 1 param)))
map =
(function f l
(apply (field 12 (global List!))
(apply uncurry f) l)))
(makeblock 0
(makeblock 0 (apply map eta_gen_cmp vec)
(apply map cmp vec))
(apply map
(function gen spec
(makeblock 0 (apply map gen vec)
(apply map spec vec)))
(makeblock 0 (makeblock 0 eta_gen_eq eq)
(makeblock 0 (makeblock 0 eta_gen_ne ne)
(makeblock 0 (makeblock 0 eta_gen_lt lt)
(makeblock 0 (makeblock 0 eta_gen_gt gt)
(makeblock 0 (makeblock 0 eta_gen_le le)
(seq (opaque (global List!))
(let
(gen_cmp = (function x y (caml_compare x y))
int_cmp =
(function x y (caml_int_compare x y))
bool_cmp =
(function x y (caml_int_compare x y))
intlike_cmp =
(function x y (caml_int_compare x y))
float_cmp =
(function x y (caml_float_compare x y))
string_cmp =
(function x y (caml_string_compare x y))
int32_cmp =
(function x y (caml_int32_compare x y))
int64_cmp =
(function x y (caml_int64_compare x y))
nativeint_cmp =
(function x y (caml_nativeint_compare x y))
gen_eq = (function x y (caml_equal x y))
int_eq = (function x y (== x y))
bool_eq = (function x y (== x y))
intlike_eq = (function x y (== x y))
float_eq = (function x y (==. x y))
string_eq =
(function x y (caml_string_equal x y))
int32_eq = (function x y (Int32.== x y))
int64_eq = (function x y (Int64.== x y))
nativeint_eq =
(function x y (Nativeint.== x y))
gen_ne = (function x y (caml_notequal x y))
int_ne = (function x y (!= x y))
bool_ne = (function x y (!= x y))
intlike_ne = (function x y (!= x y))
float_ne = (function x y (!=. x y))
string_ne =
(function x y (caml_string_notequal x y))
int32_ne = (function x y (Int32.!= x y))
int64_ne = (function x y (Int64.!= x y))
nativeint_ne =
(function x y (Nativeint.!= x y))
gen_lt = (function x y (caml_lessthan x y))
int_lt = (function x y (< x y))
bool_lt = (function x y (< x y))
intlike_lt = (function x y (< x y))
float_lt = (function x y (<. x y))
string_lt =
(function x y (caml_string_lessthan x y))
int32_lt = (function x y (Int32.< x y))
int64_lt = (function x y (Int64.< x y))
nativeint_lt =
(function x y (Nativeint.< x y))
gen_gt =
(function x y (caml_greaterthan x y))
int_gt = (function x y (> x y))
bool_gt = (function x y (> x y))
intlike_gt = (function x y (> x y))
float_gt = (function x y (>. x y))
string_gt =
(function x y (caml_string_greaterthan x y))
int32_gt = (function x y (Int32.> x y))
int64_gt = (function x y (Int64.> x y))
nativeint_gt =
(function x y (Nativeint.> x y))
gen_le = (function x y (caml_lessequal x y))
int_le = (function x y (<= x y))
bool_le = (function x y (<= x y))
intlike_le = (function x y (<= x y))
float_le = (function x y (<=. x y))
string_le =
(function x y (caml_string_lessequal x y))
int32_le = (function x y (Int32.<= x y))
int64_le = (function x y (Int64.<= x y))
nativeint_le =
(function x y (Nativeint.<= x y))
gen_ge =
(function x y (caml_greaterequal x y))
int_ge = (function x y (>= x y))
bool_ge = (function x y (>= x y))
intlike_ge = (function x y (>= x y))
float_ge = (function x y (>=. x y))
string_ge =
(function x y (caml_string_greaterequal x y))
int32_ge = (function x y (Int32.>= x y))
int64_ge = (function x y (Int64.>= x y))
nativeint_ge =
(function x y (Nativeint.>= x y))
eta_gen_cmp =
(function prim prim (caml_compare prim prim))
eta_int_cmp =
(function prim prim
(caml_int_compare prim prim))
eta_bool_cmp =
(function prim prim
(caml_int_compare prim prim))
eta_intlike_cmp =
(function prim prim
(caml_int_compare prim prim))
eta_float_cmp =
(function prim prim
(caml_float_compare prim prim))
eta_string_cmp =
(function prim prim
(caml_string_compare prim prim))
eta_int32_cmp =
(function prim prim
(caml_int32_compare prim prim))
eta_int64_cmp =
(function prim prim
(caml_int64_compare prim prim))
eta_nativeint_cmp =
(function prim prim
(caml_nativeint_compare prim prim))
eta_gen_eq =
(function prim prim (caml_equal prim prim))
eta_int_eq =
(function prim prim (== prim prim))
eta_bool_eq =
(function prim prim (== prim prim))
eta_intlike_eq =
(function prim prim (== prim prim))
eta_float_eq =
(function prim prim (==. prim prim))
eta_string_eq =
(function prim prim
(caml_string_equal prim prim))
eta_int32_eq =
(function prim prim (Int32.== prim prim))
eta_int64_eq =
(function prim prim (Int64.== prim prim))
eta_nativeint_eq =
(function prim prim (Nativeint.== prim prim))
eta_gen_ne =
(function prim prim (caml_notequal prim prim))
eta_int_ne =
(function prim prim (!= prim prim))
eta_bool_ne =
(function prim prim (!= prim prim))
eta_intlike_ne =
(function prim prim (!= prim prim))
eta_float_ne =
(function prim prim (!=. prim prim))
eta_string_ne =
(function prim prim
(caml_string_notequal prim prim))
eta_int32_ne =
(function prim prim (Int32.!= prim prim))
eta_int64_ne =
(function prim prim (Int64.!= prim prim))
eta_nativeint_ne =
(function prim prim (Nativeint.!= prim prim))
eta_gen_lt =
(function prim prim (caml_lessthan prim prim))
eta_int_lt =
(function prim prim (< prim prim))
eta_bool_lt =
(function prim prim (< prim prim))
eta_intlike_lt =
(function prim prim (< prim prim))
eta_float_lt =
(function prim prim (<. prim prim))
eta_string_lt =
(function prim prim
(caml_string_lessthan prim prim))
eta_int32_lt =
(function prim prim (Int32.< prim prim))
eta_int64_lt =
(function prim prim (Int64.< prim prim))
eta_nativeint_lt =
(function prim prim (Nativeint.< prim prim))
eta_gen_gt =
(function prim prim
(caml_greaterthan prim prim))
eta_int_gt =
(function prim prim (> prim prim))
eta_bool_gt =
(function prim prim (> prim prim))
eta_intlike_gt =
(function prim prim (> prim prim))
eta_float_gt =
(function prim prim (>. prim prim))
eta_string_gt =
(function prim prim
(caml_string_greaterthan prim prim))
eta_int32_gt =
(function prim prim (Int32.> prim prim))
eta_int64_gt =
(function prim prim (Int64.> prim prim))
eta_nativeint_gt =
(function prim prim (Nativeint.> prim prim))
eta_gen_le =
(function prim prim (caml_lessequal prim prim))
eta_int_le =
(function prim prim (<= prim prim))
eta_bool_le =
(function prim prim (<= prim prim))
eta_intlike_le =
(function prim prim (<= prim prim))
eta_float_le =
(function prim prim (<=. prim prim))
eta_string_le =
(function prim prim
(caml_string_lessequal prim prim))
eta_int32_le =
(function prim prim (Int32.<= prim prim))
eta_int64_le =
(function prim prim (Int64.<= prim prim))
eta_nativeint_le =
(function prim prim (Nativeint.<= prim prim))
eta_gen_ge =
(function prim prim
(caml_greaterequal prim prim))
eta_int_ge =
(function prim prim (>= prim prim))
eta_bool_ge =
(function prim prim (>= prim prim))
eta_intlike_ge =
(function prim prim (>= prim prim))
eta_float_ge =
(function prim prim (>=. prim prim))
eta_string_ge =
(function prim prim
(caml_string_greaterequal prim prim))
eta_int32_ge =
(function prim prim (Int32.>= prim prim))
eta_int64_ge =
(function prim prim (Int64.>= prim prim))
eta_nativeint_ge =
(function prim prim (Nativeint.>= prim prim))
int_vec = [0: [0: 1 1] [0: [0: 1 2] [0: [0: 2 1] 0a]]]
bool_vec = [0: [0: 0a 0a] [0: [0: 0a 1a] [0: [0: 1a 0a] 0a]]]
intlike_vec = [0: [0: 0a 0a] [0: [0: 0a 1a] [0: [0: 1a 0a] 0a]]]
float_vec = [0: [0: 1. 1.] [0: [0: 1. 2.] [0: [0: 2. 1.] 0a]]]
string_vec =
[0: [0: "1" "1"] [0: [0: "1" "2"] [0: [0: "2" "1"] 0a]]]
int32_vec = [0: [0: 1l 1l] [0: [0: 1l 2l] [0: [0: 2l 1l] 0a]]]
int64_vec = [0: [0: 1L 1L] [0: [0: 1L 2L] [0: [0: 2L 1L] 0a]]]
nativeint_vec =
[0: [0: 1n 1n] [0: [0: 1n 2n] [0: [0: 2n 1n] 0a]]]
test_vec =
(function cmp eq ne lt gt le ge
vec
(let
(uncurry =
(function f param
(apply f (field 0 param) (field 1 param)))
map =
(function f l
(apply (field 12 (global List!))
(apply uncurry f) l)))
(makeblock 0
(makeblock 0 (apply map gen_cmp vec)
(apply map cmp vec))
(apply map
(function gen spec
(makeblock 0 (apply map gen vec)
(apply map spec vec)))
(makeblock 0 (makeblock 0 gen_eq eq)
(makeblock 0 (makeblock 0 gen_ne ne)
(makeblock 0 (makeblock 0 gen_lt lt)
(makeblock 0 (makeblock 0 gen_gt gt)
(makeblock 0 (makeblock 0 gen_le le)
(makeblock 0 (makeblock 0 gen_ge ge) 0a)))))))))))
(seq
(apply test_vec int_cmp int_eq int_ne int_lt
int_gt int_le int_ge int_vec)
(apply test_vec bool_cmp bool_eq bool_ne
bool_lt bool_gt bool_le bool_ge bool_vec)
(apply test_vec intlike_cmp intlike_eq intlike_ne
intlike_lt intlike_gt intlike_le intlike_ge
intlike_vec)
(apply test_vec float_cmp float_eq float_ne
float_lt float_gt float_le float_ge
float_vec)
(apply test_vec string_cmp string_eq string_ne
string_lt string_gt string_le string_ge
string_vec)
(apply test_vec int32_cmp int32_eq int32_ne
int32_lt int32_gt int32_le int32_ge
int32_vec)
(apply test_vec int64_cmp int64_eq int64_ne
int64_lt int64_gt int64_le int64_ge
int64_vec)
(apply test_vec nativeint_cmp nativeint_eq
nativeint_ne nativeint_lt nativeint_gt
nativeint_le nativeint_ge nativeint_vec)
(let
(eta_test_vec =
(function cmp eq ne lt gt le
ge vec
(let
(uncurry =
(function f param
(apply f (field 0 param)
(field 1 param)))
map =
(function f l
(apply (field 12 (global List!))
(apply uncurry f) l)))
(makeblock 0
(makeblock 0 (apply map eta_gen_cmp vec)
(apply map cmp vec))
(apply map
(function gen spec
(makeblock 0 (apply map gen vec)
(apply map spec vec)))
(makeblock 0 (makeblock 0 eta_gen_eq eq)
(makeblock 0 (makeblock 0 eta_gen_ne ne)
(makeblock 0 (makeblock 0 eta_gen_lt lt)
(makeblock 0 (makeblock 0 eta_gen_gt gt)
(makeblock 0
(makeblock 0 eta_gen_ge ge) 0a)))))))))))
(seq
(apply eta_test_vec eta_int_cmp eta_int_eq
eta_int_ne eta_int_lt eta_int_gt eta_int_le
eta_int_ge int_vec)
(apply eta_test_vec eta_bool_cmp eta_bool_eq
eta_bool_ne eta_bool_lt eta_bool_gt
eta_bool_le eta_bool_ge bool_vec)
(apply eta_test_vec eta_intlike_cmp eta_intlike_eq
eta_intlike_ne eta_intlike_lt eta_intlike_gt
eta_intlike_le eta_intlike_ge intlike_vec)
(apply eta_test_vec eta_float_cmp eta_float_eq
eta_float_ne eta_float_lt eta_float_gt
eta_float_le eta_float_ge float_vec)
(apply eta_test_vec eta_string_cmp eta_string_eq
eta_string_ne eta_string_lt eta_string_gt
eta_string_le eta_string_ge string_vec)
(apply eta_test_vec eta_int32_cmp eta_int32_eq
eta_int32_ne eta_int32_lt eta_int32_gt
eta_int32_le eta_int32_ge int32_vec)
(apply eta_test_vec eta_int64_cmp eta_int64_eq
eta_int64_ne eta_int64_lt eta_int64_gt
eta_int64_le eta_int64_ge int64_vec)
(apply eta_test_vec eta_nativeint_cmp
eta_nativeint_eq eta_nativeint_ne eta_nativeint_lt
eta_nativeint_gt eta_nativeint_le eta_nativeint_ge
nativeint_vec)
(makeblock 0 gen_cmp int_cmp bool_cmp
intlike_cmp float_cmp string_cmp int32_cmp
int64_cmp nativeint_cmp gen_eq int_eq
bool_eq intlike_eq float_eq string_eq
int32_eq int64_eq nativeint_eq gen_ne
int_ne bool_ne intlike_ne float_ne
string_ne int32_ne int64_ne nativeint_ne
gen_lt int_lt bool_lt intlike_lt
float_lt string_lt int32_lt int64_lt
nativeint_lt gen_gt int_gt bool_gt
intlike_gt float_gt string_gt int32_gt
int64_gt nativeint_gt gen_le int_le
bool_le intlike_le float_le string_le
int32_le int64_le nativeint_le gen_ge
int_ge bool_ge intlike_ge float_ge
string_ge int32_ge int64_ge nativeint_ge
eta_gen_cmp eta_int_cmp eta_bool_cmp
eta_intlike_cmp eta_float_cmp eta_string_cmp
eta_int32_cmp eta_int64_cmp eta_nativeint_cmp
eta_gen_eq eta_int_eq eta_bool_eq
eta_intlike_eq eta_float_eq eta_string_eq
eta_int32_eq eta_int64_eq eta_nativeint_eq
eta_gen_ne eta_int_ne eta_bool_ne
eta_intlike_ne eta_float_ne eta_string_ne
eta_int32_ne eta_int64_ne eta_nativeint_ne
eta_gen_lt eta_int_lt eta_bool_lt
eta_intlike_lt eta_float_lt eta_string_lt
eta_int32_lt eta_int64_lt eta_nativeint_lt
eta_gen_gt eta_int_gt eta_bool_gt
eta_intlike_gt eta_float_gt eta_string_gt
eta_int32_gt eta_int64_gt eta_nativeint_gt
eta_gen_le eta_int_le eta_bool_le
eta_intlike_le eta_float_le eta_string_le
eta_int32_le eta_int64_le eta_nativeint_le
eta_gen_ge eta_int_ge eta_bool_ge
eta_intlike_ge eta_float_ge eta_string_ge
eta_int32_ge eta_int64_ge eta_nativeint_ge
int_vec bool_vec intlike_vec float_vec
string_vec int32_vec int64_vec nativeint_vec
test_vec eta_test_vec))))))
(makeblock 0 eta_gen_le le)
(makeblock 0
(makeblock 0 eta_gen_ge ge) 0a)))))))))))
(seq
(apply eta_test_vec eta_int_cmp eta_int_eq
eta_int_ne eta_int_lt eta_int_gt eta_int_le
eta_int_ge int_vec)
(apply eta_test_vec eta_bool_cmp eta_bool_eq
eta_bool_ne eta_bool_lt eta_bool_gt
eta_bool_le eta_bool_ge bool_vec)
(apply eta_test_vec eta_intlike_cmp eta_intlike_eq
eta_intlike_ne eta_intlike_lt eta_intlike_gt
eta_intlike_le eta_intlike_ge intlike_vec)
(apply eta_test_vec eta_float_cmp eta_float_eq
eta_float_ne eta_float_lt eta_float_gt
eta_float_le eta_float_ge float_vec)
(apply eta_test_vec eta_string_cmp eta_string_eq
eta_string_ne eta_string_lt eta_string_gt
eta_string_le eta_string_ge string_vec)
(apply eta_test_vec eta_int32_cmp eta_int32_eq
eta_int32_ne eta_int32_lt eta_int32_gt
eta_int32_le eta_int32_ge int32_vec)
(apply eta_test_vec eta_int64_cmp eta_int64_eq
eta_int64_ne eta_int64_lt eta_int64_gt
eta_int64_le eta_int64_ge int64_vec)
(apply eta_test_vec eta_nativeint_cmp
eta_nativeint_eq eta_nativeint_ne
eta_nativeint_lt eta_nativeint_gt
eta_nativeint_le eta_nativeint_ge nativeint_vec)
(makeblock 0 gen_cmp int_cmp bool_cmp
intlike_cmp float_cmp string_cmp int32_cmp
int64_cmp nativeint_cmp gen_eq int_eq
bool_eq intlike_eq float_eq string_eq
int32_eq int64_eq nativeint_eq gen_ne
int_ne bool_ne intlike_ne float_ne
string_ne int32_ne int64_ne nativeint_ne
gen_lt int_lt bool_lt intlike_lt
float_lt string_lt int32_lt int64_lt
nativeint_lt gen_gt int_gt bool_gt
intlike_gt float_gt string_gt int32_gt
int64_gt nativeint_gt gen_le int_le
bool_le intlike_le float_le string_le
int32_le int64_le nativeint_le gen_ge
int_ge bool_ge intlike_ge float_ge
string_ge int32_ge int64_ge nativeint_ge
eta_gen_cmp eta_int_cmp eta_bool_cmp
eta_intlike_cmp eta_float_cmp eta_string_cmp
eta_int32_cmp eta_int64_cmp eta_nativeint_cmp
eta_gen_eq eta_int_eq eta_bool_eq
eta_intlike_eq eta_float_eq eta_string_eq
eta_int32_eq eta_int64_eq eta_nativeint_eq
eta_gen_ne eta_int_ne eta_bool_ne
eta_intlike_ne eta_float_ne eta_string_ne
eta_int32_ne eta_int64_ne eta_nativeint_ne
eta_gen_lt eta_int_lt eta_bool_lt
eta_intlike_lt eta_float_lt eta_string_lt
eta_int32_lt eta_int64_lt eta_nativeint_lt
eta_gen_gt eta_int_gt eta_bool_gt
eta_intlike_gt eta_float_gt eta_string_gt
eta_int32_gt eta_int64_gt eta_nativeint_gt
eta_gen_le eta_int_le eta_bool_le
eta_intlike_le eta_float_le eta_string_le
eta_int32_le eta_int64_le eta_nativeint_le
eta_gen_ge eta_int_ge eta_bool_ge
eta_intlike_ge eta_float_ge eta_string_ge
eta_int32_ge eta_int64_ge eta_nativeint_ge
int_vec bool_vec intlike_vec float_vec
string_vec int32_vec int64_vec
nativeint_vec test_vec eta_test_vec)))))))

2
testsuite/tests/typing-modules/pr7207.ml Normal file
View File

@ -0,0 +1,2 @@
module F (X : sig end) = struct type t = int end;;
type t = F(Does_not_exist).t;;

7
testsuite/tests/typing-modules/pr7207.ml.reference Normal file
View File

@ -0,0 +1,7 @@
# module F : functor (X : sig end) -> sig type t = int end
# Characters 9-28:
type t = F(Does_not_exist).t;;
^^^^^^^^^^^^^^^^^^^
Error: Unbound module Does_not_exist
#

13
testsuite/tests/typing-polyvariants-bugs/pr7199_ok.ml Normal file
View File

@ -0,0 +1,13 @@
module type S = sig
type +'a t
val foo : [`A] t -> unit
val bar : [< `A | `B] t -> unit
end
module Make(T : S) = struct
let f x =
T.foo x;
T.bar x;
(x :> [`A | `C] T.t)
end

6
tools/Makefile.shared
View File

@ -51,9 +51,9 @@ CAMLDEP_IMPORTS=timings.cmo misc.cmo config.cmo identifiable.cmo numbers.cmo \
arg_helper.cmo clflags.cmo terminfo.cmo \
warnings.cmo location.cmo longident.cmo docstrings.cmo \
syntaxerr.cmo ast_helper.cmo parser.cmo lexer.cmo parse.cmo \
ccomp.cmo ast_mapper.cmo ast_iterator.cmo ast_invariants.cmo pparse.cmo \
compenv.cmo \
builtin_attributes.cmo depend.cmo
ccomp.cmo ast_mapper.cmo ast_iterator.cmo \
builtin_attributes.cmo ast_invariants.cmo \
pparse.cmo compenv.cmo depend.cmo
ocamldep: $(CAMLDEP_OBJ)
$(CAMLC) $(LINKFLAGS) -compat-32 -o ocamldep $(CAMLDEP_IMPORTS) \

3
tools/make-package-macosx
View File

@ -88,7 +88,8 @@ mkdir -p resources
cat >resources/ReadMe.txt <<EOF
This package installs OCaml version ${VERSION}.
You need Mac OS X 10.11.x (El Capitan) or later, with the
XCode tools installed (v7.2.1 or later).
XCode tools installed (v7.3 or later) and the command-line
tools for XCode.
Files will be installed in the following directories:

4
typing/printtyp.ml
View File

@ -1431,11 +1431,11 @@ let explanation unif t3 t4 ppf =
row1.row_fields, row1.row_closed, row2.row_fields, row2.row_closed with
| [], true, [], true ->
fprintf ppf "@,These two variant types have no intersection"
| [], true, fields, _ ->
| [], true, (_::_ as fields), _ ->
fprintf ppf
"@,@[The first variant type does not allow tag(s)@ @[<hov>%a@]@]"
print_tags fields
| fields, _, [], true ->
| (_::_ as fields), _, [], true ->
fprintf ppf
"@,@[The second variant type does not allow tag(s)@ @[<hov>%a@]@]"
print_tags fields

7
typing/typecore.ml
View File

@ -1945,7 +1945,7 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected =
| false, Rejected, _
-> ()
| true, Rejected, _
| false, Required, Tvar _ ->
| false, Required, (Tvar _ | Tconstr _) ->
raise (Error (loc, env, Inlined_record_escape))
| false, Required, _ ->
() (* will fail later *)
@ -2424,8 +2424,9 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected =
(Texp_constraint cty, loc, sexp.pexp_attributes) :: arg.exp_extra;
}
| Pexp_coerce(sarg, sty, sty') ->
(* Could be always true, only 1% slowdown for lablgtk *)
let separate = !Clflags.principal || Env.has_local_constraints env in
let separate = true in (* always separate, 1% slowdown for lablgtk *)
(* Also see PR#7199 for a problem with the following:
let separate = !Clflags.principal || Env.has_local_constraints env in*)
let (arg, ty',cty,cty') =
match sty with
| None ->

2
typing/typetexp.ml
View File

@ -101,8 +101,8 @@ let rec narrow_unbound_lid_error : 'a. _ -> _ -> _ -> _ -> 'a =
raise (Error (loc, env, Cannot_scrape_alias(flid, p)))
| _ -> ()
end;
let mmd = Env.find_module (Env.lookup_module ~load:true mlid env) env in
check_module mlid;
let mmd = Env.find_module (Env.lookup_module ~load:true mlid env) env in
begin match Env.scrape_alias env mmd.md_type with
| Mty_alias p ->
raise (Error (loc, env, Cannot_scrape_alias(mlid, p)))