summaryrefslogtreecommitdiffstats
path: root/tools
diff options
context:
space:
mode:
Diffstat (limited to 'tools')
-rw-r--r--tools/.depend24
-rw-r--r--tools/.ignore3
-rw-r--r--tools/Makefile2
-rw-r--r--tools/Makefile.nt2
-rw-r--r--tools/Makefile.shared38
-rwxr-xr-xtools/check-typo33
-rwxr-xr-xtools/ci-build159
-rw-r--r--tools/cmt2annot.ml16
-rw-r--r--tools/depend.ml87
-rw-r--r--tools/depend.mli2
-rw-r--r--tools/dumpobj.ml12
-rw-r--r--tools/eqparsetree.ml10
-rwxr-xr-xtools/make-package-macosx2
-rwxr-xr-xtools/make-version-header.sh20
-rw-r--r--tools/objinfo.ml54
-rw-r--r--tools/objinfo_helper.c5
-rw-r--r--tools/ocamlcp.ml11
-rw-r--r--tools/ocamldep.ml59
-rw-r--r--tools/ocamlmklib.ml10
-rw-r--r--tools/ocamloptp.ml13
-rw-r--r--tools/ocamlprof.ml21
-rw-r--r--tools/profiling.ml2
-rw-r--r--tools/read_cmt.ml42
-rw-r--r--tools/tast_iter.ml55
-rw-r--r--tools/tast_iter.mli4
-rw-r--r--tools/untypeast.ml198
-rw-r--r--tools/untypeast.mli3
27 files changed, 647 insertions, 240 deletions
diff --git a/tools/.depend b/tools/.depend
index a058ee37f..b0407009d 100644
--- a/tools/.depend
+++ b/tools/.depend
@@ -28,25 +28,25 @@ depend.cmx : ../parsing/parsetree.cmi ../utils/misc.cmx \
../parsing/longident.cmx ../parsing/location.cmx ../parsing/asttypes.cmi \
depend.cmi
dumpobj.cmo : ../utils/tbl.cmi opnames.cmo ../bytecomp/opcodes.cmo \
- ../utils/misc.cmi ../parsing/location.cmi ../bytecomp/lambda.cmi \
- ../bytecomp/instruct.cmi ../typing/ident.cmi ../utils/config.cmi \
- ../bytecomp/cmo_format.cmi ../bytecomp/bytesections.cmi \
- ../parsing/asttypes.cmi
+ ../parsing/location.cmi ../bytecomp/lambda.cmi ../bytecomp/instruct.cmi \
+ ../typing/ident.cmi ../utils/config.cmi ../bytecomp/cmo_format.cmi \
+ ../bytecomp/bytesections.cmi ../parsing/asttypes.cmi
dumpobj.cmx : ../utils/tbl.cmx opnames.cmx ../bytecomp/opcodes.cmx \
- ../utils/misc.cmx ../parsing/location.cmx ../bytecomp/lambda.cmx \
- ../bytecomp/instruct.cmx ../typing/ident.cmx ../utils/config.cmx \
- ../bytecomp/cmo_format.cmi ../bytecomp/bytesections.cmx \
- ../parsing/asttypes.cmi
+ ../parsing/location.cmx ../bytecomp/lambda.cmx ../bytecomp/instruct.cmx \
+ ../typing/ident.cmx ../utils/config.cmx ../bytecomp/cmo_format.cmi \
+ ../bytecomp/bytesections.cmx ../parsing/asttypes.cmi
eqparsetree.cmo : ../parsing/parsetree.cmi ../parsing/longident.cmi \
../parsing/location.cmi ../parsing/asttypes.cmi
eqparsetree.cmx : ../parsing/parsetree.cmi ../parsing/longident.cmx \
../parsing/location.cmx ../parsing/asttypes.cmi
objinfo.cmo : ../asmcomp/printclambda.cmi ../utils/misc.cmi \
- ../utils/config.cmi ../asmcomp/cmx_format.cmi ../bytecomp/cmo_format.cmi \
- ../typing/cmi_format.cmi ../bytecomp/bytesections.cmi
+ ../utils/config.cmi ../asmcomp/cmx_format.cmi ../typing/cmt_format.cmi \
+ ../bytecomp/cmo_format.cmi ../typing/cmi_format.cmi \
+ ../bytecomp/bytesections.cmi
objinfo.cmx : ../asmcomp/printclambda.cmx ../utils/misc.cmx \
- ../utils/config.cmx ../asmcomp/cmx_format.cmi ../bytecomp/cmo_format.cmi \
- ../typing/cmi_format.cmx ../bytecomp/bytesections.cmx
+ ../utils/config.cmx ../asmcomp/cmx_format.cmi ../typing/cmt_format.cmx \
+ ../bytecomp/cmo_format.cmi ../typing/cmi_format.cmx \
+ ../bytecomp/bytesections.cmx
ocaml299to3.cmo :
ocaml299to3.cmx :
ocamlcp.cmo : ../driver/main_args.cmi
diff --git a/tools/.ignore b/tools/.ignore
index ce14846de..94fac02fb 100644
--- a/tools/.ignore
+++ b/tools/.ignore
@@ -18,11 +18,10 @@ keywords
lexer299.ml
ocaml299to3
ocamlmklib
-ocamlmklib.ml
+ocamlmklibconfig.ml
lexer301.ml
scrapelabels
addlabels
-myocamlbuild_config.ml
objinfo_helper
read_cmt
read_cmt.opt
diff --git a/tools/Makefile b/tools/Makefile
index e2f3cb26e..b5cc10109 100644
--- a/tools/Makefile
+++ b/tools/Makefile
@@ -19,7 +19,7 @@ ocamlmktop: ocamlmktop.tpl ../config/Makefile
chmod +x ocamlmktop
install::
- cp ocamlmktop $(BINDIR)
+ cp ocamlmktop $(INSTALL_BINDIR)
clean::
rm -f ocamlmktop
diff --git a/tools/Makefile.nt b/tools/Makefile.nt
index 052af81c2..ed9b35946 100644
--- a/tools/Makefile.nt
+++ b/tools/Makefile.nt
@@ -21,7 +21,7 @@ ocamlmktop: $(OCAMLMKTOP)
$(CAMLC) $(LINKFLAGS) -o ocamlmktop $(OCAMLMKTOP_IMPORTS) $(OCAMLMKTOP)
install::
- cp ocamlmktop $(BINDIR)/ocamlmktop$(EXE)
+ cp ocamlmktop $(INSTALL_BINDIR)/ocamlmktop$(EXE)
clean::
rm -f ocamlmktop$(EXE)
diff --git a/tools/Makefile.shared b/tools/Makefile.shared
index 39be1db4e..251743449 100644
--- a/tools/Makefile.shared
+++ b/tools/Makefile.shared
@@ -13,12 +13,12 @@
include ../config/Makefile
CAMLRUN=../boot/ocamlrun
-CAMLC=$(CAMLRUN) ../boot/ocamlc -strict-sequence -nostdlib -I ../boot
+CAMLC=$(CAMLRUN) ../boot/ocamlc -nostdlib -I ../boot
CAMLOPT=$(CAMLRUN) ../ocamlopt -nostdlib -I ../stdlib
CAMLLEX=$(CAMLRUN) ../boot/ocamllex
INCLUDES=-I ../utils -I ../parsing -I ../typing -I ../bytecomp -I ../asmcomp \
-I ../driver -I ../toplevel
-COMPFLAGS= -w +32..39 -warn-error A $(INCLUDES)
+COMPFLAGS= -strict-sequence -w +27+32..39 -warn-error A -safe-string $(INCLUDES)
LINKFLAGS=$(INCLUDES)
all: ocamldep ocamlprof ocamlcp ocamloptp ocamlmktop ocamlmklib dumpobj \
@@ -39,7 +39,7 @@ CAMLDEP_OBJ=depend.cmo ocamldep.cmo
CAMLDEP_IMPORTS=misc.cmo config.cmo clflags.cmo terminfo.cmo \
warnings.cmo location.cmo longident.cmo \
syntaxerr.cmo ast_helper.cmo parser.cmo lexer.cmo parse.cmo \
- ccomp.cmo pparse.cmo compenv.cmo
+ ccomp.cmo ast_mapper.cmo pparse.cmo compenv.cmo
ocamldep: depend.cmi $(CAMLDEP_OBJ)
$(CAMLC) $(LINKFLAGS) -compat-32 -o ocamldep $(CAMLDEP_IMPORTS) $(CAMLDEP_OBJ)
@@ -54,10 +54,14 @@ clean::
if test -f ocamldep; then mv -f ocamldep ocamldep.bak; else :; fi
rm -f ocamldep.opt
+
+INSTALL_BINDIR=$(DESTDIR)$(BINDIR)
+INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR)
+
install::
- cp ocamldep $(BINDIR)/ocamldep$(EXE)
+ cp ocamldep $(INSTALL_BINDIR)/ocamldep$(EXE)
if test -f ocamldep.opt; \
- then cp ocamldep.opt $(BINDIR)/ocamldep.opt$(EXE); else :; fi
+ then cp ocamldep.opt $(INSTALL_BINDIR)/ocamldep.opt$(EXE); else :; fi
# The profiler
@@ -79,13 +83,13 @@ ocamloptp: ocamloptp.cmo
opt:: profiling.cmx
install::
- cp ocamlprof $(BINDIR)/ocamlprof$(EXE)
- cp ocamlcp $(BINDIR)/ocamlcp$(EXE)
- cp ocamloptp $(BINDIR)/ocamloptp$(EXE)
- cp profiling.cmi profiling.cmo $(LIBDIR)
+ cp ocamlprof $(INSTALL_BINDIR)/ocamlprof$(EXE)
+ cp ocamlcp $(INSTALL_BINDIR)/ocamlcp$(EXE)
+ cp ocamloptp $(INSTALL_BINDIR)/ocamloptp$(EXE)
+ cp profiling.cmi profiling.cmo $(INSTALL_LIBDIR)
installopt::
- cp profiling.cmx profiling.o $(LIBDIR)
+ cp profiling.cmx profiling.$(O) $(INSTALL_LIBDIR)
clean::
rm -f ocamlprof ocamlcp ocamloptp
@@ -97,7 +101,7 @@ ocamlmklib: ocamlmklibconfig.cmo ocamlmklib.cmo
$(CAMLC) $(LINKFLAGS) -o ocamlmklib ocamlmklibconfig.cmo ocamlmklib.cmo
install::
- cp ocamlmklib $(BINDIR)/ocamlmklib$(EXE)
+ cp ocamlmklib $(INSTALL_BINDIR)/ocamlmklib$(EXE)
clean::
rm -f ocamlmklib
@@ -132,7 +136,7 @@ lexer299.ml: lexer299.mll
$(CAMLLEX) lexer299.mll
#install::
-# cp ocaml299to3 $(BINDIR)/ocaml299to3$(EXE)
+# cp ocaml299to3 $(INSTALL_BINDIR)/ocaml299to3$(EXE)
clean::
rm -f ocaml299to3 lexer299.ml
@@ -148,7 +152,7 @@ lexer301.ml: lexer301.mll
$(CAMLLEX) lexer301.mll
#install::
-# cp scrapelabels $(LIBDIR)
+# cp scrapelabels $(INSTALL_LIBDIR)
clean::
rm -f scrapelabels lexer301.ml
@@ -164,7 +168,7 @@ addlabels: addlabels.cmo
$(ADDLABELS_IMPORTS) addlabels.cmo
#install::
-# cp addlabels $(LIBDIR)
+# cp addlabels $(INSTALL_LIBDIR)
clean::
rm -f addlabels
@@ -260,7 +264,7 @@ opnames.ml: ../byterun/instruct.h
sed -e '/\/\*/d' \
-e '/^#/d' \
-e 's/enum \(.*\) {/let names_of_\1 = [|/' \
- -e 's/};$$/ |]/' \
+ -e 's/.*};$$/ |]/' \
-e 's/\([A-Z][A-Z_0-9a-z]*\)/"\1"/g' \
-e 's/,/;/g' \
../byterun/instruct.h > opnames.ml
@@ -285,8 +289,8 @@ objinfo: objinfo_helper$(EXE) $(OBJINFO)
$(CAMLC) -o objinfo $(OBJINFO)
install::
- cp objinfo $(BINDIR)/ocamlobjinfo$(EXE)
- cp objinfo_helper$(EXE) $(LIBDIR)/objinfo_helper$(EXE)
+ cp objinfo $(INSTALL_BINDIR)/ocamlobjinfo$(EXE)
+ cp objinfo_helper$(EXE) $(INSTALL_LIBDIR)/objinfo_helper$(EXE)
clean::
rm -f objinfo objinfo_helper$(EXE)
diff --git a/tools/check-typo b/tools/check-typo
index 05c7c68c0..bd48dc7a3 100755
--- a/tools/check-typo
+++ b/tools/check-typo
@@ -23,6 +23,7 @@
# - absence of empty lines at end of file (white-at-eof)
# - presence of a LF character at the end of the file (missing-lf)
# - maximum line length of 80 characters (long-line)
+# - maximum line length of 132 characters (very-long-line)
# - presence of a copyright header (missing-header)
# - absence of a leftover "$Id" string (svn-keyword)
@@ -34,22 +35,24 @@
# Built-in exceptions:
# - Any binary file (i.e. with svn:mime-type = application/octet-stream)
# is automatically exempt from all the rules.
+# - Any file whose name matches one of the following patterns is
+# automatically exempt from all rules
+# *.reference
+# */reference
+# */.depend*
# - Any file whose name begins with "Makefile" is automatically exempt
# from the "tabs" rule.
# - Any file whose name matches one of the following patterns is
# automatically exempt from the "missing-header" rule.
-# */.depend*
# */.ignore
# *.mlpack
# *.mllib
# *.mltop
# *.odocl
# *.clib
-# *.reference
-# */reference
-# - Any file whose name matches one of the following patterns is
-# automatically exempt from the "long-line" rule.
-# *.reference
+# - Any file whose name matches the following pattern is automatically
+# exempt from the "long-line" rule (but not from "very-long-line").
+# */ocamldoc/*
# ASCII characters are bytes from 0 to 127. Any other byte is
# flagged as a non-ASCII character.
@@ -131,17 +134,15 @@ IGNORE_DIRS="
svnrules=`svn propget ocaml:typo "$f"`
fi
rules="$userrules"
+ add_hd(){ rules="missing-header,$rules"; }
case "$f" in
Makefile*|*/Makefile*) rules="tab,$rules";;
- esac
- h(){ rules="missing-header,$rules"; }
- case "$f" in
- */.depend*|*/.ignore) h;;
- *.mlpack|*.mllib|*.mltop|*.odocl|*.itarget|*.clib) h;;
- *.reference|*/reference) h;;
+ */.ignore) add_hd;;
+ *.mlpack|*.mllib|*.mltop|*.odocl|*.itarget|*.clib) add_hd;;
+ *.reference|*/reference|*/.depend*) continue;;
esac
case "$f" in
- *.reference) rules="long-line,$rules";;
+ ocamldoc/*|*/ocamldoc/*) rules="long-line,$rules";;
esac
(cat "$f"; echo) \
@@ -186,6 +187,12 @@ IGNORE_DIRS="
err("long-line", "line is over 80 characters");
}
+ length($0) > 132 {
+ RSTART = 133;
+ RLENGTH = 0;
+ err("very-long-line", "line is over 132 characters");
+ }
+
3 <= NR && NR <= 5 \
&& (/ OCaml / || / ocamlbuild / || / OCamldoc /) {
header_ocaml = NR;
diff --git a/tools/ci-build b/tools/ci-build
new file mode 100755
index 000000000..4bb2593eb
--- /dev/null
+++ b/tools/ci-build
@@ -0,0 +1,159 @@
+#!/bin/sh
+#########################################################################
+# #
+# OCaml #
+# #
+# Damien Doligez, projet Gallium, INRIA Rocquencourt #
+# #
+# Copyright 2014 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
+# This script is run on our continuous-integration servers to recompile
+# from scratch and run the test suite.
+
+# arguments:
+# 1. architecture: bsd, macos, linux, cygwin, mingw, mingw64, msvc, msvc64
+# 2. directory in which to build (trunk, 4.02, etc)
+# for windows, this is relative to $HOME/jenkins-workspace
+# for bsd, macos, linux, this is "." or an absolute directory
+# 3. options:
+# -conf configure-option
+# -patch1 file-name apply patch with -p1
+
+error () {
+ echo "$1" >&2
+ exit 3
+}
+
+#########################################################################
+# be verbose
+set -x
+
+#########################################################################
+# "Parse" mandatory command-line arguments.
+
+arch="$1"
+branch="$2"
+shift 2
+
+#########################################################################
+# If we are called from a Windows batch script, we must set up the
+# Unix environment variables (e.g. PATH).
+
+case "$arch" in
+ bsd|macos|linux) ;;
+ cygwin|mingw|mingw64)
+ . /etc/profile
+ . "$HOME/.profile"
+ ;;
+ msvc)
+ . /etc/profile
+ . "$HOME/.profile"
+ . "$HOME/.msenv32"
+ ;;
+ msvc64)
+ . /etc/profile
+ . "$HOME/.profile"
+ . "$HOME/.msenv64"
+ ;;
+ *) error "unknown architecture: $arch";;
+esac
+
+#########################################################################
+
+# be verbose and stop on error
+set -ex
+
+#########################################################################
+# set up variables
+
+# default values
+make=make
+instdir="$HOME/ocaml-tmp-install"
+workdir="$branch"
+docheckout=false
+nt=
+
+case "$arch" in
+ bsd)
+ make=gmake
+ ;;
+ macos) ;;
+ linux) ;;
+ cygwin)
+ workdir="$HOME/jenkins-workspace/$branch"
+ docheckout=true
+ ;;
+ mingw)
+ instdir=/cygdrive/c/ocamlmgw
+ workdir="$HOME/jenkins-workspace/$branch"
+ docheckout=true
+ nt=.nt
+ ;;
+ mingw64)
+ instdir=/cygdrive/c/ocamlmgw64
+ workdir="$HOME/jenkins-workspace/$branch"
+ docheckout=true
+ nt=.nt
+ ;;
+ msvc)
+ instdir=/cygdrive/c/ocamlms
+ workdir="$HOME/jenkins-workspace/$branch"
+ docheckout=true
+ nt=.nt
+ ;;
+ msvc64)
+ instdir=/cygdrive/c/ocamlms64
+ workdir="$HOME/jenkins-workspace/$branch"
+ docheckout=true
+ nt=.nt
+ ;;
+ *) error "unknown architecture: $arch";;
+esac
+
+#########################################################################
+# Go to the right directory
+
+cd "$workdir"
+
+#########################################################################
+# parse optional command-line arguments (has to be done after the "cd")
+# Configure options are not allowed to have spaces or special characters
+# for the moment. We'll fix that when needed.
+confoptions=""
+while [ $# -gt 0 ]; do
+ case $1 in
+ -conf) confoptions="$confoptions $2"; shift 2;;
+ -patch1) patch -f -p1 <"$2"; shift 2;;
+ *) error "unknown option $1";;
+ esac
+done
+
+#########################################################################
+# Do the work
+
+$make -f Makefile$nt distclean || :
+
+if $docheckout; then
+ svn update --accept theirs-full
+fi
+
+case $nt in
+ "") ./configure -prefix "$instdir" $confoptions;;
+ .nt)
+ cp config/m-nt.h config/m.h
+ cp config/s-nt.h config/s.h
+ cp config/Makefile.$arch config/Makefile
+ ;;
+ *) error "internal error";;
+esac
+
+$make -f Makefile$nt world.opt
+$make -f Makefile$nt install
+
+rm -rf "$instdir"
+cd testsuite
+$make all
diff --git a/tools/cmt2annot.ml b/tools/cmt2annot.ml
index a7c5a005f..36ca187ca 100644
--- a/tools/cmt2annot.ml
+++ b/tools/cmt2annot.ml
@@ -87,8 +87,10 @@ let iterator rebuild_env =
bind_bindings exp.exp_loc bindings
| Texp_let (Nonrecursive, bindings, body) ->
bind_bindings body.exp_loc bindings
+ | Texp_match (_, f1, f2, _) ->
+ bind_cases f1;
+ bind_cases f2
| Texp_function (_, f, _)
- | Texp_match (_, f, _)
| Texp_try (_, f) ->
bind_cases f
| _ -> ()
@@ -154,7 +156,7 @@ let gen_annot target_filename filename
match target_filename with
| None -> Some (filename ^ ".annot")
| Some "-" -> None
- | Some filename -> target_filename
+ | Some _ -> target_filename
in
let iterator = iterator cmt_use_summaries in
match cmt_annots with
@@ -177,9 +179,13 @@ let gen_ml target_filename filename cmt =
let (printer, ext) =
match cmt.Cmt_format.cmt_annots with
| Cmt_format.Implementation typedtree ->
- (fun ppf -> Pprintast.structure ppf (Untypeast.untype_structure typedtree)), ".ml"
+ (fun ppf -> Pprintast.structure ppf
+ (Untypeast.untype_structure typedtree)),
+ ".ml"
| Cmt_format.Interface typedtree ->
- (fun ppf -> Pprintast.signature ppf (Untypeast.untype_signature typedtree)), ".mli"
+ (fun ppf -> Pprintast.signature ppf
+ (Untypeast.untype_signature typedtree)),
+ ".mli"
| _ ->
Printf.fprintf stderr "File was generated with an error\n%!";
exit 2
@@ -187,7 +193,7 @@ let gen_ml target_filename filename cmt =
let target_filename = match target_filename with
None -> Some (filename ^ ext)
| Some "-" -> None
- | Some filename -> target_filename
+ | Some _ -> target_filename
in
let oc = match target_filename with
None -> None
diff --git a/tools/depend.ml b/tools/depend.ml
index 82c2db832..222d08d31 100644
--- a/tools/depend.ml
+++ b/tools/depend.ml
@@ -21,34 +21,35 @@ module StringSet = Set.Make(struct type t = string let compare = compare end)
let free_structure_names = ref StringSet.empty
-let rec addmodule bv lid =
- match lid with
- Lident s ->
+let rec add_path bv = function
+ | Lident s ->
if not (StringSet.mem s bv)
then free_structure_names := StringSet.add s !free_structure_names
- | Ldot(l, s) -> addmodule bv l
- | Lapply(l1, l2) -> addmodule bv l1; addmodule bv l2
+ | Ldot(l, _s) -> add_path bv l
+ | Lapply(l1, l2) -> add_path bv l1; add_path bv l2
+
+let open_module bv lid = add_path bv lid
let add bv lid =
match lid.txt with
- Ldot(l, s) -> addmodule bv l
+ Ldot(l, _s) -> add_path bv l
| _ -> ()
-let addmodule bv lid = addmodule bv lid.txt
+let addmodule bv lid = add_path bv lid.txt
let rec add_type bv ty =
match ty.ptyp_desc with
Ptyp_any -> ()
- | Ptyp_var v -> ()
+ | Ptyp_var _ -> ()
| Ptyp_arrow(_, t1, t2) -> add_type bv t1; add_type bv t2
| Ptyp_tuple tl -> List.iter (add_type bv) tl
| Ptyp_constr(c, tl) -> add bv c; List.iter (add_type bv) tl
- | Ptyp_object (fl, _) -> List.iter (fun (_, t) -> add_type bv t) fl
+ | Ptyp_object (fl, _) -> List.iter (fun (_, _, t) -> add_type bv t) fl
| Ptyp_class(c, tl) -> add bv c; List.iter (add_type bv) tl
- | Ptyp_alias(t, s) -> add_type bv t
+ | Ptyp_alias(t, _) -> add_type bv t
| Ptyp_variant(fl, _, _) ->
List.iter
- (function Rtag(_,_,stl) -> List.iter (add_type bv) stl
+ (function Rtag(_,_,_,stl) -> List.iter (add_type bv) stl
| Rinherit sty -> add_type bv sty)
fl
| Ptyp_poly(_, t) -> add_type bv t
@@ -63,11 +64,12 @@ let add_opt add_fn bv = function
None -> ()
| Some x -> add_fn bv x
-let add_constructor_decl bv pcd =
- begin match pcd.pcd_args with
+let add_constructor_arguments bv = function
| Pcstr_tuple l -> List.iter (add_type bv) l
| Pcstr_record l -> List.iter (fun l -> add_type bv l.pld_type) l
- end;
+
+let add_constructor_decl bv pcd =
+ add_constructor_arguments bv pcd.pcd_args;
Misc.may (add_type bv) pcd.pcd_res
let add_type_declaration bv td =
@@ -80,9 +82,21 @@ let add_type_declaration bv td =
| Ptype_variant cstrs ->
List.iter (add_constructor_decl bv) cstrs
| Ptype_record lbls ->
- List.iter (fun pld -> add_type bv pld.pld_type) lbls in
+ List.iter (fun pld -> add_type bv pld.pld_type) lbls
+ | Ptype_open -> () in
add_tkind td.ptype_kind
+let add_extension_constructor bv ext =
+ match ext.pext_kind with
+ Pext_decl(args, rty) ->
+ add_constructor_arguments bv args;
+ Misc.may (add_type bv) rty
+ | Pext_rebind lid -> add bv lid
+
+let add_type_extension bv te =
+ add bv te.ptyext_path;
+ List.iter (add_extension_constructor bv) te.ptyext_constructors
+
let rec add_class_type bv cty =
match cty.pcty_desc with
Pcty_constr(l, tyl) ->
@@ -100,6 +114,7 @@ and add_class_type_field bv pctf =
| Pctf_val(_, _, _, ty) -> add_type bv ty
| Pctf_method(_, _, _, ty) -> add_type bv ty
| Pctf_constraint(ty1, ty2) -> add_type bv ty1; add_type bv ty2
+ | Pctf_attribute _ -> ()
| Pctf_extension _ -> ()
let add_class_description bv infos =
@@ -127,6 +142,7 @@ let rec add_pattern bv pat =
| Ppat_type li -> add bv li
| Ppat_lazy p -> add_pattern bv p
| Ppat_unpack id -> pattern_bv := StringSet.add id.txt !pattern_bv
+ | Ppat_exception p -> add_pattern bv p
| Ppat_extension _ -> ()
let add_pattern bv pat =
@@ -170,10 +186,10 @@ let rec add_expr bv exp =
| Pexp_constraint(e1, ty2) ->
add_expr bv e1;
add_type bv ty2
- | Pexp_send(e, m) -> add_expr bv e
+ | Pexp_send(e, _m) -> add_expr bv e
| Pexp_new li -> add bv li
- | Pexp_setinstvar(v, e) -> add_expr bv e
- | Pexp_override sel -> List.iter (fun (s, e) -> add_expr bv e) sel
+ | Pexp_setinstvar(_v, e) -> add_expr bv e
+ | Pexp_override sel -> List.iter (fun (_s, e) -> add_expr bv e) sel
| Pexp_letmodule(id, m, e) ->
add_module bv m; add_expr (StringSet.add id.txt bv) e
| Pexp_assert (e) -> add_expr bv e
@@ -183,7 +199,7 @@ let rec add_expr bv exp =
let bv = add_pattern bv pat in List.iter (add_class_field bv) fieldl
| Pexp_newtype (_, e) -> add_expr bv e
| Pexp_pack m -> add_module bv m
- | Pexp_open (_ovf, m, e) -> addmodule bv m; add_expr bv e
+ | Pexp_open (_ovf, m, e) -> open_module bv m.txt; add_expr bv e
| Pexp_extension _ -> ()
and add_cases bv cases =
@@ -231,8 +247,10 @@ and add_sig_item bv item =
add_type bv vd.pval_type; bv
| Psig_type dcls ->
List.iter (add_type_declaration bv) dcls; bv
- | Psig_exception pcd ->
- add_constructor_decl bv pcd; bv
+ | Psig_typext te ->
+ add_type_extension bv te; bv
+ | Psig_exception pext ->
+ add_extension_constructor bv pext; bv
| Psig_module pmd ->
add_modtype bv pmd.pmd_type; StringSet.add pmd.pmd_name.txt bv
| Psig_recmodule decls ->
@@ -248,10 +266,10 @@ and add_sig_item bv item =
| Some mty -> add_modtype bv mty
end;
bv
- | Psig_open (_ovf, lid, _) ->
- addmodule bv lid; bv
- | Psig_include (mty, _) ->
- add_modtype bv mty; bv
+ | Psig_open od ->
+ open_module bv od.popen_lid.txt; bv
+ | Psig_include incl ->
+ add_modtype bv incl.pincl_mod; bv
| Psig_class cdl ->
List.iter (add_class_description bv) cdl; bv
| Psig_class_type cdtl ->
@@ -288,10 +306,11 @@ and add_struct_item bv item =
add_type bv vd.pval_type; bv
| Pstr_type dcls ->
List.iter (add_type_declaration bv) dcls; bv
- | Pstr_exception pcd ->
- add_constructor_decl bv pcd; bv
- | Pstr_exn_rebind(id, l, _attrs) ->
- add bv l; bv
+ | Pstr_typext te ->
+ add_type_extension bv te;
+ bv
+ | Pstr_exception pext ->
+ add_extension_constructor bv pext; bv
| Pstr_module x ->
add_module bv x.pmb_expr; StringSet.add x.pmb_name.txt bv
| Pstr_recmodule bindings ->
@@ -308,14 +327,14 @@ and add_struct_item bv item =
| Some mty -> add_modtype bv mty
end;
bv
- | Pstr_open (_ovf, l, _attrs) ->
- addmodule bv l; bv
+ | Pstr_open od ->
+ open_module bv od.popen_lid.txt; bv
| Pstr_class cdl ->
List.iter (add_class_declaration bv) cdl; bv
| Pstr_class_type cdtl ->
List.iter (add_class_type_declaration bv) cdtl; bv
- | Pstr_include (modl, _attrs) ->
- add_module bv modl; bv
+ | Pstr_include incl ->
+ add_module bv incl.pincl_mod; bv
| Pstr_attribute _ | Pstr_extension _ ->
bv
@@ -355,7 +374,7 @@ and add_class_field bv pcf =
| Pcf_method(_, _, Cfk_virtual ty) -> add_type bv ty
| Pcf_constraint(ty1, ty2) -> add_type bv ty1; add_type bv ty2
| Pcf_initializer e -> add_expr bv e
- | Pcf_extension _ -> ()
+ | Pcf_attribute _ | Pcf_extension _ -> ()
and add_class_declaration bv decl =
add_class_expr bv decl.pci_expr
diff --git a/tools/depend.mli b/tools/depend.mli
index f859cfef2..93fc084f7 100644
--- a/tools/depend.mli
+++ b/tools/depend.mli
@@ -16,6 +16,8 @@ module StringSet : Set.S with type elt = string
val free_structure_names : StringSet.t ref
+val open_module : StringSet.t -> Longident.t -> unit
+
val add_use_file : StringSet.t -> Parsetree.toplevel_phrase list -> unit
val add_signature : StringSet.t -> Parsetree.signature -> unit
diff --git a/tools/dumpobj.ml b/tools/dumpobj.ml
index db8494cc2..f1e289738 100644
--- a/tools/dumpobj.ml
+++ b/tools/dumpobj.ml
@@ -481,8 +481,8 @@ let print_reloc (info, pos) =
(* Print a .cmo file *)
-let dump_obj filename ic =
- let buffer = Misc.input_bytes ic (String.length cmo_magic_number) in
+let dump_obj ic =
+ let buffer = really_input_string ic (String.length cmo_magic_number) in
if buffer <> cmo_magic_number then begin
prerr_endline "Not an object file"; exit 2
end;
@@ -493,6 +493,7 @@ let dump_obj filename ic =
if cu.cu_debug > 0 then begin
seek_in ic cu.cu_debug;
let evl = (input_value ic : debug_event list) in
+ ignore (input_value ic); (* Skip the list of absolute directory names *)
record_events 0 evl
end;
seek_in ic cu.cu_pos;
@@ -501,7 +502,7 @@ let dump_obj filename ic =
(* Read the primitive table from an executable *)
let read_primitive_table ic len =
- let p = Misc.input_bytes ic len in
+ let p = really_input_string ic len in
let rec split beg cur =
if cur >= len then []
else if p.[cur] = '\000' then
@@ -518,7 +519,7 @@ let dump_exe ic =
primitives := read_primitive_table ic prim_size;
ignore(Bytesections.seek_section ic "DATA");
let init_data = (input_value ic : Obj.t array) in
- globals := Array.create (Array.length init_data) Empty;
+ globals := Array.make (Array.length init_data) Empty;
for i = 0 to Array.length init_data - 1 do
!globals.(i) <- Constant (init_data.(i))
done;
@@ -531,6 +532,7 @@ let dump_exe ic =
for _i = 1 to num_eventlists do
let orig = input_binary_int ic in
let evl = (input_value ic : debug_event list) in
+ ignore (input_value ic); (* Skip the list of absolute directory names *)
record_events orig evl
done
with Not_found -> ()
@@ -555,7 +557,7 @@ let arg_fun filename =
begin try
objfile := false; dump_exe ic
with Bytesections.Bad_magic_number ->
- objfile := true; seek_in ic 0; dump_obj filename ic
+ objfile := true; seek_in ic 0; dump_obj ic
end;
close_in ic;
printf "## end of ocaml dump of %S\n%!" filename
diff --git a/tools/eqparsetree.ml b/tools/eqparsetree.ml
index 332efa3e1..128453e0c 100644
--- a/tools/eqparsetree.ml
+++ b/tools/eqparsetree.ml
@@ -120,7 +120,7 @@ module Asttypes = struct
(('all_a0 loc) * ('all_a0 loc)) -> 'result =
fun mf_a ({ txt = a0; loc = a1 }, { txt = b0; loc = b1 }) ->
(mf_a (a0, b0)) && (Location.eq_t (a1, b1))
-
+
end
let rec eq_row_field : (row_field * row_field) -> 'result =
@@ -185,7 +185,7 @@ and eq_core_type : (core_type * core_type) -> 'result =
({ ptyp_desc = a0; ptyp_loc = a1 },
{ ptyp_desc = b0; ptyp_loc = b1 })
-> (eq_core_type_desc (a0, b0)) && (Location.eq_t (a1, b1))
-
+
let eq_class_infos :
'all_a0.
(('all_a0 * 'all_a0) -> 'result) ->
@@ -221,7 +221,7 @@ let eq_class_infos :
(eq_bool (a0, b0)) && (eq_bool (a1, b1)))
(a4, b4)))
&& (Location.eq_t (a5, b5))
-
+
let rec eq_pattern_desc : (pattern_desc * pattern_desc) -> 'result =
function
| (Ppat_any, Ppat_any) -> true
@@ -259,7 +259,7 @@ and eq_pattern : (pattern * pattern) -> 'result =
({ ppat_desc = a0; ppat_loc = a1 },
{ ppat_desc = b0; ppat_loc = b1 })
-> (eq_pattern_desc (a0, b0)) && (Location.eq_t (a1, b1))
-
+
let rec eq_structure_item_desc :
(structure_item_desc * structure_item_desc) -> 'result =
function
@@ -760,7 +760,7 @@ and eq_expression : (expression * expression) -> 'result =
({ pexp_desc = a0; pexp_loc = a1 },
{ pexp_desc = b0; pexp_loc = b1 })
-> (eq_expression_desc (a0, b0)) && (Location.eq_t (a1, b1))
-
+
let rec eq_directive_argument :
(directive_argument * directive_argument) -> 'result =
function
diff --git a/tools/make-package-macosx b/tools/make-package-macosx
index 1fa08919d..e823156ba 100755
--- a/tools/make-package-macosx
+++ b/tools/make-package-macosx
@@ -85,7 +85,7 @@ mkdir -p resources
cat >resources/ReadMe.txt <<EOF
This package installs OCaml version ${VERSION}.
You need Mac OS X 10.7.x (Lion) or later, with the
-XCode tools installed (v4.3.3 or later).
+XCode tools installed (v4.6.3 or later).
Files will be installed in the following directories:
diff --git a/tools/make-version-header.sh b/tools/make-version-header.sh
index b5e69be95..26c5c1428 100755
--- a/tools/make-version-header.sh
+++ b/tools/make-version-header.sh
@@ -13,9 +13,6 @@
# #
#########################################################################
-# For maximal compatibility with older versions, we Use "ocamlc -v"
-# instead of "ocamlc -vnum" or the VERSION file in .../lib/ocaml/.
-
# This script extracts the components from an OCaml version number
# and provides them as C defines:
# OCAML_VERSION_MAJOR: the major version number
@@ -26,7 +23,18 @@
# Note that additional-info is always absent in officially-released
# versions of OCaml.
-version="`ocamlc -v | sed -n -e 's/.*version //p'`"
+# usage:
+# make-version-header.sh [version-file]
+# The argument is the VERSION file from the OCaml sources.
+# If the argument is not given, the version number from "ocamlc -v" will
+# be used.
+
+case $# in
+ 0) version="`ocamlc -v | sed -n -e 's/.*version //p'`";;
+ 1) version="`sed -e 1q $1`";;
+ *) echo "usage: make-version-header.sh [version-file]" >&2
+ exit 2;;
+esac
major="`echo "$version" | sed -n -e '1s/^\([0-9]*\)\..*/\1/p'`"
minor="`echo "$version" | sed -n -e '1s/^[0-9]*\.\([0-9]*\).*/\1/p'`"
@@ -34,10 +42,12 @@ patchlvl="`echo "$version" | sed -n -e '1s/^[0-9]*\.[0-9]*\.\([0-9]*\).*/\1/p'`"
suffix="`echo "$version" | sed -n -e '1s/^[^+]*+\(.*\)/\1/p'`"
echo "#define OCAML_VERSION_MAJOR $major"
-echo "#define OCAML_VERSION_MINOR $minor"
+printf "#define OCAML_VERSION_MINOR %d\n" $minor
case $patchlvl in "") patchlvl=0;; esac
echo "#define OCAML_VERSION_PATCHLEVEL $patchlvl"
case "$suffix" in
"") echo "#undef OCAML_VERSION_ADDITIONAL";;
*) echo "#define OCAML_VERSION_ADDITIONAL \"$suffix\"";;
esac
+printf "#define OCAML_VERSION %d%02d%02d\n" $major $minor $patchlvl
+echo "#define OCAML_VERSION_STRING \"$version\""
diff --git a/tools/objinfo.ml b/tools/objinfo.ml
index 6f3ec7566..37a03b342 100644
--- a/tools/objinfo.ml
+++ b/tools/objinfo.ml
@@ -31,11 +31,18 @@ let input_stringlist ic len =
else acc
in fold 0 0 []
in
- let sect = Misc.input_bytes ic len in
+ let sect = really_input_string ic len in
get_string_list sect len
-let print_name_crc (name, crc) =
- printf "\t%s\t%s\n" (Digest.to_hex crc) name
+let dummy_crc = String.make 32 '-'
+
+let print_name_crc (name, crco) =
+ let crc =
+ match crco with
+ None -> dummy_crc
+ | Some crc -> Digest.to_hex crc
+ in
+ printf "\t%s\t%s\n" crc name
let print_line name =
printf "\t%s\n" name
@@ -69,11 +76,28 @@ let print_cma_infos (lib : Cmo_format.library) =
printf "\n";
List.iter print_cmo_infos lib.lib_units
-let print_cmi_infos name sign crcs =
+let print_cmi_infos name crcs =
printf "Unit name: %s\n" name;
printf "Interfaces imported:\n";
List.iter print_name_crc crcs
+let print_cmt_infos cmt =
+ let open Cmt_format in
+ printf "Cmt unit name: %s\n" cmt.cmt_modname;
+ print_string "Cmt interfaces imported:\n";
+ List.iter print_name_crc cmt.cmt_imports;
+ printf "Source file: %s\n"
+ (match cmt.cmt_sourcefile with None -> "(none)" | Some f -> f);
+ printf "Compilation flags:";
+ Array.iter print_spaced_string cmt.cmt_args;
+ printf "\nLoad path:";
+ List.iter print_spaced_string cmt.cmt_loadpath;
+ printf "\n";
+ printf "cmt interface digest: %s\n"
+ (match cmt.cmt_interface_digest with
+ | None -> ""
+ | Some crc -> Digest.to_hex crc)
+
let print_general_infos name crc defines cmi cmx =
printf "Name: %s\n" name;
printf "CRC of implementation: %s\n" (Digest.to_hex crc);
@@ -143,7 +167,7 @@ let dump_byte ic =
| "CRCS" ->
p_section
"Imported units"
- (input_value ic : (string * Digest.t) list)
+ (input_value ic : (string * Digest.t option) list)
| "DLLS" ->
p_list
"Used DLLs"
@@ -189,7 +213,7 @@ let dump_obj filename =
printf "File %s\n" filename;
let ic = open_in_bin filename in
let len_magic_number = String.length cmo_magic_number in
- let magic_number = Misc.input_bytes ic len_magic_number in
+ let magic_number = really_input_string ic len_magic_number in
if magic_number = cmo_magic_number then begin
let cu_pos = input_binary_int ic in
seek_in ic cu_pos;
@@ -202,11 +226,19 @@ let dump_obj filename =
let toc = (input_value ic : library) in
close_in ic;
print_cma_infos toc
- end else if magic_number = cmi_magic_number then begin
- let cmi = Cmi_format.input_cmi ic in
+ end else if magic_number = cmi_magic_number ||
+ magic_number = cmt_magic_number then begin
close_in ic;
- print_cmi_infos cmi.Cmi_format.cmi_name cmi.Cmi_format.cmi_sign
- cmi.Cmi_format.cmi_crcs
+ let cmi, cmt = Cmt_format.read filename in
+ begin match cmi with
+ | None -> ()
+ | Some cmi ->
+ print_cmi_infos cmi.Cmi_format.cmi_name cmi.Cmi_format.cmi_crcs
+ end;
+ begin match cmt with
+ | None -> ()
+ | Some cmt -> print_cmt_infos cmt
+ end
end else if magic_number = cmx_magic_number then begin
let ui = (input_value ic : unit_infos) in
let crc = Digest.input ic in
@@ -219,7 +251,7 @@ let dump_obj filename =
end else begin
let pos_trailer = in_channel_length ic - len_magic_number in
let _ = seek_in ic pos_trailer in
- let _ = really_input ic magic_number 0 len_magic_number in
+ let magic_number = really_input_string ic len_magic_number in
if magic_number = Config.exec_magic_number then begin
dump_byte ic;
close_in ic
diff --git a/tools/objinfo_helper.c b/tools/objinfo_helper.c
index 58dfd2d45..a8c79bd39 100644
--- a/tools/objinfo_helper.c
+++ b/tools/objinfo_helper.c
@@ -17,7 +17,12 @@
#ifdef HAS_LIBBFD
#include <stdlib.h>
#include <string.h>
+
+// PACKAGE: protect against binutils change
+// https://sourceware.org/bugzilla/show_bug.cgi?id=14243
+#define PACKAGE "ocamlobjinfo"
#include <bfd.h>
+#undef PACKAGE
int main(int argc, char ** argv)
{
diff --git a/tools/ocamlcp.ml b/tools/ocamlcp.ml
index bca5ae63c..51559aea3 100644
--- a/tools/ocamlcp.ml
+++ b/tools/ocamlcp.ml
@@ -54,6 +54,7 @@ module Options = Main_args.Make_bytecomp_options (struct
let _dllib = option_with_arg "-dllib"
let _dllpath = option_with_arg "-dllpath"
let _dtypes = option "-dtypes"
+ let _for_pack = option_with_arg "-for-pack"
let _g = option "-g"
let _i = option "-i"
let _I s = option_with_arg "-I" s
@@ -64,25 +65,29 @@ module Options = Main_args.Make_bytecomp_options (struct
let _labels = option "-labels"
let _linkall = option "-linkall"
let _make_runtime = option "-make-runtime"
+ let _no_alias_deps = option "-no-alias-deps"
let _no_app_funct = option "-no-app-funct"
let _noassert = option "-noassert"
let _nolabels = option "-nolabels"
let _noautolink = option "-noautolink"
let _nostdlib = option "-nostdlib"
let _o s = option_with_arg "-o" s
+ let _open s = option_with_arg "-open" s
let _output_obj = option "-output-obj"
let _pack = option "-pack"
- let _pp s = incompatible "-pp"
- let _ppx s = incompatible "-ppx"
+ let _pp _s = incompatible "-pp"
+ let _ppx _s = incompatible "-ppx"
let _principal = option "-principal"
let _rectypes = option "-rectypes"
let _runtime_variant s = option_with_arg "-runtime-variant" s
+ let _safe_string = option "-safe-string"
let _short_paths = option "-short-paths"
let _strict_sequence = option "-strict-sequence"
- let _trans_mod = option "-trans-mod"
+ let _strict_formats = option "-strict-formats"
let _thread () = option "-thread" ()
let _vmthread () = option "-vmthread" ()
let _unsafe = option "-unsafe"
+ let _unsafe_string = option "-unsafe-string"
let _use_prims s = option_with_arg "-use-prims" s
let _use_runtime s = option_with_arg "-use-runtime" s
let _v = option "-v"
diff --git a/tools/ocamldep.ml b/tools/ocamldep.ml
index 735a5f97b..db0695c9c 100644
--- a/tools/ocamldep.ml
+++ b/tools/ocamldep.ml
@@ -18,7 +18,6 @@ let ppf = Format.err_formatter
type file_kind = ML | MLI;;
-let include_dirs = ref []
let load_path = ref ([] : (string * string array) list)
let ml_synonyms = ref [".ml"]
let mli_synonyms = ref [".mli"]
@@ -35,11 +34,7 @@ let files = ref []
let fix_slash s =
if Sys.os_type = "Unix" then s else begin
- let r = String.copy s in
- for i = 0 to String.length r - 1 do
- if r.[i] = '\\' then r.[i] <- '/'
- done;
- r
+ String.map (function '\\' -> '/' | c -> c) s
end
(* Since we reinitialize load_path after reading OCAMLCOMP,
@@ -61,18 +56,21 @@ let readdir dir =
dirs := StringMap.add dir contents !dirs;
contents
+let add_to_list li s =
+ li := s :: !li
+
let add_to_load_path dir =
try
let dir = Misc.expand_directory Config.standard_library dir in
let contents = readdir dir in
- load_path := (dir, contents) :: !load_path
+ add_to_list load_path (dir, contents)
with Sys_error msg ->
Format.fprintf Format.err_formatter "@[Bad -I option: %s@]@." msg;
error_occurred := true
let add_to_synonym_list synonyms suffix =
if (String.length suffix) > 1 && suffix.[0] = '.' then
- synonyms := suffix :: !synonyms
+ add_to_list synonyms suffix
else begin
Format.fprintf Format.err_formatter "@[Bad suffix: '%s'@]@." suffix;
error_occurred := true
@@ -160,20 +158,20 @@ let print_filename s =
else count n (i+1)
in
let spaces = count 0 0 in
- let result = String.create (String.length s + spaces) in
+ let result = Bytes.create (String.length s + spaces) in
let rec loop i j =
if i >= String.length s then ()
else if s.[i] = ' ' then begin
- result.[j] <- '\\';
- result.[j+1] <- ' ';
+ Bytes.set result j '\\';
+ Bytes.set result (j+1) ' ';
loop (i+1) (j+2);
end else begin
- result.[j] <- s.[i];
+ Bytes.set result j s.[i];
loop (i+1) (j+1);
end
in
loop 0 0;
- print_string result;
+ print_bytes result;
end
;;
@@ -205,7 +203,7 @@ let print_raw_dependencies source_file deps =
(* Process one file *)
-let report_err source_file exn =
+let report_err exn =
error_occurred := true;
match exn with
| Sys_error msg ->
@@ -217,14 +215,22 @@ let report_err source_file exn =
Location.report_error err
| None -> raise x
+let tool_name = "ocamldep"
+
let read_parse_and_extract parse_function extract_function magic source_file =
Depend.free_structure_names := Depend.StringSet.empty;
try
let input_file = Pparse.preprocess source_file in
begin try
let ast =
- Pparse.file Format.err_formatter input_file parse_function magic in
- extract_function Depend.StringSet.empty ast;
+ Pparse.file ~tool_name Format.err_formatter
+ input_file parse_function magic
+ in
+ let bound_vars = Depend.StringSet.empty in
+ List.iter (fun modname ->
+ Depend.open_module bound_vars (Longident.Lident modname)
+ ) !Clflags.open_modules;
+ extract_function bound_vars ast;
Pparse.remove_preprocessed input_file;
!Depend.free_structure_names
with x ->
@@ -232,7 +238,7 @@ let read_parse_and_extract parse_function extract_function magic source_file =
raise x
end
with x ->
- report_err source_file x;
+ report_err x;
Depend.StringSet.empty
let ml_file_dependencies source_file =
@@ -288,7 +294,7 @@ let mli_file_dependencies source_file =
print_raw_dependencies source_file extracted_deps
end else begin
let basename = Filename.chop_extension source_file in
- let (byt_deps, opt_deps) =
+ let (byt_deps, _opt_deps) =
Depend.StringSet.fold (find_dependency MLI)
extracted_deps ([], []) in
print_dependencies [basename ^ ".cmi"] byt_deps
@@ -299,7 +305,7 @@ let file_dependencies_as kind source_file =
load_path := [];
List.iter add_to_load_path (
(!Compenv.last_include_dirs @
- !include_dirs @
+ !Clflags.include_dirs @
!Compenv.first_include_dirs
));
Location.input_name := source_file;
@@ -309,7 +315,7 @@ let file_dependencies_as kind source_file =
| ML -> ml_file_dependencies source_file
| MLI -> mli_file_dependencies source_file
end
- with x -> report_err source_file x
+ with x -> report_err x
let file_dependencies source_file =
if List.exists (Filename.check_suffix source_file) !ml_synonyms then
@@ -324,8 +330,9 @@ let sort_files_by_dependencies files =
(* Init Hashtbl with all defined modules *)
let files = List.map (fun (file, file_kind, deps) ->
- let modname = Filename.chop_extension (Filename.basename file) in
- modname.[0] <- Char.uppercase modname.[0];
+ let modname =
+ String.capitalize (Filename.chop_extension (Filename.basename file))
+ in
let key = (modname, file_kind) in
let new_deps = ref [] in
Hashtbl.add h key (file, new_deps);
@@ -407,14 +414,14 @@ let print_version_num () =
let _ =
Clflags.classic := false;
- first_include_dirs := Filename.current_dir_name :: !first_include_dirs;
+ add_to_list first_include_dirs Filename.current_dir_name;
Compenv.readenv ppf Before_args;
Arg.parse [
"-absname", Arg.Set Location.absname,
" Show absolute filenames in error messages";
"-all", Arg.Set all_dependencies,
" Generate dependencies on all files";
- "-I", Arg.String (fun s -> include_dirs := s :: !include_dirs),
+ "-I", Arg.String (add_to_list Clflags.include_dirs),
"<dir> Add <dir> to the list of include directories";
"-impl", Arg.String (file_dependencies_as ML),
"<f> Process <f> as a .ml file";
@@ -430,9 +437,11 @@ let _ =
" Generate dependencies for native-code only (no .cmo files)";
"-one-line", Arg.Set one_line,
" Output one line per file, regardless of the length";
+ "-open", Arg.String (add_to_list Clflags.open_modules),
+ "<module> Opens the module <module> before typing";
"-pp", Arg.String(fun s -> Clflags.preprocessor := Some s),
"<cmd> Pipe sources through preprocessor <cmd>";
- "-ppx", Arg.String(fun s -> first_ppx := s :: !first_ppx),
+ "-ppx", Arg.String (add_to_list first_ppx),
"<cmd> Pipe abstract syntax trees through preprocessor <cmd>";
"-slash", Arg.Set Clflags.force_slash,
" (Windows) Use forward slash / instead of backslash \\ in file paths";
diff --git a/tools/ocamlmklib.ml b/tools/ocamlmklib.ml
index 0ef86979b..77ae57bec 100644
--- a/tools/ocamlmklib.ml
+++ b/tools/ocamlmklib.ml
@@ -215,10 +215,14 @@ let prepostfix pre name post =
let transl_path s =
match Sys.os_type with
| "Win32" ->
+ let s = Bytes.of_string s in
let rec aux i =
- if i = String.length s || s.[i] = ' ' then s
- else (if s.[i] = '/' then s.[i] <- '\\'; aux (i + 1))
- in aux 0
+ if i = Bytes.length s || Bytes.get s i = ' ' then s
+ else begin
+ if Bytes.get s i = '/' then Bytes.set s i '\\';
+ aux (i + 1)
+ end
+ in Bytes.to_string (aux 0)
| _ -> s
let build_libs () =
diff --git a/tools/ocamloptp.ml b/tools/ocamloptp.ml
index 6d730f2c3..0b788843f 100644
--- a/tools/ocamloptp.ml
+++ b/tools/ocamloptp.ml
@@ -64,28 +64,33 @@ module Options = Main_args.Make_optcomp_options (struct
let _keep_locs = option "-keep-locs"
let _labels = option "-labels"
let _linkall = option "-linkall"
+ let _no_alias_deps = option "-no-alias-deps"
let _no_app_funct = option "-no-app-funct"
+ let _no_float_const_prop = option "-no-float-const-prop"
let _noassert = option "-noassert"
let _noautolink = option "-noautolink"
let _nodynlink = option "-nodynlink"
let _nolabels = option "-nolabels"
let _nostdlib = option "-nostdlib"
let _o s = option_with_arg "-o" s
+ let _open s = option_with_arg "-open" s
let _output_obj = option "-output-obj"
let _p = option "-p"
let _pack = option "-pack"
- let _pp s = incompatible "-pp"
- let _ppx s = incompatible "-ppx"
+ let _pp _s = incompatible "-pp"
+ let _ppx _s = incompatible "-ppx"
let _principal = option "-principal"
let _rectypes = option "-rectypes"
let _runtime_variant s = option_with_arg "-runtime-variant" s
let _S = option "-S"
+ let _safe_string = option "-safe-string"
let _short_paths = option "-short-paths"
let _strict_sequence = option "-strict-sequence"
+ let _strict_formats = option "-strict-formats"
let _shared = option "-shared"
let _thread = option "-thread"
- let _trans_mod = option "-trans-mod"
let _unsafe = option "-unsafe"
+ let _unsafe_string = option "-unsafe-string"
let _v = option "-v"
let _version = option "-version"
let _vnum = option "-vnum"
@@ -105,6 +110,7 @@ module Options = Main_args.Make_optcomp_options (struct
let _dcmm = option "-dcmm"
let _dsel = option "-dsel"
let _dcombine = option "-dcombine"
+ let _dcse = option "-dcse"
let _dlive = option "-dlive"
let _dspill = option "-dspill"
let _dsplit = option "-dsplit"
@@ -115,6 +121,7 @@ module Options = Main_args.Make_optcomp_options (struct
let _dscheduling = option "-dscheduling"
let _dlinear = option "-dlinear"
let _dstartup = option "-dstartup"
+ let _opaque = option "-opaque"
let anonymous = process_file
end);;
diff --git a/tools/ocamlprof.ml b/tools/ocamlprof.ml
index 1fde3fe49..dde248cd4 100644
--- a/tools/ocamlprof.ml
+++ b/tools/ocamlprof.ml
@@ -35,7 +35,7 @@ and inchan = ref stdin
and outchan = ref stdout
(* To copy source fragments *)
-let copy_buffer = String.create 256
+let copy_buffer = Bytes.create 256
let copy_chars_unix nchars =
let n = ref nchars in
@@ -86,7 +86,7 @@ let add_incr_counter modul (kind,pos) =
| Close -> fprintf !outchan ")";
;;
-let counters = ref (Array.create 0 0)
+let counters = ref (Array.make 0 0)
(* User defined marker *)
let special_id = ref ""
@@ -122,7 +122,7 @@ let init_rewrite modes mod_name =
cur_point := 0;
if !instr_mode then begin
fprintf !outchan "module %sProfiling = Profiling;; " modprefix;
- fprintf !outchan "let %s%s_cnt = Array.create 000000000" idprefix mod_name;
+ fprintf !outchan "let %s%s_cnt = Array.make 000000000" idprefix mod_name;
pos_len := pos_out !outchan;
fprintf !outchan
" 0;; Profiling.counters := \
@@ -131,7 +131,7 @@ let init_rewrite modes mod_name =
end
let final_rewrite add_function =
- to_insert := Sort.list (fun x y -> snd x < snd y) !to_insert;
+ to_insert := List.sort (fun x y -> compare (snd x) (snd y)) !to_insert;
prof_counter := 0;
List.iter add_function !to_insert;
copy (in_channel_length !inchan);
@@ -173,8 +173,8 @@ and rewrite_exp iflag sexp =
and rw_exp iflag sexp =
match sexp.pexp_desc with
- Pexp_ident lid -> ()
- | Pexp_constant cst -> ()
+ Pexp_ident _lid -> ()
+ | Pexp_constant _cst -> ()
| Pexp_let(_, spat_sexp_list, sbody) ->
rewrite_patexp_list iflag spat_sexp_list;
@@ -314,7 +314,7 @@ and rewrite_annotate_exp_list l =
l
and rewrite_function iflag = function
- | [{pc_lhs=spat; pc_guard=None;
+ | [{pc_lhs=_; pc_guard=None;
pc_rhs={pexp_desc = (Pexp_function _|Pexp_fun _)} as sexp}] ->
rewrite_exp iflag sexp
| l -> rewrite_funmatching l
@@ -344,6 +344,7 @@ and rewrite_class_field iflag cf =
| Pcf_method (_, _, Cfk_virtual _)
| Pcf_val (_, _, Cfk_virtual _)
| Pcf_constraint _ -> ()
+ | Pcf_attribute _ -> ()
| Pcf_extension _ -> ()
and rewrite_class_expr iflag cexpr =
@@ -370,11 +371,11 @@ and rewrite_class_declaration iflag cl =
and rewrite_mod iflag smod =
match smod.pmod_desc with
- Pmod_ident lid -> ()
+ Pmod_ident _ -> ()
| Pmod_structure sstr -> List.iter (rewrite_str_item iflag) sstr
- | Pmod_functor(param, smty, sbody) -> rewrite_mod iflag sbody
+ | Pmod_functor(_param, _smty, sbody) -> rewrite_mod iflag sbody
| Pmod_apply(smod1, smod2) -> rewrite_mod iflag smod1; rewrite_mod iflag smod2
- | Pmod_constraint(smod, smty) -> rewrite_mod iflag smod
+ | Pmod_constraint(smod, _smty) -> rewrite_mod iflag smod
| Pmod_unpack(sexp) -> rewrite_exp iflag sexp
| Pmod_extension _ -> ()
diff --git a/tools/profiling.ml b/tools/profiling.ml
index 5dae8e461..49a84108e 100644
--- a/tools/profiling.ml
+++ b/tools/profiling.ml
@@ -37,7 +37,7 @@ let dump_counters () =
then raise Bad_profile)
!counters prevl;
List.iter2
- (fun (curname, (_,curcount)) (prevname, (_,prevcount)) ->
+ (fun (_curname, (_,curcount)) (_prevname, (_,prevcount)) ->
for i = 0 to Array.length curcount - 1 do
curcount.(i) <- curcount.(i) + prevcount.(i)
done)
diff --git a/tools/read_cmt.ml b/tools/read_cmt.ml
index c0c5eb09d..eacba02a5 100644
--- a/tools/read_cmt.ml
+++ b/tools/read_cmt.ml
@@ -16,46 +16,59 @@ let print_info_arg = ref false
let target_filename = ref None
let arg_list = [
- "-o", Arg.String (fun s ->
- target_filename := Some s
- ), " FILE (or -) : dump to file FILE (or stdout)";
+ "-o", Arg.String (fun s -> target_filename := Some s),
+ " FILE (or -) : dump to file FILE (or stdout)";
"-annot", Arg.Set gen_annot, " : generate the corresponding .annot file";
- "-src", Arg.Set gen_ml, " : generate an equivalent of the original source file (without comments) from a .cmt or a .cmti file";
+ "-src", Arg.Set gen_ml,
+ " : convert .cmt or .cmti back to source code (without comments)";
"-info", Arg.Set print_info_arg, " : print information on the file";
]
-let arg_usage = "read_cmt [OPTIONS] FILE.cmt : read FILE.cmt and print related information"
+let arg_usage =
+ "read_cmt [OPTIONS] FILE.cmt : read FILE.cmt and print related information"
+
+let dummy_crc = String.make 32 '-'
let print_info cmt =
let open Cmt_format in
Printf.printf "module name: %s\n" cmt.cmt_modname;
begin match cmt.cmt_annots with
- Packed (_, list) -> Printf.printf "pack: %s\n" (String.concat " " list)
+ Packed (_, list) ->
+ Printf.printf "pack: %s\n" (String.concat " " list)
| Implementation _ -> Printf.printf "kind: implementation\n"
| Interface _ -> Printf.printf "kind: interface\n"
- | Partial_implementation _ -> Printf.printf "kind: implementation with errors\n"
+ | Partial_implementation _ ->
+ Printf.printf "kind: implementation with errors\n"
| Partial_interface _ -> Printf.printf "kind: interface with errors\n"
end;
- Printf.printf "command: %s\n" (String.concat " " (Array.to_list cmt.cmt_args));
+ Printf.printf "command: %s\n"
+ (String.concat " " (Array.to_list cmt.cmt_args));
begin match cmt.cmt_sourcefile with
None -> ()
| Some name ->
Printf.printf "sourcefile: %s\n" name;
end;
Printf.printf "build directory: %s\n" cmt.cmt_builddir;
- List.iter (fun dir -> Printf.printf "load path: %s\n%!" dir) cmt.cmt_loadpath;
+ List.iter (Printf.printf "load path: %s\n%!") cmt.cmt_loadpath;
begin
match cmt.cmt_source_digest with
None -> ()
- | Some digest -> Printf.printf "source digest: %s\n" (Digest.to_hex digest);
+ | Some digest ->
+ Printf.printf "source digest: %s\n" (Digest.to_hex digest);
end;
begin
match cmt.cmt_interface_digest with
None -> ()
- | Some digest -> Printf.printf "interface digest: %s\n" (Digest.to_hex digest);
+ | Some digest ->
+ Printf.printf "interface digest: %s\n" (Digest.to_hex digest);
end;
- List.iter (fun (name, digest) ->
- Printf.printf "import: %s %s\n" name (Digest.to_hex digest);
+ List.iter (fun (name, crco) ->
+ let crc =
+ match crco with
+ None -> dummy_crc
+ | Some crc -> Digest.to_hex crc
+ in
+ Printf.printf "import: %s %s\n" name crc;
) (List.sort compare cmt.cmt_imports);
Printf.printf "%!";
()
@@ -74,7 +87,8 @@ let _ =
if !gen_ml then Cmt2annot.gen_ml !target_filename filename cmt;
if !print_info_arg || not (!gen_ml || !gen_annot) then print_info cmt;
end else begin
- Printf.fprintf stderr "Error: the file must have an extension in .cmt or .cmti.\n%!";
+ Printf.fprintf stderr
+ "Error: the file's extension must be .cmt or .cmti.\n%!";
Arg.usage arg_list arg_usage
end
) arg_usage
diff --git a/tools/tast_iter.ml b/tools/tast_iter.ml
index c8af13670..be5b85441 100644
--- a/tools/tast_iter.ml
+++ b/tools/tast_iter.ml
@@ -17,18 +17,14 @@ let opt f = function None -> () | Some x -> f x
let structure sub str =
List.iter (sub # structure_item) str.str_items
-let constructor_decl sub cd =
- List.iter (sub # core_type) cd.cd_args;
- opt (sub # core_type) cd.cd_res
-
let structure_item sub x =
match x.str_desc with
| Tstr_eval (exp, _attrs) -> sub # expression exp
| Tstr_value (rec_flag, list) -> sub # bindings (rec_flag, list)
| Tstr_primitive v -> sub # value_description v
| Tstr_type list -> List.iter (sub # type_declaration) list
- | Tstr_exception decl -> constructor_decl sub decl
- | Tstr_exn_rebind (_id, _, _p, _, _) -> ()
+ | Tstr_typext te -> sub # type_extension te
+ | Tstr_exception ext -> sub # extension_constructor ext
| Tstr_module mb -> sub # module_binding mb
| Tstr_recmodule list -> List.iter (sub # module_binding) list
| Tstr_modtype mtd -> opt (sub # module_type) mtd.mtd_type
@@ -37,12 +33,23 @@ let structure_item sub x =
List.iter (fun (ci, _, _) -> sub # class_expr ci.ci_expr) list
| Tstr_class_type list ->
List.iter (fun (_id, _, ct) -> sub # class_type ct.ci_expr) list
- | Tstr_include (mexpr, _, _) -> sub # module_expr mexpr
+ | Tstr_include incl -> sub # module_expr incl.incl_mod
| Tstr_attribute _ -> ()
let value_description sub x =
sub # core_type x.val_desc
+let constructor_args sub = function
+ | Cstr_tuple l -> List.iter (sub # core_type) l
+ | Cstr_record l -> List.iter (fun ld -> sub # core_type ld.ld_type) l
+
+let constructor_decl sub cd =
+ constructor_args sub cd.cd_args;
+ opt (sub # core_type) cd.cd_res
+
+let label_decl sub ld =
+ sub # core_type ld.ld_type
+
let type_declaration sub decl =
List.iter
(fun (ct1, ct2, _loc) -> sub # core_type ct1; sub # core_type ct2)
@@ -52,10 +59,21 @@ let type_declaration sub decl =
| Ttype_variant list ->
List.iter (constructor_decl sub) list
| Ttype_record list ->
- List.iter (fun ld -> sub # core_type ld.ld_type) list
+ List.iter (label_decl sub) list
+ | Ttype_open -> ()
end;
opt (sub # core_type) decl.typ_manifest
+let type_extension sub te =
+ List.iter (sub # extension_constructor) te.tyext_constructors
+
+let extension_constructor sub ext =
+ match ext.ext_kind with
+ Text_decl(ctl, cto) ->
+ constructor_args sub ctl;
+ opt (sub # core_type) cto
+ | Text_rebind _ -> ()
+
let pattern sub pat =
let extra = function
| Tpat_type _
@@ -98,9 +116,10 @@ let expression sub exp =
| Texp_apply (exp, list) ->
sub # expression exp;
List.iter (fun (_, expo, _) -> opt (sub # expression) expo) list
- | Texp_match (exp, cases, _) ->
+ | Texp_match (exp, cases, exn_cases, _) ->
sub # expression exp;
- sub # cases cases
+ sub # cases cases;
+ sub # cases exn_cases
| Texp_try (exp, cases) ->
sub # expression exp;
sub # cases cases
@@ -166,8 +185,10 @@ let signature_item sub item =
sub # value_description v
| Tsig_type list ->
List.iter (sub # type_declaration) list
- | Tsig_exception decl ->
- constructor_decl sub decl
+ | Tsig_typext te ->
+ sub # type_extension te
+ | Tsig_exception ext ->
+ sub # extension_constructor ext
| Tsig_module md ->
sub # module_type md.md_type
| Tsig_recmodule list ->
@@ -175,7 +196,7 @@ let signature_item sub item =
| Tsig_modtype mtd ->
opt (sub # module_type) mtd.mtd_type
| Tsig_open _ -> ()
- | Tsig_include (mty,_,_) -> sub # module_type mty
+ | Tsig_include incl -> sub # module_type incl.incl_mod
| Tsig_class list ->
List.iter (sub # class_description) list
| Tsig_class_type list ->
@@ -274,6 +295,7 @@ let class_type_field sub ctf =
| Tctf_constraint (ct1, ct2) ->
sub # core_type ct1;
sub # core_type ct2
+ | Tctf_attribute _ -> ()
let core_type sub ct =
match ct.ctyp_desc with
@@ -286,7 +308,7 @@ let core_type sub ct =
| Ttyp_constr (_path, _, list) ->
List.iter (sub # core_type) list
| Ttyp_object (list, _o) ->
- List.iter (fun (_, t) -> sub # core_type t) list
+ List.iter (fun (_, _, t) -> sub # core_type t) list
| Ttyp_class (_path, _, list) ->
List.iter (sub # core_type) list
| Ttyp_alias (ct, _s) ->
@@ -302,7 +324,7 @@ let class_structure sub cs =
let row_field sub rf =
match rf with
- | Ttag (_label, _bool, list) -> List.iter (sub # core_type) list
+ | Ttag (_label, _attrs, _bool, list) -> List.iter (sub # core_type) list
| Tinherit ct -> sub # core_type ct
let class_field sub cf =
@@ -322,6 +344,7 @@ let class_field sub cf =
sub # expression exp
| Tcf_initializer exp ->
sub # expression exp
+ | Tcf_attribute _ -> ()
let bindings sub (_rec_flag, list) =
List.iter (sub # binding) list
@@ -353,6 +376,7 @@ class iter = object(this)
method class_type_field = class_type_field this
method core_type = core_type this
method expression = expression this
+ method extension_constructor = extension_constructor this
method module_binding = module_binding this
method module_expr = module_expr this
method module_type = module_type this
@@ -364,6 +388,7 @@ class iter = object(this)
method structure = structure this
method structure_item = structure_item this
method type_declaration = type_declaration this
+ method type_extension = type_extension this
method value_description = value_description this
method with_constraint = with_constraint this
end
diff --git a/tools/tast_iter.mli b/tools/tast_iter.mli
index f80609566..1d81afa56 100644
--- a/tools/tast_iter.mli
+++ b/tools/tast_iter.mli
@@ -28,6 +28,7 @@ class iter: object
method class_type_field: class_type_field -> unit
method core_type: core_type -> unit
method expression: expression -> unit
+ method extension_constructor: extension_constructor -> unit
method module_binding: module_binding -> unit
method module_expr: module_expr -> unit
method module_type: module_type -> unit
@@ -39,6 +40,7 @@ class iter: object
method structure: structure -> unit
method structure_item: structure_item -> unit
method type_declaration: type_declaration -> unit
+ method type_extension: type_extension -> unit
method value_description: value_description -> unit
method with_constraint: with_constraint -> unit
end
@@ -63,6 +65,7 @@ val class_type_declaration: iter -> class_type_declaration -> unit
val class_type_field: iter -> class_type_field -> unit
val core_type: iter -> core_type -> unit
val expression: iter -> expression -> unit
+val extension_constructor: iter -> extension_constructor -> unit
val module_binding: iter -> module_binding -> unit
val module_expr: iter -> module_expr -> unit
val module_type: iter -> module_type -> unit
@@ -74,5 +77,6 @@ val signature_item: iter -> signature_item -> unit
val structure: iter -> structure -> unit
val structure_item: iter -> structure_item -> unit
val type_declaration: iter -> type_declaration -> unit
+val type_extension: iter -> type_extension -> unit
val value_description: iter -> value_description -> unit
val with_constraint: iter -> with_constraint -> unit
diff --git a/tools/untypeast.ml b/tools/untypeast.ml
index 4d2304e27..58242fc23 100644
--- a/tools/untypeast.ml
+++ b/tools/untypeast.ml
@@ -30,6 +30,9 @@ Some notes:
*)
+let string_is_prefix sub str =
+ let sublen = String.length sub in
+ String.length str >= sublen && String.sub str 0 sublen = sub
let option f = function None -> None | Some e -> Some (f e)
@@ -53,41 +56,38 @@ and untype_structure_item item =
Pstr_primitive (untype_value_description vd)
| Tstr_type list ->
Pstr_type (List.map untype_type_declaration list)
- | Tstr_exception decl ->
- Pstr_exception (untype_constructor_declaration decl)
- | Tstr_exn_rebind (_id, name, _p, lid, attrs) ->
- Pstr_exn_rebind (name, lid, attrs)
+ | Tstr_typext tyext ->
+ Pstr_typext (untype_type_extension tyext)
+ | Tstr_exception ext ->
+ Pstr_exception (untype_extension_constructor ext)
| Tstr_module mb ->
Pstr_module (untype_module_binding mb)
| Tstr_recmodule list ->
Pstr_recmodule (List.map untype_module_binding list)
| Tstr_modtype mtd ->
- Pstr_modtype {pmtd_name=mtd.mtd_name; pmtd_type=option untype_module_type mtd.mtd_type;
+ Pstr_modtype {pmtd_name=mtd.mtd_name;
+ pmtd_type=option untype_module_type mtd.mtd_type;
pmtd_loc=mtd.mtd_loc;pmtd_attributes=mtd.mtd_attributes;}
- | Tstr_open (ovf, _path, lid, attrs) -> Pstr_open (ovf, lid, attrs)
+ | Tstr_open od ->
+ Pstr_open {popen_lid = od.open_txt; popen_override = od.open_override;
+ popen_attributes = od.open_attributes;
+ popen_loc = od.open_loc;
+ }
| Tstr_class list ->
- Pstr_class (List.map (fun (ci, _, _) ->
- { pci_virt = ci.ci_virt;
- pci_params = ci.ci_params;
- pci_name = ci.ci_id_name;
- pci_expr = untype_class_expr ci.ci_expr;
- pci_loc = ci.ci_loc;
- pci_attributes = ci.ci_attributes;
- }
- ) list)
+ Pstr_class
+ (List.map
+ (fun (ci, _, _) -> untype_class_declaration ci)
+ list)
| Tstr_class_type list ->
- Pstr_class_type (List.map (fun (_id, _name, ct) ->
- {
- pci_virt = ct.ci_virt;
- pci_params = ct.ci_params;
- pci_name = ct.ci_id_name;
- pci_expr = untype_class_type ct.ci_expr;
- pci_loc = ct.ci_loc;
- pci_attributes = ct.ci_attributes;
- }
- ) list)
- | Tstr_include (mexpr, _, attrs) ->
- Pstr_include (untype_module_expr mexpr, attrs)
+ Pstr_class_type
+ (List.map
+ (fun (_id, _name, ct) -> untype_class_type_declaration ct)
+ list)
+ | Tstr_include incl ->
+ Pstr_include {pincl_mod = untype_module_expr incl.incl_mod;
+ pincl_attributes = incl.incl_attributes;
+ pincl_loc = incl.incl_loc;
+ }
| Tstr_attribute x ->
Pstr_attribute x
in
@@ -113,7 +113,7 @@ and untype_module_binding mb =
and untype_type_declaration decl =
{
ptype_name = decl.typ_name;
- ptype_params = decl.typ_params;
+ ptype_params = List.map untype_type_parameter decl.typ_params;
ptype_cstrs = List.map (fun (ct1, ct2, loc) ->
(untype_core_type ct1,
untype_core_type ct2, loc)
@@ -123,13 +123,8 @@ and untype_type_declaration decl =
| Ttype_variant list ->
Ptype_variant (List.map untype_constructor_declaration list)
| Ttype_record list ->
- Ptype_record (List.map (fun ld ->
- {pld_name=ld.ld_name;
- pld_mutable=ld.ld_mutable;
- pld_type=untype_core_type ld.ld_type;
- pld_loc=ld.ld_loc;
- pld_attributes=ld.ld_attributes}
- ) list)
+ Ptype_record (List.map untype_label_declaration list)
+ | Ttype_open -> Ptype_open
);
ptype_private = decl.typ_private;
ptype_manifest = option untype_core_type decl.typ_manifest;
@@ -137,15 +132,53 @@ and untype_type_declaration decl =
ptype_loc = decl.typ_loc;
}
+and untype_type_parameter (ct, v) = (untype_core_type ct, v)
+
+and untype_constructor_arguments = function
+ | Cstr_tuple l -> Pcstr_tuple (List.map untype_core_type l)
+ | Cstr_record l -> Pcstr_record (List.map untype_label_declaration l)
+
and untype_constructor_declaration cd =
{
pcd_name = cd.cd_name;
- pcd_args = Pcstr_tuple (List.map untype_core_type cd.cd_args);
+ pcd_args = untype_constructor_arguments cd.cd_args;
pcd_res = option untype_core_type cd.cd_res;
pcd_loc = cd.cd_loc;
pcd_attributes = cd.cd_attributes;
}
+and untype_label_declaration ld =
+ {
+ pld_name=ld.ld_name;
+ pld_mutable=ld.ld_mutable;
+ pld_type=untype_core_type ld.ld_type;
+ pld_loc=ld.ld_loc;
+ pld_attributes=ld.ld_attributes
+ }
+
+and untype_type_extension tyext =
+ {
+ ptyext_path = tyext.tyext_txt;
+ ptyext_params = List.map untype_type_parameter tyext.tyext_params;
+ ptyext_constructors =
+ List.map untype_extension_constructor tyext.tyext_constructors;
+ ptyext_private = tyext.tyext_private;
+ ptyext_attributes = tyext.tyext_attributes;
+ }
+
+and untype_extension_constructor ext =
+ {
+ pext_name = ext.ext_name;
+ pext_kind = (match ext.ext_kind with
+ Text_decl (args, ret) ->
+ Pext_decl (untype_constructor_arguments args,
+ option untype_core_type ret)
+ | Text_rebind (_p, lid) -> Pext_rebind lid
+ );
+ pext_loc = ext.ext_loc;
+ pext_attributes = ext.ext_attributes;
+ }
+
and untype_pattern pat =
let desc =
match pat with
@@ -191,7 +224,8 @@ and untype_pattern pat =
| Tpat_or (p1, p2, _) -> Ppat_or (untype_pattern p1, untype_pattern p2)
| Tpat_lazy p -> Ppat_lazy (untype_pattern p)
in
- Pat.mk ~loc:pat.pat_loc ~attrs:pat.pat_attributes desc (* todo: fix attributes on extras *)
+ Pat.mk ~loc:pat.pat_loc ~attrs:pat.pat_attributes desc
+ (* todo: fix attributes on extras *)
and untype_extra (extra, loc, attrs) sexp =
let desc =
@@ -217,11 +251,12 @@ and untype_case {c_lhs; c_guard; c_rhs} =
pc_rhs = untype_expression c_rhs;
}
-and untype_binding {vb_pat; vb_expr; vb_attributes} =
+and untype_binding {vb_pat; vb_expr; vb_attributes; vb_loc} =
{
pvb_pat = untype_pattern vb_pat;
pvb_expr = untype_expression vb_expr;
pvb_attributes = vb_attributes;
+ pvb_loc = vb_loc;
}
and untype_expression exp =
@@ -246,8 +281,18 @@ and untype_expression exp =
None -> list
| Some exp -> (label, untype_expression exp) :: list
) list [])
- | Texp_match (exp, cases, _) ->
- Pexp_match (untype_expression exp, untype_cases cases)
+ | Texp_match (exp, cases, exn_cases, _) ->
+ let merged_cases = untype_cases cases
+ @ List.map
+ (fun c ->
+ let uc = untype_case c in
+ let pat = { uc.pc_lhs
+ with ppat_desc = Ppat_exception uc.pc_lhs }
+ in
+ { uc with pc_lhs = pat })
+ exn_cases
+ in
+ Pexp_match (untype_expression exp, merged_cases)
| Texp_try (exp, cases) ->
Pexp_try (untype_expression exp, untype_cases cases)
| Texp_tuple list ->
@@ -328,10 +373,13 @@ and untype_signature_item item =
Psig_value (untype_value_description v)
| Tsig_type list ->
Psig_type (List.map untype_type_declaration list)
- | Tsig_exception decl ->
- Psig_exception (untype_constructor_declaration decl)
+ | Tsig_typext tyext ->
+ Psig_typext (untype_type_extension tyext)
+ | Tsig_exception ext ->
+ Psig_exception (untype_extension_constructor ext)
| Tsig_module md ->
- Psig_module {pmd_name = md.md_name; pmd_type = untype_module_type md.md_type;
+ Psig_module {pmd_name = md.md_name;
+ pmd_type = untype_module_type md.md_type;
pmd_attributes = md.md_attributes; pmd_loc = md.md_loc;
}
| Tsig_recmodule list ->
@@ -339,10 +387,20 @@ and untype_signature_item item =
{pmd_name = md.md_name; pmd_type = untype_module_type md.md_type;
pmd_attributes = md.md_attributes; pmd_loc = md.md_loc}) list)
| Tsig_modtype mtd ->
- Psig_modtype {pmtd_name=mtd.mtd_name; pmtd_type=option untype_module_type mtd.mtd_type;
+ Psig_modtype {pmtd_name=mtd.mtd_name;
+ pmtd_type=option untype_module_type mtd.mtd_type;
pmtd_attributes=mtd.mtd_attributes; pmtd_loc=mtd.mtd_loc}
- | Tsig_open (ovf, _path, lid, attrs) -> Psig_open (ovf, lid, attrs)
- | Tsig_include (mty, _, attrs) -> Psig_include (untype_module_type mty, attrs)
+ | Tsig_open od ->
+ Psig_open {popen_lid = od.open_txt;
+ popen_override = od.open_override;
+ popen_attributes = od.open_attributes;
+ popen_loc = od.open_loc;
+ }
+ | Tsig_include incl ->
+ Psig_include {pincl_mod = untype_module_type incl.incl_mod;
+ pincl_attributes = incl.incl_attributes;
+ pincl_loc = incl.incl_loc;
+ }
| Tsig_class list ->
Psig_class (List.map untype_class_description list)
| Tsig_class_type list ->
@@ -354,10 +412,20 @@ and untype_signature_item item =
psig_loc = item.sig_loc;
}
+and untype_class_declaration cd =
+ {
+ pci_virt = cd.ci_virt;
+ pci_params = List.map untype_type_parameter cd.ci_params;
+ pci_name = cd.ci_id_name;
+ pci_expr = untype_class_expr cd.ci_expr;
+ pci_loc = cd.ci_loc;
+ pci_attributes = cd.ci_attributes;
+ }
+
and untype_class_description cd =
{
pci_virt = cd.ci_virt;
- pci_params = cd.ci_params;
+ pci_params = List.map untype_type_parameter cd.ci_params;
pci_name = cd.ci_id_name;
pci_expr = untype_class_type cd.ci_expr;
pci_loc = cd.ci_loc;
@@ -367,7 +435,7 @@ and untype_class_description cd =
and untype_class_type_declaration cd =
{
pci_virt = cd.ci_virt;
- pci_params = cd.ci_params;
+ pci_params = List.map untype_type_parameter cd.ci_params;
pci_name = cd.ci_id_name;
pci_expr = untype_class_type cd.ci_expr;
pci_loc = cd.ci_loc;
@@ -488,6 +556,7 @@ and untype_class_type_field ctf =
Pctf_method (s, priv, virt, untype_core_type ct)
| Tctf_constraint (ct1, ct2) ->
Pctf_constraint (untype_core_type ct1, untype_core_type ct2)
+ | Tctf_attribute x -> Pctf_attribute x
in
{
pctf_desc = desc;
@@ -506,7 +575,8 @@ and untype_core_type ct =
Ptyp_constr (lid,
List.map untype_core_type list)
| Ttyp_object (list, o) ->
- Ptyp_object (List.map (fun (s, t) -> (s, untype_core_type t)) list, o)
+ Ptyp_object
+ (List.map (fun (s, a, t) -> (s, a, untype_core_type t)) list, o)
| Ttyp_class (_path, lid, list) ->
Ptyp_class (lid, List.map untype_core_type list)
| Ttyp_alias (ct, s) ->
@@ -519,16 +589,26 @@ and untype_core_type ct =
Typ.mk ~loc:ct.ctyp_loc desc
and untype_class_structure cs =
- { pcstr_self = untype_pattern cs.cstr_self;
+ let rec remove_self = function
+ | { pat_desc = Tpat_alias (p, id, _s) } when string_is_prefix "selfpat-" id.Ident.name ->
+ remove_self p
+ | p -> p
+ in
+ { pcstr_self = untype_pattern (remove_self cs.cstr_self);
pcstr_fields = List.map untype_class_field cs.cstr_fields;
}
and untype_row_field rf =
match rf with
- Ttag (label, bool, list) ->
- Rtag (label, bool, List.map untype_core_type list)
+ Ttag (label, attrs, bool, list) ->
+ Rtag (label, attrs, bool, List.map untype_core_type list)
| Tinherit ct -> Rinherit (untype_core_type ct)
+and is_self_pat = function
+ | { pat_desc = Tpat_alias(_pat, id, _) } ->
+ string_is_prefix "self-" (Ident.name id)
+ | _ -> false
+
and untype_class_field cf =
let desc = match cf.cf_desc with
Tcf_inherit (ovf, cl, super, _vals, _meths) ->
@@ -542,7 +622,19 @@ and untype_class_field cf =
| Tcf_method (lab, priv, Tcfk_virtual cty) ->
Pcf_method (lab, priv, Cfk_virtual (untype_core_type cty))
| Tcf_method (lab, priv, Tcfk_concrete (o, exp)) ->
+ let remove_fun_self = function
+ | { exp_desc = Texp_function("", [case], _) } when is_self_pat case.c_lhs && case.c_guard = None -> case.c_rhs
+ | e -> e
+ in
+ let exp = remove_fun_self exp in
Pcf_method (lab, priv, Cfk_concrete (o, untype_expression exp))
- | Tcf_initializer exp -> Pcf_initializer (untype_expression exp)
+ | Tcf_initializer exp ->
+ let remove_fun_self = function
+ | { exp_desc = Texp_function("", [case], _) } when is_self_pat case.c_lhs && case.c_guard = None -> case.c_rhs
+ | e -> e
+ in
+ let exp = remove_fun_self exp in
+ Pcf_initializer (untype_expression exp)
+ | Tcf_attribute x -> Pcf_attribute x
in
{ pcf_desc = desc; pcf_loc = cf.cf_loc; pcf_attributes = cf.cf_attributes }
diff --git a/tools/untypeast.mli b/tools/untypeast.mli
index 0e0351ef9..efd0a031d 100644
--- a/tools/untypeast.mli
+++ b/tools/untypeast.mli
@@ -13,7 +13,8 @@
val untype_structure : Typedtree.structure -> Parsetree.structure
val untype_signature : Typedtree.signature -> Parsetree.signature
val untype_expression : Typedtree.expression -> Parsetree.expression
-val untype_type_declaration : Typedtree.type_declaration -> Parsetree.type_declaration
+val untype_type_declaration :
+ Typedtree.type_declaration -> Parsetree.type_declaration
val untype_module_type : Typedtree.module_type -> Parsetree.module_type
val lident_of_path : Path.t -> Longident.t
generated by cgit v1.2.3-70-g09d2 (git 2.46.0) at 2025-03-27 12:04:40 +0000