From 2d5bd020211be4104dec7c9e7792f458ffc101c8 Mon Sep 17 00:00:00 2001 From: Jacques Garrigue Date: Oct 01 2013 01:32:58 +0000 Subject: bootstrap camlp4 git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@14203 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02 --- diff --git a/camlp4/boot/Camlp4.ml b/camlp4/boot/Camlp4.ml index 3bfde79..be79b84 100644 --- a/camlp4/boot/Camlp4.ml +++ b/camlp4/boot/Camlp4.ml @@ -929,6 +929,8 @@ module Sig = | (* t of & t *) TyPkg of loc * module_type | (* (module S) *) + TyAtt of loc * string * str_item * ctyp + | (* .. [@attr] *) TyAnt of loc * string and (* $s$ *) patt = @@ -985,6 +987,8 @@ module Sig = | (* `s *) PaLaz of loc * patt | (* lazy p *) + PaAtt of loc * string * str_item * patt + | (* .. [@attr] *) PaMod of loc * string and (* (module M) *) expr = @@ -1074,6 +1078,8 @@ module Sig = ExFUN of loc * string * expr | (* (module ME : S) which is represented as (module (ME : S)) *) ExPkg of loc * module_expr + | (* e [@attr] *) + ExAtt of loc * string * str_item * expr and module_type = | MtNil of loc | (* i *) @@ -1089,7 +1095,9 @@ module Sig = MtWit of loc * module_type * with_constr | (* module type of m *) MtOf of loc * module_expr - | MtAnt of loc * string + | MtAtt of loc * string * str_item * module_type + | (* .. [@attr] *) + MtAnt of loc * string and (* $s$ *) sig_item = | SgNil of loc @@ -1187,7 +1195,9 @@ module Sig = | (* (value e) *) (* (value e : S) which is represented as (value (e : S)) *) MePkg of loc * expr - | MeAnt of loc * string + | MeAtt of loc * string * str_item * module_expr + | (* .. [@attr] *) + MeAnt of loc * string and (* $s$ *) str_item = | StNil of loc @@ -1236,6 +1246,8 @@ module Sig = | (* ct = ct *) CtEq of loc * class_type * class_type | (* $s$ *) + CtAtt of loc * string * str_item * class_type + | (* .. [@attr] *) CtAnt of loc * string and class_sig_item = | CgNil of loc @@ -1272,6 +1284,8 @@ module Sig = | (* ce = ce *) CeEq of loc * class_expr * class_expr | (* $s$ *) + CeAtt of loc * string * str_item * class_expr + | (* .. [@attr] *) CeAnt of loc * string and class_str_item = | CrNil of loc @@ -1805,6 +1819,7 @@ module Sig = | TyAmp of loc * ctyp * ctyp | TyOfAmp of loc * ctyp * ctyp | TyPkg of loc * module_type + | TyAtt of loc * string * str_item * ctyp | TyAnt of loc * string and patt = | PaNil of loc @@ -1835,6 +1850,7 @@ module Sig = | PaTyp of loc * ident | PaVrn of loc * string | PaLaz of loc * patt + | PaAtt of loc * string * str_item * patt | PaMod of loc * string and expr = | ExNil of loc @@ -1881,6 +1897,7 @@ module Sig = | ExOpI of loc * ident * override_flag * expr | ExFUN of loc * string * expr | ExPkg of loc * module_expr + | ExAtt of loc * string * str_item * expr and module_type = | MtNil of loc | MtId of loc * ident @@ -1889,6 +1906,7 @@ module Sig = | MtSig of loc * sig_item | MtWit of loc * module_type * with_constr | MtOf of loc * module_expr + | MtAtt of loc * string * str_item * module_type | MtAnt of loc * string and sig_item = | SgNil of loc @@ -1943,6 +1961,7 @@ module Sig = | MeStr of loc * str_item | MeTyc of loc * module_expr * module_type | MePkg of loc * expr + | MeAtt of loc * string * str_item * module_expr | MeAnt of loc * string and str_item = | StNil of loc @@ -1969,6 +1988,7 @@ module Sig = | CtAnd of loc * class_type * class_type | CtCol of loc * class_type * class_type | CtEq of loc * class_type * class_type + | CtAtt of loc * string * str_item * class_type | CtAnt of loc * string and class_sig_item = | CgNil of loc @@ -1989,6 +2009,7 @@ module Sig = | CeTyc of loc * class_expr * class_type | CeAnd of loc * class_expr * class_expr | CeEq of loc * class_expr * class_expr + | CeAtt of loc * string * str_item * class_expr | CeAnt of loc * string and class_str_item = | CrNil of loc @@ -6943,6 +6964,7 @@ module Struct = | Ast.PaLab (_, _, (Ast.PaNil _)) -> true | Ast.PaLab (_, _, p) -> is_irrefut_patt p | Ast.PaLaz (_, p) -> is_irrefut_patt p + | Ast.PaAtt (_loc, _s, _str, p) -> is_irrefut_patt p | Ast.PaId (_, _) -> false | Ast.PaMod (_, _) -> true | Ast.PaVrn (_, _) | Ast.PaStr (_, _) | Ast.PaRng (_, _, _) | @@ -7480,6 +7502,19 @@ module Struct = and meta_class_expr _loc = function | Ast.CeAnt (x0, x1) -> Ast.ExAnt (x0, x1) + | Ast.CeAtt (x0, x1, x2, x3) -> + Ast.ExApp (_loc, + (Ast.ExApp (_loc, + (Ast.ExApp (_loc, + (Ast.ExApp (_loc, + (Ast.ExId (_loc, + (Ast.IdAcc (_loc, + (Ast.IdUid (_loc, "Ast")), + (Ast.IdUid (_loc, "CeAtt")))))), + (meta_loc _loc x0))), + (meta_string _loc x1))), + (meta_str_item _loc x2))), + (meta_class_expr _loc x3)) | Ast.CeEq (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, @@ -7777,6 +7812,19 @@ module Struct = and meta_class_type _loc = function | Ast.CtAnt (x0, x1) -> Ast.ExAnt (x0, x1) + | Ast.CtAtt (x0, x1, x2, x3) -> + Ast.ExApp (_loc, + (Ast.ExApp (_loc, + (Ast.ExApp (_loc, + (Ast.ExApp (_loc, + (Ast.ExId (_loc, + (Ast.IdAcc (_loc, + (Ast.IdUid (_loc, "Ast")), + (Ast.IdUid (_loc, "CtAtt")))))), + (meta_loc _loc x0))), + (meta_string _loc x1))), + (meta_str_item _loc x2))), + (meta_class_type _loc x3)) | Ast.CtEq (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, @@ -7855,6 +7903,19 @@ module Struct = and meta_ctyp _loc = function | Ast.TyAnt (x0, x1) -> Ast.ExAnt (x0, x1) + | Ast.TyAtt (x0, x1, x2, x3) -> + Ast.ExApp (_loc, + (Ast.ExApp (_loc, + (Ast.ExApp (_loc, + (Ast.ExApp (_loc, + (Ast.ExId (_loc, + (Ast.IdAcc (_loc, + (Ast.IdUid (_loc, "Ast")), + (Ast.IdUid (_loc, "TyAtt")))))), + (meta_loc _loc x0))), + (meta_string _loc x1))), + (meta_str_item _loc x2))), + (meta_ctyp _loc x3)) | Ast.TyPkg (x0, x1) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, @@ -8261,6 +8322,19 @@ module Struct = (Ast.IdUid (_loc, "DiTo"))))) and meta_expr _loc = function + | Ast.ExAtt (x0, x1, x2, x3) -> + Ast.ExApp (_loc, + (Ast.ExApp (_loc, + (Ast.ExApp (_loc, + (Ast.ExApp (_loc, + (Ast.ExId (_loc, + (Ast.IdAcc (_loc, + (Ast.IdUid (_loc, "Ast")), + (Ast.IdUid (_loc, "ExAtt")))))), + (meta_loc _loc x0))), + (meta_string _loc x1))), + (meta_str_item _loc x2))), + (meta_expr _loc x3)) | Ast.ExPkg (x0, x1) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, @@ -8874,6 +8948,19 @@ module Struct = and meta_module_expr _loc = function | Ast.MeAnt (x0, x1) -> Ast.ExAnt (x0, x1) + | Ast.MeAtt (x0, x1, x2, x3) -> + Ast.ExApp (_loc, + (Ast.ExApp (_loc, + (Ast.ExApp (_loc, + (Ast.ExApp (_loc, + (Ast.ExId (_loc, + (Ast.IdAcc (_loc, + (Ast.IdUid (_loc, "Ast")), + (Ast.IdUid (_loc, "MeAtt")))))), + (meta_loc _loc x0))), + (meta_string _loc x1))), + (meta_str_item _loc x2))), + (meta_module_expr _loc x3)) | Ast.MePkg (x0, x1) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, @@ -8946,6 +9033,19 @@ module Struct = and meta_module_type _loc = function | Ast.MtAnt (x0, x1) -> Ast.ExAnt (x0, x1) + | Ast.MtAtt (x0, x1, x2, x3) -> + Ast.ExApp (_loc, + (Ast.ExApp (_loc, + (Ast.ExApp (_loc, + (Ast.ExApp (_loc, + (Ast.ExId (_loc, + (Ast.IdAcc (_loc, + (Ast.IdUid (_loc, "Ast")), + (Ast.IdUid (_loc, "MtAtt")))))), + (meta_loc _loc x0))), + (meta_string _loc x1))), + (meta_str_item _loc x2))), + (meta_module_type _loc x3)) | Ast.MtOf (x0, x1) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, @@ -9046,6 +9146,19 @@ module Struct = (Ast.IdUid (_loc, "PaMod")))))), (meta_loc _loc x0))), (meta_string _loc x1)) + | Ast.PaAtt (x0, x1, x2, x3) -> + Ast.ExApp (_loc, + (Ast.ExApp (_loc, + (Ast.ExApp (_loc, + (Ast.ExApp (_loc, + (Ast.ExId (_loc, + (Ast.IdAcc (_loc, + (Ast.IdUid (_loc, "Ast")), + (Ast.IdUid (_loc, "PaAtt")))))), + (meta_loc _loc x0))), + (meta_string _loc x1))), + (meta_str_item _loc x2))), + (meta_patt _loc x3)) | Ast.PaLaz (x0, x1) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, @@ -9815,6 +9928,19 @@ module Struct = and meta_class_expr _loc = function | Ast.CeAnt (x0, x1) -> Ast.PaAnt (x0, x1) + | Ast.CeAtt (x0, x1, x2, x3) -> + Ast.PaApp (_loc, + (Ast.PaApp (_loc, + (Ast.PaApp (_loc, + (Ast.PaApp (_loc, + (Ast.PaId (_loc, + (Ast.IdAcc (_loc, + (Ast.IdUid (_loc, "Ast")), + (Ast.IdUid (_loc, "CeAtt")))))), + (meta_loc _loc x0))), + (meta_string _loc x1))), + (meta_str_item _loc x2))), + (meta_class_expr _loc x3)) | Ast.CeEq (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, @@ -10112,6 +10238,19 @@ module Struct = and meta_class_type _loc = function | Ast.CtAnt (x0, x1) -> Ast.PaAnt (x0, x1) + | Ast.CtAtt (x0, x1, x2, x3) -> + Ast.PaApp (_loc, + (Ast.PaApp (_loc, + (Ast.PaApp (_loc, + (Ast.PaApp (_loc, + (Ast.PaId (_loc, + (Ast.IdAcc (_loc, + (Ast.IdUid (_loc, "Ast")), + (Ast.IdUid (_loc, "CtAtt")))))), + (meta_loc _loc x0))), + (meta_string _loc x1))), + (meta_str_item _loc x2))), + (meta_class_type _loc x3)) | Ast.CtEq (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, @@ -10190,6 +10329,19 @@ module Struct = and meta_ctyp _loc = function | Ast.TyAnt (x0, x1) -> Ast.PaAnt (x0, x1) + | Ast.TyAtt (x0, x1, x2, x3) -> + Ast.PaApp (_loc, + (Ast.PaApp (_loc, + (Ast.PaApp (_loc, + (Ast.PaApp (_loc, + (Ast.PaId (_loc, + (Ast.IdAcc (_loc, + (Ast.IdUid (_loc, "Ast")), + (Ast.IdUid (_loc, "TyAtt")))))), + (meta_loc _loc x0))), + (meta_string _loc x1))), + (meta_str_item _loc x2))), + (meta_ctyp _loc x3)) | Ast.TyPkg (x0, x1) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, @@ -10596,6 +10748,19 @@ module Struct = (Ast.IdUid (_loc, "DiTo"))))) and meta_expr _loc = function + | Ast.ExAtt (x0, x1, x2, x3) -> + Ast.PaApp (_loc, + (Ast.PaApp (_loc, + (Ast.PaApp (_loc, + (Ast.PaApp (_loc, + (Ast.PaId (_loc, + (Ast.IdAcc (_loc, + (Ast.IdUid (_loc, "Ast")), + (Ast.IdUid (_loc, "ExAtt")))))), + (meta_loc _loc x0))), + (meta_string _loc x1))), + (meta_str_item _loc x2))), + (meta_expr _loc x3)) | Ast.ExPkg (x0, x1) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, @@ -11209,6 +11374,19 @@ module Struct = and meta_module_expr _loc = function | Ast.MeAnt (x0, x1) -> Ast.PaAnt (x0, x1) + | Ast.MeAtt (x0, x1, x2, x3) -> + Ast.PaApp (_loc, + (Ast.PaApp (_loc, + (Ast.PaApp (_loc, + (Ast.PaApp (_loc, + (Ast.PaId (_loc, + (Ast.IdAcc (_loc, + (Ast.IdUid (_loc, "Ast")), + (Ast.IdUid (_loc, "MeAtt")))))), + (meta_loc _loc x0))), + (meta_string _loc x1))), + (meta_str_item _loc x2))), + (meta_module_expr _loc x3)) | Ast.MePkg (x0, x1) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, @@ -11281,6 +11459,19 @@ module Struct = and meta_module_type _loc = function | Ast.MtAnt (x0, x1) -> Ast.PaAnt (x0, x1) + | Ast.MtAtt (x0, x1, x2, x3) -> + Ast.PaApp (_loc, + (Ast.PaApp (_loc, + (Ast.PaApp (_loc, + (Ast.PaApp (_loc, + (Ast.PaId (_loc, + (Ast.IdAcc (_loc, + (Ast.IdUid (_loc, "Ast")), + (Ast.IdUid (_loc, "MtAtt")))))), + (meta_loc _loc x0))), + (meta_string _loc x1))), + (meta_str_item _loc x2))), + (meta_module_type _loc x3)) | Ast.MtOf (x0, x1) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, @@ -11381,6 +11572,19 @@ module Struct = (Ast.IdUid (_loc, "PaMod")))))), (meta_loc _loc x0))), (meta_string _loc x1)) + | Ast.PaAtt (x0, x1, x2, x3) -> + Ast.PaApp (_loc, + (Ast.PaApp (_loc, + (Ast.PaApp (_loc, + (Ast.PaApp (_loc, + (Ast.PaId (_loc, + (Ast.IdAcc (_loc, + (Ast.IdUid (_loc, "Ast")), + (Ast.IdUid (_loc, "PaAtt")))))), + (meta_loc _loc x0))), + (meta_string _loc x1))), + (meta_str_item _loc x2))), + (meta_patt _loc x3)) | Ast.PaLaz (x0, x1) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, @@ -12377,6 +12581,12 @@ module Struct = | PaLaz (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#patt _x_i1 in PaLaz (_x, _x_i1) + | PaAtt (_x, _x_i1, _x_i2, _x_i3) -> + let _x = o#loc _x in + let _x_i1 = o#string _x_i1 in + let _x_i2 = o#str_item _x_i2 in + let _x_i3 = o#patt _x_i3 + in PaAtt (_x, _x_i1, _x_i2, _x_i3) | PaMod (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in PaMod (_x, _x_i1) @@ -12416,6 +12626,12 @@ module Struct = | MtOf (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#module_expr _x_i1 in MtOf (_x, _x_i1) + | MtAtt (_x, _x_i1, _x_i2, _x_i3) -> + let _x = o#loc _x in + let _x_i1 = o#string _x_i1 in + let _x_i2 = o#str_item _x_i2 in + let _x_i3 = o#module_type _x_i3 + in MtAtt (_x, _x_i1, _x_i2, _x_i3) | MtAnt (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in MtAnt (_x, _x_i1) @@ -12447,6 +12663,12 @@ module Struct = | MePkg (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#expr _x_i1 in MePkg (_x, _x_i1) + | MeAtt (_x, _x_i1, _x_i2, _x_i3) -> + let _x = o#loc _x in + let _x_i1 = o#string _x_i1 in + let _x_i2 = o#str_item _x_i2 in + let _x_i3 = o#module_expr _x_i3 + in MeAtt (_x, _x_i1, _x_i2, _x_i3) | MeAnt (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in MeAnt (_x, _x_i1) @@ -12705,6 +12927,12 @@ module Struct = | ExPkg (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#module_expr _x_i1 in ExPkg (_x, _x_i1) + | ExAtt (_x, _x_i1, _x_i2, _x_i3) -> + let _x = o#loc _x in + let _x_i1 = o#string _x_i1 in + let _x_i2 = o#str_item _x_i2 in + let _x_i3 = o#expr _x_i3 + in ExAtt (_x, _x_i1, _x_i2, _x_i3) method direction_flag : direction_flag -> direction_flag = function | DiTo -> DiTo @@ -12852,6 +13080,12 @@ module Struct = | TyPkg (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#module_type _x_i1 in TyPkg (_x, _x_i1) + | TyAtt (_x, _x_i1, _x_i2, _x_i3) -> + let _x = o#loc _x in + let _x_i1 = o#string _x_i1 in + let _x_i2 = o#str_item _x_i2 in + let _x_i3 = o#ctyp _x_i3 + in TyAtt (_x, _x_i1, _x_i2, _x_i3) | TyAnt (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in TyAnt (_x, _x_i1) @@ -12889,6 +13123,12 @@ module Struct = let _x_i1 = o#class_type _x_i1 in let _x_i2 = o#class_type _x_i2 in CtEq (_x, _x_i1, _x_i2) + | CtAtt (_x, _x_i1, _x_i2, _x_i3) -> + let _x = o#loc _x in + let _x_i1 = o#string _x_i1 in + let _x_i2 = o#str_item _x_i2 in + let _x_i3 = o#class_type _x_i3 + in CtAtt (_x, _x_i1, _x_i2, _x_i3) | CtAnt (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in CtAnt (_x, _x_i1) @@ -13024,6 +13264,12 @@ module Struct = let _x_i1 = o#class_expr _x_i1 in let _x_i2 = o#class_expr _x_i2 in CeEq (_x, _x_i1, _x_i2) + | CeAtt (_x, _x_i1, _x_i2, _x_i3) -> + let _x = o#loc _x in + let _x_i1 = o#string _x_i1 in + let _x_i2 = o#str_item _x_i2 in + let _x_i3 = o#class_expr _x_i3 + in CeAtt (_x, _x_i1, _x_i2, _x_i3) | CeAnt (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in CeAnt (_x, _x_i1) @@ -13267,6 +13513,10 @@ module Struct = let o = o#loc _x in let o = o#string _x_i1 in o | PaLaz (_x, _x_i1) -> let o = o#loc _x in let o = o#patt _x_i1 in o + | PaAtt (_x, _x_i1, _x_i2, _x_i3) -> + let o = o#loc _x in + let o = o#string _x_i1 in + let o = o#str_item _x_i2 in let o = o#patt _x_i3 in o | PaMod (_x, _x_i1) -> let o = o#loc _x in let o = o#string _x_i1 in o method override_flag : override_flag -> 'self_type = @@ -13299,6 +13549,11 @@ module Struct = let o = o#with_constr _x_i2 in o | MtOf (_x, _x_i1) -> let o = o#loc _x in let o = o#module_expr _x_i1 in o + | MtAtt (_x, _x_i1, _x_i2, _x_i3) -> + let o = o#loc _x in + let o = o#string _x_i1 in + let o = o#str_item _x_i2 in + let o = o#module_type _x_i3 in o | MtAnt (_x, _x_i1) -> let o = o#loc _x in let o = o#string _x_i1 in o method module_expr : module_expr -> 'self_type = @@ -13323,6 +13578,11 @@ module Struct = let o = o#module_type _x_i2 in o | MePkg (_x, _x_i1) -> let o = o#loc _x in let o = o#expr _x_i1 in o + | MeAtt (_x, _x_i1, _x_i2, _x_i3) -> + let o = o#loc _x in + let o = o#string _x_i1 in + let o = o#str_item _x_i2 in + let o = o#module_expr _x_i3 in o | MeAnt (_x, _x_i1) -> let o = o#loc _x in let o = o#string _x_i1 in o method module_binding : module_binding -> 'self_type = @@ -13520,6 +13780,10 @@ module Struct = let o = o#string _x_i1 in let o = o#expr _x_i2 in o | ExPkg (_x, _x_i1) -> let o = o#loc _x in let o = o#module_expr _x_i1 in o + | ExAtt (_x, _x_i1, _x_i2, _x_i3) -> + let o = o#loc _x in + let o = o#string _x_i1 in + let o = o#str_item _x_i2 in let o = o#expr _x_i3 in o method direction_flag : direction_flag -> 'self_type = function | DiTo -> o @@ -13630,6 +13894,10 @@ module Struct = let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o | TyPkg (_x, _x_i1) -> let o = o#loc _x in let o = o#module_type _x_i1 in o + | TyAtt (_x, _x_i1, _x_i2, _x_i3) -> + let o = o#loc _x in + let o = o#string _x_i1 in + let o = o#str_item _x_i2 in let o = o#ctyp _x_i3 in o | TyAnt (_x, _x_i1) -> let o = o#loc _x in let o = o#string _x_i1 in o method class_type : class_type -> 'self_type = @@ -13658,6 +13926,11 @@ module Struct = let o = o#loc _x in let o = o#class_type _x_i1 in let o = o#class_type _x_i2 in o + | CtAtt (_x, _x_i1, _x_i2, _x_i3) -> + let o = o#loc _x in + let o = o#string _x_i1 in + let o = o#str_item _x_i2 in + let o = o#class_type _x_i3 in o | CtAnt (_x, _x_i1) -> let o = o#loc _x in let o = o#string _x_i1 in o method class_str_item : class_str_item -> 'self_type = @@ -13765,6 +14038,11 @@ module Struct = let o = o#loc _x in let o = o#class_expr _x_i1 in let o = o#class_expr _x_i2 in o + | CeAtt (_x, _x_i1, _x_i2, _x_i3) -> + let o = o#loc _x in + let o = o#string _x_i1 in + let o = o#str_item _x_i2 in + let o = o#class_expr _x_i3 in o | CeAnt (_x, _x_i1) -> let o = o#loc _x in let o = o#string _x_i1 in o method binding : binding -> 'self_type = @@ -14182,29 +14460,40 @@ module Struct = let with_loc txt loc = Camlp4_import.Location.mkloc txt (mkloc loc) - let mktyp loc d = { ptyp_desc = d; ptyp_loc = mkloc loc; ptyp_attributes = []} + let mktyp loc d = + { ptyp_desc = d; ptyp_loc = mkloc loc; ptyp_attributes = []; } - let mkpat loc d = { ppat_desc = d; ppat_loc = mkloc loc; ppat_attributes = []} + let mkpat loc d = + { ppat_desc = d; ppat_loc = mkloc loc; ppat_attributes = []; } - let mkghpat loc d = { ppat_desc = d; ppat_loc = mkghloc loc; ppat_attributes = []} + let mkghpat loc d = + { ppat_desc = d; ppat_loc = mkghloc loc; ppat_attributes = []; + } - let mkexp loc d = { pexp_desc = d; pexp_loc = mkloc loc; pexp_attributes = []} + let mkexp loc d = + { pexp_desc = d; pexp_loc = mkloc loc; pexp_attributes = []; } - let mkmty loc d = { pmty_desc = d; pmty_loc = mkloc loc; pmty_attributes = []} + let mkmty loc d = + { pmty_desc = d; pmty_loc = mkloc loc; pmty_attributes = []; } let mksig loc d = { psig_desc = d; psig_loc = mkloc loc; } - let mkmod loc d = { pmod_desc = d; pmod_loc = mkloc loc; pmod_attributes = []} + let mkmod loc d = + { pmod_desc = d; pmod_loc = mkloc loc; pmod_attributes = []; } let mkstr loc d = { pstr_desc = d; pstr_loc = mkloc loc; } - let mkcty loc d = { pcty_desc = d; pcty_loc = mkloc loc; pcty_attributes = []} + let mkcty loc d = + { pcty_desc = d; pcty_loc = mkloc loc; pcty_attributes = []; } - let mkcl loc d = { pcl_desc = d; pcl_loc = mkloc loc; pcl_attributes = []} + let mkcl loc d = + { pcl_desc = d; pcl_loc = mkloc loc; pcl_attributes = []; } - let mkcf loc d = { pcf_desc = d; pcf_loc = mkloc loc; pcf_attributes = [] } + let mkcf loc d = + { pcf_desc = d; pcf_loc = mkloc loc; pcf_attributes = []; } - let mkctf loc d = { pctf_desc = d; pctf_loc = mkloc loc; pctf_attributes = [] } + let mkctf loc d = + { pctf_desc = d; pctf_loc = mkloc loc; pctf_attributes = []; } let mkpolytype t = match t.ptyp_desc with @@ -14358,6 +14647,10 @@ module Struct = ((loc, (IdLid ((loc, "*predef*"))), (IdLid ((loc, "option")))))))) + let attribute_fwd = ref (fun _ _ _ -> assert false) + + let attribute loc s str = !attribute_fwd loc s str + let rec ctyp = function | TyId (loc, i) -> @@ -14388,15 +14681,22 @@ module Struct = | TyArr (loc, t1, t2) -> mktyp loc (Ptyp_arrow ("", (ctyp t1), (ctyp t2))) | Ast.TyObj (loc, fl, Ast.RvNil) -> - mktyp loc (Ptyp_object (meth_list fl [], Closed)) + mktyp loc (Ptyp_object ((meth_list fl []), Closed)) | Ast.TyObj (loc, fl, Ast.RvRowVar) -> - mktyp loc - (Ptyp_object (meth_list fl [], Open)) - | TyCls (loc, id) -> - mktyp loc (Ptyp_class ((ident id), [])) + mktyp loc (Ptyp_object ((meth_list fl []), Open)) + | TyCls (loc, id) -> mktyp loc (Ptyp_class ((ident id), [])) | Ast.TyPkg (loc, pt) -> let (i, cs) = package_type pt in mktyp loc (Ptyp_package (i, cs)) + | TyAtt (loc, s, str, e) -> + let e = ctyp e + in + { + (e) + with + ptyp_attributes = + e.ptyp_attributes @ [ attribute loc s str ]; + } | TyLab (loc, _, _) -> error loc "labelled type not allowed here" | TyMan (loc, _, _) -> @@ -14459,7 +14759,7 @@ module Struct = match fl with | Ast.TyNil _ -> acc | Ast.TySem (_, t1, t2) -> meth_list t1 (meth_list t2 acc) - | Ast.TyCol (loc, (Ast.TyId (_, (Ast.IdLid (_, lab)))), t) -> + | Ast.TyCol (_, (Ast.TyId (_, (Ast.IdLid (_, lab)))), t) -> (lab, (mkpolytype (ctyp t))) :: acc | _ -> assert false and package_type_constraints wc acc = @@ -14481,16 +14781,16 @@ module Struct = | mt -> error (loc_of_module_type mt) "unexpected package type" let mktype loc name tl cl tk tp tm = - { - ptype_name = name; - ptype_params = tl; - ptype_cstrs = cl; - ptype_kind = tk; - ptype_private = tp; - ptype_manifest = tm; - ptype_loc = mkloc loc; - ptype_attributes = []; - } + { + ptype_name = name; + ptype_params = tl; + ptype_cstrs = cl; + ptype_kind = tk; + ptype_private = tp; + ptype_manifest = tm; + ptype_loc = mkloc loc; + ptype_attributes = []; + } let mkprivate' m = if m then Private else Public @@ -14504,32 +14804,58 @@ module Struct = function | Ast.TyCol (loc, (Ast.TyId (_, (Ast.IdLid (sloc, s)))), (Ast.TyMut (_, t))) -> - {pld_name=with_loc s sloc; - pld_mutable=Mutable; - pld_type=mkpolytype (ctyp t); - pld_loc=mkloc loc; - pld_attributes=[]; - } + { + pld_name = with_loc s sloc; + pld_mutable = Mutable; + pld_type = mkpolytype (ctyp t); + pld_loc = mkloc loc; + pld_attributes = []; + } | Ast.TyCol (loc, (Ast.TyId (_, (Ast.IdLid (sloc, s)))), t) -> - {pld_name=with_loc s sloc; - pld_mutable=Immutable; - pld_type=mkpolytype (ctyp t); - pld_loc=mkloc loc; - pld_attributes=[]; + { + pld_name = with_loc s sloc; + pld_mutable = Immutable; + pld_type = mkpolytype (ctyp t); + pld_loc = mkloc loc; + pld_attributes = []; } | _ -> assert false let mkvariant = function | Ast.TyId (loc, (Ast.IdUid (sloc, s))) -> - {pcd_name = with_loc (conv_con s) sloc; pcd_args = []; pcd_res = None; pcd_loc = mkloc loc; pcd_attributes = []} + { + pcd_name = with_loc (conv_con s) sloc; + pcd_args = []; + pcd_res = None; + pcd_loc = mkloc loc; + pcd_attributes = []; + } | Ast.TyOf (loc, (Ast.TyId (_, (Ast.IdUid (sloc, s)))), t) -> - {pcd_name = with_loc (conv_con s) sloc; pcd_args = List.map ctyp (list_of_ctyp t []); pcd_res = None; pcd_loc = mkloc loc; pcd_attributes = []} + { + pcd_name = with_loc (conv_con s) sloc; + pcd_args = List.map ctyp (list_of_ctyp t []); + pcd_res = None; + pcd_loc = mkloc loc; + pcd_attributes = []; + } | Ast.TyCol (loc, (Ast.TyId (_, (Ast.IdUid (sloc, s)))), (Ast.TyArr (_, t, u))) -> - {pcd_name = with_loc (conv_con s) sloc; pcd_args = List.map ctyp (list_of_ctyp t []); pcd_res = Some (ctyp u); pcd_loc = mkloc loc; pcd_attributes = []} + { + pcd_name = with_loc (conv_con s) sloc; + pcd_args = List.map ctyp (list_of_ctyp t []); + pcd_res = Some (ctyp u); + pcd_loc = mkloc loc; + pcd_attributes = []; + } | Ast.TyCol (loc, (Ast.TyId (_, (Ast.IdUid (sloc, s)))), t) -> - {pcd_name = with_loc (conv_con s) sloc; pcd_args = []; pcd_res = Some (ctyp t); pcd_loc = mkloc loc; pcd_attributes = []} + { + pcd_name = with_loc (conv_con s) sloc; + pcd_args = []; + pcd_res = Some (ctyp t); + pcd_loc = mkloc loc; + pcd_attributes = []; + } | _ -> assert false let rec type_decl name tl cl loc m pflag = @@ -14559,15 +14885,21 @@ module Struct = match t with | Ast.TyNil _ -> None | _ -> Some (ctyp t) - in mktype loc name tl cl Ptype_abstract (mkprivate' pflag) m) + in + mktype loc name tl cl Ptype_abstract + (mkprivate' pflag) m) - let type_decl name tl cl t loc = type_decl name tl cl loc None false t + let type_decl name tl cl t loc = + type_decl name tl cl loc None false t let mkvalue_desc loc name t p = - { pval_name = name; - pval_type = ctyp t; pval_prim = p; pval_loc = mkloc loc; + { + pval_name = name; + pval_type = ctyp t; + pval_prim = p; + pval_loc = mkloc loc; pval_attributes = []; - } + } let rec list_of_meta_list = function @@ -14599,9 +14931,9 @@ module Struct = match t with | Ast.TyApp (_, t1, t2) -> type_parameters t1 (type_parameters t2 acc) - | Ast.TyQuP (_, s) -> (s, (true, false)) :: acc - | Ast.TyQuM (_, s) -> (s, (false, true)) :: acc - | Ast.TyQuo (_, s) -> (s, (false, false)) :: acc + | Ast.TyQuP (_, s) -> (s, Covariant) :: acc + | Ast.TyQuM (_, s) -> (s, Contravariant) :: acc + | Ast.TyQuo (_, s) -> (s, Invariant) :: acc | _ -> assert false let rec optional_type_parameters t acc = @@ -14624,12 +14956,10 @@ module Struct = match t with | Ast.TyCom (_, t1, t2) -> class_parameters t1 (class_parameters t2 acc) - | Ast.TyQuP (loc, s) -> - ((with_loc s loc), Covariant) :: acc + | Ast.TyQuP (loc, s) -> ((with_loc s loc), Covariant) :: acc | Ast.TyQuM (loc, s) -> ((with_loc s loc), Contravariant) :: acc - | Ast.TyQuo (loc, s) -> - ((with_loc s loc), Invariant) :: acc + | Ast.TyQuo (loc, s) -> ((with_loc s loc), Invariant) :: acc | _ -> assert false let rec type_parameters_and_type_name t acc = @@ -14644,35 +14974,38 @@ module Struct = let (id, tpl) = type_parameters_and_type_name id_tpl [] in let (kind, priv, ct) = opt_private_ctyp ct in - pwith_type id - { - ptype_name = Camlp4_import.Location.mkloc (Camlp4_import.Longident.last id.txt) id.loc; - ptype_params = tpl; - ptype_cstrs = []; - ptype_kind = kind; - ptype_private = priv; - ptype_manifest = Some ct; - ptype_loc = mkloc loc; - ptype_attributes = []; - } + pwith_type id + { + ptype_name = + Camlp4_import.Location.mkloc + (Camlp4_import.Longident.last id.txt) id.loc; + ptype_params = tpl; + ptype_cstrs = []; + ptype_kind = kind; + ptype_private = priv; + ptype_manifest = Some ct; + ptype_loc = mkloc loc; + ptype_attributes = []; + } let rec mkwithc wc acc = match wc with | Ast.WcNil _ -> acc | Ast.WcTyp (loc, id_tpl, ct) -> - (mkwithtyp (fun lid x -> Pwith_type (lid, x)) loc id_tpl ct) :: acc + (mkwithtyp (fun lid x -> Pwith_type (lid, x)) loc id_tpl ct) :: + acc | Ast.WcMod (_, i1, i2) -> - (Pwith_module (long_uident i1, long_uident i2)) :: acc + (Pwith_module ((long_uident i1), (long_uident i2))) :: acc | Ast.WcTyS (loc, id_tpl, ct) -> (mkwithtyp (fun _ x -> Pwith_typesubst x) loc id_tpl ct) :: acc | Ast.WcMoS (loc, i1, i2) -> - begin match long_uident i1 with - | {txt=Lident s; loc} -> - (Pwith_modsubst ({txt=s;loc},long_uident i2)) :: - acc - | _ -> error loc "bad 'with module :=' constraint" - end + (match long_uident i1 with + | { txt = Lident s; loc = loc } -> + (Pwith_modsubst ({ txt = s; loc = loc; }, + (long_uident i2))) :: + acc + | _ -> error loc "bad 'with module :=' constraint") | Ast.WcAnd (_, wc1, wc2) -> mkwithc wc1 (mkwithc wc2 acc) | Ast.WcAnt (loc, _) -> error loc "bad with constraint (antiquotation)" @@ -14707,8 +15040,7 @@ module Struct = | Ast.PaId (loc, (Ast.IdLid (sloc, s))) -> mkpat loc (Ppat_var (with_loc s sloc)) | Ast.PaId (loc, i) -> - let p = - Ppat_construct ((long_uident ~conv_con i), None) + let p = Ppat_construct ((long_uident ~conv_con i), None) in mkpat loc p | PaAli (loc, p1, p2) -> let (p, i) = @@ -14732,18 +15064,16 @@ module Struct = in (match (patt f).ppat_desc with | Ppat_construct (li, None) -> - let a = - match al with - | [ a ] -> a - | _ -> mkpat loc (Ppat_tuple al) - in - mkpat loc - (Ppat_construct (li, (Some a))) + let a = + (match al with + | [ a ] -> a + | _ -> mkpat loc (Ppat_tuple al)) + in mkpat loc (Ppat_construct (li, (Some a))) | Ppat_variant (s, None) -> let a = - match al with - | [ a ] -> a - | _ -> mkpat loc (Ppat_tuple al) + (match al with + | [ a ] -> a + | _ -> mkpat loc (Ppat_tuple al)) in mkpat loc (Ppat_variant (s, (Some a))) | _ -> error (loc_of_patt f) @@ -14814,7 +15144,7 @@ module Struct = | PaStr (loc, s) -> mkpat loc (Ppat_constant - (Const_string (string_of_string_token loc s, None))) + (Const_string ((string_of_string_token loc s), None))) | Ast.PaTup (loc, (Ast.PaCom (_, p1, p2))) -> mkpat loc (Ppat_tuple @@ -14827,6 +15157,15 @@ module Struct = mkpat loc (Ppat_variant ((conv_con s), None)) | PaLaz (loc, p) -> mkpat loc (Ppat_lazy (patt p)) | PaMod (loc, m) -> mkpat loc (Ppat_unpack (with_loc m loc)) + | PaAtt (loc, s, str, e) -> + let e = patt e + in + { + (e) + with + ppat_attributes = + e.ppat_attributes @ [ attribute loc s str ]; + } | (PaEq (_, _, _) | PaSem (_, _, _) | PaCom (_, _, _) | PaNil _ as p) -> error (loc_of_patt p) "invalid pattern" and mklabpat = @@ -14890,8 +15229,9 @@ module Struct = List.mem s var_names -> Ptyp_var ("&" ^ s) | Ptyp_constr (longident, lst) -> Ptyp_constr (longident, (List.map loop lst)) - | Ptyp_object (lst, o) -> - Ptyp_object (List.map (fun (s, t) -> (s, loop t)) lst, o) + | Ptyp_object ((lst, o)) -> + Ptyp_object + (((List.map (fun (s, t) -> (s, (loop t))) lst), o)) | Ptyp_class (longident, lst) -> Ptyp_class ((longident, (List.map loop lst))) | Ptyp_alias (core_type, string) -> @@ -14906,6 +15246,7 @@ module Struct = Ptyp_package ((longident, (List.map (fun (n, typ) -> (n, (loop typ))) lst))) + | Ptyp_extension x -> Ptyp_extension x in { (t) with ptyp_desc = desc; } and loop_row_field x = match x with @@ -14925,13 +15266,13 @@ module Struct = e) -> let (e, l) = (match sep_expr_acc [] e with - | (loc, ml, Ast.ExId (sloc, (Ast.IdUid (_, s)))) :: l -> - ((mkexp loc - (Pexp_construct ((mkli sloc (conv_con s) ml), - None))), - l) - | (loc, ml, Ast.ExId (sloc, (Ast.IdLid (_, s)))) :: l -> - ((mkexp loc (Pexp_ident (mkli sloc s ml))), l) + | (loc, ml, Ast.ExId (_, (Ast.IdUid (_, s)))) :: l -> + ((mkexp loc + (Pexp_construct ((mkli loc (conv_con s) ml), + None))), + l) + | (loc, ml, Ast.ExId (_, (Ast.IdLid (_, s)))) :: l -> + ((mkexp loc (Pexp_ident (mkli loc s ml))), l) | (_, [], e) :: l -> ((expr e), l) | _ -> error loc "bad ast in expression") in let (_, e) = @@ -14957,21 +15298,18 @@ module Struct = in (match (expr f).pexp_desc with | Pexp_construct (li, None) -> - let al = List.map snd al - in - let a = - match al with - | [ a ] -> a - | _ -> mkexp loc (Pexp_tuple al) - in - mkexp loc - (Pexp_construct (li, (Some a))) + let al = List.map snd al in + let a = + (match al with + | [ a ] -> a + | _ -> mkexp loc (Pexp_tuple al)) + in mkexp loc (Pexp_construct (li, (Some a))) | Pexp_variant (s, None) -> let al = List.map snd al in let a = - match al with - | [ a ] -> a - | _ -> mkexp loc (Pexp_tuple al) + (match al with + | [ a ] -> a + | _ -> mkexp loc (Pexp_tuple al)) in mkexp loc (Pexp_variant (s, (Some a))) | _ -> mkexp loc (Pexp_apply ((expr f), al))) | ExAre (loc, e1, e2) -> @@ -14982,7 +15320,13 @@ module Struct = [ ("", (expr e1)); ("", (expr e2)) ])) | ExArr (loc, e) -> mkexp loc (Pexp_array (List.map expr (list_of_expr e []))) - | ExAsf loc -> mkexp loc (Pexp_assert (mkexp loc (Pexp_construct ({txt=Lident "false"; loc=mkloc loc}, None)))) + | ExAsf loc -> + mkexp loc + (Pexp_assert + (mkexp loc + (Pexp_construct + ({ txt = Lident "false"; loc = mkloc loc; }, + None)))) | ExAss (loc, e, v) -> let e = (match e with @@ -15019,9 +15363,7 @@ module Struct = | ExCoe (loc, e, t1, t2) -> let t1 = (match t1 with | Ast.TyNil _ -> None | t -> Some (ctyp t)) - in - mkexp loc - (Pexp_coerce ((expr e), t1, ctyp t2)) + in mkexp loc (Pexp_coerce ((expr e), t1, (ctyp t2))) | ExFlo (loc, s) -> mkexp loc (Pexp_constant (Const_float (remove_underscores s))) @@ -15032,20 +15374,16 @@ module Struct = (Pexp_for ((with_loc i loc), (expr e1), (expr e2), (mkdirection df), (expr e3))) | Ast.ExFun (loc, (Ast.McArr (_, (PaLab (_, lab, po)), w, e))) - -> - mkfun loc lab None (patt_of_lab loc lab po) e w + -> mkfun loc lab None (patt_of_lab loc lab po) e w | Ast.ExFun (loc, (Ast.McArr (_, (PaOlbi (_, lab, p, e1)), w, e2))) -> let lab = paolab lab p - in - mkfun loc ("?" ^ lab) (Some (expr e1)) (patt p) e2 w + in mkfun loc ("?" ^ lab) (Some (expr e1)) (patt p) e2 w | Ast.ExFun (loc, (Ast.McArr (_, (PaOlb (_, lab, p)), w, e))) -> let lab = paolab lab p - in - mkfun loc ("?" ^ lab) None (patt_of_lab loc lab p) e w - | ExFun (loc, a) -> - mkexp loc (Pexp_function (match_case a [])) + in mkfun loc ("?" ^ lab) None (patt_of_lab loc lab p) e w + | ExFun (loc, a) -> mkexp loc (Pexp_function (match_case a [])) | ExIfe (loc, e1, e2, e3) -> mkexp loc (Pexp_ifthenelse ((expr e1), (expr e2), (Some (expr e3)))) @@ -15133,7 +15471,7 @@ module Struct = | ExStr (loc, s) -> mkexp loc (Pexp_constant - (Const_string (string_of_string_token loc s, None))) + (Const_string ((string_of_string_token loc s), None))) | ExTry (loc, e, a) -> mkexp loc (Pexp_try ((expr e), (match_case a []))) | Ast.ExTup (loc, (Ast.ExCom (_, e1, e2))) -> @@ -15142,8 +15480,7 @@ module Struct = (List.map expr (list_of_expr e1 (list_of_expr e2 [])))) | Ast.ExTup (loc, _) -> error loc "singleton tuple" | ExTyc (loc, e, t) -> - mkexp loc - (Pexp_constraint ((expr e), (ctyp t))) + mkexp loc (Pexp_constraint ((expr e), (ctyp t))) | Ast.ExId (loc, (Ast.IdUid (_, "()"))) -> mkexp loc (Pexp_construct ((lident_with_loc "()" loc), None)) @@ -15164,8 +15501,8 @@ module Struct = | Ast.ExPkg (loc, (Ast.MeTyc (_, me, pt))) -> mkexp loc (Pexp_constraint - (mkexp loc (Pexp_pack (module_expr me)), - mktyp loc (Ptyp_package (package_type pt)))) + (((mkexp loc (Pexp_pack (module_expr me))), + (mktyp loc (Ptyp_package (package_type pt)))))) | Ast.ExPkg (loc, me) -> mkexp loc (Pexp_pack (module_expr me)) | ExFUN (loc, i, e) -> mkexp loc (Pexp_newtype (i, (expr e))) | Ast.ExCom (loc, _, _) -> @@ -15173,6 +15510,15 @@ module Struct = | Ast.ExSem (loc, _, _) -> error loc "expr; expr: not allowed here, use do {...} or [|...|] to surround them" + | ExAtt (loc, s, str, e) -> + let e = expr e + in + { + (e) + with + pexp_attributes = + e.pexp_attributes @ [ attribute loc s str ]; + } | (ExId (_, _) | ExNil _ as e) -> error (loc_of_expr e) "invalid expr" and patt_of_lab _loc lab = @@ -15208,9 +15554,7 @@ module Struct = let ty' = varify_constructors vars (ctyp ty) in let mkexp = mkexp _loc in let mkpat = mkpat _loc in - let e = - mkexp - (Pexp_constraint ((expr e), (ctyp ty))) in + let e = mkexp (Pexp_constraint ((expr e), (ctyp ty))) in let rec mk_newtypes x = (match x with | [ newtype ] -> mkexp (Pexp_newtype ((newtype, e))) @@ -15223,34 +15567,35 @@ module Struct = (Ppat_constraint (((mkpat (Ppat_var (with_loc bind_name sloc))), (mktyp _loc (Ptyp_poly (ampersand_vars, ty')))))) in - let e = mk_newtypes vars in {pvb_pat=pat; pvb_expr=e; pvb_attributes=[]} :: acc + let e = mk_newtypes vars + in + { pvb_pat = pat; pvb_expr = e; pvb_attributes = []; } :: + acc | Ast.BiEq (_loc, p, (Ast.ExTyc (_, e, (Ast.TyPol (_, vs, ty))))) -> - {pvb_pat=patt (Ast.PaTyc (_loc, p, (Ast.TyPol (_loc, vs, ty)))); - pvb_expr=expr e; - pvb_attributes=[]} :: acc - | Ast.BiEq (_, p, e) -> {pvb_pat=patt p; pvb_expr=expr e; pvb_attributes=[]} :: acc + { + pvb_pat = + patt (Ast.PaTyc (_loc, p, (Ast.TyPol (_loc, vs, ty)))); + pvb_expr = expr e; + pvb_attributes = []; + } :: acc + | Ast.BiEq (_, p, e) -> + { pvb_pat = patt p; pvb_expr = expr e; pvb_attributes = []; + } :: acc | Ast.BiNil _ -> acc | _ -> assert false and match_case x acc = match x with | Ast.McOr (_, x, y) -> match_case x (match_case y acc) - | Ast.McArr (_, p, w, e) -> when_expr (patt p) e w :: acc + | Ast.McArr (_, p, w, e) -> (when_expr (patt p) e w) :: acc | Ast.McNil _ -> acc | _ -> assert false and when_expr p e w = - let g = - match w with - | Ast.ExNil _ -> None - | w -> Some (expr w) - in - {pc_lhs = p; pc_guard = g; pc_rhs = expr e} + let g = match w with | Ast.ExNil _ -> None | g -> Some (expr g) + in { pc_lhs = p; pc_guard = g; pc_rhs = expr e; } and mkfun loc lab def p e w = - begin match w with - | Ast.ExNil _ -> () - | _ -> assert false - end; - mkexp loc (Pexp_fun (lab, def, p, expr e)) + let () = match w with | Ast.ExNil _ -> () | _ -> assert false + in mkexp loc (Pexp_fun (lab, def, p, (expr e))) and mklabexp x acc = match x with | Ast.RbSem (_, x, y) -> mklabexp x (mklabexp y acc) @@ -15276,10 +15621,10 @@ module Struct = in ((ctyp t1), (ctyp t2), (mkloc loc))) cl in - (type_decl (with_loc c cloc) - (List.fold_right optional_type_parameters tl []) cl - td cloc) :: - acc + (type_decl (with_loc c cloc) + (List.fold_right optional_type_parameters tl []) cl td + cloc) :: + acc | _ -> assert false and module_type = function @@ -15298,6 +15643,15 @@ module Struct = mkmty loc (Pmty_with ((module_type mt), (mkwithc wc []))) | Ast.MtOf (loc, me) -> mkmty loc (Pmty_typeof (module_expr me)) + | MtAtt (loc, s, str, e) -> + let e = module_type e + in + { + (e) + with + pmty_attributes = + e.pmty_attributes @ [ attribute loc s str ]; + } | Ast.MtAnt (_, _) -> assert false and sig_item s l = match s with @@ -15318,27 +15672,44 @@ module Struct = | SgDir (_, _, _) -> l | Ast.SgExc (loc, (Ast.TyId (_, (Ast.IdUid (_, s))))) -> (mksig loc - (Psig_exception {pcd_name=with_loc (conv_con s) loc; pcd_args=[];pcd_attributes=[]; pcd_loc=mkloc loc; pcd_res=None})) :: + (Psig_exception + { + pcd_name = with_loc (conv_con s) loc; + pcd_args = []; + pcd_attributes = []; + pcd_res = None; + pcd_loc = mkloc loc; + })) :: l | Ast.SgExc (loc, (Ast.TyOf (_, (Ast.TyId (_, (Ast.IdUid (_, s)))), t))) -> (mksig loc - (Psig_exception {pcd_name=with_loc (conv_con s) loc; - pcd_args=List.map ctyp (list_of_ctyp t []); - pcd_loc = mkloc loc; - pcd_res = None; - pcd_attributes = []})) :: l + (Psig_exception + { + pcd_name = with_loc (conv_con s) loc; + pcd_args = List.map ctyp (list_of_ctyp t []); + pcd_attributes = []; + pcd_res = None; + pcd_loc = mkloc loc; + })) :: + l | SgExc (_, _) -> assert false | SgExt (loc, n, t, sl) -> (mksig loc (Psig_value - (mkvalue_desc loc (with_loc n loc) t (list_of_meta_list sl)))) :: + (mkvalue_desc loc (with_loc n loc) t + (list_of_meta_list sl)))) :: l | SgInc (loc, mt) -> - (mksig loc (Psig_include (module_type mt, []))) :: l + (mksig loc (Psig_include ((module_type mt), []))) :: l | SgMod (loc, n, mt) -> (mksig loc - (Psig_module {pmd_name=with_loc n loc; pmd_type=module_type mt; pmd_attributes=[]})) :: + (Psig_module + { + pmd_name = with_loc n loc; + pmd_type = module_type mt; + pmd_attributes = []; + })) :: l | SgRecMod (loc, mb) -> (mksig loc (Psig_recmodule (module_sig_binding mb []))) :: @@ -15348,7 +15719,15 @@ module Struct = (match mt with | MtQuo (_, _) -> None | _ -> Some (module_type mt)) - in (mksig loc (Psig_modtype {pmtd_name=with_loc n loc; pmtd_type=si; pmtd_attributes=[]})) :: l + in + (mksig loc + (Psig_modtype + { + pmtd_name = with_loc n loc; + pmtd_type = si; + pmtd_attributes = []; + })) :: + l | SgOpn (loc, id) -> (mksig loc (Psig_open (Fresh, (long_uident id), []))) :: l | SgTyp (loc, tdl) -> @@ -15363,20 +15742,29 @@ module Struct = | Ast.MbAnd (_, x, y) -> module_sig_binding x (module_sig_binding y acc) | Ast.MbCol (loc, s, mt) -> - {pmd_name=with_loc s loc; pmd_type=module_type mt; pmd_attributes=[]} :: acc + { + pmd_name = with_loc s loc; + pmd_type = module_type mt; + pmd_attributes = []; + } :: acc | _ -> assert false and module_str_binding x acc = match x with | Ast.MbAnd (_, x, y) -> module_str_binding x (module_str_binding y acc) | Ast.MbColEq (loc, s, mt, me) -> - {pmb_name=with_loc s loc; - pmb_expr= - {pmod_loc=Camlp4_import.Location.none; - pmod_desc=Pmod_constraint(module_expr me,module_type mt); - pmod_attributes=[]; - }; - pmb_attributes=[]} :: acc + { + pmb_name = with_loc s loc; + pmb_expr = + { + pmod_loc = Camlp4_import.Location.none; + pmod_desc = + Pmod_constraint + (((module_expr me), (module_type mt))); + pmod_attributes = []; + }; + pmb_attributes = []; + } :: acc | _ -> assert false and module_expr = function @@ -15400,8 +15788,17 @@ module Struct = (mkexp loc (Pexp_constraint (((expr e), - mktyp loc (Ptyp_package (package_type pt))))))) + (mktyp loc (Ptyp_package (package_type pt)))))))) | Ast.MePkg (loc, e) -> mkmod loc (Pmod_unpack (expr e)) + | MeAtt (loc, s, str, e) -> + let e = module_expr e + in + { + (e) + with + pmod_attributes = + e.pmod_attributes @ [ attribute loc s str ]; + } | Ast.MeAnt (loc, _) -> error loc "antiquotation in module_expr" and str_item s l = @@ -15424,13 +15821,27 @@ module Struct = | Ast.StExc (loc, (Ast.TyId (_, (Ast.IdUid (_, s)))), Ast. ONone) -> (mkstr loc - (Pstr_exception {pcd_name=with_loc (conv_con s) loc;pcd_args=[];pcd_attributes=[];pcd_res=None;pcd_loc=mkloc loc})) :: + (Pstr_exception + { + pcd_name = with_loc (conv_con s) loc; + pcd_args = []; + pcd_attributes = []; + pcd_res = None; + pcd_loc = mkloc loc; + })) :: l | Ast.StExc (loc, (Ast.TyOf (_, (Ast.TyId (_, (Ast.IdUid (_, s)))), t)), Ast. ONone) -> (mkstr loc - (Pstr_exception {pcd_name=with_loc (conv_con s) loc; pcd_args=List.map ctyp (list_of_ctyp t []);pcd_attributes=[];pcd_res=None;pcd_loc=mkloc loc})) :: + (Pstr_exception + { + pcd_name = with_loc (conv_con s) loc; + pcd_args = List.map ctyp (list_of_ctyp t []); + pcd_attributes = []; + pcd_res = None; + pcd_loc = mkloc loc; + })) :: l | Ast.StExc (loc, (Ast.TyId (_, (Ast.IdUid (_, s)))), (Ast.OSome i)) -> @@ -15442,23 +15853,24 @@ module Struct = (Ast.TyOf (_, (Ast.TyId (_, (Ast.IdUid (_, _)))), _)), (Ast.OSome _)) -> error loc "type in exception alias" | StExc (_, _, _) -> assert false - | StExp (loc, e) -> (mkstr loc (Pstr_eval (expr e, []))) :: l + | StExp (loc, e) -> (mkstr loc (Pstr_eval ((expr e), []))) :: l | StExt (loc, n, t, sl) -> (mkstr loc (Pstr_primitive - (mkvalue_desc loc (with_loc n loc) t (list_of_meta_list sl)))) :: + (mkvalue_desc loc (with_loc n 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 - {pmb_name=with_loc n loc; - pmb_expr=module_expr me; - pmb_attributes=[] - } - )) - :: l + { + pmb_name = with_loc n loc; + pmb_expr = module_expr me; + pmb_attributes = []; + })) :: + l | StRecMod (loc, mb) -> (mkstr loc (Pstr_recmodule (module_str_binding mb []))) :: l @@ -15467,10 +15879,20 @@ module Struct = (match mt with | MtQuo (_, _) -> None | _ -> Some (module_type mt)) - in (mkstr loc (Pstr_modtype {pmtd_name=with_loc n loc; pmtd_type=si; pmtd_attributes=[]})) :: l + in + (mkstr loc + (Pstr_modtype + { + pmtd_name = with_loc n loc; + pmtd_type = si; + pmtd_attributes = []; + })) :: + l | StOpn (loc, ov, id) -> - let fresh = override_flag loc ov in - (mkstr loc (Pstr_open (fresh, (long_uident id), []))) :: l + let fresh = override_flag loc ov + in + (mkstr loc (Pstr_open (fresh, (long_uident id), []))) :: + l | StTyp (loc, tdl) -> (mkstr loc (Pstr_type (mktype_decl tdl []))) :: l | StVal (loc, rf, bi) -> @@ -15498,10 +15920,16 @@ module Struct = in mkcty loc (Pcty_signature - { - pcsig_self = ctyp t; - pcsig_fields = cil; - }) + { pcsig_self = ctyp t; pcsig_fields = cil; }) + | CtAtt (loc, s, str, e) -> + let e = class_type e + in + { + (e) + with + pcty_attributes = + e.pcty_attributes @ [ attribute loc s str ]; + } | CtCon (loc, _, _, _) -> error loc "invalid virtual class inside a class type" | CtAnt (_, _) | CtEq (_, _, _) | CtCol (_, _, _) | @@ -15534,16 +15962,15 @@ module Struct = let params = (match params with | Ast.TyNil _ -> [] - | t -> - class_parameters t []) + | t -> class_parameters t []) in { pci_virt = mkvirtual vir; pci_params = params; pci_name = with_loc name nloc; pci_expr = class_type ct; - pci_loc = mkloc loc; pci_attributes = []; + pci_loc = mkloc loc; } | ct -> error (loc_of_class_type ct) @@ -15559,7 +15986,8 @@ module Struct = (mkctf loc (Pctf_inherit (class_type ct))) :: l | CgMth (loc, s, pf, t) -> (mkctf loc - (Pctf_method ((s, (mkprivate pf), Concrete, (mkpolytype (ctyp t)))))) :: + (Pctf_method + ((s, (mkprivate pf), Concrete, (mkpolytype (ctyp t)))))) :: l | CgVal (loc, s, b, v, t) -> (mkctf loc @@ -15567,7 +15995,8 @@ module Struct = l | CgVir (loc, s, b, t) -> (mkctf loc - (Pctf_method ((s, (mkprivate b), Virtual, (mkpolytype (ctyp t)))))) :: + (Pctf_method + ((s, (mkprivate b), Virtual, (mkpolytype (ctyp t)))))) :: l | CgAnt (_, _) -> assert false and class_expr = @@ -15612,6 +16041,15 @@ module Struct = | CeTyc (loc, ce, ct) -> mkcl loc (Pcl_constraint ((class_expr ce), (class_type ct))) + | CeAtt (loc, s, str, e) -> + let e = class_expr e + in + { + (e) + with + pcl_attributes = + e.pcl_attributes @ [ attribute loc s str ]; + } | CeCon (loc, _, _, _) -> error loc "invalid virtual class inside a class expression" | CeAnt (_, _) | CeEq (_, _, _) | CeAnd (_, _, _) | CeNil _ -> @@ -15641,24 +16079,25 @@ module Struct = (mkcf loc (Pcf_method (((with_loc s loc), (mkprivate pf), - Cfk_concrete ((override_flag loc ov), e))))) :: + (Cfk_concrete (((override_flag loc ov), e))))))) :: l | CrVal (loc, s, ov, mf, e) -> (mkcf loc (Pcf_val (((with_loc s loc), (mkmutable mf), - Cfk_concrete ((override_flag loc ov), (expr e)))))) :: + (Cfk_concrete (((override_flag loc ov), (expr e)))))))) :: l | CrVir (loc, s, pf, t) -> (mkcf loc (Pcf_method (((with_loc s loc), (mkprivate pf), - Cfk_virtual (mkpolytype (ctyp t)))))) :: + (Cfk_virtual (mkpolytype (ctyp t))))))) :: l | CrVvr (loc, s, mf, t) -> (mkcf loc (Pcf_val - (((with_loc s loc), (mkmutable mf), Cfk_virtual (ctyp t))))) :: + (((with_loc s loc), (mkmutable mf), + (Cfk_virtual (ctyp t)))))) :: l | CrAnt (_, _) -> assert false @@ -15680,6 +16119,11 @@ module Struct = | StDir (_, d, dp) -> Ptop_dir (d, (directive dp)) | si -> Ptop_def (str_item si) + let attribute loc s str = + ((with_loc s loc), (PStr (str_item str))) + + let () = attribute_fwd := attribute + end end @@ -19557,6 +20001,8 @@ module Printers = | Ast.ExPkg (_, me) -> pp f "@[@[(module %a@])@]" o#module_expr me + | Ast.ExAtt (_loc, s, str, e) -> + pp f "((%a)[@@%s %a])" o#expr e s o#str_item str | Ast.ExApp (_, _, _) | Ast.ExAcc (_, _, _) | Ast.ExAre (_, _, _) | Ast.ExSte (_, _, _) | Ast.ExAss (_, _, _) | Ast.ExSnd (_, _, _) | @@ -19693,6 +20139,8 @@ module Printers = Ast.PaCom (_, _, _) | Ast.PaSem (_, _, _) | Ast.PaEq (_, _, _) | Ast.PaLaz (_, _) as p) -> pp f "@[<1>(%a)@]" o#patt p + | Ast.PaAtt (_loc, s, str, e) -> + pp f "((%a)[@@%s %a])" o#patt e s o#str_item str method patt_tycon = fun f -> function @@ -19741,6 +20189,8 @@ module Printers = | Ast.TyVrn (_, s) -> pp f "`%a" o#var s | Ast.TySta (_, t1, t2) -> pp f "%a *@ %a" o#simple_ctyp t1 o#simple_ctyp t2 + | Ast.TyAtt (_loc, s, str, e) -> + pp f "((%a)[@@%s %a])" o#ctyp e s o#str_item str | Ast.TyNil _ -> assert false | t -> pp f "@[<1>(%a)@]" o#ctyp t method ctyp = @@ -19960,6 +20410,9 @@ module Printers = | Ast.MtQuo (_, s) -> pp f "'%a" o#var s | Ast.MtSig (_, sg) -> pp f "@[@[sig@ %a@]@ end@]" o#sig_item sg + | Ast.MtAtt (_loc, s, str, e) -> + pp f "((%a)[@@%s %a])" o#module_type e s o#str_item + str | Ast.MtWit (_, mt, wc) -> pp f "@[<2>%a@ with@ %a@]" o#module_type mt o#with_constraint wc @@ -20022,6 +20475,9 @@ module Printers = o#module_type mt | Ast.MePkg (_, e) -> pp f "@[<1>(%s %a)@]" o#value_val o#expr e + | Ast.MeAtt (_loc, s, str, e) -> + pp f "((%a)[@@%s %a])" o#module_expr e s o#str_item + str method class_expr = fun f ce -> let () = o#node f ce Ast.loc_of_class_expr @@ -20068,6 +20524,9 @@ module Printers = | Ast.CeEq (_, ce1, ce2) -> pp f "@[<2>%a =@]@ %a" o#class_expr ce1 o#class_expr ce2 + | Ast.CeAtt (_loc, s, str, e) -> + pp f "((%a)[@@%s %a])" o#class_expr e s o#str_item + str | _ -> assert false method class_type = fun f ct -> @@ -20104,6 +20563,9 @@ module Printers = pp f "%a :@ %a" o#class_type ct1 o#class_type ct2 | Ast.CtEq (_, ct1, ct2) -> pp f "%a =@ %a" o#class_type ct1 o#class_type ct2 + | Ast.CtAtt (_loc, s, str, e) -> + pp f "((%a)[@@%s %a])" o#class_type e s o#str_item + str | _ -> assert false method class_sig_item = fun f csg -> @@ -21647,4 +22109,3 @@ module Register : end - diff --git a/camlp4/boot/camlp4boot.ml b/camlp4/boot/camlp4boot.ml index 4065ec3..8cdb994 100644 --- a/camlp4/boot/camlp4boot.ml +++ b/camlp4/boot/camlp4boot.ml @@ -1915,7 +1915,19 @@ New syntax:\ ((fun () -> (None, [ ((Some "top"), (Some Camlp4.Sig.Grammar.RightA), - [ ([ Gram.Skeyword "object"; + [ ([ Gram.Sself; Gram.Skeyword "[@"; + Gram.Snterm + (Gram.Entry.obj + (a_LIDENT : 'a_LIDENT Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (str_items : 'str_items Gram.Entry.t)); + Gram.Skeyword "]" ], + (Gram.Action.mk + (fun _ (str : 'str_items) (s : 'a_LIDENT) _ + (e : 'expr) (_loc : Gram.Loc.t) -> + (Ast.ExAtt (_loc, s, str, e) : 'expr)))); + ([ Gram.Skeyword "object"; Gram.Snterm (Gram.Entry.obj (opt_class_self_patt : @@ -3586,7 +3598,20 @@ New syntax:\ Gram.extend (patt : 'patt Gram.Entry.t) ((fun () -> (None, - [ ((Some "|"), (Some Camlp4.Sig.Grammar.LeftA), + [ ((Some "attribute"), None, + [ ([ Gram.Sself; Gram.Skeyword "[@"; + Gram.Snterm + (Gram.Entry.obj + (a_LIDENT : 'a_LIDENT Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (str_items : 'str_items Gram.Entry.t)); + Gram.Skeyword "]" ], + (Gram.Action.mk + (fun _ (str : 'str_items) (s : 'a_LIDENT) _ + (e : 'patt) (_loc : Gram.Loc.t) -> + (Ast.PaAtt (_loc, s, str, e) : 'patt)))) ]); + ((Some "|"), (Some Camlp4.Sig.Grammar.LeftA), [ ([ Gram.Sself; Gram.Skeyword "|"; Gram.Sself ], (Gram.Action.mk (fun (p2 : 'patt) _ (p1 : 'patt) @@ -4947,6 +4972,19 @@ New syntax:\ | Invalid_argument s -> raise (Stream.Error s) : 'ctyp)))) ]); + ((Some "attribute"), None, + [ ([ Gram.Sself; Gram.Skeyword "[@"; + Gram.Snterm + (Gram.Entry.obj + (a_LIDENT : 'a_LIDENT Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (str_items : 'str_items Gram.Entry.t)); + Gram.Skeyword "]" ], + (Gram.Action.mk + (fun _ (str : 'str_items) (s : 'a_LIDENT) _ + (e : 'ctyp) (_loc : Gram.Loc.t) -> + (Ast.TyAtt (_loc, s, str, e) : 'ctyp)))) ]); ((Some "simple"), None, [ ([ Gram.Skeyword "("; Gram.Skeyword "module"; Gram.Snterm