Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 329 lines (271 sloc) 8.842 kb
fccc685 Initial open-source release
MLstate authored
1 (*
2 Copyright © 2011 MLstate
3
4 This file is part of OPA.
5
6 OPA is free software: you can redistribute it and/or modify it under the
7 terms of the GNU Affero General Public License, version 3, as published by
8 the Free Software Foundation.
9
10 OPA is distributed in the hope that it will be useful, but WITHOUT ANY
11 WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
12 FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
13 more details.
14
15 You should have received a copy of the GNU Affero General Public License
16 along with OPA. If not, see <http://www.gnu.org/licenses/>.
17 *)
18
19 module String = Base.String
20
21 (* TODO: a safe module InfixOperators, not in base.ml
22 open InfixOperators
23 *)
24 let (@*) = InfixOperator.(@*)
25 let (|>) = InfixOperator.(|>)
26
27 (* <!> If you add anything there, update *parse* and *parsed_t* functions *)
28 type t = {
29 backend_restriction : StringSet.t option ;
30 no_projection : StringSet.t option ;
31 opaname : bool ;
32 raise_ : bool ;
33 restricted : string list option option ;
34 second_order : bool ;
35 cps_bypass : bool ;
36 opacapi : bool ;
37 }
38
39 type parsed_t = ( string * string option ) list
40
41 let default = {
42 backend_restriction = None ;
43 no_projection = Some StringSet.empty ;
44 opaname = true ;
45 raise_ = false ;
46 restricted = None ;
47 second_order = false ;
48 cps_bypass = false ;
49 opacapi = false ;
50 }
51
52 (* for errors message, please put all tags there *)
53 let known_tags = [
54 "backend" ;
55 "opaname" ;
56 "normalize" ;
57 "raise" ;
58 "restricted" ;
59 "no-projection";
60 "cps-bypass" ;
61 "opacapi" ;
62 ]
63
64 let is_default t = ( t == default )
65
66 let string_of_restricted = function
67 | None -> "no restriction"
68 | Some None -> "compiler only (any pass)"
69 | Some Some list -> String.concat_map ~left:"compiler only (pass(es) : " ~right:")" ", " (fun s -> s) list
70
71
72 type 'a pprinter = 'a Base.Format.pprinter
73 let pp = Format.fprintf
74 let pp_string = Format.pp_print_string
75 let pp_list = Base.Format.pp_list
76 let pp_meta_string fmt s = Format.fprintf fmt "%S" s
77
78 let pp_option name pp' fmt = function
79 | None -> pp_string fmt name
80 | Some o -> pp fmt "%s:%a" name pp' o
81
82
83 let pp_tag fmt (tag, attribute) = pp_option tag pp_string fmt attribute
84
85 let pp_meta_tag fmt (tag, attribute) =
86 Format.fprintf fmt "(%S, %a)" tag (Option.pp_meta pp_meta_string) attribute
87
88 let pp_meta fmt parsed_t =
89 Format.fprintf fmt "[ %a ]" (pp_list " ; " pp_meta_tag) parsed_t
90
91 (* following guidelines about errors *)
92 type error =
93 | Unknown_tag of (string * string option)
94 | RaiseInconsistency
95
96 exception Exception of error
97
98 let pp_error fmt = function
99 | Unknown_tag ((typo, _) as tag) ->
100 Format.fprintf fmt "Unknown tag [ %a , ... ]@\n" pp_tag tag ;
101 Format.fprintf fmt "%a" (HintUtils.pp_suggestion known_tags) typo
102 | RaiseInconsistency ->
103 Format.fprintf fmt "Inconsistency on tag [ raise , ...]@\n" ;
104 Format.fprintf fmt "This tag is not compatible with @{<bright>cps-bypass@}, nor @{<bright>no-projection(:cps?)@}"
105
106 let error_unknown_tag tag = raise (Exception (Unknown_tag tag))
107
108 let check_tags tags =
109 let inconsistency () = raise (Exception RaiseInconsistency) in
110 let () =
111 if tags.raise_
112 then
113 let () =
114 match tags.no_projection with
115 | None -> inconsistency ()
116 | Some set -> if StringSet.mem "cps" set then inconsistency ()
117 in
118 let () =
119 if tags.cps_bypass then inconsistency ()
120 in
121 ()
122 in
123 ()
124
125 let parse_aux =
126 let fold t = function
127 | "no-projection", None ->
128 { t with no_projection = None }
129 | "no-projection", Some s ->
130 (match t.no_projection with
131 | None -> t
132 | Some old -> { t with no_projection = Some (StringSet.add s old) })
133 | "opaname", _ ->
134 (* opaname is now set by default, but we keep the syntax for backward compatibility *)
135 { t with opaname = true }
136 | "normalize", _ ->
137 { t with opaname = false }
138 | "raise", _ ->
139 { t with raise_ = true }
140 | "restricted", opt ->
141 begin
142 let restricted =
143 match opt with
144 | None -> Some None
145 | Some pass ->
146 begin
147 match t.restricted with
148 | None -> Some (Some [pass])
149 | Some None -> Some None
150 | Some (Some other_pass) -> Some (Some (pass::other_pass))
151 end
152 in
153 { t with restricted = restricted }
154 end
155
156 | "backend", opt ->
157 let opt = Option.default "anybackend" opt in
158 { t with
159 backend_restriction =
160 Some (StringSet.add opt (Option.default StringSet.empty t.backend_restriction))
161 }
162
163 (* internal attributes : should not be parsed, but are generated by bslregister *)
164 | "second-order", _ ->
165 { t with second_order = true }
166 | "cps-bypass", _ ->
167 { t with cps_bypass = true }
168
169 | "opacapi", _ ->
170 { t with opacapi = true }
171
172 | tag ->
173 error_unknown_tag tag
174
175 in
176 List.fold_left fold default
177
178 let parse ?pos parsed_t =
179 match pos with
180 | None -> parse_aux parsed_t
181 | Some pos -> (
182 try
183 let tags = parse_aux parsed_t in
184 check_tags tags ;
185 tags
186 with
187 | Exception error ->
188 OManager.printf "%a" FilePos.pp_citation pos ;
189 OManager.error "%a@\n" pp_error error
190 )
191
192 (* reversing : used for code generation. *)
193
194 let parsed_t_backend t acc =
195 let tag = "backend" in
196 match t.backend_restriction with
197 | None -> acc
198 | Some set ->
199 StringSet.fold (
200 fun backend acc -> (tag, Some backend) :: acc
201 ) set acc
202
203 let parsed_t_no_projection t acc =
204 let no_projection = "no-projection" in
205 match t.no_projection with
206 | None -> (no_projection, None) :: acc
207 | Some set ->
208 if StringSet.is_empty set
209 then acc
210 else
211 StringSet.fold (
212 fun elt acc -> (no_projection, Some elt) :: acc
213 ) set acc
214
215 let parsed_t_opaname t acc =
216 let normalize = "normalize" in
217 match t.opaname with
218 | false -> (normalize, None) :: acc
219 | true -> acc
220
221 let parsed_t_raise t acc =
222 let raise_ = "raise" in
223 match t.raise_ with
224 | true -> (raise_, None) :: acc
225 | false -> acc
226
227 let parsed_t_restricted t acc =
228 let restricted = "restricted" in
229 match t.restricted with
230 | None -> acc
231 | Some None -> (restricted, None) :: acc
232 | Some (Some passes) ->
233 List.fold_left (
234 fun acc pass -> (restricted, Some pass) :: acc
235 ) acc passes
236
237
238 let parsed_t_second_order t acc =
239 let second_order = "second-order" in
240 if t.second_order
241 then (second_order, None) :: acc
242 else acc
243
244
245 let parsed_t_cps_bypass t acc =
246 let cps_bypass = "cps-bypass" in
247 if t.cps_bypass
248 then (cps_bypass, None) :: acc
249 else acc
250
251 let parsed_t_opacapi t acc =
252 let opacapi = "opacapi" in
253 if t.opacapi
254 then (opacapi, None) :: acc
255 else acc
256
257 let parsed_t t =
258 let (||>) acc f = f t acc in
259 []
260 ||> parsed_t_backend
261 ||> parsed_t_no_projection
262 ||> parsed_t_opaname
263 ||> parsed_t_raise
264 ||> parsed_t_restricted
265 ||> parsed_t_second_order
266 ||> parsed_t_cps_bypass
267 ||> parsed_t_opacapi
268 |> List.sort Pervasives.compare
269
270
271 (** {6 Printing} *)
272
273 let pp fmt t =
274 let parsed_t = parsed_t t in
275 pp fmt "[@[<4>@ %a @]]" (pp_list " ;@ " pp_tag) parsed_t
276
277
278 module Q = QmlAst
279
280 let authorized_bypass ~restriction tags =
281 #<If:BSL_NO_RESTRICTION>
282 true
283 #<Else>
284 match restriction with
285 | None -> (
286 match tags.restricted with
287 | None -> true
288 | Some _ -> false
289 )
290 | Some pass -> (
291 match tags.restricted with
292 | None
293 | Some None -> true
294 | Some (Some authorized_passes) -> List.mem pass authorized_passes
295 )
296 #<End>
297
298
299 let authorized_bypass_as_expr tags bypass =
300 match bypass with
301 | Q.Bypass _ ->
302 authorized_bypass ~restriction:None tags
303 | Q.Directive (_, `restricted_bypass restriction, _, _) ->
304 authorized_bypass ~restriction:(Some restriction) tags
305 | _ -> assert false (* this function is not meant to be called with anything else *)
306
307 type passname = string
308
309 let do_projection {no_projection = no_projection} pass_name =
310 match no_projection with
311 | None -> false
312 | Some s -> not (StringSet.mem pass_name s)
313
314
315 let never_projected {no_projection = no_projection} =
316 match no_projection with
317 | None -> true
318 | Some _ -> false
319
320
321 let string_of_no_projection = function
322 | None -> "never project"
323 | Some s ->
324 if StringSet.is_empty s then
325 "always project"
326 else
327 String.concat_map ~left:"always project but for the following passes: " ", "
328 (fun x -> x) (StringSet.elements s)
Something went wrong with that request. Please try again.