|
| 1 | +(***********************************************************************) |
| 2 | +(* *) |
| 3 | +(* OCaml *) |
| 4 | +(* *) |
| 5 | +(* Alain Frisch, LexiFi *) |
| 6 | +(* *) |
| 7 | +(* Copyright 2012 Institut National de Recherche en Informatique et *) |
| 8 | +(* en Automatique. All rights reserved. This file is distributed *) |
| 9 | +(* under the terms of the Q Public License version 1.0. *) |
| 10 | +(* *) |
| 11 | +(***********************************************************************) |
| 12 | + |
| 13 | +open Asttypes |
| 14 | +open Parsetree |
| 15 | + |
| 16 | +let string_of_cst = function |
| 17 | + | Const_string(s, _) -> Some s |
| 18 | + | _ -> None |
| 19 | + |
| 20 | +let string_of_payload = function |
| 21 | + | PStr[{pstr_desc=Pstr_eval({pexp_desc=Pexp_constant c},_)}] -> |
| 22 | + string_of_cst c |
| 23 | + | _ -> None |
| 24 | + |
| 25 | +let rec error_of_extension ext = |
| 26 | + match ext with |
| 27 | + | ({txt = ("ocaml.error"|"error") as txt; loc}, p) -> |
| 28 | + let rec sub_from inner = |
| 29 | + match inner with |
| 30 | + | {pstr_desc=Pstr_extension (ext, _)} :: rest -> |
| 31 | + error_of_extension ext :: sub_from rest |
| 32 | + | {pstr_loc} :: rest -> |
| 33 | + (Location.errorf ~loc |
| 34 | + "Invalid syntax for sub-error of extension '%s'." txt) :: |
| 35 | + sub_from rest |
| 36 | + | [] -> [] |
| 37 | + in |
| 38 | + begin match p with |
| 39 | + | PStr({pstr_desc=Pstr_eval |
| 40 | + ({pexp_desc=Pexp_constant(Const_string(msg,_))}, _)}:: |
| 41 | + {pstr_desc=Pstr_eval |
| 42 | + ({pexp_desc=Pexp_constant(Const_string(if_highlight,_))}, _)}:: |
| 43 | + inner) -> |
| 44 | + Location.error ~loc ~if_highlight ~sub:(sub_from inner) msg |
| 45 | + | PStr({pstr_desc=Pstr_eval |
| 46 | + ({pexp_desc=Pexp_constant(Const_string(msg,_))}, _)}::inner) -> |
| 47 | + Location.error ~loc ~sub:(sub_from inner) msg |
| 48 | + | _ -> Location.errorf ~loc "Invalid syntax for extension '%s'." txt |
| 49 | + end |
| 50 | + | ({txt; loc}, _) -> |
| 51 | + Location.errorf ~loc "Uninterpreted extension '%s'." txt |
| 52 | + |
| 53 | +let rec deprecated_of_attrs = function |
| 54 | + | [] -> None |
| 55 | + | ({txt = "ocaml.deprecated"|"deprecated"; _}, p) :: _ -> |
| 56 | + begin match string_of_payload p with |
| 57 | + | Some txt -> Some txt |
| 58 | + | None -> Some "" |
| 59 | + end |
| 60 | + | _ :: tl -> deprecated_of_attrs tl |
| 61 | + |
| 62 | +let check_deprecated loc attrs s = |
| 63 | + match deprecated_of_attrs attrs with |
| 64 | + | None -> () |
| 65 | + | Some "" -> Location.prerr_warning loc (Warnings.Deprecated s) |
| 66 | + | Some txt -> Location.prerr_warning loc (Warnings.Deprecated (s ^ "\n" ^ txt)) |
| 67 | + |
| 68 | +let rec deprecated_of_sig = function |
| 69 | + | {psig_desc = Psig_attribute a} :: tl -> |
| 70 | + begin match deprecated_of_attrs [a] with |
| 71 | + | None -> deprecated_of_sig tl |
| 72 | + | Some _ as r -> r |
| 73 | + end |
| 74 | + | _ -> None |
| 75 | + |
| 76 | + |
| 77 | +let rec deprecated_of_str = function |
| 78 | + | {pstr_desc = Pstr_attribute a} :: tl -> |
| 79 | + begin match deprecated_of_attrs [a] with |
| 80 | + | None -> deprecated_of_str tl |
| 81 | + | Some _ as r -> r |
| 82 | + end |
| 83 | + | _ -> None |
| 84 | + |
| 85 | + |
| 86 | +let emit_external_warnings = |
| 87 | + (* Note: this is run as a preliminary pass when type-checking an |
| 88 | + interface or implementation. This allows to cover all kinds of |
| 89 | + attributes, but the drawback is that it doesn't take local |
| 90 | + configuration of warnings (with '@@warning'/'@@warnerror' |
| 91 | + attributes) into account. We should rather check for |
| 92 | + 'ppwarning' attributes during the actual type-checking, making |
| 93 | + sure to cover all contexts (easier and more ugly alternative: |
| 94 | + duplicate here the logic which control warnings locally). *) |
| 95 | + let open Ast_mapper in |
| 96 | + { |
| 97 | + default_mapper with |
| 98 | + attribute = (fun _ a -> |
| 99 | + begin match a with |
| 100 | + | {txt="ocaml.ppwarning"|"ppwarning"}, |
| 101 | + PStr[{pstr_desc=Pstr_eval({pexp_desc=Pexp_constant |
| 102 | + (Const_string (s, _))},_); |
| 103 | + pstr_loc}] -> |
| 104 | + Location.prerr_warning pstr_loc (Warnings.Preprocessor s) |
| 105 | + | _ -> () |
| 106 | + end; |
| 107 | + a |
| 108 | + ) |
| 109 | + } |
| 110 | + |
| 111 | + |
| 112 | +let warning_scope = ref [] |
| 113 | + |
| 114 | +let warning_enter_scope () = |
| 115 | + warning_scope := (Warnings.backup ()) :: !warning_scope |
| 116 | +let warning_leave_scope () = |
| 117 | + match !warning_scope with |
| 118 | + | [] -> assert false |
| 119 | + | hd :: tl -> |
| 120 | + Warnings.restore hd; |
| 121 | + warning_scope := tl |
| 122 | + |
| 123 | +let warning_attribute attrs = |
| 124 | + let process loc txt errflag payload = |
| 125 | + match string_of_payload payload with |
| 126 | + | Some s -> |
| 127 | + begin try Warnings.parse_options errflag s |
| 128 | + with Arg.Bad _ -> |
| 129 | + Location.prerr_warning loc |
| 130 | + (Warnings.Attribute_payload |
| 131 | + (txt, "Ill-formed list of warnings")) |
| 132 | + end |
| 133 | + | None -> |
| 134 | + Location.prerr_warning loc |
| 135 | + (Warnings.Attribute_payload |
| 136 | + (txt, "A single string literal is expected")) |
| 137 | + in |
| 138 | + List.iter |
| 139 | + (function |
| 140 | + | ({txt = ("ocaml.warning"|"warning") as txt; loc}, payload) -> |
| 141 | + process loc txt false payload |
| 142 | + | ({txt = ("ocaml.warnerror"|"warnerror") as txt; loc}, payload) -> |
| 143 | + process loc txt true payload |
| 144 | + | _ -> |
| 145 | + () |
| 146 | + ) |
| 147 | + attrs |
| 148 | + |
| 149 | +let with_warning_attribute attrs f = |
| 150 | + try |
| 151 | + warning_enter_scope (); |
| 152 | + warning_attribute attrs; |
| 153 | + let ret = f () in |
| 154 | + warning_leave_scope (); |
| 155 | + ret |
| 156 | + with exn -> |
| 157 | + warning_leave_scope (); |
| 158 | + raise exn |
0 commit comments