Commit bc8338f1 authored by Raphael Rieu-Helft's avatar Raphael Rieu-Helft

Handle syntactic shortcuts in Ocaml extraction (fix #284).

parent 9bb268b5
...@@ -59,6 +59,7 @@ module C = struct ...@@ -59,6 +59,7 @@ module C = struct
| Eindex of expr * expr (* Array access *) | Eindex of expr * expr (* Array access *)
| Edot of expr * string (* Field access with dot *) | Edot of expr * string (* Field access with dot *)
| Earrow of expr * string (* Pointer access with arrow *) | Earrow of expr * string (* Pointer access with arrow *)
| Esyntaxrename of string * expr list (* syntax val f "g" w/o params *)
| Esyntax of string * ty * (ty array) * (expr*ty) list * int list | Esyntax of string * ty * (ty array) * (expr*ty) list * int list
(* template, type and type arguments of result, typed arguments, precedence level *) (* template, type and type arguments of result, typed arguments, precedence level *)
...@@ -172,7 +173,9 @@ module C = struct ...@@ -172,7 +173,9 @@ module C = struct
| Edot (e,i) -> Edot (propagate_in_expr id v e, i) | Edot (e,i) -> Edot (propagate_in_expr id v e, i)
| Earrow (e,i) -> Earrow (propagate_in_expr id v e, i) | Earrow (e,i) -> Earrow (propagate_in_expr id v e, i)
| Esyntax (s,t,ta,l,p) -> | Esyntax (s,t,ta,l,p) ->
Esyntax (s,t,ta,List.map (fun (e,t) -> (propagate_in_expr id v e),t) l,p) Esyntax (s,t,ta,List.map (fun (e,t) -> (propagate_in_expr id v e),t) l,p)
| Esyntaxrename (s, l) ->
Esyntaxrename (s, List.map (propagate_in_expr id v) l)
| Enothing -> Enothing | Enothing -> Enothing
| Econst c -> Econst c | Econst c -> Econst c
| Elikely e -> Elikely (propagate_in_expr id v e) | Elikely e -> Elikely (propagate_in_expr id v e)
...@@ -400,6 +403,7 @@ module C = struct ...@@ -400,6 +403,7 @@ module C = struct
| Esize_type _ -> true | Esize_type _ -> true
| Eindex (_,_) | Edot (_,_) | Earrow (_,_) -> false | Eindex (_,_) | Edot (_,_) | Earrow (_,_) -> false
| Esyntax (_,_,_,_,_) -> false | Esyntax (_,_,_,_,_) -> false
| Esyntaxrename _ -> false
let rec get_const_expr (d,s) = let rec get_const_expr (d,s) =
let fail () = raise (Unsupported "non-constant array size") in let fail () = raise (Unsupported "non-constant array size") in
...@@ -558,8 +562,8 @@ module Print = struct ...@@ -558,8 +562,8 @@ module Print = struct
| Ecast(ty, e) -> | Ecast(ty, e) ->
fprintf fmt (protect_on (prec < 2) "(%a)%a") fprintf fmt (protect_on (prec < 2) "(%a)%a")
(print_ty ~paren:false) ty (print_expr ~prec:2) e (print_ty ~paren:false) ty (print_expr ~prec:2) e
| Ecall (Esyntax (s, _, _, [],_), l) -> | Esyntaxrename (s, l) ->
(* function defined in the prelude *) (* call to function defined in the prelude *)
fprintf fmt (protect_on (prec < 1) "%s(%a)") fprintf fmt (protect_on (prec < 1) "%s(%a)")
s (print_list comma (print_expr ~prec:15)) l s (print_list comma (print_expr ~prec:15)) l
| Ecall (e,l) -> | Ecall (e,l) ->
...@@ -988,29 +992,29 @@ module MLToC = struct ...@@ -988,29 +992,29 @@ module MLToC = struct
unboxed_params args in unboxed_params args in
match query_syntax info.syntax rs.rs_name with match query_syntax info.syntax rs.rs_name with
| Some s -> | Some s ->
begin let complex s =
try String.contains s '%'
let _ = || String.contains s ' '
Str.search_forward || String.contains s '(' in
(Str.regexp "[%]\\([tv]?\\)[0-9]+") s 0 in if complex s
let rty = ty_of_ity (match e.e_ity with then
| C _ -> assert false let rty = ty_of_ity (match e.e_ity with
| I i -> i) in | C _ -> assert false
let rtyargs = match rty.ty_node with | I i -> i) in
| Tyvar _ -> [||] let rtyargs = match rty.ty_node with
| Tyapp (_,args) -> | Tyvar _ -> [||]
Array.of_list (List.map (ty_of_ty info) args) | Tyapp (_,args) ->
in Array.of_list (List.map (ty_of_ty info) args)
let p = Mid.find rs.rs_name info.prec in in
C.Esyntax(s,ty_of_ty info rty, rtyargs, params, p) let p = Mid.find rs.rs_name info.prec in
with Not_found -> C.Esyntax(s,ty_of_ty info rty, rtyargs, params, p)
if args=[] else
then C.(Esyntax(s, Tnosyntax, [||], [], [])) (*constant*) if args=[]
else then C.(Esyntax(s, Tnosyntax, [||], [], [])) (*constant*)
(*function defined in the prelude *) else
let cargs = List.map fst params in (*function defined in the prelude *)
C.(Ecall(Esyntax(s, Tnosyntax, [||], [], []), cargs)) let cargs = List.map fst params in
end C.(Esyntaxrename (s, cargs))
| None -> | None ->
match rs.rs_field with match rs.rs_field with
| None -> | None ->
......
...@@ -187,6 +187,9 @@ module Print = struct ...@@ -187,6 +187,9 @@ module Print = struct
let print_rs info fmt rs = let print_rs info fmt rs =
fprintf fmt "%a" (print_lident info) rs.rs_name fprintf fmt "%a" (print_lident info) rs.rs_name
let complex_syntax s =
String.contains s '%' || String.contains s ' ' || String.contains s '('
(** Types *) (** Types *)
let rec print_ty ~use_quote ?(paren=false) info fmt = function let rec print_ty ~use_quote ?(paren=false) info fmt = function
...@@ -201,9 +204,13 @@ module Print = struct ...@@ -201,9 +204,13 @@ module Print = struct
(print_list star (print_ty ~use_quote ~paren:true info)) tl (print_list star (print_ty ~use_quote ~paren:true info)) tl
| Tapp (ts, tl) -> | Tapp (ts, tl) ->
match query_syntax info.info_syn ts with match query_syntax info.info_syn ts with
| Some s -> | Some s when complex_syntax s ->
fprintf fmt (protect_on paren "%a") fprintf fmt (protect_on paren "%a")
(syntax_arguments s (print_ty ~use_quote ~paren:true info)) tl (syntax_arguments s (print_ty ~use_quote ~paren:true info)) tl
| Some s ->
fprintf fmt (protect_on paren "%a%s")
(print_list_suf space (print_ty ~use_quote ~paren:true info)) tl
s
| None -> | None ->
match tl with match tl with
| [] -> | [] ->
...@@ -263,10 +270,13 @@ module Print = struct ...@@ -263,10 +270,13 @@ module Print = struct
| Ptuple pl -> | Ptuple pl ->
fprintf fmt "(%a)" (print_list comma (print_pat ~paren:true info)) pl fprintf fmt "(%a)" (print_list comma (print_pat ~paren:true info)) pl
| Papp (ls, pl) -> | Papp (ls, pl) ->
match query_syntax info.info_syn ls.ls_name, pl with match query_syntax info.info_syn ls.ls_name with
| Some s, _ -> | Some s when complex_syntax s || pl = [] ->
syntax_arguments s (print_pat info) fmt pl syntax_arguments s (print_pat info) fmt pl
| None, pl -> | Some s ->
fprintf fmt (protect_on paren "%s (%a)")
s (print_list comma (print_pat ~paren:true info)) pl
| None ->
let pjl = let rs = restore_rs ls in get_record info rs in let pjl = let rs = restore_rs ls in get_record info rs in
match pjl with match pjl with
| [] -> print_papp info ls fmt pl | [] -> print_papp info ls fmt pl
...@@ -353,9 +363,13 @@ module Print = struct ...@@ -353,9 +363,13 @@ module Print = struct
List.exists is_constructor its List.exists is_constructor its
| _ -> false in | _ -> false in
match query_syntax info.info_syn rs.rs_name, pvl with match query_syntax info.info_syn rs.rs_name, pvl with
| Some s, _ (* when is_local_id info rs.rs_name *)-> | Some s, _ when complex_syntax s ->
let p = Mid.find rs.rs_name info.info_prec in let p = Mid.find rs.rs_name info.info_prec in
syntax_arguments_prec s (print_expr info) p fmt pvl syntax_arguments_prec s (print_expr info) p fmt pvl
| Some s, _ ->
fprintf fmt "@[<hov 2>%s %a@]"
s
(print_apply_args info) (pvl, rs.rs_cty.cty_args)
| None, [t] when is_rs_tuple rs -> | None, [t] when is_rs_tuple rs ->
fprintf fmt "@[%a@]" (print_expr info 1) t fprintf fmt "@[%a@]" (print_expr info 1) t
| None, tl when is_rs_tuple rs -> | None, tl when is_rs_tuple rs ->
...@@ -572,9 +586,12 @@ module Print = struct ...@@ -572,9 +586,12 @@ module Print = struct
match query_syntax info.info_syn xs.xs_name, e_opt with match query_syntax info.info_syn xs.xs_name, e_opt with
| Some s, None -> | Some s, None ->
fprintf fmt "raise (%s)" s fprintf fmt "raise (%s)" s
| Some s, Some e -> | Some s, Some e when complex_syntax s ->
fprintf fmt (protect_on paren "raise %a") fprintf fmt (protect_on paren "raise %a")
(syntax_arguments_prec s (print_expr info) [4; 3]) [e] (syntax_arguments_prec s (print_expr info) []) [e]
| Some s, Some e ->
fprintf fmt (protect_on paren "raise (%s %a)")
s (print_expr info 3) e
| None, None -> | None, None ->
fprintf fmt (protect_on paren "raise %a") fprintf fmt (protect_on paren "raise %a")
(print_uident info) xs.xs_name (print_uident info) xs.xs_name
...@@ -587,9 +604,13 @@ module Print = struct ...@@ -587,9 +604,13 @@ module Print = struct
if case then fprintf fmt "exception " else fprintf fmt "" in if case then fprintf fmt "exception " else fprintf fmt "" in
let print_var fmt pv = print_lident info fmt (pv_name pv) in let print_var fmt pv = print_lident info fmt (pv_name pv) in
match query_syntax info.info_syn xs.xs_name, pvl with match query_syntax info.info_syn xs.xs_name, pvl with
| Some s, _ -> fprintf fmt "@[<hov 4>| %a%a ->@ %a@]" | Some s, _ when complex_syntax s || pvl = [] ->
print_exn () (syntax_arguments s print_var) pvl fprintf fmt "@[<hov 4>| %a%a ->@ %a@]"
(print_expr info 17) e print_exn () (syntax_arguments s print_var) pvl
(print_expr info 17) e
| Some s, _ -> fprintf fmt "@[<hov 4>| %a%s (%a) ->@ %a@]"
print_exn () s
(print_list comma print_var) pvl (print_expr info 17) e
| None, [] -> fprintf fmt "@[<hov 4>| %a%a ->@ %a@]" | None, [] -> fprintf fmt "@[<hov 4>| %a%a ->@ %a@]"
print_exn () (print_uident info) xs.xs_name (print_expr info 17) e print_exn () (print_uident info) xs.xs_name (print_expr info 17) e
| None, [pv] -> fprintf fmt "@[<hov 4>| %a%a %a ->@ %a@]" | None, [pv] -> fprintf fmt "@[<hov 4>| %a%a %a ->@ %a@]"
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment