package / ocaml-base-compiler.4.10.0 / parsing / builtin_attributes.ml
1 (**************************************************************************)
2 (* *)
3 (* OCaml *)
4 (* *)
5 (* Alain Frisch, LexiFi *)
6 (* *)
7 (* Copyright 2012 Institut National de Recherche en Informatique et *)
8 (* en Automatique. *)
9 (* *)
10 (* All rights reserved. This file is distributed under the terms of *)
11 (* the GNU Lesser General Public License version 2.1, with the *)
12 (* special exception on linking described in the file LICENSE. *)
13 (* *)
14 (**************************************************************************)
15
16 open Asttypes
17 open Parsetree
18
19 let string_of_cst = function
20 | Pconst_string(s, _) -> Some s
21 | _ -> None
22
23 let string_of_payload = function
24 | PStr[{pstr_desc=Pstr_eval({pexp_desc=Pexp_constant c},_)}] ->
25 string_of_cst c
26 | _ -> None
27
28 let string_of_opt_payload p =
29 match string_of_payload p with
30 | Some s -> s
31 | None -> ""
32
33 let error_of_extension ext =
34 let submessage_from main_loc main_txt = function
35 | {pstr_desc=Pstr_extension
36 (({txt = ("ocaml.error"|"error"); loc}, p), _)} ->
37 begin match p with
38 | PStr([{pstr_desc=Pstr_eval
39 ({pexp_desc=Pexp_constant(Pconst_string(msg,_))}, _)}]) ->
40 { Location.loc; txt = fun ppf -> Format.pp_print_text ppf msg }
41 | _ ->
42 { Location.loc; txt = fun ppf ->
43 Format.fprintf ppf
44 "Invalid syntax for sub-message of extension '%s'." main_txt }
45 end
46 | {pstr_desc=Pstr_extension (({txt; loc}, _), _)} ->
47 { Location.loc; txt = fun ppf ->
48 Format.fprintf ppf "Uninterpreted extension '%s'." txt }
49 | _ ->
50 { Location.loc = main_loc; txt = fun ppf ->
51 Format.fprintf ppf
52 "Invalid syntax for sub-message of extension '%s'." main_txt }
53 in
54 match ext with
55 | ({txt = ("ocaml.error"|"error") as txt; loc}, p) ->
56 begin match p with
57 | PStr [] -> raise Location.Already_displayed_error
58 | PStr({pstr_desc=Pstr_eval
59 ({pexp_desc=Pexp_constant(Pconst_string(msg,_))}, _)}::
60 inner) ->
61 let sub = List.map (submessage_from loc txt) inner in
62 Location.error_of_printer ~loc ~sub Format.pp_print_text msg
63 | _ ->
64 Location.errorf ~loc "Invalid syntax for extension '%s'." txt
65 end
66 | ({txt; loc}, _) ->
67 Location.errorf ~loc "Uninterpreted extension '%s'." txt
68
69 let kind_and_message = function
70 | PStr[
71 {pstr_desc=
72 Pstr_eval
73 ({pexp_desc=Pexp_apply
74 ({pexp_desc=Pexp_ident{txt=Longident.Lident id}},
75 [Nolabel,{pexp_desc=Pexp_constant (Pconst_string(s,_))}])
76 },_)}] ->
77 Some (id, s)
78 | PStr[
79 {pstr_desc=
80 Pstr_eval
81 ({pexp_desc=Pexp_ident{txt=Longident.Lident id}},_)}] ->
82 Some (id, "")
83 | _ -> None
84
85 let cat s1 s2 =
86 if s2 = "" then s1 else s1 ^ "\n" ^ s2
87
88 let alert_attr x =
89 match x.attr_name.txt with
90 | "ocaml.deprecated"|"deprecated" ->
91 Some (x, "deprecated", string_of_opt_payload x.attr_payload)
92 | "ocaml.alert"|"alert" ->
93 begin match kind_and_message x.attr_payload with
94 | Some (kind, message) -> Some (x, kind, message)
95 | None -> None (* note: bad payloads detected by warning_attribute *)
96 end
97 | _ -> None
98
99 let alert_attrs l =
100 List.filter_map alert_attr l
101
102 let alerts_of_attrs l =
103 List.fold_left
104 (fun acc (_, kind, message) ->
105 let upd = function
106 | None | Some "" -> Some message
107 | Some s -> Some (cat s message)
108 in
109 Misc.Stdlib.String.Map.update kind upd acc
110 )
111 Misc.Stdlib.String.Map.empty
112 (alert_attrs l)
113
114 let check_alerts loc attrs s =
115 Misc.Stdlib.String.Map.iter
116 (fun kind message -> Location.alert loc ~kind (cat s message))
117 (alerts_of_attrs attrs)
118
119 let check_alerts_inclusion ~def ~use loc attrs1 attrs2 s =
120 let m2 = alerts_of_attrs attrs2 in
121 Misc.Stdlib.String.Map.iter
122 (fun kind msg ->
123 if not (Misc.Stdlib.String.Map.mem kind m2) then
124 Location.alert ~def ~use ~kind loc (cat s msg)
125 )
126 (alerts_of_attrs attrs1)
127
128 let rec deprecated_mutable_of_attrs = function
129 | [] -> None
130 | {attr_name = {txt = "ocaml.deprecated_mutable"|"deprecated_mutable"; _};
131 attr_payload = p} :: _ ->
132 Some (string_of_opt_payload p)
133 | _ :: tl -> deprecated_mutable_of_attrs tl
134
135 let check_deprecated_mutable loc attrs s =
136 match deprecated_mutable_of_attrs attrs with
137 | None -> ()
138 | Some txt ->
139 Location.deprecated loc (Printf.sprintf "mutating field %s" (cat s txt))
140
141 let check_deprecated_mutable_inclusion ~def ~use loc attrs1 attrs2 s =
142 match deprecated_mutable_of_attrs attrs1,
143 deprecated_mutable_of_attrs attrs2
144 with
145 | None, _ | Some _, Some _ -> ()
146 | Some txt, None ->
147 Location.deprecated ~def ~use loc
148 (Printf.sprintf "mutating field %s" (cat s txt))
149
150 let rec attrs_of_sig = function
151 | {psig_desc = Psig_attribute a} :: tl ->
152 a :: attrs_of_sig tl
153 | _ ->
154 []
155
156 let alerts_of_sig sg = alerts_of_attrs (attrs_of_sig sg)
157
158 let rec attrs_of_str = function
159 | {pstr_desc = Pstr_attribute a} :: tl ->
160 a :: attrs_of_str tl
161 | _ ->
162 []
163
164 let alerts_of_str str = alerts_of_attrs (attrs_of_str str)
165
166 let check_no_alert attrs =
167 List.iter
168 (fun (a, _, _) ->
169 Location.prerr_warning a.attr_loc
170 (Warnings.Misplaced_attribute a.attr_name.txt)
171 )
172 (alert_attrs attrs)
173
174 let warn_payload loc txt msg =
175 Location.prerr_warning loc (Warnings.Attribute_payload (txt, msg))
176
177 let warning_attribute ?(ppwarning = true) =
178 let process loc txt errflag payload =
179 match string_of_payload payload with
180 | Some s ->
181 begin try Warnings.parse_options errflag s
182 with Arg.Bad msg -> warn_payload loc txt msg
183 end
184 | None ->
185 warn_payload loc txt "A single string literal is expected"
186 in
187 let process_alert loc txt = function
188 | PStr[{pstr_desc=
189 Pstr_eval(
190 {pexp_desc=Pexp_constant(Pconst_string(s,_))},
191 _)
192 }] ->
193 begin try Warnings.parse_alert_option s
194 with Arg.Bad msg -> warn_payload loc txt msg
195 end
196 | k ->
197 match kind_and_message k with
198 | Some ("all", _) ->
199 warn_payload loc txt "The alert name 'all' is reserved"
200 | Some _ -> ()
201 | None -> warn_payload loc txt "Invalid payload"
202 in
203 function
204 | {attr_name = {txt = ("ocaml.warning"|"warning") as txt; _};
205 attr_loc;
206 attr_payload;
207 } ->
208 process attr_loc txt false attr_payload
209 | {attr_name = {txt = ("ocaml.warnerror"|"warnerror") as txt; _};
210 attr_loc;
211 attr_payload
212 } ->
213 process attr_loc txt true attr_payload
214 | {attr_name = {txt="ocaml.ppwarning"|"ppwarning"; _};
215 attr_loc = _;
216 attr_payload =
217 PStr [
218 { pstr_desc=
219 Pstr_eval({pexp_desc=Pexp_constant (Pconst_string (s, _))},_);
220 pstr_loc }
221 ];
222 } when ppwarning ->
223 Location.prerr_warning pstr_loc (Warnings.Preprocessor s)
224 | {attr_name = {txt = ("ocaml.alert"|"alert") as txt; _};
225 attr_loc;
226 attr_payload;
227 } ->
228 process_alert attr_loc txt attr_payload
229 | _ ->
230 ()
231
232 let warning_scope ?ppwarning attrs f =
233 let prev = Warnings.backup () in
234 try
235 List.iter (warning_attribute ?ppwarning) (List.rev attrs);
236 let ret = f () in
237 Warnings.restore prev;
238 ret
239 with exn ->
240 Warnings.restore prev;
241 raise exn
242
243
244 let warn_on_literal_pattern =
245 List.exists
246 (fun a -> match a.attr_name.txt with
247 | "ocaml.warn_on_literal_pattern"|"warn_on_literal_pattern" -> true
248 | _ -> false
249 )
250
251 let explicit_arity =
252 List.exists
253 (fun a -> match a.attr_name.txt with
254 | "ocaml.explicit_arity"|"explicit_arity" -> true
255 | _ -> false
256 )
257
258 let immediate =
259 List.exists
260 (fun a -> match a.attr_name.txt with
261 | "ocaml.immediate"|"immediate" -> true
262 | _ -> false
263 )
264
265 let immediate64 =
266 List.exists
267 (fun a -> match a.attr_name.txt with
268 | "ocaml.immediate64"|"immediate64" -> true
269 | _ -> false
270 )
271
272 (* The "ocaml.boxed (default)" and "ocaml.unboxed (default)"
273 attributes cannot be input by the user, they are added by the
274 compiler when applying the default setting. This is done to record
275 in the .cmi the default used by the compiler when compiling the
276 source file because the default can change between compiler
277 invocations. *)
278
279 let check l a = List.mem a.attr_name.txt l
280
281 let has_unboxed attr =
282 List.exists (check ["ocaml.unboxed"; "unboxed"])
283 attr
284
285 let has_boxed attr =
286 List.exists (check ["ocaml.boxed"; "boxed"]) attr
287