Attention une mise à jour du serveur va être effectuée le vendredi 16 avril entre 12h et 12h30. Cette mise à jour va générer une interruption du service de quelques minutes.

Commit 9bb268b5 authored by Raphael Rieu-Helft's avatar Raphael Rieu-Helft

Move the Ocaml printer to a precedence-based system

parent 41e5758e
......@@ -16,12 +16,6 @@ module ref.Ref
syntax val (:=) "%1 = %2" prec 14 13 14
end
module mach.int.Unsigned
syntax constant zero_unsigned "0"
end
module mach.int.Int32
syntax type int32 "int32_t"
......
This diff is collapsed.
......@@ -116,7 +116,7 @@ val gen_syntax_arguments_typed_prec :
val syntax_arguments_typed_prec :
string -> (int -> term Pp.pp) -> ty Pp.pp -> term -> int list -> term list Pp.pp
(** (syntax_arguments_typed templ print_arg prec_list fmt l) prints in the
(** (syntax_arguments_typed_prec templ print_arg prec_list fmt l) prints in the
formatter fmt the list l using the template templ, the printer print_arg
and the precedence list prec_list *)
......
......@@ -34,8 +34,29 @@ type info = {
info_mo_known_map : Pdecl.known_map;
info_fname : string option;
info_flat : bool;
info_prec : int list Mid.t;
info_current_ph : string list; (* current path *)
}
}
(* operator precedence, from http://caml.inria.fr/pub/docs/manual-ocaml/expr.html
! ? ~ ... | 1
. .( .[ .~ | 2
#... | 3
fun/cstr app| 4 left
-_ -._ | 5
** lsl lsr | 6 right
* / % | 7 left
+ - | 8 left
:: | 9 right
@ ^ | 10 right
= < > != | 11 left
& && | 12 right
or || | 13 right
, | 14
<- := | 15 right
if | 16
;   | 17 right
let fun try | 18 *)
module Print = struct
......@@ -307,15 +328,15 @@ module Print = struct
| Eapp (rs, _)
when query_syntax info.info_syn rs.rs_name = Some "None" -> ()
| _ -> fprintf fmt "?%s:%a" (pv_name pv).id_string
(print_expr ~paren:true info) expr end
(print_expr info 1) expr end
else if is_named ~attrs:(pv_name pv).id_attrs then
fprintf fmt "~%s:%a" (pv_name pv).id_string
(print_expr ~paren:true info) expr
else fprintf fmt "%a" (print_expr ~paren:true info) expr;
(print_expr info 1) expr
else fprintf fmt "%a" (print_expr info 3) expr;
if exprl <> [] then fprintf fmt "@ ";
print_apply_args info fmt (exprl, pvl)
| expr :: exprl, [] ->
fprintf fmt "%a" (print_expr ~paren:true info) expr;
fprintf fmt "%a" (print_expr info 3) expr;
print_apply_args info fmt (exprl, [])
| [], _ -> ()
......@@ -333,13 +354,14 @@ module Print = struct
| _ -> false in
match query_syntax info.info_syn rs.rs_name, pvl with
| Some s, _ (* when is_local_id info rs.rs_name *)->
syntax_arguments s (print_expr ~paren:true info) fmt pvl;
let p = Mid.find rs.rs_name info.info_prec in
syntax_arguments_prec s (print_expr info) p fmt pvl
| None, [t] when is_rs_tuple rs ->
fprintf fmt "@[%a@]" (print_expr info) t
fprintf fmt "@[%a@]" (print_expr info 1) t
| None, tl when is_rs_tuple rs ->
fprintf fmt "@[(%a)@]" (print_list comma (print_expr info)) tl
fprintf fmt "@[(%a)@]" (print_list comma (print_expr info 14)) tl
| None, [t1] when isfield ->
fprintf fmt "%a.%a" (print_expr info) t1 (print_lident info) rs.rs_name
fprintf fmt "%a.%a" (print_expr info 2) t1 (print_lident info) rs.rs_name
| None, tl when isconstructor () ->
let pjl = get_record info rs in
begin match pjl, tl with
......@@ -347,21 +369,20 @@ module Print = struct
(print_uident info) fmt rs.rs_name
| [], [t] ->
fprintf fmt "@[<hov 2>%a %a@]" (print_uident info) rs.rs_name
(print_expr ~paren:true info) t
(print_expr info 2) t
| [], tl ->
fprintf fmt "@[<hov 2>%a (%a)@]" (print_uident info) rs.rs_name
(print_list comma (print_expr ~paren:true info)) tl
(print_list comma (print_expr info 14)) tl
| pjl, tl -> let equal fmt () = fprintf fmt " =@ " in
fprintf fmt "@[<hov 2>{ %a }@]"
(print_list2 semi equal (print_rs info)
(print_expr ~paren:true info)) (pjl, tl) end
(print_expr info 17)) (pjl, tl) end
| None, [] ->
(print_lident info) fmt rs.rs_name
| _, tl ->
fprintf fmt "@[<hov 2>%a %a@]"
(print_lident info) rs.rs_name
(print_apply_args info) (tl, rs.rs_cty.cty_args)
(* (print_list space (print_expr ~paren:true info)) tl *)
and print_svar fmt s =
Stv.iter (fun tv -> fprintf fmt "%a " (print_tv ~use_quote:false) tv) s
......@@ -371,7 +392,7 @@ module Print = struct
fprintf fmt "@[%a@] :@ %a@ =@ %a"
(print_list space (print_vs_arg info)) args
(print_ty ~use_quote:false info) res
(print_expr info) e
(print_expr ~opr:false info 18) e
else
let ty_args = List.map (fun (_, ty, _) -> ty) args in
let id_args = List.map (fun (id, _, _) -> id) args in
......@@ -383,12 +404,12 @@ module Print = struct
(print_list_suf arrow (print_ty ~use_quote:false ~paren:true info)) ty_args
(print_ty ~use_quote:false ~paren:true info) res
(print_list_delim ~start ~stop:arrow ~sep:space (print_lident info)) id_args
(print_expr info) e
(print_expr ~opr:false info 18) e
and print_let_def ?(functor_arg=false) info fmt = function
| Lvar (pv, e) ->
fprintf fmt "@[<hov 2>let %a =@ %a@]"
(print_lident info) (pv_name pv) (print_expr info) e
(print_lident info) (pv_name pv) (print_expr ~opr:false info 18) e
| Lsym (rs, svar, res, args, ef) ->
fprintf fmt "@[<hov 2>let %a %a@]"
(print_lident info) rs.rs_name
......@@ -418,7 +439,7 @@ module Print = struct
forget_vars args
| Lany ({rs_name}, _, _, _) -> check_val_in_drv info rs_name.id_loc rs_name
and print_expr ?(paren=false) info fmt e =
and print_expr ?(opr=true) info prec fmt e =
match e.e_node with
| Econst c ->
let n = c.Number.il_int in
......@@ -430,15 +451,16 @@ module Print = struct
| Some s -> syntax_arguments s print_constant fmt [e]
| None when n = "0" -> fprintf fmt "Z.zero"
| None when n = "1" -> fprintf fmt "Z.one"
| None -> fprintf fmt (protect_on paren "Z.of_string \"%s\"") n)
| None -> fprintf fmt
(protect_on (opr && prec < 4) "Z.of_string \"%s\"") n)
| Evar pvs ->
(print_lident info) fmt (pv_name pvs)
| Elet (let_def, e) ->
fprintf fmt (protect_on paren "@[%a@] in@ @[%a@]")
(print_let_def info) let_def (print_expr info) e;
fprintf fmt (protect_on (opr && prec < 18) "@[%a@] in@ @[%a@]")
(print_let_def info) let_def (print_expr ~opr info 18) e;
forget_let_defn let_def
| Eabsurd ->
fprintf fmt (protect_on paren "assert false (* absurd *)")
fprintf fmt (protect_on (opr && prec < 4) "assert false (* absurd *)")
| Eapp (rs, []) when rs_equal rs rs_true ->
fprintf fmt "true"
| Eapp (rs, []) when rs_equal rs rs_false ->
......@@ -446,96 +468,104 @@ module Print = struct
| Eapp (rs, []) -> (* avoids parenthesis around values *)
fprintf fmt "%a" (print_apply info rs) []
| Eapp (rs, pvl) ->
fprintf fmt (protect_on paren "%a")
fprintf fmt (protect_on (opr && prec < 4) "%a")
(print_apply info rs) pvl
| Ematch (e1, [p, e2], []) ->
fprintf fmt (protect_on paren "let %a =@ %a in@ %a")
(print_pat info) p (print_expr info) e1 (print_expr info) e2
fprintf fmt (protect_on (opr && prec < 18) "let %a =@ %a in@ %a")
(print_pat info) p (print_expr ~opr:false info 18) e1
(print_expr ~opr info 18) e2
| Ematch (e, pl, []) ->
fprintf fmt
(protect_on paren "begin match @[%a@] with@\n@[<hov>%a@]@\nend")
(print_expr info) e (print_list newline (print_branch info)) pl
"begin match @[%a@] with@\n@[<hov>%a@]@\nend"
(print_expr info 18) e
(print_list newline (print_branch info)) pl
| Eassign al ->
let assign fmt (rho, rs, e) =
fprintf fmt "@[<hov 2>%a.%a <-@ %a@]"
(print_lident info) (pv_name rho) (print_lident info) rs.rs_name
(print_expr info) e in
(print_expr info 15) e in
begin match al with
| [] -> assert false | [a] -> assign fmt a
| al -> fprintf fmt "@[begin %a end@]" (print_list semi assign) al end
| Eif (e1, e2, {e_node = Eblock []}) ->
fprintf fmt
(protect_on paren
(protect_on (opr && prec < 16)
"@[<hv>@[<hov 2>if@ %a@]@ then begin@;<1 2>@[%a@] end@]")
(print_expr info) e1 (print_expr info) e2
(print_expr ~opr:false info 15) e1 (print_expr ~opr:false info 18) e2
| Eif (e1, e2, e3) when is_false e2 && is_true e3 ->
fprintf fmt (protect_on paren "not %a") (print_expr info ~paren:true) e1
fprintf fmt (protect_on (opr && prec < 4) "not %a")
(print_expr info 3) e1
| Eif (e1, e2, e3) when is_true e2 ->
fprintf fmt (protect_on paren "@[<hv>%a || %a@]")
(print_expr info ~paren:true) e1 (print_expr info ~paren:true) e3
fprintf fmt (protect_on (opr && prec < 13) "@[<hv>%a || %a@]")
(print_expr info 12) e1 (print_expr info 13) e3
| Eif (e1, e2, e3) when is_false e3 ->
fprintf fmt (protect_on paren "@[<hv>%a && %a@]")
(print_expr info ~paren:true) e1 (print_expr info ~paren:true) e2
fprintf fmt (protect_on (opr && prec < 12) "@[<hv>%a && %a@]")
(print_expr info 11) e1 (print_expr info 12) e2
| Eif (e1, e2, e3) ->
fprintf fmt (protect_on paren
fprintf fmt (protect_on (opr && prec < 16)
"@[<hv>@[<hov 2>if@ %a@ then@ begin@ @[%a@] end@]\
@;<1 0>else@ begin@;<1 2>@[%a@] end@]")
(print_expr info) e1 (print_expr info) e2 (print_expr info) e3
(print_expr ~opr:false info 18) e1
(print_expr ~opr:false info 18) e2
(print_expr ~opr:false info 18) e3
| Eblock [] ->
fprintf fmt "()"
| Eblock [e] ->
print_expr info fmt e
print_expr info prec fmt e
| Eblock el ->
fprintf fmt "@[<hv>begin@;<1 2>@[%a@]@ end@]"
(print_list semi (print_expr info)) el
let rec aux fmt = function
| [] -> assert false
| [e] -> print_expr ~opr:false info 18 fmt e
| h::t -> print_expr info 17 fmt h; semi fmt (); aux fmt t in
fprintf fmt "@[<hv>begin@;<1 2>@[%a@]@ end@]" aux el
| Efun (varl, e) ->
fprintf fmt (protect_on paren "@[<hov 2>fun %a ->@ %a@]")
(print_list space (print_vs_arg info)) varl (print_expr info) e
fprintf fmt (protect_on (opr && prec < 18) "@[<hov 2>fun %a ->@ %a@]")
(print_list space (print_vs_arg info)) varl (print_expr info 17) e
| Ewhile (e1, e2) ->
fprintf fmt "@[<hov 2>while %a do@\n%a@ done@]"
(print_expr info) e1 (print_expr info) e2
(print_expr info 18) e1 (print_expr ~opr:false info 18) e2
| Eraise (xs, e_opt) ->
print_raise ~paren info xs fmt e_opt
print_raise ~paren:(prec < 4) info xs fmt e_opt
| Efor (pv1, pv2, dir, pv3, e) ->
if is_mapped_to_int info pv1.pv_ity then begin
fprintf fmt "@[<hov 2>for %a = %a %a %a do@ @[%a@]@ done@]"
(print_lident info) (pv_name pv1) (print_lident info) (pv_name pv2)
print_for_direction dir (print_lident info) (pv_name pv3)
(print_expr info) e;
(print_expr ~opr:false info 18) e;
forget_pv pv1 end
else
let for_id = id_register (id_fresh "for_loop_to") in
let cmp, op = match dir with
| To -> "Z.leq", "Z.succ"
| DownTo -> "Z.geq", "Z.pred" in
fprintf fmt (protect_on paren
fprintf fmt (protect_on (opr && prec < 18)
"@[<hov 2>let rec %a %a =@ if %s %a %a then \
begin@ %a; %a (%s %a) end@ in@ %a %a@]")
(* let rec *) (print_lident info) for_id (print_pv info) pv1
(* if *) cmp (print_pv info) pv1 (print_pv info) pv3
(* then *) (print_expr info) e (print_lident info) for_id
(* then *) (print_expr info 16) e (print_lident info) for_id
op (print_pv info) pv1
(* in *) (print_lident info) for_id (print_pv info) pv2
| Ematch (e, [], xl) ->
fprintf fmt "@[<hv>@[<hov 2>begin@ try@ %a@] with@]@\n@[<hov>%a@]@\nend"
(print_expr info) e (print_list newline (print_xbranch info false)) xl
(print_expr info 17) e (print_list newline (print_xbranch info false)) xl
| Ematch (e, bl, xl) ->
fprintf fmt
(protect_on paren "begin match @[%a@] with@\n@[<hov>%a@\n%a@]@\nend")
(print_expr info) e (print_list newline (print_branch info)) bl
"begin match @[%a@] with@\n@[<hov>%a@\n%a@]@\nend"
(print_expr info 17) e (print_list newline (print_branch info)) bl
(print_list newline (print_xbranch info true)) xl
| Eexn (xs, None, e) ->
fprintf fmt "@[<hv>let exception %a in@\n%a@]"
(print_uident info) xs.xs_name (print_expr info) e
(print_uident info) xs.xs_name (print_expr info 18) e
| Eexn (xs, Some t, e) ->
fprintf fmt "@[<hv>let exception %a of %a in@\n%a@]"
(print_uident info) xs.xs_name (print_ty ~use_quote:false ~paren:true info) t
(print_expr info) e
| Eignore e -> fprintf fmt "ignore (%a)" (print_expr info) e
(print_expr info 18) e
| Eignore e -> fprintf fmt "ignore %a" (print_expr info 4) e
and print_branch info fmt (p, e) =
fprintf fmt "@[<hov 2>| %a ->@ @[%a@]@]"
(print_pat info) p (print_expr info) e;
(print_pat info) p (print_expr info 17) e;
forget_pat p
and print_raise ~paren info xs fmt e_opt =
......@@ -543,14 +573,14 @@ module Print = struct
| Some s, None ->
fprintf fmt "raise (%s)" s
| Some s, Some e ->
fprintf fmt (protect_on paren "raise (%a)")
(syntax_arguments s (print_expr info)) [e]
fprintf fmt (protect_on paren "raise %a")
(syntax_arguments_prec s (print_expr info) [4; 3]) [e]
| None, None ->
fprintf fmt (protect_on paren "raise %a")
(print_uident info) xs.xs_name
| None, Some e ->
fprintf fmt (protect_on paren "raise (%a %a)")
(print_uident info) xs.xs_name (print_expr ~paren:true info) e
(print_uident info) xs.xs_name (print_expr info 3) e
and print_xbranch info case fmt (xs, pvl, e) =
let print_exn fmt () =
......@@ -559,15 +589,15 @@ module Print = struct
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 ~paren:true) e
(print_expr info 17) e
| None, [] -> fprintf fmt "@[<hov 4>| %a%a ->@ %a@]"
print_exn () (print_uident info) xs.xs_name (print_expr info) e
print_exn () (print_uident info) xs.xs_name (print_expr info 17) e
| None, [pv] -> fprintf fmt "@[<hov 4>| %a%a %a ->@ %a@]"
print_exn () (print_uident info) xs.xs_name print_var pv
(print_expr info) e
(print_expr info 17) e
| None, pvl -> fprintf fmt "@[<hov 4>| %a%a (%a) ->@ %a@]"
print_exn () (print_uident info) xs.xs_name
(print_list comma print_var) pvl (print_expr info) e
(print_list comma print_var) pvl (print_expr info 17) e
let print_type_decl info fst fmt its =
let print_constr fmt (id, cs_args) =
......@@ -681,8 +711,9 @@ let print_decl =
info_mo_known_map = m.mod_known;
info_fname = Opt.map Compile.clean_name fname;
info_flat = flat;
info_prec = pargs.Pdriver.prec;
info_current_ph = [];
} in
} in
if not (Hashtbl.mem memo d) then begin Hashtbl.add memo d ();
Print.print_decl info fmt d end
......
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