+3

.depend

reviewed

··· 1195 1195 utils/misc.cmi \ 1196 1196 parsing/location.cmi \ 1197 1197 utils/local_store.cmi \ 1198 1198 + utils/lazy_backtrack.cmi \ 1198 1199 typing/ident.cmi \ 1199 1200 utils/clflags.cmi \ 1200 1201 typing/btype.cmi \ ··· 1207 1208 utils/misc.cmx \ 1208 1209 parsing/location.cmx \ 1209 1210 utils/local_store.cmx \ 1211 1211 + utils/lazy_backtrack.cmx \ 1210 1212 typing/ident.cmx \ 1211 1213 utils/clflags.cmx \ 1212 1214 typing/btype.cmx \ ··· 1215 1217 typing/subst.cmi : \ 1216 1218 typing/types.cmi \ 1217 1219 typing/path.cmi \ 1220 1220 + parsing/parsetree.cmi \ 1218 1221 parsing/location.cmi \ 1219 1222 typing/ident.cmi 1220 1223 typing/tast_iterator.cmo : \

+2

.gitattributes

reviewed

··· 101 101 otherlibs/win32unix/stat.c typo.long-line 102 102 otherlibs/win32unix/symlink.c typo.long-line 103 103 104 104 + runtime/sak.c typo.non-ascii 105 105 + 104 106 stdlib/hashbang typo.white-at-eol typo.missing-lf 105 107 106 108 testsuite/tests/** typo.missing-header typo.long-line=may

+2

.gitignore

reviewed

··· 199 199 /runtime/ld.conf 200 200 /runtime/.gdb_history 201 201 /runtime/.dep 202 202 + /runtime/build_config.h 203 203 + /runtime/sak 202 204 /runtime/domain_state32.inc 203 205 /runtime/domain_state64.inc 204 206 /runtime/GIT_HASH

+24 -9

Changes

reviewed

··· 130 130 - #10555: Do not use ghost locations for type constraints 131 131 (Nicolás Ojeda Bär, report by Anton Bachin, review by Thomas Refis) 132 132 133 133 - ### Build system: 133 133 + - #10559: Evaluate signature substitutions lazily 134 134 + (Stephen Dolan, review by Leo White) 134 135 135 135 - - #10471: Fix detection of arm32 architectures with musl in the configure 136 136 - script. 137 137 - (Louis Gesbert) 136 136 + ### Build system: 138 137 139 138 ### Bug fixes: 140 139 ··· 156 155 157 156 - #10542: Fix detection of immediate64 types through unboxed types. 158 157 (Leo White, review by Stephen Dolan and Gabriel Scherer) 158 158 + 159 159 + - #10590: Some typechecker optimisations 160 160 + (Stephen Dolan, review by Gabriel Scherer and Leo White) 159 161 160 162 OCaml 4.13.0 161 163 ------------- ··· 354 356 (Gabriel Scherer, review by Nicolás Ojeda Bär, Alain Frisch, Xavier Leroy, 355 357 Daniel Bünzli and Stephen Dolan) 356 358 357 357 - * #10169, #10270, #10301: Use capitalized module names in the Standard Library 358 358 - prefixing scheme to match Dune, e.g. Stdlib__String instead of Stdlib__string. 359 359 - This is a breaking change only to code which attempted to use the internal 360 360 - names before. The Standard Library generated by the Dune rules is now 361 361 - equivalent to the main build (the Dune rules still do not generate a 359 359 + * #10169, #10270, #10301, #10451: Use capitalized module names in the Standard 360 360 + Library prefixing scheme to match Dune, e.g. Stdlib__String instead of 361 361 + Stdlib__string. This is a breaking change only to code which attempted to use 362 362 + the internal names before. The Standard Library generated by the Dune rules is 363 363 + now equivalent to the main build (the Dune rules still do not generate a 362 364 distributable compiler). 363 365 (David Allsopp and Mark Shinwell, review by Gabriel Scherer) 364 366 ··· 650 652 which runtime to use while building the compilers (Sébastien Hinderer, 651 653 review by David Allsopp) 652 654 655 655 + - #10451: Replace the use of iconv with a C utility to convert $(LIBDIR) to a 656 656 + C string constant on Windows when building the runtime. Hardens the generation 657 657 + of the constant on Unix for paths with backslashes, double-quotes and 658 658 + newlines. 659 659 + (David Allsopp, review by Florian Angeletti and Sébastien Hinderer) 660 660 + 661 661 + - #10471: Fix detection of arm32 architectures with musl in configure. 662 662 + (Louis Gesbert, review by David Allsopp) 663 663 + 653 664 ### Bug fixes: 654 665 655 666 - #6654, #9774, #10401: make `include` and with `constraints` handle correctly ··· 776 787 - #10584, #10856: Standard Library documentation build no longer fails if 777 788 optional libraries have been disabled. 778 789 (David Allsopp, report by Yuri Victorovich review by Florian Angeletti) 790 790 + 791 791 + - #10593: Fix untyping of patterns without named existential quantifiers. This 792 792 + bug was only present in the beta version of OCaml 4.13.0. 793 793 + (Ulysse Gérard, review by Florian Angeletti) 779 794 780 795 OCaml 4.12, maintenance version 781 796 -------------------------------

+3

Makefile

reviewed

··· 773 773 774 774 # The runtime system for the bytecode compiler 775 775 776 776 + $(SAK): 777 777 + $(MAKE) -C runtime sak$(EXE) 778 778 + 776 779 .PHONY: runtime 777 780 runtime: stdlib/libcamlrun.$(A) 778 781

+12

Makefile.common

reviewed

··· 160 160 161 161 %.ml %.mli: %.mly 162 162 $(OCAMLYACC) $(OCAMLYACCFLAGS) $< 163 163 + 164 164 + SAK = $(ROOTDIR)/runtime/sak$(EXE) 165 165 + 166 166 + # stdlib/StdlibModules cannot be include'd unless $(SAK) has been built. These 167 167 + # two rules add that dependency. They have to be pattern rules since 168 168 + # Makefile.common is included before default targets. 169 169 + $(ROOTDIR)/%/sak$(EXE): 170 170 + $(MAKE) -C $(ROOTDIR)/$* sak$(EXE) 171 171 + 172 172 + ifneq "$(REQUIRES_CONFIGURATION)" "" 173 173 + $(ROOTDIR)/%/StdlibModules: $(SAK) ; 174 174 + endif

+1 -1

api_docgen/Makefile.common

reviewed

··· 15 15 ROOTDIR = .. 16 16 DOCGEN= $(ROOTDIR)/api_docgen 17 17 18 18 - -include $(ROOTDIR)/stdlib/StdlibModules 19 18 include $(ROOTDIR)/Makefile.common 19 19 + include $(ROOTDIR)/stdlib/StdlibModules 20 20 include $(ROOTDIR)/Makefile.best_binaries 21 21 include $(DOCGEN)/Makefile.docfiles 22 22

boot/ocamlc

reviewed

This is a binary file and will not be displayed.

boot/ocamllex

reviewed

This is a binary file and will not be displayed.

+3 -6

bytecomp/bytelink.ml

reviewed

··· 481 481 \n#endif\ 482 482 \n#include <caml/mlvalues.h>\ 483 483 \n#include <caml/startup.h>\ 484 484 - \n#include <caml/sys.h>\n"; 484 484 + \n#include <caml/sys.h>\ 485 485 + \n#include <caml/misc.h>\n"; 485 486 output_string outchan "static int caml_code[] = {\n"; 486 487 Symtable.init(); 487 488 clear_crc_interfaces (); ··· 512 513 (* The entry point *) 513 514 if with_main then begin 514 515 output_string outchan "\ 515 515 - \n#ifdef _WIN32\ 516 516 - \nint wmain(int argc, wchar_t **argv)\ 517 517 - \n#else\ 518 518 - \nint main(int argc, char **argv)\ 519 519 - \n#endif\ 516 516 + \nint main_os(int argc, char_os **argv)\ 520 517 \n{\ 521 518 \n caml_byte_program_mode = COMPLETE_EXE;\ 522 519 \n caml_startup_code(caml_code, sizeof(caml_code),\

-4

manual/README.md

reviewed

··· 25 25 26 26 1. Run `make` in the manual directory. 27 27 28 28 - NB: If you already set `LD_LIBRARY_PATH` (OS X: `DYLD_LIBRARY_PATH`) 29 29 - in your environment don't forget to append the absolute paths to 30 30 - `otherlibs/unix` and `otherlibs/str` to it. 31 31 - 32 28 Outputs 33 29 ------- 34 30

+9 -12

manual/src/Makefile

reviewed

··· 1 1 - SRC = $(abspath ../..) 2 2 - -include $(SRC)/Makefile.config 1 1 + ROOTDIR = ../.. 2 2 + -include $(ROOTDIR)/Makefile.build_config 3 3 4 4 - export LD_LIBRARY_PATH ?= "$(SRC)/otherlibs/unix/:$(SRC)/otherlibs/str/" 5 5 - export DYLD_LIBRARY_PATH ?= "$(SRC)/otherlibs/unix/:$(SRC)/otherlibs/str/" 6 6 - 7 7 - TEXQUOTE = $(SRC)/runtime/ocamlrun ../tools/texquote2 4 4 + TEXQUOTE = $(ROOTDIR)/runtime/ocamlrun ../tools/texquote2 8 5 9 6 FILES = allfiles.tex biblio.tex foreword.tex version.tex cmds/warnings-help.etex ifocamldoc.tex 10 7 ··· 18 15 HTML_FLAGS = -fix -exec xxdate.exe -O 19 16 TEXT_FLAGS = -fix -exec xxdate.exe -text -w 79 -s 20 17 21 21 - # Copy the documentation files from SRC/api_docgen 22 22 - APIDOC=$(SRC)/api_docgen 18 18 + # Copy the documentation files from ROOTDIR/api_docgen 19 19 + APIDOC=$(ROOTDIR)/api_docgen 23 20 .PHONY: html_files 24 21 .PHONY: latex_files 25 22 ifeq ($(DOCUMENTATION_TOOL),odoc) ··· 125 122 $(TEXQUOTE) < $< > $*.texquote_error.tex 126 123 mv $*.texquote_error.tex $@ 127 124 128 128 - version.tex: $(SRC)/VERSION 125 125 + version.tex: $(ROOTDIR)/VERSION 129 126 sed -n -e '1s/^\([0-9]*\.[0-9]*\).*$$/\\def\\ocamlversion{\1}/p' $< > $@ 130 127 131 131 - cmds/warnings-help.etex: $(SRC)/utils/warnings.ml $(SRC)/ocamlc 128 128 + cmds/warnings-help.etex: $(ROOTDIR)/utils/warnings.ml $(ROOTDIR)/ocamlc 132 129 (echo "% This file is generated from (ocamlc -warn-help)";\ 133 130 echo "% according to a rule in manual/src/Makefile.";\ 134 131 echo "% In particular, the reference to documentation sections";\ 135 132 echo "% are inserted through the Makefile, which should be updated";\ 136 133 echo "% when a new warning is documented.";\ 137 134 echo "%";\ 138 138 - $(SRC)/boot/ocamlrun $(SRC)/ocamlc -warn-help \ 135 135 + $(ROOTDIR)/boot/ocamlrun $(ROOTDIR)/ocamlc -warn-help \ 139 136 | LC_ALL=C sed -e 's/^ *\([0-9][0-9]*\) *\[\([a-z][a-z-]*\)\]\(.*\)/\\item[\1 "\2"] \3/' \ 140 137 -e 's/^ *\([0-9A-Z][0-9]*\) *\([^]].*\)/\\item[\1] \2/'\ 141 138 | sed -e 's/@/\\@/g' \ ··· 148 145 mv $@.tmp $@;\ 149 146 done 150 147 151 151 - ifocamldoc.tex: $(SRC)/Makefile.config 148 148 + ifocamldoc.tex: $(ROOTDIR)/Makefile.build_config 152 149 $(MAKE) -C $(APIDOC) build/latex/ifocamldoc.tex 153 150 cp $(APIDOC)/build/latex/ifocamldoc.tex $@ 154 151

+5 -4

manual/src/html_processing/Makefile

reviewed

··· 50 50 51 51 js: $(JS_FILES) 52 52 53 53 + CURL = curl -s 53 54 # download images for local use 54 55 SEARCH := search_icon.svg 55 56 $(WEBDIRAPI)/search_icon.svg: | $(WEBDIRAPI) 56 56 - curl "https://ocaml.org/img/search.svg" > $(WEBDIRAPI)/$(SEARCH) 57 57 + $(CURL) "https://ocaml.org/img/search.svg" > $(WEBDIRAPI)/$(SEARCH) 57 58 58 59 $(WEBDIRCOMP)/%: $(WEBDIRAPI)/% | $(WEBDIRCOMP) 59 60 cp $< $@ 60 61 61 61 - $(WEBDIRMAIN)/%: $(WEBDIRAPI/% | $(WEBDIRAPI) 62 62 + $(WEBDIRMAN)/%: $(WEBDIRAPI)/% | $(WEBDIRMAN) 62 63 cp $< $@ 63 64 64 65 LOGO := colour-logo.svg 65 66 $(WEBDIRAPI)/colour-logo.svg: | $(WEBDIRAPI) $(WEBDIRMAN) $(WEBDIRCOMP) 66 66 - curl "https://raw.githubusercontent.com/ocaml/ocaml-logo/master/Colour/SVG/colour-logo.svg" > $(WEBDIRAPI)/$(LOGO) 67 67 + $(CURL) "https://raw.githubusercontent.com/ocaml/ocaml-logo/master/Colour/SVG/colour-logo.svg" > $(WEBDIRAPI)/$(LOGO) 67 68 68 69 ICON := favicon.ico 69 70 $(WEBDIRAPI)/favicon.ico: | $(WEBDIRAPI) $(WEBDIRMAN) $(WEBDIRCOMP) 70 70 - curl "https://raw.githubusercontent.com/ocaml/ocaml-logo/master/Colour/Favicon/32x32.ico" > $(WEBDIRAPI)/$(ICON) 71 71 + $(CURL) "https://raw.githubusercontent.com/ocaml/ocaml-logo/master/Colour/Favicon/32x32.ico" > $(WEBDIRAPI)/$(ICON) 71 72 72 73 IMG_FILES0 := colour-logo.svg 73 74 IMG_FILES := $(addprefix $(WEBDIRAPI)/, $(IMG_FILES0)) $(addprefix $(WEBDIRCOMP)/, $(IMG_FILES0)) $(addprefix $(WEBDIRMAN)/, $(IMG_FILES0))

+3 -3

manual/src/library/Makefile

reviewed

··· 1 1 - SRC = ../../.. 1 1 + ROOTDIR = ../../.. 2 2 3 3 - CSLDIR = $(SRC) 3 3 + CSLDIR = $(ROOTDIR) 4 4 5 5 - TEXQUOTE = $(SRC)/runtime/ocamlrun ../../tools/texquote2 5 5 + TEXQUOTE = $(ROOTDIR)/runtime/ocamlrun ../../tools/texquote2 6 6 7 7 FILES = core.tex builtin.tex stdlib-blurb.tex compilerlibs.tex \ 8 8 libunix.tex libstr.tex old.tex libthreads.tex libdynlink.tex

+2 -2

manual/src/macros.tex

reviewed

··· 229 229 \fi 230 230 \newenvironment{linklist}{\begingroup\ocamldocinputstart}{\endgroup} 231 231 232 232 - \newcommand{\compilerdocitem}[2]{\input{#1.tex}} 233 233 - \newcommand{\libdocitem}[2]{\input{#1.tex}} 232 232 + \newcommand{\compilerdocitem}[2]{\input{library/#1.tex}} 233 233 + \newcommand{\libdocitem}[2]{\input{library/#1.tex}} 234 234 \ifocamldoc 235 235 \newcommand{\stddocitem}[2]{\libdocitem{#1}{#2}} 236 236 \else

+1

manual/src/manual.tex

reviewed

··· 157 157 \newcommand{\ocamlcodefragment}[1]{{\ttfamily\setlength{\parindent}{0cm}% 158 158 \raggedright#1}} 159 159 \newcommand{\ocamlinlinecode}[1]{{\ttfamily#1}} 160 160 + \newenvironment{ocamlarrow}{}{} 160 161 \newenvironment{ocamlexception}{\bfseries}{} 161 162 \newenvironment{ocamlextension}{\bfseries}{} 162 163 \newenvironment{ocamlconstructor}{\bfseries}{}

+1 -1

manual/tests/Makefile

reviewed

··· 1 1 ROOTDIR = ../.. 2 2 - include $(ROOTDIR)/stdlib/StdlibModules 3 2 include $(ROOTDIR)/api_docgen/Makefile.docfiles 4 3 include $(ROOTDIR)/Makefile.common 4 4 + include $(ROOTDIR)/stdlib/StdlibModules 5 5 include $(ROOTDIR)/Makefile.best_binaries 6 6 STDLIBFLAGS = -nostdlib -I $(ROOTDIR)/stdlib 7 7 OCAMLC ?= $(BEST_OCAMLC) $(STDLIBFLAGS)

-1

manual/tools/Makefile

reviewed

··· 1 1 ROOTDIR = ../.. 2 2 - COMPFLAGS = -I $(ROOTDIR)/otherlibs/str -I $(ROOTDIR)/otherlibs/unix 3 2 include $(ROOTDIR)/Makefile.common 4 3 include $(ROOTDIR)/Makefile.best_binaries 5 4

-1

ocaml-variants.opam

reviewed

··· 40 40 ] 41 41 conflict-class: "ocaml-core-compiler" 42 42 flags: compiler 43 43 - setenv: CAML_LD_LIBRARY_PATH = "%{lib}%/stublibs" 44 43 build: [ 45 44 [ 46 45 "./configure"

-2

ocamldoc/Makefile

reviewed

··· 323 323 324 324 # stdlib non-prefixed : 325 325 ####################### 326 326 - SRC=$(ROOTDIR) 327 327 - 328 326 329 327 .PHONY: autotest_stdlib 330 328 autotest_stdlib:

+16 -21

ocamldoc/Makefile.best_ocamldoc

reviewed

··· 13 13 #* * 14 14 #************************************************************************** 15 15 16 16 - OCAMLDOC=$(ROOTDIR)/ocamldoc/ocamldoc$(EXE) 17 17 - OCAMLDOC_OPT=$(ROOTDIR)/ocamldoc/ocamldoc.opt$(EXE) 16 16 + OCAMLDOC = $(ROOTDIR)/ocamldoc/ocamldoc$(EXE) 17 17 + OCAMLDOC_OPT = $(ROOTDIR)/ocamldoc/ocamldoc.opt$(EXE) 18 18 19 19 - # TODO: clarify whether the following really needs to be that complicated 20 20 - ifeq "$(UNIX_OR_WIN32)" "unix" 21 21 - ifeq "$(TARGET)" "$(HOST)" 22 22 - ifeq "$(SUPPORTS_SHARED_LIBRARIES)" "true" 23 23 - OCAMLDOC_RUN_BYTE=$(OCAMLRUN) -I $(ROOTDIR)/otherlibs/$(UNIXLIB) -I $(ROOTDIR)/otherlibs/str ./$(OCAMLDOC) 24 24 - else 25 25 - # if shared-libraries are not supported, unix.cma and str.cma 26 26 - # are compiled with -custom, so ocamldoc also uses -custom, 27 27 - # and (ocamlrun ocamldoc) does not work. 28 28 - OCAMLDOC_RUN_BYTE=./$(OCAMLDOC) 29 29 - endif 19 19 + ifeq "$(TARGET)" "$(HOST)" 20 20 + ifeq "$(SUPPORTS_SHARED_LIBRARIES)" "true" 21 21 + OCAMLDOC_RUN_BYTE = $(OCAMLRUN) -I $(ROOTDIR)/otherlibs/$(UNIXLIB) \ 22 22 + -I $(ROOTDIR)/otherlibs/str ./$(OCAMLDOC) 30 23 else 31 31 - OCAMLDOC_RUN_BYTE=$(OCAMLRUN) ./$(OCAMLDOC) 24 24 + # if shared-libraries are not supported, unix.cma and str.cma 25 25 + # are compiled with -custom, so ocamldoc also uses -custom, 26 26 + # and (ocamlrun ocamldoc) does not work. 27 27 + OCAMLDOC_RUN_BYTE = ./$(OCAMLDOC) 32 28 endif 33 33 - else # Windows 34 34 - OCAMLDOC_RUN_BYTE = \ 35 35 - CAML_LD_LIBRARY_PATH="$(ROOTDIR)/otherlibs/win32unix;$(ROOTDIR)/otherlibs/str" $(OCAMLRUN) ./$(OCAMLDOC) 29 29 + else 30 30 + OCAMLDOC_RUN_BYTE = $(OCAMLRUN) ./$(OCAMLDOC) 36 31 endif 37 32 38 38 - OCAMLDOC_RUN_OPT=./$(OCAMLDOC_OPT) 33 33 + OCAMLDOC_RUN_OPT = ./$(OCAMLDOC_OPT) 39 34 40 40 - OCAMLDOC_RUN_PLUGINS=$(OCAMLDOC_RUN_BYTE) 35 35 + OCAMLDOC_RUN_PLUGINS = $(OCAMLDOC_RUN_BYTE) 41 36 42 37 ifeq "$(wildcard $(OCAMLDOC_OPT))" "" 43 43 - OCAMLDOC_RUN=$(OCAMLDOC_RUN_BYTE) 38 38 + OCAMLDOC_RUN = $(OCAMLDOC_RUN_BYTE) 44 39 else 45 45 - OCAMLDOC_RUN=$(OCAMLDOC_RUN_OPT) 40 40 + OCAMLDOC_RUN = $(OCAMLDOC_RUN_OPT) 46 41 endif

+15 -27

runtime/Makefile

reviewed

··· 39 39 dynlink clambda_checks afl bigarray \ 40 40 memprof domain sync skiplist codefrag) 41 41 42 42 - GENERATED_HEADERS := caml/opnames.h caml/version.h caml/jumptbl.h 42 42 + GENERATED_HEADERS := caml/opnames.h caml/version.h caml/jumptbl.h build_config.h 43 43 CONFIG_HEADERS := caml/m.h caml/s.h 44 44 45 45 ifeq "$(TOOLCHAIN)" "msvc" ··· 106 106 $(ASM_OBJECTS:.$(O)=_libasmrunpic.$(O)) 107 107 108 108 # General (non target-specific) assembler and compiler flags 109 109 - 110 110 - # On Windows, OCAML_STDLIB_DIR needs to be defined dynamically 111 111 - 112 112 - ifeq "$(UNIX_OR_WIN32)" "win32" 113 113 - # OCAML_STDLIB_DIR needs to arrive in dynlink.c as a string which both gcc and 114 114 - # msvc are willing parse without warning. This means we can't pass UTF-8 115 115 - # directly since, as far as I can tell, cl can cope, but the pre-processor 116 116 - # can't. So the string needs to be directly translated to L"" form. To do this, 117 117 - # we take advantage of the fact that Cygwin uses GNU libiconv which includes a 118 118 - # Java pseudo-encoding which translates any UTF-8 sequences to \uXXXX (and, 119 119 - # unlike the C99 pseudo-encoding, emits two surrogate values when needed, rather 120 120 - # than \UXXXXXXXX). The \u is then translated to \x in order to accommodate 121 121 - # pre-Visual Studio 2013 compilers where \x is a non-standard alias for \u. 122 122 - OCAML_STDLIB_DIR = $(shell echo $(LIBDIR)| iconv -t JAVA | sed -e 's/\\u/\\x/g') 123 123 - STDLIB_CPP_FLAG = -DOCAML_STDLIB_DIR='L"$(OCAML_STDLIB_DIR)"' 124 124 - else # Unix 125 125 - OCAML_STDLIB_DIR = $(LIBDIR) 126 126 - STDLIB_CPP_FLAG = -DOCAML_STDLIB_DIR='"$(OCAML_STDLIB_DIR)"' 127 127 - endif 128 109 129 110 ifneq "$(CCOMPTYPE)" "msvc" 130 111 OC_CFLAGS += -g ··· 163 144 # Build, install and clean targets 164 145 165 146 .PHONY: all 166 166 - all: $(BYTECODE_STATIC_LIBRARIES) $(BYTECODE_SHARED_LIBRARIES) $(PROGRAMS) 147 147 + all: $(BYTECODE_STATIC_LIBRARIES) $(BYTECODE_SHARED_LIBRARIES) $(PROGRAMS) \ 148 148 + sak$(EXE) 167 149 168 150 .PHONY: allopt 169 151 ifneq "$(NATIVE_COMPILER)" "false" ··· 194 176 .PHONY: clean 195 177 clean: 196 178 rm -f *.o *.obj *.a *.lib *.so *.dll ld.conf 197 197 - rm -f ocamlrun ocamlrund ocamlruni ocamlruns 198 198 - rm -f ocamlrun.exe ocamlrund.exe ocamlruni.exe ocamlruns.exe 179 179 + rm -f ocamlrun ocamlrund ocamlruni ocamlruns sak 180 180 + rm -f ocamlrun.exe ocamlrund.exe ocamlruni.exe ocamlruns.exe sak.exe 199 181 rm -f primitives primitives.new prims.c $(GENERATED_HEADERS) 200 182 rm -f GIT_HASH GIT_HASH.new 201 183 rm -f domain_state*.inc ··· 272 254 echo "#define OCAML_RUNTIME_BUILD_GIT_BRANCH \"`(git symbolic-ref -q --short HEAD || echo "<branch unavailable>")`\"" >> $@ 273 255 echo "#define OCAML_RUNTIME_BUILD_GIT_TAG \"`(git describe --tags --exact-match || echo "<tag unavailable>")`\"" >> $@ 274 256 257 257 + sak$(EXE): sak.$(O) 258 258 + $(call MKEXE_USING_COMPILER,$@,$^) 259 259 + 260 260 + C_LITERAL = $(shell ./sak$(EXE) encode-C-literal '$(1)') 261 261 + 262 262 + build_config.h: $(ROOTDIR)/Makefile.config sak$(EXE) 263 263 + echo '/* This file is generated from $(ROOTDIR)/Makefile.config */' > $@ 264 264 + echo '#define OCAML_STDLIB_DIR $(call C_LITERAL,$(LIBDIR))' >> $@ 265 265 + echo '#define HOST "$(HOST)"' >> $@ 266 266 + 275 267 # Libraries and programs 276 268 277 269 ocamlrun$(EXE): prims.$(O) libcamlrun.$(A) ··· 375 367 376 368 $(foreach object_type, $(object_types), \ 377 369 $(eval $(call COMPILE_C_FILE,$(object_type),%))) 378 378 - 379 379 - dynlink.%.$(O): OC_CPPFLAGS += $(STDLIB_CPP_FLAG) 380 380 - 381 381 - startup_byt.%.$(O): OC_CPPFLAGS += $(STDLIB_CPP_FLAG) -DHOST='"$(HOST)"' 382 370 383 371 $(UNIX_OR_WIN32)_non_shared.%.$(O): OC_CPPFLAGS += -DBUILDING_LIBCAMLRUNS 384 372

+4

runtime/caml/misc.h

reviewed

··· 316 316 317 317 #ifdef CAML_INTERNALS 318 318 #define T(x) L ## x 319 319 + 320 320 + #define main_os wmain 319 321 #endif 320 322 321 323 #define access_os _waccess ··· 354 356 355 357 #ifdef CAML_INTERNALS 356 358 #define T(x) x 359 359 + 360 360 + #define main_os main 357 361 #endif 358 362 359 363 #define access_os access

+2

runtime/dynlink.c

reviewed

··· 36 36 #include "caml/prims.h" 37 37 #include "caml/signals.h" 38 38 39 39 + #include "build_config.h" 40 40 + 39 41 #ifndef NATIVE_CODE 40 42 41 43 /* The table of primitives */

+1 -5

runtime/main.c

reviewed

··· 27 27 #include <windows.h> 28 28 #endif 29 29 30 30 - #ifdef _WIN32 31 31 - int wmain(int argc, wchar_t **argv) 32 32 - #else 33 33 - int main(int argc, char **argv) 34 34 - #endif 30 30 + int main_os(int argc, char_os **argv) 35 31 { 36 32 #ifdef _WIN32 37 33 /* Expand wildcards and diversions in command line */

+144

runtime/sak.c

reviewed

··· 1 1 + /**************************************************************************/ 2 2 + /* */ 3 3 + /* OCaml */ 4 4 + /* */ 5 5 + /* David Allsopp, OCaml Labs, Cambridge. */ 6 6 + /* */ 7 7 + /* Copyright 2021 David Allsopp Ltd. */ 8 8 + /* */ 9 9 + /* All rights reserved. This file is distributed under the terms of */ 10 10 + /* the GNU Lesser General Public License version 2.1, with the */ 11 11 + /* special exception on linking described in the file LICENSE. */ 12 12 + /* */ 13 13 + /**************************************************************************/ 14 14 + 15 15 + /* Runtime Builder's Swiss Army Knife. This utility performs functions 16 16 + previously delegated to classic Unix utilities but which ultimately seem to 17 17 + cause more hassle for maintenance than the initial simplicity suggests. 18 18 + 19 19 + This tool is a memorial to the many hours and PRs spent chasing down strange 20 20 + locale issues, stray CR characters and fighting yet another incompatible 21 21 + implementation of sed or awk. */ 22 22 + 23 23 + /* Borrow the Unicode *_os definitions and T() macro from misc.h */ 24 24 + #define CAML_INTERNALS 25 25 + #include "caml/misc.h" 26 26 + 27 27 + #include <stdio.h> 28 28 + #include <string.h> 29 29 + #include <ctype.h> 30 30 + 31 31 + #ifdef _WIN32 32 32 + #define strncmp_os wcsncmp 33 33 + #define toupper_os towupper 34 34 + #define printf_os wprintf 35 35 + #else 36 36 + #define strncmp_os strncmp 37 37 + #define toupper_os toupper 38 38 + #define printf_os printf 39 39 + #endif 40 40 + 41 41 + /* Operations 42 42 + - encode-C-literal. Used for the OCAML_STDLIB_DIR macro in 43 43 + runtime/build_config.h to ensure the LIBDIR make variable is correctly 44 44 + represented as a C string literal. 45 45 + 46 46 + On Unix, `sak encode-C-literal /usr/local/lib` returns `"/usr/local/lib"` 47 47 + 48 48 + On Windows, `sak encode-C-literal "C:\OCaml🐫\lib"` returns 49 49 + `L"C:\\OCaml\xd83d\xdc2b\\lib"` 50 50 + - add-stdlib-prefix. Used in stdlib/StdlibModules to convert the list of 51 51 + basenames given in STDLIB_MODULE_BASENAMES to the actual file basenames 52 52 + in STDLIB_MODULES. 53 53 + 54 54 + For example, `sak add-stdlib-prefix stdlib camlinternalAtomic Sys` returns 55 55 + ` stdlib camlinternalAtomic stdlib__Sys` 56 56 + */ 57 57 + 58 58 + void usage(void) 59 59 + { 60 60 + printf( 61 61 + "OCaml Build System Swiss Army Knife\n" 62 62 + "Usage: sak command\n" 63 63 + "Commands:\n" 64 64 + " * encode-C-literal path - encodes path as a C string literal\n" 65 65 + " * add-stdlib-prefix name1 ... - prefix standard library module names\n" 66 66 + ); 67 67 + } 68 68 + 69 69 + /* Converts the supplied path (UTF-8 on Unix and UCS-2ish on Windows) to a valid 70 70 + C string literal. On Windows, this is always a wchar_t* (L"..."). */ 71 71 + void encode_C_literal(char_os *path) 72 72 + { 73 73 + char_os c; 74 74 + 75 75 + #ifdef _WIN32 76 76 + putchar('L'); 77 77 + #endif 78 78 + putchar('"'); 79 79 + 80 80 + while ((c = *path++) != 0) { 81 81 + /* Escape \, " and \n */ 82 82 + if (c == '\\') { 83 83 + printf("\\\\"); 84 84 + } else if (c == '"') { 85 85 + printf("\\\""); 86 86 + } else if (c == '\n') { 87 87 + printf("\\n"); 88 88 + #ifndef _WIN32 89 89 + /* On Unix, nothing else needs escaping */ 90 90 + } else { 91 91 + putchar(c); 92 92 + #else 93 93 + /* On Windows, allow 7-bit printable characters to be displayed literally 94 94 + and escape everything else (using the older \x notation for increased 95 95 + compatibility, rather than the newer \U. */ 96 96 + } else if (c < 0x80 && iswprint(c)) { 97 97 + putwchar(c); 98 98 + } else { 99 99 + printf("\\x%04x", c); 100 100 + #endif 101 101 + } 102 102 + } 103 103 + 104 104 + putchar('"'); 105 105 + } 106 106 + 107 107 + /* Print the given array of module names to stdout. "stdlib" and names beginning 108 108 + "camlinternal" are printed unaltered. All other names are prefixed "stdlib__" 109 109 + with the original name capitalised (i.e. "foo" prints "stdlib__Foo"). */ 110 110 + void add_stdlib_prefix(int count, char_os **names) 111 111 + { 112 112 + int i; 113 113 + char_os *name; 114 114 + 115 115 + for (i = 0; i < count; i++) { 116 116 + name = *names++; 117 117 + 118 118 + /* "stdlib" and camlinternal* do not get changed. All other names get 119 119 + capitalised and prefixed "stdlib__". */ 120 120 + if (strcmp_os(T("stdlib"), name) == 0 121 121 + || strncmp_os(T("camlinternal"), name, 12) == 0) { 122 122 + printf_os(T(" %s"), name); 123 123 + } else { 124 124 + /* name is a null-terminated string, so an empty string simply has the 125 125 + null-terminator "capitalised". */ 126 126 + *name = toupper_os(*name); 127 127 + printf_os(T(" stdlib__%s"), name); 128 128 + } 129 129 + } 130 130 + } 131 131 + 132 132 + int main_os(int argc, char_os **argv) 133 133 + { 134 134 + if (argc == 3 && !strcmp_os(argv[1], T("encode-C-literal"))) { 135 135 + encode_C_literal(argv[2]); 136 136 + } else if (argc > 1 && !strcmp_os(argv[1], T("add-stdlib-prefix"))) { 137 137 + add_stdlib_prefix(argc - 2, &argv[2]); 138 138 + } else { 139 139 + usage(); 140 140 + return 1; 141 141 + } 142 142 + 143 143 + return 0; 144 144 + }

+2

runtime/startup_byt.c

reviewed

··· 59 59 #include "caml/sys.h" 60 60 #include "caml/startup.h" 61 61 62 62 + #include "build_config.h" 63 63 + 62 64 #ifndef O_BINARY 63 65 #define O_BINARY 0 64 66 #endif

+9 -17

stdlib/StdlibModules

reviewed

··· 15 15 #* * 16 16 #************************************************************************** 17 17 18 18 - # This file must be self-contained. 18 18 + # This file should be included after Makefile.common 19 19 20 20 # This file lists all standard library modules. It is used by: 21 21 # 1. stdlib/Makefile when building stdlib.cma ··· 33 33 34 34 # Basenames of the source files for the standard library (i.e. unprefixed and 35 35 # with lowercase first letters). These must be listed in dependency order. 36 36 - STDLIB_MODULE_BASENAMES=\ 36 36 + STDLIB_MODULE_BASENAMES = \ 37 37 camlinternalFormatBasics camlinternalAtomic \ 38 38 stdlib pervasives seq option either result bool char uchar \ 39 39 sys list int bytes string unit marshal obj array float int32 int64 nativeint \ ··· 45 45 filename complex arrayLabels listLabels bytesLabels stringLabels moreLabels \ 46 46 stdLabels bigarray in_channel out_channel 47 47 48 48 - STDLIB_PREFIXED_MODULES=\ 48 48 + STDLIB_PREFIXED_MODULES = \ 49 49 $(filter-out stdlib camlinternal%, $(STDLIB_MODULE_BASENAMES)) 50 50 51 51 - define add_stdlib_prefix_first 52 52 - $(shell echo $1 | cut -c1 | tr '[:lower:]' '[:upper:]') 53 53 - endef 54 54 - 55 55 - # add stdlib__ as prefix to a module except for internal modules 56 56 - # and the stdlib module itself 57 57 - define add_stdlib_prefix 58 58 - $(or $(filter-out $(STDLIB_PREFIXED_MODULES), $1), \ 59 59 - stdlib__$(call add_stdlib_prefix_first,$1)$(shell echo $1 | cut -c2-)) 60 60 - endef 61 61 - 62 62 - STDLIB_MODULES:=\ 63 63 - $(foreach module, $(STDLIB_MODULE_BASENAMES), \ 64 64 - $(call add_stdlib_prefix,$(module))) 51 51 + # The pattern FOO = $(eval FOO := $$(shell <cmd>)$(FOO) ensures that <cmd> is 52 52 + # executed either once or not at all, giving us GNU make's equivalent of a 53 53 + # string lazy_t. 54 54 + STDLIB_MODULES = \ 55 55 + $(eval STDLIB_MODULES := $$(shell \ 56 56 + $(SAK) add-stdlib-prefix $(STDLIB_MODULE_BASENAMES)))$(STDLIB_MODULES)

+17

testsuite/tests/compiler-libs/test_untypeast.ml

reviewed

··· 1 1 + (* TEST 2 2 + flags = "-I ${ocamlsrcdir}/typing \ 3 3 + -I ${ocamlsrcdir}/parsing" 4 4 + include ocamlcommon 5 5 + * expect 6 6 + *) 7 7 + 8 8 + let res = 9 9 + let s = {| match None with Some (Some _) -> () | _ -> () |} in 10 10 + let pe = Parse.expression (Lexing.from_string s) in 11 11 + let te = Typecore.type_expression (Env.initial_safe_string) pe in 12 12 + let ute = Untypeast.untype_expression te in 13 13 + Format.asprintf "%a" Pprintast.expression ute 14 14 + 15 15 + [%%expect{| 16 16 + val res : string = "match None with | Some (Some _) -> () | _ -> ()" 17 17 + |}]

+3 -5

testsuite/tests/embedded/cmmain.c

reviewed

··· 15 15 16 16 #include <stdlib.h> 17 17 #include <stdio.h> 18 18 + #define CAML_INTERNALS 19 19 + #include <caml/misc.h> 18 20 #include <caml/callback.h> 19 21 20 22 extern int fib(int n); 21 23 extern char * format_result(int n); 22 24 23 23 - #ifdef _WIN32 24 24 - int wmain(int argc, wchar_t ** argv) 25 25 - #else 26 26 - int main(int argc, char ** argv) 27 27 - #endif 25 25 + int main_os(int argc, char_os ** argv) 28 26 { 29 27 printf("Initializing OCaml code...\n"); 30 28

+4 -6

testsuite/tests/output-complete-obj/test.ml_stub.c

reviewed

··· 1 1 + #define CAML_INTERNALS 1 2 #include <caml/mlvalues.h> 2 3 #include <caml/alloc.h> 3 4 #include <caml/callback.h> 4 5 #include <caml/memory.h> 5 5 - 6 6 - #ifdef _WIN32 7 7 - int wmain(int argc, wchar_t ** argv){ 8 8 - #else 9 9 - int main(int argc, char ** argv){ 10 10 - #endif 6 6 + #include <caml/misc.h> 11 7 8 8 + int main_os(int argc, char_os **argv) 9 9 + { 12 10 caml_startup(argv); 13 11 return 0; 14 12 }

+9 -9

testsuite/tests/shadow_include/shadow_all.ml

reviewed

··· 304 304 val unit : unit 305 305 external e : unit -> unit = "%identity" 306 306 module M = N.M 307 307 - module type T = sig end 307 307 + module type T = N.T 308 308 exception E 309 309 type ext = N.ext = .. 310 310 type ext += C ··· 329 329 val unit : unit 330 330 external e : unit -> unit = "%identity" 331 331 module M = N.M 332 332 - module type T = sig end 332 332 + module type T = N.T 333 333 exception E 334 334 type ext = N.ext = .. 335 335 type ext += C ··· 352 352 val unit : unit 353 353 external e : unit -> unit = "%identity" 354 354 module M = N.M 355 355 - module type T = sig end 355 355 + module type T = N.T 356 356 exception E 357 357 type ext = N.ext = .. 358 358 type ext += C ··· 370 370 [%%expect{| 371 371 module Module_type : 372 372 sig 373 373 - module type U = sig end 373 373 + module type U = N.T 374 374 type t = N.t 375 375 val unit : unit 376 376 external e : unit -> unit = "%identity" 377 377 module M = N.M 378 378 - module type T = sig end 378 378 + module type T = N.T 379 379 exception E 380 380 type ext = N.ext = .. 381 381 type ext += C ··· 398 398 val unit : unit 399 399 external e : unit -> unit = "%identity" 400 400 module M = N.M 401 401 - module type T = sig end 401 401 + module type T = N.T 402 402 exception E 403 403 type ext = N.ext = .. 404 404 type ext += C ··· 421 421 val unit : unit 422 422 external e : unit -> unit = "%identity" 423 423 module M = N.M 424 424 - module type T = sig end 424 424 + module type T = N.T 425 425 exception E 426 426 type ext = N.ext = .. 427 427 type ext += C ··· 444 444 val unit : unit 445 445 external e : unit -> unit = "%identity" 446 446 module M = N.M 447 447 - module type T = sig end 447 447 + module type T = N.T 448 448 exception E 449 449 type ext = N.ext = .. 450 450 type ext += C ··· 467 467 val unit : unit 468 468 external e : unit -> unit = "%identity" 469 469 module M = N.M 470 470 - module type T = sig end 470 470 + module type T = N.T 471 471 exception E 472 472 type ext = N.ext = .. 473 473 type ext += C

+5 -19

testsuite/tests/typing-modules/functors.ml

reviewed

··· 1310 1310 module type t = arg -> sig type arg = A.arg end 1311 1311 end 1312 1312 module Add_one : 1313 1313 - sig 1314 1314 - type witness 1315 1315 - module M = Add_one'.M 1316 1316 - module type t = arg -> sig type arg = A.arg end 1317 1317 - end 1313 1313 + sig type witness module M = Add_one'.M module type t = Add_one'.t end 1318 1314 module Add_three' : 1319 1315 sig 1320 1316 module M : arg -> arg -> arg -> sig type arg = A.arg end 1321 1317 module type t = arg -> arg -> arg -> sig type arg = A.arg end 1322 1318 end 1323 1319 module Add_three : 1324 1324 - sig 1325 1325 - module M = Add_three'.M 1326 1326 - module type t = arg -> arg -> arg -> sig type arg = A.arg end 1327 1327 - type witness 1328 1328 - end 1320 1320 + sig module M = Add_three'.M module type t = Add_three'.t type witness end 1329 1321 Line 22, characters 21-43: 1330 1322 22 | module Wrong_intro = F(Add_three')(A)(A)(A) 1331 1323 ^^^^^^^^^^^^^^^^^^^^^^ ··· 1336 1328 functor (X : $T1) arg arg arg -> ... 1337 1329 1. Modules do not match: 1338 1330 Add_three' : 1339 1339 - sig 1340 1340 - module M = Add_three'.M 1341 1341 - module type t = arg -> arg -> arg -> sig type arg = A.arg end 1342 1342 - end 1331 1331 + sig module M = Add_three'.M module type t = Add_three'.t end 1343 1332 is not included in 1344 1333 $T1 = sig type witness module type t module M : t end 1345 1334 The type `witness' is required but not provided ··· 1360 1349 functor (X : ...) arg arg arg -> ... 1361 1350 1. The following extra argument is provided 1362 1351 Add_one' : 1363 1363 - sig 1364 1364 - module M = Add_one'.M 1365 1365 - module type t = arg -> sig type arg = A.arg end 1366 1366 - end 1352 1352 + sig module M = Add_one'.M module type t = Add_one'.t end 1367 1353 2. Module Add_three matches the expected module type 1368 1354 3. Module A matches the expected module type arg 1369 1355 4. Module A matches the expected module type arg ··· 1388 1374 sig 1389 1375 type witness = Add_one.witness 1390 1376 module M = Add_one'.M 1391 1391 - module type t = arg -> sig type arg = A.arg end 1377 1377 + module type t = Add_one.t 1392 1378 end 1393 1379 2. Module Add_three matches the expected module type 1394 1380 3. Module A matches the expected module type arg

+158 -96

typing/env.ml

reviewed

··· 500 500 flags: int; 501 501 } 502 502 503 503 - and module_declaration_lazy = 504 504 - (Subst.t * Subst.scoping * module_declaration, module_declaration) 505 505 - Lazy_backtrack.t 506 506 - 507 503 and module_components = 508 504 { 509 505 alerts: alerts; ··· 520 516 cm_prefixing_subst: Subst.t; 521 517 cm_path: Path.t; 522 518 cm_addr: address_lazy; 523 523 - cm_mty: Types.module_type; 519 519 + cm_mty: Subst.Lazy.modtype; 524 520 } 525 521 526 522 and module_components_repr = ··· 575 571 tda_descriptions : type_descriptions; } 576 572 577 573 and module_data = 578 578 - { mda_declaration : module_declaration_lazy; 574 574 + { mda_declaration : Subst.Lazy.module_decl; 579 575 mda_components : module_components; 580 576 mda_address : address_lazy; } 581 577 ··· 584 580 | Mod_persistent 585 581 | Mod_unbound of module_unbound_reason 586 582 587 587 - and modtype_data = modtype_declaration 583 583 + and modtype_data = Subst.Lazy.modtype_declaration 588 584 589 585 and class_data = 590 586 { clda_declaration : class_declaration; ··· 671 667 | `Class None | `Class_type None | `Component None -> 672 668 None 673 669 674 674 - let subst_modtype_maker (subst, scoping, md) = 675 675 - {md with md_type = Subst.modtype scoping subst md.md_type} 676 676 - 677 670 let empty = { 678 671 values = IdTbl.empty; constrs = TycompTbl.empty; 679 672 labels = TycompTbl.empty; types = IdTbl.empty; ··· 747 740 let strengthen = 748 741 (* to be filled with Mtype.strengthen *) 749 742 ref ((fun ~aliasable:_ _env _mty _path -> assert false) : 750 750 - aliasable:bool -> t -> module_type -> Path.t -> module_type) 743 743 + aliasable:bool -> t -> Subst.Lazy.modtype -> 744 744 + Path.t -> Subst.Lazy.modtype) 751 745 752 746 let md md_type = 753 747 {md_type; md_attributes=[]; md_loc=Location.none ··· 865 859 in 866 860 let mda_address = Lazy_backtrack.create_forced (Aident id) in 867 861 let mda_declaration = 868 868 - Lazy_backtrack.create (Subst.identity, Subst.Make_local, md) 862 862 + Subst.(Lazy.module_decl Make_local identity (Lazy.of_module_decl md)) 869 863 in 870 864 let mda_components = 871 865 let freshening_subst = ··· 873 867 in 874 868 components_of_module ~alerts ~uid:md.md_uid 875 869 empty freshening_subst Subst.identity 876 876 - path mda_address (Mty_signature sign) 870 870 + path mda_address (Subst.Lazy.of_modtype (Mty_signature sign)) 877 871 in 878 872 { 879 873 mda_declaration; ··· 1013 1007 match path with 1014 1008 | Pident id -> 1015 1009 let data = find_ident_module id env in 1016 1016 - Lazy_backtrack.force subst_modtype_maker data.mda_declaration 1010 1010 + Subst.Lazy.force_module_decl data.mda_declaration 1017 1011 | Pdot(p, s) -> 1018 1012 let sc = find_structure_components p env in 1019 1013 let data = NameMap.find s sc.comp_modules in 1020 1020 - Lazy_backtrack.force subst_modtype_maker data.mda_declaration 1014 1014 + Subst.Lazy.force_module_decl data.mda_declaration 1021 1015 | Papply(p1, p2) -> 1022 1016 let fc = find_functor_components p1 env in 1023 1017 if alias then md (fc.fcomp_res) 1024 1018 else md (modtype_of_functor_appl fc p1 p2) 1025 1019 1020 1020 + let find_module_lazy ~alias path env = 1021 1021 + match path with 1022 1022 + | Pident id -> 1023 1023 + let data = find_ident_module id env in 1024 1024 + data.mda_declaration 1025 1025 + | Pdot(p, s) -> 1026 1026 + let sc = find_structure_components p env in 1027 1027 + let data = NameMap.find s sc.comp_modules in 1028 1028 + data.mda_declaration 1029 1029 + | Papply(p1, p2) -> 1030 1030 + let fc = find_functor_components p1 env in 1031 1031 + let md = 1032 1032 + if alias then md (fc.fcomp_res) 1033 1033 + else md (modtype_of_functor_appl fc p1 p2) 1034 1034 + in 1035 1035 + Subst.Lazy.of_module_decl md 1036 1036 + 1037 1037 + let find_strengthened_module ~aliasable path env = 1038 1038 + let md = find_module_lazy ~alias:true path env in 1039 1039 + let mty = !strengthen ~aliasable env md.mdl_type path in 1040 1040 + Subst.Lazy.force_modtype mty 1041 1041 + 1026 1042 let find_value_full path env = 1027 1043 match path with 1028 1044 | Pident id -> begin ··· 1043 1059 NameMap.find s sc.comp_types 1044 1060 | Papply _ -> raise Not_found 1045 1061 1046 1046 - let find_modtype path env = 1062 1062 + let find_modtype_lazy path env = 1047 1063 match path with 1048 1064 | Pident id -> IdTbl.find_same id env.modtypes 1049 1065 | Pdot(p, s) -> 1050 1066 let sc = find_structure_components p env in 1051 1067 NameMap.find s sc.comp_modtypes 1052 1068 | Papply _ -> raise Not_found 1069 1069 + 1070 1070 + let find_modtype path env = 1071 1071 + Subst.Lazy.force_modtype_decl (find_modtype_lazy path env) 1053 1072 1054 1073 let find_class_full path env = 1055 1074 match path with ··· 1226 1245 expand_module_path lax env path 1227 1246 1228 1247 and expand_module_path lax env path = 1229 1229 - try match find_module ~alias:true path env with 1230 1230 - {md_type=Mty_alias path1} -> 1248 1248 + try match find_module_lazy ~alias:true path env with 1249 1249 + {mdl_type=MtyL_alias path1} -> 1231 1250 let path' = normalize_module_path lax env path1 in 1232 1251 if lax || !Clflags.transparent_modules then path' else 1233 1252 let id = Path.head path in ··· 1283 1302 expand_modtype_path env path 1284 1303 1285 1304 and expand_modtype_path env path = 1286 1286 - match (find_modtype path env).mtd_type with 1287 1287 - | Some (Mty_ident path) -> normalize_modtype_path env path 1305 1305 + match (find_modtype_lazy path env).mtdl_type with 1306 1306 + | Some (MtyL_ident path) -> normalize_modtype_path env path 1288 1307 | _ | exception Not_found -> path 1289 1308 1290 1309 let find_module path env = 1291 1310 find_module ~alias:false path env 1311 1311 + 1312 1312 + let find_module_lazy path env = 1313 1313 + find_module_lazy ~alias:false path env 1292 1314 1293 1315 (* Find the manifest type associated to a type when appropriate: 1294 1316 - the type should be public or should have a private row, ··· 1319 1341 (decl.type_params, body, decl.type_expansion_scope) 1320 1342 | _ -> raise Not_found 1321 1343 1322 1322 - let find_modtype_expansion path env = 1323 1323 - match (find_modtype path env).mtd_type with 1344 1344 + let find_modtype_expansion_lazy path env = 1345 1345 + match (find_modtype_lazy path env).mtdl_type with 1324 1346 | None -> raise Not_found 1325 1347 | Some mty -> mty 1348 1348 + 1349 1349 + let find_modtype_expansion path env = 1350 1350 + Subst.Lazy.force_modtype (find_modtype_expansion_lazy path env) 1326 1351 1327 1352 let rec is_functor_arg path env = 1328 1353 match path with ··· 1374 1399 let iter_env_cont = ref [] 1375 1400 1376 1401 let rec scrape_alias_for_visit env (sub : Subst.t option) mty = 1402 1402 + let open Subst.Lazy in 1377 1403 match mty with 1378 1378 - | Mty_alias path -> 1404 1404 + | MtyL_alias path -> 1379 1405 begin match may_subst Subst.module_path sub path with 1380 1406 | Pident id 1381 1407 when Ident.persistent id 1382 1408 && not (Persistent_env.looked_up !persistent_env (Ident.name id)) -> 1383 1409 false 1384 1410 | path -> (* PR#6600: find_module may raise Not_found *) 1385 1385 - try scrape_alias_for_visit env sub (find_module path env).md_type 1411 1411 + try 1412 1412 + scrape_alias_for_visit env sub (find_module_lazy path env).mdl_type 1386 1413 with Not_found -> false 1387 1414 end 1388 1415 | _ -> true ··· 1490 1517 (* Expand manifest module type names at the top of the given module type *) 1491 1518 1492 1519 let rec scrape_alias env sub ?path mty = 1520 1520 + let open Subst.Lazy in 1493 1521 match mty, path with 1494 1494 - Mty_ident _, _ -> 1522 1522 + MtyL_ident _, _ -> 1495 1523 let p = 1496 1496 - match may_subst (Subst.modtype Keep) sub mty with 1497 1497 - | Mty_ident p -> p 1524 1524 + match may_subst (Subst.Lazy.modtype Keep) sub mty with 1525 1525 + | MtyL_ident p -> p 1498 1526 | _ -> assert false (* only [Mty_ident]s in [sub] *) 1499 1527 in 1500 1528 begin try 1501 1501 - scrape_alias env sub (find_modtype_expansion p env) ?path 1529 1529 + scrape_alias env sub (find_modtype_expansion_lazy p env) ?path 1502 1530 with Not_found -> 1503 1531 mty 1504 1532 end 1505 1505 - | Mty_alias path, _ -> 1533 1533 + | MtyL_alias path, _ -> 1506 1534 let path = may_subst Subst.module_path sub path in 1507 1535 begin try 1508 1508 - scrape_alias env sub (find_module path env).md_type ~path 1536 1536 + scrape_alias env sub ((find_module_lazy path env).mdl_type) ~path 1509 1537 with Not_found -> 1510 1538 (*Location.prerr_warning Location.none 1511 1539 (Warnings.No_cmi_file (Path.name path));*) ··· 1525 1553 let id' = Ident.rename id in 1526 1554 id', Some (add_fn id (Pident id') sub) 1527 1555 in 1556 1556 + let open Subst.Lazy in 1528 1557 let rec prefix_idents root items_and_paths freshening_sub prefixing_sub = 1529 1558 function 1530 1559 | [] -> (List.rev items_and_paths, freshening_sub, prefixing_sub) 1531 1531 - | Sig_value(id, _, _) as item :: rem -> 1560 1560 + | SigL_value(id, _, _) as item :: rem -> 1532 1561 let p = Pdot(root, Ident.name id) in 1533 1562 prefix_idents root 1534 1563 ((item, p) :: items_and_paths) freshening_sub prefixing_sub rem 1535 1535 - | Sig_type(id, td, rs, vis) :: rem -> 1564 1564 + | SigL_type(id, td, rs, vis) :: rem -> 1536 1565 let p = Pdot(root, Ident.name id) in 1537 1566 let id', freshening_sub = refresh id Subst.add_type freshening_sub in 1538 1567 prefix_idents root 1539 1539 - ((Sig_type(id', td, rs, vis), p) :: items_and_paths) 1568 1568 + ((SigL_type(id', td, rs, vis), p) :: items_and_paths) 1540 1569 freshening_sub 1541 1570 (Subst.add_type id' p prefixing_sub) 1542 1571 rem 1543 1543 - | Sig_typext(id, ec, es, vis) :: rem -> 1572 1572 + | SigL_typext(id, ec, es, vis) :: rem -> 1544 1573 let p = Pdot(root, Ident.name id) in 1545 1574 let id', freshening_sub = refresh id Subst.add_type freshening_sub in 1546 1575 (* we extend the substitution in case of an inlined record *) 1547 1576 prefix_idents root 1548 1548 - ((Sig_typext(id', ec, es, vis), p) :: items_and_paths) 1577 1577 + ((SigL_typext(id', ec, es, vis), p) :: items_and_paths) 1549 1578 freshening_sub 1550 1579 (Subst.add_type id' p prefixing_sub) 1551 1580 rem 1552 1552 - | Sig_module(id, pres, md, rs, vis) :: rem -> 1581 1581 + | SigL_module(id, pres, md, rs, vis) :: rem -> 1553 1582 let p = Pdot(root, Ident.name id) in 1554 1583 let id', freshening_sub = refresh id Subst.add_module freshening_sub in 1555 1584 prefix_idents root 1556 1556 - ((Sig_module(id', pres, md, rs, vis), p) :: items_and_paths) 1585 1585 + ((SigL_module(id', pres, md, rs, vis), p) :: items_and_paths) 1557 1586 freshening_sub 1558 1587 (Subst.add_module id' p prefixing_sub) 1559 1588 rem 1560 1560 - | Sig_modtype(id, mtd, vis) :: rem -> 1589 1589 + | SigL_modtype(id, mtd, vis) :: rem -> 1561 1590 let p = Pdot(root, Ident.name id) in 1562 1591 let id', freshening_sub = 1563 1592 refresh id (fun i p s -> Subst.add_modtype i (Mty_ident p) s) 1564 1593 freshening_sub 1565 1594 in 1566 1595 prefix_idents root 1567 1567 - ((Sig_modtype(id', mtd, vis), p) :: items_and_paths) 1596 1596 + ((SigL_modtype(id', mtd, vis), p) :: items_and_paths) 1568 1597 freshening_sub 1569 1598 (Subst.add_modtype id' (Mty_ident p) prefixing_sub) 1570 1599 rem 1571 1571 - | Sig_class(id, cd, rs, vis) :: rem -> 1600 1600 + | SigL_class(id, cd, rs, vis) :: rem -> 1572 1601 (* pretend this is a type, cf. PR#6650 *) 1573 1602 let p = Pdot(root, Ident.name id) in 1574 1603 let id', freshening_sub = refresh id Subst.add_type freshening_sub in 1575 1604 prefix_idents root 1576 1576 - ((Sig_class(id', cd, rs, vis), p) :: items_and_paths) 1605 1605 + ((SigL_class(id', cd, rs, vis), p) :: items_and_paths) 1577 1606 freshening_sub 1578 1607 (Subst.add_type id' p prefixing_sub) 1579 1608 rem 1580 1580 - | Sig_class_type(id, ctd, rs, vis) :: rem -> 1609 1609 + | SigL_class_type(id, ctd, rs, vis) :: rem -> 1581 1610 let p = Pdot(root, Ident.name id) in 1582 1611 let id', freshening_sub = refresh id Subst.add_type freshening_sub in 1583 1612 prefix_idents root 1584 1584 - ((Sig_class_type(id', ctd, rs, vis), p) :: items_and_paths) 1613 1613 + ((SigL_class_type(id', ctd, rs, vis), p) :: items_and_paths) 1585 1614 freshening_sub 1586 1615 (Subst.add_type id' p prefixing_sub) 1587 1616 rem 1588 1617 in 1618 1618 + let sg = Subst.Lazy.force_signature_once sg in 1589 1619 prefix_idents root [] freshening_sub prefixing_sub sg 1590 1620 1591 1621 (* Compute structure descriptions *) ··· 1608 1638 let module_declaration_address env id presence md = 1609 1639 match presence with 1610 1640 | Mp_absent -> begin 1611 1611 - match md.md_type with 1612 1612 - | Mty_alias path -> Lazy_backtrack.create (ModAlias {env; path}) 1641 1641 + let open Subst.Lazy in 1642 1642 + match md.mdl_type with 1643 1643 + | MtyL_alias path -> Lazy_backtrack.create (ModAlias {env; path}) 1613 1644 | _ -> assert false 1614 1645 end 1615 1646 | Mp_present -> ··· 1629 1660 {cm_env; cm_freshening_subst; cm_prefixing_subst; 1630 1661 cm_path; cm_addr; cm_mty} : _ result = 1631 1662 match scrape_alias cm_env cm_freshening_subst cm_mty with 1632 1632 - Mty_signature sg -> 1663 1663 + MtyL_signature sg -> 1633 1664 let c = 1634 1665 { comp_values = NameMap.empty; 1635 1666 comp_constrs = NameMap.empty; ··· 1650 1681 Lazy_backtrack.create addr 1651 1682 in 1652 1683 let sub = may_subst Subst.compose freshening_sub prefixing_sub in 1653 1653 - List.iter (fun (item, path) -> 1684 1684 + List.iter (fun ((item : Subst.Lazy.signature_item), path) -> 1654 1685 match item with 1655 1655 - Sig_value(id, decl, _) -> 1686 1686 + SigL_value(id, decl, _) -> 1656 1687 let decl' = Subst.value_description sub decl in 1657 1688 let addr = 1658 1689 match decl.val_kind with ··· 1661 1692 in 1662 1693 let vda = { vda_description = decl'; vda_address = addr } in 1663 1694 c.comp_values <- NameMap.add (Ident.name id) vda c.comp_values; 1664 1664 - | Sig_type(id, decl, _, _) -> 1695 1695 + | SigL_type(id, decl, _, _) -> 1665 1696 let fresh_decl = 1666 1697 may_subst Subst.type_declaration freshening_sub decl 1667 1698 in ··· 1704 1735 in 1705 1736 c.comp_types <- NameMap.add (Ident.name id) tda c.comp_types; 1706 1737 env := store_type_infos id fresh_decl !env 1707 1707 - | Sig_typext(id, ext, _, _) -> 1738 1738 + | SigL_typext(id, ext, _, _) -> 1708 1739 let ext' = Subst.extension_constructor sub ext in 1709 1740 let descr = 1710 1741 Datarepr.extension_descr ~current_unit:(get_unit_name ()) path ··· 1713 1744 let addr = next_address () in 1714 1745 let cda = { cda_description = descr; cda_address = Some addr } in 1715 1746 c.comp_constrs <- add_to_tbl (Ident.name id) cda c.comp_constrs 1716 1716 - | Sig_module(id, pres, md, _, _) -> 1747 1747 + | SigL_module(id, pres, md, _, _) -> 1717 1748 let md' = 1718 1749 (* The prefixed items get the same scope as [cm_path], which is 1719 1750 the prefix. *) 1720 1720 - Lazy_backtrack.create 1721 1721 - (sub, Subst.Rescope (Path.scope cm_path), md) 1751 1751 + Subst.Lazy.module_decl 1752 1752 + (Subst.Rescope (Path.scope cm_path)) sub md 1722 1753 in 1723 1754 let addr = 1724 1755 match pres with 1725 1756 | Mp_absent -> begin 1726 1726 - match md.md_type with 1727 1727 - | Mty_alias p -> 1757 1757 + match md.mdl_type with 1758 1758 + | MtyL_alias p -> 1728 1759 let path = may_subst Subst.module_path freshening_sub p in 1729 1760 Lazy_backtrack.create (ModAlias {env = !env; path}) 1730 1761 | _ -> assert false ··· 1732 1763 | Mp_present -> next_address () 1733 1764 in 1734 1765 let alerts = 1735 1735 - Builtin_attributes.alerts_of_attrs md.md_attributes 1766 1766 + Builtin_attributes.alerts_of_attrs md.mdl_attributes 1736 1767 in 1737 1768 let comps = 1738 1738 - components_of_module ~alerts ~uid:md.md_uid !env freshening_sub 1739 1739 - prefixing_sub path addr md.md_type 1769 1769 + components_of_module ~alerts ~uid:md.mdl_uid !env freshening_sub 1770 1770 + prefixing_sub path addr md.mdl_type 1740 1771 in 1741 1772 let mda = 1742 1773 { mda_declaration = md'; ··· 1746 1777 c.comp_modules <- 1747 1778 NameMap.add (Ident.name id) mda c.comp_modules; 1748 1779 env := 1749 1749 - store_module ~freshening_sub ~check:None id addr pres md !env 1750 1750 - | Sig_modtype(id, decl, _) -> 1780 1780 + store_module ~update_summary:false ~freshening_sub ~check:None 1781 1781 + id addr pres md !env 1782 1782 + | SigL_modtype(id, decl, _) -> 1751 1783 let fresh_decl = 1752 1784 (* the fresh_decl is only going in the local temporary env, and 1753 1785 shouldn't be used for anything. So we make the items local. *) 1754 1754 - may_subst (Subst.modtype_declaration Make_local) freshening_sub 1786 1786 + may_subst (Subst.Lazy.modtype_decl Make_local) freshening_sub 1755 1787 decl 1756 1788 in 1757 1789 let final_decl = 1758 1790 (* The prefixed items get the same scope as [cm_path], which is 1759 1791 the prefix. *) 1760 1760 - Subst.modtype_declaration (Rescope (Path.scope cm_path)) 1792 1792 + Subst.Lazy.modtype_decl (Rescope (Path.scope cm_path)) 1761 1793 prefixing_sub fresh_decl 1762 1794 in 1763 1795 c.comp_modtypes <- 1764 1796 NameMap.add (Ident.name id) final_decl c.comp_modtypes; 1765 1765 - env := store_modtype id fresh_decl !env 1766 1766 - | Sig_class(id, decl, _, _) -> 1797 1797 + env := store_modtype ~update_summary:false id fresh_decl !env 1798 1798 + | SigL_class(id, decl, _, _) -> 1767 1799 let decl' = Subst.class_declaration sub decl in 1768 1800 let addr = next_address () in 1769 1801 let clda = { clda_declaration = decl'; clda_address = addr } in 1770 1802 c.comp_classes <- NameMap.add (Ident.name id) clda c.comp_classes 1771 1771 - | Sig_class_type(id, decl, _, _) -> 1803 1803 + | SigL_class_type(id, decl, _, _) -> 1772 1804 let decl' = Subst.cltype_declaration sub decl in 1773 1805 c.comp_cltypes <- 1774 1806 NameMap.add (Ident.name id) decl' c.comp_cltypes) 1775 1807 items_and_paths; 1776 1808 Ok (Structure_comps c) 1777 1777 - | Mty_functor(arg, ty_res) -> 1809 1809 + | MtyL_functor(arg, ty_res) -> 1778 1810 let sub = 1779 1811 may_subst Subst.compose cm_freshening_subst cm_prefixing_subst 1780 1812 in 1781 1813 let scoping = Subst.Rescope (Path.scope cm_path) in 1814 1814 + let open Subst.Lazy in 1782 1815 Ok (Functor_comps { 1783 1816 (* fcomp_arg and fcomp_res must be prefixed eagerly, because 1784 1817 they are interpreted in the outer environment *) ··· 1786 1819 (match arg with 1787 1820 | Unit -> Unit 1788 1821 | Named (param, ty_arg) -> 1789 1789 - Named (param, Subst.modtype scoping sub ty_arg)); 1790 1790 - fcomp_res = Subst.modtype scoping sub ty_res; 1822 1822 + Named (param, force_modtype (modtype scoping sub ty_arg))); 1823 1823 + fcomp_res = force_modtype (modtype scoping sub ty_res); 1791 1824 fcomp_cache = Hashtbl.create 17; 1792 1825 fcomp_subst_cache = Hashtbl.create 17 }) 1793 1793 - | Mty_ident _ -> Error No_components_abstract 1794 1794 - | Mty_alias p -> Error (No_components_alias p) 1826 1826 + | MtyL_ident _ -> Error No_components_abstract 1827 1827 + | MtyL_alias p -> Error (No_components_alias p) 1795 1828 1796 1829 (* Insertion of bindings by identifier + path *) 1797 1830 ··· 1965 1998 constrs = TycompTbl.add id cda env.constrs; 1966 1999 summary = Env_extension(env.summary, id, ext) } 1967 2000 1968 1968 - and store_module ~check ~freshening_sub id addr presence md env = 1969 1969 - let loc = md.md_loc in 2001 2001 + and store_module ?(update_summary=true) ~check ~freshening_sub 2002 2002 + id addr presence md env = 2003 2003 + let open Subst.Lazy in 2004 2004 + let loc = md.mdl_loc in 1970 2005 Option.iter 1971 1971 - (fun f -> check_usage loc id md.md_uid f !module_declarations) check; 1972 1972 - let alerts = Builtin_attributes.alerts_of_attrs md.md_attributes in 2006 2006 + (fun f -> check_usage loc id md.mdl_uid f !module_declarations) check; 2007 2007 + let alerts = Builtin_attributes.alerts_of_attrs md.mdl_attributes in 1973 2008 let module_decl_lazy = 1974 2009 match freshening_sub with 1975 1975 - | None -> Lazy_backtrack.create_forced md 1976 1976 - | Some s -> Lazy_backtrack.create (s, Subst.Rescope (Ident.scope id), md) 2010 2010 + | None -> md 2011 2011 + | Some s -> module_decl (Rescope (Ident.scope id)) s md 1977 2012 in 1978 2013 let comps = 1979 1979 - components_of_module ~alerts ~uid:md.md_uid 1980 1980 - env freshening_sub Subst.identity (Pident id) addr md.md_type 2014 2014 + components_of_module ~alerts ~uid:md.mdl_uid 2015 2015 + env freshening_sub Subst.identity (Pident id) addr md.mdl_type 1981 2016 in 1982 2017 let mda = 1983 2018 { mda_declaration = module_decl_lazy; 1984 2019 mda_components = comps; 1985 2020 mda_address = addr } 1986 2021 in 2022 2022 + let summary = 2023 2023 + if not update_summary then env.summary 2024 2024 + else Env_module (env.summary, id, presence, force_module_decl md) in 1987 2025 { env with 1988 2026 modules = IdTbl.add id (Mod_local mda) env.modules; 1989 1989 - summary = Env_module(env.summary, id, presence, md) } 2027 2027 + summary } 1990 2028 1991 1991 - and store_modtype id info env = 2029 2029 + and store_modtype ?(update_summary=true) id info env = 2030 2030 + let summary = 2031 2031 + if not update_summary then env.summary 2032 2032 + else Env_modtype (env.summary, id, Subst.Lazy.force_modtype_decl info) in 1992 2033 { env with 1993 2034 modtypes = IdTbl.add id info env.modtypes; 1994 1994 - summary = Env_modtype(env.summary, id, info) } 2035 2035 + summary } 1995 2036 1996 2037 and store_class id addr desc env = 1997 2038 let clda = { clda_declaration = desc; clda_address = addr } in ··· 2030 2071 components_of_module ~alerts:Misc.Stdlib.String.Map.empty 2031 2072 ~uid:Uid.internal_not_actually_unique 2032 2073 (*???*) 2033 2033 - env None Subst.identity p addr mty 2074 2074 + env None Subst.identity p addr (Subst.Lazy.of_modtype mty) 2034 2075 in 2035 2076 Hashtbl.add f_comp.fcomp_cache arg comps; 2036 2077 comps ··· 2068 2109 else 2069 2110 Some (fun s -> Warnings.Unused_module s) 2070 2111 in 2112 2112 + let md = Subst.Lazy.of_module_decl md in 2071 2113 let addr = module_declaration_address env id presence md in 2072 2114 let env = store_module ~freshening_sub:None ~check id addr presence md env in 2073 2115 if arg then add_functor_arg id env else env 2074 2116 2117 2117 + and add_module_declaration_lazy ~update_summary id presence md env = 2118 2118 + let addr = module_declaration_address env id presence md in 2119 2119 + let env = store_module ~update_summary ~freshening_sub:None 2120 2120 + ~check:None id addr presence md env in 2121 2121 + env 2122 2122 + 2075 2123 and add_modtype id info env = 2076 2076 - store_modtype id info env 2124 2124 + store_modtype id (Subst.Lazy.of_modtype_decl info) env 2125 2125 + 2126 2126 + and add_modtype_lazy ~update_summary id info env = 2127 2127 + store_modtype ~update_summary id info env 2077 2128 2078 2129 and add_class id ty env = 2079 2130 let addr = class_declaration_address env id ty in ··· 2089 2140 { env with 2090 2141 local_constraints = Path.Map.add path info env.local_constraints } 2091 2142 2143 2143 + (* Non-lazy version of scrape_alias *) 2144 2144 + let scrape_alias t mty = 2145 2145 + mty |> Subst.Lazy.of_modtype |> scrape_alias t |> Subst.Lazy.force_modtype 2092 2146 2093 2147 (* Insertion of bindings by name *) 2094 2148 ··· 2115 2169 2116 2170 let enter_modtype ~scope name mtd env = 2117 2171 let id = Ident.create_scoped ~scope name in 2118 2118 - let env = store_modtype id mtd env in 2172 2172 + let env = store_modtype id (Subst.Lazy.of_modtype_decl mtd) env in 2119 2173 (id, env) 2120 2174 2121 2175 let enter_class ~scope name desc env = ··· 2318 2372 (* Read a signature from a file *) 2319 2373 let read_signature modname filename = 2320 2374 let mda = read_pers_mod modname filename in 2321 2321 - let md = Lazy_backtrack.force subst_modtype_maker mda.mda_declaration in 2375 2375 + let md = Subst.Lazy.force_module_decl mda.mda_declaration in 2322 2376 match md.md_type with 2323 2377 | Mty_signature sg -> sg 2324 2378 | Mty_ident _ | Mty_functor _ | Mty_alias _ -> assert false ··· 2517 2571 end 2518 2572 2519 2573 let use_modtype ~use ~loc path desc = 2574 2574 + let open Subst.Lazy in 2520 2575 if use then begin 2521 2521 - mark_modtype_used desc.mtd_uid; 2522 2522 - Builtin_attributes.check_alerts loc desc.mtd_attributes 2576 2576 + mark_modtype_used desc.mtdl_uid; 2577 2577 + Builtin_attributes.check_alerts loc desc.mtdl_attributes 2523 2578 (Path.name path) 2524 2579 end 2525 2580 ··· 2608 2663 2609 2664 let lookup_ident_modtype ~errors ~use ~loc s env = 2610 2665 match IdTbl.find_name wrap_identity ~mark:use s env.modtypes with 2611 2611 - | (path, data) as res -> 2666 2666 + | (path, data) -> 2612 2667 use_modtype ~use ~loc path data; 2613 2613 - res 2668 2668 + (path, data) 2614 2669 | exception Not_found -> 2615 2670 may_lookup_error errors loc env (Unbound_modtype (Lident s)) 2616 2671 ··· 2749 2804 match lid with 2750 2805 | Lident s -> 2751 2806 let path, data = lookup_ident_module Load ~errors ~use ~loc s env in 2752 2752 - let md = Lazy_backtrack.force subst_modtype_maker data.mda_declaration in 2807 2807 + let md = Subst.Lazy.force_module_decl data.mda_declaration in 2753 2808 path, md 2754 2809 | Ldot(l, s) -> 2755 2810 let path, data = lookup_dot_module ~errors ~use ~loc l s env in 2756 2756 - let md = Lazy_backtrack.force subst_modtype_maker data.mda_declaration in 2811 2811 + let md = Subst.Lazy.force_module_decl data.mda_declaration in 2757 2812 path, md 2758 2813 | Lapply _ as lid -> 2759 2814 let path_f, comp_f, path_arg = lookup_apply ~errors ~use ~loc lid env in ··· 2882 2937 let (path, tda) = lookup_type_full ~errors ~use ~loc lid env in 2883 2938 path, tda.tda_declaration 2884 2939 2885 2885 - let lookup_modtype ~errors ~use ~loc lid env = 2940 2940 + let lookup_modtype_lazy ~errors ~use ~loc lid env = 2886 2941 match lid with 2887 2942 | Lident s -> lookup_ident_modtype ~errors ~use ~loc s env 2888 2943 | Ldot(l, s) -> lookup_dot_modtype ~errors ~use ~loc l s env 2889 2944 | Lapply _ -> assert false 2890 2945 2946 2946 + let lookup_modtype ~errors ~use ~loc lid env = 2947 2947 + let (path, mt) = lookup_modtype_lazy ~errors ~use ~loc lid env in 2948 2948 + path, Subst.Lazy.force_modtype_decl mt 2949 2949 + 2891 2950 let lookup_class ~errors ~use ~loc lid env = 2892 2951 match lid with 2893 2952 | Lident s -> lookup_ident_class ~errors ~use ~loc s env ··· 2999 3058 3000 3059 let lookup_modtype ?(use=true) ~loc lid env = 3001 3060 lookup_modtype ~errors:true ~use ~loc lid env 3061 3061 + 3062 3062 + let lookup_modtype_path ?(use=true) ~loc lid env = 3063 3063 + fst (lookup_modtype_lazy ~errors:true ~use ~loc lid env) 3002 3064 3003 3065 let lookup_class ?(use=true) ~loc lid env = 3004 3066 lookup_class ~errors:true ~use ~loc lid env ··· 3139 3201 | Mod_unbound _ -> acc 3140 3202 | Mod_local mda -> 3141 3203 let md = 3142 3142 - Lazy_backtrack.force subst_modtype_maker mda.mda_declaration 3204 3204 + Subst.Lazy.force_module_decl mda.mda_declaration 3143 3205 in 3144 3206 f name p md acc 3145 3207 | Mod_persistent -> ··· 3147 3209 | None -> acc 3148 3210 | Some mda -> 3149 3211 let md = 3150 3150 - Lazy_backtrack.force subst_modtype_maker 3151 3151 - mda.mda_declaration 3212 3212 + Subst.Lazy.force_module_decl mda.mda_declaration 3152 3213 in 3153 3214 f name p md acc) 3154 3215 env.modules ··· 3163 3224 NameMap.fold 3164 3225 (fun s mda acc -> 3165 3226 let md = 3166 3166 - Lazy_backtrack.force subst_modtype_maker mda.mda_declaration 3227 3227 + Subst.Lazy.force_module_decl mda.mda_declaration 3167 3228 in 3168 3229 f s (Pdot (p, s)) md acc) 3169 3230 c.comp_modules ··· 3188 3249 (fun env -> env.types) (fun sc -> sc.comp_types) 3189 3250 (fun k p tda acc -> f k p tda.tda_declaration acc) 3190 3251 and fold_modtypes f = 3252 3252 + let f l path data acc = f l path (Subst.Lazy.force_modtype_decl data) acc in 3191 3253 find_all wrap_identity 3192 3254 (fun env -> env.modtypes) (fun sc -> sc.comp_modtypes) f 3193 3255 and fold_classes f =

+12 -1

typing/env.mli

reviewed

··· 86 86 val find_class: Path.t -> t -> class_declaration 87 87 val find_cltype: Path.t -> t -> class_type_declaration 88 88 89 89 + val find_strengthened_module: 90 90 + aliasable:bool -> Path.t -> t -> module_type 91 91 + 89 92 val find_ident_constructor: Ident.t -> t -> constructor_description 90 93 val find_ident_label: Ident.t -> t -> label_description 91 94 ··· 96 99 (* Find the manifest type information associated to a type for the sake 97 100 of the compiler's type-based optimisations. *) 98 101 val find_modtype_expansion: Path.t -> t -> module_type 102 102 + val find_modtype_expansion_lazy: Path.t -> t -> Subst.Lazy.modtype 99 103 100 104 val find_hash_type: Path.t -> t -> type_declaration 101 105 (* Find the "#t" type given the path for "t" *) ··· 211 215 212 216 val lookup_module_path: 213 217 ?use:bool -> loc:Location.t -> load:bool -> Longident.t -> t -> Path.t 218 218 + val lookup_modtype_path: 219 219 + ?use:bool -> loc:Location.t -> Longident.t -> t -> Path.t 214 220 215 221 val lookup_constructor: 216 222 ?use:bool -> loc:Location.t -> constructor_usage -> Longident.t -> t -> ··· 278 284 ?arg:bool -> Ident.t -> module_presence -> module_type -> t -> t 279 285 val add_module_declaration: ?arg:bool -> check:bool -> Ident.t -> 280 286 module_presence -> module_declaration -> t -> t 287 287 + val add_module_declaration_lazy: update_summary:bool -> 288 288 + Ident.t -> module_presence -> Subst.Lazy.module_decl -> t -> t 281 289 val add_modtype: Ident.t -> modtype_declaration -> t -> t 290 290 + val add_modtype_lazy: update_summary:bool -> 291 291 + Ident.t -> Subst.Lazy.modtype_declaration -> t -> t 282 292 val add_class: Ident.t -> class_declaration -> t -> t 283 293 val add_cltype: Ident.t -> class_type_declaration -> t -> t 284 294 val add_local_type: Path.t -> type_declaration -> t -> t ··· 438 448 val add_delayed_check_forward: ((unit -> unit) -> unit) ref 439 449 (* Forward declaration to break mutual recursion with Mtype. *) 440 450 val strengthen: 441 441 - (aliasable:bool -> t -> module_type -> Path.t -> module_type) ref 451 451 + (aliasable:bool -> t -> Subst.Lazy.modtype -> 452 452 + Path.t -> Subst.Lazy.modtype) ref 442 453 (* Forward declaration to break mutual recursion with Ctype. *) 443 454 val same_constr: (t -> type_expr -> type_expr -> bool) ref 444 455 (* Forward declaration to break mutual recursion with Printtyp. *)

+12 -9

typing/includemod.ml

reviewed

··· 210 210 | exception Not_found -> None 211 211 | x -> Some x 212 212 213 213 - let expand_module_alias env path = 214 214 - match (Env.find_module path env).md_type with 213 213 + let expand_module_alias ~strengthen env path = 214 214 + match 215 215 + if strengthen then Env.find_strengthened_module ~aliasable:true path env 216 216 + else (Env.find_module path env).md_type 217 217 + with 215 218 | x -> Ok x 216 219 | exception Not_found -> Error (Error.Unbound_module_path path) 217 220 ··· 345 348 | None -> List.rev before, res 346 349 end 347 350 | Mty_alias p as res -> 348 348 - begin match expand_module_alias env p with 351 351 + begin match expand_module_alias ~strengthen:false env p with 349 352 | Ok mty -> retrieve_functor_params before env mty 350 353 | Error _ -> List.rev before, res 351 354 end ··· 380 383 | exception Env.Error (Env.Missing_module (_, _, path)) -> 381 384 Error Error.(Mt_core(Unbound_module_path path)) 382 385 | p1 -> 383 383 - begin match expand_module_alias env p1 with 386 386 + begin match expand_module_alias ~strengthen:false env p1 with 384 387 | Error e -> Error (Error.Mt_core e) 385 388 | Ok mty1 -> 386 389 match strengthened_modtypes ~loc ~aliasable:true env ~mark ··· 575 578 false 576 579 | _ -> name2, true 577 580 in 578 578 - begin try 579 579 - let (id1, item1, pos1) = FieldMap.find name2 comps1 in 581 581 + begin match FieldMap.find name2 comps1 with 582 582 + | (id1, item1, pos1) -> 580 583 let new_subst = 581 584 match item2 with 582 585 Sig_type _ -> ··· 591 594 in 592 595 pair_components new_subst 593 596 ((item1, item2, pos1) :: paired) unpaired rem 594 594 - with Not_found -> 597 597 + | exception Not_found -> 595 598 let unpaired = 596 599 if report then 597 600 item2 :: unpaired ··· 1032 1035 | Error mdiff -> 1033 1036 raise (Error(env,Error.(In_Module_type mdiff))) 1034 1037 1035 1035 - let expand_module_alias env path = 1036 1036 - match expand_module_alias env path with 1038 1038 + let expand_module_alias ~strengthen env path = 1039 1039 + match expand_module_alias ~strengthen env path with 1037 1040 | Ok x -> x 1038 1041 | Result.Error _ -> 1039 1042 raise (Error(env,In_Expansion(Error.Unbound_module_path path)))

+1 -1

typing/includemod.mli

reviewed

··· 214 214 args : (Error.functor_arg_descr * Types.module_type) list ; 215 215 } 216 216 217 217 - val expand_module_alias: Env.t -> Path.t -> Types.module_type 217 217 + val expand_module_alias: strengthen:bool -> Env.t -> Path.t -> Types.module_type 218 218 219 219 module Functor_inclusion_diff: sig 220 220 module Defs: sig

+73 -45

typing/mtype.ml

reviewed

··· 19 19 open Path 20 20 open Types 21 21 22 22 - 23 23 - let rec scrape env mty = 22 22 + let rec scrape_lazy env mty = 23 23 + let open Subst.Lazy in 24 24 match mty with 25 25 - Mty_ident p -> 25 25 + MtyL_ident p -> 26 26 begin try 27 27 - scrape env (Env.find_modtype_expansion p env) 27 27 + scrape_lazy env (Env.find_modtype_expansion_lazy p env) 28 28 with Not_found -> 29 29 mty 30 30 end 31 31 | _ -> mty 32 32 33 33 + let scrape env mty = 34 34 + match mty with 35 35 + Mty_ident p -> 36 36 + Subst.Lazy.force_modtype (scrape_lazy env (MtyL_ident p)) 37 37 + | _ -> mty 38 38 + 33 39 let freshen ~scope mty = 34 40 Subst.modtype (Rescope scope) Subst.identity mty 35 41 36 36 - let rec strengthen ~aliasable env mty p = 37 37 - match scrape env mty with 38 38 - Mty_signature sg -> 39 39 - Mty_signature(strengthen_sig ~aliasable env sg p) 40 40 - | Mty_functor(Named (Some param, arg), res) 42 42 + let rec strengthen_lazy ~aliasable env mty p = 43 43 + let open Subst.Lazy in 44 44 + match scrape_lazy env mty with 45 45 + MtyL_signature sg -> 46 46 + MtyL_signature(strengthen_lazy_sig ~aliasable env sg p) 47 47 + | MtyL_functor(Named (Some param, arg), res) 41 48 when !Clflags.applicative_functors -> 42 42 - Mty_functor(Named (Some param, arg), 43 43 - strengthen ~aliasable:false env res (Papply(p, Pident param))) 44 44 - | Mty_functor(Named (None, arg), res) 49 49 + MtyL_functor(Named (Some param, arg), 50 50 + strengthen_lazy ~aliasable:false env res (Papply(p, Pident param))) 51 51 + | MtyL_functor(Named (None, arg), res) 45 52 when !Clflags.applicative_functors -> 46 53 let param = Ident.create_scoped ~scope:(Path.scope p) "Arg" in 47 47 - Mty_functor(Named (Some param, arg), 48 48 - strengthen ~aliasable:false env res (Papply(p, Pident param))) 54 54 + MtyL_functor(Named (Some param, arg), 55 55 + strengthen_lazy ~aliasable:false env res (Papply(p, Pident param))) 49 56 | mty -> 50 57 mty 51 58 52 52 - and strengthen_sig ~aliasable env sg p = 59 59 + and strengthen_lazy_sig' ~aliasable env sg p = 60 60 + let open Subst.Lazy in 53 61 match sg with 54 62 [] -> [] 55 55 - | (Sig_value(_, _, _) as sigelt) :: rem -> 56 56 - sigelt :: strengthen_sig ~aliasable env rem p 57 57 - | Sig_type(id, {type_kind=Type_abstract}, _, _) :: rem 63 63 + | (SigL_value(_, _, _) as sigelt) :: rem -> 64 64 + sigelt :: strengthen_lazy_sig' ~aliasable env rem p 65 65 + | SigL_type(id, {type_kind=Type_abstract}, _, _) :: rem 58 66 when Btype.is_row_name (Ident.name id) -> 59 59 - strengthen_sig ~aliasable env rem p 60 60 - | Sig_type(id, decl, rs, vis) :: rem -> 67 67 + strengthen_lazy_sig' ~aliasable env rem p 68 68 + | SigL_type(id, decl, rs, vis) :: rem -> 61 69 let newdecl = 62 70 match decl.type_manifest, decl.type_private, decl.type_kind with 63 71 Some _, Public, _ -> decl ··· 71 79 else 72 80 { decl with type_manifest = manif } 73 81 in 74 74 - Sig_type(id, newdecl, rs, vis) :: strengthen_sig ~aliasable env rem p 75 75 - | (Sig_typext _ as sigelt) :: rem -> 76 76 - sigelt :: strengthen_sig ~aliasable env rem p 77 77 - | Sig_module(id, pres, md, rs, vis) :: rem -> 82 82 + SigL_type(id, newdecl, rs, vis) :: 83 83 + strengthen_lazy_sig' ~aliasable env rem p 84 84 + | (SigL_typext _ as sigelt) :: rem -> 85 85 + sigelt :: strengthen_lazy_sig' ~aliasable env rem p 86 86 + | SigL_module(id, pres, md, rs, vis) :: rem -> 78 87 let str = 79 79 - strengthen_decl ~aliasable env md (Pdot(p, Ident.name id)) 88 88 + strengthen_lazy_decl ~aliasable env md (Pdot(p, Ident.name id)) 80 89 in 81 81 - Sig_module(id, pres, str, rs, vis) 82 82 - :: strengthen_sig ~aliasable 83 83 - (Env.add_module_declaration ~check:false id pres md env) rem p 90 90 + let env = 91 91 + Env.add_module_declaration_lazy ~update_summary:false id pres md env in 92 92 + SigL_module(id, pres, str, rs, vis) 93 93 + :: strengthen_lazy_sig' ~aliasable env rem p 84 94 (* Need to add the module in case it defines manifest module types *) 85 85 - | Sig_modtype(id, decl, vis) :: rem -> 95 95 + | SigL_modtype(id, decl, vis) :: rem -> 86 96 let newdecl = 87 87 - match decl.mtd_type with 88 88 - None -> 89 89 - {decl with mtd_type = Some(Mty_ident(Pdot(p,Ident.name id)))} 90 90 - | Some _ -> 97 97 + match decl.mtdl_type with 98 98 + | Some _ when not aliasable -> 99 99 + (* [not alisable] condition needed because of recursive modules. 100 100 + See [Typemod.check_recmodule_inclusion]. *) 91 101 decl 102 102 + | _ -> 103 103 + {decl with mtdl_type = Some(MtyL_ident(Pdot(p,Ident.name id)))} 92 104 in 93 93 - Sig_modtype(id, newdecl, vis) :: 94 94 - strengthen_sig ~aliasable (Env.add_modtype id decl env) rem p 105 105 + let env = Env.add_modtype_lazy ~update_summary:false id decl env in 106 106 + SigL_modtype(id, newdecl, vis) :: 107 107 + strengthen_lazy_sig' ~aliasable env rem p 95 108 (* Need to add the module type in case it is manifest *) 96 96 - | (Sig_class _ as sigelt) :: rem -> 97 97 - sigelt :: strengthen_sig ~aliasable env rem p 98 98 - | (Sig_class_type _ as sigelt) :: rem -> 99 99 - sigelt :: strengthen_sig ~aliasable env rem p 109 109 + | (SigL_class _ as sigelt) :: rem -> 110 110 + sigelt :: strengthen_lazy_sig' ~aliasable env rem p 111 111 + | (SigL_class_type _ as sigelt) :: rem -> 112 112 + sigelt :: strengthen_lazy_sig' ~aliasable env rem p 113 113 + 114 114 + and strengthen_lazy_sig ~aliasable env sg p = 115 115 + let sg = Subst.Lazy.force_signature_once sg in 116 116 + let sg = strengthen_lazy_sig' ~aliasable env sg p in 117 117 + Subst.Lazy.of_signature_items sg 118 118 + 119 119 + and strengthen_lazy_decl ~aliasable env md p = 120 120 + let open Subst.Lazy in 121 121 + match md.mdl_type with 122 122 + | MtyL_alias _ -> md 123 123 + | _ when aliasable -> {md with mdl_type = MtyL_alias p} 124 124 + | mty -> {md with mdl_type = strengthen_lazy ~aliasable env mty p} 125 125 + 126 126 + let () = Env.strengthen := strengthen_lazy 100 127 101 101 - and strengthen_decl ~aliasable env md p = 102 102 - match md.md_type with 103 103 - | Mty_alias _ -> md 104 104 - | _ when aliasable -> {md with md_type = Mty_alias p} 105 105 - | mty -> {md with md_type = strengthen ~aliasable env mty p} 128 128 + let strengthen ~aliasable env mty p = 129 129 + let mty = strengthen_lazy ~aliasable env (Subst.Lazy.of_modtype mty) p in 130 130 + Subst.Lazy.force_modtype mty 106 131 107 107 - let () = Env.strengthen := strengthen 132 132 + let strengthen_decl ~aliasable env md p = 133 133 + let md = strengthen_lazy_decl ~aliasable env 134 134 + (Subst.Lazy.of_module_decl md) p in 135 135 + Subst.Lazy.force_module_decl md 108 136 109 137 let rec make_aliases_absent pres mty = 110 138 match mty with

+14 -11

typing/rec_check.ml

reviewed

··· 1202 1202 is_destructuring_pattern l || is_destructuring_pattern r 1203 1203 1204 1204 let is_valid_recursive_expression idlist expr = 1205 1205 - let ty = expression expr Return in 1206 1206 - match Env.unguarded ty idlist, Env.dependent ty idlist, 1207 1207 - classify_expression expr with 1208 1208 - | _ :: _, _, _ (* The expression inspects rec-bound variables *) 1209 1209 - | [], _ :: _, Dynamic -> (* The expression depends on rec-bound variables 1210 1210 - and its size is unknown *) 1211 1211 - false 1212 1212 - | [], _, Static (* The expression has known size *) 1213 1213 - | [], [], Dynamic -> (* The expression has unknown size, 1214 1214 - but does not depend on rec-bound variables *) 1215 1215 - true 1205 1205 + match expr.exp_desc with 1206 1206 + | Texp_function _ -> 1207 1207 + (* Fast path: functions can never have invalid recursive references *) 1208 1208 + true 1209 1209 + | _ -> 1210 1210 + match classify_expression expr with 1211 1211 + | Static -> 1212 1212 + (* The expression has known size *) 1213 1213 + let ty = expression expr Return in 1214 1214 + Env.unguarded ty idlist = [] 1215 1215 + | Dynamic -> 1216 1216 + (* The expression has unknown size *) 1217 1217 + let ty = expression expr Return in 1218 1218 + Env.unguarded ty idlist = [] && Env.dependent ty idlist = [] 1216 1219 1217 1220 (* A class declaration may contain let-bindings. If they are recursive, 1218 1221 their validity will already be checked by [is_valid_recursive_expression]

+268 -82

typing/subst.ml

reviewed

··· 417 417 For_copy.with_scope 418 418 (fun copy_scope -> extension_constructor' copy_scope s ext) 419 419 420 420 + 421 421 + (* For every binding k |-> d of m1, add k |-> f d to m2 422 422 + and return resulting merged map. *) 423 423 + 424 424 + let merge_path_maps f m1 m2 = 425 425 + Path.Map.fold (fun k d accu -> Path.Map.add k (f d) accu) m1 m2 426 426 + 427 427 + let keep_latest_loc l1 l2 = 428 428 + match l2 with 429 429 + | None -> l1 430 430 + | Some _ -> l2 431 431 + 432 432 + let type_replacement s = function 433 433 + | Path p -> Path (type_path s p) 434 434 + | Type_function { params; body } -> 435 435 + For_copy.with_scope (fun copy_scope -> 436 436 + let params = List.map (typexp copy_scope s) params in 437 437 + let body = typexp copy_scope s body in 438 438 + Type_function { params; body }) 439 439 + 420 440 type scoping = 421 441 | Keep 422 442 | Make_local 423 443 | Rescope of int 424 444 445 445 + module Lazy_types = struct 446 446 + 447 447 + type module_decl = 448 448 + { 449 449 + mdl_type: modtype; 450 450 + mdl_attributes: Parsetree.attributes; 451 451 + mdl_loc: Location.t; 452 452 + mdl_uid: Uid.t; 453 453 + } 454 454 + 455 455 + and modtype = 456 456 + | MtyL_ident of Path.t 457 457 + | MtyL_signature of signature 458 458 + | MtyL_functor of functor_parameter * modtype 459 459 + | MtyL_alias of Path.t 460 460 + 461 461 + and modtype_declaration = 462 462 + { 463 463 + mtdl_type: modtype option; 464 464 + mtdl_attributes: Parsetree.attributes; 465 465 + mtdl_loc: Location.t; 466 466 + mtdl_uid: Uid.t; 467 467 + } 468 468 + 469 469 + and signature' = 470 470 + | S_eager of Types.signature 471 471 + | S_lazy of signature_item list 472 472 + 473 473 + and signature = 474 474 + (scoping * t * signature', signature') Lazy_backtrack.t 475 475 + 476 476 + and signature_item = 477 477 + SigL_value of Ident.t * value_description * visibility 478 478 + | SigL_type of Ident.t * type_declaration * rec_status * visibility 479 479 + | SigL_typext of Ident.t * extension_constructor * ext_status * visibility 480 480 + | SigL_module of 481 481 + Ident.t * module_presence * module_decl * rec_status * visibility 482 482 + | SigL_modtype of Ident.t * modtype_declaration * visibility 483 483 + | SigL_class of Ident.t * class_declaration * rec_status * visibility 484 484 + | SigL_class_type of Ident.t * class_type_declaration * 485 485 + rec_status * visibility 486 486 + 487 487 + and functor_parameter = 488 488 + | Unit 489 489 + | Named of Ident.t option * modtype 490 490 + 491 491 + end 492 492 + open Lazy_types 493 493 + 425 494 let rename_bound_idents scoping s sg = 426 495 let rename = 427 496 let open Ident in ··· 432 501 in 433 502 let rec rename_bound_idents s sg = function 434 503 | [] -> sg, s 435 435 - | Sig_type(id, td, rs, vis) :: rest -> 504 504 + | SigL_type(id, td, rs, vis) :: rest -> 436 505 let id' = rename id in 437 506 rename_bound_idents 438 507 (add_type id (Pident id') s) 439 439 - (Sig_type(id', td, rs, vis) :: sg) 508 508 + (SigL_type(id', td, rs, vis) :: sg) 440 509 rest 441 441 - | Sig_module(id, pres, md, rs, vis) :: rest -> 510 510 + | SigL_module(id, pres, md, rs, vis) :: rest -> 442 511 let id' = rename id in 443 512 rename_bound_idents 444 513 (add_module id (Pident id') s) 445 445 - (Sig_module (id', pres, md, rs, vis) :: sg) 514 514 + (SigL_module (id', pres, md, rs, vis) :: sg) 446 515 rest 447 447 - | Sig_modtype(id, mtd, vis) :: rest -> 516 516 + | SigL_modtype(id, mtd, vis) :: rest -> 448 517 let id' = rename id in 449 518 rename_bound_idents 450 519 (add_modtype id (Mty_ident(Pident id')) s) 451 451 - (Sig_modtype(id', mtd, vis) :: sg) 520 520 + (SigL_modtype(id', mtd, vis) :: sg) 452 521 rest 453 453 - | Sig_class(id, cd, rs, vis) :: rest -> 522 522 + | SigL_class(id, cd, rs, vis) :: rest -> 454 523 (* cheat and pretend they are types cf. PR#6650 *) 455 524 let id' = rename id in 456 525 rename_bound_idents 457 526 (add_type id (Pident id') s) 458 458 - (Sig_class(id', cd, rs, vis) :: sg) 527 527 + (SigL_class(id', cd, rs, vis) :: sg) 459 528 rest 460 460 - | Sig_class_type(id, ctd, rs, vis) :: rest -> 529 529 + | SigL_class_type(id, ctd, rs, vis) :: rest -> 461 530 (* cheat and pretend they are types cf. PR#6650 *) 462 531 let id' = rename id in 463 532 rename_bound_idents 464 533 (add_type id (Pident id') s) 465 465 - (Sig_class_type(id', ctd, rs, vis) :: sg) 534 534 + (SigL_class_type(id', ctd, rs, vis) :: sg) 466 535 rest 467 467 - | Sig_value(id, vd, vis) :: rest -> 536 536 + | SigL_value(id, vd, vis) :: rest -> 468 537 (* scope doesn't matter for value identifiers. *) 469 538 let id' = Ident.rename id in 470 470 - rename_bound_idents s (Sig_value(id', vd, vis) :: sg) rest 471 471 - | Sig_typext(id, ec, es, vis) :: rest -> 539 539 + rename_bound_idents s (SigL_value(id', vd, vis) :: sg) rest 540 540 + | SigL_typext(id, ec, es, vis) :: rest -> 472 541 let id' = rename id in 473 473 - rename_bound_idents s (Sig_typext(id',ec,es,vis) :: sg) rest 542 542 + rename_bound_idents s (SigL_typext(id',ec,es,vis) :: sg) rest 474 543 in 475 544 rename_bound_idents s [] sg 476 545 477 477 - let rec modtype scoping s = function 478 478 - Mty_ident p as mty -> 546 546 + let rec lazy_module_decl md = 547 547 + { mdl_type = lazy_modtype md.md_type; 548 548 + mdl_attributes = md.md_attributes; 549 549 + mdl_loc = md.md_loc; 550 550 + mdl_uid = md.md_uid } 551 551 + 552 552 + and subst_lazy_module_decl scoping s md = 553 553 + let mdl_type = subst_lazy_modtype scoping s md.mdl_type in 554 554 + { mdl_type; 555 555 + mdl_attributes = attrs s md.mdl_attributes; 556 556 + mdl_loc = loc s md.mdl_loc; 557 557 + mdl_uid = md.mdl_uid } 558 558 + 559 559 + and force_module_decl md = 560 560 + let md_type = force_modtype md.mdl_type in 561 561 + { md_type; 562 562 + md_attributes = md.mdl_attributes; 563 563 + md_loc = md.mdl_loc; 564 564 + md_uid = md.mdl_uid } 565 565 + 566 566 + and lazy_modtype = function 567 567 + | Mty_ident p -> MtyL_ident p 568 568 + | Mty_signature sg -> 569 569 + MtyL_signature (Lazy_backtrack.create_forced (S_eager sg)) 570 570 + | Mty_functor (Unit, mty) -> MtyL_functor (Unit, lazy_modtype mty) 571 571 + | Mty_functor (Named (id, arg), res) -> 572 572 + MtyL_functor (Named (id, lazy_modtype arg), lazy_modtype res) 573 573 + | Mty_alias p -> MtyL_alias p 574 574 + 575 575 + and subst_lazy_modtype scoping s = function 576 576 + | MtyL_ident p -> 479 577 begin match Path.Map.find p s.modtypes with 480 480 - | mty -> mty 578 578 + | mty -> lazy_modtype mty 481 579 | exception Not_found -> 482 580 begin match p with 483 483 - | Pident _ -> mty 581 581 + | Pident _ -> MtyL_ident p 484 582 | Pdot(p, n) -> 485 485 - Mty_ident(Pdot(module_path s p, n)) 583 583 + MtyL_ident(Pdot(module_path s p, n)) 486 584 | Papply _ -> 487 585 fatal_error "Subst.modtype" 488 586 end 489 587 end 490 490 - | Mty_signature sg -> 491 491 - Mty_signature(signature scoping s sg) 492 492 - | Mty_functor(Unit, res) -> 493 493 - Mty_functor(Unit, modtype scoping s res) 494 494 - | Mty_functor(Named (None, arg), res) -> 495 495 - Mty_functor(Named (None, (modtype scoping s) arg), modtype scoping s res) 496 496 - | Mty_functor(Named (Some id, arg), res) -> 588 588 + | MtyL_signature sg -> 589 589 + MtyL_signature(subst_lazy_signature scoping s sg) 590 590 + | MtyL_functor(Unit, res) -> 591 591 + MtyL_functor(Unit, subst_lazy_modtype scoping s res) 592 592 + | MtyL_functor(Named (None, arg), res) -> 593 593 + MtyL_functor(Named (None, (subst_lazy_modtype scoping s) arg), 594 594 + subst_lazy_modtype scoping s res) 595 595 + | MtyL_functor(Named (Some id, arg), res) -> 497 596 let id' = Ident.rename id in 498 498 - Mty_functor(Named (Some id', (modtype scoping s) arg), 499 499 - modtype scoping (add_module id (Pident id') s) res) 500 500 - | Mty_alias p -> 501 501 - Mty_alias (module_path s p) 597 597 + MtyL_functor(Named (Some id', (subst_lazy_modtype scoping s) arg), 598 598 + subst_lazy_modtype scoping (add_module id (Pident id') s) res) 599 599 + | MtyL_alias p -> 600 600 + MtyL_alias (module_path s p) 601 601 + 602 602 + and force_modtype = function 603 603 + | MtyL_ident p -> Mty_ident p 604 604 + | MtyL_signature sg -> Mty_signature (force_signature sg) 605 605 + | MtyL_functor (param, res) -> 606 606 + let param : Types.functor_parameter = 607 607 + match param with 608 608 + | Unit -> Unit 609 609 + | Named (id, mty) -> Named (id, force_modtype mty) in 610 610 + Mty_functor (param, force_modtype res) 611 611 + | MtyL_alias p -> Mty_alias p 502 612 503 503 - and signature scoping s sg = 613 613 + and lazy_modtype_decl mtd = 614 614 + let mtdl_type = Option.map lazy_modtype mtd.mtd_type in 615 615 + { mtdl_type; 616 616 + mtdl_attributes = mtd.mtd_attributes; 617 617 + mtdl_loc = mtd.mtd_loc; 618 618 + mtdl_uid = mtd.mtd_uid } 619 619 + 620 620 + and subst_lazy_modtype_decl scoping s mtd = 621 621 + { mtdl_type = Option.map (subst_lazy_modtype scoping s) mtd.mtdl_type; 622 622 + mtdl_attributes = attrs s mtd.mtdl_attributes; 623 623 + mtdl_loc = loc s mtd.mtdl_loc; 624 624 + mtdl_uid = mtd.mtdl_uid } 625 625 + 626 626 + and force_modtype_decl mtd = 627 627 + let mtd_type = Option.map force_modtype mtd.mtdl_type in 628 628 + { mtd_type; 629 629 + mtd_attributes = mtd.mtdl_attributes; 630 630 + mtd_loc = mtd.mtdl_loc; 631 631 + mtd_uid = mtd.mtdl_uid } 632 632 + 633 633 + and subst_lazy_signature scoping s sg = 634 634 + match Lazy_backtrack.get_contents sg with 635 635 + | Left (scoping', s', sg) -> 636 636 + let scoping = 637 637 + match scoping', scoping with 638 638 + | sc, Keep -> sc 639 639 + | _, (Make_local|Rescope _) -> scoping 640 640 + in 641 641 + let s = compose s' s in 642 642 + Lazy_backtrack.create (scoping, s, sg) 643 643 + | Right sg -> 644 644 + Lazy_backtrack.create (scoping, s, sg) 645 645 + 646 646 + and force_signature sg = 647 647 + List.map force_signature_item (force_signature_once sg) 648 648 + 649 649 + and force_signature_once sg = 650 650 + lazy_signature' (Lazy_backtrack.force force_signature_once' sg) 651 651 + 652 652 + and lazy_signature' = function 653 653 + | S_lazy sg -> sg 654 654 + | S_eager sg -> List.map lazy_signature_item sg 655 655 + 656 656 + and force_signature_once' (scoping, s, sg) = 657 657 + let sg = lazy_signature' sg in 504 658 (* Components of signature may be mutually recursive (e.g. type declarations 505 659 or class and type declarations), so first build global renaming 506 660 substitution... *) 507 661 let (sg', s') = rename_bound_idents scoping s sg in 508 662 (* ... then apply it to each signature component in turn *) 509 663 For_copy.with_scope (fun copy_scope -> 510 510 - List.rev_map (signature_item' copy_scope scoping s') sg' 664 664 + S_lazy (List.rev_map (subst_lazy_signature_item' copy_scope scoping s') sg') 511 665 ) 512 666 513 513 - 514 514 - and signature_item' copy_scope scoping s comp = 515 515 - match comp with 516 516 - Sig_value(id, d, vis) -> 517 517 - Sig_value(id, value_description' copy_scope s d, vis) 667 667 + and lazy_signature_item = function 668 668 + | Sig_value(id, d, vis) -> 669 669 + SigL_value(id, d, vis) 518 670 | Sig_type(id, d, rs, vis) -> 519 519 - Sig_type(id, type_declaration' copy_scope s d, rs, vis) 671 671 + SigL_type(id, d, rs, vis) 520 672 | Sig_typext(id, ext, es, vis) -> 521 521 - Sig_typext(id, extension_constructor' copy_scope s ext, es, vis) 522 522 - | Sig_module(id, pres, d, rs, vis) -> 523 523 - Sig_module(id, pres, module_declaration scoping s d, rs, vis) 673 673 + SigL_typext(id, ext, es, vis) 674 674 + | Sig_module(id, res, d, rs, vis) -> 675 675 + SigL_module(id, res, lazy_module_decl d, rs, vis) 524 676 | Sig_modtype(id, d, vis) -> 525 525 - Sig_modtype(id, modtype_declaration scoping s d, vis) 677 677 + SigL_modtype(id, lazy_modtype_decl d, vis) 526 678 | Sig_class(id, d, rs, vis) -> 527 527 - Sig_class(id, class_declaration' copy_scope s d, rs, vis) 679 679 + SigL_class(id, d, rs, vis) 528 680 | Sig_class_type(id, d, rs, vis) -> 529 529 - Sig_class_type(id, cltype_declaration' copy_scope s d, rs, vis) 681 681 + SigL_class_type(id, d, rs, vis) 530 682 531 531 - and signature_item scoping s comp = 532 532 - For_copy.with_scope 533 533 - (fun copy_scope -> signature_item' copy_scope scoping s comp) 683 683 + and subst_lazy_signature_item' copy_scope scoping s comp = 684 684 + match comp with 685 685 + SigL_value(id, d, vis) -> 686 686 + SigL_value(id, value_description' copy_scope s d, vis) 687 687 + | SigL_type(id, d, rs, vis) -> 688 688 + SigL_type(id, type_declaration' copy_scope s d, rs, vis) 689 689 + | SigL_typext(id, ext, es, vis) -> 690 690 + SigL_typext(id, extension_constructor' copy_scope s ext, es, vis) 691 691 + | SigL_module(id, pres, d, rs, vis) -> 692 692 + SigL_module(id, pres, subst_lazy_module_decl scoping s d, rs, vis) 693 693 + | SigL_modtype(id, d, vis) -> 694 694 + SigL_modtype(id, subst_lazy_modtype_decl scoping s d, vis) 695 695 + | SigL_class(id, d, rs, vis) -> 696 696 + SigL_class(id, class_declaration' copy_scope s d, rs, vis) 697 697 + | SigL_class_type(id, d, rs, vis) -> 698 698 + SigL_class_type(id, cltype_declaration' copy_scope s d, rs, vis) 534 699 535 535 - and module_declaration scoping s decl = 536 536 - { 537 537 - md_type = modtype scoping s decl.md_type; 538 538 - md_attributes = attrs s decl.md_attributes; 539 539 - md_loc = loc s decl.md_loc; 540 540 - md_uid = decl.md_uid; 541 541 - } 542 542 - 543 543 - and modtype_declaration scoping s decl = 544 544 - { 545 545 - mtd_type = Option.map (modtype scoping s) decl.mtd_type; 546 546 - mtd_attributes = attrs s decl.mtd_attributes; 547 547 - mtd_loc = loc s decl.mtd_loc; 548 548 - mtd_uid = decl.mtd_uid; 549 549 - } 550 550 - 551 551 - 552 552 - (* For every binding k |-> d of m1, add k |-> f d to m2 553 553 - and return resulting merged map. *) 554 554 - 555 555 - let merge_path_maps f m1 m2 = 556 556 - Path.Map.fold (fun k d accu -> Path.Map.add k (f d) accu) m1 m2 557 557 - 558 558 - let keep_latest_loc l1 l2 = 559 559 - match l2 with 560 560 - | None -> l1 561 561 - | Some _ -> l2 700 700 + and force_signature_item = function 701 701 + | SigL_value(id, vd, vis) -> Sig_value(id, vd, vis) 702 702 + | SigL_type(id, d, rs, vis) -> Sig_type(id, d, rs, vis) 703 703 + | SigL_typext(id, ext, es, vis) -> Sig_typext(id, ext, es, vis) 704 704 + | SigL_module(id, pres, d, rs, vis) -> 705 705 + Sig_module(id, pres, force_module_decl d, rs, vis) 706 706 + | SigL_modtype(id, d, vis) -> 707 707 + Sig_modtype (id, force_modtype_decl d, vis) 708 708 + | SigL_class(id, d, rs, vis) -> Sig_class(id, d, rs, vis) 709 709 + | SigL_class_type(id, d, rs, vis) -> Sig_class_type(id, d, rs, vis) 562 710 563 563 - let type_replacement s = function 564 564 - | Path p -> Path (type_path s p) 565 565 - | Type_function { params; body } -> 566 566 - For_copy.with_scope (fun copy_scope -> 567 567 - let params = List.map (typexp copy_scope s) params in 568 568 - let body = typexp copy_scope s body in 569 569 - Type_function { params; body }) 711 711 + and modtype scoping s t = 712 712 + t |> lazy_modtype |> subst_lazy_modtype scoping s |> force_modtype 570 713 571 714 (* Composition of substitutions: 572 715 apply (compose s1 s2) x = apply s2 (apply s1 x) *) 573 716 574 574 - let compose s1 s2 = 717 717 + and compose s1 s2 = 718 718 + if s1 == identity then s2 else 719 719 + if s2 == identity then s1 else 575 720 { types = merge_path_maps (type_replacement s2) s1.types s2.types; 576 721 modules = merge_path_maps (module_path s2) s1.modules s2.modules; 577 722 modtypes = merge_path_maps (modtype Keep s2) s1.modtypes s2.modtypes; 578 723 for_saving = s1.for_saving || s2.for_saving; 579 724 loc = keep_latest_loc s1.loc s2.loc; 580 725 } 726 726 + 727 727 + 728 728 + let subst_lazy_signature_item scoping s comp = 729 729 + For_copy.with_scope 730 730 + (fun copy_scope -> subst_lazy_signature_item' copy_scope scoping s comp) 731 731 + 732 732 + module Lazy = struct 733 733 + include Lazy_types 734 734 + 735 735 + let of_module_decl = lazy_module_decl 736 736 + let of_modtype = lazy_modtype 737 737 + let of_modtype_decl = lazy_modtype_decl 738 738 + let of_signature sg = Lazy_backtrack.create_forced (S_eager sg) 739 739 + let of_signature_items sg = Lazy_backtrack.create_forced (S_lazy sg) 740 740 + let of_signature_item = lazy_signature_item 741 741 + 742 742 + let module_decl = subst_lazy_module_decl 743 743 + let modtype = subst_lazy_modtype 744 744 + let modtype_decl = subst_lazy_modtype_decl 745 745 + let signature = subst_lazy_signature 746 746 + let signature_item = subst_lazy_signature_item 747 747 + 748 748 + let force_module_decl = force_module_decl 749 749 + let force_modtype = force_modtype 750 750 + let force_modtype_decl = force_modtype_decl 751 751 + let force_signature = force_signature 752 752 + let force_signature_once = force_signature_once 753 753 + let force_signature_item = force_signature_item 754 754 + end 755 755 + 756 756 + let signature sc s sg = 757 757 + Lazy.(sg |> of_signature |> signature sc s |> force_signature) 758 758 + 759 759 + let signature_item sc s comp = 760 760 + Lazy.(comp|> of_signature_item |> signature_item sc s |> force_signature_item) 761 761 + 762 762 + let modtype_declaration sc s decl = 763 763 + Lazy.(decl |> of_modtype_decl |> modtype_decl sc s |> force_modtype_decl) 764 764 + 765 765 + let module_declaration scoping s decl = 766 766 + Lazy.(decl |> of_module_decl |> module_decl scoping s |> force_module_decl)

+63

typing/subst.mli

reviewed

··· 87 87 (* A forward reference to be filled in ctype.ml. *) 88 88 val ctype_apply_env_empty: 89 89 (type_expr list -> type_expr -> type_expr list -> type_expr) ref 90 90 + 91 91 + 92 92 + module Lazy : sig 93 93 + type module_decl = 94 94 + { 95 95 + mdl_type: modtype; 96 96 + mdl_attributes: Parsetree.attributes; 97 97 + mdl_loc: Location.t; 98 98 + mdl_uid: Uid.t; 99 99 + } 100 100 + 101 101 + and modtype = 102 102 + | MtyL_ident of Path.t 103 103 + | MtyL_signature of signature 104 104 + | MtyL_functor of functor_parameter * modtype 105 105 + | MtyL_alias of Path.t 106 106 + 107 107 + and modtype_declaration = 108 108 + { 109 109 + mtdl_type: modtype option; (* Note: abstract *) 110 110 + mtdl_attributes: Parsetree.attributes; 111 111 + mtdl_loc: Location.t; 112 112 + mtdl_uid: Uid.t; 113 113 + } 114 114 + 115 115 + and signature 116 116 + 117 117 + and signature_item = 118 118 + SigL_value of Ident.t * value_description * visibility 119 119 + | SigL_type of Ident.t * type_declaration * rec_status * visibility 120 120 + | SigL_typext of Ident.t * extension_constructor * ext_status * visibility 121 121 + | SigL_module of 122 122 + Ident.t * module_presence * module_decl * rec_status * visibility 123 123 + | SigL_modtype of Ident.t * modtype_declaration * visibility 124 124 + | SigL_class of Ident.t * class_declaration * rec_status * visibility 125 125 + | SigL_class_type of Ident.t * class_type_declaration * 126 126 + rec_status * visibility 127 127 + 128 128 + and functor_parameter = 129 129 + | Unit 130 130 + | Named of Ident.t option * modtype 131 131 + 132 132 + 133 133 + val of_module_decl : Types.module_declaration -> module_decl 134 134 + val of_modtype : Types.module_type -> modtype 135 135 + val of_modtype_decl : Types.modtype_declaration -> modtype_declaration 136 136 + val of_signature : Types.signature -> signature 137 137 + val of_signature_items : signature_item list -> signature 138 138 + val of_signature_item : Types.signature_item -> signature_item 139 139 + 140 140 + val module_decl : scoping -> t -> module_decl -> module_decl 141 141 + val modtype : scoping -> t -> modtype -> modtype 142 142 + val modtype_decl : scoping -> t -> modtype_declaration -> modtype_declaration 143 143 + val signature : scoping -> t -> signature -> signature 144 144 + val signature_item : scoping -> t -> signature_item -> signature_item 145 145 + 146 146 + val force_module_decl : module_decl -> Types.module_declaration 147 147 + val force_modtype : modtype -> Types.module_type 148 148 + val force_modtype_decl : modtype_declaration -> Types.modtype_declaration 149 149 + val force_signature : signature -> Types.signature 150 150 + val force_signature_once : signature -> signature_item list 151 151 + val force_signature_item : signature_item -> Types.signature_item 152 152 + end

+89 -50

typing/typecore.ml

reviewed

··· 955 955 956 956 (* warn if there are several distinct candidates in scope *) 957 957 let warn_if_ambiguous warn lid env lbl rest = 958 958 - Printtyp.Conflicts.reset (); 959 959 - let paths = ambiguous_types env lbl rest in 960 960 - let expansion = 961 961 - Format.asprintf "%t" Printtyp.Conflicts.print_explanations in 962 962 - if paths <> [] then 963 963 - warn lid.loc 964 964 - (Warnings.Ambiguous_name ([Longident.last lid.txt], 965 965 - paths, false, expansion)) 958 958 + if Warnings.is_active (Ambiguous_name ([],[],false,"")) then begin 959 959 + Printtyp.Conflicts.reset (); 960 960 + let paths = ambiguous_types env lbl rest in 961 961 + let expansion = 962 962 + Format.asprintf "%t" Printtyp.Conflicts.print_explanations in 963 963 + if paths <> [] then 964 964 + warn lid.loc 965 965 + (Warnings.Ambiguous_name ([Longident.last lid.txt], 966 966 + paths, false, expansion)) 967 967 + end 966 968 967 969 (* a non-principal type was used for disambiguation *) 968 970 let warn_non_principal warn lid = ··· 973 975 974 976 (* we selected a name out of the lexical scope *) 975 977 let warn_out_of_scope warn lid env tpath = 976 976 - let path_s = 977 977 - Printtyp.wrap_printing_env ~error:true env 978 978 - (fun () -> Printtyp.string_of_path tpath) in 979 979 - warn lid.loc 980 980 - (Warnings.Name_out_of_scope (path_s, [Longident.last lid.txt], false)) 978 978 + if Warnings.is_active (Name_out_of_scope ("",[],false)) then begin 979 979 + let path_s = 980 980 + Printtyp.wrap_printing_env ~error:true env 981 981 + (fun () -> Printtyp.string_of_path tpath) in 982 982 + warn lid.loc 983 983 + (Warnings.Name_out_of_scope (path_s, [Longident.last lid.txt], false)) 984 984 + end 981 985 982 986 (* warn if the selected name is not the last introduced in scope 983 987 -- in these cases the resolution is different from pre-disambiguation OCaml ··· 2516 2520 List.iter generalize vars; 2517 2521 check_univars env kind exp ty_expected vars 2518 2522 2519 2519 - let check_partial_application statement exp = 2520 2520 - let rec f delay = 2523 2523 + (* [check_statement] implements the [non-unit-statement] check. 2524 2524 + 2525 2525 + This check is called in contexts where the value of the expression is known 2526 2526 + to be discarded (eg. the lhs of a sequence). We check that [exp] has type 2527 2527 + unit, or has an explicit type annotation; otherwise we raise the 2528 2528 + [non-unit-statement] warning. *) 2529 2529 + 2530 2530 + let check_statement exp = 2531 2531 + let ty = get_desc (expand_head exp.exp_env exp.exp_type) in 2532 2532 + match ty with 2533 2533 + | Tconstr (p, _, _) when Path.same p Predef.path_unit -> () 2534 2534 + | Tvar _ -> () 2535 2535 + | _ -> 2536 2536 + let rec loop {exp_loc; exp_desc; exp_extra; _} = 2537 2537 + match exp_desc with 2538 2538 + | Texp_let (_, _, e) 2539 2539 + | Texp_sequence (_, e) 2540 2540 + | Texp_letexception (_, e) 2541 2541 + | Texp_letmodule (_, _, _, _, e) -> 2542 2542 + loop e 2543 2543 + | _ -> 2544 2544 + let loc = 2545 2545 + match List.find_opt (function 2546 2546 + | (Texp_constraint _, _, _) -> true 2547 2547 + | _ -> false) exp_extra 2548 2548 + with 2549 2549 + | Some (_, loc, _) -> loc 2550 2550 + | None -> exp_loc 2551 2551 + in 2552 2552 + Location.prerr_warning loc Warnings.Non_unit_statement 2553 2553 + in 2554 2554 + loop exp 2555 2555 + 2556 2556 + 2557 2557 + (* [check_partial_application] implements the [ignored-partial-application] 2558 2558 + warning (and if [statement] is [true], also [non-unit-statement]). 2559 2559 + 2560 2560 + If [exp] has a function type, we check that it is not syntactically the 2561 2561 + result of a function application, as this is often a bug in certain contexts 2562 2562 + (eg the rhs of a let-binding or in the argument of [ignore]). For example, 2563 2563 + [ignore (List.map print_int)] written by mistake instad of [ignore (List.map 2564 2564 + print_int li)]. 2565 2565 + 2566 2566 + The check can be disabled by explicitly annotating the expression with a type 2567 2567 + constraint, eg [(e : _ -> _)]. 2568 2568 + 2569 2569 + If [statement] is [true] and the [ignored-partial-application] is {em not} 2570 2570 + triggered, then the [non-unit-statement] check is performaed (see 2571 2571 + [check_statement]). 2572 2572 + 2573 2573 + If the type of [exp] is not known at the time this function is called, the 2574 2574 + check is retried again after typechecking. *) 2575 2575 + 2576 2576 + let check_partial_application ~statement exp = 2577 2577 + let check_statement () = if statement then check_statement exp in 2578 2578 + let doit () = 2521 2579 let ty = get_desc (expand_head exp.exp_env exp.exp_type) in 2522 2522 - let check_statement () = 2523 2523 - match ty with 2524 2524 - | Tconstr (p, _, _) when Path.same p Predef.path_unit -> 2525 2525 - () 2526 2526 - | _ -> 2527 2527 - if statement then 2528 2528 - let rec loop {exp_loc; exp_desc; exp_extra; _} = 2529 2529 - match exp_desc with 2530 2530 - | Texp_let (_, _, e) 2531 2531 - | Texp_sequence (_, e) 2532 2532 - | Texp_letexception (_, e) 2533 2533 - | Texp_letmodule (_, _, _, _, e) -> 2534 2534 - loop e 2535 2535 - | _ -> 2536 2536 - let loc = 2537 2537 - match List.find_opt (function 2538 2538 - | (Texp_constraint _, _, _) -> true 2539 2539 - | _ -> false) exp_extra 2540 2540 - with 2541 2541 - | Some (_, loc, _) -> loc 2542 2542 - | None -> exp_loc 2543 2543 - in 2544 2544 - Location.prerr_warning loc Warnings.Non_unit_statement 2545 2545 - in 2546 2546 - loop exp 2547 2547 - in 2548 2548 - match ty, exp.exp_desc with 2549 2549 - | Tarrow _, _ -> 2580 2580 + match ty with 2581 2581 + | Tarrow _ -> 2550 2582 let rec check {exp_desc; exp_loc; exp_extra; _} = 2551 2583 if List.exists (function 2552 2584 | (Texp_constraint _, _, _) -> true ··· 2578 2610 end 2579 2611 in 2580 2612 check exp 2581 2581 - | Tvar _, _ -> 2582 2582 - if delay then add_delayed_check (fun () -> f false) 2583 2613 | _ -> 2584 2614 check_statement () 2585 2615 in 2586 2586 - f true 2616 2616 + let ty = get_desc (expand_head exp.exp_env exp.exp_type) in 2617 2617 + match ty with 2618 2618 + | Tvar _ -> 2619 2619 + (* The type of [exp] is not known. Delay the check until after 2620 2620 + typechecking in order to give a chance for the type to become known 2621 2621 + through unification. *) 2622 2622 + add_delayed_check doit 2623 2623 + | _ -> 2624 2624 + doit () 2587 2625 2588 2626 (* Check that a type is generalizable at some level *) 2589 2627 let generalizable level ty = ··· 3001 3039 try rue exp 3002 3040 with Error (_, _, Expr_type_clash _) as err -> 3003 3041 Misc.reraise_preserving_backtrace err (fun () -> 3004 3004 - check_partial_application false exp) 3042 3042 + check_partial_application ~statement:false exp) 3005 3043 end 3006 3044 | Pexp_match(sarg, caselist) -> 3007 3045 begin_def (); ··· 4644 4682 [Nolabel, sarg] when is_ignore funct -> 4645 4683 let ty_arg, ty_res = filter_arrow env (instance funct.exp_type) Nolabel in 4646 4684 let exp = type_expect env sarg (mk_expected ty_arg) in 4647 4647 - check_partial_application false exp; 4685 4685 + check_partial_application ~statement:false exp; 4648 4686 ([Nolabel, Some exp], ty_res) 4649 4687 | _ -> 4650 4688 let ty = funct.exp_type in ··· 4752 4790 unify_exp env exp expected_ty); 4753 4791 exp 4754 4792 else begin 4755 4755 - check_partial_application true exp; 4793 4793 + check_partial_application ~statement:true exp; 4756 4794 unify_var env tv ty; 4757 4795 exp 4758 4796 end 4759 4797 4760 4798 and type_unpacks ?(in_function : (Location.t * type_expr) option) 4761 4799 env (unpacks : to_unpack list) sbody expected_ty = 4800 4800 + if unpacks = [] then type_expect ?in_function env sbody expected_ty else 4762 4801 let ty = newvar() in 4763 4802 (* remember original level *) 4764 4803 let extended_env, tunpacks = ··· 5308 5347 | {vb_pat = {pat_desc = Tpat_any; pat_extra; _}; vb_expr; _} -> 5309 5348 if not (List.exists (function (Tpat_constraint _, _, _) -> true 5310 5349 | _ -> false) pat_extra) then 5311 5311 - check_partial_application false vb_expr 5350 5350 + check_partial_application ~statement:false vb_expr 5312 5351 | _ -> ()) l; 5313 5352 (l, new_env, unpacks) 5314 5353

+21 -19

typing/typemod.ml

reviewed

··· 767 767 let rec approx_modtype env smty = 768 768 match smty.pmty_desc with 769 769 Pmty_ident lid -> 770 770 - let (path, _info) = 771 771 - Env.lookup_modtype ~use:false ~loc:smty.pmty_loc lid.txt env 770 770 + let path = 771 771 + Env.lookup_modtype_path ~use:false ~loc:smty.pmty_loc lid.txt env 772 772 in 773 773 Mty_ident path 774 774 | Pmty_alias lid -> ··· 809 809 | Pwith_module (_, lid') -> 810 810 (* Lookup the module to make sure that it is not recursive. 811 811 (GPR#1626) *) 812 812 - ignore (Env.lookup_module ~use:false ~loc:lid'.loc lid'.txt env) 812 812 + ignore (Env.lookup_module_path ~use:false ~load:false 813 813 + ~loc:lid'.loc lid'.txt env) 813 814 | Pwith_modsubst (_, lid') -> 814 814 - ignore (Env.lookup_module ~use:false ~loc:lid'.loc lid'.txt env)) 815 815 + ignore (Env.lookup_module_path ~use:false ~load:false 816 816 + ~loc:lid'.loc lid'.txt env)) 815 817 constraints; 816 818 body 817 819 | Pmty_typeof smod -> ··· 1262 1264 (* Check and translate a module type expression *) 1263 1265 1264 1266 let transl_modtype_longident loc env lid = 1265 1265 - let (path, _info) = Env.lookup_modtype ~loc lid env in 1266 1266 - path 1267 1267 + Env.lookup_modtype_path ~loc lid env 1267 1268 1268 1269 let transl_module_alias loc env lid = 1269 1270 Env.lookup_module_path ~load:false ~loc lid env ··· 2104 2105 mod_attributes = smod.pmod_attributes; 2105 2106 mod_loc = smod.pmod_loc } in 2106 2107 let aliasable = not (Env.is_functor_arg path env) in 2107 2107 - let md = 2108 2108 - if alias && aliasable then 2109 2109 - (Env.add_required_global (Path.head path); md) 2110 2110 - else match (Env.find_module path env).md_type with 2108 2108 + if alias && aliasable then 2109 2109 + (Env.add_required_global (Path.head path); md) 2110 2110 + else begin 2111 2111 + let mty = 2112 2112 + if sttn then 2113 2113 + Env.find_strengthened_module ~aliasable path env 2114 2114 + else 2115 2115 + (Env.find_module path env).md_type 2116 2116 + in 2117 2117 + match mty with 2111 2118 | Mty_alias p1 when not alias -> 2112 2119 let p1 = Env.normalize_module_path (Some smod.pmod_loc) env p1 in 2113 2113 - let mty = Includemod.expand_module_alias env p1 in 2120 2120 + let mty = Includemod.expand_module_alias 2121 2121 + ~strengthen:sttn env p1 in 2114 2122 { md with 2115 2123 mod_desc = 2116 2124 Tmod_constraint (md, mty, Tmodtype_implicit, 2117 2125 Tcoerce_alias (env, path, Tcoerce_none)); 2118 2118 - mod_type = 2119 2119 - if sttn then Mtype.strengthen ~aliasable:true env mty p1 2120 2120 - else mty } 2126 2126 + mod_type = mty } 2121 2127 | mty -> 2122 2122 - let mty = 2123 2123 - if sttn then Mtype.strengthen ~aliasable env mty path 2124 2124 - else mty 2125 2125 - in 2126 2128 { md with mod_type = mty } 2127 2127 - in md 2129 2129 + end 2128 2130 | Pmod_structure sstr -> 2129 2131 let (str, sg, names, _finalenv) = 2130 2132 type_structure funct_body anchor env sstr in

+9 -6

typing/untypeast.ml

reviewed

··· 331 331 | Tpat_tuple list -> 332 332 Ppat_tuple (List.map (sub.pat sub) list) 333 333 | Tpat_construct (lid, _, args, vto) -> 334 334 - let vl, tyo = 334 334 + let tyo = 335 335 match vto with 336 336 - None -> [], None 336 336 + None -> None 337 337 | Some (vl, ty) -> 338 338 - List.map (fun x -> {x with txt = Ident.name x.txt}) vl, 339 339 - Some (sub.typ sub ty) 338 338 + let vl = 339 339 + List.map (fun x -> {x with txt = Ident.name x.txt}) vl 340 340 + in 341 341 + Some (vl, sub.typ sub ty) 340 342 in 341 343 let arg = 342 344 match args with ··· 346 348 in 347 349 Ppat_construct (map_loc sub lid, 348 350 match tyo, arg with 349 349 - | Some ty, Some arg -> 351 351 + | Some (vl, ty), Some arg -> 350 352 Some (vl, Pat.mk ~loc (Ppat_constraint (arg, ty))) 351 351 - | _ -> None) 353 353 + | None, Some arg -> Some ([], arg) 354 354 + | _, None -> None) 352 355 | Tpat_variant (label, pato, _) -> 353 356 Ppat_variant (label, Option.map (sub.pat sub) pato) 354 357 | Tpat_record (list, closed) ->

+6

utils/lazy_backtrack.ml

reviewed

··· 42 42 let get_arg x = 43 43 match !x with Thunk a -> Some a | _ -> None 44 44 45 45 + let get_contents x = 46 46 + match !x with 47 47 + | Thunk a -> Either.Left a 48 48 + | Done b -> Either.Right b 49 49 + | Raise e -> raise e 50 50 + 45 51 let create x = 46 52 ref (Thunk x) 47 53

+1

utils/lazy_backtrack.mli

reviewed

··· 20 20 val force : ('a -> 'b) -> ('a,'b) t -> 'b 21 21 val create : 'a -> ('a,'b) t 22 22 val get_arg : ('a,'b) t -> 'a option 23 23 + val get_contents : ('a,'b) t -> ('a,'b) Either.t 23 24 val create_forced : 'b -> ('a, 'b) t 24 25 val create_failed : exn -> ('a, 'b) t 25 26

+1

yacc/defs.h

reviewed

··· 30 30 #include "caml/config.h" 31 31 #include "caml/mlvalues.h" 32 32 #include "caml/osdeps.h" 33 33 + #include "caml/misc.h" 33 34 34 35 #define caml_stat_strdup strdup 35 36

+1 -5

yacc/main.c

reviewed

··· 420 420 open_error(interface_file_name); 421 421 } 422 422 423 423 - #ifdef _WIN32 424 424 - int wmain(int argc, wchar_t **argv) 425 425 - #else 426 426 - int main(int argc, char **argv) 427 427 - #endif 423 423 + int main_os(int argc, char_os **argv) 428 424 { 429 425 set_signals(); 430 426 getargs(argc, argv);