Skip to content

Commit 285b240

Browse files
hhugohhugo
committed
Compiler: add support for OCaml 4.14.3+trunk
1 parent d02ff40 commit 285b240

File tree

3 files changed

+140
-87
lines changed

3 files changed

+140
-87
lines changed

‎compiler/lib/parse_bytecode.ml

Lines changed: 6 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -256,7 +256,8 @@ end = struct
256256
in
257257
List.sort names ~cmp:(fun (i, _) (j, _) -> compare i j)
258258
with Not_found -> []
259-
[@@if ocaml_version < (5, 2, 0)]
259+
[@@if
260+
ocaml_version < (4, 14, 3) || (ocaml_version >= (5, 0) && ocaml_version < (5, 2, 0))]
260261

261262
let find_rec { events_by_pc; _ } pc =
262263
try
@@ -276,7 +277,10 @@ end = struct
276277
in
277278
List.sort names ~cmp:(fun (i, _) (j, _) -> compare i j)
278279
with Not_found -> []
279-
[@@if ocaml_version >= (5, 2, 0)]
280+
[@@if
281+
not
282+
(ocaml_version < (4, 14, 3)
283+
|| (ocaml_version >= (5, 0) && ocaml_version < (5, 2, 0)))]
280284

281285
let dummy_location (loc : Location.t) =
282286
loc.loc_start.pos_cnum = -1 || loc.loc_end.pos_cnum = -1

‎compiler/ppx/ppx_optcomp_light.ml

Lines changed: 134 additions & 80 deletions
Original file line numberDiff line numberDiff line change
@@ -88,92 +88,146 @@ end = struct
8888
| n -> n)
8989
end
9090

91-
exception Invalid
91+
exception Invalid of Location.t
9292

93-
let get_env s =
94-
match Properties.get s with
95-
| None -> Sys.getenv s
96-
| Some p -> p
93+
type op =
94+
| LE
95+
| GE
96+
| GT
97+
| LT
98+
| NEQ
99+
| EQ
100+
| AND
101+
| OR
102+
| NOT
103+
104+
type e =
105+
| Version of Version.t
106+
| Tuple of e list
107+
| Bool of bool
108+
| Int of int
109+
| String of string
110+
111+
let get_bin_op = function
112+
| { pexp_desc = Pexp_ident { txt = Lident str; _ }; pexp_loc = loc; _ } -> (
113+
match str with
114+
| "<=" -> LE
115+
| ">=" -> GE
116+
| ">" -> GT
117+
| "<" -> LT
118+
| "=" -> EQ
119+
| "<>" -> NEQ
120+
| "&&" -> AND
121+
| "||" -> OR
122+
| _ -> raise (Invalid loc))
123+
| { pexp_loc = loc; _ } -> raise (Invalid loc)
124+
125+
let get_un_op = function
126+
| { pexp_desc = Pexp_ident { txt = Lident str; _ }; pexp_loc = loc; _ } -> (
127+
match str with
128+
| "not" -> NOT
129+
| _ -> raise (Invalid loc))
130+
| { pexp_loc = loc; _ } -> raise (Invalid loc)
131+
132+
let version = function
133+
| Version v -> v
134+
| Tuple l ->
135+
Version.of_list
136+
(List.map l ~f:(function
137+
| Int i -> i
138+
| _ -> raise (Invalid Location.none)))
139+
| Bool _ | Int _ | String _ -> raise (Invalid Location.none)
97140

98141
let keep loc (attrs : attributes) =
99-
try
100-
let keep =
101-
List.for_all attrs ~f:(function
102-
| { attr_name = { txt = ("if" | "ifnot") as ifnot; _ }; attr_payload; _ } -> (
103-
let norm =
104-
match ifnot with
105-
| "if" -> fun x -> x
106-
| "ifnot" -> fun x -> not x
107-
| _ -> assert false
108-
in
142+
let ifs =
143+
List.filter attrs ~f:(function
144+
| { attr_name = { txt = "if"; _ }; _ } -> true
145+
| _ -> false)
146+
in
147+
match ifs with
148+
| [] -> true
149+
| _ -> (
150+
try
151+
let keep_one { attr_payload; attr_loc; _ } =
152+
let e =
109153
match attr_payload with
110-
| PStr
111-
[ { pstr_desc =
112-
Pstr_eval
113-
( { pexp_desc = Pexp_construct ({ txt = Lident ident; _ }, None)
114-
; _
115-
}
116-
, [] )
117-
; _
118-
}
119-
] ->
120-
let b =
121-
match bool_of_string (get_env ident) with
122-
| true -> true
123-
| false -> false
124-
| exception _ -> false
125-
in
126-
norm b
127-
| PStr
128-
[ { pstr_desc =
129-
Pstr_eval
130-
( { pexp_desc = Pexp_apply (op, [ (Nolabel, a); (Nolabel, b) ])
131-
; _
132-
}
133-
, [] )
134-
; _
135-
}
136-
] ->
137-
let get_op = function
138-
| { pexp_desc = Pexp_ident { txt = Lident str; _ }; _ } -> (
139-
match str with
140-
| "<=" -> ( <= )
141-
| ">=" -> ( >= )
142-
| ">" -> ( > )
143-
| "<" -> ( < )
144-
| "<>" -> ( <> )
145-
| "=" -> ( = )
146-
| _ -> raise Invalid)
147-
| _ -> raise Invalid
148-
in
149-
let eval = function
150-
| { pexp_desc = Pexp_ident { txt = Lident "ocaml_version"; _ }; _ } ->
151-
Version.current
152-
| { pexp_desc = Pexp_tuple l; _ } ->
153-
let l =
154-
List.map l ~f:(function
155-
| { pexp_desc = Pexp_constant (Pconst_integer (d, None)); _ } ->
156-
int_of_string d
157-
| _ -> raise Invalid)
158-
in
159-
Version.of_list l
160-
| _ -> raise Invalid
161-
in
162-
let op = get_op op in
154+
| PStr [ { pstr_desc = Pstr_eval (e, []); _ } ] -> e
155+
| _ -> raise (Invalid attr_loc)
156+
in
157+
let loc = e.pexp_loc in
158+
let rec eval = function
159+
| { pexp_desc = Pexp_ident { txt = Lident "ocaml_version"; _ }; _ } ->
160+
Version Version.current
161+
| { pexp_desc = Pexp_construct ({ txt = Lident "true"; _ }, None); _ } ->
162+
Bool true
163+
| { pexp_desc = Pexp_construct ({ txt = Lident "false"; _ }, None); _ } ->
164+
Bool false
165+
| { pexp_desc = Pexp_constant (Pconst_integer (d, None)); _ } ->
166+
Int (int_of_string d)
167+
| { pexp_desc = Pexp_tuple l; _ } -> Tuple (List.map l ~f:eval)
168+
| { pexp_desc = Pexp_apply (op, [ (Nolabel, a); (Nolabel, b) ]); pexp_loc; _ }
169+
-> (
170+
let op = get_bin_op op in
163171
let a = eval a in
164172
let b = eval b in
165-
norm (op (Version.compare a b) 0)
166-
| _ -> raise Invalid)
167-
| _ -> true)
168-
in
169-
if false && not keep
170-
then
171-
Printf.eprintf
172-
"dropping %s:%d\n%!"
173-
loc.Location.loc_start.pos_fname
174-
loc.Location.loc_start.pos_lnum;
175-
keep
176-
with Invalid -> Location.raise_errorf ~loc "Invalid attribute format"
173+
match op with
174+
| LE | GE | LT | GT | NEQ | EQ ->
175+
let comp =
176+
match a, b with
177+
| Version _, _ | _, Version _ ->
178+
Version.compare (version a) (version b)
179+
| Int a, Int b -> compare a b
180+
| _ -> raise (Invalid pexp_loc)
181+
in
182+
let op =
183+
match op with
184+
| LE -> ( <= )
185+
| GE -> ( >= )
186+
| LT -> ( < )
187+
| GT -> ( > )
188+
| EQ -> ( = )
189+
| NEQ -> ( <> )
190+
| _ -> assert false
191+
in
192+
Bool (op comp 0)
193+
| AND -> (
194+
match a, b with
195+
| Bool a, Bool b -> Bool (a && b)
196+
| _ -> raise (Invalid loc))
197+
| OR -> (
198+
match a, b with
199+
| Bool a, Bool b -> Bool (a || b)
200+
| _ -> raise (Invalid loc))
201+
| NOT -> raise (Invalid loc))
202+
| { pexp_desc = Pexp_apply (op, [ (Nolabel, a) ]); _ } -> (
203+
let op = get_un_op op in
204+
let a = eval a in
205+
match op, a with
206+
| NOT, Bool b -> Bool (not b)
207+
| NOT, _ -> raise (Invalid loc)
208+
| _ -> raise (Invalid loc))
209+
| _ -> raise (Invalid loc)
210+
in
211+
match eval e with
212+
| Bool b -> b
213+
| Int _ | String _ | Tuple _ | Version _ -> raise (Invalid loc)
214+
in
215+
let keep = List.for_all ~f:keep_one ifs in
216+
if false
217+
then
218+
if not keep
219+
then
220+
Printf.eprintf
221+
"dropping %s:%d\n%!"
222+
loc.Location.loc_start.pos_fname
223+
loc.Location.loc_start.pos_lnum
224+
else
225+
Printf.eprintf
226+
"keep %s:%d\n%!"
227+
loc.Location.loc_start.pos_fname
228+
loc.Location.loc_start.pos_lnum;
229+
keep
230+
with Invalid loc -> Location.raise_errorf ~loc "Invalid attribute format")
177231

178232
let filter_map ~f l =
179233
let l =

‎compiler/ppx/properties.ml

Lines changed: 0 additions & 5 deletions
This file was deleted.

0 commit comments

Comments
 (0)