From: Stéphane Glondu Date: Mon, 18 Sep 2023 11:36:04 +0000 (+0200) Subject: New upstream version 4.14.1 X-Git-Tag: archive/raspbian/4.14.1-1+rpi1^2~15^2 X-Git-Url: https://dgit.raspbian.org/?a=commitdiff_plain;h=2a39510035b4d52987d43b38814a8b3fde964c8c;p=ocaml.git New upstream version 4.14.1 --- diff --git a/Changes b/Changes index a8ce94bd..a91fe1ec 100644 --- a/Changes +++ b/Changes @@ -1,3 +1,103 @@ +OCaml 4.14.1 (20 December 2022) +------------------------------ + +### Bug fixes: + +- #11803, #11808: on x86, the destination of an integer comparison must be + a register, it cannot be a stack slot. + (Vincent Laviron, review by Xavier Leroy, report by + Emilio Jesús Gallego Arias) + + +OCaml 4.14.1 +----------------------------- + +### Compiler user-interface and warnings: + +- #11184, #11670: Stop calling ranlib on created / installed libraries + (Sébastien Hinderer and Xavier Leroy, review by the same) + +### Build system: + +- #11370, #11373: Don't pass CFLAGS to flexlink during configure. + (David Allsopp, report by William Hu, review by Xavier Leroy and + Sébastien Hinderer) + +- #11487: Thwart FMA test optimization during configure + (William Hu, review by David Allsopp and Sébastien Hinderer) + +### Bug fixes: + +- #10768, #11340: Fix typechecking regression when combining first class + modules and GADTs. + (Jacques Garrigue, report by François Thiré, review by Matthew Ryan) + +- #11204: Fix regression introduced in 4.14.0 that would trigger Warning 17 when + calling virtual methods introduced by constraining the self type from within + the class definition. + (Nicolás Ojeda Bär, review by Leo White) + +- #11263, #11267: caml/{memory,misc}.h: check whether `_MSC_VER` is defined + before using it to ensure that the headers can always be used in code which + turns on -Wundef (or equivalent). + (David Allsopp and Nicolás Ojeda Bär, review by Nicolás Ojeda Bär and + Sébastien Hinderer) + +- #11314, #11416: fix non-informative error message for module inclusion + (Florian Angeletti, report by Thierry Martinez, review by Gabriel Scherer) + +- #11358, #11379: Refactor the initialization of bytecode threading, + This avoids a "dangling pointer" warning of GCC 12.1. + (Xavier Leroy, report by Armaël Guéneau, review by Gabriel Scherer) + +- #11387, module type with constraints no longer crash the compiler in presence + of both shadowing warnings and the `-bin-annot` compiler flag. + (Florian Angeletti, report by Christophe Raffalli, review by Gabriel Scherer) + +- #11392, #11392: assertion failure with -rectypes and external definitions + (Gabriel Scherer, review by Florian Angeletti, report by Dmitrii Kosarev) + +- #11417: Fix regression allowing virtual methods in non-virtual classes. + (Leo White, review by Florian Angeletti) + +- #11468: Fix regression from #10186 (OCaml 4.13) detecting IPv6 on Windows for + mingw-w64 i686 port. + (David Allsopp, review by Xavier Leroy and Sébastien Hinderer) + +- #11489, #11496: More prudent deallocation of alternate signal stack + (Xavier Leroy, report by @rajdakin, review by Florian Angeletti) + +- #11516, #11524: Fix the `deprecated_mutable` attribute. + (Chris Casinghino, review by Nicolás Ojeda Bär and Florian Angeletti) + +- #11194, #11609: Fix inconsistent type variable names in "unbound type var" + messages + (Ulysse Gérard and Florian Angeletti, review Florian Angeletti and + Gabriel Scherer) + +- #11622: Prevent stack overflow when printing a constructor or record + mismatch error involving recursive types. + (Florian Angeletti, review by Gabriel Scherer) + +- #11732: Ensure that types from packed modules are always generalised + (Stephen Dolan and Leo White, review by Jacques Garrigue) + +- #11737: Fix segfault condition in Unix.stat under Windows in the presence of + multiple threads. + (Marc Lasson, Nicolás Ojeda Bär, review by Gabriel Scherer and David Allsopp) + +- #11776: Extend environment with functor parameters in `strengthen_lazy`. + (Chris Casinghino and Luke Maurer, review by Gabriel Scherer) + +- #11533, #11534: follow synonyms again in #show_module_type + (this had stopped working in 4.14.0) + (Gabriel Scherer, review by Jacques Garrigue, report by Yaron Minsky) + +- #11768, #11788: Fix crash at start-up of bytecode programs in + no-naked-pointers mode caused by wrong initialization of caml_global_data + (Xavier Leroy, report by Etienne Millon, review by Gabriel Scherer) + + OCaml 4.14.0 (28 March 2022) ---------------------------- @@ -62,7 +162,6 @@ OCaml 4.14.0 (28 March 2022) definition-aware operations. (Ulysse Gérard, Thomas Refis and Leo White, review by Florian Angeletti) - ### Language features: - #10462: Add attribute to produce a compiler error for polls. diff --git a/INSTALL.adoc b/INSTALL.adoc index f4199ca4..08d67ebb 100644 --- a/INSTALL.adoc +++ b/INSTALL.adoc @@ -43,8 +43,8 @@ * Under Cygwin, the `gcc-core` package is required. `flexdll` is also necessary for shared library support. -* Binutils including `ar`, `ranlib`, and `strip` are required if your - distribution does not already provide them with the C compiler. +* Binutils including `ar` and `strip` are required if your distribution + does not already provide them with the C compiler. == Configuration diff --git a/Makefile b/Makefile index 3c74bc79..0e92785d 100644 --- a/Makefile +++ b/Makefile @@ -585,8 +585,6 @@ endif ifeq "$(INSTALL_OCAMLNAT)" "true" $(INSTALL_PROG) ocamlnat$(EXE) "$(INSTALL_BINDIR)" endif - cd "$(INSTALL_COMPLIBDIR)" && \ - $(RANLIB) ocamlcommon.$(A) ocamlbytecomp.$(A) ocamloptcomp.$(A) # Installation of the *.ml sources of compiler-libs .PHONY: install-compiler-sources diff --git a/Makefile.build_config.in b/Makefile.build_config.in index eeac09dd..4d6705d2 100644 --- a/Makefile.build_config.in +++ b/Makefile.build_config.in @@ -20,7 +20,7 @@ # $(ROOTDIR) has been defined. include $(ROOTDIR)/Makefile.config -INSTALL ?= @INSTALL@ +INSTALL ?= @INSTALL@ -p INSTALL_DATA ?= @INSTALL_DATA@ INSTALL_PROG ?= @INSTALL_PROGRAM@ diff --git a/Makefile.config.in b/Makefile.config.in index eb3d85eb..4badb74c 100644 --- a/Makefile.config.in +++ b/Makefile.config.in @@ -88,10 +88,6 @@ LDFLAGS?=@LDFLAGS@ ### How to invoke the C preprocessor through the C compiler CPP=@CPP@ -### How to invoke ranlib -RANLIB=@RANLIB@ -RANLIBCMD=@RANLIBCMD@ - ### How to invoke ar ARCMD=@AR@ diff --git a/README.win32.adoc b/README.win32.adoc index ecf6b1ef..410a8eef 100644 --- a/README.win32.adoc +++ b/README.win32.adoc @@ -63,9 +63,7 @@ Only the `make` Cygwin package is required. `diffutils` is required if you wish to be able to run the test suite. Unless you are also compiling the Cygwin port of OCaml, you do not need the -`gcc-core` or `flexdll` packages. If you do install them, care may be required -to ensure that a particular build is using the correct installation of -`flexlink`. +`gcc-core` or `flexdll` packages. [[bmflex]] In addition to Cygwin, FlexDLL must also be installed, which is available from @@ -197,7 +195,7 @@ quickly as it will be unable to link `ocamlrun`. Now run: - ./configure --build=i686-pc-cygwin --host=i686-pc-windows + ./configure --build=x86_64-pc-cygwin --host=i686-pc-windows for 32-bit, or: @@ -262,7 +260,7 @@ the WinZip Options Window.) Now run: - ./configure --build=i686-pc-cygwin --host=i686-w64-mingw32 + ./configure --build=x86_64-pc-cygwin --host=i686-w64-mingw32 for 32-bit, or: diff --git a/VERSION b/VERSION index 5fbf658d..4d777f22 100644 --- a/VERSION +++ b/VERSION @@ -1,4 +1,4 @@ -4.14.0 +4.14.1 # Starting with OCaml 4.14, although the version string that appears above is # still correct and this file can thus still be used to figure it out, diff --git a/aclocal.m4 b/aclocal.m4 index 7e49468e..addb0d8b 100644 --- a/aclocal.m4 +++ b/aclocal.m4 @@ -328,6 +328,7 @@ AC_DEFUN([OCAML_TEST_FLEXLINK], [ CC="$1 -chain $2 -exe" LIBS="conftest2.$ac_objext" CPPFLAGS="$3 $CPPFLAGS" + CFLAGS="" AC_LINK_IFELSE( [AC_LANG_SOURCE([int main() { return 0; }])], [AC_MSG_RESULT([yes])], @@ -439,7 +440,7 @@ int main (void) { broken implementations of Cygwin64, mingw-w64 (x86_64) and VS2013-2017. The static volatile variables aim to thwart GCC's constant folding. */ static volatile double x, y, z; - double t264, t265, t266; + volatile double t264, t265, t266; x = 0x3.bd5b7dde5fddap-496; y = 0x3.bd5b7dde5fddap-496; z = -0xd.fc352bc352bap-992; diff --git a/asmcomp/amd64/reload.ml b/asmcomp/amd64/reload.ml index 1f4cadc3..9e3cadbe 100644 --- a/asmcomp/amd64/reload.ml +++ b/asmcomp/amd64/reload.ml @@ -33,7 +33,7 @@ open Mach Iload R R R Istore R R Iintop(Icomp) R R S - or S S R + or R S R Iintop(Imul|Idiv|Imod) R R S Iintop(Imulh) R R S Iintop(shift) S S R @@ -41,6 +41,7 @@ open Mach or S S R Iintop_imm(Iadd, n)/lea R R Iintop_imm(Imul, n) R R + Iintop_imm(Icomp, n) R S Iintop_imm(others) S S Inegf...Idivf R R S Ifloatofint R S @@ -66,7 +67,14 @@ inherit Reloadgen.reload_generic as super method! reload_operation op arg res = match op with - | Iintop(Iadd|Isub|Iand|Ior|Ixor|Icomp _|Icheckbound) -> + | Iintop(Iadd|Isub|Iand|Ior|Ixor|Icheckbound) -> + (* One of the two arguments can reside in the stack, but not both *) + if stackp arg.(0) && stackp arg.(1) + then ([|arg.(0); self#makereg arg.(1)|], res) + else (arg, res) + | Iintop(Icomp _) -> + (* The result must be a register (PR#11803) *) + let res = self#makeregs res in (* One of the two arguments can reside in the stack, but not both *) if stackp arg.(0) && stackp arg.(1) then ([|arg.(0); self#makereg arg.(1)|], res) @@ -80,6 +88,9 @@ method! reload_operation op arg res = if stackp arg.(0) then (let r = self#makereg arg.(0) in ([|r|], [|r|])) else (arg, res) + | Iintop_imm(Icomp _, _) -> + (* The result must be in a register (PR#11803) *) + (arg, self#makeregs res) | Iintop(Imulh | Idiv | Imod | Ilsl | Ilsr | Iasr) | Iintop_imm(_, _) -> (* The argument(s) and results can be either in register or on stack *) diff --git a/asmcomp/i386/reload.ml b/asmcomp/i386/reload.ml index 09497e05..6a20e887 100644 --- a/asmcomp/i386/reload.ml +++ b/asmcomp/i386/reload.ml @@ -40,7 +40,14 @@ method! makereg r = method! reload_operation op arg res = match op with - Iintop(Iadd|Isub|Iand|Ior|Ixor|Icomp _|Icheckbound) -> + Iintop(Iadd|Isub|Iand|Ior|Ixor|Icheckbound) -> + (* One of the two arguments can reside in the stack *) + if stackp arg.(0) && stackp arg.(1) + then ([|arg.(0); self#makereg arg.(1)|], res) + else (arg, res) + | Iintop(Icomp _) -> + (* The result must be a register (PR#11803) *) + let res = self#makeregs res in (* One of the two arguments can reside in the stack *) if stackp arg.(0) && stackp arg.(1) then ([|arg.(0); self#makereg arg.(1)|], res) @@ -60,6 +67,9 @@ method! reload_operation op arg res = if stackp arg.(0) then let r = self#makereg arg.(0) in ([|r|], [|r|]) else (arg, res) + | Iintop_imm(Icomp _, _) -> + (* The result must be in a register (PR#11803) *) + (arg, self#makeregs res) | Iintop(Imulh | Ilsl | Ilsr | Iasr) | Iintop_imm(_, _) | Ifloatofint | Iintoffloat | Ispecific(Ipush) -> (* The argument(s) can be either in register or on stack *) diff --git a/asmcomp/reloadgen.ml b/asmcomp/reloadgen.ml index d9c70716..c000dd4a 100644 --- a/asmcomp/reloadgen.ml +++ b/asmcomp/reloadgen.ml @@ -46,7 +46,7 @@ method makereg r = newr.spill_cost <- 100000; newr -method private makeregs rv = +method makeregs rv = let n = Array.length rv in let newv = Array.make n Reg.dummy in for i = 0 to n-1 do newv.(i) <- self#makereg rv.(i) done; diff --git a/asmcomp/reloadgen.mli b/asmcomp/reloadgen.mli index 638082f0..0cf264c4 100644 --- a/asmcomp/reloadgen.mli +++ b/asmcomp/reloadgen.mli @@ -20,6 +20,7 @@ class reload_generic : object (* Can be overridden to reflect instructions that can operate directly on stack locations *) method makereg : Reg.t -> Reg.t + method makeregs : Reg.t array -> Reg.t array (* Can be overridden to avoid creating new registers of some class (i.e. if all "registers" of that class are actually on stack) *) method fundecl : Mach.fundecl -> int array -> Mach.fundecl * bool diff --git a/boot/ocamlc b/boot/ocamlc index c8ea2f99..1f7167c5 100755 Binary files a/boot/ocamlc and b/boot/ocamlc differ diff --git a/boot/ocamllex b/boot/ocamllex index 27825a61..ab79e035 100755 Binary files a/boot/ocamllex and b/boot/ocamllex differ diff --git a/build-aux/ocaml_version.m4 b/build-aux/ocaml_version.m4 index 03c63069..8c69847c 100644 --- a/build-aux/ocaml_version.m4 +++ b/build-aux/ocaml_version.m4 @@ -33,7 +33,7 @@ m4_define([OCAML__DEVELOPMENT_VERSION], [false]) m4_define([OCAML__VERSION_MAJOR], [4]) m4_define([OCAML__VERSION_MINOR], [14]) -m4_define([OCAML__VERSION_PATCHLEVEL], [0]) +m4_define([OCAML__VERSION_PATCHLEVEL], [1]) # Note that the OCAML__VERSION_EXTRA string defined below is always empty # for officially-released versions of OCaml. m4_define([OCAML__VERSION_EXTRA], []) diff --git a/configure b/configure index 8a2c007f..2c956eff 100755 --- a/configure +++ b/configure @@ -56,7 +56,7 @@ if test -e '.git' ; then : fi fi # Guess values for system-dependent variables and create Makefiles. -# Generated by GNU Autoconf 2.69 for OCaml 4.14.0. +# Generated by GNU Autoconf 2.69 for OCaml 4.14.1. # # Report bugs to . # @@ -646,8 +646,8 @@ MAKEFLAGS= # Identity of this package. PACKAGE_NAME='OCaml' PACKAGE_TARNAME='ocaml' -PACKAGE_VERSION='4.14.0' -PACKAGE_STRING='OCaml 4.14.0' +PACKAGE_VERSION='4.14.1' +PACKAGE_STRING='OCaml 4.14.1' PACKAGE_BUGREPORT='caml-list@inria.fr' PACKAGE_URL='http://www.ocaml.org' @@ -711,6 +711,7 @@ NMEDIT DSYMUTIL MANIFEST_TOOL AWK +RANLIB STRIP ac_ct_AR DLLTOOL @@ -796,8 +797,6 @@ natdynlinkopts natdynlink supports_shared_libraries mklib -RANLIBCMD -RANLIB AR shebangscripts long_shebang @@ -1486,7 +1485,7 @@ if test "$ac_init_help" = "long"; then # Omit some internal or obsolete options to make the list less imposing. # This message is too long to be a string in the A/UX 3.1 sh. cat <<_ACEOF -\`configure' configures OCaml 4.14.0 to adapt to many kinds of systems. +\`configure' configures OCaml 4.14.1 to adapt to many kinds of systems. Usage: $0 [OPTION]... [VAR=VALUE]... @@ -1552,7 +1551,7 @@ fi if test -n "$ac_init_help"; then case $ac_init_help in - short | recursive ) echo "Configuration of OCaml 4.14.0:";; + short | recursive ) echo "Configuration of OCaml 4.14.1:";; esac cat <<\_ACEOF @@ -1718,7 +1717,7 @@ fi test -n "$ac_init_help" && exit $ac_status if $ac_init_version; then cat <<\_ACEOF -OCaml configure 4.14.0 +OCaml configure 4.14.1 generated by GNU Autoconf 2.69 Copyright (C) 2012 Free Software Foundation, Inc. @@ -2427,7 +2426,7 @@ cat >config.log <<_ACEOF This file contains any messages produced by compilers while running configure, to aid debugging if configure makes a mistake. -It was created by OCaml $as_me 4.14.0, which was +It was created by OCaml $as_me 4.14.1, which was generated by GNU Autoconf 2.69. Invocation command line was $ $0 $@ @@ -2776,8 +2775,8 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu -{ $as_echo "$as_me:${as_lineno-$LINENO}: Configuring OCaml version 4.14.0" >&5 -$as_echo "$as_me: Configuring OCaml version 4.14.0" >&6;} +{ $as_echo "$as_me:${as_lineno-$LINENO}: Configuring OCaml version 4.14.1" >&5 +$as_echo "$as_me: Configuring OCaml version 4.14.1" >&6;} # Configuration variables @@ -2853,7 +2852,7 @@ ac_configure="$SHELL $ac_aux_dir/configure" # Please don't use this var. -VERSION=4.14.0 +VERSION=4.14.1 OCAML_DEVELOPMENT_VERSION=false @@ -2863,7 +2862,7 @@ OCAML_VERSION_MAJOR=4 OCAML_VERSION_MINOR=14 -OCAML_VERSION_PATCHLEVEL=0 +OCAML_VERSION_PATCHLEVEL=1 OCAML_VERSION_EXTRA= @@ -2918,8 +2917,6 @@ OCAML_VERSION_SHORT=4.14 - - @@ -2987,15 +2984,15 @@ $as_echo "#define OCAML_VERSION_MAJOR 4" >>confdefs.h $as_echo "#define OCAML_VERSION_MINOR 14" >>confdefs.h -$as_echo "#define OCAML_VERSION_PATCHLEVEL 0" >>confdefs.h +$as_echo "#define OCAML_VERSION_PATCHLEVEL 1" >>confdefs.h $as_echo "#define OCAML_VERSION_ADDITIONAL \"\"" >>confdefs.h $as_echo "#define OCAML_VERSION_EXTRA \"\"" >>confdefs.h -$as_echo "#define OCAML_VERSION 41400" >>confdefs.h +$as_echo "#define OCAML_VERSION 41401" >>confdefs.h -$as_echo "#define OCAML_VERSION_STRING \"4.14.0\"" >>confdefs.h +$as_echo "#define OCAML_VERSION_STRING \"4.14.1\"" >>confdefs.h # Checks for system types @@ -12519,27 +12516,17 @@ else fi ;; esac -# Extracting information from libtool's configuration -if test -n "$RANLIB" ; then : - RANLIBCMD="$RANLIB" -else - RANLIB="$AR rs"; RANLIBCMD="" - -fi - case $host in #( # In config/Makefile.mingw*, we had: # TARGET=i686-w64-mingw32 and x86_64-w64-mingw32 # TOOLPREF=$(TARGET)- # ARCMD=$(TOOLPREF)ar - # RANLIB=$(TOOLPREF)ranlib - # RANLIBCMD=$(TOOLPREF)ranlib - # However autoconf and libtool seem to use ar and ranlib + # However autoconf and libtool seem to use ar # So we let them do, at the moment *-pc-windows) : libext=lib - AR=""; RANLIB=echo; RANLIBCMD="" + AR="" if test "$host_cpu" = "x86_64" ; then : machine="-machine:AMD64 " else @@ -12549,7 +12536,7 @@ fi ;; #( *) : - mklib="rm -f \$(1) && ${AR} rc \$(1) \$(2) && ${RANLIB} \$(1)" + mklib="rm -f \$(1) && ${AR} rc \$(1) \$(2)" ;; esac @@ -13084,6 +13071,7 @@ esac CC="$flexlink -chain $flexdll_chain -exe" LIBS="conftest2.$ac_objext" CPPFLAGS="$internal_cppflags $CPPFLAGS" + CFLAGS="" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main() { return 0; } @@ -14839,7 +14827,7 @@ int main (void) { broken implementations of Cygwin64, mingw-w64 (x86_64) and VS2013-2017. The static volatile variables aim to thwart GCC's constant folding. */ static volatile double x, y, z; - double t264, t265, t266; + volatile double t264, t265, t266; x = 0x3.bd5b7dde5fddap-496; y = 0x3.bd5b7dde5fddap-496; z = -0xd.fc352bc352bap-992; @@ -17890,6 +17878,8 @@ case $host in #( $as_echo "#define HAS_STRERROR 1" >>confdefs.h + $as_echo "#define HAS_IPV6 1" >>confdefs.h + $as_echo "#define HAS_NICE 1" >>confdefs.h ;; #( *-pc-windows) : @@ -18425,7 +18415,7 @@ cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # report actual input values of CONFIG_FILES etc. instead of their # values after options handling. ac_log=" -This file was extended by OCaml $as_me 4.14.0, which was +This file was extended by OCaml $as_me 4.14.1, which was generated by GNU Autoconf 2.69. Invocation command line was CONFIG_FILES = $CONFIG_FILES @@ -18492,7 +18482,7 @@ _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_cs_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`" ac_cs_version="\\ -OCaml config.status 4.14.0 +OCaml config.status 4.14.1 configured by $0, generated by GNU Autoconf 2.69, with options \\"\$ac_cs_config\\" diff --git a/configure.ac b/configure.ac index 2f4ebf9b..ebb8bbdb 100644 --- a/configure.ac +++ b/configure.ac @@ -119,8 +119,6 @@ AC_SUBST([bootstrapping_flexdll]) AC_SUBST([long_shebang]) AC_SUBST([shebangscripts]) AC_SUBST([AR]) -AC_SUBST([RANLIB]) -AC_SUBST([RANLIBCMD]) AC_SUBST([mklib]) AC_SUBST([supports_shared_libraries]) AC_SUBST([natdynlink]) @@ -474,32 +472,24 @@ AS_CASE([$enable_dependency_generation], [compute_deps=true])], [compute_deps=false])]) -# Extracting information from libtool's configuration -AS_IF([test -n "$RANLIB" ], - [RANLIBCMD="$RANLIB"], - [RANLIB="$AR rs"; RANLIBCMD=""] -) - AS_CASE([$host], # In config/Makefile.mingw*, we had: # TARGET=i686-w64-mingw32 and x86_64-w64-mingw32 # TOOLPREF=$(TARGET)- # ARCMD=$(TOOLPREF)ar - # RANLIB=$(TOOLPREF)ranlib - # RANLIBCMD=$(TOOLPREF)ranlib - # However autoconf and libtool seem to use ar and ranlib + # However autoconf and libtool seem to use ar # So we let them do, at the moment [*-pc-windows], [ libext=lib - AR=""; RANLIB=echo; RANLIBCMD="" + AR="" AS_IF([test "$host_cpu" = "x86_64" ], [machine="-machine:AMD64 "], [machine=""]) mklib="link -lib -nologo $machine /out:\$(1) \$(2)" ], [ - mklib="rm -f \$(1) && ${AR} rc \$(1) \$(2) && ${RANLIB} \$(1)" + mklib="rm -f \$(1) && ${AR} rc \$(1) \$(2)" ]) ## Find vendor of the C compiler @@ -2026,6 +2016,7 @@ AS_CASE([$host], [*-*-mingw32], [AC_DEFINE([HAS_BROKEN_PRINTF]) AC_DEFINE([HAS_STRERROR]) + AC_DEFINE([HAS_IPV6]) AC_DEFINE([HAS_NICE])], [*-pc-windows], [AC_DEFINE([HAS_BROKEN_PRINTF]) diff --git a/driver/main_args.ml b/driver/main_args.ml index 82034546..60db017a 100644 --- a/driver/main_args.ml +++ b/driver/main_args.ml @@ -569,10 +569,6 @@ let mk_no_unboxed_types f = " unannotated unboxable types will not be unboxed (default)" ;; -let mk_force_tmc f = - "-force-tmc", Arg.Unit f, " Rewrite all possible TMC calls" -;; - let mk_unsafe f = "-unsafe", Arg.Unit f, " Do not compile bounds checking on array and string access" @@ -935,7 +931,6 @@ module type Common_options = sig val _no_strict_sequence : unit -> unit val _strict_formats : unit -> unit val _no_strict_formats : unit -> unit - val _force_tmc : unit -> unit val _unboxed_types : unit -> unit val _no_unboxed_types : unit -> unit val _unsafe_string : unit -> unit @@ -1232,7 +1227,6 @@ struct mk_strict_formats F._strict_formats; mk_no_strict_formats F._no_strict_formats; mk_thread F._thread; - mk_force_tmc F._force_tmc; mk_unboxed_types F._unboxed_types; mk_no_unboxed_types F._no_unboxed_types; mk_unsafe F._unsafe; @@ -1435,7 +1429,6 @@ struct mk_strict_formats F._strict_formats; mk_no_strict_formats F._no_strict_formats; mk_thread F._thread; - mk_force_tmc F._force_tmc; mk_unbox_closures F._unbox_closures; mk_unbox_closures_factor F._unbox_closures_factor; mk_inline_max_unroll F._inline_max_unroll; @@ -1635,7 +1628,6 @@ struct mk_strict_formats F._strict_formats; mk_no_strict_formats F._no_strict_formats; mk_thread F._thread; - mk_force_tmc F._force_tmc; mk_unboxed_types F._unboxed_types; mk_no_unboxed_types F._no_unboxed_types; mk_unsafe_string F._unsafe_string; @@ -1939,7 +1931,6 @@ module Default = struct let _noprompt = set noprompt let _nopromptcont = set nopromptcont let _stdin () = (* placeholder: file_argument ""*) () - let _force_tmc = set force_tmc let _version () = print_version () let _vnum () = print_version_num () let _eval (_:string) = () @@ -1976,7 +1967,6 @@ module Default = struct "Profiling with \"gprof\" (option `-p') is only supported up to \ OCaml 4.08.0" let _shared () = shared := true; dlcode := true - let _force_tmc = set force_tmc let _v () = Compenv.print_version_and_library "native-code compiler" end @@ -1997,7 +1987,6 @@ module Default = struct let _pp s = Clflags.preprocessor := (Some s) let _ppx s = Clflags.all_ppx := (s :: (!Clflags.all_ppx)) let _thread = set Clflags.use_threads - let _force_tmc = set force_tmc let _v () = Compenv.print_version_and_library "documentation generator" let _verbose = set Clflags.verbose let _version = Compenv.print_version_string @@ -2031,7 +2020,6 @@ third-party libraries such as Lwt, but with a different API." let _output_complete_exe () = _output_complete_obj (); output_complete_executable := true let _output_obj () = output_c_object := true; custom_runtime := true - let _force_tmc = set force_tmc let _use_prims s = use_prims := s let _use_runtime s = use_runtime := s let _v () = Compenv.print_version_and_library "compiler" diff --git a/driver/main_args.mli b/driver/main_args.mli index 2b963ef1..d8b0b017 100644 --- a/driver/main_args.mli +++ b/driver/main_args.mli @@ -40,7 +40,6 @@ module type Common_options = sig val _no_strict_sequence : unit -> unit val _strict_formats : unit -> unit val _no_strict_formats : unit -> unit - val _force_tmc : unit -> unit val _unboxed_types : unit -> unit val _no_unboxed_types : unit -> unit val _unsafe_string : unit -> unit diff --git a/manual/src/cmds/intf-c.etex b/manual/src/cmds/intf-c.etex index 7cd50a13..bb420c29 100644 --- a/manual/src/cmds/intf-c.etex +++ b/manual/src/cmds/intf-c.etex @@ -1449,6 +1449,10 @@ the value \var{a} and returns the value returned by~\var{f}. (a curried OCaml function with three arguments) to \var{a}, \var{b} and \var{c}. \item "caml_callbackN("\var{f, n, args}")" applies the functional value \var{f} to the \var{n} arguments contained in the C array of values \var{args}. +The array \var{args} must \emph{not} be declared with "CAMLlocalN". +It should be declared as "value "\var{args}"["\var{n}"];". +Alternatively, a C99 compound literal can be used: +"caml_callbackN("\var{f, n, }"(value[]){"\nth{arg}{1}, \ldots, \nth{arg}{n}"})". \end{itemize} If the function \var{f} does not return, but raises an exception that escapes the scope of the application, then this exception is diff --git a/ocaml-variants.opam b/ocaml-variants.opam index 6dbf90e1..e64286c0 100644 --- a/ocaml-variants.opam +++ b/ocaml-variants.opam @@ -1,9 +1,9 @@ opam-version: "2.0" -version: "4.14.0" +version: "4.14.1" license: "LGPL-2.1-or-later WITH OCaml-LGPL-linking-exception" -synopsis: "Official release of OCaml 4.14.0" +synopsis: "Official release of OCaml 4.14.1" depends: [ - "ocaml" {= "4.14.0" & post} + "ocaml" {= "4.14.1" & post} "base-unix" {post} "base-bigarray" {post} "base-threads" {post} diff --git a/otherlibs/Makefile.otherlibs.common b/otherlibs/Makefile.otherlibs.common index 95ff4d58..17c8e2df 100644 --- a/otherlibs/Makefile.otherlibs.common +++ b/otherlibs/Makefile.otherlibs.common @@ -95,7 +95,6 @@ install:: fi ifneq "$(STUBSLIB)" "" $(INSTALL_DATA) $(STUBSLIB) "$(INSTALL_LIBDIR)/" - cd "$(INSTALL_LIBDIR)"; $(RANLIB) lib$(CLIBNAME).$(A) endif $(INSTALL_DATA) \ @@ -115,7 +114,6 @@ installopt: $(INSTALL_DATA) \ $(CAMLOBJS_NAT) $(LIBNAME).cmxa $(LIBNAME).$(A) \ "$(INSTALL_LIBDIR)/" - cd "$(INSTALL_LIBDIR)"; $(RANLIB) $(LIBNAME).a if test -f $(LIBNAME).cmxs; then \ $(INSTALL_PROG) $(LIBNAME).cmxs "$(INSTALL_LIBDIR)"; \ fi diff --git a/otherlibs/dynlink/Makefile b/otherlibs/dynlink/Makefile index 6b02dc19..c21bf573 100644 --- a/otherlibs/dynlink/Makefile +++ b/otherlibs/dynlink/Makefile @@ -249,12 +249,11 @@ ifeq "$(INSTALL_SOURCE_ARTIFACTS)" "true" endif installopt: - if $(NATDYNLINK); then \ - $(INSTALL_DATA) \ - $(NATOBJS) dynlink.cmxa dynlink.$(A) \ - "$(INSTALL_LIBDIR)" && \ - cd "$(INSTALL_LIBDIR)" && $(RANLIB) dynlink.$(A); \ - fi +ifeq "$(strip $(NATDYNLINK))" "true" + $(INSTALL_DATA) \ + $(NATOBJS) dynlink.cmxa dynlink.$(A) \ + "$(INSTALL_LIBDIR)" +endif partialclean: rm -f $(extract_crc) *.cm[ioaxt] *.cmti *.cmxa \ diff --git a/otherlibs/systhreads/Makefile b/otherlibs/systhreads/Makefile index 8fc1bdb9..640a7666 100644 --- a/otherlibs/systhreads/Makefile +++ b/otherlibs/systhreads/Makefile @@ -121,7 +121,6 @@ install: $(INSTALL_PROG) dllthreads$(EXT_DLL) "$(INSTALL_STUBLIBDIR)"; \ fi $(INSTALL_DATA) libthreads.$(A) "$(INSTALL_LIBDIR)" - cd "$(INSTALL_LIBDIR)"; $(RANLIB) libthreads.$(A) mkdir -p "$(INSTALL_THREADSLIBDIR)" $(INSTALL_DATA) \ $(CMIFILES) threads.cma \ @@ -136,11 +135,9 @@ endif installopt: $(INSTALL_DATA) libthreadsnat.$(A) "$(INSTALL_LIBDIR)" - cd "$(INSTALL_LIBDIR)"; $(RANLIB) libthreadsnat.$(A) $(INSTALL_DATA) \ $(THREADS_NCOBJS) threads.cmxa threads.$(A) \ "$(INSTALL_THREADSLIBDIR)" - cd "$(INSTALL_THREADSLIBDIR)" && $(RANLIB) threads.$(A) %.cmi: %.mli $(CAMLC) -c $(COMPFLAGS) $< diff --git a/otherlibs/systhreads/st_stubs.c b/otherlibs/systhreads/st_stubs.c index b7a6a9a6..043e0703 100644 --- a/otherlibs/systhreads/st_stubs.c +++ b/otherlibs/systhreads/st_stubs.c @@ -524,6 +524,7 @@ static ST_THREAD_FUNCTION caml_thread_start(void * arg) { caml_thread_t th = (caml_thread_t) arg; value clos; + void * signal_stack; #ifdef NATIVE_CODE struct longjmp_buffer termination_buf; char tos; @@ -536,7 +537,7 @@ static ST_THREAD_FUNCTION caml_thread_start(void * arg) /* Acquire the global mutex */ caml_leave_blocking_section(); st_thread_set_id(Ident(th->descr)); - caml_setup_stack_overflow_detection(); + signal_stack = caml_setup_stack_overflow_detection(); #ifdef NATIVE_CODE /* Setup termination handler (for caml_thread_exit) */ if (sigsetjmp(termination_buf.buf, 0) == 0) { @@ -550,7 +551,7 @@ static ST_THREAD_FUNCTION caml_thread_start(void * arg) #ifdef NATIVE_CODE } #endif - caml_stop_stack_overflow_detection(); + caml_stop_stack_overflow_detection(signal_stack); /* The thread now stops running */ return 0; } diff --git a/otherlibs/unix/unix.mli b/otherlibs/unix/unix.mli index d5f4cb98..1498a85e 100644 --- a/otherlibs/unix/unix.mli +++ b/otherlibs/unix/unix.mli @@ -995,11 +995,11 @@ val close_process_full : val symlink : ?to_dir: (* thwart tools/sync_stdlib_docs *) bool -> string -> string -> unit (** [symlink ?to_dir src dst] creates the file [dst] as a symbolic link - to the file [src]. On Windows, [to_dir] indicates if the symbolic link + to the file [src]. On Windows, [~to_dir] indicates if the symbolic link points to a directory or a file; if omitted, [symlink] examines [src] using [stat] and picks appropriately, if [src] does not exist then [false] - is assumed (for this reason, it is recommended that the [to_dir] parameter - be specified in new code). On Unix, [to_dir] is ignored. + is assumed (for this reason, it is recommended that the [~to_dir] parameter + be specified in new code). On Unix, [~to_dir] is ignored. Windows symbolic links are available in Windows Vista onwards. There are some important differences between Windows symlinks and their POSIX counterparts. diff --git a/otherlibs/win32unix/stat.c b/otherlibs/win32unix/stat.c index ab90993d..056fac98 100644 --- a/otherlibs/win32unix/stat.c +++ b/otherlibs/win32unix/stat.c @@ -347,6 +347,7 @@ static int do_stat(int do_lstat, int use_64, const char* opath, HANDLE fstat, __ CAMLprim value unix_stat(value path) { + CAMLparam1(path); struct _stat64 buf; __int64 st_ino; @@ -354,11 +355,12 @@ CAMLprim value unix_stat(value path) if (!do_stat(0, 0, String_val(path), NULL, &st_ino, &buf)) { uerror("stat", path); } - return stat_aux(0, st_ino, &buf); + CAMLreturn (stat_aux(0, st_ino, &buf)); } CAMLprim value unix_stat_64(value path) { + CAMLparam1(path); struct _stat64 buf; __int64 st_ino; @@ -366,11 +368,12 @@ CAMLprim value unix_stat_64(value path) if (!do_stat(0, 1, String_val(path), NULL, &st_ino, &buf)) { uerror("stat", path); } - return stat_aux(1, st_ino, &buf); + CAMLreturn (stat_aux(1, st_ino, &buf)); } CAMLprim value unix_lstat(value path) { + CAMLparam1(path); struct _stat64 buf; __int64 st_ino; @@ -378,11 +381,12 @@ CAMLprim value unix_lstat(value path) if (!do_stat(1, 0, String_val(path), NULL, &st_ino, &buf)) { uerror("lstat", path); } - return stat_aux(0, st_ino, &buf); + CAMLreturn (stat_aux(0, st_ino, &buf)); } CAMLprim value unix_lstat_64(value path) { + CAMLparam1(path); struct _stat64 buf; __int64 st_ino; @@ -390,7 +394,7 @@ CAMLprim value unix_lstat_64(value path) if (!do_stat(1, 1, String_val(path), NULL, &st_ino, &buf)) { uerror("lstat", path); } - return stat_aux(1, st_ino, &buf); + CAMLreturn (stat_aux(1, st_ino, &buf)); } static value do_fstat(value handle, int use_64) diff --git a/runtime/caml/fix_code.h b/runtime/caml/fix_code.h index 83c393a1..2eafaa81 100644 --- a/runtime/caml/fix_code.h +++ b/runtime/caml/fix_code.h @@ -34,8 +34,7 @@ void caml_set_instruction (code_t pos, opcode_t instr); int caml_is_instruction (opcode_t instr1, opcode_t instr2); #ifdef THREADED_CODE -extern char ** caml_instr_table; -extern char * caml_instr_base; +void caml_init_thread_code(void ** instr_table, void * instr_base); void caml_thread_code (code_t code, asize_t len); #endif diff --git a/runtime/caml/memory.h b/runtime/caml/memory.h index 1e9cdf6d..d9e58bc2 100644 --- a/runtime/caml/memory.h +++ b/runtime/caml/memory.h @@ -329,7 +329,7 @@ struct caml__roots_block { #define CAMLunused_start __attribute__ ((unused)) #define CAMLunused_end #define CAMLunused __attribute__ ((unused)) -#elif _MSC_VER >= 1500 +#elif defined(_MSC_VER) && _MSC_VER >= 1500 #define CAMLunused_start __pragma( warning (push) ) \ __pragma( warning (disable:4189 ) ) #define CAMLunused_end __pragma( warning (pop)) diff --git a/runtime/caml/misc.h b/runtime/caml/misc.h index 5915c30a..c605f871 100644 --- a/runtime/caml/misc.h +++ b/runtime/caml/misc.h @@ -35,7 +35,7 @@ /* Supported since at least GCC 3.1 */ #define CAMLdeprecated_typedef(name, type) \ typedef type name __attribute ((deprecated)) -#elif _MSC_VER >= 1310 +#elif defined(_MSC_VER) && _MSC_VER >= 1310 /* NB deprecated("message") only supported from _MSC_VER >= 1400 */ #define CAMLdeprecated_typedef(name, type) \ typedef __declspec(deprecated) type name @@ -43,7 +43,8 @@ #define CAMLdeprecated_typedef(name, type) typedef type name #endif -#if defined(__GNUC__) && __STDC_VERSION__ >= 199901L || _MSC_VER >= 1925 +#if defined(__GNUC__) && __STDC_VERSION__ >= 199901L \ + || defined(_MSC_VER) && _MSC_VER >= 1925 #define CAML_STRINGIFY(x) #x #ifdef _MSC_VER @@ -90,7 +91,7 @@ CAMLdeprecated_typedef(addr, char *); #define CAMLnoreturn_start #define CAMLnoreturn_end __attribute__ ((noreturn)) #define Noreturn __attribute__ ((noreturn)) -#elif _MSC_VER >= 1500 +#elif defined(_MSC_VER) && _MSC_VER >= 1500 #define CAMLnoreturn_start __declspec(noreturn) #define CAMLnoreturn_end #define Noreturn @@ -138,11 +139,12 @@ CAMLdeprecated_typedef(addr, char *); /* we need to be able to compute the exact offset of each member. */ #if defined(__STDC_VERSION__) && __STDC_VERSION__ >= 201112L #define CAMLalign(n) _Alignas(n) -#elif defined(__cplusplus) && (__cplusplus >= 201103L || _MSC_VER >= 1900) +#elif defined(__cplusplus) \ + && (__cplusplus >= 201103L || defined(_MSC_VER) && _MSC_VER >= 1900) #define CAMLalign(n) alignas(n) #elif defined(SUPPORTS_ALIGNED_ATTRIBUTE) #define CAMLalign(n) __attribute__((aligned(n))) -#elif _MSC_VER >= 1500 +#elif defined(_MSC_VER) && _MSC_VER >= 1500 #define CAMLalign(n) __declspec(align(n)) #else #error "How do I align values on this platform?" @@ -170,7 +172,7 @@ CAMLdeprecated_typedef(addr, char *); #define CAMLunused_start __attribute__ ((unused)) #define CAMLunused_end #define CAMLunused __attribute__ ((unused)) -#elif _MSC_VER >= 1500 +#elif defined(_MSC_VER) && _MSC_VER >= 1500 #define CAMLunused_start __pragma( warning (push) ) \ __pragma( warning (disable:4189 ) ) #define CAMLunused_end __pragma( warning (pop)) diff --git a/runtime/caml/signals.h b/runtime/caml/signals.h index c6aeebfc..62b0e7fa 100644 --- a/runtime/caml/signals.h +++ b/runtime/caml/signals.h @@ -87,8 +87,8 @@ value caml_do_pending_actions_exn (void); value caml_process_pending_actions_with_root (value extra_root); // raises value caml_process_pending_actions_with_root_exn (value extra_root); int caml_set_signal_action(int signo, int action); -CAMLextern int caml_setup_stack_overflow_detection(void); -CAMLextern int caml_stop_stack_overflow_detection(void); +CAMLextern void * caml_setup_stack_overflow_detection(void); +CAMLextern int caml_stop_stack_overflow_detection(void *); CAMLextern void caml_init_signals(void); CAMLextern void caml_terminate_signals(void); CAMLextern void (*caml_enter_blocking_section_hook)(void); diff --git a/runtime/fix_code.c b/runtime/fix_code.c index aa059be5..55840198 100644 --- a/runtime/fix_code.c +++ b/runtime/fix_code.c @@ -82,8 +82,14 @@ void caml_fixup_endianness(code_t code, asize_t len) #ifdef THREADED_CODE -char ** caml_instr_table; -char * caml_instr_base; +static char ** caml_instr_table; +static char * caml_instr_base; + +void caml_init_thread_code(void ** instr_table, void * instr_base) +{ + caml_instr_table = (char **) instr_table; + caml_instr_base = (char *) instr_base; +} static int* opcode_nargs = NULL; int* caml_init_opcode_nargs(void) diff --git a/runtime/interp.c b/runtime/interp.c index a59811c8..e6700994 100644 --- a/runtime/interp.c +++ b/runtime/interp.c @@ -50,9 +50,9 @@ sp is a local copy of the global variable Caml_state->extern_sp. */ #ifdef THREADED_CODE # define Instruct(name) lbl_##name # if defined(ARCH_SIXTYFOUR) && !defined(ARCH_CODE32) -# define Jumptbl_base ((char *) &&lbl_ACC0) +# define Jumptbl_base &&lbl_ACC0 # else -# define Jumptbl_base ((char *) 0) +# define Jumptbl_base 0 # define jumptbl_base ((char *) 0) # endif # ifdef DEBUG @@ -249,8 +249,7 @@ value caml_interprete(code_t prog, asize_t prog_size) if (prog == NULL) { /* Interpreter is initializing */ #ifdef THREADED_CODE - caml_instr_table = (char **) jumptable; - caml_instr_base = Jumptbl_base; + caml_init_thread_code(jumptable, Jumptbl_base); #endif return Val_unit; } diff --git a/runtime/signals_byt.c b/runtime/signals_byt.c index 439fb564..7cb461ac 100644 --- a/runtime/signals_byt.c +++ b/runtime/signals_byt.c @@ -81,7 +81,7 @@ int caml_set_signal_action(int signo, int action) return 0; } -CAMLexport int caml_setup_stack_overflow_detection(void) { return 0; } -CAMLexport int caml_stop_stack_overflow_detection(void) { return 0; } +CAMLexport void * caml_setup_stack_overflow_detection(void) { return NULL; } +CAMLexport int caml_stop_stack_overflow_detection(void * p) { return 0; } CAMLexport void caml_init_signals(void) { } CAMLexport void caml_terminate_signals(void) { } diff --git a/runtime/signals_nat.c b/runtime/signals_nat.c index 443f5d53..1dd8289c 100644 --- a/runtime/signals_nat.c +++ b/runtime/signals_nat.c @@ -254,6 +254,10 @@ DECLARE_SIGNAL_HANDLER(segv_handler) /* Initialization of signal stuff */ +#ifdef HAS_STACK_OVERFLOW_DETECTION +static void * caml_signal_stack = NULL; +#endif + void caml_init_signals(void) { /* Bound-check trap handling */ @@ -278,7 +282,8 @@ void caml_init_signals(void) #endif #ifdef HAS_STACK_OVERFLOW_DETECTION - if (caml_setup_stack_overflow_detection() != -1) { + caml_signal_stack = caml_setup_stack_overflow_detection(); + if (caml_signal_stack != NULL) { struct sigaction act; SET_SIGACT(act, segv_handler); act.sa_flags |= SA_ONSTACK | SA_NODEFER; @@ -314,7 +319,8 @@ void caml_terminate_signals(void) #ifdef HAS_STACK_OVERFLOW_DETECTION set_signal_default(SIGSEGV); - caml_stop_stack_overflow_detection(); + caml_stop_stack_overflow_detection(caml_signal_stack); + caml_signal_stack = NULL; #endif } @@ -323,37 +329,44 @@ void caml_terminate_signals(void) Each thread needs its own alternate stack. The alternate stack used to be statically-allocated for the main thread, but this is incompatible with Glibc 2.34 and newer, where SIGSTKSZ - may not be a compile-time constant (issue #10250). */ + may not be a compile-time constant (issue #10250). + Return the dynamically-allocated alternate signal stack, or NULL + if an error occurred. + The returned pointer must be passed to [caml_stop_stack_overflow_detection]. +*/ -CAMLexport int caml_setup_stack_overflow_detection(void) +CAMLexport void * caml_setup_stack_overflow_detection(void) { #ifdef HAS_STACK_OVERFLOW_DETECTION stack_t stk; - stk.ss_sp = malloc(SIGSTKSZ); - if (stk.ss_sp == NULL) return -1; stk.ss_size = SIGSTKSZ; + stk.ss_sp = malloc(stk.ss_size); + if (stk.ss_sp == NULL) return NULL; stk.ss_flags = 0; if (sigaltstack(&stk, NULL) == -1) { free(stk.ss_sp); - return -1; + return NULL; } + return stk.ss_sp; +#else + return NULL; #endif - /* Success (or stack overflow detection not available) */ - return 0; } -CAMLexport int caml_stop_stack_overflow_detection(void) +CAMLexport int caml_stop_stack_overflow_detection(void * signal_stack) { #ifdef HAS_STACK_OVERFLOW_DETECTION stack_t oldstk, stk; stk.ss_flags = SS_DISABLE; + stk.ss_sp = NULL; /* not required but avoids a valgrind false alarm */ + stk.ss_size = SIGSTKSZ; /* macOS wants a valid size here */ if (sigaltstack(&stk, &oldstk) == -1) return -1; - /* If caml_setup_stack_overflow_detection failed, we are not using - an alternate signal stack. SS_DISABLE will be set in oldstk, - and there is nothing to free in this case. */ - if (! (oldstk.ss_flags & SS_DISABLE)) free(oldstk.ss_sp); - return 0; -#else - return 0; + /* Check whether someone else installed their own signal stack */ + if (!(oldstk.ss_flags & SS_DISABLE) && oldstk.ss_sp != signal_stack) { + /* Re-activate their signal stack. */ + sigaltstack(&oldstk, NULL); + } + free(signal_stack); #endif + return 0; } diff --git a/runtime/stacks.c b/runtime/stacks.c index a1409b2a..611b0501 100644 --- a/runtime/stacks.c +++ b/runtime/stacks.c @@ -24,7 +24,7 @@ #include "caml/mlvalues.h" #include "caml/stacks.h" -value caml_global_data = 0; +value caml_global_data = Val_unit; /* must be a valid value (#11768) */ uintnat caml_max_stack_size; /* also used in gc_ctrl.c */ diff --git a/stdlib/Makefile b/stdlib/Makefile index df34bc2d..f367956f 100644 --- a/stdlib/Makefile +++ b/stdlib/Makefile @@ -105,7 +105,6 @@ installopt-default:: $(INSTALL_DATA) \ stdlib.cmxa stdlib.$(A) std_exit.$(O) *.cmx \ "$(INSTALL_LIBDIR)" - cd "$(INSTALL_LIBDIR)"; $(RANLIB) stdlib.$(A) ifeq "$(UNIX_OR_WIN32)" "unix" HEADERPROGRAM = header diff --git a/stdlib/float.mli b/stdlib/float.mli index ba84d9b0..93d2f301 100644 --- a/stdlib/float.mli +++ b/stdlib/float.mli @@ -178,7 +178,12 @@ val of_string_opt: string -> float option (** Same as [of_string], but returns [None] instead of raising. *) val to_string : float -> string -(** Return the string representation of a floating-point number. *) +(** Return a string representation of a floating-point number. + + This conversion can involve a loss of precision. For greater control over + the manner in which the number is printed, see {!Printf}. + + This function is an alias for {!Stdlib.string_of_float}. *) type fpclass = Stdlib.fpclass = FP_normal (** Normal number, none of the below *) diff --git a/stdlib/gc.mli b/stdlib/gc.mli index b211197f..8031eeb8 100644 --- a/stdlib/gc.mli +++ b/stdlib/gc.mli @@ -442,7 +442,10 @@ external eventlog_pause : unit -> unit = "caml_eventlog_pause" Traces are collected if the program is linked to the instrumented runtime and started with the environment variable OCAML_EVENTLOG_ENABLED. Events are flushed to disk after pausing, and no new events will be - recorded until [eventlog_resume] is called. *) + recorded until [eventlog_resume] is called. + + @since 4.11 + *) external eventlog_resume : unit -> unit = "caml_eventlog_resume" (** [eventlog_resume ()] will resume the collection of traces in the @@ -451,7 +454,10 @@ external eventlog_resume : unit -> unit = "caml_eventlog_resume" and started with the environment variable OCAML_EVENTLOG_ENABLED. This call can be used after calling [eventlog_pause], or if the program was started with OCAML_EVENTLOG_ENABLED=p. (which pauses the collection of - traces before the first event.) *) + traces before the first event.) + + @since 4.11 + *) (** [Memprof] is a sampling engine for allocated memory words. Every diff --git a/stdlib/stdlib.mli b/stdlib/stdlib.mli index 237adfbd..0eaee271 100644 --- a/stdlib/stdlib.mli +++ b/stdlib/stdlib.mli @@ -776,7 +776,10 @@ external int_of_string : string -> int = "caml_int_of_string" [Failure "int_of_string"] instead of returning [None]. *) val string_of_float : float -> string -(** Return the string representation of a floating-point number. *) +(** Return a string representation of a floating-point number. + + This conversion can involve a loss of precision. For greater control over + the manner in which the number is printed, see {!Printf}. *) val float_of_string_opt: string -> float option (** Convert the given string to a float. The string is read in decimal @@ -861,7 +864,10 @@ val print_int : int -> unit (** Print an integer, in decimal, on standard output. *) val print_float : float -> unit -(** Print a floating-point number, in decimal, on standard output. *) +(** Print a floating-point number, in decimal, on standard output. + + The conversion of the number to a string uses {!string_of_float} and + can involve a loss of precision. *) val print_endline : string -> unit (** Print a string, followed by a newline character, on @@ -889,7 +895,10 @@ val prerr_int : int -> unit (** Print an integer, in decimal, on standard error. *) val prerr_float : float -> unit -(** Print a floating-point number, in decimal, on standard error. *) +(** Print a floating-point number, in decimal, on standard error. + + The conversion of the number to a string uses {!string_of_float} and + can involve a loss of precision. *) val prerr_endline : string -> unit (** Print a string, followed by a newline character on standard diff --git a/stdlib/string.mli b/stdlib/string.mli index cc22af55..414b3936 100644 --- a/stdlib/string.mli +++ b/stdlib/string.mli @@ -139,8 +139,8 @@ val concat : string -> string list -> string val cat : string -> string -> string (** [cat s1 s2] concatenates s1 and s2 ([s1 ^ s2]). - @raise Invalid_argument if the result is longer then - than {!Sys.max_string_length} bytes. + @raise Invalid_argument if the result is longer than + {!Sys.max_string_length} bytes. @since 4.13.0 *) @@ -158,14 +158,14 @@ val compare : t -> t -> int val starts_with : prefix (* comment thwarts tools/sync_stdlib_docs *) :string -> string -> bool -(** [starts_with ][~][prefix s] is [true] if and only if [s] starts with +(** [starts_with ][~prefix s] is [true] if and only if [s] starts with [prefix]. @since 4.13.0 *) val ends_with : suffix (* comment thwarts tools/sync_stdlib_docs *) :string -> string -> bool -(** [ends_with suffix s] is [true] if and only if [s] ends with [suffix]. +(** [ends_with ][~suffix s] is [true] if and only if [s] ends with [suffix]. @since 4.13.0 *) diff --git a/stdlib/stringLabels.mli b/stdlib/stringLabels.mli index ac14715e..91b971ed 100644 --- a/stdlib/stringLabels.mli +++ b/stdlib/stringLabels.mli @@ -139,8 +139,8 @@ val concat : sep:string -> string list -> string val cat : string -> string -> string (** [cat s1 s2] concatenates s1 and s2 ([s1 ^ s2]). - @raise Invalid_argument if the result is longer then - than {!Sys.max_string_length} bytes. + @raise Invalid_argument if the result is longer than + {!Sys.max_string_length} bytes. @since 4.13.0 *) @@ -158,14 +158,14 @@ val compare : t -> t -> int val starts_with : prefix (* comment thwarts tools/sync_stdlib_docs *) :string -> string -> bool -(** [starts_with ][~][prefix s] is [true] if and only if [s] starts with +(** [starts_with ][~prefix s] is [true] if and only if [s] starts with [prefix]. @since 4.13.0 *) val ends_with : suffix (* comment thwarts tools/sync_stdlib_docs *) :string -> string -> bool -(** [ends_with ~suffix s] is [true] if and only if [s] ends with [suffix]. +(** [ends_with ][~suffix s] is [true] if and only if [s] ends with [suffix]. @since 4.13.0 *) diff --git a/stdlib/templates/float.template.mli b/stdlib/templates/float.template.mli index e35c0180..e2f7411a 100644 --- a/stdlib/templates/float.template.mli +++ b/stdlib/templates/float.template.mli @@ -178,7 +178,12 @@ val of_string_opt: string -> float option (** Same as [of_string], but returns [None] instead of raising. *) val to_string : float -> string -(** Return the string representation of a floating-point number. *) +(** Return a string representation of a floating-point number. + + This conversion can involve a loss of precision. For greater control over + the manner in which the number is printed, see {!Printf}. + + This function is an alias for {!Stdlib.string_of_float}. *) type fpclass = Stdlib.fpclass = FP_normal (** Normal number, none of the below *) diff --git a/testsuite/tests/lib-bigarray-2/has-gfortran.sh b/testsuite/tests/lib-bigarray-2/has-gfortran.sh index 82f7ae8a..7eef1e66 100644 --- a/testsuite/tests/lib-bigarray-2/has-gfortran.sh +++ b/testsuite/tests/lib-bigarray-2/has-gfortran.sh @@ -5,6 +5,9 @@ if ! which gfortran > /dev/null 2>&1; then elif ! grep -q '^CC=gcc' ${ocamlsrcdir}/Makefile.config; then echo "OCaml was not compiled with gcc" > ${ocamltest_response} test_result=${TEST_SKIP} +elif gcc --version 2>&1 | grep -q 'Apple clang version'; then + echo "OCaml was not compiled with gcc" > ${ocamltest_response} + test_result=${TEST_SKIP} else test_result=${TEST_PASS} fi diff --git a/testsuite/tests/lib-channels/input_all.ml b/testsuite/tests/lib-channels/input_all.ml index 4de94539..711eed73 100644 --- a/testsuite/tests/lib-channels/input_all.ml +++ b/testsuite/tests/lib-channels/input_all.ml @@ -1,6 +1,11 @@ (* TEST + +* hassysthreads include systhreads readonly_files = "input_all.ml" +** bytecode +** native + *) let data_file = diff --git a/testsuite/tests/tool-toplevel/show.ml b/testsuite/tests/tool-toplevel/show.ml index 425c6c7e..28b59d9f 100644 --- a/testsuite/tests/tool-toplevel/show.ml +++ b/testsuite/tests/tool-toplevel/show.ml @@ -124,3 +124,52 @@ type _ t += A : int t [%%expect{| type 'a t += A : int t |}];; + + + + +(* regression tests for #11533 *) +#show Set.OrderedType;; +[%%expect {| +module type OrderedType = sig type t val compare : t -> t -> int end +|}];; + +(* extra tests after #11533 + + The regression in #11533 would only show up when showing values defined + outside the current module. Those new tests below test modules and module + types from the standard library. To minimize test churn / promotion, + we are looking for some that will change as little as possible + in the future. + + - For module type it's easy: OrderedType is fixed in stone as + changing it would break all code using Set.Make. + + - For modules we use Stdlib.Unit, one of the stdlib modules + that is less likely to change very often (there are only + so many features you can add to 'unit'). +*) +module U = Stdlib.Unit;; +module type OT = Set.OrderedType;; +[%%expect {| +module U = Unit +module type OT = Set.OrderedType +|}];; + +#show U;; +[%%expect {| +module U = Unit +module U : + sig + type t = unit = () + val equal : t -> t -> bool + val compare : t -> t -> int + val to_string : t -> string + end +|}];; + +#show OT;; +[%%expect {| +module type OT = Set.OrderedType +module type OT = sig type t val compare : t -> t -> int end +|}];; diff --git a/testsuite/tests/typing-external/pr11392.ml b/testsuite/tests/typing-external/pr11392.ml new file mode 100644 index 00000000..91c8ea77 --- /dev/null +++ b/testsuite/tests/typing-external/pr11392.ml @@ -0,0 +1,34 @@ +(* TEST + * expect +*) + +type 'self nat = + | Z + | S of 'self +;; +[%%expect{| +type 'self nat = Z | S of 'self +|}] + + + +(* without rectypes: rejected *) +external cast : int -> 'self nat as 'self = "%identity" +;; +[%%expect{| +Line 1, characters 16-41: +1 | external cast : int -> 'self nat as 'self = "%identity" + ^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This alias is bound to type int -> 'a nat + but is used as an instance of type 'a + The type variable 'a occurs inside int -> 'a nat +|}] + +#rectypes;; + +(* with rectypes: accepted (used to crash) *) +external cast : int -> 'self nat as 'self = "%identity" +;; +[%%expect{| +external cast : int -> 'a nat as 'a = "%identity" +|}] diff --git a/testsuite/tests/typing-modules/functors.ml b/testsuite/tests/typing-modules/functors.ml index 932bc9f9..3fa34a1d 100644 --- a/testsuite/tests/typing-modules/functors.ml +++ b/testsuite/tests/typing-modules/functors.ml @@ -1701,3 +1701,47 @@ Error: The functor application Bar(A)(FiveArgsExt)(TY)(TY)(TY)(TY)(TY) is ill-ty 8. Module TY matches the expected module type ty 9. Module TY matches the expected module type ty |}] + +module Shape_arg = struct + module M1 (Arg1 : sig end) = struct + module type S1 = sig + type t + end + end + + module type S2 = sig + module Make (Arg2 : sig end) : M1(Arg2).S1 + end + + module M2 : S2 = struct + module Make (Arg3 : sig end) = struct + type t = T + end + end + + module M3 (Arg4 : sig end) = struct + module type S3 = sig + type t = M2.Make(Arg4).t + end + end + + module M4 (Arg5 : sig end) : M3(Arg5).S3 = struct + module M5 = M2.Make (Arg5) + + type t = M5.t + end +end +[%%expect{| +module Shape_arg : + sig + module M1 : + functor (Arg1 : sig end) -> sig module type S1 = sig type t end end + module type S2 = + sig module Make : functor (Arg2 : sig end) -> M1(Arg2).S1 end + module M2 : S2 + module M3 : + functor (Arg4 : sig end) -> + sig module type S3 = sig type t = M2.Make(Arg4).t end end + module M4 : functor (Arg5 : sig end) -> M3(Arg5).S3 + end +|}] diff --git a/testsuite/tests/typing-modules/inclusion_errors.ml b/testsuite/tests/typing-modules/inclusion_errors.ml index 4e7ff09b..e4333a08 100644 --- a/testsuite/tests/typing-modules/inclusion_errors.ml +++ b/testsuite/tests/typing-modules/inclusion_errors.ml @@ -1715,3 +1715,96 @@ Error: Signature mismatch: type t = < m : int > A private row type would be revealed. |}];; + + +(** Unexpected recursive types *) +module M: sig + type _ t = A : ( as 'a) -> ( as 'b) t +end = struct + type _ t = A : ( as 'a) -> ( as 'b) t +end +[%%expect {| +Lines 3-5, characters 6-3: +3 | ......struct +4 | type _ t = A : ( as 'a) -> ( as 'b) t +5 | end +Error: Signature mismatch: + Modules do not match: + sig + type _ t = A : (< x : 'b * 'b > as 'b) -> (< y : 'a > as 'a) t + end + is not included in + sig type _ t = A : (< x : 'b > as 'b) -> (< y : 'a > as 'a) t end + Type declarations do not match: + type _ t = A : (< x : 'b * 'b > as 'b) -> (< y : 'a > as 'a) t + is not included in + type _ t = A : (< x : 'b > as 'b) -> (< y : 'a > as 'a) t + Constructors do not match: + A : (< x : 'b * 'b > as 'b) -> (< y : 'a > as 'a) t + is not the same as: + A : (< x : 'b > as 'b) -> (< y : 'a > as 'a) t + The type < x : 'a * 'a > as 'a is not equal to the type + < x : 'b > as 'b + Types for method x are incompatible +|}] +module R: sig + type t = { a: ( as 'a) } +end = struct + type t = { a: ( as 'a) } +end +[%%expect {| +Lines 3-5, characters 6-3: +3 | ......struct +4 | type t = { a: ( as 'a) } +5 | end +Error: Signature mismatch: + Modules do not match: + sig type t = { a : < x : 'a * 'a > as 'a; } end + is not included in + sig type t = { a : < x : 'a > as 'a; } end + Type declarations do not match: + type t = { a : < x : 'a * 'a > as 'a; } + is not included in + type t = { a : < x : 'a > as 'a; } + Fields do not match: + a : < x : 'a * 'a > as 'a; + is not the same as: + a : < x : 'a > as 'a; + The type < x : 'a * 'a > as 'a is not equal to the type + < x : 'b > as 'b + Types for method x are incompatible +|}] +type _ ext = .. +module Ext: sig + type _ ext += A : ( as 'a) -> ( as 'b) ext +end = struct + type _ ext += A : ( as 'a) -> ( as 'b) ext +end +[%%expect {| +type _ ext = .. +Lines 4-6, characters 6-3: +4 | ......struct +5 | type _ ext += A : ( as 'a) -> ( as 'b) ext +6 | end +Error: Signature mismatch: + Modules do not match: + sig + type _ ext += + A : (< x : 'b * 'b > as 'b) -> (< y : 'a > as 'a) ext + end + is not included in + sig + type _ ext += A : (< x : 'b > as 'b) -> (< y : 'a > as 'a) ext + end + Extension declarations do not match: + type _ ext += A : (< x : 'b * 'b > as 'b) -> (< y : 'a > as 'a) ext + is not included in + type _ ext += A : (< x : 'b > as 'b) -> (< y : 'a > as 'a) ext + Constructors do not match: + A : (< x : 'b * 'b > as 'b) -> (< y : 'a > as 'a) ext + is not the same as: + A : (< x : 'b > as 'b) -> (< y : 'a > as 'a) ext + The type < x : 'a * 'a > as 'a is not equal to the type + < x : 'b > as 'b + Types for method x are incompatible +|}] diff --git a/testsuite/tests/typing-modules/inclusion_errors_elision.ml b/testsuite/tests/typing-modules/inclusion_errors_elision.ml new file mode 100644 index 00000000..3dbd0e67 --- /dev/null +++ b/testsuite/tests/typing-modules/inclusion_errors_elision.ml @@ -0,0 +1,93 @@ +(* TEST + flags ="-keep-original-error-size" + * expect + *) + + +module A = struct + type a and b and c and d +end + +module type S = sig + module B = A +end + +module C : S = struct + module B = struct + type a and b and c and d and e and f and g and h + end +end +[%%expect {| +module A : sig type a and b and c and d end +module type S = sig module B = A end +Lines 9-13, characters 15-3: + 9 | ...............struct +10 | module B = struct +11 | type a and b and c and d and e and f and g and h +12 | end +13 | end +Error: Signature mismatch: + ... + In module B: + Modules do not match: + sig + type a = B.a + and b = B.b + and c = B.c + and d = B.d + and e = B.e + and f = B.f + and g = B.g + and h = B.h + end + is not included in + (module A) +|}] + +module A = struct + type a and b and c and d +end + +module type S = sig + module type B = sig + module C = A + end +end + +module D : S = struct + module type B = sig + module C: sig + type a and b and c and d and e and f and g and h + end + end +end +[%%expect{| +module A : sig type a and b and c and d end +module type S = sig module type B = sig module C = A end end +Lines 11-17, characters 15-3: +11 | ...............struct +12 | module type B = sig +13 | module C: sig +14 | type a and b and c and d and e and f and g and h +15 | end +16 | end +17 | end +Error: Signature mismatch: + ... + ... + ... + At position module type B = sig module C : end + Modules do not match: + sig + type a = C.a + and b = C.b + and c = C.c + and d = C.d + and e = C.e + and f = C.f + and g = C.g + and h = C.h + end + is not included in + (module A) +|}] diff --git a/testsuite/tests/typing-modules/packed_module_levels.ml b/testsuite/tests/typing-modules/packed_module_levels.ml new file mode 100644 index 00000000..a4883d00 --- /dev/null +++ b/testsuite/tests/typing-modules/packed_module_levels.ml @@ -0,0 +1,42 @@ +(* TEST + * expect +*) +type (_, _) equ = Refl : ('q, 'q) equ + +module type Ty = sig type t end +type 'a modu = (module Ty with type t = 'a) + +type 'q1 packed = + P : 'q0 modu * ('q0, 'q1) equ -> 'q1 packed + +(* Adds a module M to the environment where M.t equals an existential *) +let repack (type q) (x : q packed) : q modu = + match x with + | P (p, eq) -> + let module M = (val p) in + let Refl = eq in + (module M) + +[%%expect{| +type (_, _) equ = Refl : ('q, 'q) equ +module type Ty = sig type t end +type 'a modu = (module Ty with type t = 'a) +type 'q1 packed = P : 'q0 modu * ('q0, 'q1) equ -> 'q1 packed +val repack : 'q packed -> 'q modu = +|}] + +(* Same, using a polymorphic function rather than an existential *) + +let mkmod (type a) () : a modu = + (module struct type t = a end) + +let f (type foo) (intish : (foo, int) equ) = + let module M = (val (mkmod () : foo modu)) in + let Refl = intish in + let module C : sig type t = int end = M in + () + +[%%expect{| +val mkmod : unit -> 'a modu = +val f : ('foo, int) equ -> unit = +|}] diff --git a/testsuite/tests/typing-objects/Tests.ml b/testsuite/tests/typing-objects/Tests.ml index f617bcf1..dd94c074 100644 --- a/testsuite/tests/typing-objects/Tests.ml +++ b/testsuite/tests/typing-objects/Tests.ml @@ -955,6 +955,21 @@ Warning 17 [undeclared-virtual-method]: the virtual method m is not declared. class c : object method m : int method n : int end |}];; +class virtual c = object (self : 'c) + constraint 'c = < f : int; .. > +end +[%%expect {| +class virtual c : object method virtual f : int end +|}];; + +class virtual c = object (self : 'c) + constraint 'c = < f : int; .. > + method g = self # f +end +[%%expect {| +class virtual c : object method virtual f : int method g : int end +|}];; + class [ 'a ] c = object (_ : 'a) end;; let o = object method m = 1 @@ -1329,3 +1344,77 @@ let _ = (new foo)#f true class foo : object method f : bool -> bool end - : bool = true |}];; + + +class c : object + method virtual m : int +end = object + method m = 9 + end +[%%expect {| +Lines 1-3, characters 10-3: +1 | ..........object +2 | method virtual m : int +3 | end......... +Error: This non-virtual class type has virtual methods. + The following methods are virtual : m +|}];; + +class virtual c : object + method virtual m : int +end = object + method m = 42 + end +[%%expect {| +class virtual c : object method virtual m : int end +|}];; + +class virtual cv = object + method virtual m : int + end + +class c : cv = object + method m = 42 + end +[%%expect {| +class virtual cv : object method virtual m : int end +Line 5, characters 10-12: +5 | class c : cv = object + ^^ +Error: This non-virtual class type has virtual methods. + The following methods are virtual : m +|}];; + +class virtual c : cv = object + method m = 41 + end +[%%expect {| +class virtual c : cv +|}];; + +class c = cv +[%%expect {| +Line 1, characters 10-12: +1 | class c = cv + ^^ +Error: This non-virtual class has virtual methods. + The following methods are virtual : m +|}];; + +class virtual c = cv +[%%expect {| +class virtual c : cv +|}];; + +(** Test classes abbreviations with a recursive type *) +class ['a] c = object method m: ( as 'b) -> unit = fun _ -> () end +class d = ['a] c +[%%expect {| +class ['a] c : object method m : (< f : 'b; x : 'a > as 'b) -> unit end +Line 2, characters 0-16: +2 | class d = ['a] c + ^^^^^^^^^^^^^^^^ +Error: Some type variables are unbound in this type: class d : ['a] c + The method m has type (< f : 'b; x : 'a > as 'b) -> unit where 'a + is unbound +|}] diff --git a/testsuite/tests/typing-objects/unbound-type-var.ml b/testsuite/tests/typing-objects/unbound-type-var.ml new file mode 100644 index 00000000..9e00cea2 --- /dev/null +++ b/testsuite/tests/typing-objects/unbound-type-var.ml @@ -0,0 +1,19 @@ +(* TEST + * expect +*) + +class test a c = +object + method b = c +end + +[%%expect{| +Lines 1-4, characters 0-3: +1 | class test a c = +2 | object +3 | method b = c +4 | end +Error: Some type variables are unbound in this type: + class test : 'a -> 'b -> object method b : 'b end + The method b has type 'b where 'b is unbound +|}] diff --git a/testsuite/tests/warnings/deprecated_mutable.compilers.reference b/testsuite/tests/warnings/deprecated_mutable.compilers.reference new file mode 100644 index 00000000..620dc57d --- /dev/null +++ b/testsuite/tests/warnings/deprecated_mutable.compilers.reference @@ -0,0 +1,4 @@ +File "deprecated_mutable.ml", line 13, characters 11-12: +13 | let () = y.x <- 42 + ^ +Alert deprecated: mutating field x diff --git a/testsuite/tests/warnings/deprecated_mutable.ml b/testsuite/tests/warnings/deprecated_mutable.ml new file mode 100644 index 00000000..78fb12ac --- /dev/null +++ b/testsuite/tests/warnings/deprecated_mutable.ml @@ -0,0 +1,13 @@ +(* TEST + +flags = "-w +A-70" + +* bytecode + +*) + +type t = {mutable x : int [@deprecated_mutable]} + +let y : t = {x = 5} + +let () = y.x <- 42 diff --git a/tools/ci/inria/main b/tools/ci/inria/main index 63046592..d4c2ea27 100755 --- a/tools/ci/inria/main +++ b/tools/ci/inria/main @@ -144,6 +144,7 @@ cleanup=false check_make_alldepend=false jobs='' bootstrap=false +init_submodule=false case "${OCAML_ARCH}" in bsd|solaris) @@ -213,6 +214,12 @@ fi pwd cd "$jenkinsdir" +if $init_submodule; then + git submodule update --init flexdll +elif [ -f flexdll/Makefile ]; then + git submodule deinit --force flexdll +fi + ######################################################################### # parse optional command-line arguments (has to be done after the "cd") diff --git a/tools/ocamlmklib.ml b/tools/ocamlmklib.ml index 0ca7b80f..1cf8ef91 100644 --- a/tools/ocamlmklib.ml +++ b/tools/ocamlmklib.ml @@ -25,10 +25,8 @@ let mklib out files opts = then "-machine:AMD64 " else "" in - Printf.sprintf "link -lib -nologo %s-out:%s %s %s" - machine out opts files - else Printf.sprintf "%s rcs %s %s %s && %s %s" - Config.ar out opts files Config.ranlib out + Printf.sprintf "link -lib -nologo %s-out:%s %s %s" machine out opts files + else Printf.sprintf "%s rcs %s %s %s" Config.ar out opts files (* PR#4783: under Windows, don't use absolute paths because we do not know where the binary distribution will be installed. *) diff --git a/tools/sync_stdlib_docs b/tools/sync_stdlib_docs index edf50a2a..083c6f0f 100755 --- a/tools/sync_stdlib_docs +++ b/tools/sync_stdlib_docs @@ -32,7 +32,7 @@ LABLABREGEX="s/\([a-z_]+:([a-z\('])/\(\1/g" #Remove a tilde if it is followed by a label name and a space or closing #OCamldoc code section with ] -TILDEREGEX="s/~([a-z_]+[ \]])/\1/g" +TILDEREGEX="s/ ~([a-z_]+(?=[ \]]))/ \1/g" #Indent a non-blank line by two characters, for moreLabels templates INDENTREGEX="s/^(.+)$/ \1/m" diff --git a/toplevel/topdirs.ml b/toplevel/topdirs.ml index 97c1f1ae..bc57e324 100644 --- a/toplevel/topdirs.ml +++ b/toplevel/topdirs.ml @@ -535,6 +535,9 @@ let is_rec_module id md = Btype.unmark_iterators.it_module_declaration Btype.unmark_iterators md; rs +let secretly_the_same_path env path1 path2 = + let norm path = Printtyp.rewrite_double_underscore_paths env path in + Path.same (norm path1) (norm path2) let () = reg_show_prim "show_module" @@ -544,27 +547,46 @@ let () = | Pident id -> id | _ -> id in - let rec accum_aliases md acc = - let acc rs = + let rec accum_aliases path md acc = + let def rs = Sig_module (id, Mp_present, {md with md_type = trim_signature md.md_type}, - rs, Exported) :: acc in + rs, Exported) in match md.md_type with - | Mty_alias path -> - let md = Env.find_module path env in - accum_aliases md (acc Trec_not) + | Mty_alias new_path -> + let md = Env.find_module new_path env in + accum_aliases new_path md + (if secretly_the_same_path env path new_path + then acc + else def Trec_not :: acc) | Mty_ident _ | Mty_signature _ | Mty_functor _ -> - List.rev (acc (is_rec_module id md)) + List.rev (def (is_rec_module id md) :: acc) in - accum_aliases md [] + accum_aliases path md [] ) "Print the signature of the corresponding module." let () = reg_show_prim "show_module_type" (fun env loc id lid -> - let _path, desc = Env.lookup_modtype ~loc lid env in - [ Sig_modtype (id, desc, Exported) ] + let path, mtd = Env.lookup_modtype ~loc lid env in + let id = match path with + | Pident id -> id + | _ -> id + in + let rec accum_defs path mtd acc = + let def = Sig_modtype (id, mtd, Exported) in + match mtd.mtd_type with + | Some (Mty_ident new_path) -> + let mtd = Env.find_modtype new_path env in + accum_defs new_path mtd + (if secretly_the_same_path env path new_path + then acc + else def :: acc) + | None | Some (Mty_alias _ | Mty_signature _ | Mty_functor _) -> + List.rev (def :: acc) + in + accum_defs path mtd [] ) "Print the signature of the corresponding module type." diff --git a/typing/env.ml b/typing/env.ml index 06b99f41..6e324888 100644 --- a/typing/env.ml +++ b/typing/env.ml @@ -104,6 +104,10 @@ let add_label_usage lu usage = lu.lu_mutation <- true; lu.lu_construct <- true +let is_mutating_label_usage = function + | Mutation -> true + | (Projection | Construct | Exported_private | Exported) -> false + let label_usages () = {lu_projection = false; lu_mutation = false; lu_construct = false} @@ -2219,6 +2223,14 @@ and add_cltype ?shape id ty env = let add_module ?arg ?shape id presence mty env = add_module_declaration ~check:false ?arg ?shape id presence (md mty) env +let add_module_lazy ~update_summary id presence mty env = + let md = Subst.Lazy.{mdl_type = mty; + mdl_attributes = []; + mdl_loc = Location.none; + mdl_uid = Uid.internal_not_actually_unique} + in + add_module_declaration_lazy ~update_summary id presence md env + let add_local_type path info env = { env with local_constraints = Path.Map.add path info env.local_constraints } @@ -2723,7 +2735,10 @@ let use_cltype ~use ~loc path desc = let use_label ~use ~loc usage env lbl = if use then begin mark_label_description_used usage env lbl; - Builtin_attributes.check_alerts loc lbl.lbl_attributes lbl.lbl_name + Builtin_attributes.check_alerts loc lbl.lbl_attributes lbl.lbl_name; + if is_mutating_label_usage usage then + Builtin_attributes.check_deprecated_mutable loc lbl.lbl_attributes + lbl.lbl_name end let use_constructor_desc ~use ~loc usage env cstr = diff --git a/typing/env.mli b/typing/env.mli index 55ab3a5b..49040b83 100644 --- a/typing/env.mli +++ b/typing/env.mli @@ -289,6 +289,8 @@ val add_extension: check:bool -> rebind:bool -> Ident.t -> extension_constructor -> t -> t val add_module: ?arg:bool -> ?shape:Shape.t -> Ident.t -> module_presence -> module_type -> t -> t +val add_module_lazy: update_summary:bool -> + Ident.t -> module_presence -> Subst.Lazy.modtype -> t -> t val add_module_declaration: ?arg:bool -> ?shape:Shape.t -> check:bool -> Ident.t -> module_presence -> module_declaration -> t -> t val add_module_declaration_lazy: update_summary:bool -> diff --git a/typing/includemod_errorprinter.ml b/typing/includemod_errorprinter.ml index 24d452fd..b719e162 100644 --- a/typing/includemod_errorprinter.ml +++ b/typing/includemod_errorprinter.ml @@ -709,7 +709,16 @@ let rec module_type ~expansion_token ~eqmode ~env ~before ~ctx diff = functor_params ~expansion_token ~env ~before ~ctx d | _ -> let inner = if eqmode then eq_module_types else module_types in - let next = dwith_context_and_elision ctx inner diff in + let next = + match diff.symptom with + | Mt_core _ -> + (* In those cases, the refined error messages for the current error + will at most add some minor comments on the current error. + It is thus better to avoid eliding the current error message. + *) + dwith_context ctx (inner diff) + | _ -> dwith_context_and_elision ctx inner diff + in let before = next :: before in module_type_symptom ~eqmode ~expansion_token ~env ~before ~ctx diff.symptom diff --git a/typing/mtype.ml b/typing/mtype.ml index d649bcdc..f6aba792 100644 --- a/typing/mtype.ml +++ b/typing/mtype.ml @@ -46,6 +46,9 @@ let rec strengthen_lazy ~aliasable env mty p = MtyL_signature(strengthen_lazy_sig ~aliasable env sg p) | MtyL_functor(Named (Some param, arg), res) when !Clflags.applicative_functors -> + let env = + Env.add_module_lazy ~update_summary:false param Mp_present arg env + in MtyL_functor(Named (Some param, arg), strengthen_lazy ~aliasable:false env res (Papply(p, Pident param))) | MtyL_functor(Named (None, arg), res) diff --git a/typing/printtyp.ml b/typing/printtyp.ml index 1a696449..8dcf18bf 100644 --- a/typing/printtyp.ml +++ b/typing/printtyp.ml @@ -1058,7 +1058,10 @@ let reset () = reset_except_context () let prepare_for_printing tyl = - reset_except_context (); List.iter prepare_type tyl + reset_except_context (); + List.iter prepare_type tyl + +let add_type_to_preparation = prepare_type (* Disabled in classic mode when printing an unification error *) let print_labels = ref true @@ -1463,10 +1466,13 @@ and tree_of_label l = let constructor ppf c = reset_except_context (); + prepare_type_constructor_arguments c.cd_args; + Option.iter prepare_type c.cd_res; !Oprint.out_constr ppf (tree_of_constructor c) let label ppf l = reset_except_context (); + prepare_type l.ld_type; !Oprint.out_label ppf (tree_of_label l) let tree_of_type_declaration id decl rs = @@ -1534,6 +1540,8 @@ let extension_constructor id ppf ext = let extension_only_constructor id ppf ext = reset_except_context (); + prepare_type_constructor_arguments ext.ext_args; + Option.iter prepare_type ext.ext_ret_type; let name = Ident.name id in let args, ret = extension_constructor_args_and_ret_type_subtree diff --git a/typing/printtyp.mli b/typing/printtyp.mli index 13b2ed95..09571f40 100644 --- a/typing/printtyp.mli +++ b/typing/printtyp.mli @@ -107,6 +107,12 @@ val type_expr: formatter -> type_expr -> unit Any type variables that are shared between multiple types in the input list will be given the same name when printed with [prepared_type_expr]. *) val prepare_for_printing: type_expr list -> unit + +(** [add_type_to_preparation ty] extend a previous type expression preparation + to the type expression [ty] +*) +val add_type_to_preparation: type_expr -> unit + val prepared_type_expr: formatter -> type_expr -> unit (** The function [prepared_type_expr] is a less-safe but more-flexible version of [type_expr] that should only be called on [type_expr]s that have been diff --git a/typing/tast_mapper.ml b/typing/tast_mapper.ml index 6d359a59..9eb7f64e 100644 --- a/typing/tast_mapper.ml +++ b/typing/tast_mapper.ml @@ -458,10 +458,10 @@ let module_type sub x = let with_constraint sub = function | Twith_type decl -> Twith_type (sub.type_declaration sub decl) | Twith_typesubst decl -> Twith_typesubst (sub.type_declaration sub decl) + | Twith_modtype mty -> Twith_modtype (sub.module_type sub mty) + | Twith_modtypesubst mty -> Twith_modtypesubst (sub.module_type sub mty) | Twith_module _ - | Twith_modsubst _ - | Twith_modtype _ - | Twith_modtypesubst _ as d -> d + | Twith_modsubst _ as d -> d let open_description sub od = {od with open_env = sub.env sub od.open_env} diff --git a/typing/typeclass.ml b/typing/typeclass.ml index 048ee998..79d464fa 100644 --- a/typing/typeclass.ml +++ b/typing/typeclass.ml @@ -177,6 +177,13 @@ let check_virtual loc env virt kind sign = | meths, vars -> raise(Error(loc, env, Virtual_class(kind, meths, vars))) +let rec check_virtual_clty loc env virt kind clty = + match clty with + | Cty_constr(_, _, clty) | Cty_arrow(_, _, clty) -> + check_virtual_clty loc env virt kind clty + | Cty_signature sign -> + check_virtual loc env virt kind sign + (* Return the constructor type associated to a class type *) let rec constructor_type constr cty = match cty with @@ -398,6 +405,8 @@ and class_type_aux env virt self_scope scty = ) styl params in let typ = Cty_constr (path, params, clty) in + (* Check for unexpected virtual methods *) + check_virtual_clty scty.pcty_loc env virt Class_type typ; cltyp (Tcty_constr ( path, lid , ctys)) typ | Pcty_signature pcsig -> @@ -552,12 +561,11 @@ type first_pass_accummulater = concrete_vals : VarSet.t; local_meths : MethSet.t; local_vals : VarSet.t; - vars : Ident.t Vars.t; - meths : Ident.t Meths.t; } + vars : Ident.t Vars.t; } let rec class_field_first_pass self_loc cl_num sign self_scope acc cf = let { rev_fields; val_env; par_env; concrete_meths; concrete_vals; - local_meths; local_vals; vars; meths } = acc + local_meths; local_vals; vars } = acc in let loc = cf.pcf_loc in let attributes = cf.pcf_attributes in @@ -612,13 +620,6 @@ let rec class_field_first_pass self_loc cl_num sign self_scope acc cf = (val_env, par_env, inherited_vars, vars)) parent_sign.csig_vars (val_env, par_env, [], vars) in - let meths = - Meths.fold - (fun label _ meths -> - if Meths.mem label meths then meths - else Meths.add label (Ident.create_local label) meths) - parent_sign.csig_meths meths - in (* Methods available through super *) let super_meths = MethSet.fold @@ -641,7 +642,7 @@ let rec class_field_first_pass self_loc cl_num sign self_scope acc cf = in let rev_fields = field :: rev_fields in { acc with rev_fields; val_env; par_env; - concrete_meths; concrete_vals; vars; meths }) + concrete_meths; concrete_vals; vars }) | Pcf_val (label, mut, Cfk_virtual styp) -> with_attrs (fun () -> @@ -723,15 +724,11 @@ let rec class_field_first_pass self_loc cl_num sign self_scope acc cf = let cty = transl_simple_type val_env false sty in let ty = cty.ctyp_type in add_method loc val_env label.txt priv Virtual ty sign; - let meths = - if Meths.mem label.txt meths then meths - else Meths.add label.txt (Ident.create_local label.txt) meths - in let field = Virtual_method { label; priv; cty; loc; attributes } in let rev_fields = field :: rev_fields in - { acc with rev_fields; meths }) + { acc with rev_fields }) | Pcf_method (label, priv, Cfk_concrete (override, expr)) -> with_attrs @@ -785,10 +782,6 @@ let rec class_field_first_pass self_loc cl_num sign self_scope acc cf = raise(Error(loc, val_env, Field_type_mismatch ("method", label.txt, err))) end; - let meths = - if Meths.mem label.txt meths then meths - else Meths.add label.txt (Ident.create_local label.txt) meths - in let sdefinition = make_method self_loc cl_num expr in let warning_state = Warnings.backup () in let field = @@ -799,7 +792,7 @@ let rec class_field_first_pass self_loc cl_num sign self_scope acc cf = let rev_fields = field :: rev_fields in let concrete_meths = MethSet.add label.txt concrete_meths in let local_meths = MethSet.add label.txt local_meths in - { acc with rev_fields; concrete_meths; local_meths; meths }) + { acc with rev_fields; concrete_meths; local_meths }) | Pcf_constraint (sty1, sty2) -> with_attrs @@ -837,11 +830,10 @@ and class_fields_first_pass self_loc cl_num sign self_scope let local_meths = MethSet.empty in let local_vals = VarSet.empty in let vars = Vars.empty in - let meths = Meths.empty in let init_acc = { rev_fields; val_env; par_env; concrete_meths; concrete_vals; - local_meths; local_vals; vars; meths } + local_meths; local_vals; vars } in let acc = Builtin_attributes.warning_scope [] @@ -850,7 +842,7 @@ and class_fields_first_pass self_loc cl_num sign self_scope (class_field_first_pass self_loc cl_num sign self_scope) init_acc cfs) in - List.rev acc.rev_fields, acc.vars, acc.meths + List.rev acc.rev_fields, acc.vars and class_field_second_pass cl_num sign met_env field = let mkcf desc loc attrs = @@ -1003,7 +995,7 @@ and class_structure cl_num virt self_scope final val_env met_env loc end; (* Typing of class fields *) - let (fields, vars, meths) = + let (fields, vars) = class_fields_first_pass self_loc cl_num sign self_scope val_env par_env str in @@ -1016,6 +1008,13 @@ and class_structure cl_num virt self_scope final val_env met_env loc update_class_signature loc val_env ~warn_implicit_public:false virt kind sign; + let meths = + Meths.fold + (fun label _ meths -> + Meths.add label (Ident.create_local label) meths) + sign.csig_meths Meths.empty + in + (* Close the signature if it is final *) begin match final with | Not_final -> () @@ -1087,6 +1086,8 @@ and class_expr_aux cl_num val_env met_env virt self_scope scl = try Ctype.unify val_env ty' ty with Ctype.Unify err -> raise(Error(cty'.ctyp_loc, val_env, Parameter_mismatch err))) tyl params; + (* Check for unexpected virtual methods *) + check_virtual_clty scl.pcl_loc val_env virt Class clty'; let cl = rc {cl_desc = Tcl_ident (path, lid, tyl); cl_loc = scl.pcl_loc; @@ -1972,7 +1973,6 @@ let report_error env ppf = function (function ppf -> fprintf ppf "but is expected to have type") | Unexpected_field (ty, lab) -> - Printtyp.prepare_for_printing [ty]; fprintf ppf "@[@[<2>This object is expected to have type :@ %a@]\ @ This type does not have a method %s." @@ -2061,7 +2061,8 @@ let report_error env ppf = function let print_reason ppf (ty0, real, lab, ty) = let ty1 = if real then ty0 else Btype.newgenty(Tobject(ty0, ref None)) in - Printtyp.prepare_for_printing [ty; ty1]; + Printtyp.add_type_to_preparation ty; + Printtyp.add_type_to_preparation ty1; fprintf ppf "The method %s@ has type@;<1 2>%a@ where@ %a@ is unbound" lab diff --git a/typing/typedecl.ml b/typing/typedecl.ml index 9d38ebe9..d00c0fc4 100644 --- a/typing/typedecl.ml +++ b/typing/typedecl.ml @@ -1334,7 +1334,7 @@ let rec parse_native_repr_attributes env core_type ty ~global_repr = parse_native_repr_attributes env ct2 t2 ~global_repr in (repr_arg :: repr_args, repr_res) - | Ptyp_poly (_, t), _, _ -> + | (Ptyp_poly (_, t) | Ptyp_alias (t, _)), _, _ -> parse_native_repr_attributes env t ty ~global_repr | Ptyp_arrow _, _, _ | _, Tarrow _, _ -> assert false | _ -> ([], make_native_repr env core_type ty ~global_repr) diff --git a/typing/typemod.ml b/typing/typemod.ml index 5774460e..b575de29 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -2048,8 +2048,13 @@ and package_constraints env loc mty constrs = end let modtype_of_package env loc p fl = - package_constraints env loc (Mty_ident p) - (List.map (fun (n, t) -> (Longident.flatten n, t)) fl) + (* We call Ctype.correct_levels to ensure that the types being added to the + module type are at generic_level. *) + let mty = + package_constraints env loc (Mty_ident p) + (List.map (fun (n, t) -> Longident.flatten n, Ctype.correct_levels t) fl) + in + Subst.modtype Keep Subst.identity mty let package_subtype env p1 fl1 p2 fl2 = let mkmty p fl = @@ -2069,9 +2074,11 @@ let () = Ctype.package_subtype := package_subtype let wrap_constraint env mark arg mty explicit = let mark = if mark then Includemod.Mark_both else Includemod.Mark_neither in + let mty1 = Subst.modtype Keep Subst.identity arg.mod_type in + let mty2 = Subst.modtype Keep Subst.identity mty in let coercion = try - Includemod.modtypes ~loc:arg.mod_loc env ~mark arg.mod_type mty + Includemod.modtypes ~loc:arg.mod_loc env ~mark mty1 mty2 with Includemod.Error msg -> raise(Error(arg.mod_loc, env, Not_included msg)) in { mod_desc = Tmod_constraint(arg, mty, explicit, coercion); diff --git a/utils/Makefile b/utils/Makefile index 7231fae2..de923900 100644 --- a/utils/Makefile +++ b/utils/Makefile @@ -73,7 +73,6 @@ config.ml: config.mlp $(ROOTDIR)/Makefile.config Makefile $(call SUBST_STRING,OCAMLOPT_CPPFLAGS) \ $(call SUBST_STRING,PACKLD) \ $(call SUBST,PROFINFO_WIDTH) \ - $(call SUBST_STRING,RANLIBCMD) \ $(call SUBST_STRING,RPATH) \ $(call SUBST_STRING,MKSHAREDLIBRPATH) \ $(call SUBST,FORCE_SAFE_STRING) \ diff --git a/utils/ccomp.ml b/utils/ccomp.ml index 955968d1..d23c3f2b 100644 --- a/utils/ccomp.ml +++ b/utils/ccomp.ml @@ -140,12 +140,8 @@ let create_archive archive file_list = quoted_archive (quote_files file_list)) | _ -> assert(String.length Config.ar > 0); - let r1 = - command(Printf.sprintf "%s rc %s %s" - Config.ar quoted_archive (quote_files file_list)) in - if r1 <> 0 || String.length Config.ranlib = 0 - then r1 - else command(Config.ranlib ^ " " ^ quoted_archive) + command(Printf.sprintf "%s rc %s %s" + Config.ar quoted_archive (quote_files file_list)) let expand_libname cclibs = cclibs |> List.map (fun cclib -> diff --git a/utils/clflags.ml b/utils/clflags.ml index 46b61f41..83bd357f 100644 --- a/utils/clflags.ml +++ b/utils/clflags.ml @@ -135,7 +135,6 @@ let profile_columns : Profile.column list ref = ref [] (* -dprofile/-dtimings *) let native_code = ref false (* set to true under ocamlopt *) -let force_tmc = ref false (* -force-tmc *) let force_slash = ref false (* for ocamldep *) let clambda_checks = ref false (* -clambda-checks *) let cmm_invariants = diff --git a/utils/clflags.mli b/utils/clflags.mli index 5d9cb863..8cab8f15 100644 --- a/utils/clflags.mli +++ b/utils/clflags.mli @@ -189,7 +189,6 @@ val dlcode : bool ref val pic_code : bool ref val runtime_variant : string ref val with_runtime : bool ref -val force_tmc : bool ref val force_slash : bool ref val keep_docs : bool ref val keep_locs : bool ref diff --git a/utils/config.mli b/utils/config.mli index 7f70a52d..94dee3cb 100644 --- a/utils/config.mli +++ b/utils/config.mli @@ -82,9 +82,6 @@ val mkexe: string val mkmaindll: string (** The linker command line to build main programs as dlls. *) -val ranlib: string -(** Command to randomize a library, or "" if not needed *) - val default_rpath: string (** Option to add a directory to be searched for libraries at runtime (used by ocamlmklib) *) diff --git a/utils/config.mlp b/utils/config.mlp index 44c6ff8f..f758a9b4 100644 --- a/utils/config.mlp +++ b/utils/config.mlp @@ -54,7 +54,6 @@ let native_c_compiler = c_compiler ^ " " ^ ocamlopt_cflags ^ " " ^ ocamlopt_cppflags let native_c_libraries = "%%NATIVECCLIBS%%" let native_pack_linker = "%%PACKLD%%" -let ranlib = "%%RANLIBCMD%%" let default_rpath = "%%RPATH%%" let mksharedlibrpath = "%%MKSHAREDLIBRPATH%%" let ar = "%%ARCMD%%" @@ -177,7 +176,6 @@ let configuration_variables = p "bytecomp_c_libraries" bytecomp_c_libraries; p "native_c_libraries" native_c_libraries; p "native_pack_linker" native_pack_linker; - p "ranlib" ranlib; p "architecture" architecture; p "model" model; p_int "int_size" Sys.int_size;