···2727*.png binary
2828*.tfm binary
29293030-# Tell GitHub not to show diffs for autogenerated files
3131-*.depend linguist-generated
3030+# configure is declared as binary so that it doesn't get included in diffs.
3131+# This also means it will have the correct Unix line-endings, even on Windows.
3232+/configure binary
32333334# 'union' merge driver just unions textual content in case of conflict
3435# http://krlmlr.github.io/using-gitattributes-to-avoid-merge-conflicts/
···81828283# configure is generated so do not check it
8384configure typo.prune
8585+8686+ocaml-variants.opam typo.prune
84878588emacs/*.el typo.long-line=may
8689emacs/caml.el typo.long-line=may typo.missing-header
···139142140143/tools/ci/appveyor/appveyor_build.cmd text eol=crlf
141144142142-configure text eol=lf
143145configure.ac text eol=lf
144146autogen text eol=lf
145147build-aux/compile text eol=lf
···1313#* *
1414#**************************************************************************
15151616+dist: xenial
1617sudo: false
1718language: c
1819git:
+72-13
Changes
···2121 (Greg V, review by Sébastien Hinderer, Stephen Dolan, Damien Doligez
2222 and Xavier Leroy)
23232424+- GPR#8547: Optimize matches that are an affine function of the input.
2525+ (Stefan Muenzel, review by Alain Frisch, Gabriel Scherer)
2626+2427### Compiler user-interface and warnings:
25282629* #2276: Remove support for compiler plugins and hooks (also adds
2730 [Dynlink.unsafe_get_global_value])
2831 (Mark Shinwell, Xavier Clerc, review by Nicolás Ojeda Bär,
2932 Florian Angeletti, David Allsopp and Xavier Leroy)
3333+3434+- #2301: Hint on type error on int literal
3535+ (Jules Aguillon, review by Nicolás Ojeda Bär , Florian Angeletti,
3636+ Gabriel Scherer and Armaël Guéneau)
3737+3838+- #2307: Hint on type error on int's operators
3939+ (Jules Aguillon, with help from Armaël Guéneau,
4040+ review by Gabriel Scherer and Florian Angeletti)
30413142- #2314: Remove support for gprof profiling.
3243 (Mark Shinwell, review by Xavier Clerc and Stephen Dolan)
···3445- #3819, #8546 more explanations and tests for illegal permutation
3546 (Florian Angeletti, review by Gabriel Scherer)
36474848+- #8541: Correctly print multi-lines locations
4949+ (Louis Roché, review by Gabriel Scherer)
5050+5151+- #8579: Better error message for private constructors
5252+ of an extensible variant type
5353+ (Guillaume Bury, review by many fine eyes)
5454+3755### Compiler distribution build system:
5656+5757+- #2267: merge generation of header programs, also fixing parallel build on
5858+ Cygwin.
5959+ (David Allsopp, review by Sébastien Hinderer)
38603961- #8514: Use boot/ocamlc.opt for building, if available.
4062 (Stephen Dolan, review by Gabriel Scherer)
···5072- #1973: fix compilation of catches with multiple handlers
5173 (Vincent Laviron)
52747575+- #2190: fix pretty printing (using Pprintast) of "lazy ..." patterns and
7676+ "fun (type t) -> ..." expressions.
7777+ (Nicolás Ojeda Bär, review by Gabriel Scherer)
7878+5379- #2228, #8545: refactoring the handling of .cmi files
5480 by moving the logic from Env to a new module Persistent_env
5581 (Gabriel Scherer, review by Jérémie Dimino and Thomas Refis)
···5783- #2229: Env: remove prefix_idents cache
5884 (Thomas Refis, review by Frédéric Bour and Gabriel Scherer)
59856060-- #2237: Reorder linearisation of Trywith to avoid a call instruction
6161- (Vincent Laviron and Greta Yorsh, additional review by Mark Shinwell)
8686+- #2237, #8582: Reorder linearisation of Trywith to avoid a call instruction
8787+ (Vincent Laviron and Greta Yorsh, additional review by Mark Shinwell;
8888+ fix in #8582 by Mark Shinwell, Xavier Leroy and Anil Madhavapeddy)
62896390- #2265: Add bytecomp/opcodes.mli
6491 (Mark Shinwell, review by Nicolas Ojeda Bar)
···73100- #2280: Don't make more Clambda constants after starting Cmmgen
74101 (Mark Shinwell, review by Vincent Laviron)
75102103103+- #2281: Move some middle-end files around
104104+ (Mark Shinwell)
105105+76106- #2283: Add [is_prefix] and [find_and_chop_longest_common_prefix] to
77107 [Misc.Stdlib.List]
78108 (Mark Shinwell, review by Alain Frisch and Stephen Dolan)
···9712798128- #7878, #8542: Replaced TypedtreeIter with tast_iterator
99129 (Isaac "Izzy" Avram, review by Gabriel Scherer and Nicolás Ojeda Bär)
130130+131131+- #8598: Replace "not is_nonexpansive" by "maybe_expansive".
132132+ (Thomas Refis, review by David Allsopp, Florian Angeletti, Gabriel Radanne,
133133+ Gabriel Scherer and Xavier Leroy)
100134101135### Runtime system:
102136103137- #1725, #2279: Deprecate Obj.set_tag and Obj.truncate
104138 (Stephen Dolan, review by Gabriel Scherer, Damien Doligez and Xavier Leroy)
105139140140+- #2075, #7729: rename _T macro used to support Unicode in the (Windows) runtime
141141+ in order to avoid compiler warning
142142+ (Nicolás Ojeda Bär, review by Gabriel Scherer and David Allsopp)
143143+106144* #2240: Constify "identifier" in struct custom_operations
107145 (Cedric Cellier, review by Xavier Leroy)
108146···118156 in printf %F
119157 (Pierre Roux, review by Gabriel Scherer)
120158159159+- #6148, #8596: optimize some buffer operations
160160+ (Damien Doligez, reports by John Whitington and Alain Frisch,
161161+ review by Jeremy Yallop and Gabriel Scherer)
162162+121163### Other libraries:
122164123165- #7903, #2306: Make Thread.delay interruptible by signals again
···136178 (Jérémie Dimino, review by Nicolas Ojeda Bar, Xavier Leroy and
137179 Sébastien Hinderer)
138180139139-### Compiler user-interface and warnings:
181181+### Manual and documentation:
140182141141-- #2301: Hint on type error on int literal
142142- (Jules Aguillon, review by Nicolás Ojeda Bär , Florian Angeletti,
143143- Gabriel Scherer and Armaël Guéneau)
144144-145145-- #2307: Hint on type error on int's operators
146146- (Jules Aguillon, with help from Armaël Guéneau,
147147- review by Gabriel Scherer and Florian Angeletti)
148148-149149-### Manual and documentation:
183183+- #7584, #8538: Document .cmt* files in the "overview" of ocaml{c,opt}
184184+ (Oxana Kostikova, rewiew by Florian Angeletti)
150185151186- #8515: manual, precise constraints on reexported types
152187 (Florian Angeletti, review by Gabriel Scherer)
···158193- #7937, #2287: fix uncaught Unify exception when looking for type
159194 declaration
160195 (Florian Angeletti, review by Jacques Garrigue)
196196+197197+- GPR#2296: Fix parsing of hexadecimal floats with underscores in the exponent.
198198+ (Hugo Heuzard and Xavier Leroy, review by Gabriel Scherer)
161199162200OCaml 4.08.0
163201------------
···548586549587### Runtime system:
550588551551-- #7198, #7750, #1738: add a function (caml_custom_alloc_mem)
589589+- #7198, #7750, #1738: add a function (caml_alloc_custom_mem)
552590 and three GC parameters to give the user better control of the
553591 out-of-heap memory retained by custom values; use the function to
554592 allocate bigarrays and I/O channels.
···578616 no-naked-pointers
579617 (Sam Goldman, review by Gabriel Scherer, David Allsopp, Stephen Dolan)
580618619619+- #7829, #8585: Fix pointer comparisons in freelist.c (for 32-bit platforms)
620620+ (David Allsopp and Damien Doligez)
621621+622622+- #8567, #8569: on ARM64, use 32-bit loads to access caml_backtrace_active
623623+ (Xavier Leroy, review by Mark Shinwell and Greta Yorsh)
624624+625625+- #8568: Fix a memory leak in mmapped bigarrays
626626+ (Damien Doligez, review by Xavier Leroy and Jérémie Dimino)
627627+581628### Tools
582629583630- #2182: Split Emacs caml-mode as an independent project.
···613660- #2189: change ocamldep Makefile-output to print each dependency
614661 on a new line, for more readable diffs of versioned dependencies.
615662 (Gabriel Scherer, review by Nicolás Ojeda Bär)
663663+664664+- #2221: ocamldep will now correctly allow a .ml file in an include directory
665665+ that appears first in the search order to shadow a .mli appearing in a later
666666+ include directory.
667667+ (Nicolás Ojeda Bär, review by Florian Angeletti)
616668617669- #2223: ocamltest: fix the "bsd" and "not-bsd" built-in actions to
618670 recognize all BSD variants
···753805754806* #8533: Remove some unused configure tests
755807 (Stephen Dolan, review by David Allsopp and Sébastien Hinderer)
808808+809809+- GPR#2207,#8604: Add opam files to allow pinning
810810+ (Leo White, Greta Yorsh, review by Gabriel Radanne)
756811757812### Internal/compiler-libs changes:
758813···10161071- #7929, #2261: Subst.signature: call cleanup_types exactly once
10171072 (Thomas Refis, review by Gabriel Scherer and Jacques Garrigue,
10181073 report by Daniel Bünzli and Jon Ludlam)
10741074+10751075+- #8550, #8552: Soundness issue with class generalization
10761076+ (Jacques Garrigue, review by Leo White and Thomas Refis,
10771077+ report by Jeremy Yallop)
1019107810201079OCaml 4.07.1 (4 October 2018)
10211080-----------------------------
+8
HACKING.adoc
···4343----
4444opam compiler-conf install
4545----
4646++
4747+With opam 2, create a local opam switch with the compiler installed from
4848+the current source directory:
4949++
5050+----
5151+opam switch create . --empty
5252+opam install .
5353+----
465447556. You did it, Well done! Consult link:CONTRIBUTING.md[] to send your contribution upstream.
4856
···231231FLAT_FLOAT_ARRAY=@flat_float_array@
232232AWK=@AWK@
233233234234+235235+### Native command to build ocamlrun.exe
236236+237237+ifeq "$(TOOLCHAIN)" "msvc"
238238+ MERGEMANIFESTEXE=test ! -f $(1).manifest \
239239+ || mt -nologo -outputresource:$(1) -manifest $(1).manifest \
240240+ && rm -f $(1).manifest
241241+ MKEXE_BOOT=$(CC) $(OC_CFLAGS) $(OUTPUTEXE)$(1) $(2) \
242242+ /link /subsystem:console $(OC_LDFLAGS) && ($(MERGEMANIFESTEXE))
243243+else
244244+ MKEXE_BOOT=$(CC) $(OC_CFLAGS) $(OC_LDFLAGS) $(OUTPUTEXE)$(1) $(2)
245245+endif # ifeq "$(TOOLCHAIN)" "msvc"
246246+234247# The following variables were defined only in the config/Makefile.* files.
235248# They were not defined by the configure script used on Unix systems,
236249# so we also make sure to provide them only under Windows
···253266 # (see ocamlmklibconfig.ml in tools/Makefile)
254267 FLEXLINK_FLAGS=@flexlink_flags@
255268 FLEXLINK=$(FLEXLINK_CMD) $(FLEXLINK_FLAGS)
256256-257257- ### Native command to build ocamlrun.exe
258258-259259- ifeq "$(TOOLCHAIN)" "mingw"
260260- MKEXE_BOOT=$(CC) $(OC_CFLAGS) $(OC_LDFLAGS) $(OUTPUTEXE)$(1) $(2)
261261- endif # ifeq "$(TOOLCHAIN)" "mingw"
262262-263263- ifeq "$(TOOLCHAIN)" "msvc"
264264- MERGEMANIFESTEXE=test ! -f $(1).manifest \
265265- || mt -nologo -outputresource:$(1) -manifest $(1).manifest \
266266- && rm -f $(1).manifest
267267- MKEXE_BOOT=$(CC) $(OC_CFLAGS) $(OUTPUTEXE)$(1) $(2) \
268268- /link /subsystem:console $(OC_LDFLAGS) && ($(MERGEMANIFESTEXE))
269269- endif # ifeq "$(TOOLCHAIN)" "msvc"
270269endif # ifeq "$(UNIX_OR_WIN32)" "win32"
+21-30
README.adoc
···11|=====
22-| Branch `trunk` | Branch `4.07` | Branch `4.06` | Branch `4.05` | Branch `4.04`
22+| Branch `trunk` | Branch `4.08` | Branch `4.07` | Branch `4.06` | Branch `4.05`
3344| image:https://travis-ci.org/ocaml/ocaml.svg?branch=trunk["TravisCI Build Status (trunk branch)",
55 link="https://travis-ci.org/ocaml/ocaml"]
66 image:https://ci.appveyor.com/api/projects/status/github/ocaml/ocaml?branch=trunk&svg=true["AppVeyor Build Status (trunk branch)",
77+ link="https://ci.appveyor.com/project/avsm/ocaml"]
88+| image:https://travis-ci.org/ocaml/ocaml.svg?branch=4.08["TravisCI Build Status (4.08 branch)",
99+ link="https://travis-ci.org/ocaml/ocaml"]
1010+ image:https://ci.appveyor.com/api/projects/status/github/ocaml/ocaml?branch=4.08&svg=true["AppVeyor Build Status (4.08 branch)",
711 link="https://ci.appveyor.com/project/avsm/ocaml"]
812| image:https://travis-ci.org/ocaml/ocaml.svg?branch=4.07["TravisCI Build Status (4.07 branch)",
913 link="https://travis-ci.org/ocaml/ocaml"]
···1721 link="https://travis-ci.org/ocaml/ocaml"]
1822 image:https://ci.appveyor.com/api/projects/status/github/ocaml/ocaml?branch=4.05&svg=true["AppVeyor Build Status (4.05 branch)",
1923 link="https://ci.appveyor.com/project/avsm/ocaml"]
2020-| image:https://travis-ci.org/ocaml/ocaml.svg?branch=4.04["TravisCI Build Status (4.04 branch)",
2121- link="https://travis-ci.org/ocaml/ocaml"]
2222- image:https://ci.appveyor.com/api/projects/status/github/ocaml/ocaml?branch=4.04&svg=true["AppVeyor Build Status (4.04 branch)",
2323- link="https://ci.appveyor.com/project/avsm/ocaml"]
2424-2524|=====
26252726= README =
···4645moderate memory requirements of the bytecode compiler. The native-code
4746compiler currently runs on the following platforms:
48474949-Tier 1 (actively used and maintained by the core OCaml team):
4848+|====
4949+| | Tier 1 (actively maintained) | Tier 2 (maintained when possible)
50505151-AMD64 (Opteron):: Linux, OS X, MS Windows
5252-IA32 (Pentium):: Linux, FreeBSD, MS Windows
5353-PowerPC:: Linux, OS X
5454-ARM:: Linux
5555-5656-Tier 2 (maintained when possible, with help from users):
5757-5858-AMD64:: FreeBSD, OpenBSD, NetBSD
5959-IA32 (Pentium):: NetBSD, OpenBSD, Solaris 9
6060-PowerPC:: NetBSD
6161-ARM:: NetBSD
5151+| x86 64 bits | Linux, macOS, Windows, FreeBSD | NetBSD, OpenBSD
5252+| x86 32 bits | Linux, Windows | FreeBSD, NetBSD, OpenBSD
5353+| ARM 64 bits | Linux | FreeBSD
5454+| ARM 32 bits | Linux | FreeBSD, NetBSD, OpenBSD
5555+| Power 64 bits | Linux |
5656+| Power 32 bits | | Linux
5757+| IBM Z (s390x) | Linux |
5858+|====
62596360Other operating systems for the processors above have not been tested, but
6461the compiler may work under other operating systems with little work.
65626666-Before the introduction of objects, OCaml was known as Caml Special Light.
6767-OCaml is almost upwards compatible with Caml Special Light, except for a few
6868-additional reserved keywords that have forced some renaming of standard
6969-library functions.
70637164== Copyright
72657366All files marked "Copyright INRIA" in this distribution are copyright 1996,
74671997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
7575-2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016 Institut National de
7676-Recherche en Informatique et en Automatique (INRIA) and distributed under
7777-the conditions stated in file LICENSE.
6868+2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019
6969+Institut National de Recherche en Informatique et en Automatique (INRIA)
7070+and distributed under the conditions stated in file LICENSE.
78717972== Installation
8073···84778578== Documentation
86798787-The OCaml manual is distributed in HTML, PDF, Postscript, DVI, and Emacs
8080+The OCaml manual is distributed in HTML, PDF, and Emacs
8881Info files. It is available at
89829083http://caml.inria.fr/pub/docs/manual-ocaml/
···121114122115== Bug Reports and User Feedback
123116124124-Please report bugs using the Web interface to the bug-tracking system at
125125-http://caml.inria.fr/bin/caml-bugs
117117+Please report bugs using the issue tracker at
118118+https://github.com/ocaml/ocaml/issues
126119127120To be effective, bug reports should include a complete program (preferably
128121small) that exhibits the unexpected behavior, and the configuration you are
129122using (machine type, etc).
130130-131131-You can also contact the implementors directly at mailto:caml@inria.fr[].
132123133124For information on contributing to OCaml, see link:HACKING.adoc[] and
134125link:CONTRIBUTING.md[].
+1
asmcomp/amd64/emit.mlp
···3333 emit.mlp files for certain other targets; the reference here ensures
3434 that when releases are being prepared the .depend files are correct
3535 for all targets. *)
3636+[@@@ocaml.warning "-66"]
3637open! Branch_relaxation
37383839let _label s = D.label ~typ:QWORD s
+5-2
asmcomp/arm/emit.mlp
···354354 end;
355355 if !offset_literals <> [] then begin
356356 (* Additions using the pc register read a value 4 or 8 bytes greater than
357357- the instruction's address, depending on the thumb setting *)
358358- let offset = if !thumb then 4 else 8 in
357357+ the instruction's address, depending on the Thumb setting. However in
358358+ Thumb mode we must follow interworking conventions and ensure that the
359359+ bottom bit of the pc value is set when reloaded from the trap frame.
360360+ Hence "3" not "4". *)
361361+ let offset = if !thumb then 3 else 8 in
359362 ` .align 2\n`;
360363 List.iter
361364 (fun { lbl; dst; src; } ->
···3636module V = Backend_var
3737module VP = Backend_var.With_provenance
38383939+(* The current backend *)
4040+3941let no_phantom_lets () =
4042 Misc.fatal_error "Closure does not support phantom let generation"
4143···276278(* The [fpc] parameter is true if constant propagation of
277279 floating-point computations is allowed *)
278280279279-let simplif_arith_prim_pure fpc p (args, approxs) dbg =
281281+let simplif_arith_prim_pure ~backend fpc p (args, approxs) dbg =
282282+ let module B = (val backend : Backend_intf.S) in
280283 let open Clambda_primitives in
281284 let default = (Uprim(p, args, dbg), Value_unknown) in
282285 match approxs with
···308311 | Pandint -> make_const_int (n1 land n2)
309312 | Porint -> make_const_int (n1 lor n2)
310313 | Pxorint -> make_const_int (n1 lxor n2)
311311- | Plslint when 0 <= n2 && n2 < 8 * Arch.size_int ->
314314+ | Plslint when 0 <= n2 && n2 < 8 * B.size_int ->
312315 make_const_int (n1 lsl n2)
313313- | Plsrint when 0 <= n2 && n2 < 8 * Arch.size_int ->
316316+ | Plsrint when 0 <= n2 && n2 < 8 * B.size_int ->
314317 make_const_int (n1 lsr n2)
315315- | Pasrint when 0 <= n2 && n2 < 8 * Arch.size_int ->
318318+ | Pasrint when 0 <= n2 && n2 < 8 * B.size_int ->
316319 make_const_int (n1 asr n2)
317320 | Pintcomp c -> make_integer_comparison c n1 n2
318321 | _ -> default
···366369 | [Value_const(Uconst_ref(_, Some (Uconst_nativeint n1)));
367370 Value_const(Uconst_int n2)] ->
368371 begin match p with
369369- | Plslbint Pnativeint when 0 <= n2 && n2 < 8 * Arch.size_int ->
372372+ | Plslbint Pnativeint when 0 <= n2 && n2 < 8 * B.size_int ->
370373 make_const_natint (Nativeint.shift_left n1 n2)
371371- | Plsrbint Pnativeint when 0 <= n2 && n2 < 8 * Arch.size_int ->
374374+ | Plsrbint Pnativeint when 0 <= n2 && n2 < 8 * B.size_int ->
372375 make_const_natint (Nativeint.shift_right_logical n1 n2)
373373- | Pasrbint Pnativeint when 0 <= n2 && n2 < 8 * Arch.size_int ->
376376+ | Pasrbint Pnativeint when 0 <= n2 && n2 < 8 * B.size_int ->
374377 make_const_natint (Nativeint.shift_right n1 n2)
375378 | _ -> default
376379 end
···462465 Value_const (List.nth l n)
463466 | _ -> Value_unknown
464467465465-let simplif_prim_pure fpc p (args, approxs) dbg =
468468+let simplif_prim_pure ~backend fpc p (args, approxs) dbg =
466469 let open Clambda_primitives in
467470 match p, args, approxs with
468471 (* Block construction *)
···502505 end
503506 (* Catch-all *)
504507 | _ ->
505505- simplif_arith_prim_pure fpc p (args, approxs) dbg
508508+ simplif_arith_prim_pure ~backend fpc p (args, approxs) dbg
506509507507-let simplif_prim fpc p (args, approxs as args_approxs) dbg =
510510+let simplif_prim ~backend fpc p (args, approxs as args_approxs) dbg =
508511 if List.for_all is_pure args
509509- then simplif_prim_pure fpc p args_approxs dbg
512512+ then simplif_prim_pure ~backend fpc p args_approxs dbg
510513 else
511514 (* XXX : always return the same approxs as simplif_prim_pure? *)
512515 let approx =
···547550 else
548551 dbg
549552550550-let rec substitute loc fpc sb rn ulam =
553553+let rec substitute loc ((backend, fpc) as st) sb rn ulam =
551554 match ulam with
552555 Uvar v ->
553556 begin try V.Map.find v sb with Not_found -> ulam end
554557 | Uconst _ -> ulam
555558 | Udirect_apply(lbl, args, dbg) ->
556559 let dbg = subst_debuginfo loc dbg in
557557- Udirect_apply(lbl, List.map (substitute loc fpc sb rn) args, dbg)
560560+ Udirect_apply(lbl, List.map (substitute loc st sb rn) args, dbg)
558561 | Ugeneric_apply(fn, args, dbg) ->
559562 let dbg = subst_debuginfo loc dbg in
560560- Ugeneric_apply(substitute loc fpc sb rn fn,
561561- List.map (substitute loc fpc sb rn) args, dbg)
563563+ Ugeneric_apply(substitute loc st sb rn fn,
564564+ List.map (substitute loc st sb rn) args, dbg)
562565 | Uclosure(defs, env) ->
563566 (* Question: should we rename function labels as well? Otherwise,
564567 there is a risk that function labels are not globally unique.
···568571 - When we substitute offsets for idents bound by let rec
569572 in [close], case [Lletrec], we discard the original
570573 let rec body and use only the substituted term. *)
571571- Uclosure(defs, List.map (substitute loc fpc sb rn) env)
572572- | Uoffset(u, ofs) -> Uoffset(substitute loc fpc sb rn u, ofs)
574574+ Uclosure(defs, List.map (substitute loc st sb rn) env)
575575+ | Uoffset(u, ofs) -> Uoffset(substitute loc st sb rn u, ofs)
573576 | Ulet(str, kind, id, u1, u2) ->
574577 let id' = VP.rename id in
575575- Ulet(str, kind, id', substitute loc fpc sb rn u1,
576576- substitute loc fpc
578578+ Ulet(str, kind, id', substitute loc st sb rn u1,
579579+ substitute loc st
577580 (V.Map.add (VP.var id) (Uvar (VP.var id')) sb) rn u2)
578581 | Uphantom_let _ -> no_phantom_lets ()
579582 | Uletrec(bindings, body) ->
···588591 in
589592 Uletrec(
590593 List.map
591591- (fun (_id, id', rhs) -> (id', substitute loc fpc sb' rn rhs))
594594+ (fun (_id, id', rhs) -> (id', substitute loc st sb' rn rhs))
592595 bindings1,
593593- substitute loc fpc sb' rn body)
596596+ substitute loc st sb' rn body)
594597 | Uprim(p, args, dbg) ->
595595- let sargs = List.map (substitute loc fpc sb rn) args in
598598+ let sargs = List.map (substitute loc st sb rn) args in
596599 let dbg = subst_debuginfo loc dbg in
597600 let (res, _) =
598598- simplif_prim fpc p (sargs, List.map approx_ulam sargs) dbg in
601601+ simplif_prim ~backend fpc p (sargs, List.map approx_ulam sargs) dbg in
599602 res
600603 | Uswitch(arg, sw, dbg) ->
601601- let sarg = substitute loc fpc sb rn arg in
604604+ let sarg = substitute loc st sb rn arg in
602605 let action =
603606 (* Unfortunately, we cannot easily deal with the
604607 case of a constructed block (makeblock) bound to a local
···614617 | _ -> None
615618 in
616619 begin match action with
617617- | Some u -> substitute loc fpc sb rn u
620620+ | Some u -> substitute loc st sb rn u
618621 | None ->
619622 Uswitch(sarg,
620623 { sw with
621624 us_actions_consts =
622622- Array.map (substitute loc fpc sb rn) sw.us_actions_consts;
625625+ Array.map (substitute loc st sb rn) sw.us_actions_consts;
623626 us_actions_blocks =
624624- Array.map (substitute loc fpc sb rn) sw.us_actions_blocks;
627627+ Array.map (substitute loc st sb rn) sw.us_actions_blocks;
625628 },
626629 dbg)
627630 end
628631 | Ustringswitch(arg,sw,d) ->
629632 Ustringswitch
630630- (substitute loc fpc sb rn arg,
631631- List.map (fun (s,act) -> s,substitute loc fpc sb rn act) sw,
632632- Misc.may_map (substitute loc fpc sb rn) d)
633633+ (substitute loc st sb rn arg,
634634+ List.map (fun (s,act) -> s,substitute loc st sb rn act) sw,
635635+ Misc.may_map (substitute loc st sb rn) d)
633636 | Ustaticfail (nfail, args) ->
634637 let nfail =
635638 match rn with
···640643 fatal_errorf "Closure.split_list: invalid nfail (%d)" nfail
641644 end
642645 | None -> nfail in
643643- Ustaticfail (nfail, List.map (substitute loc fpc sb rn) args)
646646+ Ustaticfail (nfail, List.map (substitute loc st sb rn) args)
644647 | Ucatch(nfail, ids, u1, u2) ->
645648 let nfail, rn =
646649 match rn with
···656659 )
657660 ids ids' sb
658661 in
659659- Ucatch(nfail, ids', substitute loc fpc sb rn u1,
660660- substitute loc fpc sb' rn u2)
662662+ Ucatch(nfail, ids', substitute loc st sb rn u1,
663663+ substitute loc st sb' rn u2)
661664 | Utrywith(u1, id, u2) ->
662665 let id' = VP.rename id in
663663- Utrywith(substitute loc fpc sb rn u1, id',
664664- substitute loc fpc
666666+ Utrywith(substitute loc st sb rn u1, id',
667667+ substitute loc st
665668 (V.Map.add (VP.var id) (Uvar (VP.var id')) sb) rn u2)
666669 | Uifthenelse(u1, u2, u3) ->
667667- begin match substitute loc fpc sb rn u1 with
670670+ begin match substitute loc st sb rn u1 with
668671 Uconst (Uconst_ptr n) ->
669672 if n <> 0 then
670670- substitute loc fpc sb rn u2
673673+ substitute loc st sb rn u2
671674 else
672672- substitute loc fpc sb rn u3
675675+ substitute loc st sb rn u3
673676 | Uprim(P.Pmakeblock _, _, _) ->
674674- substitute loc fpc sb rn u2
677677+ substitute loc st sb rn u2
675678 | su1 ->
676676- Uifthenelse(su1, substitute loc fpc sb rn u2,
677677- substitute loc fpc sb rn u3)
679679+ Uifthenelse(su1, substitute loc st sb rn u2,
680680+ substitute loc st sb rn u3)
678681 end
679682 | Usequence(u1, u2) ->
680680- Usequence(substitute loc fpc sb rn u1, substitute loc fpc sb rn u2)
683683+ Usequence(substitute loc st sb rn u1, substitute loc st sb rn u2)
681684 | Uwhile(u1, u2) ->
682682- Uwhile(substitute loc fpc sb rn u1, substitute loc fpc sb rn u2)
685685+ Uwhile(substitute loc st sb rn u1, substitute loc st sb rn u2)
683686 | Ufor(id, u1, u2, dir, u3) ->
684687 let id' = VP.rename id in
685685- Ufor(id', substitute loc fpc sb rn u1, substitute loc fpc sb rn u2, dir,
686686- substitute loc fpc
688688+ Ufor(id', substitute loc st sb rn u1, substitute loc st sb rn u2, dir,
689689+ substitute loc st
687690 (V.Map.add (VP.var id) (Uvar (VP.var id')) sb) rn u3)
688691 | Uassign(id, u) ->
689692 let id' =
···691694 match V.Map.find id sb with Uvar i -> i | _ -> assert false
692695 with Not_found ->
693696 id in
694694- Uassign(id', substitute loc fpc sb rn u)
697697+ Uassign(id', substitute loc st sb rn u)
695698 | Usend(k, u1, u2, ul, dbg) ->
696699 let dbg = subst_debuginfo loc dbg in
697697- Usend(k, substitute loc fpc sb rn u1, substitute loc fpc sb rn u2,
698698- List.map (substitute loc fpc sb rn) ul, dbg)
700700+ Usend(k, substitute loc st sb rn u1, substitute loc st sb rn u2,
701701+ List.map (substitute loc st sb rn) ul, dbg)
699702 | Uunreachable ->
700703 Uunreachable
701704···751754752755(* Generate a direct application *)
753756754754-let direct_apply fundesc ufunct uargs ~loc ~attribute =
757757+let direct_apply ~backend fundesc ufunct uargs ~loc ~attribute =
755758 let app_args =
756759 if fundesc.fun_closed then uargs else uargs @ [ufunct] in
757760 let app =
···762765 "Function information unavailable";
763766 Udirect_apply(fundesc.fun_label, app_args, dbg)
764767 | Some(params, body), _ ->
765765- bind_params loc fundesc.fun_float_const_prop params app_args body
768768+ bind_params loc (backend, fundesc.fun_float_const_prop) params app_args
769769+ body
766770 in
767771 (* If ufunct can contain side-effects or function definitions,
768772 we must make sure that it is evaluated exactly once.
···823827824828exception NotClosed
825829826826-let close_approx_var fenv cenv id =
830830+type env = {
831831+ backend : (module Backend_intf.S);
832832+ cenv : ulambda V.Map.t;
833833+ fenv : value_approximation V.Map.t;
834834+}
835835+836836+let close_approx_var { fenv; cenv } id =
827837 let approx = try V.Map.find id fenv with Not_found -> Value_unknown in
828838 match approx with
829839 Value_const c -> make_const c
···831841 let subst = try V.Map.find id cenv with Not_found -> Uvar id in
832842 (subst, approx)
833843834834-let close_var fenv cenv id =
835835- let (ulam, _app) = close_approx_var fenv cenv id in ulam
844844+let close_var env id =
845845+ let (ulam, _app) = close_approx_var env id in ulam
836846837837-let rec close fenv cenv = function
838838- Lvar id ->
839839- close_approx_var fenv cenv id
847847+let rec close ({ backend; fenv; cenv } as env) lam =
848848+ let module B = (val backend : Backend_intf.S) in
849849+ match lam with
850850+ | Lvar id ->
851851+ close_approx_var env id
840852 | Lconst cst ->
841853 let str ?(shared = true) cst =
842854 let name =
···870882 in
871883 make_const (transl cst)
872884 | Lfunction _ as funct ->
873873- close_one_function fenv cenv (Ident.create_local "fun") funct
885885+ close_one_function env (Ident.create_local "fun") funct
874886875887 (* We convert [f a] to [let a' = a in let f' = f in fun b c -> f' a' b c]
876888 when fun_arity > nargs *)
877889 | Lapply{ap_func = funct; ap_args = args; ap_loc = loc;
878890 ap_inlined = attribute} ->
879891 let nargs = List.length args in
880880- begin match (close fenv cenv funct, close_list fenv cenv args) with
892892+ begin match (close env funct, close_list env args) with
881893 ((ufunct, Value_closure(fundesc, approx_res)),
882894 [Uprim(P.Pmakeblock _, uargs, _)])
883895 when List.length uargs = - fundesc.fun_arity ->
884896 let app =
885885- direct_apply ~loc ~attribute fundesc ufunct uargs in
897897+ direct_apply ~backend ~loc ~attribute fundesc ufunct uargs in
886898 (app, strengthen_approx app approx_res)
887899 | ((ufunct, Value_closure(fundesc, approx_res)), uargs)
888900 when nargs = fundesc.fun_arity ->
889901 let app =
890890- direct_apply ~loc ~attribute fundesc ufunct uargs in
902902+ direct_apply ~backend ~loc ~attribute fundesc ufunct uargs in
891903 (app, strengthen_approx app approx_res)
892904893905 | ((ufunct, (Value_closure(fundesc, _) as fapprox)), uargs)
···910922 in
911923 let funct_var = V.create_local "funct" in
912924 let fenv = V.Map.add funct_var fapprox fenv in
913913- let (new_fun, approx) = close fenv cenv
925925+ let (new_fun, approx) = close { backend; fenv; cenv }
914926 (Lfunction{
915927 kind = Curried;
916928 return = Pgenval;
···940952 let dbg = Debuginfo.from_location loc in
941953 warning_if_forced_inline ~loc ~attribute "Over-application";
942954 let body =
943943- Ugeneric_apply(direct_apply ~loc ~attribute
955955+ Ugeneric_apply(direct_apply ~backend ~loc ~attribute
944956 fundesc ufunct first_args,
945957 rem_args, dbg)
946958 in
···957969 (Ugeneric_apply(ufunct, uargs, dbg), Value_unknown)
958970 end
959971 | Lsend(kind, met, obj, args, loc) ->
960960- let (umet, _) = close fenv cenv met in
961961- let (uobj, _) = close fenv cenv obj in
972972+ let (umet, _) = close env met in
973973+ let (uobj, _) = close env obj in
962974 let dbg = Debuginfo.from_location loc in
963963- (Usend(kind, umet, uobj, close_list fenv cenv args, dbg),
975975+ (Usend(kind, umet, uobj, close_list env args, dbg),
964976 Value_unknown)
965977 | Llet(str, kind, id, lam, body) ->
966966- let (ulam, alam) = close_named fenv cenv id lam in
978978+ let (ulam, alam) = close_named env id lam in
967979 begin match (str, alam) with
968980 (Variable, _) ->
969969- let (ubody, abody) = close fenv cenv body in
981981+ let (ubody, abody) = close env body in
970982 (Ulet(Mutable, kind, VP.create id, ulam, ubody), abody)
971983 | (_, Value_const _)
972984 when str = Alias || is_pure ulam ->
973973- close (V.Map.add id alam fenv) cenv body
985985+ close { backend; fenv = (V.Map.add id alam fenv); cenv } body
974986 | (_, _) ->
975975- let (ubody, abody) = close (V.Map.add id alam fenv) cenv body in
987987+ let (ubody, abody) =
988988+ close { backend; fenv = (V.Map.add id alam fenv); cenv } body
989989+ in
976990 (Ulet(Immutable, kind, VP.create id, ulam, ubody), abody)
977991 end
978992 | Lletrec(defs, body) ->
···981995 defs
982996 then begin
983997 (* Simple case: only function definitions *)
984984- let (clos, infos) = close_functions fenv cenv defs in
998998+ let (clos, infos) = close_functions env defs in
985999 let clos_ident = V.create_local "clos" in
9861000 let fenv_body =
9871001 List.fold_right
9881002 (fun (id, _pos, approx) fenv -> V.Map.add id approx fenv)
9891003 infos fenv in
990990- let (ubody, approx) = close fenv_body cenv body in
10041004+ let (ubody, approx) = close { backend; fenv = fenv_body; cenv } body in
9911005 let sb =
9921006 List.fold_right
9931007 (fun (id, pos, _approx) sb ->
9941008 V.Map.add id (Uoffset(Uvar clos_ident, pos)) sb)
9951009 infos V.Map.empty in
9961010 (Ulet(Immutable, Pgenval, VP.create clos_ident, clos,
997997- substitute Location.none !Clflags.float_const_prop sb None ubody),
10111011+ substitute Location.none (backend, !Clflags.float_const_prop) sb
10121012+ None ubody),
9981013 approx)
9991014 end else begin
10001015 (* General case: recursive definition of values *)
···10021017 [] -> ([], fenv)
10031018 | (id, lam) :: rem ->
10041019 let (udefs, fenv_body) = clos_defs rem in
10051005- let (ulam, approx) = close_named fenv cenv id lam in
10201020+ let (ulam, approx) = close_named env id lam in
10061021 ((VP.create id, ulam) :: udefs, V.Map.add id approx fenv_body) in
10071022 let (udefs, fenv_body) = clos_defs defs in
10081008- let (ubody, approx) = close fenv_body cenv body in
10231023+ let (ubody, approx) = close { backend; fenv = fenv_body; cenv } body in
10091024 (Uletrec(udefs, ubody), approx)
10101025 end
10111026 (* Compile-time constants *)
10121027 | Lprim(Pctconst c, [arg], _loc) ->
10131028 let cst, approx =
10141029 match c with
10151015- | Big_endian -> make_const_bool Arch.big_endian
10161016- | Word_size -> make_const_int (8*Arch.size_int)
10171017- | Int_size -> make_const_int (8*Arch.size_int - 1)
10181018- | Max_wosize -> make_const_int ((1 lsl ((8*Arch.size_int) - 10)) - 1 )
10301030+ | Big_endian -> make_const_bool B.big_endian
10311031+ | Word_size -> make_const_int (8*B.size_int)
10321032+ | Int_size -> make_const_int (8*B.size_int - 1)
10331033+ | Max_wosize -> make_const_int ((1 lsl ((8*B.size_int) - 10)) - 1 )
10191034 | Ostype_unix -> make_const_bool (Sys.os_type = "Unix")
10201035 | Ostype_win32 -> make_const_bool (Sys.os_type = "Win32")
10211036 | Ostype_cygwin -> make_const_bool (Sys.os_type = "Cygwin")
10221037 | Backend_type ->
10231038 make_const_ptr 0 (* tag 0 is the same as Native here *)
10241039 in
10251025- let arg, _approx = close fenv cenv arg in
10401040+ let arg, _approx = close env arg in
10261041 let id = Ident.create_local "dummy" in
10271042 Ulet(Immutable, Pgenval, VP.create id, arg, cst), approx
10281043 | Lprim(Pignore, [arg], _loc) ->
10291044 let expr, approx = make_const_ptr 0 in
10301030- Usequence(fst (close fenv cenv arg), expr), approx
10451045+ Usequence(fst (close env arg), expr), approx
10311046 | Lprim((Pidentity | Pbytes_to_string | Pbytes_of_string), [arg], _loc) ->
10321032- close fenv cenv arg
10471047+ close env arg
10331048 | Lprim(Pdirapply,[funct;arg], loc)
10341049 | Lprim(Prevapply,[arg;funct], loc) ->
10351035- close fenv cenv (Lapply{ap_should_be_tailcall=false;
10501050+ close env (Lapply{ap_should_be_tailcall=false;
10361051 ap_loc=loc;
10371052 ap_func=funct;
10381053 ap_args=[arg];
···10431058 check_constant_result (getglobal dbg id)
10441059 (Compilenv.global_approx id)
10451060 | Lprim(Pfield (n, ptr, mut), [lam], loc) ->
10461046- let (ulam, approx) = close fenv cenv lam in
10611061+ let (ulam, approx) = close env lam in
10471062 let dbg = Debuginfo.from_location loc in
10481063 check_constant_result (Uprim(P.Pfield (n, ptr, mut), [ulam], dbg))
10491064 (field_approx n approx)
10501065 | Lprim(Psetfield(n, is_ptr, init), [Lprim(Pgetglobal id, [], _); lam], loc)->
10511051- let (ulam, approx) = close fenv cenv lam in
10661066+ let (ulam, approx) = close env lam in
10521067 if approx <> Value_unknown then
10531068 (!global_approx).(n) <- approx;
10541069 let dbg = Debuginfo.from_location loc in
10551070 (Uprim(P.Psetfield(n, is_ptr, init), [getglobal dbg id; ulam], dbg),
10561071 Value_unknown)
10571072 | Lprim(Praise k, [arg], loc) ->
10581058- let (ulam, _approx) = close fenv cenv arg in
10731073+ let (ulam, _approx) = close env arg in
10591074 let dbg = Debuginfo.from_location loc in
10601075 (Uprim(P.Praise k, [ulam], dbg),
10611076 Value_unknown)
10621077 | Lprim(Pperform, [arg], loc) ->
10631063- let (arg, _approx) = close fenv cenv arg in
10781078+ let (arg, _approx) = close env arg in
10641079 let dbg = Debuginfo.from_location loc in
10651080 let alloc_cont = Uprim(P.Pmakeblock(Obj.cont_tag, Mutable, None),
10661081 [Uconst (Uconst_int 0)],
10671082 dbg) in
10681083 (Udirect_apply ("caml_perform", [arg; alloc_cont], dbg), Value_unknown)
10691084 | Lprim(Presume, args, loc) ->
10701070- let args = close_list fenv cenv args in
10851085+ let args = close_list env args in
10711086 let dbg = Debuginfo.from_location loc in
10721087 (Udirect_apply ("caml_resume", args, dbg), Value_unknown)
10731088 | Lprim(Prunstack, args, loc) ->
10741074- let args = close_list fenv cenv args in
10891089+ let args = close_list env args in
10751090 let dbg = Debuginfo.from_location loc in
10761091 (Udirect_apply ("caml_runstack", args, dbg), Value_unknown)
10771092 | Lprim(Preperform, args, loc) ->
10781078- let args = close_list fenv cenv args in
10931093+ let args = close_list env args in
10791094 let dbg = Debuginfo.from_location loc in
10801095 (Udirect_apply ("caml_reperform", args, dbg), Value_unknown)
10811096 | Lprim (Pmakearray _, [], _loc) -> make_const_ref (Uconst_block (0, []))
10821097 | Lprim(p, args, loc) ->
10831098 let p = Convert_primitives.convert p in
10841099 let dbg = Debuginfo.from_location loc in
10851085- simplif_prim !Clflags.float_const_prop
10861086- p (close_list_approx fenv cenv args) dbg
11001100+ simplif_prim ~backend !Clflags.float_const_prop
11011101+ p (close_list_approx env args) dbg
10871102 | Lswitch(arg, sw, dbg) ->
10881103 let fn fail =
10891089- let (uarg, _) = close fenv cenv arg in
11041104+ let (uarg, _) = close env arg in
10901105 let const_index, const_actions, fconst =
10911091- close_switch fenv cenv sw.sw_consts sw.sw_numconsts fail
11061106+ close_switch env sw.sw_consts sw.sw_numconsts fail
10921107 and block_index, block_actions, fblock =
10931093- close_switch fenv cenv sw.sw_blocks sw.sw_numblocks fail in
11081108+ close_switch env sw.sw_blocks sw.sw_numblocks fail in
10941109 let ulam =
10951110 Uswitch
10961111 (uarg,
···11121127 then
11131128 let i = next_raise_count () in
11141129 let ubody,_ = fn (Some (Lstaticraise (i,[])))
11151115- and uhandler,_ = close fenv cenv lamfail in
11301130+ and uhandler,_ = close env lamfail in
11161131 Ucatch (i,[],ubody,uhandler),Value_unknown
11171132 else fn fail
11181133 end
11191134 | Lstringswitch(arg,sw,d,_) ->
11201120- let uarg,_ = close fenv cenv arg in
11351135+ let uarg,_ = close env arg in
11211136 let usw =
11221137 List.map
11231138 (fun (s,act) ->
11241124- let uact,_ = close fenv cenv act in
11391139+ let uact,_ = close env act in
11251140 s,uact)
11261141 sw in
11271142 let ud =
11281143 Misc.may_map
11291144 (fun d ->
11301130- let ud,_ = close fenv cenv d in
11451145+ let ud,_ = close env d in
11311146 ud) d in
11321147 Ustringswitch (uarg,usw,ud),Value_unknown
11331148 | Lstaticraise (i, args) ->
11341134- (Ustaticfail (i, close_list fenv cenv args), Value_unknown)
11491149+ (Ustaticfail (i, close_list env args), Value_unknown)
11351150 | Lstaticcatch(body, (i, vars), handler) ->
11361136- let (ubody, _) = close fenv cenv body in
11371137- let (uhandler, _) = close fenv cenv handler in
11511151+ let (ubody, _) = close env body in
11521152+ let (uhandler, _) = close env handler in
11381153 let vars = List.map (fun (var, k) -> VP.create var, k) vars in
11391154 (Ucatch(i, vars, ubody, uhandler), Value_unknown)
11401155 | Ltrywith(body, id, handler) ->
11411141- let (ubody, _) = close fenv cenv body in
11421142- let (uhandler, _) = close fenv cenv handler in
11561156+ let (ubody, _) = close env body in
11571157+ let (uhandler, _) = close env handler in
11431158 (Utrywith(ubody, VP.create id, uhandler), Value_unknown)
11441159 | Lifthenelse(arg, ifso, ifnot) ->
11451145- begin match close fenv cenv arg with
11601160+ begin match close env arg with
11461161 (uarg, Value_const (Uconst_ptr n)) ->
11471162 sequence_constant_expr uarg
11481148- (close fenv cenv (if n = 0 then ifnot else ifso))
11631163+ (close env (if n = 0 then ifnot else ifso))
11491164 | (uarg, _ ) ->
11501150- let (uifso, _) = close fenv cenv ifso in
11511151- let (uifnot, _) = close fenv cenv ifnot in
11651165+ let (uifso, _) = close env ifso in
11661166+ let (uifnot, _) = close env ifnot in
11521167 (Uifthenelse(uarg, uifso, uifnot), Value_unknown)
11531168 end
11541169 | Lsequence(lam1, lam2) ->
11551155- let (ulam1, _) = close fenv cenv lam1 in
11561156- let (ulam2, approx) = close fenv cenv lam2 in
11701170+ let (ulam1, _) = close env lam1 in
11711171+ let (ulam2, approx) = close env lam2 in
11571172 (Usequence(ulam1, ulam2), approx)
11581173 | Lwhile(cond, body) ->
11591159- let (ucond, _) = close fenv cenv cond in
11601160- let (ubody, _) = close fenv cenv body in
11741174+ let (ucond, _) = close env cond in
11751175+ let (ubody, _) = close env body in
11611176 (Uwhile(ucond, ubody), Value_unknown)
11621177 | Lfor(id, lo, hi, dir, body) ->
11631163- let (ulo, _) = close fenv cenv lo in
11641164- let (uhi, _) = close fenv cenv hi in
11651165- let (ubody, _) = close fenv cenv body in
11781178+ let (ulo, _) = close env lo in
11791179+ let (uhi, _) = close env hi in
11801180+ let (ubody, _) = close env body in
11661181 (Ufor(VP.create id, ulo, uhi, dir, ubody), Value_unknown)
11671182 | Lassign(id, lam) ->
11681168- let (ulam, _) = close fenv cenv lam in
11831183+ let (ulam, _) = close env lam in
11691184 (Uassign(id, ulam), Value_unknown)
11701185 | Levent(lam, _) ->
11711171- close fenv cenv lam
11861186+ close env lam
11721187 | Lifused _ ->
11731188 assert false
1174118911751175-and close_list fenv cenv = function
11901190+and close_list env = function
11761191 [] -> []
11771192 | lam :: rem ->
11781178- let (ulam, _) = close fenv cenv lam in
11791179- ulam :: close_list fenv cenv rem
11931193+ let (ulam, _) = close env lam in
11941194+ ulam :: close_list env rem
1180119511811181-and close_list_approx fenv cenv = function
11961196+and close_list_approx env = function
11821197 [] -> ([], [])
11831198 | lam :: rem ->
11841184- let (ulam, approx) = close fenv cenv lam in
11851185- let (ulams, approxs) = close_list_approx fenv cenv rem in
11991199+ let (ulam, approx) = close env lam in
12001200+ let (ulams, approxs) = close_list_approx env rem in
11861201 (ulam :: ulams, approx :: approxs)
1187120211881188-and close_named fenv cenv id = function
12031203+and close_named env id = function
11891204 Lfunction _ as funct ->
11901190- close_one_function fenv cenv id funct
12051205+ close_one_function env id funct
11911206 | lam ->
11921192- close fenv cenv lam
12071207+ close env lam
1193120811941209(* Build a shared closure for a set of mutually recursive functions *)
1195121011961196-and close_functions fenv cenv fun_defs =
12111211+and close_functions { backend; fenv; cenv } fun_defs =
11971212 let fun_defs =
11981213 List.flatten
11991214 (List.map
···12641279 (fun (id, _params, _return, _body, _fundesc, _dbg) pos env ->
12651280 V.Map.add id (Uoffset(Uvar env_param, pos - env_pos)) env)
12661281 uncurried_defs clos_offsets cenv_fv in
12671267- let (ubody, approx) = close fenv_rec cenv_body body in
12821282+ let (ubody, approx) =
12831283+ close { backend; fenv = fenv_rec; cenv = cenv_body } body
12841284+ in
12681285 if !useless_env && occurs_var env_param ubody then raise NotClosed;
12691286 let fun_params =
12701287 if !useless_env
···13351352 with offsets and approximations. *)
13361353 let (clos, infos) = List.split clos_info_list in
13371354 let fv = if !useless_env then [] else fv in
13381338- (Uclosure(clos, List.map (close_var fenv cenv) fv), infos)
13551355+ (Uclosure(clos, List.map (close_var { backend; fenv; cenv }) fv), infos)
1339135613401357(* Same, for one non-recursive function *)
1341135813421342-and close_one_function fenv cenv id funct =
13431343- match close_functions fenv cenv [id, funct] with
13591359+and close_one_function env id funct =
13601360+ match close_functions env [id, funct] with
13441361 | (clos, (i, _, approx) :: _) when id = i -> (clos, approx)
13451362 | _ -> fatal_error "Closure.close_one_function"
1346136313471364(* Close a switch *)
1348136513491349-and close_switch fenv cenv cases num_keys default =
13661366+and close_switch env cases num_keys default =
13501367 let ncases = List.length cases in
13511368 let index = Array.make num_keys 0
13521369 and store = Storer.mk_store () in
···13731390 Array.map
13741391 (function
13751392 | Single lam|Shared (Lstaticraise (_,[]) as lam) ->
13761376- let ulam,_ = close fenv cenv lam in
13931393+ let ulam,_ = close env lam in
13771394 ulam
13781395 | Shared lam ->
13791379- let ulam,_ = close fenv cenv lam in
13961396+ let ulam,_ = close env lam in
13801397 let i = next_raise_count () in
13811398(*
13821399 let string_of_lambda e =
···1460147714611478(* The entry point *)
1462147914631463-let intro size lam =
14801480+let intro ~backend ~size lam =
14641481 reset ();
14651482 let id = Compilenv.make_symbol None in
14661483 global_approx := Array.init size (fun i -> Value_global_field (id, i));
14671484 Compilenv.set_global_approx(Value_tuple !global_approx);
14681468- let (ulam, _approx) = close V.Map.empty V.Map.empty lam in
14851485+ let (ulam, _approx) =
14861486+ close { backend; fenv = V.Map.empty; cenv = V.Map.empty } lam
14871487+ in
14691488 let opaque =
14701489 !Clflags.opaque
14711490 || Env.is_imported_opaque (Compilenv.current_unit_name ())
···11#!/bin/sh
22-autoconf -W all,error
22+#**************************************************************************
33+#* *
44+#* OCaml *
55+#* *
66+#* David Allsopp, MetaStack Solutions Ltd. *
77+#* *
88+#* Copyright 2019 MetaStack Solutions Ltd. *
99+#* *
1010+#* All rights reserved. This file is distributed under the terms of *
1111+#* the GNU Lesser General Public License version 2.1, with the *
1212+#* special exception on linking described in the file LICENSE. *
1313+#* *
1414+#**************************************************************************
1515+1616+version=$(autoconf --version | sed -ne 's/^autoconf .* \([0-9][^ ]*\)$/\1/p')
1717+if [ "$version" != '2.69' ] ; then
1818+ echo "autoconf 2.69 is required" >&2
1919+ exit 1
2020+else
2121+ autoconf -W all,error
2222+ # Some distros have this 2013 patch to autoconf, some don't...
2323+ sed -i -e '/^runstatedir/d' \
2424+ -e '/-runstatedir /,+8d' \
2525+ -e '/--runstatedir=DIR/d' \
2626+ -e 's/ runstatedir//' configure
2727+fi
···8787 end
88888989(* Find file 'name' (capitalized) in search path *)
9090-let find_file name =
9191- let uname = String.uncapitalize_ascii name in
9090+let find_module_in_load_path name =
9191+ let names = List.map (fun ext -> name ^ ext) (!mli_synonyms @ !ml_synonyms) in
9292+ let unames =
9393+ let uname = String.uncapitalize_ascii name in
9494+ List.map (fun ext -> uname ^ ext) (!mli_synonyms @ !ml_synonyms)
9595+ in
9296 let rec find_in_array a pos =
9397 if pos >= Array.length a then None else begin
9498 let s = a.(pos) in
9595- if s = name || s = uname then Some s else find_in_array a (pos + 1)
9999+ if List.mem s names || List.mem s unames then
100100+ Some s
101101+ else
102102+ find_in_array a (pos + 1)
96103 end in
97104 let rec find_in_path = function
98105 [] -> raise Not_found
···103110 | None -> find_in_path rem in
104111 find_in_path !load_path
105112106106-let rec find_file_in_list = function
107107- [] -> raise Not_found
108108-| x :: rem -> try find_file x with Not_found -> find_file_in_list rem
109109-110110-111113let find_dependency target_kind modname (byt_deps, opt_deps) =
112114 try
113113- let candidates = List.map ((^) modname) !mli_synonyms in
114114- let filename = find_file_in_list candidates in
115115+ let filename = find_module_in_load_path modname in
115116 let basename = Filename.chop_extension filename in
116117 let cmi_file = basename ^ ".cmi" in
117118 let cmx_file = basename ^ ".cmx" in
119119+ let mli_exists =
120120+ List.exists (fun ext -> Sys.file_exists (basename ^ ext)) !mli_synonyms in
118121 let ml_exists =
119122 List.exists (fun ext -> Sys.file_exists (basename ^ ext)) !ml_synonyms in
120120- let new_opt_dep =
121121- if !all_dependencies then
122122- match target_kind with
123123- | MLI -> [ cmi_file ]
124124- | ML ->
125125- cmi_file :: (if ml_exists then [ cmx_file ] else [])
126126- else
123123+ if mli_exists then
124124+ let new_opt_dep =
125125+ if !all_dependencies then
126126+ match target_kind with
127127+ | MLI -> [ cmi_file ]
128128+ | ML ->
129129+ cmi_file :: (if ml_exists then [ cmx_file ] else [])
130130+ else
127131 (* this is a make-specific hack that makes .cmx to be a 'proxy'
128132 target that would force the dependency on .cmi via transitivity *)
129133 if ml_exists
130134 then [ cmx_file ]
131135 else [ cmi_file ]
132132- in
133133- ( cmi_file :: byt_deps, new_opt_dep @ opt_deps)
134134- with Not_found ->
135135- try
136136- (* "just .ml" case *)
137137- let candidates = List.map ((^) modname) !ml_synonyms in
138138- let filename = find_file_in_list candidates in
139139- let basename = Filename.chop_extension filename in
140140- let cmi_file = basename ^ ".cmi" in
141141- let cmx_file = basename ^ ".cmx" in
142142- let bytenames =
143143- if !all_dependencies then
144144- match target_kind with
145145- | MLI -> [ cmi_file ]
146146- | ML -> [ cmi_file ]
147147- else
148148- (* again, make-specific hack *)
149149- [basename ^ (if !native_only then ".cmx" else ".cmo")] in
150150- let optnames =
151151- if !all_dependencies
152152- then match target_kind with
153153- | MLI -> [ cmi_file ]
154154- | ML -> [ cmi_file; cmx_file ]
155155- else [ cmx_file ]
156156- in
157157- (bytenames @ byt_deps, optnames @ opt_deps)
136136+ in
137137+ ( cmi_file :: byt_deps, new_opt_dep @ opt_deps)
138138+ else
139139+ (* "just .ml" case *)
140140+ let bytenames =
141141+ if !all_dependencies then
142142+ match target_kind with
143143+ | MLI -> [ cmi_file ]
144144+ | ML -> [ cmi_file ]
145145+ else
146146+ (* again, make-specific hack *)
147147+ [basename ^ (if !native_only then ".cmx" else ".cmo")] in
148148+ let optnames =
149149+ if !all_dependencies
150150+ then match target_kind with
151151+ | MLI -> [ cmi_file ]
152152+ | ML -> [ cmi_file; cmx_file ]
153153+ else [ cmx_file ]
154154+ in
155155+ (bytenames @ byt_deps, optnames @ opt_deps)
158156 with Not_found ->
159157 (byt_deps, opt_deps)
160158
+4-4
driver/optcompile.ml
···4949 |>> Simplif.simplify_lambda
5050 |>> print_if i.ppf_dump Clflags.dump_lambda Printlambda.lambda
5151 |> (fun ((module_ident, size), lam) ->
5252- Middle_end.middle_end
5252+ Flambda_middle_end.middle_end
5353 ~ppf_dump:i.ppf_dump
5454 ~prefixname:i.output_prefix
5555 ~size
···6161 i.output_prefix ~required_globals ~backend ~ppf_dump:i.ppf_dump;
6262 Compilenv.save_unit_info (cmx i))
63636464-let clambda i typed =
6464+let clambda i backend typed =
6565 Clflags.use_inlining_arguments_set Clflags.classic_arguments;
6666 typed
6767 |> Profile.(record transl)
···7373 { program with Lambda.code }
7474 |> print_if i.ppf_dump Clflags.dump_lambda Printlambda.program
7575 |> Asmgen.compile_implementation_clambda
7676- i.output_prefix ~ppf_dump:i.ppf_dump;
7676+ i.output_prefix ~backend ~ppf_dump:i.ppf_dump;
7777 Compilenv.save_unit_info (cmx i))
78787979let implementation ~backend ~source_file ~output_prefix =
···8181 Compilenv.reset ?packname:!Clflags.for_package info.module_name;
8282 if Config.flambda
8383 then flambda info backend typed
8484- else clambda info typed
8484+ else clambda info backend typed
8585 in
8686 with_info ~source_file ~output_prefix ~dump_ext:"cmx" @@ fun info ->
8787 Compile_common.implementation info ~backend
+1
driver/optcompile.mli
···25252626val clambda :
2727 Compile_common.info ->
2828+ (module Backend_intf.S) ->
2829 Typedtree.structure * Typedtree.module_coercion -> unit
2930(** [clambda info typed] applies the regular compilation pipeline to the
3031 given typechecked implementation and outputs the resulting files.
···11+;**************************************************************************
22+;* *
33+;* OCaml *
44+;* *
55+;* Thomas Refis, Jane Street Europe *
66+;* *
77+;* Copyright 2018 Jane Street Group LLC *
88+;* *
99+;* All rights reserved. This file is distributed under the terms of *
1010+;* the GNU Lesser General Public License version 2.1, with the *
1111+;* special exception on linking described in the file LICENSE. *
1212+;* *
1313+;**************************************************************************
1414+1515+(rule
1616+ (targets runtimedef.ml)
1717+ (mode fallback)
1818+ (deps (:fail (file ../runtime/caml/fail.h))
1919+ (:prim (file ../runtime/primitives)))
2020+ (action (with-stdout-to %{targets}
2121+ (run ./generate_runtimedef.sh %{fail} %{prim}))))
···9494and `top.etex`. If you need to update this list of options, the top comment
9595of `unified-options.etex` contains the relevant information.
96969797-- Part IV, The OCaml library: 'libref'
9797+- Part IV, The OCaml library: 'library'
9898 This parts contains an brief presentation of all libraries bundled with the
9999 compilers and the api documentation generated for these libraries.
100100 - The core library: `core.etex`
+12-1
manual/manual/cmds/comp.etex
···100100The produced file has the executable bit set, and it manages to launch
101101the bytecode interpreter by itself.
102102103103+The compiler is able to emit some information on its internal stages.
104104+It can output ".cmt" files for the implementation of the compilation unit
105105+and ".cmti" for signatures if the option "-bin-annot" is passed to it (see the
106106+description of "-bin-annot" below).
107107+Each such file contains a typed abstract syntax tree (AST), that is produced
108108+during the type checking procedure. This tree contains all available information
109109+about the location and the specific type of each term in the source file.
110110+The AST is partial if type checking was unsuccessful.
111111+112112+These ".cmt" and ".cmti" files are typically useful for code inspection tools.
113113+103114\section{Options}\label{s:comp-options}
104115105116The following command-line options are recognized by "ocamlc".
···361372 after the addition of new fields to a record type.
362373363374\begin{verbatim}
364364-type 'a point = {x='a ;y='a}
375375+type 'a point = {x : 'a; y : 'a}
365376let dx { x } = x (* implicit field elision: trigger warning 9 *)
366377let dy { y; _ } = y (* explicit field elision: do not trigger warning 9 *)
367378\end{verbatim}
+13-1
manual/manual/cmds/native.etex
···8686The output of the linking phase is a regular Unix or Windows
8787executable file. It does not need "ocamlrun" to run.
88888989+% The following two paragraphs are a duplicate from the description of the batch compiler.
9090+9191+The compiler is able to emit some information on its internal stages.
9292+It can output ".cmt" files for the implementation of the compilation unit
9393+and ".cmti" for signatures if the option "-bin-annot" is passed to it (see the
9494+description of "-bin-annot" below).
9595+Each such file contains a typed abstract syntax tree (AST), that is produced
9696+during the type checking procedure. This tree contains all available information
9797+about the location and the specific type of each term in the source file.
9898+The AST is partial if type checking was unsuccessful.
9999+100100+These ".cmt" and ".cmti" files are typically useful for code inspection tools.
101101+89102\section{Options}
9010391104The following command-line options are recognized by "ocamlopt".
···227240"Sys" standard library module.
228241229242\end{itemize}
230230-
···205205 log scriptenv in
206206 let final_value =
207207 if Result.is_pass result then begin
208208- let modifiers = Environments.modifiers_of_file response_file in
209209- let modified_env = Environments.apply_modifiers newenv modifiers in
210210- (result, modified_env)
208208+ match Environments.modifiers_of_file response_file with
209209+ | modifiers ->
210210+ let modified_env = Environments.apply_modifiers newenv modifiers in
211211+ (result, modified_env)
212212+ | exception Failure reason ->
213213+ (Result.fail_with_reason reason, newenv)
214214+ | exception Variables.No_such_variable name ->
215215+ let reason =
216216+ Printf.sprintf "error in script response: unknown variable %s" name
217217+ in
218218+ (Result.fail_with_reason reason, newenv)
211219 end else begin
212220 let reason = String.trim (Sys.string_of_file response_file) in
213221 let newresult = { result with Result.reason = Some reason } in
···240248 } in let exit_status = run settings in
241249 let final_value = match exit_status with
242250 | 0 ->
243243- let modifiers = Environments.modifiers_of_file response_file in
244244- let modified_env = Environments.apply_modifiers hookenv modifiers in
245245- (Result.pass, modified_env)
251251+ begin match Environments.modifiers_of_file response_file with
252252+ | modifiers ->
253253+ let modified_env = Environments.apply_modifiers hookenv modifiers in
254254+ (Result.pass, modified_env)
255255+ | exception Failure reason ->
256256+ (Result.fail_with_reason reason, hookenv)
257257+ | exception Variables.No_such_variable name ->
258258+ let reason =
259259+ Printf.sprintf "error in script response: unknown variable %s" name
260260+ in
261261+ (Result.fail_with_reason reason, hookenv)
262262+ end
246263 | _ ->
247264 Printf.fprintf log "Hook returned %d" exit_status;
248265 let reason = String.trim (Sys.string_of_file response_file) in
+11-30
ocamltest/environments.ml
···144144 List.fold_left apply_modifier environment modifiers
145145146146let modifier_of_string str =
147147- let invalid_argument = (Invalid_argument "modifier_of_string") in
148148- if str="" then raise invalid_argument else begin
149149- let l = String.length str in
150150- if str.[0] = '-' then begin
151151- let variable_name = String.sub str 1 (l-1) in
152152- match Variables.find_variable variable_name with
153153- | None -> raise (Variables.No_such_variable variable_name)
154154- | Some variable -> Remove variable
155155- end else begin match String.index_opt str '=' with
156156- | None -> raise invalid_argument
157157- | Some pos_eq -> if pos_eq <= 0 then raise invalid_argument else
158158- let (append, varname_length) =
159159- (match String.index_opt str '+' with
160160- | None -> (false, pos_eq)
161161- | Some pos_plus ->
162162- if pos_plus = pos_eq-1
163163- then (true, pos_plus)
164164- else raise invalid_argument) in
165165- let variable_name = String.sub str 0 varname_length in
166166- match Variables.find_variable variable_name with
167167- | None -> raise (Variables.No_such_variable variable_name)
168168- | Some variable ->
169169- if pos_eq >= l-2 || str.[pos_eq+1]<>'"' || str.[l-1]<>'"'
170170- then raise invalid_argument
171171- else let value_length = l - pos_eq - 3 in
172172- let value = String.sub str (pos_eq+2) value_length in
173173- if append then Append (variable, value)
174174- else Add (variable, value)
175175- end
176176- end
147147+ let lexbuf = Lexing.from_string str in
148148+ let variable_name, result = Tsl_lexer.modifier lexbuf in
149149+ let variable =
150150+ match Variables.find_variable variable_name with
151151+ | None -> raise (Variables.No_such_variable variable_name)
152152+ | Some variable -> variable
153153+ in
154154+ match result with
155155+ | `Remove -> Remove variable
156156+ | `Add value -> Add (variable, value)
157157+ | `Append value -> Append (variable, value)
177158178159let modifiers_of_file filename =
179160 let ic = open_in filename in
···1212;* *
1313;**************************************************************************
14141515-(library
1616- (name dynlink)
1717- (wrapped false)
1818- (modules dynlink dynlink_compilerlibs dynlink_common dynlink_types
1919- dynlink_platform_intf)
2020- ; the -33 is specific to the hackery done with dune.
2121- (flags (:standard -nostdlib -w -33))
2222- (modules_without_implementation dynlink)
2323- (libraries ocamlcommon stdlib))
2424-2525-(rule
2626- (targets dynlink_compilerlibs.ml)
2727- (action (write-file %{targets}
2828- "(* empty because we are linking with ocamlcommon *)")))
1515+; mshinwell: Disabled: this needs to build in the same way as the
1616+; Makefile does, with the [Dynlink_compilerlibs] pack.
1717+;
1818+; (library
1919+; (name dynlink)
2020+; (wrapped false)
2121+; (modules dynlink dynlink_compilerlibs dynlink_common dynlink_types
2222+; dynlink_platform_intf)
2323+; ; the -33 is specific to the hackery done with dune.
2424+; (flags (:standard -nostdlib -w -33))
2525+; (modules_without_implementation dynlink)
2626+; (libraries ocamlcommon stdlib))
2727+;
2828+; (rule
2929+; (targets dynlink_compilerlibs.ml)
3030+; (action (write-file %{targets}
3131+; "(* empty because we are linking with ocamlcommon *)")))
+2
otherlibs/systhreads/st_stubs.c
···247247 caml_thread_restore_runtime_state();
248248}
249249250250+#if 0
250251static int caml_thread_try_leave_blocking_section(void)
251252{
252253 /* Disable immediate processing of signals (PR#3659).
···255256 polling. */
256257 return 0;
257258}
259259+#endif
258260259261/* Create and setup a new thread info block.
260262 This block has no associated thread descriptor and
···190190 if loc.loc_start.pos_fname = "" then !input_name
191191 else loc.loc_start.pos_fname
192192 in
193193- let line = loc.loc_start.pos_lnum in
193193+ let startline = loc.loc_start.pos_lnum in
194194+ let endline = loc.loc_end.pos_lnum in
194195 let startchar = loc.loc_start.pos_cnum - loc.loc_start.pos_bol in
195195- let endchar = loc.loc_end.pos_cnum - loc.loc_start.pos_bol in
196196+ let endchar = loc.loc_end.pos_cnum - loc.loc_end.pos_bol in
196197197198 let first = ref true in
198199 let capitalize s =
···210211 existing setup of editors that parse locations in error messages (e.g.
211212 Emacs). *)
212213 comma ();
213213- Format.fprintf ppf "%s %i" (capitalize "line")
214214- (if line_valid line then line else 1);
214214+ let startline = if line_valid startline then startline else 1 in
215215+ let endline = if line_valid endline then endline else startline in
216216+ begin if startline = endline then
217217+ Format.fprintf ppf "%s %i" (capitalize "line") startline
218218+ else
219219+ Format.fprintf ppf "%s %i-%i" (capitalize "lines") startline endline
220220+ end;
215221216222 if chars_valid ~startchar ~endchar then (
217223 comma ();
+5-3
parsing/pprintast.ml
···471471 | Ppat_constraint (p, ct) ->
472472 pp f "@[<2>(%a@;:@;%a)@]" (pattern1 ctxt) p (core_type ctxt) ct
473473 | Ppat_lazy p ->
474474- pp f "@[<2>(lazy@;%a)@]" (pattern1 ctxt) p
474474+ pp f "@[<2>(lazy@;%a)@]" (simple_pattern ctxt) p
475475 | Ppat_exception p ->
476476 pp f "@[<2>exception@;%a@]" (pattern1 ctxt) p
477477 | Ppat_effect(p1, p2) ->
···588588 (attributes ctxt) x.pexp_attributes
589589 else match x.pexp_desc with
590590 | Pexp_function _ | Pexp_fun _ | Pexp_match _ | Pexp_try _ | Pexp_sequence _
591591+ | Pexp_newtype _
591592 when ctxt.pipe || ctxt.semi ->
592593 paren true (expression reset_ctxt) f x
593594 | Pexp_ifthenelse _ | Pexp_sequence _ when ctxt.ifthenelse ->
···599600 | Pexp_fun (l, e0, p, e) ->
600601 pp f "@[<2>fun@;%a->@;%a@]"
601602 (label_exp ctxt) (l, e0, p)
603603+ (expression ctxt) e
604604+ | Pexp_newtype (lid, e) ->
605605+ pp f "@[<2>fun@;(type@;%s)@;->@;%a@]" lid.txt
602606 (expression ctxt) e
603607 | Pexp_function l ->
604608 pp f "@[<hv>function%a@]" (case_list ctxt) l
···764768 | Pexp_constant c -> constant f c;
765769 | Pexp_pack me ->
766770 pp f "(module@;%a)" (module_expr ctxt) me
767767- | Pexp_newtype (lid, e) ->
768768- pp f "fun@;(type@;%s)@;->@;%a" lid.txt (expression ctxt) e
769771 | Pexp_tuple l ->
770772 pp f "@[<hov2>(%a)@]" (list (simple_expr ctxt) ~sep:",@;") l
771773 | Pexp_constraint (e, ct) ->
···162162 break;
163163 case CAML_BA_MAPPED_FILE:
164164 /* Bigarrays for mapped files use a different finalization method */
165165+ /* fallthrough */
165166 default:
166167 CAMLassert(0);
167168 }
···936937CAMLprim value caml_ba_slice(value vb, value vind)
937938{
938939 CAMLparam2 (vb, vind);
939939- #define b ((struct caml_ba_array *) Caml_ba_array_val(vb))
940940+ #define b (Caml_ba_array_val(vb))
940941 CAMLlocal1 (res);
941942 intnat index[CAML_BA_MAX_NUM_DIMS];
942943 int num_inds, i;
···968969 offset * caml_ba_element_size[b->flags & CAML_BA_KIND_MASK];
969970 /* Allocate an OCaml bigarray to hold the result */
970971 res = caml_ba_alloc(b->flags, b->num_dims - num_inds, sub_data, sub_dims);
972972+ /* Copy the finalization function from the original array (PR#8568) */
973973+ Custom_ops_val(res) = Custom_ops_val(vb);
971974 /* Create or update proxy in case of managed bigarray */
972975 caml_ba_update_proxy(b, Caml_ba_array_val(res));
973976 /* Return result */
···982985{
983986 CAMLparam2 (vb, vlayout);
984987 CAMLlocal1 (res);
985985- #define b ((struct caml_ba_array *) Caml_ba_array_val(vb))
988988+ #define b (Caml_ba_array_val(vb))
986989 /* if the layout is different, change the flags and reverse the dimensions */
987990 if (Caml_ba_layout_val(vlayout) != (b->flags & CAML_BA_LAYOUT_MASK)) {
988991 /* change the flags to reflect the new layout */
···993996 unsigned int i;
994997 for(i = 0; i < b->num_dims; i++) new_dim[i] = b->dim[b->num_dims - i - 1];
995998 res = caml_ba_alloc(flags, b->num_dims, b->data, new_dim);
999999+ /* Copy the finalization function from the original array (PR#8568) */
10001000+ Custom_ops_val(res) = Custom_ops_val(vb);
9961001 caml_ba_update_proxy(b, Caml_ba_array_val(res));
9971002 CAMLreturn(res);
9981003 } else {
···10091014{
10101015 CAMLparam3 (vb, vofs, vlen);
10111016 CAMLlocal1 (res);
10121012- #define b ((struct caml_ba_array *) Caml_ba_array_val(vb))
10171017+ #define b (Caml_ba_array_val(vb))
10131018 intnat ofs = Long_val(vofs);
10141019 intnat len = Long_val(vlen);
10151020 int i, changed_dim;
···10361041 ofs * mul * caml_ba_element_size[b->flags & CAML_BA_KIND_MASK];
10371042 /* Allocate an OCaml bigarray to hold the result */
10381043 res = caml_ba_alloc(b->flags, b->num_dims, sub_data, b->dim);
10441044+ /* Copy the finalization function from the original array (PR#8568) */
10451045+ Custom_ops_val(res) = Custom_ops_val(vb);
10391046 /* Doctor the changed dimension */
10401047 Caml_ba_array_val(res)->dim[changed_dim] = len;
10411048 /* Create or update proxy in case of managed bigarray */
···11891196{
11901197 CAMLparam2 (vb, vdim);
11911198 CAMLlocal1 (res);
11921192-#define b ((struct caml_ba_array *) Caml_ba_array_val(vb))
11991199+#define b (Caml_ba_array_val(vb))
11931200 intnat dim[CAML_BA_MAX_NUM_DIMS];
11941201 mlsize_t num_dims;
11951202 uintnat num_elts;
···12111218 caml_invalid_argument("Bigarray.reshape: size mismatch");
12121219 /* Create bigarray with same data and new dimensions */
12131220 res = caml_ba_alloc(b->flags, num_dims, b->data, dim);
12211221+ /* Copy the finalization function from the original array (PR#8568) */
12221222+ Custom_ops_val(res) = Custom_ops_val(vb);
12141223 /* Create or update proxy in case of managed bigarray */
12151224 caml_ba_update_proxy(b, Caml_ba_array_val(res));
12161225 /* Return result */
+6-2
runtime/caml/misc.h
···256256257257#ifdef _WIN32
258258259259-#define _T(x) L ## x
259259+#ifdef CAML_INTERNALS
260260+#define T(x) L ## x
261261+#endif
260262261263#define access_os _waccess
262264#define open_os _wopen
···286288287289#else /* _WIN32 */
288290289289-#define _T(x) x
291291+#ifdef CAML_INTERNALS
292292+#define T(x) x
293293+#endif
290294291295#define access_os access
292296#define open_os open
+1-1
runtime/debugger.c
···181181 Store_field(flags, 1, Val_emptylist);
182182 marshal_flags = caml_create_root(flags);
183183184184- a = caml_secure_getenv(_T("CAML_DEBUG_SOCKET"));
184184+ a = caml_secure_getenv(T("CAML_DEBUG_SOCKET"));
185185 address = a ? caml_stat_strdup_of_os(a) : NULL;
186186 if (address == NULL) return;
187187 if (dbg_addr != NULL) caml_stat_free(dbg_addr);
+6-6
runtime/dynlink.c
···7373/* Parse the OCAML_STDLIB_DIR/ld.conf file and add the directories
7474 listed there to the search path */
75757676-#define LD_CONF_NAME _T("ld.conf")
7676+#define LD_CONF_NAME T("ld.conf")
77777878static char_os * parse_ld_conf(void)
7979{
···8686#endif
8787 int ldconf, nread;
88888989- stdlib = caml_secure_getenv(_T("OCAMLLIB"));
9090- if (stdlib == NULL) stdlib = caml_secure_getenv(_T("CAMLLIB"));
8989+ stdlib = caml_secure_getenv(T("OCAMLLIB"));
9090+ if (stdlib == NULL) stdlib = caml_secure_getenv(T("CAMLLIB"));
9191 if (stdlib == NULL) stdlib = OCAML_STDLIB_DIR;
9292- ldconfname = caml_stat_strconcat_os(3, stdlib, _T("/"), LD_CONF_NAME);
9292+ ldconfname = caml_stat_strconcat_os(3, stdlib, T("/"), LD_CONF_NAME);
9393 if (stat_os(ldconfname, &st) == -1) {
9494 caml_stat_free(ldconfname);
9595 return NULL;
···109109 caml_stat_free(config);
110110 q = wconfig;
111111 for (p = wconfig; *p != 0; p++) {
112112- if (*p == _T('\n')) {
112112+ if (*p == '\n') {
113113 *p = 0;
114114 caml_ext_table_add(&caml_shared_libs_path, q);
115115 q = p + 1;
···165165 - directories specified in the executable
166166 - directories specified in the file <stdlib>/ld.conf */
167167 tofree1 = caml_decompose_path(&caml_shared_libs_path,
168168- caml_secure_getenv(_T("CAML_LD_LIBRARY_PATH")));
168168+ caml_secure_getenv(T("CAML_LD_LIBRARY_PATH")));
169169 if (lib_path != NULL)
170170 for (p = lib_path; *p != 0; p += strlen_os(p) + 1)
171171 caml_ext_table_add(&caml_shared_libs_path, p);
+21-22
runtime/floats.c
···277277 return res;
278278}
279279280280-static int caml_float_of_hex(const char * s, double * res)
280280+static int caml_float_of_hex(const char * s, const char * end, double * res)
281281{
282282 int64_t m = 0; /* the mantissa - top 60 bits at most */
283283 int n_bits = 0; /* total number of bits read */
···289289 char * p; /* for converting the exponent */
290290 double f;
291291292292- while (*s != 0) {
292292+ while (s < end) {
293293 char c = *s++;
294294 switch (c) {
295295- case '_':
296296- break;
297295 case '.':
298296 if (dec_point >= 0) return -1; /* multiple decimal points */
299297 dec_point = n_bits;
···302300 long e;
303301 if (*s == 0) return -1; /* nothing after exponent mark */
304302 e = strtol(s, &p, 10);
305305- if (*p != 0) return -1; /* ill-formed exponent */
303303+ if (p != end) return -1; /* ill-formed exponent */
306304 /* Handle exponents larger than int by returning 0/infinity directly.
307305 Mind that INT_MIN/INT_MAX are included in the test so as to capture
308306 the overflow case of strtol on Win64 -- long and int have the same
···377375 int sign;
378376 double d;
379377380380- /* Check for hexadecimal FP constant */
381381- src = String_val(vs);
382382- sign = 1;
383383- if (*src == '-') { sign = -1; src++; }
384384- else if (*src == '+') { src++; };
385385- if (src[0] == '0' && (src[1] == 'x' || src[1] == 'X')) {
386386- if (caml_float_of_hex(src + 2, &d) == -1)
387387- caml_failwith("float_of_string");
388388- return caml_copy_double(sign < 0 ? -d : d);
389389- }
390390- /* Remove '_' characters before calling strtod () */
378378+ /* Remove '_' characters before conversion */
391379 len = caml_string_length(vs);
392380 buf = len < sizeof(parse_buffer) ? parse_buffer : caml_stat_alloc(len + 1);
393381 src = String_val(vs);
···398386 }
399387 *dst = 0;
400388 if (dst == buf) goto error;
389389+ /* Check for hexadecimal FP constant */
390390+ src = buf;
391391+ sign = 1;
392392+ if (*src == '-') { sign = -1; src++; }
393393+ else if (*src == '+') { src++; };
394394+ if (src[0] == '0' && (src[1] == 'x' || src[1] == 'X')) {
395395+ /* Convert using our hexadecimal FP parser */
396396+ if (caml_float_of_hex(src + 2, dst, &d) == -1) goto error;
397397+ if (sign < 0) d = -d;
398398+ } else {
399399+ /* Convert using strtod */
401400#if defined(HAS_STRTOD_L) && defined(HAS_LOCALE)
402402- d = strtod_l((const char *) buf, &end, caml_locale);
401401+ d = strtod_l((const char *) buf, &end, caml_locale);
403402#else
404404- USE_LOCALE;
405405- /* Convert using strtod */
406406- d = strtod((const char *) buf, &end);
407407- RESTORE_LOCALE;
403403+ USE_LOCALE;
404404+ d = strtod((const char *) buf, &end);
405405+ RESTORE_LOCALE;
408406#endif /* HAS_STRTOD_L */
409409- if (end != dst) goto error;
407407+ if (end != dst) goto error;
408408+ }
410409 if (buf != parse_buffer) caml_stat_free(buf);
411410 return caml_copy_double(d);
412411 error:
···5959 params.verb_gc = 0x3F;
6060#endif
6161#ifndef NATIVE_CODE
6262- cds_file = caml_secure_getenv(_T("CAML_DEBUG_FILE"));
6262+ cds_file = caml_secure_getenv(T("CAML_DEBUG_FILE"));
6363 if (cds_file != NULL) {
6464 params.cds_file = caml_stat_strdup_os(cds_file);
6565 }
···69697070static void scanmult (char_os *opt, uintnat *var)
7171{
7272- char_os mult = _T(' ');
7272+ char_os mult = ' ';
7373 unsigned int val = 1;
7474- sscanf_os (opt, _T("=%u%c"), &val, &mult);
7575- sscanf_os (opt, _T("=0x%x%c"), &val, &mult);
7474+ sscanf_os (opt, T("=%u%c"), &val, &mult);
7575+ sscanf_os (opt, T("=0x%x%c"), &val, &mult);
7676 switch (mult) {
7777- case _T('k'): *var = (uintnat) val * 1024; break;
7878- case _T('M'): *var = (uintnat) val * (1024 * 1024); break;
7979- case _T('G'): *var = (uintnat) val * (1024 * 1024 * 1024); break;
7777+ case 'k': *var = (uintnat) val * 1024; break;
7878+ case 'M': *var = (uintnat) val * (1024 * 1024); break;
7979+ case 'G': *var = (uintnat) val * (1024 * 1024 * 1024); break;
8080 default: *var = (uintnat) val; break;
8181 }
8282}
83838484void caml_parse_ocamlrunparam(void)
8585{
8686- char_os *opt = caml_secure_getenv (_T("OCAMLRUNPARAM"));
8686+ char_os *opt = caml_secure_getenv (T("OCAMLRUNPARAM"));
87878888 init_startup_params();
89899090- if (opt == NULL) opt = caml_secure_getenv (_T("CAMLRUNPARAM"));
9090+ if (opt == NULL) opt = caml_secure_getenv (T("CAMLRUNPARAM"));
91919292 if (opt != NULL){
9393- while (*opt != _T('\0')){
9393+ while (*opt != '\0'){
9494 switch (*opt++){
9595- //case _T('a'): scanmult (opt, &p); caml_set_allocation_policy (p); break;
9696- case _T('b'): scanmult (opt, ¶ms.backtrace_enabled_init); break;
9797- case _T('c'): scanmult (opt, ¶ms.cleanup_on_exit); break;
9898- case _T('e'): scanmult (opt, ¶ms.eventlog_enabled); break;
9999- case _T('f'): scanmult (opt, ¶ms.init_fiber_wsz); break;
100100- case _T('h'): scanmult (opt, ¶ms.init_heap_wsz); break;
101101- //case _T('H'): scanmult (opt, &caml_use_huge_pages); break;
102102- case _T('i'): scanmult (opt, ¶ms.init_heap_chunk_sz); break;
103103- case _T('l'): scanmult (opt, ¶ms.init_max_stack_wsz); break;
104104- case _T('M'): scanmult (opt, ¶ms.init_custom_major_ratio); break;
105105- case _T('m'): scanmult (opt, ¶ms.init_custom_minor_ratio); break;
106106- case _T('n'): scanmult (opt, ¶ms.init_custom_minor_max_bsz); break;
107107- case _T('o'): scanmult (opt, ¶ms.init_percent_free); break;
108108- case _T('O'): scanmult (opt, ¶ms.init_max_percent_free); break;
109109- case _T('p'): scanmult (opt, ¶ms.parser_trace); break;
110110- case _T('R'): break; /* see stdlib/hashtbl.mli */
111111- case _T('s'): scanmult (opt, ¶ms.init_minor_heap_wsz); break;
112112- case _T('S'): scanmult (opt, ¶ms.print_stats); break;
113113- case _T('t'): scanmult (opt, ¶ms.trace_level); break;
114114- case _T('v'): scanmult (opt, ¶ms.verb_gc); break;
115115- case _T('V'): scanmult (opt, ¶ms.verify_heap); break;
116116- //case _T('w'): scanmult (opt, &caml_init_major_window); break;
117117- case _T('W'): scanmult (opt, &caml_runtime_warnings); break;
9595+ //case 'a': scanmult (opt, &p); caml_set_allocation_policy (p); break;
9696+ case 'b': scanmult (opt, ¶ms.backtrace_enabled_init); break;
9797+ case 'c': scanmult (opt, ¶ms.cleanup_on_exit); break;
9898+ case 'e': scanmult (opt, ¶ms.eventlog_enabled); break;
9999+ case 'f': scanmult (opt, ¶ms.init_fiber_wsz); break;
100100+ case 'h': scanmult (opt, ¶ms.init_heap_wsz); break;
101101+ //case 'H': scanmult (opt, &caml_use_huge_pages); break;
102102+ case 'i': scanmult (opt, ¶ms.init_heap_chunk_sz); break;
103103+ case 'l': scanmult (opt, ¶ms.init_max_stack_wsz); break;
104104+ case 'M': scanmult (opt, ¶ms.init_custom_major_ratio); break;
105105+ case 'm': scanmult (opt, ¶ms.init_custom_minor_ratio); break;
106106+ case 'n': scanmult (opt, ¶ms.init_custom_minor_max_bsz); break;
107107+ case 'o': scanmult (opt, ¶ms.init_percent_free); break;
108108+ case 'O': scanmult (opt, ¶ms.init_max_percent_free); break;
109109+ case 'p': scanmult (opt, ¶ms.parser_trace); break;
110110+ case 'R': break; /* see stdlib/hashtbl.mli */
111111+ case 's': scanmult (opt, ¶ms.init_minor_heap_wsz); break;
112112+ case 'S': scanmult (opt, ¶ms.print_stats); break;
113113+ case 't': scanmult (opt, ¶ms.trace_level); break;
114114+ case 'v': scanmult (opt, ¶ms.verb_gc); break;
115115+ case 'V': scanmult (opt, ¶ms.verify_heap); break;
116116+ //case 'w': scanmult (opt, &caml_init_major_window); break;
117117+ case 'W': scanmult (opt, &caml_runtime_warnings); break;
118118 }
119119 --opt; /* to handle patterns like ",b=1" */
120120- while (*opt != _T('\0')){
120120+ while (*opt != '\0'){
121121 if (*opt++ == ',') break;
122122 }
123123 }
···206206{
207207 int i, j;
208208209209- for(i = 1; argv[i] != NULL && argv[i][0] == _T('-'); i++) {
209209+ for(i = 1; argv[i] != NULL && argv[i][0] == '-'; i++) {
210210 switch(argv[i][1]) {
211211- case _T('t'):
211211+ case 't':
212212 params.trace_level++; /* ignored unless DEBUG mode */
213213 break;
214214- case _T('v'):
215215- if (!strcmp_os (argv[i], _T("-version"))){
214214+ case 'v':
215215+ if (!strcmp_os (argv[i], T("-version"))){
216216 printf ("The OCaml runtime, version " OCAML_VERSION_STRING "\n");
217217 exit (0);
218218- }else if (!strcmp_os (argv[i], _T("-vnum"))){
218218+ }else if (!strcmp_os (argv[i], T("-vnum"))){
219219 printf (OCAML_VERSION_STRING "\n");
220220 exit (0);
221221 }else{
222222 params.verb_gc = 0x001+0x004+0x008+0x010+0x020;
223223 }
224224 break;
225225- case _T('p'):
225225+ case 'p':
226226 for (j = 0; caml_names_of_builtin_cprim[j] != NULL; j++)
227227 printf("%s\n", caml_names_of_builtin_cprim[j]);
228228 exit(0);
229229 break;
230230- case _T('b'):
230230+ case 'b':
231231 params.backtrace_enabled_init = 1;
232232 break;
233233- case _T('I'):
233233+ case 'I':
234234 if (argv[i + 1] != NULL) {
235235 caml_ext_table_add(&caml_shared_libs_path, argv[i + 1]);
236236 i++;
+1-1
runtime/startup_byt.c
···359359 caml_minor_collection();
360360#ifdef _WIN32
361361 /* Start a thread to handle signals */
362362- if (caml_secure_getenv(_T("CAMLSIGPIPE")))
362362+ if (caml_secure_getenv(T("CAMLSIGPIPE")))
363363 _beginthread(caml_signal_thread, 4096, NULL);
364364#endif
365365 /* Execute the program */
+1-1
runtime/startup_nat.c
···123123 caml_init_signals();
124124 caml_debugger_init (); /* force debugger.o stub to be linked */
125125 exe_name = argv[0];
126126- if (exe_name == NULL) exe_name = _T("");
126126+ if (exe_name == NULL) exe_name = T("");
127127 proc_self_exe = caml_executable_name();
128128 if (proc_self_exe != NULL)
129129 exe_name = proc_self_exe;
···7272 this tricky function that is slow anyway. *)
7373 Bytes.blit b.buffer 0 new_buffer 0 b.position;
7474 b.buffer <- new_buffer;
7575- b.length <- !new_len
7575+ b.length <- !new_len;
7676+ assert (b.position + more <= b.length)
76777778let add_char b c =
7879 let pos = b.position in
···163164 then invalid_arg "Buffer.add_substring/add_subbytes";
164165 let new_position = b.position + len in
165166 if new_position > b.length then resize b len;
166166- Bytes.blit_string s offset b.buffer b.position len;
167167+ Bytes.unsafe_blit_string s offset b.buffer b.position len;
167168 b.position <- new_position
168169169170let add_subbytes b s offset len =
···173174 let len = String.length s in
174175 let new_position = b.position + len in
175176 if new_position > b.length then resize b len;
176176- Bytes.blit_string s 0 b.buffer b.position len;
177177+ Bytes.unsafe_blit_string s 0 b.buffer b.position len;
177178 b.position <- new_position
178179179180let add_bytes b s = add_string b (Bytes.unsafe_to_string s)
···277278278279let to_seq b =
279280 let rec aux i () =
281281+ (* Note that b.position is not a constant and cannot be lifted out of aux *)
280282 if i >= b.position then Seq.Nil
281283 else
282282- let x = Bytes.get b.buffer i in
284284+ let x = Bytes.unsafe_get b.buffer i in
283285 Seq.Cons (x, aux (i+1))
284286 in
285287 aux 0
286288287289let to_seqi b =
288290 let rec aux i () =
291291+ (* Note that b.position is not a constant and cannot be lifted out of aux *)
289292 if i >= b.position then Seq.Nil
290293 else
291291- let x = Bytes.get b.buffer i in
294294+ let x = Bytes.unsafe_get b.buffer i in
292295 Seq.Cons ((i,x), aux (i+1))
293296 in
294297 aux 0
+3
stdlib/bytes.mli
···669669external unsafe_blit :
670670 bytes -> int -> bytes -> int -> int -> unit
671671 = "caml_blit_bytes" [@@noalloc]
672672+external unsafe_blit_string :
673673+ string -> int -> bytes -> int -> int -> unit
674674+ = "caml_blit_string" [@@noalloc]
672675external unsafe_fill :
673676 bytes -> int -> int -> char -> unit = "caml_fill_bytes" [@@noalloc]
···6363end
6464and B: sig val value: unit end = struct let value = A.f () end
6565[%%expect {|
6666-Line 4, characters 6-72:
6666+Lines 4-7, characters 6-3:
67674 | ......struct
68685 | module F(X:sig end) = struct end
69696 | let f () = B.value
···9393 and B: sig val value: unit end = struct let value = A.f () end
9494end
9595[%%expect {|
9696-Line 5, characters 8-62:
9696+Lines 5-8, characters 8-5:
97975 | ........struct
98986 | module M = X.M
99997 | let f () = B.value
···11-File "robustmatch.ml", line 33, characters 6-122:
11+File "robustmatch.ml", lines 33-37, characters 6-23:
2233 | ......match t1, t2, x with
3334 | | AB, AB, A -> ()
4435 | | MAB, _, A -> ()
···77Warning 8: this pattern-matching is not exhaustive.
88Here is an example of a case that is not matched:
99(AB, MAB, A)
1010-File "robustmatch.ml", line 54, characters 4-73:
1010+File "robustmatch.ml", lines 54-56, characters 4-27:
111154 | ....match r1, r2, a with
121255 | | R1, _, 0 -> ()
131356 | | _, R2, "coucou" -> ()
1414Warning 8: this pattern-matching is not exhaustive.
1515Here is an example of a case that is not matched:
1616(R1, R1, 1)
1717-File "robustmatch.ml", line 64, characters 4-73:
1717+File "robustmatch.ml", lines 64-66, characters 4-27:
181864 | ....match r1, r2, a with
191965 | | R1, _, A -> ()
202066 | | _, R2, "coucou" -> ()
2121Warning 8: this pattern-matching is not exhaustive.
2222Here is an example of a case that is not matched:
2323(R1, R1, (B|C))
2424-File "robustmatch.ml", line 69, characters 4-73:
2424+File "robustmatch.ml", lines 69-71, characters 4-20:
252569 | ....match r1, r2, a with
262670 | | _, R2, "coucou" -> ()
272771 | | R1, _, A -> ()
2828Warning 8: this pattern-matching is not exhaustive.
2929Here is an example of a case that is not matched:
3030(R1, R1, (B|C))
3131-File "robustmatch.ml", line 74, characters 4-73:
3131+File "robustmatch.ml", lines 74-76, characters 4-20:
323274 | ....match r1, r2, a with
333375 | | _, R2, "coucou" -> ()
343476 | | R1, _, _ -> ()
3535Warning 8: this pattern-matching is not exhaustive.
3636Here is an example of a case that is not matched:
3737(R2, R2, "")
3838-File "robustmatch.ml", line 85, characters 4-66:
3838+File "robustmatch.ml", lines 85-87, characters 4-20:
393985 | ....match r1, r2, a with
404086 | | R1, _, A -> ()
414187 | | _, R2, X -> ()
4242Warning 8: this pattern-matching is not exhaustive.
4343Here is an example of a case that is not matched:
4444(R1, R1, (B|C))
4545-File "robustmatch.ml", line 90, characters 4-87:
4545+File "robustmatch.ml", lines 90-93, characters 4-20:
464690 | ....match r1, r2, a with
474791 | | R1, _, A -> ()
484892 | | _, R2, X -> ()
···5050Warning 8: this pattern-matching is not exhaustive.
5151Here is an example of a case that is not matched:
5252(R2, R2, (Y|Z))
5353-File "robustmatch.ml", line 96, characters 4-66:
5353+File "robustmatch.ml", lines 96-98, characters 4-20:
545496 | ....match r1, r2, a with
555597 | | R1, _, _ -> ()
565698 | | _, R2, X -> ()
5757Warning 8: this pattern-matching is not exhaustive.
5858Here is an example of a case that is not matched:
5959(R2, R2, (Y|Z))
6060-File "robustmatch.ml", line 107, characters 4-66:
6060+File "robustmatch.ml", lines 107-109, characters 4-20:
6161107 | ....match r1, r2, a with
6262108 | | R1, _, A -> ()
6363109 | | _, R2, X -> ()
6464Warning 8: this pattern-matching is not exhaustive.
6565Here is an example of a case that is not matched:
6666(R1, R1, (B|C))
6767-File "robustmatch.ml", line 129, characters 4-66:
6767+File "robustmatch.ml", lines 129-131, characters 4-20:
6868129 | ....match r1, r2, a with
6969130 | | R1, _, A -> ()
7070131 | | _, R2, X -> ()
7171Warning 8: this pattern-matching is not exhaustive.
7272Here is an example of a case that is not matched:
7373(R1, R1, B)
7474-File "robustmatch.ml", line 151, characters 4-66:
7474+File "robustmatch.ml", lines 151-153, characters 4-20:
7575151 | ....match r1, r2, a with
7676152 | | R1, _, A -> ()
7777153 | | _, R2, X -> ()
7878Warning 8: this pattern-matching is not exhaustive.
7979Here is an example of a case that is not matched:
8080(R1, R1, B)
8181-File "robustmatch.ml", line 156, characters 4-87:
8181+File "robustmatch.ml", lines 156-159, characters 4-20:
8282156 | ....match r1, r2, a with
8383157 | | R1, _, A -> ()
8484158 | | _, R2, X -> ()
···8686Warning 8: this pattern-matching is not exhaustive.
8787Here is an example of a case that is not matched:
8888(R2, R2, Y)
8989-File "robustmatch.ml", line 162, characters 4-66:
8989+File "robustmatch.ml", lines 162-164, characters 4-20:
9090162 | ....match r1, r2, a with
9191163 | | R1, _, _ -> ()
9292164 | | _, R2, X -> ()
9393Warning 8: this pattern-matching is not exhaustive.
9494Here is an example of a case that is not matched:
9595(R2, R2, Y)
9696-File "robustmatch.ml", line 167, characters 4-66:
9696+File "robustmatch.ml", lines 167-169, characters 4-20:
9797167 | ....match r1, r2, a with
9898168 | | R1, _, C -> ()
9999169 | | _, R2, Y -> ()
100100Warning 8: this pattern-matching is not exhaustive.
101101Here is an example of a case that is not matched:
102102(R1, R1, A)
103103-File "robustmatch.ml", line 176, characters 4-90:
103103+File "robustmatch.ml", lines 176-179, characters 4-20:
104104176 | ....match r1, r2, a with
105105177 | | _, R1, 0 -> ()
106106178 | | R2, _, [||] -> ()
···108108Warning 8: this pattern-matching is not exhaustive.
109109Here is an example of a case that is not matched:
110110(R2, R2, [| _ |])
111111-File "robustmatch.ml", line 182, characters 4-69:
111111+File "robustmatch.ml", lines 182-184, characters 4-23:
112112182 | ....match r1, r2, a with
113113183 | | R1, _, _ -> ()
114114184 | | _, R2, [||] -> ()
115115Warning 8: this pattern-matching is not exhaustive.
116116Here is an example of a case that is not matched:
117117(R2, R2, [| _ |])
118118-File "robustmatch.ml", line 187, characters 4-90:
118118+File "robustmatch.ml", lines 187-190, characters 4-20:
119119187 | ....match r1, r2, a with
120120188 | | _, R2, [||] -> ()
121121189 | | R1, _, 0 -> ()
···123123Warning 8: this pattern-matching is not exhaustive.
124124Here is an example of a case that is not matched:
125125(R2, R2, [| _ |])
126126-File "robustmatch.ml", line 200, characters 4-89:
126126+File "robustmatch.ml", lines 200-203, characters 4-19:
127127200 | ....match r1, r2, a with
128128201 | | _, R2, [||] -> ()
129129202 | | R1, _, 0 -> ()
130130203 | | _, _, _ -> ()
131131Warning 4: this pattern-matching is fragile.
132132It will remain exhaustive when constructors are added to type repr.
133133-File "robustmatch.ml", line 210, characters 4-75:
133133+File "robustmatch.ml", lines 210-212, characters 4-27:
134134210 | ....match r1, r2, a with
135135211 | | R1, _, 'c' -> ()
136136212 | | _, R2, "coucou" -> ()
137137Warning 8: this pattern-matching is not exhaustive.
138138Here is an example of a case that is not matched:
139139(R1, R1, 'a')
140140-File "robustmatch.ml", line 219, characters 4-74:
140140+File "robustmatch.ml", lines 219-221, characters 4-27:
141141219 | ....match r1, r2, a with
142142220 | | R1, _, `A -> ()
143143221 | | _, R2, "coucou" -> ()
144144Warning 8: this pattern-matching is not exhaustive.
145145Here is an example of a case that is not matched:
146146(R1, R1, `B)
147147-File "robustmatch.ml", line 228, characters 4-89:
147147+File "robustmatch.ml", lines 228-230, characters 4-37:
148148228 | ....match r1, r2, a with
149149229 | | R1, _, (3, "") -> ()
150150230 | | _, R2, (1, "coucou", 'a') -> ()
151151Warning 8: this pattern-matching is not exhaustive.
152152Here is an example of a case that is not matched:
153153(R1, R1, (3, "*"))
154154-File "robustmatch.ml", line 239, characters 4-113:
154154+File "robustmatch.ml", lines 239-241, characters 4-51:
155155239 | ....match r1, r2, a with
156156240 | | R1, _, { x = 3; y = "" } -> ()
157157241 | | _, R2, { a = 1; b = "coucou"; c = 'a' } -> ()
158158Warning 8: this pattern-matching is not exhaustive.
159159Here is an example of a case that is not matched:
160160(R1, R1, {x=3; y="*"})
161161-File "robustmatch.ml", line 244, characters 4-113:
161161+File "robustmatch.ml", lines 244-246, characters 4-36:
162162244 | ....match r1, r2, a with
163163245 | | R2, _, { a = 1; b = "coucou"; c = 'a' } -> ()
164164246 | | _, R1, { x = 3; y = "" } -> ()
165165Warning 8: this pattern-matching is not exhaustive.
166166Here is an example of a case that is not matched:
167167(R2, R2, {a=1; b="coucou"; c='b'})
168168-File "robustmatch.ml", line 253, characters 4-72:
168168+File "robustmatch.ml", lines 253-255, characters 4-20:
169169253 | ....match r1, r2, a with
170170254 | | R1, _, (3, "") -> ()
171171255 | | _, R2, 1 -> ()
172172Warning 8: this pattern-matching is not exhaustive.
173173Here is an example of a case that is not matched:
174174(R1, R1, (3, "*"))
175175-File "robustmatch.ml", line 263, characters 4-82:
175175+File "robustmatch.ml", lines 263-265, characters 4-20:
176176263 | ....match r1, r2, a with
177177264 | | R1, _, { x = 3; y = "" } -> ()
178178265 | | _, R2, 1 -> ()
179179Warning 8: this pattern-matching is not exhaustive.
180180Here is an example of a case that is not matched:
181181(R1, R1, {x=3; y="*"})
182182-File "robustmatch.ml", line 272, characters 4-71:
182182+File "robustmatch.ml", lines 272-274, characters 4-20:
183183272 | ....match r1, r2, a with
184184273 | | R1, _, lazy 1 -> ()
185185274 | | _, R2, 1 -> ()
186186Warning 8: this pattern-matching is not exhaustive.
187187Here is an example of a case that is not matched:
188188(R1, R1, lazy 0)
189189-File "robustmatch.ml", line 281, characters 4-99:
189189+File "robustmatch.ml", lines 281-284, characters 4-24:
190190281 | ....match r1, r2, a with
191191282 | | R1, _, () -> ()
192192283 | | _, R2, "coucou" -> ()
+7-7
testsuite/tests/basic/patmatch_incoherence.ml
···3535| { x = None } -> ()
3636;;
3737[%%expect{|
3838-Line 1, characters 0-70:
3838+Lines 1-3, characters 0-20:
39391 | match { x = assert false } with
40402 | | { x = 3 } -> ()
41413 | | { x = None } -> ()
···5050| { x = "" } -> ()
5151;;
5252[%%expect{|
5353-Line 1, characters 0-71:
5353+Lines 1-3, characters 0-18:
54541 | match { x = assert false } with
55552 | | { x = None } -> ()
56563 | | { x = "" } -> ()
···6565| { x = `X } -> ()
6666;;
6767[%%expect{|
6868-Line 1, characters 0-71:
6868+Lines 1-3, characters 0-18:
69691 | match { x = assert false } with
70702 | | { x = None } -> ()
71713 | | { x = `X } -> ()
···8080| { x = 3 } -> ()
8181;;
8282[%%expect{|
8383-Line 1, characters 0-70:
8383+Lines 1-3, characters 0-17:
84841 | match { x = assert false } with
85852 | | { x = [||] } -> ()
86863 | | { x = 3 } -> ()
···9595| { x = 3 } -> ()
9696;;
9797[%%expect{|
9898-Line 1, characters 0-68:
9898+Lines 1-3, characters 0-17:
99991 | match { x = assert false } with
1001002 | | { x = `X } -> ()
1011013 | | { x = 3 } -> ()
···110110| { x = 3 } -> ()
111111;;
112112[%%expect{|
113113-Line 1, characters 0-74:
113113+Lines 1-3, characters 0-17:
1141141 | match { x = assert false } with
1151152 | | { x = `X "lol" } -> ()
1161163 | | { x = 3 } -> ()
···126126| { x = 3 } -> ()
127127;;
128128[%%expect{|
129129-Line 1, characters 0-95:
129129+Lines 1-4, characters 0-17:
1301301 | match { x = assert false } with
1311312 | | { x = (2., "") } -> ()
1321323 | | { x = None } -> ()
···115115 end
116116end
117117[%%expect{|
118118-Line 3, characters 4-56:
118118+Lines 3-6, characters 4-7:
1191193 | ....open struct
1201204 | type t = T
1211215 | let x = T
···135135 let g = y
136136end
137137[%%expect{|
138138-Line 3, characters 4-40:
138138+Lines 3-5, characters 4-7:
1391393 | ....open struct
1401404 | type t = T
1411415 | end
+4-4
testsuite/tests/let-syntax/let_syntax.ml
···217217 ^
218218Error: This expression has type int but an expression was expected of type
219219 float
220220- Hint: Did you mean `1.'?
220220+ Hint: Did you mean `1.'?
221221|}];;
222222223223module Ill_typed_3 = struct
···290290 x + y + z
291291 );;
292292[%%expect{|
293293-Line 3, characters 9-44:
293293+Lines 3-5, characters 9-14:
2942943 | .........x = 1
2952954 | and+ y = 2
2962965 | and+ z = 3...
···320320 x + y + z
321321 );;
322322[%%expect{|
323323-Line 3, characters 9-29:
323323+Lines 3-4, characters 9-14:
3243243 | .........x = 1
3253254 | and+ y = 2
326326Error: These bindings have type int * int but bindings were expected of type
···512512 return (first ^ second)
513513 );;
514514[%%expect{|
515515-Line 6, characters 4-55:
515515+Lines 6-7, characters 4-29:
5165166 | ....let* second = read in
5175177 | return (first ^ second)
518518Error: This expression has type
+8-8
testsuite/tests/letrec-check/basic.ml
···172172 done
173173and y = x; ();;
174174[%%expect{|
175175-Line 2, characters 2-52:
175175+Lines 2-4, characters 2-6:
1761762 | ..for i = 0 to 1 do
1771773 | let z = y in ignore z
1781784 | done
···185185 done
186186and y = 10;;
187187[%%expect{|
188188-Line 2, characters 2-33:
188188+Lines 2-4, characters 2-6:
1891892 | ..for i = 0 to y do
1901903 | ()
1911914 | done
···198198 done
199199and y = 0;;
200200[%%expect{|
201201-Line 2, characters 2-34:
201201+Lines 2-4, characters 2-6:
2022022 | ..for i = y to 10 do
2032033 | ()
2042044 | done
···211211 done
212212and y = x; ();;
213213[%%expect{|
214214-Line 2, characters 2-49:
214214+Lines 2-4, characters 2-6:
2152152 | ..while false do
2162163 | let y = x in ignore y
2172174 | done
···224224 done
225225and y = false;;
226226[%%expect{|
227227-Line 2, characters 2-26:
227227+Lines 2-4, characters 2-6:
2282282 | ..while y do
2292293 | ()
2302304 | done
···237237 done
238238and y = false;;
239239[%%expect{|
240240-Line 2, characters 2-45:
240240+Lines 2-4, characters 2-6:
2412412 | ..while y do
2422423 | let y = x in ignore y
2432434 | done
···320320and y = match x with
321321 z -> ("y", z);;
322322[%%expect{|
323323-Line 2, characters 2-85:
323323+Lines 2-4, characters 2-30:
3243242 | ..match let _ = y in raise Not_found with
3253253 | _ -> "x"
3263264 | | exception Not_found -> "z"
···346346 and y = ref wrong
347347 in ref ("foo" ^ ! ! !x);;
348348[%%expect{|
349349-Line 10, characters 2-65:
349349+Lines 10-12, characters 2-25:
35035010 | ..let rec x = ref y
35135111 | and y = ref wrong
35235212 | in ref ("foo" ^ ! ! !x)..
···1818and (m : (module T)) =
1919 (module (struct exception A of int end) : T);;
2020[%%expect{|
2121-Line 2, characters 2-36:
2121+Lines 2-3, characters 2-8:
22222 | ..let module M = (val m) in
23233 | M.A 42
2424Error: This kind of expression is not allowed as right-hand side of `let rec'
+1-1
testsuite/tests/letrec-check/modules.ml
···3737 module N = struct let y = x end
3838 end in M.N.y;;
3939[%%expect{|
4040-Line 2, characters 2-74:
4040+Lines 2-4, characters 2-14:
41412 | ..let module M = struct
42423 | module N = struct let y = x end
43434 | end in M.N.y..
···11-Line 5, characters 2-67:
11+Lines 5-6, characters 2-3:
225 | ..let y = if false then (fun z -> 1) else (fun z -> x 4 + 1) in
336 | y..
44Error: This kind of expression is not allowed as right-hand side of `let rec'
+2-2
testsuite/tests/letrec-check/unboxed.ml
···5959[%%expect{|
6060type a = { a : b; } [@@unboxed]
6161and b = X of a | Y
6262-Line 5, characters 2-75:
6262+Lines 5-9, characters 2-10:
63635 | ..{a=
64646 | (if Sys.opaque_identity true then
65657 | X a
···9999[%%expect{|
100100type d = D of e [@@unboxed]
101101and e = V of d | W
102102-Line 5, characters 2-72:
102102+Lines 5-9, characters 2-9:
1031035 | ..D
1041046 | (if Sys.opaque_identity true then
1051057 | V d
···2424 ^
2525Error: This expression has type int but an expression was expected of type
2626 float
2727- Hint: Did you mean `1.'?
2727+ Hint: Did you mean `1.'?
2828Line 4, characters 2-4:
29294 | 2 in
3030 ^^
···33332 | let x = (1
3434 ^
3535 This '(' might be unmatched
3636-Line 2, characters 8-17:
3636+Lines 2-4, characters 8-2:
37372 | ........(1
38383 | +
39394 | 2)...
···60601 | let x = (1
6161 ^
6262 This '(' might be unmatched
6363-File "error_highlighting_use4.ml", line 1, characters 8-17:
6363+File "error_highlighting_use4.ml", lines 1-3, characters 8-2:
64641 | ........(1
65652 | +
66663 | 2)...
···99 ^
1010Error: This expression has type int but an expression was expected of type
1111 int32
1212- Hint: Did you mean `1l'?
1212+ Hint: Did you mean `1l'?
1313|}]
14141515let _ : int32 * int32 = 42l, 43;;
···1919 ^^
2020Error: This expression has type int but an expression was expected of type
2121 int32
2222- Hint: Did you mean `43l'?
2222+ Hint: Did you mean `43l'?
2323|}]
24242525let _ : int32 * nativeint = 42l, 43;;
···2929 ^^
3030Error: This expression has type int but an expression was expected of type
3131 nativeint
3232- Hint: Did you mean `43n'?
3232+ Hint: Did you mean `43n'?
3333|}]
34343535let _ = min 6L 7;;
···3939 ^
4040Error: This expression has type int but an expression was expected of type
4141 int64
4242- Hint: Did you mean `7L'?
4242+ Hint: Did you mean `7L'?
4343|}]
44444545let _ : float = 123;;
···4949 ^^^
5050Error: This expression has type int but an expression was expected of type
5151 float
5252- Hint: Did you mean `123.'?
5252+ Hint: Did you mean `123.'?
5353|}]
54545555(* no hint *)
···7474 ^
7575Error: This pattern matches values of type int
7676 but a pattern was expected which matches values of type int32
7777- Hint: Did you mean `0l'?
7777+ Hint: Did you mean `0l'?
7878|}, Principal{|
7979Line 2, characters 4-5:
80802 | | 0 -> 0l
···9292 ^
9393Error: This pattern matches values of type int
9494 but a pattern was expected which matches values of type int64
9595- Hint: Did you mean `2L'?
9595+ Hint: Did you mean `2L'?
9696|}]
97979898(* symmetric *)
···103103 ^^
104104Error: This expression has type int64 but an expression was expected of type
105105 int32
106106- Hint: Did you mean `1l'?
106106+ Hint: Did you mean `1l'?
107107|}]
108108let _ : float = 1L;;
109109[%%expect{|
···112112 ^^
113113Error: This expression has type int64 but an expression was expected of type
114114 float
115115- Hint: Did you mean `1.'?
115115+ Hint: Did you mean `1.'?
116116|}]
117117let _ : int64 = 1n;;
118118[%%expect{|
···121121 ^^
122122Error: This expression has type nativeint
123123 but an expression was expected of type int64
124124- Hint: Did you mean `1L'?
124124+ Hint: Did you mean `1L'?
125125|}]
126126let _ : nativeint = 1l;;
127127[%%expect{|
···130130 ^^
131131Error: This expression has type int32 but an expression was expected of type
132132 nativeint
133133- Hint: Did you mean `1n'?
133133+ Hint: Did you mean `1n'?
134134|}]
135135136136(* not implemented *)
···7575 ^
7676Error: This expression has type int but an expression was expected of type
7777 float
7878- Hint: Did you mean `0.'?
7878+ Hint: Did you mean `0.'?
7979|}]
+321-22
testsuite/tests/typing-extensions/extensions.ml
···11(* TEST
22- * toplevel
22+ * expect
33*)
4455(* Ignore OCAMLRUNPARAM=b to be reproducible *)
66Printexc.record_backtrace false;;
77+[%%expect {|
88+- : unit = ()
99+|}]
710811type foo = ..
912;;
1313+[%%expect {|
1414+type foo = ..
1515+|}]
10161117type foo +=
1218 A
1319 | B of int
1420;;
2121+[%%expect {|
2222+type foo += A | B of int
2323+|}]
15241625let is_a x =
1726 match x with
1827 A -> true
1928 | _ -> false
2029;;
3030+[%%expect {|
3131+val is_a : foo -> bool = <fun>
3232+|}]
21332234(* The type must be open to create extension *)
23352436type foo
2537;;
3838+[%%expect {|
3939+type foo
4040+|}]
26412727-type foo += A of int (* Error type is not open *)
4242+type foo += A of int
2843;;
4444+[%%expect {|
4545+Line 1, characters 0-20:
4646+1 | type foo += A of int
4747+ ^^^^^^^^^^^^^^^^^^^^
4848+Error: Type definition foo is not extensible
4949+|}]
29503051(* The type must be public to create extension *)
31523253type foo = private ..
3354;;
5555+[%%expect {|
5656+type foo = private ..
5757+|}]
34583535-type foo += A of int (* Error type is private *)
5959+type foo += A of int
3660;;
6161+[%%expect {|
6262+Line 1, characters 12-20:
6363+1 | type foo += A of int
6464+ ^^^^^^^^
6565+Error: Cannot extend private type definition foo
6666+|}]
37673868(* The type parameters must match *)
39694070type 'a foo = ..
4171;;
7272+[%%expect {|
7373+type 'a foo = ..
7474+|}]
42754343-type ('a, 'b) foo += A of int (* Error: type parameter mismatch *)
7676+type ('a, 'b) foo += A of int
4477;;
7878+[%%expect {|
7979+Line 1, characters 0-29:
8080+1 | type ('a, 'b) foo += A of int
8181+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
8282+Error: This extension does not match the definition of type foo
8383+ They have different arities.
8484+|}]
45854686(* In a signature the type can be private *)
4787···5191 type foo += A of float
5292end
5393;;
9494+[%%expect {|
9595+module type S = sig type foo = private .. type foo += A of float end
9696+|}]
54975598(* But it must still be extensible *)
569957100module type S =
58101sig
59102 type foo
6060- type foo += B of float (* Error: foo does not have an extensible type *)
103103+ type foo += B of float
61104end
62105;;
106106+[%%expect {|
107107+Line 4, characters 2-24:
108108+4 | type foo += B of float
109109+ ^^^^^^^^^^^^^^^^^^^^^^
110110+Error: Type definition foo is not extensible
111111+|}]
6311264113(* Signatures can change the grouping of extensions *)
6511466115type foo = ..
67116;;
117117+[%%expect {|
118118+type foo = ..
119119+|}]
6812069121module M = struct
70122 type foo +=
···76128 | D of float
77129end
78130;;
131131+[%%expect {|
132132+module M :
133133+ sig
134134+ type foo += A of int | B of string
135135+ type foo += C of int | D of float
136136+137137+ end
138138+|}]
7913980140module type S = sig
81141 type foo +=
···87147 type foo += A of int
88148end
89149;;
150150+[%%expect {|
151151+module type S =
152152+ sig
153153+ type foo += B of string | C of int
154154+ type foo += D of float
155155+ type foo += A of int
156156+ end
157157+|}]
9015891159module M_S = (M : S)
92160;;
161161+[%%expect {|
162162+module M_S : S
163163+|}]
9316494165(* Extensions can be GADTs *)
9516696167type 'a foo = ..
97168;;
169169+[%%expect {|
170170+type 'a foo = ..
171171+|}]
9817299173type _ foo +=
100174 A : int -> int foo
101175 | B : int foo
102176;;
177177+[%%expect {|
178178+type _ foo += A : int -> int foo | B : int foo
179179+|}]
103180104181let get_num : type a. a foo -> a -> a option = fun f i1 ->
105182 match f with
106183 A i2 -> Some (i1 + i2)
107184 | _ -> None
108185;;
186186+[%%expect {|
187187+val get_num : 'a foo -> 'a -> 'a option = <fun>
188188+|}]
109189110190(* Extensions must obey constraints *)
111191112192type 'a foo = .. constraint 'a = [> `Var ]
113193;;
194194+[%%expect {|
195195+type 'a foo = .. constraint 'a = [> `Var ]
196196+|}]
114197115198type 'a foo += A of 'a
116199;;
200200+[%%expect {|
201201+type 'a foo += A of 'a
202202+|}]
117203118118-let a = A 9 (* ERROR: Constraints not met *)
204204+let a = A 9
119205;;
206206+[%%expect {|
207207+Line 1, characters 10-11:
208208+1 | let a = A 9
209209+ ^
210210+Error: This expression has type int but an expression was expected of type
211211+ [> `Var ]
212212+|}]
120213121121-type 'a foo += B : int foo (* ERROR: Constraints not met *)
214214+type 'a foo += B : int foo
122215;;
216216+[%%expect {|
217217+Line 1, characters 19-22:
218218+1 | type 'a foo += B : int foo
219219+ ^^^
220220+Error: This type int should be an instance of type [> `Var ]
221221+|}]
123222124223(* Signatures can make an extension private *)
125224126225type foo = ..
127226;;
227227+[%%expect {|
228228+type foo = ..
229229+|}]
128230129231module M = struct type foo += A of int end
130232;;
233233+[%%expect {|
234234+module M : sig type foo += A of int end
235235+|}]
131236132237let a1 = M.A 10
133238;;
239239+[%%expect {|
240240+val a1 : foo = M.A 10
241241+|}]
134242135243module type S = sig type foo += private A of int end
136244;;
245245+[%%expect {|
246246+module type S = sig type foo += private A of int end
247247+|}]
137248138249module M_S = (M : S)
139250;;
251251+[%%expect {|
252252+module M_S : S
253253+|}]
140254141255let is_s x =
142256 match x with
143257 M_S.A _ -> true
144258 | _ -> false
145259;;
260260+[%%expect {|
261261+val is_s : foo -> bool = <fun>
262262+|}]
146263147147-let a2 = M_S.A 20 (* ERROR: Cannot create a value using a private constructor *)
264264+let a2 = M_S.A 20
148265;;
266266+[%%expect {|
267267+Line 1, characters 9-17:
268268+1 | let a2 = M_S.A 20
269269+ ^^^^^^^^
270270+Error: Cannot use private constructor A to create values of type foo
271271+|}]
149272150273(* Extensions can be rebound *)
151274152275type foo = ..
153276;;
277277+[%%expect {|
278278+type foo = ..
279279+|}]
154280155281module M = struct type foo += A1 of int end
156282;;
283283+[%%expect {|
284284+module M : sig type foo += A1 of int end
285285+|}]
157286158287type foo += A2 = M.A1
159288;;
289289+[%%expect {|
290290+type foo += A2 of int
291291+|}]
160292161293type bar = ..
162294;;
295295+[%%expect {|
296296+type bar = ..
297297+|}]
163298164164-type bar += A3 = M.A1 (* Error: rebind wrong type *)
299299+type bar += A3 = M.A1
165300;;
301301+[%%expect {|
302302+Line 1, characters 17-21:
303303+1 | type bar += A3 = M.A1
304304+ ^^^^
305305+Error: The constructor M.A1 has type foo but was expected to be of type bar
306306+|}]
166307167308module M = struct type foo += private B1 of int end
168309;;
310310+[%%expect {|
311311+module M : sig type foo += private B1 of int end
312312+|}]
169313170314type foo += private B2 = M.B1
171315;;
316316+[%%expect {|
317317+type foo += private B2 of int
318318+|}]
172319173173-type foo += B3 = M.B1 (* Error: rebind private extension *)
320320+type foo += B3 = M.B1
174321;;
322322+[%%expect {|
323323+Line 1, characters 17-21:
324324+1 | type foo += B3 = M.B1
325325+ ^^^^
326326+Error: The constructor M.B1 is private
327327+|}]
175328176176-type foo += C = Unknown (* Error: unbound extension *)
329329+type foo += C = Unknown
177330;;
331331+[%%expect {|
332332+Line 1, characters 16-23:
333333+1 | type foo += C = Unknown
334334+ ^^^^^^^
335335+Error: Unbound constructor Unknown
336336+|}]
178337179338(* Extensions can be rebound even if type is private *)
180339181340module M : sig type foo = private .. type foo += A1 of int end
182182- = struct type foo = .. type foo += A1 of int end
341341+ = struct type foo = .. type foo += A1 of int end;;
342342+[%%expect {|
343343+module M : sig type foo = private .. type foo += A1 of int end
344344+|}]
183345184184-type M.foo += A2 = M.A1
346346+type M.foo += A2 = M.A1;;
347347+[%%expect {|
348348+type M.foo += A2 of int
349349+|}]
185350186351(* Rebinding handles abbreviations *)
187352188353type 'a foo = ..
189354;;
355355+[%%expect {|
356356+type 'a foo = ..
357357+|}]
190358191359type 'a foo1 = 'a foo = ..
192360;;
361361+[%%expect {|
362362+type 'a foo1 = 'a foo = ..
363363+|}]
193364194365type 'a foo2 = 'a foo = ..
195366;;
367367+[%%expect {|
368368+type 'a foo2 = 'a foo = ..
369369+|}]
196370197371type 'a foo1 +=
198372 A of int
199373 | B of 'a
200374 | C : int foo1
201375;;
376376+[%%expect {|
377377+type 'a foo1 += A of int | B of 'a | C : int foo1
378378+|}]
202379203380type 'a foo2 +=
204381 D = A
205382 | E = B
206383 | F = C
207384;;
385385+[%%expect {|
386386+type 'a foo2 += D of int | E of 'a | F : int foo2
387387+|}]
208388209389(* Extensions must obey variances *)
210390211391type +'a foo = ..
212392;;
393393+[%%expect {|
394394+type +'a foo = ..
395395+|}]
213396214397type 'a foo += A of (int -> 'a)
215398;;
399399+[%%expect {|
400400+type 'a foo += A of (int -> 'a)
401401+|}]
216402217403type 'a foo += B of ('a -> int)
218218- (* ERROR: Parameter variances are not satisfied *)
219404;;
405405+[%%expect {|
406406+Line 1, characters 0-31:
407407+1 | type 'a foo += B of ('a -> int)
408408+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
409409+Error: In this definition, expected parameter variances are not satisfied.
410410+ The 1st type parameter was expected to be covariant,
411411+ but it is injective contravariant.
412412+|}]
220413221414type _ foo += C : ('a -> int) -> 'a foo
222222- (* ERROR: Parameter variances are not satisfied *)
223415;;
416416+[%%expect {|
417417+Line 1, characters 0-39:
418418+1 | type _ foo += C : ('a -> int) -> 'a foo
419419+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
420420+Error: In this definition, expected parameter variances are not satisfied.
421421+ The 1st type parameter was expected to be covariant,
422422+ but it is injective contravariant.
423423+|}]
224424225425type 'a bar = ..
226426;;
427427+[%%expect {|
428428+type 'a bar = ..
429429+|}]
227430228228-type +'a bar += D of (int -> 'a) (* ERROR: type variances do not match *)
431431+type +'a bar += D of (int -> 'a)
229432;;
433433+[%%expect {|
434434+Line 1, characters 0-32:
435435+1 | type +'a bar += D of (int -> 'a)
436436+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
437437+Error: This extension does not match the definition of type bar
438438+ Their variances do not agree.
439439+|}]
230440231441(* Exceptions are compatible with extensions *)
232442···239449 exception Foo of int * float
240450end
241451;;
452452+[%%expect {|
453453+module M : sig type exn += Foo of int * float | Bar : 'a list -> exn end
454454+|}]
242455243456module M : sig
244457 exception Bar : 'a list -> exn
···249462 | Bar : 'a list -> exn
250463end
251464;;
465465+[%%expect {|
466466+module M :
467467+ sig exception Bar : 'a list -> exn exception Foo of int * float end
468468+|}]
252469253470exception Foo of int * float
254471;;
472472+[%%expect {|
473473+exception Foo of int * float
474474+|}]
255475256476exception Bar : 'a list -> exn
257477;;
478478+[%%expect {|
479479+exception Bar : 'a list -> exn
480480+|}]
258481259482module M : sig
260483 type exn +=
···265488 exception Foo = Foo
266489end
267490;;
491491+[%%expect {|
492492+module M : sig type exn += Foo of int * float | Bar : 'a list -> exn end
493493+|}]
268494269495(* Test toplevel printing *)
270496271497type foo = ..
272498;;
499499+[%%expect {|
500500+type foo = ..
501501+|}]
273502274503type foo +=
275504 Foo of int * int option
276505 | Bar of int option
277506;;
507507+[%%expect {|
508508+type foo += Foo of int * int option | Bar of int option
509509+|}]
278510279511let x = Foo(3, Some 4), Bar(Some 5) (* Prints Foo and Bar successfully *)
280512;;
513513+[%%expect {|
514514+val x : foo * foo = (Foo (3, Some 4), Bar (Some 5))
515515+|}]
281516282517type foo += Foo of string
283518;;
519519+[%%expect {|
520520+type foo += Foo of string
521521+|}]
284522285523let y = x (* Prints Bar but not Foo (which has been shadowed) *)
286524;;
525525+[%%expect {|
526526+val y : foo * foo = (<extension>, Bar (Some 5))
527527+|}]
287528288529exception Foo of int * int option
289530;;
531531+[%%expect {|
532532+exception Foo of int * int option
533533+|}]
290534291535exception Bar of int option
292536;;
537537+[%%expect {|
538538+exception Bar of int option
539539+|}]
293540294541let x = Foo(3, Some 4), Bar(Some 5) (* Prints Foo and Bar successfully *)
295542;;
543543+[%%expect {|
544544+val x : exn * exn = (Foo (3, Some 4), Bar (Some 5))
545545+|}]
296546297547type foo += Foo of string
298548;;
549549+[%%expect {|
550550+type foo += Foo of string
551551+|}]
299552300553let y = x (* Prints Bar and part of Foo (which has been shadowed) *)
301554;;
555555+[%%expect {|
556556+val y : exn * exn = (Foo (3, _), Bar (Some 5))
557557+|}]
302558303559(* Test Obj functions *)
304560305561type foo = ..
306562;;
563563+[%%expect {|
564564+type foo = ..
565565+|}]
307566308567type foo +=
309568 Foo
310569 | Bar of int
311570;;
571571+[%%expect {|
572572+type foo += Foo | Bar of int
573573+|}]
312574313575let extension_name e = Obj.Extension_constructor.name
314314- (Obj.Extension_constructor.of_val e);;
576576+ (Obj.Extension_constructor.of_val e)
577577+;;
578578+[%%expect {|
579579+val extension_name : 'a -> string = <fun>
580580+|}]
581581+315582let extension_id e = Obj.Extension_constructor.id
316316- (Obj.Extension_constructor.of_val e);;
583583+ (Obj.Extension_constructor.of_val e)
584584+;;
585585+[%%expect {|
586586+val extension_id : 'a -> int = <fun>
587587+|}]
317588318589let n1 = extension_name Foo
319590;;
591591+[%%expect {|
592592+val n1 : string = "Foo"
593593+|}]
320594321595let n2 = extension_name (Bar 1)
322596;;
597597+[%%expect {|
598598+val n2 : string = "Bar"
599599+|}]
323600324324-let t = (extension_id (Bar 2)) = (extension_id (Bar 3)) (* true *)
601601+let t = (extension_id (Bar 2)) = (extension_id (Bar 3))
325602;;
603603+[%%expect {|
604604+val t : bool = true
605605+|}]
326606327327-let f = (extension_id (Bar 2)) = (extension_id Foo) (* false *)
607607+let f = (extension_id (Bar 2)) = (extension_id Foo)
328608;;
609609+[%%expect {|
610610+val f : bool = false
611611+|}]
329612330613let is_foo x = (extension_id Foo) = (extension_id x)
614614+;;
615615+[%%expect {|
616616+val is_foo : 'a -> bool = <fun>
617617+|}]
331618332619type foo += Foo
333620;;
621621+[%%expect {|
622622+type foo += Foo
623623+|}]
334624335625let f = is_foo Foo
336626;;
627627+[%%expect {|
628628+val f : bool = false
629629+|}]
337630338338-let _ = Obj.Extension_constructor.of_val 7 (* Invalid_arg *)
631631+let _ = Obj.Extension_constructor.of_val 7
339632;;
633633+[%%expect {|
634634+Exception: Invalid_argument "Obj.extension_constructor".
635635+|}]
340636341341-let _ = Obj.Extension_constructor.of_val (object method m = 3 end) (* Invalid_arg *)
637637+let _ = Obj.Extension_constructor.of_val (object method m = 3 end)
342638;;
639639+[%%expect {|
640640+Exception: Invalid_argument "Obj.extension_constructor".
641641+|}]
···11-- : unit = ()
22-type foo = ..
33-type foo += A | B of int
44-val is_a : foo -> bool = <fun>
55-type foo
66-Line 2, characters 0-20:
77-2 | type foo += A of int (* Error type is not open *)
88- ^^^^^^^^^^^^^^^^^^^^
99-Error: Type definition foo is not extensible
1010-type foo = private ..
1111-Line 2, characters 12-20:
1212-2 | type foo += A of int (* Error type is private *)
1313- ^^^^^^^^
1414-Error: Cannot extend private type definition foo
1515-type 'a foo = ..
1616-Line 2, characters 0-29:
1717-2 | type ('a, 'b) foo += A of int (* Error: type parameter mismatch *)
1818- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
1919-Error: This extension does not match the definition of type foo
2020- They have different arities.
2121-module type S = sig type foo = private .. type foo += A of float end
2222-Line 7, characters 2-24:
2323-7 | type foo += B of float (* Error: foo does not have an extensible type *)
2424- ^^^^^^^^^^^^^^^^^^^^^^
2525-Error: Type definition foo is not extensible
2626-type foo = ..
2727-module M :
2828- sig
2929- type foo += A of int | B of string
3030- type foo += C of int | D of float
3131-3232- end
3333-module type S =
3434- sig
3535- type foo += B of string | C of int
3636- type foo += D of float
3737- type foo += A of int
3838- end
3939-module M_S : S
4040-type 'a foo = ..
4141-type _ foo += A : int -> int foo | B : int foo
4242-val get_num : 'a foo -> 'a -> 'a option = <fun>
4343-type 'a foo = .. constraint 'a = [> `Var ]
4444-type 'a foo += A of 'a
4545-Line 2, characters 10-11:
4646-2 | let a = A 9 (* ERROR: Constraints not met *)
4747- ^
4848-Error: This expression has type int but an expression was expected of type
4949- [> `Var ]
5050-Line 2, characters 19-22:
5151-2 | type 'a foo += B : int foo (* ERROR: Constraints not met *)
5252- ^^^
5353-Error: This type int should be an instance of type [> `Var ]
5454-type foo = ..
5555-module M : sig type foo += A of int end
5656-val a1 : foo = M.A 10
5757-module type S = sig type foo += private A of int end
5858-module M_S : S
5959-val is_s : foo -> bool = <fun>
6060-Line 2, characters 9-17:
6161-2 | let a2 = M_S.A 20 (* ERROR: Cannot create a value using a private constructor *)
6262- ^^^^^^^^
6363-Error: Cannot create values of the private type foo
6464-type foo = ..
6565-module M : sig type foo += A1 of int end
6666-type foo += A2 of int
6767-type bar = ..
6868-Line 2, characters 17-21:
6969-2 | type bar += A3 = M.A1 (* Error: rebind wrong type *)
7070- ^^^^
7171-Error: The constructor M.A1 has type foo but was expected to be of type bar
7272-module M : sig type foo += private B1 of int end
7373-type foo += private B2 of int
7474-Line 2, characters 17-21:
7575-2 | type foo += B3 = M.B1 (* Error: rebind private extension *)
7676- ^^^^
7777-Error: The constructor M.B1 is private
7878-Line 2, characters 16-23:
7979-2 | type foo += C = Unknown (* Error: unbound extension *)
8080- ^^^^^^^
8181-Error: Unbound constructor Unknown
8282-module M : sig type foo = private .. type foo += A1 of int end
8383-type M.foo += A2 of int
8484-type 'a foo = ..
8585-type 'a foo1 = 'a foo = ..
8686-type 'a foo2 = 'a foo = ..
8787-type 'a foo1 += A of int | B of 'a | C : int foo1
8888-type 'a foo2 += D of int | E of 'a | F : int foo2
8989-type +'a foo = ..
9090-type 'a foo += A of (int -> 'a)
9191-Line 2, characters 0-31:
9292-2 | type 'a foo += B of ('a -> int)
9393- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
9494-Error: In this definition, expected parameter variances are not satisfied.
9595- The 1st type parameter was expected to be covariant,
9696- but it is injective contravariant.
9797-Line 2, characters 0-39:
9898-2 | type _ foo += C : ('a -> int) -> 'a foo
9999- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
100100-Error: In this definition, expected parameter variances are not satisfied.
101101- The 1st type parameter was expected to be covariant,
102102- but it is injective contravariant.
103103-type 'a bar = ..
104104-Line 2, characters 0-32:
105105-2 | type +'a bar += D of (int -> 'a) (* ERROR: type variances do not match *)
106106- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
107107-Error: This extension does not match the definition of type bar
108108- Their variances do not agree.
109109-module M : sig type exn += Foo of int * float | Bar : 'a list -> exn end
110110-module M :
111111- sig exception Bar : 'a list -> exn exception Foo of int * float end
112112-exception Foo of int * float
113113-exception Bar : 'a list -> exn
114114-module M : sig type exn += Foo of int * float | Bar : 'a list -> exn end
115115-type foo = ..
116116-type foo += Foo of int * int option | Bar of int option
117117-val x : foo * foo = (Foo (3, Some 4), Bar (Some 5))
118118-type foo += Foo of string
119119-val y : foo * foo = (<extension>, Bar (Some 5))
120120-exception Foo of int * int option
121121-exception Bar of int option
122122-val x : exn * exn = (Foo (3, Some 4), Bar (Some 5))
123123-type foo += Foo of string
124124-val y : exn * exn = (Foo (3, _), Bar (Some 5))
125125-type foo = ..
126126-type foo += Foo | Bar of int
127127-val extension_name : 'a -> string = <fun>
128128-val extension_id : 'a -> int = <fun>
129129-val n1 : string = "Foo"
130130-val n2 : string = "Bar"
131131-val t : bool = true
132132-val f : bool = false
133133-val is_foo : 'a -> bool = <fun>
134134-type foo += Foo
135135-val f : bool = false
136136-Exception: Invalid_argument "Obj.extension_constructor".
137137-Exception: Invalid_argument "Obj.extension_constructor".
138138-
+225-13
testsuite/tests/typing-extensions/open_types.ml
···11(* TEST
22- * toplevel
22+ * expect
33*)
4455type foo = ..
66;;
77+[%%expect {|
88+type foo = ..
99+|}]
710811(* Check that abbreviations work *)
9121013type bar = foo = ..
1114;;
1515+[%%expect {|
1616+type bar = foo = ..
1717+|}]
12181319type baz = foo = ..
1420;;
2121+[%%expect {|
2222+type baz = foo = ..
2323+|}]
15241625type bar += Bar1 of int
1726;;
2727+[%%expect {|
2828+type bar += Bar1 of int
2929+|}]
18301931type baz += Bar2 of int
2032;;
3333+[%%expect {|
3434+type baz += Bar2 of int
3535+|}]
21362237module M = struct type bar += Foo of float end
2338;;
3939+[%%expect {|
4040+module M : sig type bar += Foo of float end
4141+|}]
24422543module type S = sig type baz += Foo of float end
2644;;
4545+[%%expect {|
4646+module type S = sig type baz += Foo of float end
4747+|}]
27482849module M_S = (M : S)
2950;;
5151+[%%expect {|
5252+module M_S : S
5353+|}]
30543155(* Abbreviations need to be made open *)
32563357type foo = ..
3458;;
5959+[%%expect {|
6060+type foo = ..
6161+|}]
35623663type bar = foo
3764;;
6565+[%%expect {|
6666+type bar = foo
6767+|}]
38683939-type bar += Bar of int (* Error: type is not open *)
6969+type bar += Bar of int
4070;;
7171+[%%expect {|
7272+Line 1, characters 0-22:
7373+1 | type bar += Bar of int
7474+ ^^^^^^^^^^^^^^^^^^^^^^
7575+Error: Type definition bar is not extensible
7676+|}]
41774242-type baz = bar = .. (* Error: type kinds don't match *)
7878+type baz = bar = ..
4379;;
8080+[%%expect {|
8181+Line 1, characters 0-19:
8282+1 | type baz = bar = ..
8383+ ^^^^^^^^^^^^^^^^^^^
8484+Error: This variant or record definition does not match that of type bar
8585+ Their kinds differ.
8686+|}]
44874588(* Abbreviations need to match parameters *)
46894790type 'a foo = ..
4891;;
9292+[%%expect {|
9393+type 'a foo = ..
9494+|}]
49955050-type ('a, 'b) bar = 'a foo = .. (* Error: arrities do not match *)
9696+type ('a, 'b) bar = 'a foo = ..
5197;;
9898+[%%expect {|
9999+Line 1, characters 0-31:
100100+1 | type ('a, 'b) bar = 'a foo = ..
101101+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
102102+Error: This variant or record definition does not match that of type 'a foo
103103+ They have different arities.
104104+|}]
5210553106type ('a, 'b) foo = ..
54107;;
108108+[%%expect {|
109109+type ('a, 'b) foo = ..
110110+|}]
551115656-type ('a, 'b) bar = ('a, 'a) foo = .. (* Error: constraints do not match *)
112112+type ('a, 'b) bar = ('a, 'a) foo = ..
57113;;
114114+[%%expect {|
115115+Line 1, characters 0-37:
116116+1 | type ('a, 'b) bar = ('a, 'a) foo = ..
117117+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
118118+Error: This variant or record definition does not match that of type
119119+ ('a, 'a) foo
120120+ Their constraints differ.
121121+|}]
5812259123(* Check that signatures can hide exstensibility *)
6012461125module M = struct type foo = .. end
62126;;
127127+[%%expect {|
128128+module M : sig type foo = .. end
129129+|}]
6313064131module type S = sig type foo end
65132;;
133133+[%%expect {|
134134+module type S = sig type foo end
135135+|}]
6613667137module M_S = (M : S)
68138;;
139139+[%%expect {|
140140+module M_S : S
141141+|}]
691427070-type M_S.foo += Foo (* ERROR: Cannot extend a type that isn't "open" *)
143143+type M_S.foo += Foo
71144;;
145145+[%%expect {|
146146+Line 1, characters 0-19:
147147+1 | type M_S.foo += Foo
148148+ ^^^^^^^^^^^^^^^^^^^
149149+Error: Type definition M_S.foo is not extensible
150150+|}]
7215173152(* Check that signatures cannot add extensibility *)
7415375154module M = struct type foo end
76155;;
156156+[%%expect {|
157157+module M : sig type foo end
158158+|}]
7715978160module type S = sig type foo = .. end
79161;;
162162+[%%expect {|
163163+module type S = sig type foo = .. end
164164+|}]
801658181-module M_S = (M : S) (* ERROR: Signatures are not compatible *)
166166+module M_S = (M : S)
82167;;
168168+[%%expect {|
169169+Line 1, characters 14-15:
170170+1 | module M_S = (M : S)
171171+ ^
172172+Error: Signature mismatch:
173173+ Modules do not match: sig type foo = M.foo end is not included in S
174174+ Type declarations do not match:
175175+ type foo = M.foo
176176+ is not included in
177177+ type foo = ..
178178+ Their kinds differ.
179179+|}]
8318084181(* Check that signatures can make exstensibility private *)
8518286183module M = struct type foo = .. end
87184;;
185185+[%%expect {|
186186+module M : sig type foo = .. end
187187+|}]
8818889189module type S = sig type foo = private .. end
90190;;
191191+[%%expect {|
192192+module type S = sig type foo = private .. end
193193+|}]
9119492195module M_S = (M : S)
93196;;
197197+[%%expect {|
198198+module M_S : S
199199+|}]
942009595-type M_S.foo += Foo (* ERROR: Cannot extend a private extensible type *)
201201+type M_S.foo += Foo
96202;;
203203+[%%expect {|
204204+Line 1, characters 16-19:
205205+1 | type M_S.foo += Foo
206206+ ^^^
207207+Error: Cannot extend private type definition M_S.foo
208208+|}]
9720998210(* Check that signatures cannot make private extensibility public *)
99211100212module M = struct type foo = private .. end
101213;;
214214+[%%expect {|
215215+module M : sig type foo = private .. end
216216+|}]
102217103218module type S = sig type foo = .. end
104219;;
220220+[%%expect {|
221221+module type S = sig type foo = .. end
222222+|}]
105223106106-module M_S = (M : S) (* ERROR: Signatures are not compatible *)
224224+module M_S = (M : S)
107225;;
226226+[%%expect {|
227227+Line 1, characters 14-15:
228228+1 | module M_S = (M : S)
229229+ ^
230230+Error: Signature mismatch:
231231+ Modules do not match:
232232+ sig type foo = M.foo = private .. end
233233+ is not included in
234234+ S
235235+ Type declarations do not match:
236236+ type foo = M.foo = private ..
237237+ is not included in
238238+ type foo = ..
239239+ A private type would be revealed.
240240+|}]
108241109242110243(* Check that signatures maintain variances *)
111244112245module M = struct type +'a foo = .. type 'a bar = 'a foo = .. end
113246;;
247247+[%%expect {|
248248+module M : sig type +'a foo = .. type 'a bar = 'a foo = .. end
249249+|}]
114250115251module type S = sig type 'a foo = .. type 'a bar = 'a foo = .. end
116252;;
253253+[%%expect {|
254254+module type S = sig type 'a foo = .. type 'a bar = 'a foo = .. end
255255+|}]
117256118118-module M_S = (M : S) (* ERROR: Signatures are not compatible *)
257257+module M_S = (M : S)
119258;;
259259+[%%expect {|
260260+Line 1, characters 14-15:
261261+1 | module M_S = (M : S)
262262+ ^
263263+Error: Signature mismatch:
264264+ Modules do not match:
265265+ sig type 'a foo = 'a M.foo = .. type 'a bar = 'a foo = .. end
266266+ is not included in
267267+ S
268268+ Type declarations do not match:
269269+ type 'a foo = 'a M.foo = ..
270270+ is not included in
271271+ type 'a foo = ..
272272+ Their variances do not agree.
273273+|}]
120274121275(* Exn is an open type *)
122276123277type exn2 = exn = ..
124278;;
279279+[%%expect {|
280280+type exn2 = exn = ..
281281+|}]
282282+283283+(* PR#8579 exceptions can be private *)
284284+285285+type exn += private Foobar
286286+let _ = raise Foobar
287287+;;
288288+[%%expect {|
289289+type exn += private Foobar
290290+Line 2, characters 14-20:
291291+2 | let _ = raise Foobar
292292+ ^^^^^^
293293+Error: Cannot use private constructor Foobar to create values of type exn
294294+|}]
295295+125296126297(* Exhaustiveness *)
127298128299type foo = ..
129300type foo += Foo
130301let f = function Foo -> ()
131131-;; (* warn *)
302302+;;
303303+[%%expect {|
304304+type foo = ..
305305+type foo += Foo
306306+Line 3, characters 8-26:
307307+3 | let f = function Foo -> ()
308308+ ^^^^^^^^^^^^^^^^^^
309309+Warning 8: this pattern-matching is not exhaustive.
310310+Here is an example of a case that is not matched:
311311+*extension*
312312+Matching over values of extensible variant types (the *extension* above)
313313+must include a wild card pattern in order to be exhaustive.
314314+val f : foo -> unit = <fun>
315315+|}]
132316133317(* More complex exhaustiveness *)
134318···136320 | [Foo] -> 1
137321 | _::_::_ -> 3
138322 | [] -> 2
139139-;; (* warn *)
323323+;;
324324+[%%expect {|
325325+Lines 1-4, characters 8-11:
326326+1 | ........function
327327+2 | | [Foo] -> 1
328328+3 | | _::_::_ -> 3
329329+4 | | [] -> 2
330330+Warning 8: this pattern-matching is not exhaustive.
331331+Here is an example of a case that is not matched:
332332+*extension*::[]
333333+Matching over values of extensible variant types (the *extension* above)
334334+must include a wild card pattern in order to be exhaustive.
335335+val f : foo list -> int = <fun>
336336+|}]
140337141338142339(* PR#7330: exhaustiveness with GADTs *)
143340144341type t = ..
145342type t += IPair : (int * int) -> t ;;
343343+[%%expect {|
344344+type t = ..
345345+type t += IPair : (int * int) -> t
346346+|}]
146347147147-let f = function IPair (i, j) -> Format.sprintf "(%d, %d)" i j ;; (* warn *)
348348+let f = function IPair (i, j) -> Format.sprintf "(%d, %d)" i j ;;
349349+[%%expect {|
350350+Line 1, characters 8-62:
351351+1 | let f = function IPair (i, j) -> Format.sprintf "(%d, %d)" i j ;;
352352+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
353353+Warning 8: this pattern-matching is not exhaustive.
354354+Here is an example of a case that is not matched:
355355+*extension*
356356+Matching over values of extensible variant types (the *extension* above)
357357+must include a wild card pattern in order to be exhaustive.
358358+val f : t -> string = <fun>
359359+|}]
···11-type foo = ..
22-type bar = foo = ..
33-type baz = foo = ..
44-type bar += Bar1 of int
55-type baz += Bar2 of int
66-module M : sig type bar += Foo of float end
77-module type S = sig type baz += Foo of float end
88-module M_S : S
99-type foo = ..
1010-type bar = foo
1111-Line 2, characters 0-22:
1212-2 | type bar += Bar of int (* Error: type is not open *)
1313- ^^^^^^^^^^^^^^^^^^^^^^
1414-Error: Type definition bar is not extensible
1515-Line 2, characters 0-19:
1616-2 | type baz = bar = .. (* Error: type kinds don't match *)
1717- ^^^^^^^^^^^^^^^^^^^
1818-Error: This variant or record definition does not match that of type bar
1919- Their kinds differ.
2020-type 'a foo = ..
2121-Line 2, characters 0-31:
2222-2 | type ('a, 'b) bar = 'a foo = .. (* Error: arrities do not match *)
2323- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
2424-Error: This variant or record definition does not match that of type 'a foo
2525- They have different arities.
2626-type ('a, 'b) foo = ..
2727-Line 2, characters 0-37:
2828-2 | type ('a, 'b) bar = ('a, 'a) foo = .. (* Error: constraints do not match *)
2929- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
3030-Error: This variant or record definition does not match that of type
3131- ('a, 'a) foo
3232- Their constraints differ.
3333-module M : sig type foo = .. end
3434-module type S = sig type foo end
3535-module M_S : S
3636-Line 2, characters 0-19:
3737-2 | type M_S.foo += Foo (* ERROR: Cannot extend a type that isn't "open" *)
3838- ^^^^^^^^^^^^^^^^^^^
3939-Error: Type definition M_S.foo is not extensible
4040-module M : sig type foo end
4141-module type S = sig type foo = .. end
4242-Line 2, characters 14-15:
4343-2 | module M_S = (M : S) (* ERROR: Signatures are not compatible *)
4444- ^
4545-Error: Signature mismatch:
4646- Modules do not match: sig type foo = M.foo end is not included in S
4747- Type declarations do not match:
4848- type foo = M.foo
4949- is not included in
5050- type foo = ..
5151- Their kinds differ.
5252-module M : sig type foo = .. end
5353-module type S = sig type foo = private .. end
5454-module M_S : S
5555-Line 2, characters 16-19:
5656-2 | type M_S.foo += Foo (* ERROR: Cannot extend a private extensible type *)
5757- ^^^
5858-Error: Cannot extend private type definition M_S.foo
5959-module M : sig type foo = private .. end
6060-module type S = sig type foo = .. end
6161-Line 2, characters 14-15:
6262-2 | module M_S = (M : S) (* ERROR: Signatures are not compatible *)
6363- ^
6464-Error: Signature mismatch:
6565- Modules do not match:
6666- sig type foo = M.foo = private .. end
6767- is not included in
6868- S
6969- Type declarations do not match:
7070- type foo = M.foo = private ..
7171- is not included in
7272- type foo = ..
7373- A private type would be revealed.
7474-module M : sig type +'a foo = .. type 'a bar = 'a foo = .. end
7575-module type S = sig type 'a foo = .. type 'a bar = 'a foo = .. end
7676-Line 2, characters 14-15:
7777-2 | module M_S = (M : S) (* ERROR: Signatures are not compatible *)
7878- ^
7979-Error: Signature mismatch:
8080- Modules do not match:
8181- sig type 'a foo = 'a M.foo = .. type 'a bar = 'a foo = .. end
8282- is not included in
8383- S
8484- Type declarations do not match:
8585- type 'a foo = 'a M.foo = ..
8686- is not included in
8787- type 'a foo = ..
8888- Their variances do not agree.
8989-type exn2 = exn = ..
9090-Line 6, characters 8-26:
9191-6 | let f = function Foo -> ()
9292- ^^^^^^^^^^^^^^^^^^
9393-Warning 8: this pattern-matching is not exhaustive.
9494-Here is an example of a case that is not matched:
9595-*extension*
9696-Matching over values of extensible variant types (the *extension* above)
9797-must include a wild card pattern in order to be exhaustive.
9898-type foo = ..
9999-type foo += Foo
100100-val f : foo -> unit = <fun>
101101-Line 4, characters 8-60:
102102-4 | ........function
103103-5 | | [Foo] -> 1
104104-6 | | _::_::_ -> 3
105105-7 | | [] -> 2
106106-Warning 8: this pattern-matching is not exhaustive.
107107-Here is an example of a case that is not matched:
108108-*extension*::[]
109109-Matching over values of extensible variant types (the *extension* above)
110110-must include a wild card pattern in order to be exhaustive.
111111-val f : foo list -> int = <fun>
112112-type t = ..
113113-type t += IPair : (int * int) -> t
114114-Line 2, characters 8-62:
115115-2 | let f = function IPair (i, j) -> Format.sprintf "(%d, %d)" i j ;; (* warn *)
116116- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
117117-Warning 8: this pattern-matching is not exhaustive.
118118-Here is an example of a case that is not matched:
119119-*extension*
120120-Matching over values of extensible variant types (the *extension* above)
121121-must include a wild card pattern in order to be exhaustive.
122122-val f : t -> string = <fun>
123123-
+2-2
testsuite/tests/typing-gadts/didier.ml
···1212;;
1313[%%expect{|
1414type 'a ty = Int : int ty | Bool : bool ty
1515-Line 6, characters 2-30:
1515+Lines 6-7, characters 2-13:
16166 | ..match tag with
17177 | | Bool -> x
1818Warning 8: this pattern-matching is not exhaustive.
···2828 | Int -> x > 0
2929;;
3030[%%expect{|
3131-Line 2, characters 2-33:
3131+Lines 2-3, characters 2-16:
32322 | ..match tag with
33333 | | Int -> x > 0
3434Warning 8: this pattern-matching is not exhaustive.
+4-4
testsuite/tests/typing-gadts/or_patterns.ml
···240240;;
241241242242[%%expect{|
243243-Line 3, characters 4-57:
243243+Lines 3-4, characters 4-30:
2442443 | ....IntLit, ((3 : a) as x)
2452454 | | BoolLit, ((true : a) as x)............
246246Error: The variable x on the left-hand side of this or-pattern has type
···551551552552553553[%%expect{|
554554-Line 3, characters 4-20:
554554+Lines 3-4, characters 4-10:
5555553 | ....Int x
5565564 | | Bool x.....
557557Error: The variable x on the left-hand side of this or-pattern has type
···575575;;
576576577577[%%expect{|
578578-Line 3, characters 4-26:
578578+Lines 3-4, characters 4-10:
5795793 | ....Int (x : a)
5805804 | | Bool x.....
581581Error: The variable x on the left-hand side of this or-pattern has type
···731731 | _, _, _ -> ()
732732;;
733733[%%expect{|
734734-Line 3, characters 4-108:
734734+Lines 3-4, characters 4-65:
7357353 | ....IntLit, ({ contents = true } as x), _
7367364 | | BoolLit, _, ({ contents = true} as x)............
737737Error: The variable x on the left-hand side of this or-pattern has type
···2727 Eq : ('a, 'a, bool) binop
2828 | Leq : ('a, 'a, bool) binop
2929 | Add : (int, int, int) binop
3030-Line 12, characters 2-195:
3030+Lines 12-16, characters 2-36:
313112 | ..match bop, x, y with
323213 | | Eq, Bool x, Bool y -> Bool (if x then y else not y)
333314 | | Leq, Int x, Int y -> Bool (x <= y)
+2-2
testsuite/tests/typing-gadts/pr5981.ml
···1212 | A, B -> "f A B"
1313end;;
1414[%%expect{|
1515-Line 7, characters 47-84:
1515+Lines 7-8, characters 47-21:
16167 | ...............................................match l, r with
17178 | | A, B -> "f A B"
1818Warning 8: this pattern-matching is not exhaustive.
···3939 | A, B -> "f A B"
4040end;;
4141[%%expect{|
4242-Line 10, characters 15-52:
4242+Lines 10-11, characters 15-21:
434310 | ...............match l, r with
444411 | | A, B -> "f A B"
4545Warning 8: this pattern-matching is not exhaustive.
+1-1
testsuite/tests/typing-gadts/pr5985.ml
···3737 object constraint 'a = 'b T.t val x' : 'b = x method x = x' end
3838end;; (* fail *)
3939[%%expect{|
4040-Line 2, characters 2-86:
4040+Lines 2-3, characters 2-67:
41412 | ..class ['a] c x =
42423 | object constraint 'a = 'b T.t val x' : 'b = x method x = x' end
4343Error: In this definition, a type variable cannot be deduced
+2-2
testsuite/tests/typing-gadts/pr5989.ml
···2525[%%expect{|
2626type (_, _) t = Any : ('a, 'b) t | Eq : ('a, 'a) t
2727module M : sig type s = private [> `A ] val eq : (s, [ `A | `B ]) t end
2828-Line 16, characters 39-64:
2828+Lines 16-17, characters 39-16:
292916 | .......................................function
303017 | | Any -> "Any"
3131Warning 8: this pattern-matching is not exhaustive.
···5555 type s = private < a : int; .. >
5656 val eq : (s, < a : int; b : bool >) t
5757 end
5858-Line 12, characters 49-74:
5858+Lines 12-13, characters 49-16:
595912 | .................................................function
606013 | | Any -> "Any"
6161Warning 8: this pattern-matching is not exhaustive.
+1-1
testsuite/tests/typing-gadts/pr6241.ml
···21212222[%%expect{|
2323type (_, _) t = A : ('a, 'a) t | B : string -> ('a, 'b) t
2424-Line 8, characters 52-74:
2424+Lines 8-9, characters 52-13:
25258 | ....................................................function
26269 | | B s -> s
2727Warning 8: this pattern-matching is not exhaustive.
+1-1
testsuite/tests/typing-gadts/pr7160.ml
···1414 | String : string -> string t
1515 | Same : 'l t -> 'l t
1616val f : int t -> int = <fun>
1717-Line 4, characters 0-97:
1717+Lines 4-5, characters 0-77:
18184 | type 'a tt = 'a t =
19195 | Int : int -> int tt | String : string -> string tt | Same : 'l1 t -> 'l2 tt..
2020Error: This variant or record definition does not match that of type 'a t
+1-1
testsuite/tests/typing-gadts/pr7260.ml
···1919type bar = < bar : unit >
2020type _ ty = Int : int ty
2121type dyn = Dyn : 'a ty -> dyn
2222-Line 7, characters 0-108:
2222+Lines 7-12, characters 0-5:
2323 7 | class foo =
2424 8 | object (this)
2525 9 | method foo (Dyn ty) =
+1-1
testsuite/tests/typing-gadts/pr7378.ml
···1515 | A : 'a * 'b * ('b -> unit) -> t
1616end;; (* should fail *)
1717[%%expect{|
1818-Line 2, characters 2-54:
1818+Lines 2-3, characters 2-37:
19192 | ..type t = X.t =
20203 | | A : 'a * 'b * ('b -> unit) -> t
2121Error: This variant or record definition does not match that of type X.t
+7-7
testsuite/tests/typing-gadts/test.ml
···103103 end
104104;;
105105[%%expect{|
106106-Line 11, characters 6-34:
106106+Lines 11-12, characters 6-19:
10710711 | ......function
10810812 | | C2 x -> x
109109Warning 8: this pattern-matching is not exhaustive.
110110Here is an example of a case that is not matched:
111111C1 _
112112-Line 24, characters 6-77:
112112+Lines 24-26, characters 6-30:
11311324 | ......function
11411425 | | Foo _ , Foo _ -> true
11511526 | | Bar _, Bar _ -> true
···260260 | String s -> print_endline s (* warn : Any *)
261261end;;
262262[%%expect{|
263263-Line 8, characters 4-50:
263263+Lines 8-9, characters 4-33:
2642648 | ....match x with
2652659 | | String s -> print_endline s.................
266266Warning 8: this pattern-matching is not exhaustive.
···687687;; (* fail *)
688688[%%expect{|
689689type (_, _) eq = Eq : ('a, 'a) eq
690690-Line 3, characters 4-90:
690690+Lines 3-4, characters 4-15:
6916913 | ....f : type a b. (a,b) eq -> (<m : a; ..> as 'c) -> (<m : b; ..> as 'c) =
6926924 | fun Eq o -> o
693693Error: The universal type variable 'b cannot be generalized:
···813813let f : type a b. (a,b) eq -> [< `A of a | `B] -> [< `A of b | `B] =
814814 fun Eq o -> o ;; (* fail *)
815815[%%expect{|
816816-Line 1, characters 4-84:
816816+Lines 1-2, characters 4-15:
8178171 | ....f : type a b. (a,b) eq -> [< `A of a | `B] -> [< `A of b | `B] =
8188182 | fun Eq o -> o..............
819819Error: This definition has type
···915915 | TA, D z -> z
916916;; (* warn *)
917917[%%expect{|
918918-Line 2, characters 2-153:
918918+Lines 2-8, characters 2-16:
9199192 | ..match x, y with
9209203 | | _, A z -> z
9219214 | | _, B z -> if z then 1 else 2
···979979;; (* ok *)
980980[%%expect{|
981981type ('a, 'b) pair = { left : 'a; right : 'b; }
982982-Line 4, characters 2-244:
982982+Lines 4-10, characters 2-29:
983983 4 | ..match {left=x; right=y} with
984984 5 | | {left=_; right=A z} -> z
985985 6 | | {left=_; right=B z} -> if z then 1 else 2
···494494 x := B
495495;;
496496[%%expect{|
497497-Line 1, characters 8-70:
497497+Lines 1-3, characters 8-10:
4984981 | ........function
4994992 | | ({ contents = M.A } : M.t ref) as x ->
5005003 | x := B
···5075073 | x := B
508508 ^
509509Warning 18: this type-based constructor disambiguation is not principal.
510510-Line 1, characters 8-70:
510510+Lines 1-3, characters 8-10:
5115111 | ........function
5125122 | | ({ contents = M.A } : M.t ref) as x ->
5135133 | x := B
+12
testsuite/tests/typing-misc/is_expansive.ml
···11+(* TEST
22+ * expect *)
33+44+match [] with x -> (fun x -> x);;
55+[%%expect{|
66+- : 'a -> 'a = <fun>
77+|}];;
88+99+match [] with x -> (fun x -> x) | _ -> .;;
1010+[%%expect{|
1111+- : 'a -> 'a = <fun>
1212+|}];;
···1212 end
1313end;;
1414[%%expect{|
1515-Line 5, characters 8-52:
1515+Lines 5-8, characters 8-5:
16165 | ........struct
17176 | type t = B
18187 | let f B = ()
···6767end;;
68686969[%%expect{|
7070-Line 4, characters 4-70:
7070+Lines 4-7, characters 4-7:
71714 | ....struct
72725 | module type s
73736 | module A(X:s) =struct end
···9999 end
100100end;;
101101 [%%expect {|
102102-Line 4, characters 4-77:
102102+Lines 4-7, characters 4-7:
1031034 | ....struct
1041045 | module T = struct type t end
1051056 | type t = A of T.t
···187187188188189189[%%expect{|
190190-Line 4, characters 2-105:
190190+Lines 4-7, characters 2-5:
1911914 | ..struct
1921925 | class a = object method c = let module X = struct type t end in () end
1931936 | class b = a
···219219end;;
220220221221[%%expect{|
222222-Line 4, characters 2-65:
222222+Lines 4-7, characters 2-5:
2232234 | ..struct
2242245 | class type a = object end
2252256 | class type b = a
···266266end;;
267267268268[%%expect{|
269269-Line 8, characters 6-141:
269269+Lines 8-15, characters 6-3:
270270 8 | ......struct
271271 9 | type t
27227210 | class type a = object method m:t end
···343343type t = B
344344type t = C
345345type t = D
346346-Line 5, characters 44-72:
346346+Lines 5-7, characters 44-3:
3473475 | ............................................struct
3483486 | let f A B C = D
3493497 | end..
+1-1
testsuite/tests/typing-misc/pr6634.ml
···10101111[%%expect{|
1212type t = int
1313-Line 3, characters 0-31:
1313+Lines 3-5, characters 0-3:
14143 | struct
15154 | type t = [`T of t]
16165 | end..
+2-2
testsuite/tests/typing-misc/pr7668_bad.ml
···2020val partition_map :
2121 ('a -> [< `Left of 'b | `Right of 'c ]) -> 'a list -> 'b list * 'c list =
2222 <fun>
2323-Line 12, characters 35-96:
2323+Lines 12-13, characters 35-18:
242412 | ...................................partition_map (fun x -> if x then `Left ()
252513 | else `Right ()) xs
2626Error: This expression has type unit list * unit list
···5757end
5858;;
5959[%%expect{|
6060-Line 8, characters 6-348:
6060+Lines 8-27, characters 6-3:
6161 8 | ......struct
6262 9 | type t = [
636310 | | `A of int
···3939 ^
4040Error: This expression has type M/2.t but an expression was expected of type
4141 M/1.t
4242- Line 4, characters 2-41:
4242+ Lines 4-6, characters 2-5:
4343 Definition of module M/1
4444 Line 1, characters 0-32:
4545 Definition of module M/2
+1-1
testsuite/tests/typing-misc/variant.ml
···1111 let f = function A | B -> 0
1212end;;
1313[%%expect{|
1414-Line 3, characters 6-61:
1414+Lines 3-6, characters 6-3:
15153 | ......struct
16164 | type t = A | B
17175 | let f = function A | B -> 0
+1-1
testsuite/tests/typing-modules/Test.ml
···180180 type t += E of int
181181end;;
182182[%%expect{|
183183-Line 3, characters 6-37:
183183+Lines 3-5, characters 6-3:
1841843 | ......struct
1851854 | type t += E of int
1861865 | end..
···9999 type s = t
100100end;;
101101[%%expect{|
102102-Line 3, characters 6-29:
102102+Lines 3-5, characters 6-3:
1031033 | ......struct
1041044 | type s = t
1051055 | end..
+1-1
testsuite/tests/typing-modules/pr6394.ml
···1010 let f = function A | B -> 0
1111end;;
1212[%%expect{|
1313-Line 4, characters 6-63:
1313+Lines 4-7, characters 6-3:
14144 | ......struct
15155 | type t = A | B
16166 | let f = function A | B -> 0
+1-1
testsuite/tests/typing-modules/pr7818.ml
···108108 module Id2 = Id
109109end;;
110110[%%expect{|
111111-Line 2, characters 57-107:
111111+Lines 2-5, characters 57-3:
1121122 | .........................................................struct
1131133 | module Id = T'.T.Id
1141144 | module Id2 = Id
···11-File "pr3968_bad.ml", line 20, characters 0-165:
11+File "pr3968_bad.ml", lines 20-29, characters 0-3:
2220 | object
3321 | val l = e1
4422 | val r = e2
+1-1
testsuite/tests/typing-objects/Exemples.ml
···9595 method set y = x <- y
9696end;;
9797[%%expect{|
9898-Line 1, characters 0-95:
9898+Lines 1-5, characters 0-3:
99991 | class ref x_init = object
1001002 | val mutable x = x_init
1011013 | method get = x
+6-6
testsuite/tests/typing-objects/Tests.ml
···3131 inherit ['a] c ()
3232end;;
3333[%%expect{|
3434-Line 3, characters 4-45:
3434+Lines 3-5, characters 4-3:
35353 | ....and d () = object
36364 | inherit ['a] c ()
37375 | end..
···8888 method virtual f : int
8989end;;
9090[%%expect{|
9191-Line 1, characters 0-48:
9191+Lines 1-3, characters 0-3:
92921 | class x () = object
93932 | method virtual f : int
94943 | end..
···116116 method f x = (x : bool c)
117117end;;
118118[%%expect{|
119119-Line 1, characters 0-78:
119119+Lines 1-4, characters 0-3:
1201201 | class ['a] c () = object
1211212 | constraint 'a = int
1221223 | method f x = (x : bool c)
···162162 method f = (x : 'a)
163163end;;
164164[%%expect{|
165165-Line 1, characters 0-50:
165165+Lines 1-3, characters 0-3:
1661661 | class ['a] c () = object
1671672 | method f = (x : 'a)
1681683 | end..
···618618 method add (mtx : 'a matrix) = (mtx#m.(0).(0) : 'a)
619619end;;
620620[%%expect{|
621621-Line 1, characters 0-153:
621621+Lines 1-4, characters 0-3:
6226221 | class virtual ['a] matrix (sz, init : int * 'a) = object
6236232 | val m = Array.make_matrix sz sz init
6246243 | method add (mtx : 'a matrix) = (mtx#m.(0).(0) : 'a)
···667667 val f : #c -> #c
668668end);;
669669[%%expect{|
670670-Line 1, characters 12-43:
670670+Lines 1-3, characters 12-3:
6716711 | ............struct
6726722 | let f (x : #c) = x
6736733 | end......
···22Warning 63: The printed interface differs from the inferred interface.
33The inferred interface contained items which could not be printed
44properly due to name collisions between identifiers.
55-File "pervasives_leitmotiv.ml", line 10, characters 0-45:
55+File "pervasives_leitmotiv.ml", lines 10-12, characters 0-3:
66 Definition of module Stdlib/1
77File "_none_", line 1:
88 Definition of module Stdlib/2
···22Warning 63: The printed interface differs from the inferred interface.
33The inferred interface contained items which could not be printed
44properly due to name collisions between identifiers.
55-File "pr7402.ml", line 14, characters 0-39:
55+File "pr7402.ml", lines 14-16, characters 0-5:
66 Definition of module M/1
77-File "pr7402.ml", line 8, characters 0-70:
77+File "pr7402.ml", lines 8-11, characters 0-3:
88 Definition of module M/2
99Beware that this warning is purely informational and will not catch
1010all instances of erroneous printed interface.
+1-1
testsuite/tests/typing-poly/error_messages.ml
···5454[%%expect {|
5555class type t_a = object method f : 'a -> int end
5656val f : t_a -> int = <fun>
5757-Line 5, characters 10-42:
5757+Lines 5-7, characters 10-5:
58585 | ..........(object
59596 | method f _ = 0
60607 | end)..
+16-4
testsuite/tests/typing-poly/poly.ml
···4747| {pv=true::_} -> "bool"
4848;;
4949[%%expect {|
5050-Line 1, characters 0-77:
5050+Lines 1-4, characters 0-24:
51511 | match px with
52522 | | {pv=[]} -> "OK"
53533 | | {pv=5::_} -> "int"
···6464| {pv=5::_} -> "int"
6565;;
6666[%%expect {|
6767-Line 1, characters 0-77:
6767+Lines 1-4, characters 0-20:
68681 | match px with
69692 | | {pv=[]} -> "OK"
70703 | | {pv=true::_} -> "bool"
···555555end
556556;;
557557[%%expect {|
558558-Line 4, characters 12-79:
558558+Lines 4-7, characters 12-17:
5595594 | ............x =
5605605 | match r with
5615616 | None -> r <- Some x; x
···12231223let f6 x =
12241224 (x : <m:'a. [< `A of < > ] as 'a> :> <m:'a. [< `A of <p:int> ] as 'a>);;
12251225[%%expect {|
12261226-Line 2, characters 2-88:
12261226+Lines 2-3, characters 2-47:
122712272 | ..(x : <m:'a. (<p:int;..> as 'a) -> int>
122812283 | :> <m:'b. (<p:int;q:int;..> as 'b) -> int>)..
12291229Error: Type < m : 'a. (< p : int; .. > as 'a) -> int > is not a subtype of
···17231723 val i : 'a -> 'a
17241724 end
17251725|}]
17261726+17271727+(* #8550 *)
17281728+class ['a] r = let r : 'a = ref [] in object method get = r end;;
17291729+[%%expect{|
17301730+Line 1, characters 0-63:
17311731+1 | class ['a] r = let r : 'a = ref [] in object method get = r end;;
17321732+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
17331733+Error: The type of this class,
17341734+ class ['a] r :
17351735+ object constraint 'a = '_weak2 list ref method get : 'a end,
17361736+ contains type variables that cannot be generalized
17371737+|}]
···11-File "b_bad.ml", line 13, characters 29-66:
11+File "b_bad.ml", lines 13-14, characters 29-28:
2213 | .............................function
3314 | A.X s -> print_endline s
44Error (warning 8): this pattern-matching is not exhaustive.
+5-5
testsuite/tests/typing-sigsubst/sigsubst.ml
···4747 and M2 : sig type t = int end
4848end with type M.t = int
4949[%%expect {|
5050-Line 1, characters 17-115:
5050+Lines 1-4, characters 17-23:
51511 | .................sig
52522 | module rec M : sig type t = M2.t end
53533 | and M2 : sig type t = int end
···162162end with type 'a t2 := 'a t * bool
163163[%%expect {|
164164type 'a t constraint 'a = 'b list
165165-Line 2, characters 16-142:
165165+Lines 2-6, characters 16-34:
1661662 | ................sig
1671673 | type 'a t2 constraint 'a = 'b list
1681684 | type 'a mylist = 'a list
···267267 module A = M
268268end with type M.t := float
269269[%%expect {|
270270-Line 1, characters 16-89:
270270+Lines 1-4, characters 16-26:
2712711 | ................sig
2722722 | module M : sig type t end
2732733 | module A = M
···329329end with type M2.t := int
330330[%%expect {|
331331module Id : functor (X : sig type t end) -> sig type t = X.t end
332332-Line 2, characters 17-120:
332332+Lines 2-5, characters 17-25:
3333332 | .................sig
3343343 | module rec M : sig type t = A of Id(M2).t end
3353354 | and M2 : sig type t end
···372372 module Alias = M
373373end with module M.N := A
374374[%%expect {|
375375-Line 1, characters 16-159:
375375+Lines 1-10, characters 16-24:
376376 1 | ................sig
377377 2 | module M : sig
378378 3 | module N : sig
+7-7
testsuite/tests/typing-unboxed-types/test.ml
···111111 type t = A of string [@@ocaml.unboxed]
112112end;;
113113[%%expect{|
114114-Line 3, characters 6-57:
114114+Lines 3-5, characters 6-3:
1151153 | ......struct
1161164 | type t = A of string [@@ocaml.unboxed]
1171175 | end..
···134134 type t = A of string
135135end;;
136136[%%expect{|
137137-Line 3, characters 6-39:
137137+Lines 3-5, characters 6-3:
1381383 | ......struct
1391394 | type t = A of string
1401405 | end..
···157157 type t = { f : string } [@@ocaml.unboxed]
158158end;;
159159[%%expect{|
160160-Line 3, characters 6-60:
160160+Lines 3-5, characters 6-3:
1611613 | ......struct
1621624 | type t = { f : string } [@@ocaml.unboxed]
1631635 | end..
···180180 type t = { f : string }
181181end;;
182182[%%expect{|
183183-Line 3, characters 6-42:
183183+Lines 3-5, characters 6-3:
1841843 | ......struct
1851854 | type t = { f : string }
1861865 | end..
···203203 type t = A of { f : string } [@@ocaml.unboxed]
204204end;;
205205[%%expect{|
206206-Line 3, characters 6-65:
206206+Lines 3-5, characters 6-3:
2072073 | ......struct
2082084 | type t = A of { f : string } [@@ocaml.unboxed]
2092095 | end..
···226226 type t = A of { f : string }
227227end;;
228228[%%expect{|
229229-Line 3, characters 6-47:
229229+Lines 3-5, characters 6-3:
2302303 | ......struct
2312314 | type t = A of { f : string }
2322325 | end..
···292292 type u = { f1 : t; f2 : t }
293293end;;
294294[%%expect{|
295295-Line 4, characters 6-86:
295295+Lines 4-7, characters 6-3:
2962964 | ......struct
2972975 | type t = A of float [@@ocaml.unboxed]
2982986 | type u = { f1 : t; f2 : t }
···11-File "w04_failure.ml", line 20, characters 2-78:
11+File "w04_failure.ml", lines 20-23, characters 2-17:
2220 | ..match r1, r2, t with
3321 | | AB, _, A -> ()
4422 | | _, XY, X -> ()
5523 | | _, _, _ -> ()
66Warning 4: this pattern-matching is fragile.
77It will remain exhaustive when constructors are added to type repr.
88-File "w04_failure.ml", line 20, characters 2-78:
88+File "w04_failure.ml", lines 20-23, characters 2-17:
9920 | ..match r1, r2, t with
101021 | | AB, _, A -> ()
111122 | | _, XY, X -> ()
121223 | | _, _, _ -> ()
1313Warning 4: this pattern-matching is fragile.
1414It will remain exhaustive when constructors are added to type ab.
1515-File "w04_failure.ml", line 20, characters 2-78:
1515+File "w04_failure.ml", lines 20-23, characters 2-17:
161620 | ..match r1, r2, t with
171721 | | AB, _, A -> ()
181822 | | _, XY, X -> ()
+1-1
testsuite/tests/warnings/w32.compilers.reference
···464659 | and[@warning "+32"] k x = x
4747 ^
4848Warning 32: unused value k.
4949-File "w32.ml", line 52, characters 0-174:
4949+File "w32.ml", lines 52-60, characters 0-3:
505052 | module M = struct
515153 | [@@@warning "-32"]
525254 | let f x = x
···223223 else
224224 echo "NOT checking $1: $path (typo.prune)"
225225 fi
226226+ if [[ $path = 'configure' || $path = 'configure.ac' ]] ; then
227227+ touch CHECK_CONFIGURE
228228+ fi
226229 done)
227230 rm -f tmp-index
231231+ if [ -e CHECK_CONFIGURE ] ; then
232232+ rm -f CHECK_CONFIGURE
233233+ echo "configure or configure.ac altered in $1"
234234+ echo "Verifying that configure.ac generates configure"
235235+ git checkout "$1"
236236+ mv configure configure.ref
237237+ ./autogen
238238+ if ! diff -q configure configure.ref >/dev/null ; then
239239+ echo "configure.ac no longer generates configure, \
240240+please run ./autogen and commit"
241241+ exit 1
242242+ fi
243243+ fi
228244}
229245230246CHECK_ALL_COMMITS=0
+2-1
tools/release-checklist
···109109# 4.07.0+dev8-2018-06-19 => 4.07.0+dev9-2018-06-26
110110# for production releases: check and change the Changes header
111111# (remove "next version" and add a date)
112112-git add VERSION Changes
112112+# Update ocaml-variants.opam file to depend on the new version of ocaml.
113113+git add VERSION Changes ocaml-variants.opam
113114git commit -m "last commit before tagging $VERSION"
114115# update VERSION with the new release; for example,
115116# 4.07.0+dev9-2018-06-26 => 4.07.0+rc2
···721721 end
722722 end
723723724724-let generalize_structure var_level ty =
724724+let generalize_structure ty =
725725 simple_abbrevs := Mnil;
726726- generalize_structure var_level ty
726726+ generalize_structure !current_level ty
727727728728(* Generalize the spine of a function, if the level >= !current_level *)
729729···878878 update_level env level true ty
879879 end
880880881881-(* Generalize and lower levels of contravariant branches simultaneously *)
881881+(* Lower level of type variables inside contravariant branches *)
882882883883-let rec generalize_expansive env var_level visited ty =
883883+let rec lower_contravariant env var_level visited contra ty =
884884 let ty = repr ty in
885885- if ty.level = generic_level || ty.level <= var_level then () else
886886- if not (Hashtbl.mem visited ty.id) then begin
887887- Hashtbl.add visited ty.id ();
885885+ let must_visit =
886886+ ty.level > var_level &&
887887+ match Hashtbl.find visited ty.id with
888888+ | done_contra -> contra && not done_contra
889889+ | exception Not_found -> true
890890+ in
891891+ if must_visit then begin
892892+ Hashtbl.add visited ty.id contra;
893893+ let generalize_rec = lower_contravariant env var_level visited in
888894 match ty.desc with
889889- Tconstr (path, tyl, abbrev) ->
895895+ Tvar _ -> if contra then set_level ty var_level
896896+ | Tconstr (path, tyl, abbrev) ->
890897 let variance =
891898 try (Env.find_type path env).type_variance
892899 with Not_found ->
···897904 List.iter2
898905 (fun v t ->
899906 if Variance.(mem May_weak v)
900900- then generalize_structure var_level t
901901- else generalize_expansive env var_level visited t)
907907+ then generalize_rec true t
908908+ else generalize_rec contra t)
902909 variance tyl
903910 | Tpackage (_, _, tyl) ->
904904- List.iter (generalize_structure var_level) tyl
911911+ List.iter (generalize_rec true) tyl
905912 | Tarrow (_, t1, t2, _) ->
906906- generalize_structure var_level t1;
907907- generalize_expansive env var_level visited t2
913913+ generalize_rec true t1;
914914+ generalize_rec contra t2
908915 | _ ->
909909- iter_type_expr (generalize_expansive env var_level visited) ty
916916+ iter_type_expr (generalize_rec contra) ty
910917 end
911918912912-let generalize_expansive env ty =
919919+let lower_contravariant env ty =
913920 simple_abbrevs := Mnil;
914914- generalize_expansive env !nongen_level (Hashtbl.create 7) ty
915915-916916-let generalize_structure ty = generalize_structure !current_level ty
921921+ lower_contravariant env !nongen_level (Hashtbl.create 7) false ty
917922918923(* Correct the levels of type [ty]. *)
919924let correct_levels ty =
+3-3
typing/ctype.mli
···154154155155val generalize: type_expr -> unit
156156 (* Generalize in-place the given type *)
157157-val generalize_expansive: Env.t -> type_expr -> unit
158158- (* Generalize the covariant part of a type, making
159159- contravariant branches non-generalizable *)
157157+val lower_contravariant: Env.t -> type_expr -> unit
158158+ (* Lower level of type variables inside contravariant branches;
159159+ to be used before generalize for expansive expressions *)
160160val generalize_structure: type_expr -> unit
161161 (* Same, but variables are only lowered to !current_level *)
162162val generalize_spine: type_expr -> unit
+110-85
typing/typecore.ml
···7575 | Virtual_class of Longident.t
7676 | Private_type of type_expr
7777 | Private_label of Longident.t * type_expr
7878+ | Private_constructor of constructor_description * type_expr
7879 | Unbound_instance_variable of string * string list
7980 | Instance_variable_not_mutable of bool * string
8081 | Not_subtype of Ctype.Unification_trace.t * Ctype.Unification_trace.t
···1803180418041805let rec is_nonexpansive exp =
18051806 match exp.exp_desc with
18061806- Texp_ident(_,_,_) -> true
18071807- | Texp_constant _ -> true
18071807+ | Texp_ident _
18081808+ | Texp_constant _
18091809+ | Texp_unreachable
18101810+ | Texp_function _
18111811+ | Texp_array [] -> true
18081812 | Texp_let(_rec_flag, pat_exp_list, body) ->
18091813 List.for_all (fun vb -> is_nonexpansive vb.vb_expr) pat_exp_list &&
18101814 is_nonexpansive body
18111811- | Texp_function _ -> true
18121815 | Texp_apply(e, (_,None)::el) ->
18131816 is_nonexpansive e && List.for_all is_nonexpansive_opt (List.map snd el)
18141814- | Texp_match(e, cases, [], _) ->
18171817+ | Texp_match(e, cases, _, _) ->
18151818 (* Not sure this is necessary, if [e] is nonexpansive then we shouldn't
18161819 care if there are exception patterns. But the previous version enforced
18171820 that there be none, so... *)
···18451848 fields
18461849 && is_nonexpansive_opt extended_expression
18471850 | Texp_field(exp, _, _) -> is_nonexpansive exp
18481848- | Texp_array [] -> true
18491851 | Texp_ifthenelse(_cond, ifso, ifnot) ->
18501852 is_nonexpansive ifso && is_nonexpansive_opt ifnot
18511853 | Texp_sequence (_e1, e2) -> is_nonexpansive e2 (* PR#4354 *)
18521852- | Texp_new (_, _, cl_decl) when Ctype.class_type_arity cl_decl.cty_type > 0 ->
18531853- true
18541854+ | Texp_new (_, _, cl_decl) -> Ctype.class_type_arity cl_decl.cty_type > 0
18541855 (* Note: nonexpansive only means no _observable_ side effects *)
18551856 | Texp_lazy e -> is_nonexpansive e
18561857 | Texp_object ({cstr_fields=fields; cstr_type = { csig_vars=vars}}, _) ->
···18871888 ("%raise" | "%reraise" | "%raise_notrace")}}) },
18881889 [Nolabel, Some e]) ->
18891890 is_nonexpansive e
18901890- | _ -> false
18911891+ | Texp_array (_ :: _)
18921892+ | Texp_apply _
18931893+ | Texp_try _
18941894+ | Texp_setfield _
18951895+ | Texp_while _
18961896+ | Texp_for _
18971897+ | Texp_send _
18981898+ | Texp_instvar _
18991899+ | Texp_setinstvar _
19001900+ | Texp_override _
19011901+ | Texp_letexception _
19021902+ | Texp_letop _
19031903+ | Texp_extension_constructor _ ->
19041904+ false
1891190518921906and is_nonexpansive_mod mexp =
18931907 match mexp.mod_desc with
18941894- | Tmod_ident _ -> true
19081908+ | Tmod_ident _
18951909 | Tmod_functor _ -> true
18961910 | Tmod_unpack (e, _) -> is_nonexpansive e
18971911 | Tmod_constraint (m, _, _, _) -> is_nonexpansive_mod m
···19281942 | Tmod_apply _ -> false
1929194319301944and is_nonexpansive_opt = function
19311931- None -> true
19451945+ | None -> true
19321946 | Some e -> is_nonexpansive e
19471947+19481948+let maybe_expansive e = not (is_nonexpansive e)
1933194919341950let check_recursive_bindings env valbinds =
19351951 let ids = let_bound_idents valbinds in
···2019203520202036(* Check that all univars are safe in a type *)
20212037let check_univars env expans kind exp ty_expected vars =
20222022- if expans && not (is_nonexpansive exp) then
20232023- generalize_expansive env exp.exp_type;
20382038+ if expans && maybe_expansive exp then
20392039+ lower_contravariant env exp.exp_type;
20242040 (* need to expand twice? cf. Ctype.unify2 *)
20252041 let vars = List.map (expand_head env) vars in
20262042 let vars = List.map (expand_head env) vars in
···25182534 begin_def ();
25192535 let arg = type_exp env sarg in
25202536 end_def ();
25212521- if not (is_nonexpansive arg) then generalize_expansive env arg.exp_type;
25372537+ if maybe_expansive arg then lower_contravariant env arg.exp_type;
25222538 generalize arg.exp_type;
25232539 let rec split_cases valc effc conts = function
25242540 | [] -> List.rev valc, List.rev effc, List.rev conts
···38913907 try
38923908 check_univars env (vars <> []) "field value" arg label.lbl_arg vars;
38933909 arg
38943894- with exn when not (is_nonexpansive arg) -> try
39103910+ with exn when maybe_expansive arg -> try
38953911 (* Try to retype without propagating ty_arg, cf PR#4862 *)
38963912 may Btype.backtrack snap;
38973913 begin_def ();
38983914 let arg = type_exp env sarg in
38993915 end_def ();
39003900- generalize_expansive env arg.exp_type;
39163916+ lower_contravariant env arg.exp_type;
39013917 unify_exp env arg ty_arg;
39023918 check_univars env false "field value" arg label.lbl_arg vars;
39033919 arg
···42734289 List.map2 (fun e (t,t0) -> type_argument ~recarg env e t t0) sargs
42744290 (List.combine ty_args ty_args0) in
42754291 if constr.cstr_private = Private then
42764276- raise(Error(loc, env, Private_type ty_res));
42924292+ begin match constr.cstr_tag with
42934293+ | Cstr_extension _ ->
42944294+ raise(Error(loc, env, Private_constructor (constr, ty_res)))
42954295+ | Cstr_constant _ | Cstr_block _ | Cstr_unboxed ->
42964296+ raise (Error(loc, env, Private_type ty_res));
42974297+ end;
42774298 (* NOTE: shouldn't we call "re" on this final expression? -- AF *)
42784299 { texp with
42794300 exp_desc = Texp_construct(lid, constr, args) }
···47754796 end_def();
47764797 List.iter2
47774798 (fun pat exp ->
47784778- if not (is_nonexpansive exp) then
47794779- generalize_expansive env pat.pat_type)
47994799+ if maybe_expansive exp then
48004800+ lower_contravariant env pat.pat_type)
47804801 pat_list exp_list;
47814802 iter_pattern_variables_type generalize pvs;
47824803 (* We also generalize expressions that are not bound to a variable.
···48794900 begin_def();
48804901 let exp = type_exp env sexp in
48814902 end_def();
48824882- if not (is_nonexpansive exp) then generalize_expansive env exp.exp_type;
49034903+ if maybe_expansive exp then lower_contravariant env exp.exp_type;
48834904 generalize exp.exp_type;
48844905 match sexp.pexp_desc with
48854906 Pexp_ident lid ->
···49114932(* Hint on type error on integer literals
49124933 To avoid confusion, it is disabled on float literals
49134934 and when the expected type is `int` *)
49144914-let report_literal_type_constraint ppf expected_type const =
49154915- let hint str_val =
49164916- let hint_suffix c =
49174917- fprintf ppf "@\n@[Hint: Did you mean `%s%c'?@]" str_val c
49184918- in
49354935+let report_literal_type_constraint expected_type const =
49364936+ let const_str = match const with
49374937+ | Const_int n -> Some (Int.to_string n)
49384938+ | Const_int32 n -> Some (Int32.to_string n)
49394939+ | Const_int64 n -> Some (Int64.to_string n)
49404940+ | Const_nativeint n -> Some (Nativeint.to_string n)
49414941+ | _ -> None
49424942+ in
49434943+ let suffix =
49194944 if Path.same expected_type Predef.path_int32 then
49204920- hint_suffix 'l'
49454945+ Some 'l'
49214946 else if Path.same expected_type Predef.path_int64 then
49224922- hint_suffix 'L'
49474947+ Some 'L'
49234948 else if Path.same expected_type Predef.path_nativeint then
49244924- hint_suffix 'n'
49494949+ Some 'n'
49254950 else if Path.same expected_type Predef.path_float then
49264926- hint_suffix '.'
49274927- else
49284928- ()
49514951+ Some '.'
49524952+ else None
49294953 in
49304930- match const with
49314931- | Const_int n -> hint (Int.to_string n)
49324932- | Const_int32 n -> hint (Int32.to_string n)
49334933- | Const_int64 n -> hint (Int64.to_string n)
49344934- | Const_nativeint n -> hint (Nativeint.to_string n)
49354935- | _ -> ()
49544954+ match const_str, suffix with
49554955+ | Some c, Some s -> [ Location.msg "@[Hint: Did you mean `%s%c'?@]" c s ]
49564956+ | _, _ -> []
4936495749374937-let report_literal_type_constraint ppf const = function
49584958+let report_literal_type_constraint const = function
49384959 | Some Unification_trace.
49394960 { expected = { t = { desc = Tconstr (typ, [], _) } } } ->
49404940- report_literal_type_constraint ppf typ const
49414941- | Some _ | None -> ()
49614961+ report_literal_type_constraint typ const
49624962+ | Some _ | None -> []
4942496349434943-let report_expr_type_clash_hints ppf exp diff =
49644964+let report_expr_type_clash_hints exp diff =
49444965 match exp with
49454945- | Some (Texp_constant const) -> report_literal_type_constraint ppf const diff
49464946- | _ -> ()
49664966+ | Some (Texp_constant const) -> report_literal_type_constraint const diff
49674967+ | _ -> []
4947496849484948-let report_pattern_type_clash_hints ppf pat diff =
49694969+let report_pattern_type_clash_hints pat diff =
49494970 match pat with
49504950- | Some (Tpat_constant const) -> report_literal_type_constraint ppf const diff
49514951- | _ -> ()
49714971+ | Some (Tpat_constant const) -> report_literal_type_constraint const diff
49724972+ | _ -> []
4952497349534974(* Hint when using int operators (eg. `+`)
49544975 on other kind of integer and floats *)
49554955-let report_numeric_operator_clash_hints actual_type operator =
49764976+let report_numeric_operator_clash_hints ~loc actual_type operator =
49564977 let stdlib = Path.Pident (Ident.create_persistent "Stdlib") in
49574978 let stdlib_qualified mod_ val_ = Path.Pdot (Path.Pdot (stdlib, mod_), val_) in
49584958- let hint expected_op =
49594959- Some (fun ppf ->
49604960- fprintf ppf "@[Hint:@ Did you mean to use `%a'?@]"
49614961- Printtyp.path expected_op
49624962- )
49794979+ let is_op op = Path.same operator (Path.Pdot (stdlib, op)) in
49804980+ let expecting_qualified name =
49814981+ let qualified = stdlib_qualified name in
49824982+ if is_op "+" then Some (qualified "add")
49834983+ else if is_op "-" then Some (qualified "sub")
49844984+ else if is_op "*" then Some (qualified "mul")
49854985+ else if is_op "/" then Some (qualified "div")
49864986+ else if is_op "mod" then Some (qualified "rem")
49874987+ else None
49634988 in
49644964- let hint ~add ~sub ~mul ~div ~mod_ () =
49654965- let is_op op = Path.same operator (Path.Pdot (stdlib, op)) in
49664966- if is_op "+" then hint add
49674967- else if is_op "-" then hint sub
49684968- else if is_op "*" then hint mul
49694969- else if is_op "/" then hint div
49704970- else if is_op "mod" then hint mod_
49894989+ let expecting_float () =
49904990+ let qualified id = Path.Pdot (stdlib, id) in
49914991+ if is_op "+" then Some (qualified "+.")
49924992+ else if is_op "-" then Some (qualified "-.")
49934993+ else if is_op "*" then Some (qualified "*.")
49944994+ else if is_op "/" then Some (qualified "/.")
49954995+ else if is_op "mod" then Some (stdlib_qualified "Float" "rem")
49714996 else None
49724997 in
49734973- let hint_qualified name =
49744974- let qualified = stdlib_qualified name in
49754975- hint ~add:(qualified "add") ~sub:(qualified "sub") ~mul:(qualified "mul")
49764976- ~div:(qualified "div") ~mod_:(qualified "rem") ()
49984998+ let expecting_op =
49994999+ if Path.same actual_type Predef.path_int32 then
50005000+ expecting_qualified "Int32"
50015001+ else if Path.same actual_type Predef.path_int64 then
50025002+ expecting_qualified "Int64"
50035003+ else if Path.same actual_type Predef.path_nativeint then
50045004+ expecting_qualified "Nativeint"
50055005+ else if Path.same actual_type Predef.path_float then
50065006+ expecting_float ()
50075007+ else None
49775008 in
49784978- let hint_std () =
49794979- let qualified id = Path.Pdot (stdlib, id) in
49804980- hint ~add:(qualified "+.") ~sub:(qualified "-.") ~mul:(qualified "*.")
49814981- ~div:(qualified "/.") ~mod_:(stdlib_qualified "Float" "rem") ()
49824982- in
49834983- let expecting = Path.same actual_type in
49844984- if expecting Predef.path_int32 then
49854985- hint_qualified "Int32"
49864986- else if expecting Predef.path_int64 then
49874987- hint_qualified "Int64"
49884988- else if expecting Predef.path_nativeint then
49894989- hint_qualified "Nativeint"
49904990- else if expecting Predef.path_float then
49914991- hint_std ()
49924992- else None
50095009+ match expecting_op with
50105010+ | Some op ->
50115011+ [ Location.msg ~loc "@[Hint:@ Did you mean to use `%a'?@]"
50125012+ Printtyp.path op ]
50135013+ | None -> []
4993501449945015(* Returns a list of `Location.msg` *)
49955016let report_application_clash_hints diff expl =
49965017 match expl, diff with
49975018 | Some (Application { exp_desc = Texp_ident (p, _, _); exp_loc = loc; _ }),
49985019 Some Unification_trace.{ got = { t = { desc = Tconstr (typ, [], _) } } } ->
49994999- begin match report_numeric_operator_clash_hints typ p with
50005000- | Some txt -> [ { txt; loc } ]
50015001- | None -> []
50025002- end
50205020+ report_numeric_operator_clash_hints ~loc typ p
50035021 | _ -> []
5004502250055023let report_type_expected_explanation expl ppf =
···50545072 fprintf ppf "but is mixed here with fields of type")
50555073 | Pattern_type_clash (trace, pat) ->
50565074 let diff = type_clash_of_trace trace in
50575057- Location.error_of_printer ~loc (fun ppf () ->
50755075+ let sub = report_pattern_type_clash_hints pat diff in
50765076+ Location.error_of_printer ~loc ~sub (fun ppf () ->
50585077 Printtyp.report_unification_error ppf env trace
50595078 (function ppf ->
50605079 fprintf ppf "This pattern matches values of type")
50615080 (function ppf ->
50625081 fprintf ppf "but a pattern was expected which matches values of \
50635082 type");
50645064- report_pattern_type_clash_hints ppf pat diff
50655083 ) ()
50665084 | Or_pattern_type_clash (id, trace) ->
50675085 report_unification_error ~loc env trace
···50835101 ) ()
50845102 | Expr_type_clash (trace, explanation, exp) ->
50855103 let diff = type_clash_of_trace trace in
50865086- let sub = report_application_clash_hints diff explanation in
51045104+ let sub = List.concat [
51055105+ report_application_clash_hints diff explanation;
51065106+ report_expr_type_clash_hints exp diff;
51075107+ ]
51085108+ in
50875109 Location.error_of_printer ~loc ~sub (fun ppf () ->
50885110 Printtyp.report_unification_error ppf env trace
50895111 ~type_expected_explanation:
···50925114 fprintf ppf "This expression has type")
50935115 (function ppf ->
50945116 fprintf ppf "but an expression was expected of type");
50955095- report_expr_type_clash_hints ppf exp diff
50965117 ) ()
50975118 | Apply_non_function typ ->
50985119 reset_and_mark_loops typ;
···52635284 | Private_label (lid, ty) ->
52645285 Location.errorf ~loc "Cannot assign field %a of the private type %a"
52655286 longident lid type_expr ty
52875287+ | Private_constructor (constr, ty) ->
52885288+ Location.errorf ~loc
52895289+ "Cannot use private constructor %s to create values of type %a"
52905290+ constr.cstr_name type_expr ty
52665291 | Not_a_variant_type lid ->
52675292 Location.errorf ~loc "The type %a@ is not a variant type" longident lid
52685293 | Incoherent_label_order ->
+1
typing/typecore.mli
···142142 | Virtual_class of Longident.t
143143 | Private_type of type_expr
144144 | Private_label of Longident.t * type_expr
145145+ | Private_constructor of constructor_description * type_expr
145146 | Unbound_instance_variable of string * string list
146147 | Instance_variable_not_mutable of bool * string
147148 | Not_subtype of Ctype.Unification_trace.t * Ctype.Unification_trace.t
+14
utils/misc.ml
···203203 else if p (Array.unsafe_get a1 i) (Array.unsafe_get a2 i) then true
204204 else loop (succ i) in
205205 loop 0
206206+207207+ let for_alli p a =
208208+ let n = Array.length a in
209209+ let rec loop i =
210210+ if i = n then true
211211+ else if p i (Array.unsafe_get a i) then loop (succ i)
212212+ else false in
213213+ loop 0
214214+215215+ let all_somes a =
216216+ try
217217+ Some (Array.map (function None -> raise_notrace Exit | Some x -> x) a)
218218+ with
219219+ | Exit -> None
206220 end
207221208222 module String = struct
+7
utils/misc.mli
···158158 (* Same as [Array.exists], but for a two-argument predicate. Raise
159159 Invalid_argument if the two arrays are determined to have
160160 different lengths. *)
161161+162162+ val for_alli : (int -> 'a -> bool) -> 'a array -> bool
163163+ (** Same as {!Array.for_all}, but the
164164+ function is applied with the index of the element as first argument,
165165+ and the element itself as second argument. *)
166166+167167+ val all_somes : 'a option array -> 'a array option
161168 end
162169163170 module String : sig