Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Merge pull request #392 from diml/ast-invariants 

Ast invariants
master
Alain Frisch 2016-01-27 22:34:02 +01:00
parent 9e8facef9c f9ebe43e75
commit 3f9442604c
14 changed files with 303 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
.depend
View File

@ -45,6 +45,7 @@ utils/warnings.cmo : utils/warnings.cmi
utils/warnings.cmx : utils/warnings.cmi
parsing/ast_helper.cmi : parsing/parsetree.cmi parsing/longident.cmi \
parsing/location.cmi parsing/docstrings.cmi parsing/asttypes.cmi
parsing/ast_invariants.cmi : parsing/parsetree.cmi
parsing/ast_mapper.cmi : parsing/parsetree.cmi parsing/location.cmi
parsing/asttypes.cmi : parsing/location.cmi
parsing/attr_helper.cmi : parsing/parsetree.cmi parsing/location.cmi \
@ -70,6 +71,10 @@ parsing/ast_helper.cmo : parsing/parsetree.cmi parsing/longident.cmi \
parsing/ast_helper.cmx : parsing/parsetree.cmi parsing/longident.cmx \
parsing/location.cmx parsing/docstrings.cmx parsing/asttypes.cmi \
parsing/ast_helper.cmi
parsing/ast_invariants.cmo : parsing/syntaxerr.cmi parsing/parsetree.cmi \
parsing/ast_mapper.cmi parsing/ast_invariants.cmi
parsing/ast_invariants.cmx : parsing/syntaxerr.cmx parsing/parsetree.cmi \
parsing/ast_mapper.cmx parsing/ast_invariants.cmi
parsing/ast_mapper.cmo : parsing/parsetree.cmi utils/misc.cmi \
parsing/longident.cmi parsing/location.cmi utils/config.cmi \
utils/clflags.cmi parsing/asttypes.cmi parsing/ast_helper.cmi \
@ -1895,10 +1900,10 @@ driver/optmain.cmx : utils/warnings.cmx utils/timings.cmx \
asmcomp/arch.cmx driver/optmain.cmi
driver/pparse.cmo : utils/timings.cmi parsing/parse.cmi utils/misc.cmi \
parsing/location.cmi utils/config.cmi utils/clflags.cmi utils/ccomp.cmi \
parsing/ast_mapper.cmi driver/pparse.cmi
parsing/ast_mapper.cmi parsing/ast_invariants.cmi driver/pparse.cmi
driver/pparse.cmx : utils/timings.cmx parsing/parse.cmx utils/misc.cmx \
parsing/location.cmx utils/config.cmx utils/clflags.cmx utils/ccomp.cmx \
parsing/ast_mapper.cmx driver/pparse.cmi
parsing/ast_mapper.cmx parsing/ast_invariants.cmx driver/pparse.cmi
toplevel/genprintval.cmi : typing/types.cmi typing/path.cmi \
typing/outcometree.cmi typing/env.cmi
toplevel/opttopdirs.cmi : parsing/longident.cmi

4
Changes
View File

@ -147,6 +147,8 @@ Compilers:
(David Allsopp)
- GPR#431: permit constant float arrays to be eligible for pattern match
branch merging (Pierre Chambart)
- GPR#392: put all parsetree invariants in a new module Ast_invariants
(Jérémie Dimino)
Runtime system:
- PR#3612: allow allocating custom block with finalizers in the minor heap
@ -473,6 +475,8 @@ Bug fixes:
(David Allsopp)
- GPR#441: better type error location in presence of type constraints
(Thomas Refis, report by Arseniy Alekseyev)
- PR#7111: reject empty let bindings instead of printing incorrect syntax
(Jérémie Dimino)
Features wishes:
- PR#4518, GPR#29: change location format for reporting errors in ocamldoc

2
Makefile.shared
View File

@ -49,7 +49,7 @@ PARSING=parsing/location.cmo parsing/longident.cmo \
parsing/lexer.cmo parsing/parse.cmo parsing/printast.cmo \
parsing/pprintast.cmo \
parsing/ast_mapper.cmo parsing/attr_helper.cmo \
parsing/builtin_attributes.cmo
parsing/builtin_attributes.cmo parsing/ast_invariants.cmo
TYPING=typing/ident.cmo typing/path.cmo \
typing/primitive.cmo typing/types.cmo \

15
driver/pparse.ml
View File

@ -145,7 +145,7 @@ let open_and_check_magic inputfile ast_magic =
in
(ic, is_ast_file)
let file ppf ~tool_name inputfile parse_fun ast_magic =
let file_aux ppf ~tool_name inputfile parse_fun invariant_fun ast_magic =
let (ic, is_ast_file) = open_and_check_magic inputfile ast_magic in
let ast =
try
@ -166,7 +166,12 @@ let file ppf ~tool_name inputfile parse_fun ast_magic =
with x -> close_in ic; raise x
in
close_in ic;
apply_rewriters ~restore:false ~tool_name ast_magic ast
let ast = apply_rewriters ~restore:false ~tool_name ast_magic ast in
if is_ast_file || !Clflags.all_ppx <> [] then invariant_fun ast;
ast
let file ppf ~tool_name inputfile parse_fun ast_magic =
file_aux ppf ~tool_name inputfile parse_fun ignore ast_magic
let report_error ppf = function
| CannotRun cmd ->
@ -183,11 +188,11 @@ let () =
| _ -> None
)
let parse_all ~tool_name parse_fun magic ppf sourcefile =
let parse_all ~tool_name parse_fun invariant_fun magic ppf sourcefile =
Location.input_name := sourcefile;
let inputfile = preprocess sourcefile in
let ast =
try file ppf ~tool_name inputfile parse_fun magic
try file_aux ppf ~tool_name inputfile parse_fun invariant_fun magic
with exn ->
remove_preprocessed inputfile;
raise exn
@ -198,8 +203,10 @@ let parse_all ~tool_name parse_fun magic ppf sourcefile =
let parse_implementation ppf ~tool_name sourcefile =
parse_all ~tool_name
(Timings.(time (Parsing sourcefile)) Parse.implementation)
Ast_invariants.structure
Config.ast_impl_magic_number ppf sourcefile
let parse_interface ppf ~tool_name sourcefile =
parse_all ~tool_name
(Timings.(time (Parsing sourcefile)) Parse.interface)
Ast_invariants.signature
Config.ast_intf_magic_number ppf sourcefile

158
parsing/ast_invariants.ml Normal file
View File

@ -0,0 +1,158 @@
(***********************************************************************)
(* *)
(* OCaml *)
(* *)
(* Jeremie Dimino, Jane Street Europe *)
(* *)
(* Copyright 2015 Jane Street Group LLC *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file ../LICENSE. *)
(* *)
(***********************************************************************)
open Asttypes
open Parsetree
open Ast_mapper
let err = Syntaxerr.ill_formed_ast
let empty_record loc = err loc "Records cannot be empty."
let empty_variant loc = err loc "Variant types cannot be empty."
let invalid_tuple loc = err loc "Tuples must have at least 2 components."
let no_args loc = err loc "Function application with no argument."
let empty_let loc = err loc "Let with no bindings."
let empty_type loc = err loc "Type declarations cannot be empty."
let complex_id loc = err loc "Functor application not allowed here."
let simple_longident id =
let rec is_simple = function
| Longident.Lident _ -> true
| Longident.Ldot (id, _) -> is_simple id
| Longident.Lapply _ -> false
in
if not (is_simple id.txt) then complex_id id.loc
let mapper =
let super = Ast_mapper.default_mapper in
let type_declaration self td =
let td = super.type_declaration self td in
let loc = td.ptype_loc in
match td.ptype_kind with
| Ptype_record [] -> empty_record loc
| Ptype_variant [] -> empty_variant loc
| _ -> td
in
let typ self ty =
let ty = super.typ self ty in
let loc = ty.ptyp_loc in
match ty.ptyp_desc with
| Ptyp_tuple ([] | [_]) -> invalid_tuple loc
| Ptyp_class (id, _) -> simple_longident id; ty
| Ptyp_package (_, cstrs) ->
List.iter (fun (id, _) -> simple_longident id) cstrs;
ty
| _ -> ty
in
let pat self pat =
let pat = super.pat self pat in
let loc = pat.ppat_loc in
match pat.ppat_desc with
| Ppat_tuple ([] | [_]) -> invalid_tuple loc
| Ppat_record ([], _) -> empty_record loc
| Ppat_construct (id, _) -> simple_longident id; pat
| Ppat_record (fields, _) ->
List.iter (fun (id, _) -> simple_longident id) fields;
pat
| _ -> pat
in
let expr self exp =
let exp = super.expr self exp in
let loc = exp.pexp_loc in
match exp.pexp_desc with
| Pexp_tuple ([] | [_]) -> invalid_tuple loc
| Pexp_record ([], _) -> empty_record loc
| Pexp_apply (_, []) -> no_args loc
| Pexp_let (_, [], _) -> empty_let loc
| Pexp_ident id
| Pexp_construct (id, _)
| Pexp_field (_, id)
| Pexp_setfield (_, id, _)
| Pexp_new id
| Pexp_open (_, id, _) -> simple_longident id; exp
| Pexp_record (fields, _) ->
List.iter (fun (id, _) -> simple_longident id) fields;
exp
| _ -> exp
in
let extension_constructor self ec =
let ec = super.extension_constructor self ec in
match ec.pext_kind with
| Pext_rebind id -> simple_longident id; ec
| _ -> ec
in
let class_expr self ce =
let ce = super.class_expr self ce in
let loc = ce.pcl_loc in
match ce.pcl_desc with
| Pcl_apply (_, []) -> no_args loc
| Pcl_constr (id, _) -> simple_longident id; ce
| _ -> ce
in
let module_type self mty =
let mty = super.module_type self mty in
match mty.pmty_desc with
| Pmty_alias id -> simple_longident id; mty
| _ -> mty
in
let open_description self opn =
let opn = super.open_description self opn in
simple_longident opn.popen_lid;
opn
in
let with_constraint self wc =
let wc = super.with_constraint self wc in
match wc with
| Pwith_type (id, _)
| Pwith_module (id, _) -> simple_longident id; wc
| _ -> wc
in
let module_expr self me =
let me = super.module_expr self me in
match me.pmod_desc with
| Pmod_ident id -> simple_longident id; me
| _ -> me
in
let structure_item self st =
let st = super.structure_item self st in
let loc = st.pstr_loc in
match st.pstr_desc with
| Pstr_type (_, []) -> empty_type loc
| Pstr_value (_, []) -> empty_let loc
| _ -> st
in
let signature_item self sg =
let sg = super.signature_item self sg in
let loc = sg.psig_loc in
match sg.psig_desc with
| Psig_type (_, []) -> empty_type loc
| _ -> sg
in
{ super with
type_declaration
; typ
; pat
; expr
; extension_constructor
; class_expr
; module_expr
; module_type
; open_description
; with_constraint
; structure_item
; signature_item
}
let structure st = ignore (mapper.structure mapper st : structure)
let signature sg = ignore (mapper.signature mapper sg : signature)

18
parsing/ast_invariants.mli Normal file
View File

@ -0,0 +1,18 @@
(***********************************************************************)
(* *)
(* OCaml *)
(* *)
(* Jeremie Dimino, Jane Street Europe *)
(* *)
(* Copyright 2015 Jane Street Group LLC *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file ../LICENSE. *)
(* *)
(***********************************************************************)
(** Check AST invariants *)
val structure : Parsetree.structure -> unit
val signature : Parsetree.signature -> unit

26
testsuite/tests/ast-invariants/Makefile Normal file
View File

@ -0,0 +1,26 @@
#########################################################################
# #
# OCaml #
# #
# Jeremie Dimino, Jane Street Europe #
# #
# Copyright 2015 Jane Street Group LLC #
# #
# All rights reserved. This file is distributed under the terms of #
# the GNU Lesser General Public License version 2.1, with the #
# special exception on linking described in the file ../LICENSE. #
# #
#########################################################################
BASEDIR=../..
COMPFLAGS=-I $(TOPDIR)/parsing -I $(TOPDIR)/utils
LIBRARIES=$(TOPDIR)/compilerlibs/ocamlcommon
MODULES=
MAIN_MODULE=test
include $(BASEDIR)/makefiles/Makefile.one
include $(BASEDIR)/makefiles/Makefile.common
# This test is a bit slow and there is little value in testing both
# versions so we run only the native code one:
NATIVECODE_ONLY=true

67
testsuite/tests/ast-invariants/test.ml Normal file
View File

@ -0,0 +1,67 @@
(***********************************************************************)
(* *)
(* OCaml *)
(* *)
(* Jeremie Dimino, Jane Street Europe *)
(* *)
(* Copyright 2015 Jane Street Group LLC *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file ../LICENSE. *)
(* *)
(***********************************************************************)
(* This test checks all ml files in the ocaml repository that are accepted
by the parser satisfy [Ast_invariants].
We don't check the invariants on the output of the parser, so this test
is to ensure that we the parser doesn't accept more than [Ast_invariants].
*)
let root = "../../.."
let () = assert (Sys.file_exists (Filename.concat root "VERSION"))
type _ kind =
| Implem : Parsetree.structure kind
| Interf : Parsetree.signature kind
let parse : type a. a kind -> Lexing.lexbuf -> a = function
| Implem -> Parse.implementation
| Interf -> Parse.interface
let invariants : type a. a kind -> a -> unit = function
| Implem -> Ast_invariants.structure
| Interf -> Ast_invariants.signature
let check_file kind fn =
Warnings.parse_options false "-a";
let ic = open_in fn in
Location.input_name := fn;
let lexbuf = Lexing.from_channel ic in
Location.init lexbuf fn;
match parse kind lexbuf with
| exception _ ->
(* A few files don't parse as they are meant for the toplevel;
ignore them *)
close_in ic
| ast ->
close_in ic;
try
invariants kind ast
with exn ->
Location.report_exception Format.std_formatter exn
let rec walk dir =
Array.iter
(fun fn ->
let fn = Filename.concat dir fn in
if Sys.is_directory fn then
walk fn
else if Filename.check_suffix fn ".mli" then
check_file Interf fn
else if Filename.check_suffix fn ".ml" then
check_file Implem fn)
(Sys.readdir dir)
let () = walk root

0
testsuite/tests/ast-invariants/test.reference Normal file
View File

3
tools/Makefile.shared
View File

@ -39,7 +39,8 @@ CAMLDEP_IMPORTS=timings.cmo misc.cmo config.cmo identifiable.cmo numbers.cmo \
arg_helper.cmo clflags.cmo terminfo.cmo \
warnings.cmo location.cmo longident.cmo docstrings.cmo \
syntaxerr.cmo ast_helper.cmo parser.cmo lexer.cmo parse.cmo \
ccomp.cmo ast_mapper.cmo pparse.cmo compenv.cmo builtin_attributes.cmo
ccomp.cmo ast_mapper.cmo ast_invariants.cmo pparse.cmo compenv.cmo \
builtin_attributes.cmo
ocamldep: depend.cmi $(CAMLDEP_OBJ)
$(CAMLC) $(LINKFLAGS) -compat-32 -o ocamldep $(CAMLDEP_IMPORTS) $(CAMLDEP_OBJ)

4
typing/typeclass.ml
View File

@ -980,9 +980,7 @@ and class_expr cl_num val_env met_env scl =
cl_attributes = scl.pcl_attributes;
}
| Pcl_apply (scl', sargs) ->
if sargs = [] then
Syntaxerr.ill_formed_ast scl.pcl_loc
"Function application with no argument.";
assert (sargs <> []);
if !Clflags.principal then Ctype.begin_def ();
let cl = class_expr cl_num val_env met_env scl' in
if !Clflags.principal then begin

15
typing/typecore.ml
View File

@ -1087,8 +1087,7 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~explode ~env
| Ppat_interval _ ->
raise (Error (loc, !env, Invalid_interval))
| Ppat_tuple spl ->
if List.length spl < 2 then
Syntaxerr.ill_formed_ast loc "Tuples must have at least 2 components.";
assert (List.length spl >= 2);
let spl_ann = List.map (fun p -> (p,newvar ())) spl in
let ty = newty (Ttuple(List.map snd spl_ann)) in
unify_pat_types loc !env ty expected_ty;
@ -1210,8 +1209,7 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~explode ~env
| _ -> k None
end
| Ppat_record(lid_sp_list, closed) ->
if lid_sp_list = [] then
Syntaxerr.ill_formed_ast loc "Records cannot be empty.";
assert (lid_sp_list <> []);
let opath, record_ty =
try
let (p0, p,_) = extract_concrete_record !env expected_ty in
@ -2065,8 +2063,7 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected =
type_function ?in_function
loc sexp.pexp_attributes env ty_expected Nolabel caselist
| Pexp_apply(sfunct, sargs) ->
if sargs = [] then
Syntaxerr.ill_formed_ast loc "Function application with no argument.";
assert (sargs <> []);
begin_def (); (* one more level for non-returning functions *)
if !Clflags.principal then begin_def ();
let funct = type_exp env sfunct in
@ -2136,8 +2133,7 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected =
exp_attributes = sexp.pexp_attributes;
exp_env = env }
| Pexp_tuple sexpl ->
if List.length sexpl < 2 then
Syntaxerr.ill_formed_ast loc "Tuples must have at least 2 components.";
assert (List.length sexpl >= 2);
let subtypes = List.map (fun _ -> newgenvar ()) sexpl in
let to_unify = newgenty (Ttuple subtypes) in
unify_exp_types loc env to_unify ty_expected;
@ -2188,8 +2184,7 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected =
exp_env = env }
end
| Pexp_record(lid_sexp_list, opt_sexp) ->
if lid_sexp_list = [] then
Syntaxerr.ill_formed_ast loc "Records cannot be empty.";
assert (lid_sexp_list <> []);
let opt_exp =
match opt_sexp with
None -> None

7
typing/typedecl.ml
View File

@ -153,8 +153,7 @@ let make_params env params =
List.map make_param params
let transl_labels loc env closed lbls =
if lbls = [] then
Syntaxerr.ill_formed_ast loc "Records cannot be empty.";
assert (lbls <> []);
let all_labels = ref StringSet.empty in
List.iter
(fun {pld_name = {txt=name; loc}} ->
@ -238,9 +237,7 @@ let transl_declaration env sdecl id =
match sdecl.ptype_kind with
Ptype_abstract -> Ttype_abstract, Type_abstract
| Ptype_variant scstrs ->
if scstrs = [] then
Syntaxerr.ill_formed_ast sdecl.ptype_loc
"Variant types cannot be empty.";
assert (scstrs <> []);
let all_constrs = ref StringSet.empty in
List.iter
(fun {pcd_name = {txt = name}} ->

3
typing/typetexp.ml
View File

@ -331,8 +331,7 @@ let rec transl_type env policy styp =
let ty = newty (Tarrow(l, ty1, cty2.ctyp_type, Cok)) in
ctyp (Ttyp_arrow (l, cty1, cty2)) ty
| Ptyp_tuple stl ->
if List.length stl < 2 then
Syntaxerr.ill_formed_ast loc "Tuples must have at least 2 components.";
assert (List.length stl >= 2);
let ctys = List.map (transl_type env policy) stl in
let ty = newty (Ttuple (List.map (fun ctyp -> ctyp.ctyp_type) ctys)) in
ctyp (Ttyp_tuple ctys) ty