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

Continue. 

git-svn-id: http://caml.inria.fr/svn/ocaml/branches/extension_points@13333 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
master
Alain Frisch 2013-03-04 12:54:57 +00:00
parent c8d3ff52a2
commit e58b2cd036
15 changed files with 152 additions and 104 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml
View File

@ -1075,13 +1075,13 @@ value varify_constructors var_names =
| StExc _ _ _ -> assert False (*FIXME*)
| StExp loc e -> [mkstr loc (Pstr_eval (expr e)) :: l]
| StExt loc n t sl -> [mkstr loc (Pstr_primitive (with_loc n loc) (mkvalue_desc loc t (list_of_meta_list sl))) :: l]
| StInc loc me -> [mkstr loc (Pstr_include (module_expr me)) :: l]
| StInc loc me -> [mkstr loc (Pstr_include (module_expr me, [])) :: l]
| StMod loc n me -> [mkstr loc (Pstr_module (with_loc n loc) (module_expr me)) :: l]
| StRecMod loc mb ->
[mkstr loc (Pstr_recmodule (module_str_binding mb [])) :: l]
| StMty loc n mt -> [mkstr loc (Pstr_modtype (with_loc n loc) (module_type mt)) :: l]
| StOpn loc id ->
[mkstr loc (Pstr_open (long_uident id)) :: l]
[mkstr loc (Pstr_open (long_uident id, [])) :: l]
| StTyp loc tdl -> [mkstr loc (Pstr_type (mktype_decl tdl [])) :: l]
| StVal loc rf bi ->
[mkstr loc (Pstr_value (mkrf rf) (binding bi [])) :: l]

4
camlp4/boot/Camlp4.ml
View File

@ -15446,7 +15446,7 @@ module Struct =
(mkvalue_desc loc t (list_of_meta_list sl))))) ::
l
| StInc (loc, me) ->
(mkstr loc (Pstr_include (module_expr me))) :: l
(mkstr loc (Pstr_include (module_expr me, []))) :: l
| StMod (loc, n, me) ->
(mkstr loc
(Pstr_module ((with_loc n loc), (module_expr me)))) ::
@ -15459,7 +15459,7 @@ module Struct =
(Pstr_modtype ((with_loc n loc), (module_type mt)))) ::
l
| StOpn (loc, id) ->
(mkstr loc (Pstr_open (long_uident id))) :: l
(mkstr loc (Pstr_open (long_uident id, []))) :: l
| StTyp (loc, tdl) ->
(mkstr loc (Pstr_type (mktype_decl tdl []))) :: l
| StVal (loc, rf, bi) ->

8
ocamldoc/odoc_ast.ml
View File

@ -1054,10 +1054,6 @@ module Analyser =
Parsetree.Pstr_eval _ ->
(* don't care *)
(0, env, [])
| Parsetree.Pstr_attribute (x, _) ->
analyse_structure_item env current_module_name loc pos_limit comment_opt x.Parsetree.pstr_desc typedtree table table_values
| Parsetree.Pstr_extension _ ->
(0, env, [])
| Parsetree.Pstr_value (rec_flag, pat_exp_list) ->
(* of rec_flag * (pattern * expression) list *)
(* For each value, look for the value name, then look in the
@ -1423,7 +1419,7 @@ module Analyser =
in
(0, new_env2, [ Element_module_type mt ])
| Parsetree.Pstr_open longident ->
| Parsetree.Pstr_open (longident, _attrs) ->
(* A VOIR : enrichir l'environnement quand open ? *)
let ele_comments = match comment_opt with
None -> []
@ -1533,7 +1529,7 @@ module Analyser =
in
(0, new_env, f ~first: true loc.Location.loc_start.Lexing.pos_cnum class_type_decl_list)
| Parsetree.Pstr_include module_expr ->
| Parsetree.Pstr_include (module_expr, _attrs) ->
(* we add a dummy included module which will be replaced by a correct
one at the end of the module analysis,
to use the Path.t of the included modules in the typdtree. *)

17
parsing/ast_mapper.ml
View File

@ -24,6 +24,7 @@ let map_tuple f1 f2 (x, y) = (f1 x, f2 y)
let map_opt f = function None -> None | Some x -> Some (f x)
let map_loc sub {loc; txt} = {loc = sub # location loc; txt}
let map_attributes sub attrs = List.map (sub # attribute) attrs
module T = struct
(* Type expressions for the core language *)
@ -210,6 +211,8 @@ module M = struct
let apply ?loc m1 m2 = mk ?loc (Pmod_apply (m1, m2))
let constraint_ ?loc m mty = mk ?loc (Pmod_constraint (m, mty))
let unpack ?loc e = mk ?loc (Pmod_unpack e)
let attribute ?loc a b = mk ?loc (Pmod_attribute (a, b))
let extension ?loc a = mk ?loc (Pmod_extension a)
let map sub {pmod_loc = loc; pmod_desc = desc} =
let loc = sub # location loc in
@ -220,6 +223,8 @@ module M = struct
| Pmod_apply (m1, m2) -> apply ~loc (sub # module_expr m1) (sub # module_expr m2)
| Pmod_constraint (m, mty) -> constraint_ ~loc (sub # module_expr m) (sub # module_type mty)
| Pmod_unpack e -> unpack ~loc (sub # expr e)
| Pmod_attribute (body, x) -> attribute ~loc (sub # module_expr body) (sub # attribute x)
| Pmod_extension x -> extension ~loc (sub # extension x)
let mk_item ?(loc = Location.none) x = {pstr_desc = x; pstr_loc = loc}
let eval ?loc a = mk_item ?loc (Pstr_eval a)
@ -231,12 +236,10 @@ module M = struct
let module_ ?loc a b = mk_item ?loc (Pstr_module (a, b))
let rec_module ?loc a = mk_item ?loc (Pstr_recmodule a)
let modtype ?loc a b = mk_item ?loc (Pstr_modtype (a, b))
let open_ ?loc a = mk_item ?loc (Pstr_open a)
let open_ ?loc ?(attributes = []) a = mk_item ?loc (Pstr_open (a, attributes))
let class_ ?loc a = mk_item ?loc (Pstr_class a)
let class_type ?loc a = mk_item ?loc (Pstr_class_type a)
let include_ ?loc a = mk_item ?loc (Pstr_include a)
let attribute ?loc a b = mk_item ?loc (Pstr_attribute (a, b))
let extension ?loc a = mk_item ?loc (Pstr_extension a)
let include_ ?loc ?(attributes = []) a = mk_item ?loc (Pstr_include (a, attributes))
let map_structure_item sub {pstr_loc = loc; pstr_desc = desc} =
let loc = sub # location loc in
@ -250,12 +253,10 @@ module M = struct
| Pstr_module (s, m) -> module_ ~loc (map_loc sub s) (sub # module_expr m)
| Pstr_recmodule l -> rec_module ~loc (List.map (fun (s, mty, me) -> (map_loc sub s, sub # module_type mty, sub # module_expr me)) l)
| Pstr_modtype (s, mty) -> modtype ~loc (map_loc sub s) (sub # module_type mty)
| Pstr_open lid -> open_ ~loc (map_loc sub lid)
| Pstr_open (lid, attrs) -> open_ ~loc ~attributes:(map_attributes sub attrs) (map_loc sub lid)
| Pstr_class l -> class_ ~loc (List.map (sub # class_declaration) l)
| Pstr_class_type l -> class_type ~loc (List.map (sub # class_type_declaration) l)
| Pstr_include e -> include_ ~loc (sub # module_expr e)
| Pstr_attribute (body, x) -> attribute ~loc (sub # structure_item body) (sub # attribute x)
| Pstr_extension x -> extension ~loc (sub # extension x)
| Pstr_include (e, attrs) -> include_ ~loc (sub # module_expr e) ~attributes:(map_attributes sub attrs)
end
module E = struct

4
parsing/ast_mapper.mli
View File

@ -174,10 +174,10 @@ module M:
val module_: ?loc:Location.t -> string loc -> module_expr -> structure_item
val rec_module: ?loc:Location.t -> (string loc * module_type * module_expr) list -> structure_item
val modtype: ?loc:Location.t -> string loc -> module_type -> structure_item
val open_: ?loc:Location.t -> Longident.t loc -> structure_item
val open_: ?loc:Location.t -> ?attributes:attribute list -> Longident.t loc -> structure_item
val class_: ?loc:Location.t -> class_declaration list -> structure_item
val class_type: ?loc:Location.t -> class_type_declaration list -> structure_item
val include_: ?loc:Location.t -> module_expr -> structure_item
val include_: ?loc:Location.t -> ?attributes:attribute list -> module_expr -> structure_item
val map_structure_item: mapper -> structure_item -> structure_item
end

14
parsing/lexer.mll
View File

@ -397,6 +397,20 @@ rule token = parse
| ">]" { GREATERRBRACKET }
| "}" { RBRACE }
| ">}" { GREATERRBRACE }
| "(:="
{ lexbuf.lex_curr_pos <- lexbuf.lex_curr_pos - 2;
let curpos = lexbuf.lex_curr_p in
lexbuf.lex_curr_p <- { curpos with pos_cnum = curpos.pos_cnum - 2 };
LPAREN
}
| "(::"
{ lexbuf.lex_curr_pos <- lexbuf.lex_curr_pos - 2;
let curpos = lexbuf.lex_curr_p in
lexbuf.lex_curr_p <- { curpos with pos_cnum = curpos.pos_cnum - 2 };
LPAREN
}
| "(:" { LPARENCOLON }
| "[:" { LBRACKETCOLON }
| "!" { BANG }
| "!=" { INFIXOP0 "!=" }

119
parsing/parser.mly
View File

@ -369,11 +369,13 @@ let wrap_type_annotation newtypes core_type body =
%token LBRACKETBAR
%token LBRACKETLESS
%token LBRACKETGREATER
%token LBRACKETCOLON
%token LESS
%token LESSMINUS
%token LET
%token <string> LIDENT
%token LPAREN
%token LPARENCOLON
%token MATCH
%token METHOD
%token MINUS
@ -465,6 +467,8 @@ The precedences must be listed from low to high.
%nonassoc below_EQUAL
%left INFIXOP0 EQUAL LESS GREATER /* expr (e OP e OP e) */
%right INFIXOP1 /* expr (e OP e OP e) */
%nonassoc below_LBRACKETCOLON
%nonassoc LBRACKETCOLON /* expr [:extn] */
%right COLONCOLON /* expr (e :: e :: e) */
%left INFIXOP2 PLUS PLUSDOT MINUS MINUSDOT /* expr (e OP e OP e) */
%left INFIXOP3 STAR /* expr (e OP e OP e) */
@ -479,7 +483,7 @@ The precedences must be listed from low to high.
/* Finally, the first tokens of simple_expr are above everything else. */
%nonassoc BACKQUOTE BANG BEGIN CHAR FALSE FLOAT INT INT32 INT64
LBRACE LBRACELESS LBRACKET LBRACKETBAR LIDENT LPAREN
NEW NATIVEINT PREFIXOP STRING TRUE UIDENT
LPARENCOLON NEW NATIVEINT PREFIXOP STRING TRUE UIDENT
/* Entry points */
@ -569,6 +573,10 @@ module_expr:
{ unclosed "(" 1 ")" 5 }
| LPAREN VAL expr error
{ unclosed "(" 1 ")" 4 }
| extension
{ mkmod(Pmod_extension $1) }
| module_expr attribute
{ mkmod(Pmod_attribute ($1, $2)) }
;
structure:
structure_tail { $1 }
@ -601,18 +609,14 @@ structure_item:
{ mkstr(Pstr_recmodule(List.rev $3)) }
| MODULE TYPE ident EQUAL module_type
{ mkstr(Pstr_modtype(mkrhs $3 3, $5)) }
| OPEN mod_longident
{ mkstr(Pstr_open (mkrhs $2 2)) }
| OPEN mod_longident opt_with_attributes
{ mkstr(Pstr_open (mkrhs $2 2, $3)) }
| CLASS class_declarations
{ mkstr(Pstr_class (List.rev $2)) }
| CLASS TYPE class_type_declarations
{ mkstr(Pstr_class_type (List.rev $3)) }
| INCLUDE module_expr
{ mkstr(Pstr_include $2) }
| DOTDOT extension
{ mkstr (Pstr_extension $2) }
| structure_item DOTDOT attribute
{ mkstr(Pstr_attribute ($1, $3)) }
| INCLUDE module_expr opt_with_attributes
{ mkstr(Pstr_include ($2, $3)) }
;
module_binding:
EQUAL module_expr
@ -677,7 +681,7 @@ signature_item:
{ mksig(Psig_modtype(mkrhs $3 3, Pmodtype_manifest $5)) }
| OPEN mod_longident
{ mksig(Psig_open (mkrhs $2 2)) }
| INCLUDE module_type
| INCLUDE module_type %prec below_WITH
{ mksig(Psig_include $2) }
| CLASS class_descriptions
{ mksig(Psig_class (List.rev $2)) }
@ -686,7 +690,7 @@ signature_item:
;
module_declaration:
COLON module_type
COLON module_type %prec below_WITH
{ $2 }
| LPAREN UIDENT COLON module_type RPAREN module_declaration
{ mkmty(Pmty_functor(mkrhs $2 2, $4, $6)) }
@ -696,7 +700,7 @@ module_rec_declarations:
| module_rec_declarations AND module_rec_declaration { $3 :: $1 }
;
module_rec_declaration:
UIDENT COLON module_type { (mkrhs $1 1, $3) }
UIDENT COLON module_type %prec below_WITH { (mkrhs $1 1, $3) }
;
/* Class expressions */
@ -731,11 +735,11 @@ class_fun_def:
{ let (l,o,p) = $1 in mkclass(Pcl_fun(l, o, p, $2)) }
;
class_expr:
class_simple_expr
class_simple_expr %prec below_SHARP
{ $1 }
| FUN class_fun_def
{ $2 }
| class_simple_expr simple_labeled_expr_list
| class_simple_expr simple_labeled_expr_list %prec below_SHARP
{ mkclass(Pcl_apply($1, List.rev $2)) }
| LET rec_flag let_bindings IN class_expr
{ mkclass(Pcl_let ($2, List.rev $3, $5)) }
@ -835,13 +839,13 @@ concrete_method :
class_type:
class_signature
{ $1 }
| QUESTION LIDENT COLON simple_core_type_or_tuple MINUSGREATER class_type
| QUESTION LIDENT COLON simple_core_type_or_tuple_no_attr MINUSGREATER class_type
{ mkcty(Pcty_fun("?" ^ $2 , mkoption $4, $6)) }
| OPTLABEL simple_core_type_or_tuple MINUSGREATER class_type
| OPTLABEL simple_core_type_or_tuple_no_attr MINUSGREATER class_type
{ mkcty(Pcty_fun("?" ^ $1, mkoption $2, $4)) }
| LIDENT COLON simple_core_type_or_tuple MINUSGREATER class_type
| LIDENT COLON simple_core_type_or_tuple_no_attr MINUSGREATER class_type
{ mkcty(Pcty_fun($1, $3, $5)) }
| simple_core_type_or_tuple MINUSGREATER class_type
| simple_core_type_or_tuple_no_attr MINUSGREATER class_type
{ mkcty(Pcty_fun("", $1, $3)) }
;
class_signature:
@ -974,7 +978,7 @@ let_pattern:
expr:
simple_expr %prec below_SHARP
{ $1 }
| simple_expr simple_labeled_expr_list
| simple_expr simple_labeled_expr_list %prec below_SHARP
{ mkexp(Pexp_apply($1, List.rev $2)) }
| LET rec_flag let_bindings IN seq_expr
{ mkexp(Pexp_let($2, List.rev $3, $5)) }
@ -1072,7 +1076,7 @@ expr:
{ mkexp (Pexp_object($2)) }
| OBJECT class_structure error
{ unclosed "object" 1 "end" 3 }
| simple_expr attribute
| expr attribute
{ mkexp (Pexp_attribute($1, $2)) }
;
opt_expr:
@ -1156,8 +1160,8 @@ simple_expr:
Some (ghtyp (Ptyp_package $5)), None)) }
| LPAREN MODULE module_expr COLON error
{ unclosed "(" 1 ")" 5 }
| extension
{ mkexp (Pexp_extension $1) }
| LPARENCOLON extension
{ mkexp (Pexp_extension $2) }
;
simple_labeled_expr_list:
labeled_simple_expr
@ -1384,7 +1388,7 @@ type_declarations:
;
type_declaration:
optional_type_parameters LIDENT type_kind constraints type_declaration_attribute
optional_type_parameters LIDENT type_kind constraints opt_with_attributes
{ let (params, variance) = List.split $1 in
let (kind, private_flag, manifest) = $3 in
(mkrhs $2 2, {ptype_params = params;
@ -1394,12 +1398,7 @@ type_declaration:
ptype_manifest = manifest;
ptype_variance = variance;
ptype_attributes = $5;
ptype_loc = symbol_rloc();
}) }
;
type_declaration_attribute:
WITH attributes { $2 }
| { [] }
ptype_loc = symbol_rloc() }) }
;
constraints:
constraints CONSTRAINT constrain { $3 :: $1 }
@ -1479,7 +1478,8 @@ generalized_constructor_arguments:
| OF core_type_list { (List.rev $2,None) }
| COLON core_type_list MINUSGREATER simple_core_type
{ (List.rev $2,Some $4) }
| COLON simple_core_type { ([],Some $2) }
| COLON simple_core_type %prec below_LBRACKETCOLON
{ ([],Some $2) }
;
@ -1574,6 +1574,14 @@ simple_core_type:
| simple_core_type attribute
{ mktyp (Ptyp_attribute($1, $2)) }
;
simple_core_type_no_attr:
simple_core_type2 %prec below_SHARP
{ $1 }
| LPAREN core_type_comma_list RPAREN %prec below_SHARP
{ match $2 with [sty] -> sty | _ -> raise Parse_error }
;
simple_core_type2:
QUOTE ident
{ mktyp(Ptyp_var $2) }
@ -1615,18 +1623,8 @@ simple_core_type2:
{ mktyp(Ptyp_variant(List.rev $3, true, Some (List.rev $5))) }
| LPAREN MODULE package_type RPAREN
{ mktyp(Ptyp_package $3) }
| extension
{ mktyp (Ptyp_extension $1) }
;
extension:
| LPAREN AMPERSAND LIDENT opt_expr RPAREN { ($3, $4) }
;
attribute:
| LPAREN COLON LIDENT opt_expr RPAREN { ($3, $4) }
;
attributes:
| { [] }
| attribute attributes { $1 :: $2 }
| LPARENCOLON extension
{ mktyp (Ptyp_extension $2) }
;
package_type:
mty_longident { (mkrhs $1 1, []) }
@ -1670,18 +1668,28 @@ name_tag_list:
| name_tag_list name_tag { $2 :: $1 }
;
simple_core_type_or_tuple:
simple_core_type { $1 }
simple_core_type %prec below_LBRACKETCOLON { $1 }
| simple_core_type STAR core_type_list
{ mktyp(Ptyp_tuple($1 :: List.rev $3)) }
;
simple_core_type_or_tuple_no_attr:
simple_core_type_no_attr
{ $1 }
| simple_core_type_no_attr STAR core_type_list_no_attr
{ mktyp(Ptyp_tuple($1 :: List.rev $3)) }
;
core_type_comma_list:
core_type { [$1] }
| core_type_comma_list COMMA core_type { $3 :: $1 }
;
core_type_list:
simple_core_type { [$1] }
simple_core_type %prec below_LBRACKETCOLON { [$1] }
| core_type_list STAR simple_core_type { $3 :: $1 }
;
core_type_list_no_attr:
simple_core_type_no_attr { [$1] }
| core_type_list STAR simple_core_type_no_attr { $3 :: $1 }
;
meth_list:
field SEMI meth_list { $1 :: $3 }
| field opt_semi { [$1] }
@ -1869,4 +1877,27 @@ additive:
| PLUS { "+" }
| PLUSDOT { "+." }
;
/* Attributes */
attribute:
LBRACKETCOLON LIDENT opt_expr RBRACKET { ($2, $3) }
;
opt_with_attributes:
{ [] }
| WITH with_attributes { $2 }
;
with_attributes:
with_attribute
{ [$1] }
| with_attribute COMMA with_attributes
{ $1 :: $3 }
;
with_attribute:
LIDENT { $1, ghunit () }
| LIDENT LPAREN expr RPAREN { $1, $3 }
;
extension:
LPARENCOLON LIDENT opt_expr RPAREN { ($2, $3) }
;
%%

8
parsing/parsetree.mli
View File

@ -281,6 +281,8 @@ and module_expr_desc =
| Pmod_apply of module_expr * module_expr
| Pmod_constraint of module_expr * module_type
| Pmod_unpack of expression
| Pmod_attribute of (module_expr * attribute)
| Pmod_extension of extension
and structure = structure_item list
@ -298,12 +300,10 @@ and structure_item_desc =
| Pstr_module of string loc * module_expr
| Pstr_recmodule of (string loc * module_type * module_expr) list
| Pstr_modtype of string loc * module_type
| Pstr_open of Longident.t loc
| Pstr_open of Longident.t loc * attribute list
| Pstr_class of class_declaration list
| Pstr_class_type of class_type_declaration list
| Pstr_include of module_expr
| Pstr_attribute of structure_item * attribute
| Pstr_extension of extension
| Pstr_include of module_expr * attribute list
(* Toplevel phrases *)

10
parsing/pprintast.ml
View File

@ -937,6 +937,7 @@ class printer ()= object(self:'self)
pp f "%a(%a)" self#module_expr me1 self#module_expr me2
| Pmod_unpack e ->
pp f "(val@ %a)" self#expression e
| Pmod_extension _ | Pmod_attribute _ -> assert false
method structure f x = self#list ~sep:"@\n" self#structure_item f x
@ -1025,7 +1026,7 @@ class printer ()= object(self:'self)
| _ ->
pp f " =@ %a" self#module_expr me
)) me
| Pstr_open (li) ->
| Pstr_open (li, _attrs) ->
pp f "@[<2>open@;%a@]" self#longident_loc li;
| Pstr_modtype (s, mt) ->
pp f "@[<2>module type %s =@;%a@]" s.txt self#module_type mt
@ -1074,7 +1075,7 @@ class printer ()= object(self:'self)
pp f "@[<hov2>external@ %s@ :@ %a@]"
(if need_parens then "( "^s.txt^" )" else s.txt)
self#value_description vd
| Pstr_include me ->
| Pstr_include (me, _attrs) ->
pp f "@[<hov2>include@ %a@]" self#module_expr me
| Pstr_exn_rebind (s, li) -> (* todo: check this *)
pp f "@[<hov2>exception@ %s@ =@ %a@]" s.txt self#longident_loc li
@ -1091,11 +1092,6 @@ class printer ()= object(self:'self)
(fun f l2 -> List.iter (text_x_modtype_x_module f) l2) l2
| _ -> assert false
end
| Pstr_attribute (body, (s, arg)) ->
pp f "@[<2>%a@ (:%s@ %a)@]" self#structure_item body s self#expression arg
| Pstr_extension (s, arg) ->
pp f "@[<2>&(%s@ %a)@]" s self#expression arg
end
method type_param f = function
| (a,opt) -> pp f "%s%a" (type_variance a ) self#type_var_option opt

32
parsing/printast.ml
View File

@ -377,12 +377,15 @@ and type_declaration i ppf x =
line i ppf "ptype_manifest =\n";
option (i+1) core_type ppf x.ptype_manifest;
line i ppf "ptype_attributes = \n";
attributes (i+1) ppf x.ptype_attributes
and attributes i ppf l =
List.iter
(fun (s, arg) ->
line (i + 1) ppf "attribute \"%s\"\n" s;
expression (i + 1) ppf arg;
line i ppf "attribute \"%s\"\n" s;
expression i ppf arg;
)
x.ptype_attributes
l
and type_kind i ppf x =
match x with
@ -631,6 +634,13 @@ and module_expr i ppf x =
| Pmod_unpack (e) ->
line i ppf "Pmod_unpack\n";
expression i ppf e;
| Pmod_attribute (body, (s, arg)) ->
line i ppf "Pmod_attribute \"%s\"\n" s;
expression i ppf arg;
module_expr i ppf body
| Pmod_extension (s, arg) ->
line i ppf "Pmod_extension \"%s\"\n" s;
expression i ppf arg
and structure i ppf x = list i structure_item ppf x
@ -666,23 +676,19 @@ and structure_item i ppf x =
| Pstr_modtype (s, mt) ->
line i ppf "Pstr_modtype %a\n" fmt_string_loc s;
module_type i ppf mt;
| Pstr_open li -> line i ppf "Pstr_open %a\n" fmt_longident_loc li;
| Pstr_open (li, attrs) ->
line i ppf "Pstr_open %a\n" fmt_longident_loc li;
attributes i ppf attrs
| Pstr_class (l) ->
line i ppf "Pstr_class\n";
list i class_declaration ppf l;
| Pstr_class_type (l) ->
line i ppf "Pstr_class_type\n";
list i class_type_declaration ppf l;
| Pstr_include me ->
| Pstr_include (me, attrs) ->
line i ppf "Pstr_include";
module_expr i ppf me
| Pstr_attribute (body, (s, arg)) ->
line i ppf "Pstr_attribute \"%s\"\n" s;
expression i ppf arg;
structure_item i ppf body
| Pstr_extension (s, arg) ->
line i ppf "Pstr_extension \"%s\"\n" s;
expression i ppf arg
module_expr i ppf me;
attributes i ppf attrs
and string_x_type_declaration i ppf (s, td) =
string_loc i ppf s;

10
tools/depend.ml
View File

@ -251,6 +251,10 @@ and add_module bv modl =
add_module bv modl; add_modtype bv mty
| Pmod_unpack(e) ->
add_expr bv e
| Pmod_attribute(modl, _) ->
add_module bv modl
| Pmod_extension _ ->
()
and add_structure bv item_list =
List.fold_left add_struct_item bv item_list
@ -281,16 +285,14 @@ and add_struct_item bv item =
bv'
| Pstr_modtype(id, mty) ->
add_modtype bv mty; bv
| Pstr_open l ->
| Pstr_open (l, _attrs) ->
addmodule bv l; 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 ->
| Pstr_include (modl, _attrs) ->
add_module bv modl; bv
| Pstr_attribute (e, _) -> add_struct_item bv e
| Pstr_extension _ -> bv
and add_use_file bv top_phrs =
ignore (List.fold_left add_top_phrase bv top_phrs)

2
tools/ocamlprof.ml
View File

@ -359,6 +359,8 @@ and rewrite_mod iflag smod =
| Pmod_apply(smod1, smod2) -> rewrite_mod iflag smod1; rewrite_mod iflag smod2
| Pmod_constraint(smod, smty) -> rewrite_mod iflag smod
| Pmod_unpack(sexp) -> rewrite_exp iflag sexp
| Pmod_attribute (smod, _) -> rewrite_mod iflag smod
| Pmod_extension _ -> ()
and rewrite_str_item iflag item =
match item.pstr_desc with

4
tools/untypeast.ml
View File

@ -64,7 +64,7 @@ and untype_structure_item item =
untype_module_expr mexpr) list)
| Tstr_modtype (_id, name, mtype) ->
Pstr_modtype (name, untype_module_type mtype)
| Tstr_open (_path, lid) -> Pstr_open (lid)
| Tstr_open (_path, lid) -> Pstr_open (lid, [])
| Tstr_class list ->
Pstr_class (List.map (fun (ci, _, _) ->
{ pci_virt = ci.ci_virt;
@ -87,7 +87,7 @@ and untype_structure_item item =
}
) list)
| Tstr_include (mexpr, _) ->
Pstr_include (untype_module_expr mexpr)
Pstr_include (untype_module_expr mexpr, [])
in
{ pstr_desc = desc; pstr_loc = item.str_loc; }

8
typing/typecore.ml
View File

@ -156,13 +156,16 @@ let iter_expression f e =
and module_expr me =
match me.pmod_desc with
| Pmod_extension _
| Pmod_ident _ -> ()
| Pmod_structure str -> List.iter structure_item str
| Pmod_constraint (me, _)
| Pmod_attribute (me, _)
| Pmod_functor (_, _, me) -> module_expr me
| Pmod_apply (me1, me2) -> module_expr me1; module_expr me2
| Pmod_unpack e -> expr e
and structure_item str =
match str.pstr_desc with
| Pstr_eval e -> expr e
@ -173,14 +176,11 @@ let iter_expression f e =
| Pstr_modtype _
| Pstr_open _
| Pstr_class_type _
| Pstr_extension _
| Pstr_exn_rebind _ -> ()
| Pstr_include me
| Pstr_include (me, _)
| Pstr_module (_, me) -> module_expr me
| Pstr_recmodule l -> List.iter (fun (_, _, me) -> module_expr me) l
| Pstr_class cdl -> List.iter (fun c -> class_expr c.pci_expr) cdl
| Pstr_attribute (i, _) -> structure_item i
and class_expr ce =
match ce.pcl_desc with

12
typing/typemod.ml
View File

@ -912,6 +912,10 @@ let rec type_module sttn funct_body anchor env smod =
mod_type = mty;
mod_env = env;
mod_loc = smod.pmod_loc }
| Pmod_attribute (me, _attrs) ->
type_module sttn funct_body anchor env me
| Pmod_extension (s, _arg) ->
raise (Error (smod.pmod_loc, env, Extension s))
and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
let type_names = ref StringSet.empty
@ -1044,7 +1048,7 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
(item :: str_rem,
Sig_modtype(id, Modtype_manifest mty.mty_type) :: sig_rem,
final_env)
| Pstr_open (lid) ->
| Pstr_open (lid, _attrs) ->
let (path, newenv) = type_open ~toplevel env loc lid in
let item = mk (Tstr_open (path, lid)) in
let (str_rem, sig_rem, final_env) = type_struct newenv srem in
@ -1106,7 +1110,7 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
Sig_type(i'', d'', rs)])
classes [sig_rem]),
final_env)
| Pstr_include smodl ->
| Pstr_include (smodl, _attrs) ->
let modl = type_module true funct_body None env smodl in
(* Rename all identifiers bound by this signature to avoid clashes *)
let sg = Subst.signature Subst.identity
@ -1119,10 +1123,6 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
(item :: str_rem,
sg @ sig_rem,
final_env)
| Pstr_attribute (st, _) ->
type_struct env srem (* keep attribute in the typedtree? *)
| Pstr_extension (s, _arg) ->
raise (Error (loc, env, Extension s))
in
if !Clflags.annotations then
(* moved to genannot *)