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
| Eindex of expr * expr (* Array access *)
| Edot of expr * string (* Field access with dot *)
| 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
(* template, type and type arguments of result, typed arguments, precedence level *)
......@@ -172,7 +173,9 @@ module C = struct
| Edot (e,i) -> Edot (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,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
| Econst c -> Econst c
| Elikely e -> Elikely (propagate_in_expr id v e)
......@@ -400,6 +403,7 @@ module C = struct
| Esize_type _ -> true
| Eindex (_,_) | Edot (_,_) | Earrow (_,_) -> false
| Esyntax (_,_,_,_,_) -> false
| Esyntaxrename _ -> false
let rec get_const_expr (d,s) =
let fail () = raise (Unsupported "non-constant array size") in
......@@ -558,8 +562,8 @@ module Print = struct
| Ecast(ty, e) ->
fprintf fmt (protect_on (prec < 2) "(%a)%a")
(print_ty ~paren:false) ty (print_expr ~prec:2) e
| Ecall (Esyntax (s, _, _, [],_), l) ->
(* function defined in the prelude *)
| Esyntaxrename (s, l) ->
(* call to function defined in the prelude *)
fprintf fmt (protect_on (prec < 1) "%s(%a)")
s (print_list comma (print_expr ~prec:15)) l
| Ecall (e,l) ->
......@@ -988,29 +992,29 @@ module MLToC = struct
unboxed_params args in
match query_syntax info.syntax rs.rs_name with
| Some s ->
begin
try
let _ =
Str.search_forward
(Str.regexp "[%]\\([tv]?\\)[0-9]+") s 0 in
let rty = ty_of_ity (match e.e_ity with
| C _ -> assert false
| I i -> i) in
let rtyargs = match rty.ty_node with
| Tyvar _ -> [||]
| Tyapp (_,args) ->
Array.of_list (List.map (ty_of_ty info) args)
in
let p = Mid.find rs.rs_name info.prec in
C.Esyntax(s,ty_of_ty info rty, rtyargs, params, p)
with Not_found ->
if args=[]
then C.(Esyntax(s, Tnosyntax, [||], [], [])) (*constant*)
else
(*function defined in the prelude *)
let cargs = List.map fst params in
C.(Ecall(Esyntax(s, Tnosyntax, [||], [], []), cargs))
end
let complex s =
String.contains s '%'
|| String.contains s ' '
|| String.contains s '(' in
if complex s
then
let rty = ty_of_ity (match e.e_ity with
| C _ -> assert false
| I i -> i) in
let rtyargs = match rty.ty_node with
| Tyvar _ -> [||]
| Tyapp (_,args) ->
Array.of_list (List.map (ty_of_ty info) args)
in
let p = Mid.find rs.rs_name info.prec in
C.Esyntax(s,ty_of_ty info rty, rtyargs, params, p)
else
if args=[]
then C.(Esyntax(s, Tnosyntax, [||], [], [])) (*constant*)
else
(*function defined in the prelude *)
let cargs = List.map fst params in
C.(Esyntaxrename (s, cargs))
| None ->
match rs.rs_field with
| None ->
......
......@@ -187,6 +187,9 @@ module Print = struct
let print_rs info fmt rs =
fprintf fmt "%a" (print_lident info) rs.rs_name
let complex_syntax s =
String.contains s '%' || String.contains s ' ' || String.contains s '('
(** Types *)
let rec print_ty ~use_quote ?(paren=false) info fmt = function
......@@ -201,9 +204,13 @@ module Print = struct
(print_list star (print_ty ~use_quote ~paren:true info)) tl
| Tapp (ts, tl) ->
match query_syntax info.info_syn ts with
| Some s ->
| Some s when complex_syntax s ->
fprintf fmt (protect_on paren "%a")
(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 ->
match tl with
| [] ->
......@@ -263,10 +270,13 @@ module Print = struct
| Ptuple pl ->
fprintf fmt "(%a)" (print_list comma (print_pat ~paren:true info)) pl
| Papp (ls, pl) ->
match query_syntax info.info_syn ls.ls_name, pl with
| Some s, _ ->
syntax_arguments s (print_pat info) fmt pl
| None, pl ->
match query_syntax info.info_syn ls.ls_name with
| Some s when complex_syntax s || pl = [] ->
syntax_arguments s (print_pat info) fmt 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
match pjl with
| [] -> print_papp info ls fmt pl
......@@ -353,9 +363,13 @@ module Print = struct
List.exists is_constructor its
| _ -> false in
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
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 ->
fprintf fmt "@[%a@]" (print_expr info 1) t
| None, tl when is_rs_tuple rs ->
......@@ -572,9 +586,12 @@ module Print = struct
match query_syntax info.info_syn xs.xs_name, e_opt with
| Some s, None ->
fprintf fmt "raise (%s)" s
| Some s, Some e ->
| Some s, Some e when complex_syntax s ->
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 ->
fprintf fmt (protect_on paren "raise %a")
(print_uident info) xs.xs_name
......@@ -587,9 +604,13 @@ module Print = struct
if case then fprintf fmt "exception " else fprintf fmt "" 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
| Some s, _ -> fprintf fmt "@[<hov 4>| %a%a ->@ %a@]"
print_exn () (syntax_arguments s print_var) pvl
(print_expr info 17) e
| Some s, _ when complex_syntax s || pvl = [] ->
fprintf fmt "@[<hov 4>| %a%a ->@ %a@]"
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@]"
print_exn () (print_uident info) xs.xs_name (print_expr info 17) e
| 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