From a714f91eab829f77f7537bf916fde76e496d816c Mon Sep 17 00:00:00 2001 From: Stephane Glondu Date: Sat, 24 Jul 2010 14:19:46 +0200 Subject: [PATCH] Imported Upstream version 3.12.0~rc1 --- Changes | 3 +- INSTALL | 3 + Makefile.nt | 14 +- README.win32 | 9 +- VERSION | 4 +- boot/ocamlc | Bin 1094920 -> 1095739 bytes boot/ocamldep | Bin 306735 -> 306742 bytes boot/ocamllex | Bin 169507 -> 169518 bytes byterun/unix.c | 7 +- config/Makefile.msvc | 4 +- config/Makefile.msvc64 | 4 +- configure | 13 +- driver/main_args.ml | 3 +- ocamlbuild/discard_printf.ml | 3 +- ocamldoc/Makefile | 4 +- ocamldoc/odoc_text_lexer.mll | 6 +- testsuite/Makefile | 6 +- .../typing-objects/Exemples.ml.reference | 63 +-- .../tests/typing-objects/Tests.ml.reference | 202 ++++------ .../typing-poly/poly.ml.principal.reference | 369 +++++++++--------- testsuite/tests/typing-poly/poly.ml.reference | 356 +++++++++-------- .../tests/typing-private/private.ml.reference | 55 +-- typing/ctype.ml | 44 ++- typing/typecore.ml | 26 +- 24 files changed, 621 insertions(+), 577 deletions(-) diff --git a/Changes b/Changes index cf46fd1f..5f4a4ac2 100644 --- a/Changes +++ b/Changes @@ -127,6 +127,7 @@ Bug Fixes: - PR#5057: fatal typing error with local module + functor + polymorphic variant - Wrong type for Obj.add_offset. - Small problem with the representation of Int32, Int64, and Nativeint constants. +- Use RTLD_LOCAL for native dynlink in private mode. Objective Caml 3.11.2: ---------------------- @@ -2623,4 +2624,4 @@ Caml Special Light 1.06: * First public release. -$Id: Changes 10566 2010-06-16 01:32:26Z garrigue $ +$Id: Changes 10613 2010-07-02 08:44:04Z frisch $ diff --git a/INSTALL b/INSTALL index cc88e26b..dbc9ac73 100644 --- a/INSTALL +++ b/INSTALL @@ -227,6 +227,9 @@ ocamlbuild instead of make (it replaces steps 2 to 5): ./build/fastworld.sh +If it doesn't work, just use one of the make-based procedures described +above. + 6- You can now install the Objective Caml system. This will create the following commands (in the binary directory selected during autoconfiguration): diff --git a/Makefile.nt b/Makefile.nt index d9a95eef..1f26c270 100644 --- a/Makefile.nt +++ b/Makefile.nt @@ -10,7 +10,7 @@ # # ######################################################################### -# $Id: Makefile.nt 10472 2010-05-28 11:21:46Z garrigue $ +# $Id: Makefile.nt 10616 2010-07-06 10:02:53Z doligez $ # The main Makefile @@ -606,23 +606,23 @@ alldepend:: # Camlp4 camlp4out: ocamlc otherlibraries ocamlbuild-mixed-boot ocamlbuild.byte - OCAMLBUILD_FIND=/usr/bin/find ./build/camlp4-byte-only.sh + ./build/camlp4-byte-only.sh camlp4opt: ocamlopt otherlibrariesopt ocamlbuild-mixed-boot ocamlbuild.native - OCAMLBUILD_FIND=/usr/bin/find ./build/camlp4-native-only.sh + ./build/camlp4-native-only.sh # Ocamlbuild ocamlbuild.byte: ocamlc otherlibraries ocamlbuild-mixed-boot - OCAMLBUILD_FIND=/usr/bin/find ./build/ocamlbuild-byte-only.sh + ./build/ocamlbuild-byte-only.sh ocamlbuild.native: ocamlopt otherlibrariesopt ocamlbuild-mixed-boot - OCAMLBUILD_FIND=/usr/bin/find ./build/ocamlbuild-native-only.sh + ./build/ocamlbuild-native-only.sh ocamlbuildlib.native: ocamlopt otherlibrariesopt ocamlbuild-mixed-boot - OCAMLBUILD_FIND=/usr/bin/find ./build/ocamlbuildlib-native-only.sh + ./build/ocamlbuildlib-native-only.sh .PHONY: ocamlbuild-mixed-boot ocamlbuild-mixed-boot: - OCAMLBUILD_FIND=/usr/bin/find ./build/mixed-boot.sh + ./build/mixed-boot.sh partialclean:: rm -rf _build diff --git a/README.win32 b/README.win32 index a103630f..ac1edc50 100644 --- a/README.win32 +++ b/README.win32 @@ -110,19 +110,20 @@ in their default directories. If this is not the case, you will need to adjust the paths accordingly. Open a Windows Command Prompt and enter the following commands: - cd "C:\Program Files\Visual Studio 9.0\VC\bin" + cd "C:\Program Files\Microsoft Visual Studio 9.0\VC\bin" vcvars32 echo VCPATH="`cygpath -p '%Path%'`" >C:\cygwin\tmp\msenv echo LIB="%LIB%;C:\Tcl\lib" >>C:\cygwin\tmp\msenv echo LIBPATH="%LIBPATH%" >>C:\cygwin\tmp\msenv echo INCLUDE="%INCLUDE%;C:\Tcl\include" >>C:\cygwin\tmp\msenv echo FLPATH="`cygpath 'C:\Program Files\flexdll'`" >>C:\cygwin\tmp\msenv + echo PATH="${VCPATH}:$PATH:${FLPATH}" >>C:\cygwin\tmp\msenv + echo export PATH LIB LIBPATH INCLUDE >>C:\cygwin\tmp\msenv + echo export OCAMLBUILD_FIND=/usr/bin/find >>C:\cygwin\tmp\msenv Open a Cygwin shell and enter the following commands: tr -d '\r' .msenv echo '. $HOME/.msenv' >>.bashrc - echo 'PATH="${VCPATH}:$PATH:${FLPATH}"' >>.bashrc - echo 'export PATH LIB LIBPATH INCLUDE' >>.bashrc Now, close the Command Prompt and the shell and you're set up for using the MS tools under Cygwin. @@ -230,7 +231,7 @@ companion MSYS tools: these have problems with long command lines. Instead, use the version of MinGW provided by Cygwin. Start a Cygwin shell and unpack the source distribution -(ocaml-X.YZ.tar.gz) with "tar xzf". Change to the top-level +(ocaml-X.YY.Z.tar.gz) with "tar xzf". Change to the top-level directory of the OCaml distribution. Then, do cp config/m-nt.h config/m.h diff --git a/VERSION b/VERSION index 7c40b26f..ac5d6051 100644 --- a/VERSION +++ b/VERSION @@ -1,6 +1,6 @@ -3.12.0+beta1 +3.12.0+rc1 # The version string is the first line of this file. # It must be in the format described in stdlib/sys.mli -# $Id: VERSION 10582 2010-06-16 11:24:09Z doligez $ +# $Id: VERSION 10630 2010-07-23 15:31:56Z doligez $ diff --git a/boot/ocamlc b/boot/ocamlc index 9eaea6c889e347fd7af4685ceedfe337197380b0..d1ead70cdf886179e3e2ca17a249a7a5374e1dfc 100755 GIT binary patch delta 6366 zcmZu#3wTu3wVpFM=ggVO%wz(SOfr*95;B3rNFacLP$N%Y(1LJz2pA9v2oxdZ(JBy9 zTBujOyh`i(VhvCQL8~xWbV_;K8x#?%_jz26&MyZ%B2bXG*N{ZN4 z0uz7+cF8~wNekh&++92nYq?_Ah)&OmEZ5>=J02s?DpdBcO z-_bx{XA%p+KMb@3Y%2lARSZ3w9d`lxj5!0KJ|bPJwM9;~W5Q@RNT}@s30c~;`*?4Z$C8sL?ReGIKmGc;zb%MI?Ty?3g4ZWt()bk}Va5?ucA4 z^g8iACs3ON&EpYgV!?+3lwZg0C8?NHc;Ps1>Ek3A|k z`SkMOPa$?&{y-cH(3cI@D>>5a(_@ncqnkQiG5VY;Rd%Yavy11@XNuPX43T*9Dbob` zHtfGi*sn(hC%#F#vm>DCbW6r+*}=OlS$c}>^gj{l*>8NoF|6Yb^ytN&6s%*LH7NtO zQ>X39@33WnoQ-XPyzSSE%l25qxeQcsX!tvZ7D@LEy*z8=?~*B|n!hizGW463X4#pc zhbAPxHqF$m9z~xSr51~m)I6Q^!~?<9KMH{MP&PUvw_+R`l)d!~`EiKlS9*qn{exDD>@(PWuY$?R2aTJL zg-i!fYzcJL$2qc8k&--QEk>ZU?{zWxRq&r&>DZcImU^ zZlZiL04i@}>zP?|;GAcVLOSA79G0)M_5Qj19;E$pz>bGsC?X?5dU@IHaLEl!6K>S2 zO_^33ywBL!nh|o=e75oU$Ki@q5ONy&`NyZpcxQm;;GY5ZJdF9RXT=QZRb{^bZ|C^D zHKr6Yj=9^?(SEZ`&Cz=)^|Cex8#q&*2g&>|%Yc{0k&jGswnU#%B8o#ixq2k40TQ}d zWLYu$VKOjR@1bQv<&hP)sgaFqwi@z-UFn8295e#*+gyEi?c*@yz-<6y=5v(;oO#wX z@7iOUM}f#6OmhX0vDY;31m5|hX*TXpmYXH#c)Ng2;F%+fwnk=!^>SacC1T{)%BHa1 zBRBiQD;tcXIf9w1(h7CvW?BNwf(0HX*%64hfK3%Q%czK6Uinyxm~(t{u=53W^nB+7 zdcQmcZ~0qcYOml>m@sqp+1`*(B6?%dvtT(PW8k}|9x}~Wj^O%w!89KPg0ePG4=Ex~ zDaiTWVp$?*bo!|!3zT>#zjz{NjE zjw=LD9Un~USUa(F>n$05{sc1kl;!#Qq+9nvU}wYS`W1ru;3d<$x*9Pr4 zfmk#FY6o#zqETf1qEtook+}z8I)*UdS(mWCG%F06h&dUFRmR2VLd!lUcofRUZAuS&Ec%*7ZI7INp5-Io(%op$ zdu7yOU#M{}y0&ZX@`kssq;6m2+>&3MG0l0Py#P+R6c`2+0hIGhQN9eY<*7%Y0dgkE z%j6_{rGsMUMmq-GgANBbTJ(TLUzCHzIC6ETtbGWvy%d|_gF{AIru!|*wW0iFfVM2b zWY{tmo)o?clrxTXt(`x2hM`Y8+SoNg?z-dXI|x8Vx%{F0|2v(G-Oks(YUuAbGB>6d z69c_OCYEH|##1JV}L3zeKiv_$`Zr7<6tG$^oWkws$`?QYQ$ ziu4bk%mhyBa>fpY&;Z6llh4&th#nwo!pNRS=)qi)s}g^)r^^G{E zfc$d5vE8}$Mfu(Vqe5wrxd)7&E78O!2aG97V;Tmrwc!=I=7edE0eD5S2Am!n*>MQ} z5^?v(0Qxee3-!K7i?#<4L)eoSAVy16^v| zrJp2ic}QqGC`sj&!-j8&-xA(r(V#_n5zv?wC$;~<9b)x|+f?2>V)Ss^&qW{Ebb`OJ zU9TBgl<^7*0c_m2L+>B>f&sVz50DOc69ZrHz4arf;!bq!=U=EQH%N4_KP1fq{D!O^ z;Lni*cdU zVwq;ih(c$9%v^^}U%SW`aNlPsmdhhk{l!w9rw4P^Sh97XTr?JGFaB$mG1Jrm(sClL zQ1Zi0+#|bi&`wVGZ&mI{thmenX{m23UY0-On-Y7!{`JJthy0$jaCP5`%03mn%j;(T zxKIDW(muT_d-v>J)w8myEU{s&f42v}Y&SIdbMT|QOl$JzV+&f{`vt~`3H)qk}xSFP@u3NSY-ZFH{kil`)rRZ89nM3&iV25#WUk-k)m89rS3q%wLzH16h)sJ zS4$MdGcm5>iTo119*X0eNpZDQaqOQGSMg5%Vq#*EJMdK4cw#ieQ=gQQSm0XaVHq0> zl;Klrc`Q(1n20$~(W~Y0SYWa;P}*aG(*eV{qx(HG7tdZ$7gxtB#-PN9C4p0Goy!X4 Qr9FWH@dcmF@;yE&L=?>RsI@5lGQ-*@jF z_Ma+V|5b5QsOv-CvrexoIZ>#ot;ttmY?%Ep+<=*>XE>5OM+&UJd5 zxRzQN!<+(DpYqm#7W5%+SwG5b4yknN#m-)~7SCwdhwfnckwm zo|Mj+{EP%fF9!Ndr6G^a-!ppYk^;Y`&8sW&r64Mx&j9A7v#%czx zI0o#XT=lt_0G-^Y+lRsjx~mwej4Z~Dj4=#c@d~C~#Ilu+3F)WVTXcuespM|mACB9m z@2${vHVSGVFVkq0KgLD9W97mGbl_)bj3h=5xf&d9TK1UT6>g4|PY6*Mp6HOX1@(Tx z=@ABXIHkKE)|^v16u_aG>m+ela$6a`nW%$7#^E3TlQhLbn z+rzS12lC@o9WV0||HA4R6~@G}oMrlJq43bl@v`r%Ni0TJ%V!ytqIIADw|j~gSaz{b zJ_D72(>n}sFOgVm?C6#-#8$Q; zr`ZCtmXoRl_^Ltl>zer8mvBbED2{9SLoVshJ+HzYtbqk({FjKlnMzzTFX_Q2BMXjp zKS>*0azagKl*zoqJvdwY&xR4b=*L;cf}>}Ns_UMLq>jGZmC6^3!$8aq<w1P# z=@YSOv^`0>M#7G%-NZ1bjyKAp)(ewepnMiF#j0^Cw$Q00=}*|mDdUtHi(Nr|lVu?3 zW@eFfi83MM12jKb`Wx}8hH0@fA=%s?B3YovZ39ILv)CZE;|N0UXG~(?GX2cPu_X?2 zHrdpGOW)SkQMuPJ4l!o! zGmIUKe)|pM)qg}Lim4(VM-y}t0}H`i9-<9tGS9hLsnFg~I*=v;b!-;o{Y2p->>7QA_hgU0odr6XI}guW1h_tT%aQu0fN@n^={jCltP1A7`v z@-ob2wb0={d}be4rl*t%%}(M9~MhZ45BNE(6n=@ot=5x%N%ftQrC)YL(8AijahH;AFrF5@M z%l^BHMA|PpBTrqFyIkqfb_dPz$|(uYGi$B}JLN~(>y>3mP$S|10}bLiei!BYF@u5n9*(NeJyk!{QzGE0U@A7ebpDy>y{z)CIN3pjUNQc3WrdmHA`*vz#(zxk( zq}5`!z;m~vm^&hHIOi%K*vyu(7dqdM9PBdY5xYlGv+CO{BL_Mhsd8i}pYaje*!4Rz zy0DqV++iq$-M{983$w;=Q*$~me_|NbEEh142M_0Qj7$dfIDF8rWSDxqF&tg`;TFps z%$O_P#>wJXHXl)VOCk79MPE?#5ViM}-r}1-jP!(DWP4-Do3md)3ni{8$b6B4kO&~l2R zwZXB&+;noVW*6>oNk7>s$XM?5RQfp{e%XrlRWwJ@%M=};=paRhC^}5h5sF^H^h(Y* zn}G{YmQUA(a%4D^W82?qy>A3fT^Ex<#&*pf4t`)e;BI`MU9ca3OhtzwVq2AMA=4a-h2HtWR!+^W4hO9+uz6DOKH^1m?UF%E z(GvbikU;IPN;fsWt|f}WwDq(tPpqVl)3zxr`Oet9qMAh5MD;@OkWfIvhisBJ& z`rsk)9s8Ivi(?*};IP7gh8pt=O5}muhmUPe5{?8d99_iWk+n^MznL!k-yO`4foUe#?GBeUTv^mEFpQu6MF6y6fEUBHfu!4jcuJ2|n_= zGXd``#A645CI*{^xl=|dX{@4nIKeuO-aB9qB=lF}Kt&VjRH5!pf*QHe3oab9qIHD_ z?Ti>kEF+HL2p1l7zI%)HCwn+)c>Ge0wvUSUQ1hsGJG}y~4O}O5&6z{j_-puy>(MLw%9X1OxlPU{<-<6>~@M>Ady zH!b7`qxFU}^y1JSS>e|!;}7RJALiqF#A4ZX-eRde65e`md~6SA{^0%t2lXG2hyR2Q z3?I5LzBP76py1ZJr3KYXD$1)1_|M|%f@r6L>Z%11bT%%8HPd zAe@VfLs~E4oLijf5Aic9_WhE~%RB?CYU=9CYbq*z4dqL#$`@2uhBUW`t)+N}D<}Io z&fG_6YnO+#453wy?^k>4g6gV@K<(11hVpuL%@iV=W;l)tfXi#| z%8kpny$YnbCBwK8LX;bT3n=`lb@WJqYorjQHV^IJA4fHZC delta 112 zcmdmXM`-;Wp$SqfNvS1?jWVq=jIAH` z)-yEHGtdU9Hr$@#%$&fZ=fa&*rm}MEY5CZMuzRcUjeOdk`Fjh<#TgRdR E02OZ_aR2}S diff --git a/boot/ocamllex b/boot/ocamllex index 6f62654d27781a7d91e065c3fe80e62b66636d29..c70830f27dd010e88cc4e30fef1f2c7700032dd4 100755 GIT binary patch delta 108 zcmZ3yhHKp#t_f01MahkFt#XW8<(R^Qd9N`rFg|5q5Uyrm;F-3)DVT|iS<2E_&(KKE zKszP1%*b3p!^ptUK-a)b*U(IJ`^+$=Onb#w!I8dB3=GV|&Oy$>K)RNJfq~sQF*nE1 L($X@*z`z0kEJqsO delta 70 zcmZ3thHLQ}t_e~sNvS1?jWVq=j9X=x!h?BFGB7YcWnd7lU|`^xvb`agiHn(6$5_wM ZNY6kUq||Wxk}#%Bd&axd`KB=`008796fFP% diff --git a/byterun/unix.c b/byterun/unix.c index 1fe70ab8..20fd172c 100644 --- a/byterun/unix.c +++ b/byterun/unix.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: unix.c 9153 2008-12-03 18:09:09Z doligez $ */ +/* $Id: unix.c 10613 2010-07-02 08:44:04Z frisch $ */ /* Unix-specific stuff */ @@ -204,13 +204,16 @@ char * caml_dlerror(void) #ifndef RTLD_GLOBAL #define RTLD_GLOBAL 0 #endif +#ifndef RTLD_LOCAL +#define RTLD_LOCAL 0 +#endif #ifndef RTLD_NODELETE #define RTLD_NODELETE 0 #endif void * caml_dlopen(char * libname, int for_execution, int global) { - return dlopen(libname, RTLD_NOW | (global ? RTLD_GLOBAL : 0) | RTLD_NODELETE); + return dlopen(libname, RTLD_NOW | (global ? RTLD_GLOBAL : RTLD_LOCAL) | RTLD_NODELETE); /* Could use RTLD_LAZY if for_execution == 0, but needs testing */ } diff --git a/config/Makefile.msvc b/config/Makefile.msvc index 05c4dc48..c93eb9a3 100644 --- a/config/Makefile.msvc +++ b/config/Makefile.msvc @@ -11,7 +11,7 @@ # # ######################################################################### -# $Id: Makefile.msvc 10461 2010-05-25 10:00:39Z frisch $ +# $Id: Makefile.msvc 10622 2010-07-07 12:04:32Z frisch $ # Configuration for Windows, Visual C++ compiler @@ -98,7 +98,7 @@ FLEXLINK=flexlink -merge-manifest FLEXDIR=$(shell $(FLEXLINK) -where) IFLEXDIR=-I"$(FLEXDIR)" MKDLL=$(FLEXLINK) -MKEXE=$(FLEXLINK) -exe +MKEXE=$(FLEXLINK) -exe -link /STACK:16777216 MKMAINDLL=$(FLEXLINK) -maindll ### How to build a static library diff --git a/config/Makefile.msvc64 b/config/Makefile.msvc64 index 8918ec4b..80d72b4f 100644 --- a/config/Makefile.msvc64 +++ b/config/Makefile.msvc64 @@ -11,7 +11,7 @@ # # ######################################################################### -# $Id: Makefile.msvc64 10461 2010-05-25 10:00:39Z frisch $ +# $Id: Makefile.msvc64 10622 2010-07-07 12:04:32Z frisch $ # Configuration for Windows, Visual C++ compiler @@ -103,7 +103,7 @@ FLEXLINK=flexlink -x64 -merge-manifest FLEXDIR=$(shell $(FLEXLINK) -where) IFLEXDIR=-I"$(FLEXDIR)" MKDLL=$(FLEXLINK) -MKEXE=$(FLEXLINK) -exe +MKEXE=$(FLEXLINK) -exe -link /STACK:33554432 MKMAINDLL=$(FLEXLINK) -maindll ### How to build a static library diff --git a/configure b/configure index 1a9d4b0e..48b05b7d 100755 --- a/configure +++ b/configure @@ -13,7 +13,7 @@ # # ######################################################################### -# $Id: configure 10490 2010-06-02 08:58:42Z xleroy $ +# $Id: configure 10626 2010-07-14 10:32:34Z xleroy $ configure_options="$*" prefix=/usr/local @@ -433,10 +433,11 @@ esac # Determine alignment constraints case "$host" in - sparc*-*-*|hppa*-*-*) + sparc*-*-*|hppa*-*-*|arm*-*-*) # On Sparc V9 with certain versions of gcc, determination of double # alignment is not reliable (PR#1521), hence force it. # Same goes for hppa. + # PR#5088 suggests same problem on ARM. # But there's a knack (PR#2572): # if we're in 64-bit mode (sizeof(long) == 8), # we must not doubleword-align floats... @@ -464,7 +465,8 @@ esac if $int64_native; then case "$host" in - sparc*-*-*|hppa*-*-*) + # PR#5088: autodetection is unreliable on ARM + sparc*-*-*|hppa*-*-*|arm*-*-*) if test $2 = 8; then echo "64-bit integers can be word-aligned." echo "#undef ARCH_ALIGN_INT64" >> m.h @@ -1571,10 +1573,11 @@ fi # Look for BFD library -if ./hasgot -i bfd.h -lbfd -ldl; then +if ./hasgot -i bfd.h && \ + ./hasgot -lbfd -ldl -liberty -lz bfd_openr; then echo "BFD library found." echo "#define HAS_LIBBFD" >> s.h - echo "LIBBFD_LINK=-lbfd -ldl" >> Makefile + echo "LIBBFD_LINK=-lbfd -ldl -liberty -lz" >> Makefile else echo "BFD library not found, 'objinfo' will be unable to display info on .cmxs files" echo "LIBBFD_LINK=" >> Makefile diff --git a/driver/main_args.ml b/driver/main_args.ml index e70f91bf..13313e9d 100644 --- a/driver/main_args.ml +++ b/driver/main_args.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: main_args.ml 10444 2010-05-20 14:06:29Z doligez $ *) +(* $Id: main_args.ml 10621 2010-07-06 14:05:26Z maranget $ *) let mk_a f = "-a", Arg.Unit f, " Build a library" @@ -712,6 +712,7 @@ struct mk_nopervasives F._nopervasives; mk_dparsetree F._dparsetree; mk_drawlambda F._drawlambda; + mk_dlambda F._dlambda; mk_dcmm F._dcmm; mk_dsel F._dsel; mk_dcombine F._dcombine; diff --git a/ocamlbuild/discard_printf.ml b/ocamlbuild/discard_printf.ml index 0d2e925d..b48b43c2 100644 --- a/ocamlbuild/discard_printf.ml +++ b/ocamlbuild/discard_printf.ml @@ -11,6 +11,5 @@ (* Original author: Nicolas Pouillard *) -let rec greedy _ = greedy -let discard_printf _fmt = Obj.magic greedy +let discard_printf fmt = Format.ifprintf Format.std_formatter fmt;; diff --git a/ocamldoc/Makefile b/ocamldoc/Makefile index 95b0f9d0..2d8b0ea0 100644 --- a/ocamldoc/Makefile +++ b/ocamldoc/Makefile @@ -9,7 +9,7 @@ #(* *) #(***********************************************************************) -# $Id: Makefile 9270 2009-05-20 11:52:42Z doligez $ +# $Id: Makefile 10584 2010-06-16 11:38:22Z guesdon $ include ../config/Makefile @@ -282,7 +282,7 @@ installopt_really: ########### test: dummy $(MKDIR) $@ - $(OCAMLDOC_RUN) -html -colorize-code -sort -d $@ $(INCLUDES) -dump $@/ocamldoc.odoc test.txt test2.txt odoc*.ml odoc*.mli -v + $(OCAMLDOC_RUN) -html -colorize-code -sort -d $@ $(INCLUDES) -dump $@/ocamldoc.odoc odoc*.ml odoc*.mli -v test_stdlib: dummy $(MKDIR) $@ diff --git a/ocamldoc/odoc_text_lexer.mll b/ocamldoc/odoc_text_lexer.mll index c56013c0..1327e78d 100644 --- a/ocamldoc/odoc_text_lexer.mll +++ b/ocamldoc/odoc_text_lexer.mll @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: odoc_text_lexer.mll 9638 2010-03-08 16:54:13Z guesdon $ *) +(* $Id: odoc_text_lexer.mll 10584 2010-06-16 11:38:22Z guesdon $ *) (** The lexer for string to build text structures. *) @@ -777,7 +777,9 @@ rule main = parse Char (Lexing.lexeme lexbuf) else let s = Lexing.lexeme lexbuf in - let tag = Odoc_misc.no_blanks s in + let len = String.length s in + (* remove this starting '{' *) + let tag = Odoc_misc.no_blanks (String.sub s 1 (len - 1)) in CUSTOM tag } diff --git a/testsuite/Makefile b/testsuite/Makefile index 51e93b8f..d7a97569 100644 --- a/testsuite/Makefile +++ b/testsuite/Makefile @@ -12,13 +12,13 @@ default: @echo " clean deletes generated files" @echo " report prints the report for the last execution, if any" -all: +all: lib @for dir in tests/*; do \ $(MAKE) $(NO_PRINT) exec-one DIR=$$dir; \ done 2>&1 | tee _log @$(MAKE) report -list: +list: lib @if [ -z $(FILE) ]; then echo "No value set for variable 'FILE'."; exit 1; fi @if [ ! -f $(FILE) ]; then echo "File '$(FILE)' does not exist."; exit 1; fi @while read LINE; do \ @@ -33,7 +33,7 @@ one: lib exec-one: @echo "Running tests from '$$DIR' ..." - @(cd $(DIR) && $(MAKE) BASEDIR=$(BASEDIR) && cd ../..) + @(cd $(DIR) && $(MAKE) TERM=dumb BASEDIR=$(BASEDIR) && cd ../..) lib: FORCE @(cd lib && $(MAKE) -s BASEDIR=$(BASEDIR) && cd ..) diff --git a/testsuite/tests/typing-objects/Exemples.ml.reference b/testsuite/tests/typing-objects/Exemples.ml.reference index 6faf6fb6..6be5b694 100644 --- a/testsuite/tests/typing-objects/Exemples.ml.reference +++ b/testsuite/tests/typing-objects/Exemples.ml.reference @@ -24,13 +24,13 @@ # val get_x : < get_x : 'a; .. > -> 'a = # val set_x : < set_x : 'a; .. > -> 'a = # - : int list = [10; 5] -# # - class ref x_init = object +# Characters 7-96: + ......ref x_init = object val mutable x = x_init method get = x method set y = x <- y - end;; -Error: Some type variables are unbound in this type: + end.. +Error: Some type variables are unbound in this type: class ref : 'a -> object @@ -75,15 +75,18 @@ val c' : color_point circle = method move : int -> unit method set_center : 'a -> unit end -# # - let c'' = new color_circle p;; -Error: This expression has type point but an expression was expected of type +# Characters 28-29: + let c'' = new color_circle p;; + ^ +Error: This expression has type point but an expression was expected of type #color_point The first object type has no method color # val c'' : color_point color_circle = # - : color_point circle = -# # (c'' :> point circle);; (* Echec *) -Error: Type +# Characters 0-21: + (c'' :> point circle);; (* Echec *) + ^^^^^^^^^^^^^^^^^^^^^ +Error: Type color_point color_circle = < center : color_point; color : string; move : int -> unit; set_center : color_point -> unit > @@ -91,8 +94,10 @@ val c' : color_point circle = point circle = < center : point; move : int -> unit; set_center : point -> unit > Type point = point is not a subtype of color_point = color_point -# # fun x -> (x : color_point color_circle :> point circle);; -Error: Type +# Characters 9-55: + fun x -> (x : color_point color_circle :> point circle);; + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: Type color_point color_circle = < center : color_point; color : string; move : int -> unit; set_center : color_point -> unit > @@ -110,18 +115,10 @@ Type point = point is not a subtype of color_point = color_point end # val p : printable_point = # 7- : unit = () -# # - class printable_color_point y c = object (self) - inherit color_point y c - inherit printable_point y as super - method print = - print_string "("; - super#print; - print_string ", "; - print_string (self#color); - print_string ")" - end;; -Warning 13: the following instance variables are overridden by the class printable_point : +# Characters 85-102: + inherit printable_point y as super + ^^^^^^^^^^^^^^^^^ +Warning 13: the following instance variables are overridden by the class printable_point : x The behaviour changed in ocaml 3.10 (previous behaviour was hiding.) class printable_color_point : @@ -210,8 +207,10 @@ and ['a] cons : # val c : int_comparable = # - : unit = () # val c2 : int_comparable2 = -# # l#add (c2 :> int_comparable);; (* Echec : 'a comp2 n'est un sous-type *) -Error: Type +# Characters 6-28: + l#add (c2 :> int_comparable);; (* Echec : 'a comp2 n'est un sous-type *) + ^^^^^^^^^^^^^^^^^^^^^^ +Error: Type int_comparable2 = < leq : int_comparable2 -> bool; set_x : int -> unit; x : int > is not a subtype of @@ -231,8 +230,10 @@ is not a subtype of end # val c3 : int_comparable3 = # - : unit = () -# # (new sorted_list ())#add c3;; (* Echec : leq n'est pas binaire *) -Error: This expression has type +# Characters 25-27: + (new sorted_list ())#add c3;; (* Echec : leq n'est pas binaire *) + ^^ +Error: This expression has type int_comparable3 = < leq : int_comparable -> bool; setx : int -> unit; x : int > but an expression was expected of type @@ -243,10 +244,10 @@ is not a subtype of < leq : int_comparable -> bool; setx : int -> unit; x : int > The first object type has no method setx # val sort : (#comparable as 'a) list -> 'a list = -# # let pr l = - List.map (fun c -> print_int c#x; print_string " ") l; - print_newline ();; -Warning 10: this expression should have type unit. +# Characters 13-66: + List.map (fun c -> print_int c#x; print_string " ") l; + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Warning 10: this expression should have type unit. val pr : < x : int; .. > list -> unit = # val l : int_comparable list = [; ; ] # 5 2 4 diff --git a/testsuite/tests/typing-objects/Tests.ml.reference b/testsuite/tests/typing-objects/Tests.ml.reference index 73d8de03..74b1c25f 100644 --- a/testsuite/tests/typing-objects/Tests.ml.reference +++ b/testsuite/tests/typing-objects/Tests.ml.reference @@ -4,16 +4,11 @@ = # class ['a] c : unit -> object constraint 'a = int method f : 'a c end and ['a] d : unit -> object constraint 'a = int method f : 'a c end -# # (* class ['a] c : unit -> object constraint 'a = int method f : 'a c end *) - (* and ['a] d : unit -> object constraint 'a = int method f : 'a c end *) - - (* 'a libre dans classe d *) - class ['a] c () = object - method f (x : 'a) = () - end and d () = object +# Characters 238-275: + ........d () = object inherit ['a] c () - end;; -Error: Some type variables are unbound in this type: + end.. +Error: Some type variables are unbound in this type: class d : unit -> object method f : 'a -> unit end The method f has type 'a -> unit where 'a is unbound # class virtual c : unit -> object end @@ -24,31 +19,22 @@ and ['a] d : unit -> object constraint 'a = int #c end # * class ['a] c : 'a -> object ('a) constraint 'a = < f : 'a; .. > method f : 'a end # - : ('a c as 'a) -> 'a = -# * # (* class ['a] c : - 'a -> object ('a) constraint 'a = < f : 'a; .. > method f : 'a end *) - (* - : ('a c as 'a) -> 'a = *) - - class x () = object +# * Characters 134-176: + ......x () = object method virtual f : int - end;; -Error: This class should be virtual. The following methods are undefined : f -# # (* The class x should be virtual: its methods f is undefined *) - - (* Methode g en trop *) - class virtual c ((x : 'a): < f : int >) = object (_ : 'a) end - and virtual d x = object (_ : 'a) - inherit c x - method g = true - end;; -Error: This pattern cannot match self: it only matches values of type + end.. +Error: This class should be virtual. The following methods are undefined : f +# Characters 139-147: + class virtual c ((x : 'a): < f : int >) = object (_ : 'a) end + ^^^^^^^^ +Error: This pattern cannot match self: it only matches values of type < f : int > -# # - (* Contrainte non respectee *) - class ['a] c () = object +# Characters 38-110: + ......['a] c () = object constraint 'a = int method f x = (x : bool c) - end;; -Error: The abbreviation c is used with parameters bool c + end.. +Error: The abbreviation c is used with parameters bool c wich are incompatible with constraints int c # class ['a, 'b] c : unit -> @@ -65,30 +51,33 @@ and ['a] d : unit -> object constraint 'a = int #c end method f : 'a -> 'b -> unit end # val x : '_a list ref = {contents = []} -# # class ['a] c () = object +# Characters 6-50: + ......['a] c () = object method f = (x : 'a) - end;; -Error: The type of this class, + end.. +Error: The type of this class, class ['a] c : unit -> object constraint 'a = '_b list ref method f : 'a end, contains type variables that cannot be generalized -# # - (* Abreviations *) - type 'a c =  - and 'a d = ;; -Error: In the definition of d, type int c should be 'a c +# Characters 24-52: + type 'a c = + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: In the definition of d, type int c should be 'a c # type 'a c = < f : 'a c; g : 'a d > and 'a d = < f : 'a c > # type 'a c = < f : 'a c > and 'a d = < f : int c > # type 'a u = < x : 'a > and 'a t = 'a t u -# # type 'a u = 'a - and 'a t = 'a t u;; -Error: The type abbreviation t is cyclic +# Characters 18-32: + and 'a t = 'a t u;; + ^^^^^^^^^^^^^^ +Error: The type abbreviation t is cyclic # type 'a u = 'a -# # type t = t u * t u;; -Error: The type abbreviation t is cyclic +# Characters 5-18: + type t = t u * t u;; + ^^^^^^^^^^^^^ +Error: The type abbreviation t is cyclic # type t = < x : 'a > as 'a # type 'a u = 'a # - : t -> t u -> bool = @@ -153,8 +142,10 @@ and 'a t = 'a t u and d : unit -> object method f : int end # class e : unit -> object method f : int end # - : int = 2 -# # class c () = object val x = - true val y = -. () end;; -Error: This expression has type bool but an expression was expected of type +# Characters 30-34: + class c () = object val x = - true val y = -. () end;; + ^^^^ +Error: This expression has type bool but an expression was expected of type int # class c : unit -> object method f : int method g : int method h : int end # class d : unit -> object method h : int method i : int method j : int end @@ -171,68 +162,26 @@ and d : unit -> object method f : int end # - : int * int * int * int * int = (1, 3, 2, 2, 3) # class c : 'a -> object val a : 'a val x : int val y : int val z : int end # class d : 'a -> object val b : 'a val t : int val u : int val z : int end -# # class e () = object - val x = 3 - inherit c 5 - val y = 3 - val t = 3 - inherit d 7 - val u = 3 - method x = x - method y = y - method z = z - method t = t - method u = u - method a = a - method b = b - end;; -Warning 13: the following instance variables are overridden by the class c : +# Characters 43-46: + inherit c 5 + ^^^ +Warning 13: the following instance variables are overridden by the class c : x The behaviour changed in ocaml 3.10 (previous behaviour was hiding.) -# class e () = object - val x = 3 - inherit c 5 - val y = 3 - val t = 3 - inherit d 7 - val u = 3 - method x = x - method y = y - method z = z - method t = t - method u = u - method a = a - method b = b - end;; - - - +Characters 53-58: + val y = 3 + ^^^^^ Warning 13: the instance variable y is overridden. The behaviour changed in ocaml 3.10 (previous behaviour was hiding.) -# class e () = object - val x = 3 - inherit c 5 - val y = 3 - val t = 3 - inherit d 7 - val u = 3 - method x = x - method y = y - method z = z - method t = t - method u = u - method a = a - method b = b - end;; - - - - - +Characters 81-84: + inherit d 7 + ^^^ Warning 13: the following instance variables are overridden by the class d : t z The behaviour changed in ocaml 3.10 (previous behaviour was hiding.) Characters 91-96: + val u = 3 + ^^^^^ Warning 13: the instance variable u is overridden. The behaviour changed in ocaml 3.10 (previous behaviour was hiding.) class e : @@ -268,12 +217,12 @@ class e : # * * * * * * * * * * * * * * * * * * * * * module M : sig class c : unit -> object method xc : int end end # class d : unit -> object val x : int method xc : int method xd : int end # - : int * int = (1, 2) -# # - class virtual ['a] matrix (sz, init : int * 'a) = object +# Characters 7-156: + ......virtual ['a] matrix (sz, init : int * 'a) = object val m = Array.create_matrix sz sz init method add (mtx : 'a matrix) = (mtx#m.(0).(0) : 'a) - end;; -Error: The abbreviation 'a matrix expands to type < add : 'a matrix -> 'a > + end.. +Error: The abbreviation 'a matrix expands to type < add : 'a matrix -> 'a > but is used with type < m : 'a array array; .. > # class c : unit -> object method m : c end # - : c = @@ -282,12 +231,11 @@ class e : # type uu = A of int | B of (< leq : 'a > as 'a) # class virtual c : unit -> object ('a) method virtual m : 'a end # module S : sig val f : (#c as 'a) -> 'a end -# # module S = (struct +# Characters 12-43: + ............struct let f (x : #c) = x - end : sig - val f : #c -> #c - end);; -Error: Signature mismatch: + end...... +Error: Signature mismatch: Modules do not match: sig val f : (#c as 'a) -> 'a end is not included in @@ -296,31 +244,41 @@ class e : val f : (#c as 'a) -> 'a is not included in val f : #c -> #c -# # - module M = struct type t = int class t () = object end end;; -Error: Multiple definition of the type name t. +# Characters 32-55: + module M = struct type t = int class t () = object end end;; + ^^^^^^^^^^^^^^^^^^^^^^^ +Error: Multiple definition of the type name t. Names must be unique in a given structure or signature. # - : < m : (< m : 'a > as 'b) -> 'b as 'a; .. > -> 'b = -# # - fun x -> (x : int -> bool :> 'a -> 'a);; -Error: Type int -> bool is not a subtype of int -> int -# # fun x -> (x : int -> bool :> int -> int);; -Error: Type int -> bool is not a subtype of int -> int +# Characters 10-39: + fun x -> (x : int -> bool :> 'a -> 'a);; + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: Type int -> bool is not a subtype of int -> int +# Characters 9-40: + fun x -> (x : int -> bool :> int -> int);; + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: Type int -> bool is not a subtype of int -> int # - : < > -> < > = # - : < .. > -> < > = # val x : '_a list ref = {contents = []} # module F : functor (X : sig end) -> sig type t = int end # - : < m : int > list ref = {contents = []} # type 'a t -# # fun (x : 'a t as 'a) -> ();; -Error: This alias is bound to type 'a t but is used as an instance of type 'a -# # fun (x : 'a t) -> (x : 'a); ();; -Error: This expression has type 'a t but an expression was expected of type +# Characters 9-19: + fun (x : 'a t as 'a) -> ();; + ^^^^^^^^^^ +Error: This alias is bound to type 'a t but is used as an instance of type 'a +# Characters 19-20: + fun (x : 'a t) -> (x : 'a); ();; + ^ +Error: This expression has type 'a t but an expression was expected of type 'a # type 'a t = < x : 'a > # - : ('a t as 'a) -> unit = -# # fun (x : 'a t) -> (x : 'a); ();; -Warning 10: this expression should have type unit. +# Characters 18-26: + fun (x : 'a t) -> (x : 'a); ();; + ^^^^^^^^ +Warning 10: this expression should have type unit. - : ('a t as 'a) -> unit = # class ['a] c : unit -> object constraint 'a = (< .. > as 'b) -> unit method m : 'a end diff --git a/testsuite/tests/typing-poly/poly.ml.principal.reference b/testsuite/tests/typing-poly/poly.ml.principal.reference index 72a4f551..63281ae0 100644 --- a/testsuite/tests/typing-poly/poly.ml.principal.reference +++ b/testsuite/tests/typing-poly/poly.ml.principal.reference @@ -120,9 +120,10 @@ val cp : color_point = val c : circle = val d : float = 11.4536240470737098 # val f : < m : 'a. 'a -> 'a > -> < m : 'b. 'b -> 'b > = -# # let f (x : < m : 'a. 'a -> 'a list >) = (x : < m : 'b. 'b -> 'c >) - ;; -Error: This expression has type < m : 'a. 'a -> 'a list > +# Characters 41-42: + let f (x : < m : 'a. 'a -> 'a list >) = (x : < m : 'b. 'b -> 'c >) + ^ +Error: This expression has type < m : 'a. 'a -> 'a list > but an expression was expected of type < m : 'a. 'a -> 'b > The universal variable 'a would escape its scope # class id : object method id : 'a -> 'a end @@ -130,57 +131,48 @@ val d : float = 11.4536240470737098 # class id_impl : object method id : 'a -> 'a end # class a : object method m : bool end and b : object method id : 'a -> 'a end -# # - class ['a] id1 = object - method virtual id : 'b. 'b -> 'a - method id x = x - end - ;; -Error: This method has type 'a -> 'a which is less general than 'b. 'b -> 'a -# # class id2 (x : 'a) = object - method virtual id : 'b. 'b -> 'a - method id x = x - end - ;; -Error: This method has type 'a -> 'a which is less general than 'b. 'b -> 'a -# # class id3 x = object - val x = x - method virtual id : 'a. 'a -> 'a - method id _ = x - end - ;; -Error: This method has type 'a -> 'a which is less general than 'b. 'b -> 'b -# # class id4 () = object - val mutable r = None - method virtual id : 'a. 'a -> 'a - method id x = +# Characters 72-77: + method id x = x + ^^^^^ +Error: This method has type 'a -> 'a which is less general than 'b. 'b -> 'a +# Characters 75-80: + method id x = x + ^^^^^ +Error: This method has type 'a -> 'a which is less general than 'b. 'b -> 'a +# Characters 80-85: + method id _ = x + ^^^^^ +Error: This method has type 'a -> 'a which is less general than 'b. 'b -> 'b +# Characters 92-159: + ............x = match r with None -> r <- Some x; x - | Some y -> y - end - ;; -Error: This method has type 'a -> 'a which is less general than 'b. 'b -> 'b + | Some y -> y +Error: This method has type 'a -> 'a which is less general than 'b. 'b -> 'b # class c : object method m : 'a -> 'b -> 'a end # val f1 : id -> int * bool = # val f2 : id -> int * bool = -# # let f3 f = f#id 1, f#id true - ;; -Error: This expression has type bool but an expression was expected of type +# Characters 24-28: + let f3 f = f#id 1, f#id true + ^^^^ +Error: This expression has type bool but an expression was expected of type int -# # let f4 f = ignore(f : id); f#id 1, f#id true - ;; -Warning 18: this use of a polymorphic method is not principal. -# let f4 f = ignore(f : id); f#id 1, f#id true - ;; - +# Characters 27-31: + let f4 f = ignore(f : id); f#id 1, f#id true + ^^^^ +Warning 18: this use of a polymorphic method is not principal. +Characters 35-39: + let f4 f = ignore(f : id); f#id 1, f#id true + ^^^^ Warning 18: this use of a polymorphic method is not principal. val f4 : id -> int * bool = # class c : object method m : #id -> int * bool end # class id2 : object method id : 'a -> 'a method mono : int -> int end # val app : int * bool = (1, true) -# # type 'a foo = 'a foo list - ;; -Error: The type abbreviation foo is cyclic +# Characters 4-25: + type 'a foo = 'a foo list + ^^^^^^^^^^^^^^^^^^^^^ +Error: The type abbreviation foo is cyclic # class ['a] bar : 'a -> object end # type 'a foo = 'a foo bar # - : (< m : 'b. 'b * 'a > as 'a) -> 'c * (< m : 'e. 'e * 'd > as 'd) = @@ -249,13 +241,17 @@ class next : #numeral -> object method fold : ('a -> 'a) -> 'a -> 'a end # class node : node_type # class node : object method as_variant : [> `Node of node_type ] end # type bad = { bad : 'a. 'a option ref; } -# # let bad = {bad = ref None};; -Error: This field value has type 'a option ref which is less general than +# Characters 17-25: + let bad = {bad = ref None};; + ^^^^^^^^ +Error: This field value has type 'a option ref which is less general than 'b. 'b option ref # type bad2 = { mutable bad2 : 'a. 'a option ref option; } # val bad2 : bad2 = {bad2 = None} -# # bad2.bad2 <- Some (ref None);; -Error: This field value has type 'a option ref option +# Characters 13-28: + bad2.bad2 <- Some (ref None);; + ^^^^^^^^^^^^^^^ +Error: This field value has type 'a option ref option which is less general than 'b. 'b option ref option # val f : < m : 'a. < p : 'a * 'b > as 'b > -> 'c -> unit = # val f : @@ -266,48 +262,49 @@ class next : #numeral -> object method fold : ('a -> 'a) -> 'a -> 'a end # class c : object method m : ([> 'a t ] as 'a) -> unit end # class c : object method m : ([> 'a t ] as 'a) -> 'a end # class c : object method m : ([> `A ] as 'a) option -> 'a end -# # - (* various old bugs *) - class virtual ['a] visitor = - object method virtual caseNil : 'a end - and virtual int_list = - object method virtual visit : 'a.('a visitor -> 'a) end;; -Error: This type scheme cannot quantify 'a : +# Characters 145-166: + object method virtual visit : 'a.('a visitor -> 'a) end;; + ^^^^^^^^^^^^^^^^^^^^^ +Error: This type scheme cannot quantify 'a : it escapes this scope. # type ('a, 'b) list_visitor = < caseCons : 'b -> 'b list -> 'a; caseNil : 'a > type 'a alist = < visit : 'b. ('b, 'a) list_visitor -> 'b > class type ct = object ('a) method fold : ('b -> 'a -> 'b) -> 'b -> 'b end type t = { f : 'a 'b. ('b -> (#ct as 'a) -> 'b) -> 'b; } -# # - (* PR#1663 *) - type t = u and u = t;; -Error: The type abbreviation t is cyclic +# Characters 20-25: + type t = u and u = t;; + ^^^^^ +Error: The type abbreviation t is cyclic # class ['a] a : object constraint 'a = [> `A of 'a a ] end type t = [ `A of t a ] -# # - (* Wrong in 3.06 *) - type ('a,'b) t constraint 'a = 'b and ('a,'b) u = ('a,'b) t;; -Error: Constraints are not satisfied in this type. +# Characters 71-80: + type ('a,'b) t constraint 'a = 'b and ('a,'b) u = ('a,'b) t;; + ^^^^^^^^^ +Error: Constraints are not satisfied in this type. Type ('a, 'b) t should be an instance of ('c, 'c) t # type 'a t = 'a and u = int t # type 'a t constraint 'a = int -# # type 'a u = 'a and 'a v = 'a u t;; -Error: Constraints are not satisfied in this type. +# Characters 26-32: + type 'a u = 'a and 'a v = 'a u t;; + ^^^^^^ +Error: Constraints are not satisfied in this type. Type 'a u t should be an instance of int t # type 'a u = 'a constraint 'a = int and 'a v = 'a u t constraint 'a = int # type g = int # type 'a t = unit constraint 'a = g -# # type 'a u = 'a and 'a v = 'a u t;; -Error: Constraints are not satisfied in this type. +# Characters 26-32: + type 'a u = 'a and 'a v = 'a u t;; + ^^^^^^ +Error: Constraints are not satisfied in this type. Type 'a u t should be an instance of g t # type 'a u = 'a constraint 'a = g and 'a v = 'a u t constraint 'a = int -# # - (* Example of wrong expansion *) - type 'a u = < m : 'a v > and 'a v = 'a list u;; -Error: In the definition of v, type 'a list u should be 'a u +# Characters 38-58: + type 'a u = < m : 'a v > and 'a v = 'a list u;; + ^^^^^^^^^^^^^^^^^^^^ +Error: In the definition of v, type 'a list u should be 'a u # type 'a t = 'a type 'a u = A of 'a t # type 'a t = < a : 'a > @@ -320,36 +317,39 @@ type 'a u = A of 'a t # - : [> `A ] option * t -> int = # - : t * [< `A | `B ] -> int = # - : [< `A | `B ] * t -> int = -# # function (`A|`B), _ -> 0 | _,(`A|`B) -> 1;; -Warning 8: this pattern-matching is not exhaustive. +# Characters 0-41: + function (`A|`B), _ -> 0 | _,(`A|`B) -> 1;; + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Warning 8: this pattern-matching is not exhaustive. Here is an example of a value that is not matched: (`AnyExtraTag, `AnyExtraTag) - : [> `A | `B ] * [> `A | `B ] -> int = -# # function `B,1 -> 1 | _,1 -> 2;; -Warning 8: this pattern-matching is not exhaustive. +# Characters 0-29: + function `B,1 -> 1 | _,1 -> 2;; + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Warning 8: this pattern-matching is not exhaustive. Here is an example of a value that is not matched: (_, 0) -# function `B,1 -> 1 | _,1 -> 2;; - - - +Characters 21-24: + function `B,1 -> 1 | _,1 -> 2;; + ^^^ Warning 11: this match case is unused. - : [< `B ] * int -> int = -# # function 1,`B -> 1 | 1,_ -> 2;; -Warning 8: this pattern-matching is not exhaustive. +# Characters 0-29: + function 1,`B -> 1 | 1,_ -> 2;; + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Warning 8: this pattern-matching is not exhaustive. Here is an example of a value that is not matched: (0, _) -# function 1,`B -> 1 | 1,_ -> 2;; - - - +Characters 21-24: + function 1,`B -> 1 | 1,_ -> 2;; + ^^^ Warning 11: this match case is unused. - : int * [< `B ] -> int = -# # - (* pass typetexp, but fails during Typedecl.check_recursion *) - type ('a, 'b) a = 'a -> unit constraint 'a = [> `B of ('a, 'b) b as 'b] - and ('a, 'b) b = 'b -> unit constraint 'b = [> `A of ('a, 'b) a as 'a];; -Error: Constraints are not satisfied in this type. +# Characters 69-135: + type ('a, 'b) a = 'a -> unit constraint 'a = [> `B of ('a, 'b) b as 'b] + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: Constraints are not satisfied in this type. Type ([> `B of 'a ], 'a) b as 'a should be an instance of @@ -384,79 +384,80 @@ type bt = 'a ca cb as 'a # class c : object method m : int end # val f : unit -> c = # val f : unit -> c = -# # let f () = object method private n = 1 method m = {<>}#n end;; -Warning 15: the following private methods were made public implicitly: +# Characters 11-60: + let f () = object method private n = 1 method m = {<>}#n end;; + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Warning 15: the following private methods were made public implicitly: n. val f : unit -> < m : int; n : int > = -# # let f () = object (self:c) method n = 1 method m = 2 end;; -Error: This object is expected to have type c but actually has type +# Characters 11-56: + let f () = object (self:c) method n = 1 method m = 2 end;; + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This object is expected to have type c but actually has type < m : int; n : 'a > The first object type has no method n -# # let f () = object (_:'s) constraint 's = < n : int > method m = 1 end;; -Error: This object is expected to have type < n : int > but actually has type +# Characters 11-69: + let f () = object (_:'s) constraint 's = < n : int > method m = 1 end;; + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This object is expected to have type < n : int > but actually has type < m : 'a > The second object type has no method n -# # class c = object (_ : 's) - method x = 1 - method private m = - object (self: 's) method x = 3 method private m = self end - end;; -Error: This object is expected to have type < x : int; .. > +# Characters 66-124: + object (self: 's) method x = 3 method private m = self end + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This object is expected to have type < x : int; .. > but actually has type < x : int > Self type cannot be unified with a closed object type # val o : < x : int > = -# # - - (* Unsound! *) - fun (x : > as 'foo) -> - (x : > as 'bar) >);; -Error: This expression has type < m : 'b. 'b * < m : 'b * 'a > > as 'a +# Characters 76-77: + (x : > as 'bar) >);; + ^ +Error: This expression has type < m : 'b. 'b * < m : 'b * 'a > > as 'a but an expression was expected of type < m : 'b. 'b * (< m : 'b * < m : 'd. 'd * 'c > > as 'c) > Types for method m are incompatible -# # type 'a foo = - type foo' = - type 'a bar = > - type bar' = - let f (x : foo') = (x : bar');; -Error: This expression has type foo' = < m : 'a. 'a * 'a foo > +# Characters 176-177: + let f (x : foo') = (x : bar');; + ^ +Error: This expression has type foo' = < m : 'a. 'a * 'a foo > but an expression was expected of type bar' = < m : 'a. 'a * 'a bar > Type 'a foo = < m : 'a * 'a foo > is not compatible with type 'a bar = < m : 'a * < m : 'b. 'b * 'a bar > > Type 'a foo = < m : 'a * 'a foo > is not compatible with type < m : 'b. 'b * 'a bar > Types for method m are incompatible -# # - fun (x : as 'foo)>) -> - (x : )> as 'bar);; -Error: This expression has type +# Characters 67-68: + (x : )> as 'bar);; + ^ +Error: This expression has type < m : 'a. 'a * ('a * < m : 'c. 'c * 'b > as 'b) > but an expression was expected of type < m : 'a. 'a * ('a * < m : 'c. 'c * ('c * 'd) >) > as 'd Types for method m are incompatible -# # fun (x : as 'foo)>) -> - (x : )> as 'bar);; -Error: This expression has type +# Characters 66-67: + (x : )> as 'bar);; + ^ +Error: This expression has type < m : 'a. 'a * ('a * < m : 'c. 'c * 'b > as 'b) > but an expression was expected of type < m : 'a. 'a * ('a * < m : 'c. 'c * ('a * 'd) >) > as 'd Types for method m are incompatible -# # fun (x : as 'foo) -> - (x : as 'bar)>);; -Error: This expression has type < m : 'b. 'b * ('b * 'a) > as 'a +# Characters 51-52: + (x : as 'bar)>);; + ^ +Error: This expression has type < m : 'b. 'b * ('b * 'a) > as 'a but an expression was expected of type < m : 'b. 'b * ('b * < m : 'd. 'd * 'c > as 'c) > Types for method m are incompatible -# # let f x = - (x : ('a * 'bar> as 'bar)> - :> ('a * 'foo)> as 'foo);; -Error: Type < m : 'a. 'a -> ('a * (< m : 'd. 'd -> 'b as 'e > as 'c) as 'b) > +# Characters 14-115: + ....(x : ('a * 'bar> as 'bar)> + :> ('a * 'foo)> as 'foo).. +Error: Type < m : 'a. 'a -> ('a * (< m : 'd. 'd -> 'b as 'e > as 'c) as 'b) > is not a subtype of < m : 'a. 'a -> ('a * 'f as 'h) as 'g > as 'f -# # - module M - : sig val f : ( as 'bar)>) -> unit end - = struct let f (x : as 'foo) = () end;; -Error: Signature mismatch: +# Characters 88-150: + = struct let f (x : as 'foo) = () end;; + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: Signature mismatch: Modules do not match: sig val f : (< m : 'b. 'b * ('b * 'a) > as 'a) -> unit end is not included in @@ -467,10 +468,10 @@ val f : unit -> < m : int; n : int > = val f : (< m : 'b. 'b * ('b * 'a) > as 'a) -> unit is not included in val f : < m : 'a. 'a * ('a * < m : 'c. 'c * 'b > as 'b) > -> unit -# # module M - : sig type t = as 'bar)> end - = struct type t = as 'foo end;; -Error: Signature mismatch: +# Characters 78-132: + = struct type t = as 'foo end;; + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: Signature mismatch: Modules do not match: sig type t = < m : 'b. 'b * ('b * 'a) > as 'a end is not included in @@ -490,40 +491,48 @@ val f : unit -> < m : int; n : int > = # - : t -> v = # type u = private [< t ] # - : u -> v = -# # fun x -> (x : v :> u);; -Error: Type v = [> `A | `B ] is not a subtype of u = [< `A | `B ] +# Characters 9-21: + fun x -> (x : v :> u);; + ^^^^^^^^^^^^ +Error: Type v = [> `A | `B ] is not a subtype of u = [< `A | `B ] # type v = private [< t ] -# # fun x -> (x : u :> v);; -Error: Type u = [< `A | `B ] is not a subtype of v = [< `A | `B ] +# Characters 9-21: + fun x -> (x : u :> v);; + ^^^^^^^^^^^^ +Error: Type u = [< `A | `B ] is not a subtype of v = [< `A | `B ] # type p = < x : p > # type q = private < x : p; .. > # - : q -> p = -# # fun x -> (x : p :> q);; -Error: Type p = < x : p > is not a subtype of q = < x : p; .. > -# # - let f1 x = - (x : as 'a) -> int> - :> as 'b) -> int>);; -Error: Type < m : 'a. (< p : int; .. > as 'a) -> int > is not a subtype of +# Characters 9-21: + fun x -> (x : p :> q);; + ^^^^^^^^^^^^ +Error: Type p = < x : p > is not a subtype of q = < x : p; .. > +# Characters 14-100: + ..(x : as 'a) -> int> + :> as 'b) -> int>).. +Error: Type < m : 'a. (< p : int; .. > as 'a) -> int > is not a subtype of < m : 'b. (< p : int; q : int; .. > as 'b) -> int > # val f2 : < m : 'a. (< p : < a : int >; .. > as 'a) -> int > -> < m : 'a. (< p : < a : int; b : int >; .. > as 'a) -> int > = -# # let f3 x = - (x : ;..> as 'a) -> int> - :> ;..> as 'b) -> int>);; -Error: Type < m : 'a. (< p : < a : int; b : int >; .. > as 'a) -> int > +# Characters 13-107: + ..(x : ;..> as 'a) -> int> + :> ;..> as 'b) -> int>).. +Error: Type < m : 'a. (< p : < a : int; b : int >; .. > as 'a) -> int > is not a subtype of < m : 'a. (< p : < a : int >; .. > as 'a) -> int > -# # let f4 x = (x : ;..> :> ;..>);; -Error: Type < p : < a : int; b : int >; .. > is not a subtype of +# Characters 11-55: + let f4 x = (x : ;..> :> ;..>);; + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: Type < p : < a : int; b : int >; .. > is not a subtype of < p : < a : int >; .. > The second object type has no method b # val f5 : < m : 'a. [< `A of < p : int > ] as 'a > -> < m : 'a. [< `A of < > ] as 'a > = -# # let f6 x = - (x : ] as 'a> :> ] as 'a>);; -Error: Type < m : 'a. [< `A of < > ] as 'a > is not a subtype of +# Characters 13-83: + (x : ] as 'a> :> ] as 'a>);; + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: Type < m : 'a. [< `A of < > ] as 'a > is not a subtype of < m : 'a. [< `A of < p : int > ] as 'a > # class c : object method id : 'a -> 'a end # type u = c option @@ -535,36 +544,42 @@ The second object type has no method b val g : 'a -> int = # type 'a t = Leaf of 'a | Node of ('a * 'a) t # val depth : 'a t -> int = -# # let rec depth : 'a. 'a t -> _ = - function Leaf _ -> 1 | Node x -> 1 + d x - and d x = depth x;; (* fails *) -Error: This definition has type 'a t -> int which is less general than +# Characters 34-74: + function Leaf _ -> 1 | Node x -> 1 + d x + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This definition has type 'a t -> int which is less general than 'b. 'b t -> int -# # let rec depth : 'a. 'a t -> _ = - function Leaf x -> x | Node x -> 1 + depth x;; (* fails *) -Error: This definition has type int t -> int which is less general than +# Characters 34-78: + function Leaf x -> x | Node x -> 1 + depth x;; (* fails *) + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This definition has type int t -> int which is less general than 'a. 'a t -> int -# # let rec depth : 'a. 'a t -> _ = - function Leaf x -> x | Node x -> depth x;; (* fails *) -Error: This definition has type 'a t -> 'a which is less general than +# Characters 34-74: + function Leaf x -> x | Node x -> depth x;; (* fails *) + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This definition has type 'a t -> 'a which is less general than 'b. 'b t -> 'a -# # let rec depth : 'a 'b. 'a t -> 'b = - function Leaf x -> x | Node x -> depth x;; (* fails *) -Error: This definition has type 'a. 'a t -> 'a which is less general than +# Characters 38-78: + function Leaf x -> x | Node x -> depth x;; (* fails *) + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This definition has type 'a. 'a t -> 'a which is less general than 'b 'c. 'c t -> 'b # val r : 'a list * '_b list ref = ([], {contents = []}) val q : unit -> 'a list * '_b list ref = # val f : 'a -> 'a = # val zero : [> `B of 'a | `Int of int ] as 'a = `Int 0 -# # let zero : 'a. [< `Int of int] as 'a = `Int 0;; (* fails *) -Error: This expression has type [> `Int of int ] +# Characters 39-45: + let zero : 'a. [< `Int of int] as 'a = `Int 0;; (* fails *) + ^^^^^^ +Error: This expression has type [> `Int of int ] but an expression was expected of type [< `Int of int ] Types for tag `Int are incompatible # type t = { f : 'a. [> `B of 'a | `Int of int ] as 'a; } val zero : t = {f = `Int 0} -# # type t = {f: 'a. [< `Int of int] as 'a} - let zero = {f = `Int 0} ;; (* fails *) -Error: This expression has type [> `Int of int ] +# Characters 56-62: + let zero = {f = `Int 0} ;; (* fails *) + ^^^^^^ +Error: This expression has type [> `Int of int ] but an expression was expected of type [< `Int of int ] Types for tag `Int are incompatible # val id : 'a -> 'a = @@ -576,7 +591,9 @@ val transf_alist : (int -> t) -> ('a * t) list -> ('a * t) list = val l : t = {f = } # type t = { f : 'a. 'a -> unit; } # - : t = {f = } -# # {f=fun ?x y -> y};; (* fail *) -Error: This field value has type unit -> unit which is less general than +# Characters 3-16: + {f=fun ?x y -> y};; (* fail *) + ^^^^^^^^^^^^^ +Error: This field value has type unit -> unit which is less general than 'a. 'a -> unit # diff --git a/testsuite/tests/typing-poly/poly.ml.reference b/testsuite/tests/typing-poly/poly.ml.reference index 75e26f18..6e4fce85 100644 --- a/testsuite/tests/typing-poly/poly.ml.reference +++ b/testsuite/tests/typing-poly/poly.ml.reference @@ -120,9 +120,10 @@ val cp : color_point = val c : circle = val d : float = 11.4536240470737098 # val f : < m : 'a. 'a -> 'a > -> < m : 'a. 'a -> 'a > = -# # let f (x : < m : 'a. 'a -> 'a list >) = (x : < m : 'b. 'b -> 'c >) - ;; -Error: This expression has type < m : 'a. 'a -> 'a list > +# Characters 41-42: + let f (x : < m : 'a. 'a -> 'a list >) = (x : < m : 'b. 'b -> 'c >) + ^ +Error: This expression has type < m : 'a. 'a -> 'a list > but an expression was expected of type < m : 'a. 'a -> 'b > The universal variable 'a would escape its scope # class id : object method id : 'a -> 'a end @@ -130,50 +131,40 @@ val d : float = 11.4536240470737098 # class id_impl : object method id : 'a -> 'a end # class a : object method m : bool end and b : object method id : 'a -> 'a end -# # - class ['a] id1 = object - method virtual id : 'b. 'b -> 'a - method id x = x - end - ;; -Error: This method has type 'a -> 'a which is less general than 'b. 'b -> 'a -# # class id2 (x : 'a) = object - method virtual id : 'b. 'b -> 'a - method id x = x - end - ;; -Error: This method has type 'a -> 'a which is less general than 'b. 'b -> 'a -# # class id3 x = object - val x = x - method virtual id : 'a. 'a -> 'a - method id _ = x - end - ;; -Error: This method has type 'a -> 'a which is less general than 'b. 'b -> 'b -# # class id4 () = object - val mutable r = None - method virtual id : 'a. 'a -> 'a - method id x = +# Characters 72-77: + method id x = x + ^^^^^ +Error: This method has type 'a -> 'a which is less general than 'b. 'b -> 'a +# Characters 75-80: + method id x = x + ^^^^^ +Error: This method has type 'a -> 'a which is less general than 'b. 'b -> 'a +# Characters 80-85: + method id _ = x + ^^^^^ +Error: This method has type 'a -> 'a which is less general than 'b. 'b -> 'b +# Characters 92-159: + ............x = match r with None -> r <- Some x; x - | Some y -> y - end - ;; -Error: This method has type 'a -> 'a which is less general than 'b. 'b -> 'b + | Some y -> y +Error: This method has type 'a -> 'a which is less general than 'b. 'b -> 'b # class c : object method m : 'a -> 'b -> 'a end # val f1 : id -> int * bool = # val f2 : id -> int * bool = -# # let f3 f = f#id 1, f#id true - ;; -Error: This expression has type bool but an expression was expected of type +# Characters 24-28: + let f3 f = f#id 1, f#id true + ^^^^ +Error: This expression has type bool but an expression was expected of type int # val f4 : id -> int * bool = # class c : object method m : #id -> int * bool end # class id2 : object method id : 'a -> 'a method mono : int -> int end # val app : int * bool = (1, true) -# # type 'a foo = 'a foo list - ;; -Error: The type abbreviation foo is cyclic +# Characters 4-25: + type 'a foo = 'a foo list + ^^^^^^^^^^^^^^^^^^^^^ +Error: The type abbreviation foo is cyclic # class ['a] bar : 'a -> object end # type 'a foo = 'a foo bar # - : (< m : 'b. 'b * 'a > as 'a) -> 'c * 'a = @@ -235,13 +226,17 @@ class next : #numeral -> object method fold : ('a -> 'a) -> 'a -> 'a end # class node : node_type # class node : object method as_variant : [> `Node of node_type ] end # type bad = { bad : 'a. 'a option ref; } -# # let bad = {bad = ref None};; -Error: This field value has type 'a option ref which is less general than +# Characters 17-25: + let bad = {bad = ref None};; + ^^^^^^^^ +Error: This field value has type 'a option ref which is less general than 'b. 'b option ref # type bad2 = { mutable bad2 : 'a. 'a option ref option; } # val bad2 : bad2 = {bad2 = None} -# # bad2.bad2 <- Some (ref None);; -Error: This field value has type 'a option ref option +# Characters 13-28: + bad2.bad2 <- Some (ref None);; + ^^^^^^^^^^^^^^^ +Error: This field value has type 'a option ref option which is less general than 'b. 'b option ref option # val f : < m : 'a. < p : 'a * 'b > as 'b > -> 'c -> unit = # val f : < m : 'a. 'a * (< p : int * 'b > as 'b) > -> 'b -> unit = @@ -250,48 +245,49 @@ class next : #numeral -> object method fold : ('a -> 'a) -> 'a -> 'a end # class c : object method m : ([> 'a t ] as 'a) -> unit end # class c : object method m : ([> 'a t ] as 'a) -> 'a end # class c : object method m : ([> `A ] as 'a) option -> 'a end -# # - (* various old bugs *) - class virtual ['a] visitor = - object method virtual caseNil : 'a end - and virtual int_list = - object method virtual visit : 'a.('a visitor -> 'a) end;; -Error: This type scheme cannot quantify 'a : +# Characters 145-166: + object method virtual visit : 'a.('a visitor -> 'a) end;; + ^^^^^^^^^^^^^^^^^^^^^ +Error: This type scheme cannot quantify 'a : it escapes this scope. # type ('a, 'b) list_visitor = < caseCons : 'b -> 'b list -> 'a; caseNil : 'a > type 'a alist = < visit : 'b. ('b, 'a) list_visitor -> 'b > class type ct = object ('a) method fold : ('b -> 'a -> 'b) -> 'b -> 'b end type t = { f : 'a 'b. ('b -> (#ct as 'a) -> 'b) -> 'b; } -# # - (* PR#1663 *) - type t = u and u = t;; -Error: The type abbreviation t is cyclic +# Characters 20-25: + type t = u and u = t;; + ^^^^^ +Error: The type abbreviation t is cyclic # class ['a] a : object constraint 'a = [> `A of 'a a ] end type t = [ `A of t a ] -# # - (* Wrong in 3.06 *) - type ('a,'b) t constraint 'a = 'b and ('a,'b) u = ('a,'b) t;; -Error: Constraints are not satisfied in this type. +# Characters 71-80: + type ('a,'b) t constraint 'a = 'b and ('a,'b) u = ('a,'b) t;; + ^^^^^^^^^ +Error: Constraints are not satisfied in this type. Type ('a, 'b) t should be an instance of ('c, 'c) t # type 'a t = 'a and u = int t # type 'a t constraint 'a = int -# # type 'a u = 'a and 'a v = 'a u t;; -Error: Constraints are not satisfied in this type. +# Characters 26-32: + type 'a u = 'a and 'a v = 'a u t;; + ^^^^^^ +Error: Constraints are not satisfied in this type. Type 'a u t should be an instance of int t # type 'a u = 'a constraint 'a = int and 'a v = 'a u t constraint 'a = int # type g = int # type 'a t = unit constraint 'a = g -# # type 'a u = 'a and 'a v = 'a u t;; -Error: Constraints are not satisfied in this type. +# Characters 26-32: + type 'a u = 'a and 'a v = 'a u t;; + ^^^^^^ +Error: Constraints are not satisfied in this type. Type 'a u t should be an instance of g t # type 'a u = 'a constraint 'a = g and 'a v = 'a u t constraint 'a = int -# # - (* Example of wrong expansion *) - type 'a u = < m : 'a v > and 'a v = 'a list u;; -Error: In the definition of v, type 'a list u should be 'a u +# Characters 38-58: + type 'a u = < m : 'a v > and 'a v = 'a list u;; + ^^^^^^^^^^^^^^^^^^^^ +Error: In the definition of v, type 'a list u should be 'a u # type 'a t = 'a type 'a u = A of 'a t # type 'a t = < a : 'a > @@ -304,36 +300,39 @@ type 'a u = A of 'a t # - : [> `A ] option * t -> int = # - : t * [< `A | `B ] -> int = # - : [< `A | `B ] * t -> int = -# # function (`A|`B), _ -> 0 | _,(`A|`B) -> 1;; -Warning 8: this pattern-matching is not exhaustive. +# Characters 0-41: + function (`A|`B), _ -> 0 | _,(`A|`B) -> 1;; + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Warning 8: this pattern-matching is not exhaustive. Here is an example of a value that is not matched: (`AnyExtraTag, `AnyExtraTag) - : [> `A | `B ] * [> `A | `B ] -> int = -# # function `B,1 -> 1 | _,1 -> 2;; -Warning 8: this pattern-matching is not exhaustive. +# Characters 0-29: + function `B,1 -> 1 | _,1 -> 2;; + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Warning 8: this pattern-matching is not exhaustive. Here is an example of a value that is not matched: (_, 0) -# function `B,1 -> 1 | _,1 -> 2;; - - - +Characters 21-24: + function `B,1 -> 1 | _,1 -> 2;; + ^^^ Warning 11: this match case is unused. - : [< `B ] * int -> int = -# # function 1,`B -> 1 | 1,_ -> 2;; -Warning 8: this pattern-matching is not exhaustive. +# Characters 0-29: + function 1,`B -> 1 | 1,_ -> 2;; + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Warning 8: this pattern-matching is not exhaustive. Here is an example of a value that is not matched: (0, _) -# function 1,`B -> 1 | 1,_ -> 2;; - - - +Characters 21-24: + function 1,`B -> 1 | 1,_ -> 2;; + ^^^ Warning 11: this match case is unused. - : int * [< `B ] -> int = -# # - (* pass typetexp, but fails during Typedecl.check_recursion *) - type ('a, 'b) a = 'a -> unit constraint 'a = [> `B of ('a, 'b) b as 'b] - and ('a, 'b) b = 'b -> unit constraint 'b = [> `A of ('a, 'b) a as 'a];; -Error: Constraints are not satisfied in this type. +# Characters 69-135: + type ('a, 'b) a = 'a -> unit constraint 'a = [> `B of ('a, 'b) b as 'b] + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: Constraints are not satisfied in this type. Type ([> `B of 'a ], 'a) b as 'a should be an instance of @@ -368,79 +367,80 @@ type bt = 'a ca cb as 'a # class c : object method m : int end # val f : unit -> c = # val f : unit -> c = -# # let f () = object method private n = 1 method m = {<>}#n end;; -Warning 15: the following private methods were made public implicitly: +# Characters 11-60: + let f () = object method private n = 1 method m = {<>}#n end;; + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Warning 15: the following private methods were made public implicitly: n. val f : unit -> < m : int; n : int > = -# # let f () = object (self:c) method n = 1 method m = 2 end;; -Error: This object is expected to have type c but actually has type +# Characters 11-56: + let f () = object (self:c) method n = 1 method m = 2 end;; + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This object is expected to have type c but actually has type < m : int; n : 'a > The first object type has no method n -# # let f () = object (_:'s) constraint 's = < n : int > method m = 1 end;; -Error: This object is expected to have type < n : int > but actually has type +# Characters 11-69: + let f () = object (_:'s) constraint 's = < n : int > method m = 1 end;; + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This object is expected to have type < n : int > but actually has type < m : 'a > The second object type has no method n -# # class c = object (_ : 's) - method x = 1 - method private m = - object (self: 's) method x = 3 method private m = self end - end;; -Error: This object is expected to have type < x : int; .. > +# Characters 66-124: + object (self: 's) method x = 3 method private m = self end + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This object is expected to have type < x : int; .. > but actually has type < x : int > Self type cannot be unified with a closed object type # val o : < x : int > = -# # - - (* Unsound! *) - fun (x : > as 'foo) -> - (x : > as 'bar) >);; -Error: This expression has type < m : 'b. 'b * < m : 'b * 'a > > as 'a +# Characters 76-77: + (x : > as 'bar) >);; + ^ +Error: This expression has type < m : 'b. 'b * < m : 'b * 'a > > as 'a but an expression was expected of type < m : 'b. 'b * (< m : 'b * < m : 'd. 'd * 'c > > as 'c) > Types for method m are incompatible -# # type 'a foo = - type foo' = - type 'a bar = > - type bar' = - let f (x : foo') = (x : bar');; -Error: This expression has type foo' = < m : 'a. 'a * 'a foo > +# Characters 176-177: + let f (x : foo') = (x : bar');; + ^ +Error: This expression has type foo' = < m : 'a. 'a * 'a foo > but an expression was expected of type bar' = < m : 'a. 'a * 'a bar > Type 'a foo = < m : 'a * 'a foo > is not compatible with type 'a bar = < m : 'a * < m : 'b. 'b * 'a bar > > Type 'a foo = < m : 'a * 'a foo > is not compatible with type < m : 'b. 'b * 'a bar > Types for method m are incompatible -# # - fun (x : as 'foo)>) -> - (x : )> as 'bar);; -Error: This expression has type +# Characters 67-68: + (x : )> as 'bar);; + ^ +Error: This expression has type < m : 'a. 'a * ('a * < m : 'c. 'c * 'b > as 'b) > but an expression was expected of type < m : 'a. 'a * ('a * < m : 'c. 'c * ('c * 'd) >) > as 'd Types for method m are incompatible -# # fun (x : as 'foo)>) -> - (x : )> as 'bar);; -Error: This expression has type +# Characters 66-67: + (x : )> as 'bar);; + ^ +Error: This expression has type < m : 'a. 'a * ('a * < m : 'c. 'c * 'b > as 'b) > but an expression was expected of type < m : 'a. 'a * ('a * < m : 'c. 'c * ('a * 'd) >) > as 'd Types for method m are incompatible -# # fun (x : as 'foo) -> - (x : as 'bar)>);; -Error: This expression has type < m : 'b. 'b * ('b * 'a) > as 'a +# Characters 51-52: + (x : as 'bar)>);; + ^ +Error: This expression has type < m : 'b. 'b * ('b * 'a) > as 'a but an expression was expected of type < m : 'b. 'b * ('b * < m : 'd. 'd * 'c > as 'c) > Types for method m are incompatible -# # let f x = - (x : ('a * 'bar> as 'bar)> - :> ('a * 'foo)> as 'foo);; -Error: Type < m : 'a. 'a -> ('a * (< m : 'd. 'd -> 'b as 'e > as 'c) as 'b) > +# Characters 14-115: + ....(x : ('a * 'bar> as 'bar)> + :> ('a * 'foo)> as 'foo).. +Error: Type < m : 'a. 'a -> ('a * (< m : 'd. 'd -> 'b as 'e > as 'c) as 'b) > is not a subtype of < m : 'a. 'a -> ('a * 'f as 'h) as 'g > as 'f -# # - module M - : sig val f : ( as 'bar)>) -> unit end - = struct let f (x : as 'foo) = () end;; -Error: Signature mismatch: +# Characters 88-150: + = struct let f (x : as 'foo) = () end;; + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: Signature mismatch: Modules do not match: sig val f : (< m : 'b. 'b * ('b * 'a) > as 'a) -> unit end is not included in @@ -451,10 +451,10 @@ val f : unit -> < m : int; n : int > = val f : (< m : 'b. 'b * ('b * 'a) > as 'a) -> unit is not included in val f : < m : 'a. 'a * ('a * < m : 'c. 'c * 'b > as 'b) > -> unit -# # module M - : sig type t = as 'bar)> end - = struct type t = as 'foo end;; -Error: Signature mismatch: +# Characters 78-132: + = struct type t = as 'foo end;; + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: Signature mismatch: Modules do not match: sig type t = < m : 'b. 'b * ('b * 'a) > as 'a end is not included in @@ -474,40 +474,48 @@ val f : unit -> < m : int; n : int > = # - : t -> v = # type u = private [< t ] # - : u -> v = -# # fun x -> (x : v :> u);; -Error: Type v = [> `A | `B ] is not a subtype of u = [< `A | `B ] +# Characters 9-21: + fun x -> (x : v :> u);; + ^^^^^^^^^^^^ +Error: Type v = [> `A | `B ] is not a subtype of u = [< `A | `B ] # type v = private [< t ] -# # fun x -> (x : u :> v);; -Error: Type u = [< `A | `B ] is not a subtype of v = [< `A | `B ] +# Characters 9-21: + fun x -> (x : u :> v);; + ^^^^^^^^^^^^ +Error: Type u = [< `A | `B ] is not a subtype of v = [< `A | `B ] # type p = < x : p > # type q = private < x : p; .. > # - : q -> p = -# # fun x -> (x : p :> q);; -Error: Type p = < x : p > is not a subtype of q = < x : p; .. > -# # - let f1 x = - (x : as 'a) -> int> - :> as 'b) -> int>);; -Error: Type < m : 'a. (< p : int; .. > as 'a) -> int > is not a subtype of +# Characters 9-21: + fun x -> (x : p :> q);; + ^^^^^^^^^^^^ +Error: Type p = < x : p > is not a subtype of q = < x : p; .. > +# Characters 14-100: + ..(x : as 'a) -> int> + :> as 'b) -> int>).. +Error: Type < m : 'a. (< p : int; .. > as 'a) -> int > is not a subtype of < m : 'b. (< p : int; q : int; .. > as 'b) -> int > # val f2 : < m : 'a. (< p : < a : int >; .. > as 'a) -> int > -> < m : 'a. (< p : < a : int; b : int >; .. > as 'a) -> int > = -# # let f3 x = - (x : ;..> as 'a) -> int> - :> ;..> as 'b) -> int>);; -Error: Type < m : 'a. (< p : < a : int; b : int >; .. > as 'a) -> int > +# Characters 13-107: + ..(x : ;..> as 'a) -> int> + :> ;..> as 'b) -> int>).. +Error: Type < m : 'a. (< p : < a : int; b : int >; .. > as 'a) -> int > is not a subtype of < m : 'a. (< p : < a : int >; .. > as 'a) -> int > -# # let f4 x = (x : ;..> :> ;..>);; -Error: Type < p : < a : int; b : int >; .. > is not a subtype of +# Characters 11-55: + let f4 x = (x : ;..> :> ;..>);; + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: Type < p : < a : int; b : int >; .. > is not a subtype of < p : < a : int >; .. > The second object type has no method b # val f5 : < m : 'a. [< `A of < p : int > ] as 'a > -> < m : 'a. [< `A of < > ] as 'a > = -# # let f6 x = - (x : ] as 'a> :> ] as 'a>);; -Error: Type < m : 'a. [< `A of < > ] as 'a > is not a subtype of +# Characters 13-83: + (x : ] as 'a> :> ] as 'a>);; + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: Type < m : 'a. [< `A of < > ] as 'a > is not a subtype of < m : 'a. [< `A of < p : int > ] as 'a > # class c : object method id : 'a -> 'a end # type u = c option @@ -519,36 +527,42 @@ The second object type has no method b val g : 'a -> int = # type 'a t = Leaf of 'a | Node of ('a * 'a) t # val depth : 'a t -> int = -# # let rec depth : 'a. 'a t -> _ = - function Leaf _ -> 1 | Node x -> 1 + d x - and d x = depth x;; (* fails *) -Error: This definition has type 'a t -> int which is less general than +# Characters 34-74: + function Leaf _ -> 1 | Node x -> 1 + d x + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This definition has type 'a t -> int which is less general than 'b. 'b t -> int -# # let rec depth : 'a. 'a t -> _ = - function Leaf x -> x | Node x -> 1 + depth x;; (* fails *) -Error: This definition has type int t -> int which is less general than +# Characters 34-78: + function Leaf x -> x | Node x -> 1 + depth x;; (* fails *) + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This definition has type int t -> int which is less general than 'a. 'a t -> int -# # let rec depth : 'a. 'a t -> _ = - function Leaf x -> x | Node x -> depth x;; (* fails *) -Error: This definition has type 'a t -> 'a which is less general than +# Characters 34-74: + function Leaf x -> x | Node x -> depth x;; (* fails *) + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This definition has type 'a t -> 'a which is less general than 'b. 'b t -> 'a -# # let rec depth : 'a 'b. 'a t -> 'b = - function Leaf x -> x | Node x -> depth x;; (* fails *) -Error: This definition has type 'a. 'a t -> 'a which is less general than +# Characters 38-78: + function Leaf x -> x | Node x -> depth x;; (* fails *) + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This definition has type 'a. 'a t -> 'a which is less general than 'b 'c. 'c t -> 'b # val r : 'a list * '_b list ref = ([], {contents = []}) val q : unit -> 'a list * '_b list ref = # val f : 'a -> 'a = # val zero : [> `B of 'a | `Int of int ] as 'a = `Int 0 -# # let zero : 'a. [< `Int of int] as 'a = `Int 0;; (* fails *) -Error: This expression has type [> `Int of int ] +# Characters 39-45: + let zero : 'a. [< `Int of int] as 'a = `Int 0;; (* fails *) + ^^^^^^ +Error: This expression has type [> `Int of int ] but an expression was expected of type [< `Int of int ] Types for tag `Int are incompatible # type t = { f : 'a. [> `B of 'a | `Int of int ] as 'a; } val zero : t = {f = `Int 0} -# # type t = {f: 'a. [< `Int of int] as 'a} - let zero = {f = `Int 0} ;; (* fails *) -Error: This expression has type [> `Int of int ] +# Characters 56-62: + let zero = {f = `Int 0} ;; (* fails *) + ^^^^^^ +Error: This expression has type [> `Int of int ] but an expression was expected of type [< `Int of int ] Types for tag `Int are incompatible # val id : 'a -> 'a = @@ -560,7 +574,9 @@ val transf_alist : (int -> t) -> ('a * t) list -> ('a * t) list = val l : t = {f = } # type t = { f : 'a. 'a -> unit; } # - : t = {f = } -# # {f=fun ?x y -> y};; (* fail *) -Error: This field value has type unit -> unit which is less general than +# Characters 3-16: + {f=fun ?x y -> y};; (* fail *) + ^^^^^^^^^^^^^ +Error: This field value has type unit -> unit which is less general than 'a. 'a -> unit # diff --git a/testsuite/tests/typing-private/private.ml.reference b/testsuite/tests/typing-private/private.ml.reference index b4e46d03..f5b85b20 100644 --- a/testsuite/tests/typing-private/private.ml.reference +++ b/testsuite/tests/typing-private/private.ml.reference @@ -1,23 +1,28 @@ # module Foobar : sig type t = private int end # module F0 : sig type t = private int end -# # - let f (x : F0.t) = (x : Foobar.t);; (* fails *) -Error: This expression has type F0.t but an expression was expected of type +# Characters 21-22: + let f (x : F0.t) = (x : Foobar.t);; (* fails *) + ^ +Error: This expression has type F0.t but an expression was expected of type Foobar.t # module F : sig type t = Foobar.t end # val f : F.t -> F.t = # module M : sig type t = < m : int > end # module M1 : sig type t = private < m : int; .. > end # module M2 : sig type t = private < m : int; .. > end -# # fun (x : M1.t) -> (x : M2.t);; (* fails *) -Error: This expression has type M1.t but an expression was expected of type +# Characters 19-20: + fun (x : M1.t) -> (x : M2.t);; (* fails *) + ^ +Error: This expression has type M1.t but an expression was expected of type M2.t # module M3 : sig type t = private M1.t end # - : M3.t -> M1.t = # - : M3.t -> M.t = -# # module M4 : sig type t = private M3.t end = M2;; (* fails *) -Error: Signature mismatch: +# Characters 44-46: + module M4 : sig type t = private M3.t end = M2;; (* fails *) + ^^ +Error: Signature mismatch: Modules do not match: sig type t = M2.t end is not included in @@ -26,8 +31,10 @@ type t = M2.t is not included in type t = private M3.t -# # module M4 : sig type t = private M3.t end = M;; (* fails *) -Error: Signature mismatch: +# Characters 44-45: + module M4 : sig type t = private M3.t end = M;; (* fails *) + ^ +Error: Signature mismatch: Modules do not match: sig type t = < m : int > end is not included in @@ -36,8 +43,10 @@ type t = < m : int > is not included in type t = private M3.t -# # module M4 : sig type t = private M3.t end = M1;; (* might be ok *) -Error: Signature mismatch: +# Characters 44-46: + module M4 : sig type t = private M3.t end = M1;; (* might be ok *) + ^^ +Error: Signature mismatch: Modules do not match: sig type t = M1.t end is not included in @@ -47,8 +56,10 @@ is not included in type t = private M3.t # module M5 : sig type t = private M1.t end -# # module M6 : sig type t = private < n:int; .. > end = M1;; (* fails *) -Error: Signature mismatch: +# Characters 53-55: + module M6 : sig type t = private < n:int; .. > end = M1;; (* fails *) + ^^ +Error: Signature mismatch: Modules do not match: sig type t = M1.t end is not included in @@ -57,10 +68,10 @@ type t = M1.t is not included in type t = private < n : int; .. > -# # - module Bar : sig type t = private Foobar.t val f : int -> t end = - struct type t = int let f (x : int) = (x : t) end;; (* must fail *) -Error: Signature mismatch: +# Characters 69-118: + struct type t = int let f (x : int) = (x : t) end;; (* must fail *) + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: Signature mismatch: Modules do not match: sig type t = int val f : t -> t end is not included in @@ -73,12 +84,10 @@ # module M1 : sig type t = M.t val mk : int -> t end # module M2 : sig type t = M.t val mk : int -> t end # module M3 : sig type t = M.t val mk : int -> t end -# # - module M4 : sig - type t = M.t = T of int - val mk : int -> t - end = M;; -Error: This variant or record definition does not match that of type M.t +# Characters 29-47: + type t = M.t = T of int + ^^^^^^^^^^^^^^^^^^ +Error: This variant or record definition does not match that of type M.t A private type would be revealed. # module M5 : sig type t = M.t = private T of int val mk : int -> t end # module M6 : sig type t = private T of int val mk : int -> t end diff --git a/typing/ctype.ml b/typing/ctype.ml index 8db0f6cf..5f05f1da 100644 --- a/typing/ctype.ml +++ b/typing/ctype.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: ctype.ml 10544 2010-06-08 14:09:30Z garrigue $ *) +(* $Id: ctype.ml 10605 2010-06-24 08:43:39Z garrigue $ *) (* Operations on core types *) @@ -126,15 +126,20 @@ let increase_global_level () = let restore_global_level gl = global_level := gl -(* Abbreviations without parameters *) +(**** Whether a path points to an object type (with hidden row variable) ****) +let is_object_type path = + let name = + match path with Path.Pident id -> Ident.name id + | Path.Pdot(_, s,_) -> s + | Path.Papply _ -> assert false + in name.[0] = '#' + +(**** Abbreviations without parameters ****) (* Shall reset after generalizing *) let simple_abbrevs = ref Mnil let proper_abbrevs path tl abbrev = - if !Clflags.principal || tl <> [] then abbrev else - let name = match path with Path.Pident id -> Ident.name id - | Path.Pdot(_, s,_) -> s - | Path.Papply _ -> assert false in - if name.[0] <> '#' then simple_abbrevs else abbrev + if !Clflags.principal || tl <> [] || is_object_type path then abbrev + else simple_abbrevs (**** Some type creators ****) @@ -2291,7 +2296,7 @@ let rec eqtype rename type_pairs subst env t1 t2 = normalize_subst subst; if List.assq t1 !subst != t2 then raise (Unify []) with Not_found -> - (*if List.exists (fun (_, t) -> t == t2) !subst then raise (Unify []);*) + if List.exists (fun (_, t) -> t == t2) !subst then raise (Unify []); subst := (t1, t2) :: !subst end | (Tconstr (p1, [], _), Tconstr (p2, [], _)) when Path.same p1 p2 -> @@ -2312,7 +2317,7 @@ let rec eqtype rename type_pairs subst env t1 t2 = normalize_subst subst; if List.assq t1' !subst != t2' then raise (Unify []) with Not_found -> - (*if List.exists (fun (_, t) -> t == t2') !subst then raise (Unify []);*) + if List.exists (fun (_, t) -> t == t2') !subst then raise (Unify []); subst := (t1', t2') :: !subst end | (Tarrow (l1, t1, u1, _), Tarrow (l2, t2, u2, _)) when l1 = l2 @@ -2487,7 +2492,7 @@ let rec moregen_clty trace type_pairs env cty1 cty2 = | _ -> raise (Failure []) with - Failure error when trace -> + Failure error when trace || error = [] -> raise (Failure (CM_Class_type_mismatch (cty1, cty2)::error)) let match_class_types ?(trace=true) env pat_sch subj_sch = @@ -3168,15 +3173,6 @@ let unalias ty = | _ -> newty2 ty.level ty.desc -let unroll_abbrev id tl ty = - let ty = repr ty in - if (ty.desc = Tvar) || (List.exists (deep_occur ty) tl) then - ty - else - let ty' = newty2 ty.level ty.desc in - link_type ty (newty2 ty.level (Tconstr (Path.Pident id, tl, ref Mnil))); - ty' - (* Return the arity (as for curried functions) of the given type. *) let rec arity ty = match (repr ty).desc with @@ -3349,6 +3345,16 @@ let nondep_type env id ty = clear_hash (); raise Not_found +let unroll_abbrev id tl ty = + let ty = repr ty and path = Path.Pident id in + if (ty.desc = Tvar) || (List.exists (deep_occur ty) tl) + || is_object_type path then + ty + else + let ty' = newty2 ty.level ty.desc in + link_type ty (newty2 ty.level (Tconstr (path, tl, ref Mnil))); + ty' + (* Preserve sharing inside type declarations. *) let nondep_type_decl env mid id is_covariant decl = try diff --git a/typing/typecore.ml b/typing/typecore.ml index 3e06110f..47908f18 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: typecore.ml 10540 2010-06-08 03:20:26Z garrigue $ *) +(* $Id: typecore.ml 10624 2010-07-12 09:36:07Z garrigue $ *) (* Typechecking for the core language *) @@ -690,8 +690,32 @@ let rec is_nonexpansive exp = Vars.fold (fun _ (mut,_,_) b -> decr count; b && mut = Immutable) vars true && !count = 0 + | Texp_pack mexp -> + is_nonexpansive_mod mexp | _ -> false +and is_nonexpansive_mod mexp = + match mexp.mod_desc with + | Tmod_ident _ -> true + | Tmod_functor _ -> true + | Tmod_unpack (e, _) -> is_nonexpansive e + | Tmod_constraint (m, _, _) -> is_nonexpansive_mod m + | Tmod_structure items -> + List.for_all + (function + | Tstr_eval _ | Tstr_primitive _ | Tstr_type _ | Tstr_modtype _ + | Tstr_open _ | Tstr_cltype _ | Tstr_exn_rebind _ -> true + | Tstr_value (_, pat_exp_list) -> + List.for_all (fun (_, exp) -> is_nonexpansive exp) pat_exp_list + | Tstr_module (_, m) | Tstr_include (m, _) -> is_nonexpansive_mod m + | Tstr_recmodule id_mod_list -> + List.for_all (fun (_, m) -> is_nonexpansive_mod m) id_mod_list + | Tstr_exception _ -> false (* true would be unsound *) + | Tstr_class _ -> false (* could be more precise *) + ) + items + | Tmod_apply _ -> false + and is_nonexpansive_opt = function None -> true | Some e -> is_nonexpansive e -- 2.30.2