Commit 718a8420 authored by Raphael Rieu-Helft's avatar Raphael Rieu-Helft

Handle precedence levels of subexpressions

parent 2e7810ad
...@@ -13,7 +13,7 @@ end ...@@ -13,7 +13,7 @@ end
module ref.Ref module ref.Ref
syntax val (!_) "%1" prec 0 syntax val (!_) "%1" prec 0
syntax val (:=) "%1 = %2" prec 14 syntax val (:=) "%1 = %2" prec 14 13 14
end end
module mach.int.Unsigned module mach.int.Unsigned
...@@ -27,17 +27,17 @@ module mach.int.Int32 ...@@ -27,17 +27,17 @@ module mach.int.Int32
syntax type int32 "int32_t" syntax type int32 "int32_t"
syntax literal int32 "%d" syntax literal int32 "%d"
syntax val (+) "%1 + %2" prec 4 syntax val (+) "%1 + %2" prec 4 4 3
syntax val (-) "%1 - %2" prec 4 syntax val (-) "%1 - %2" prec 4 4 3
syntax val (-_) "-%1" prec 2 syntax val (-_) "-%1" prec 2 1
syntax val ( * ) "%1 * %2" prec 3 syntax val ( * ) "%1 * %2" prec 3 3 2
syntax val (/) "%1 / %2" prec 3 syntax val (/) "%1 / %2" prec 3 3 2
syntax val (%) "%1 % %2" prec 3 syntax val (%) "%1 % %2" prec 3 3 2
syntax val (=) "%1 == %2" prec 7 syntax val (=) "%1 == %2" prec 7 7 6
syntax val (<=) "%1 <= %2" prec 6 syntax val (<=) "%1 <= %2" prec 6 6 5
syntax val (<) "%1 < %2" prec 6 syntax val (<) "%1 < %2" prec 6 6 5
syntax val (>=) "%1 >= %2" prec 6 syntax val (>=) "%1 >= %2" prec 6 6 5
syntax val (>) "%1 > %2" prec 6 syntax val (>) "%1 > %2" prec 6 6 5
end end
module mach.int.UInt32Gen module mach.int.UInt32Gen
...@@ -53,17 +53,17 @@ module mach.int.UInt32 ...@@ -53,17 +53,17 @@ module mach.int.UInt32
syntax literal uint32 "0x%8xU" syntax literal uint32 "0x%8xU"
syntax val (+) "%1 + %2" prec 4 syntax val (+) "%1 + %2" prec 4 4 3
syntax val (-) "%1 - %2" prec 4 syntax val (-) "%1 - %2" prec 4 4 3
syntax val (-_) "-%1" prec 2 syntax val (-_) "-%1" prec 2 1
syntax val ( * ) "%1 * %2" prec 3 syntax val ( * ) "%1 * %2" prec 3 3 2
syntax val (/) "%1 / %2" prec 3 syntax val (/) "%1 / %2" prec 3 3 2
syntax val (%) "%1 % %2" prec 3 syntax val (%) "%1 % %2" prec 3 3 2
syntax val (=) "%1 == %2" prec 7 syntax val (=) "%1 == %2" prec 7 7 6
syntax val (<=) "%1 <= %2" prec 6 syntax val (<=) "%1 <= %2" prec 6 6 5
syntax val (<) "%1 < %2" prec 6 syntax val (<) "%1 < %2" prec 6 6 5
syntax val (>=) "%1 >= %2" prec 6 syntax val (>=) "%1 >= %2" prec 6 6 5
syntax val (>) "%1 > %2" prec 6 syntax val (>) "%1 > %2" prec 6 6 5
end end
...@@ -185,17 +185,17 @@ struct __lsld32_result lsld32(uint32_t x, uint32_t cnt); ...@@ -185,17 +185,17 @@ struct __lsld32_result lsld32(uint32_t x, uint32_t cnt);
syntax literal uint32 "0x%8xU" syntax literal uint32 "0x%8xU"
syntax val (+) "%1 + %2" prec 4 syntax val (+) "%1 + %2" prec 4 4 3
syntax val (-) "%1 - %2" prec 4 syntax val (-) "%1 - %2" prec 4 4 3
syntax val (-_) "-%1" prec 2 syntax val (-_) "-%1" prec 2 1
syntax val ( * ) "%1 * %2" prec 3 syntax val ( * ) "%1 * %2" prec 3 3 2
syntax val (/) "%1 / %2" prec 3 syntax val (/) "%1 / %2" prec 3 3 2
syntax val (%) "%1 % %2" prec 3 syntax val (%) "%1 % %2" prec 3 3 2
syntax val (=) "%1 == %2" prec 7 syntax val (=) "%1 == %2" prec 7 7 6
syntax val (<=) "%1 <= %2" prec 6 syntax val (<=) "%1 <= %2" prec 6 6 5
syntax val (<) "%1 < %2" prec 6 syntax val (<) "%1 < %2" prec 6 6 5
syntax val (>=) "%1 >= %2" prec 6 syntax val (>=) "%1 >= %2" prec 6 6 5
syntax val (>) "%1 > %2" prec 6 syntax val (>) "%1 > %2" prec 6 6 5
syntax val add_with_carry "add32_with_carry" syntax val add_with_carry "add32_with_carry"
syntax val sub_with_borrow "sub32_with_borrow" syntax val sub_with_borrow "sub32_with_borrow"
...@@ -203,22 +203,22 @@ struct __lsld32_result lsld32(uint32_t x, uint32_t cnt); ...@@ -203,22 +203,22 @@ struct __lsld32_result lsld32(uint32_t x, uint32_t cnt);
syntax val add3 "add32_3" syntax val add3 "add32_3"
syntax val lsld "lsld32" syntax val lsld "lsld32"
syntax val add_mod "%1 + %2" prec 4 syntax val add_mod "%1 + %2" prec 4 4 3
syntax val sub_mod "%1 - %2" prec 4 syntax val sub_mod "%1 - %2" prec 4 4 3
syntax val mul_mod "%1 * %2" prec 3 syntax val mul_mod "%1 * %2" prec 3 3 2
syntax val div2by1 syntax val div2by1
"(uint32_t)((((uint64_t)%1) | (((uint64_t)%2) << 32))/(uint64_t)(%3))" "(uint32_t)((((uint64_t)%1) | (((uint64_t)%2) << 32))/(uint64_t)(%3))"
prec 2 prec 2
syntax val lsl "%1 << %2" prec 5 syntax val lsl "%1 << %2" prec 5 5 4
syntax val lsr "%1 >> %2" prec 5 syntax val lsr "%1 >> %2" prec 5 5 4
syntax val is_msb_set "%1 & 0x80000000U" prec 8 syntax val is_msb_set "%1 & 0x80000000U" prec 8 8
syntax val count_leading_zeros "__builtin_clz(%1)" prec 1 syntax val count_leading_zeros "__builtin_clz(%1)" prec 1 15
syntax val of_int32 "(uint32_t)(%1)" prec 2 syntax val of_int32 "(uint32_t)%1" prec 2 2
end end
...@@ -227,17 +227,17 @@ module mach.int.Int64 ...@@ -227,17 +227,17 @@ module mach.int.Int64
syntax type int64 "int64_t" syntax type int64 "int64_t"
syntax literal int64 "%dLL" syntax literal int64 "%dLL"
syntax val (+) "%1 + %2" prec 4 syntax val (+) "%1 + %2" prec 4 4 3
syntax val (-) "%1 - %2" prec 4 syntax val (-) "%1 - %2" prec 4 4 3
syntax val (-_) "-%1" prec 2 syntax val (-_) "-%1" prec 2 1
syntax val ( * ) "%1 * %2" prec 3 syntax val ( * ) "%1 * %2" prec 3 3 2
syntax val (/) "%1 / %2" prec 3 syntax val (/) "%1 / %2" prec 3 3 2
syntax val (%) "%1 % %2" prec 3 syntax val (%) "%1 % %2" prec 3 3 2
syntax val (=) "%1 == %2" prec 7 syntax val (=) "%1 == %2" prec 7 7 6
syntax val (<=) "%1 <= %2" prec 6 syntax val (<=) "%1 <= %2" prec 6 6 5
syntax val (<) "%1 < %2" prec 6 syntax val (<) "%1 < %2" prec 6 6 5
syntax val (>=) "%1 >= %2" prec 6 syntax val (>=) "%1 >= %2" prec 6 6 5
syntax val (>) "%1 > %2" prec 6 syntax val (>) "%1 > %2" prec 6 6 5
end end
...@@ -254,17 +254,17 @@ module mach.int.UInt64 ...@@ -254,17 +254,17 @@ module mach.int.UInt64
syntax literal uint64 "0x%16xULL" syntax literal uint64 "0x%16xULL"
syntax val (+) "%1 + %2" prec 4 syntax val (+) "%1 + %2" prec 4 4 3
syntax val (-) "%1 - %2" prec 4 syntax val (-) "%1 - %2" prec 4 4 3
syntax val (-_) "-%1" prec 2 syntax val (-_) "-%1" prec 2 1
syntax val ( * ) "%1 * %2" prec 3 syntax val ( * ) "%1 * %2" prec 3 3 2
syntax val (/) "%1 / %2" prec 3 syntax val (/) "%1 / %2" prec 3 3 2
syntax val (%) "%1 % %2" prec 3 syntax val (%) "%1 % %2" prec 3 3 2
syntax val (=) "%1 == %2" prec 7 syntax val (=) "%1 == %2" prec 7 7 6
syntax val (<=) "%1 <= %2" prec 6 syntax val (<=) "%1 <= %2" prec 6 6 5
syntax val (<) "%1 < %2" prec 6 syntax val (<) "%1 < %2" prec 6 6 5
syntax val (>=) "%1 >= %2" prec 6 syntax val (>=) "%1 >= %2" prec 6 6 5
syntax val (>) "%1 > %2" prec 6 syntax val (>) "%1 > %2" prec 6 6 5
end end
...@@ -511,17 +511,17 @@ static struct __lsld64_result lsld64(uint64_t x, uint64_t cnt) ...@@ -511,17 +511,17 @@ static struct __lsld64_result lsld64(uint64_t x, uint64_t cnt)
syntax val uint64_max "0xffffffffffffffffULL" prec 0 syntax val uint64_max "0xffffffffffffffffULL" prec 0
syntax val (+) "%1 + %2" prec 4 syntax val (+) "%1 + %2" prec 4 4 3
syntax val (-) "%1 - %2" prec 4 syntax val (-) "%1 - %2" prec 4 4 3
syntax val (-_) "-%1" prec 2 syntax val (-_) "-%1" prec 2 1
syntax val ( * ) "%1 * %2" prec 3 syntax val ( * ) "%1 * %2" prec 3 3 2
syntax val (/) "%1 / %2" prec 3 syntax val (/) "%1 / %2" prec 3 3 2
syntax val (%) "%1 % %2" prec 3 syntax val (%) "%1 % %2" prec 3 3 2
syntax val (=) "%1 == %2" prec 7 syntax val (=) "%1 == %2" prec 7 7 6
syntax val (<=) "%1 <= %2" prec 6 syntax val (<=) "%1 <= %2" prec 6 6 5
syntax val (<) "%1 < %2" prec 6 syntax val (<) "%1 < %2" prec 6 6 5
syntax val (>=) "%1 >= %2" prec 6 syntax val (>=) "%1 >= %2" prec 6 6 5
syntax val (>) "%1 > %2" prec 6 syntax val (>) "%1 > %2" prec 6 6 5
syntax val add_with_carry "add64_with_carry" syntax val add_with_carry "add64_with_carry"
syntax val add_double "add64_double" syntax val add_double "add64_double"
...@@ -536,20 +536,20 @@ static struct __lsld64_result lsld64(uint64_t x, uint64_t cnt) ...@@ -536,20 +536,20 @@ static struct __lsld64_result lsld64(uint64_t x, uint64_t cnt)
syntax val add3 "add64_3" syntax val add3 "add64_3"
syntax val lsld "lsld64" syntax val lsld "lsld64"
syntax val add_mod "%1 + %2" prec 4 syntax val add_mod "%1 + %2" prec 4 4 3
syntax val sub_mod "%1 - %2" prec 4 syntax val sub_mod "%1 - %2" prec 4 4 3
syntax val mul_mod "%1 * %2" prec 3 syntax val mul_mod "%1 * %2" prec 3 3 2
syntax val lsl "%1 << %2" prec 5 syntax val lsl "%1 << %2" prec 5 5 4
syntax val lsr "%1 >> %2" prec 5 syntax val lsr "%1 >> %2" prec 5 5 4
syntax val is_msb_set "%1 & 0x8000000000000000ULL" prec 8 syntax val is_msb_set "%1 & 0x8000000000000000ULL" prec 8 7
syntax val count_leading_zeros "__builtin_clzll(%1)" prec 1 syntax val count_leading_zeros "__builtin_clzll(%1)" prec 1 15
syntax val of_int32 "(uint64_t)(%1)" prec 2 syntax val of_int32 "(uint64_t)%1" prec 2 2
syntax val to_int64 "(int64_t)(%1)" prec 2 syntax val to_int64 "(int64_t)%1" prec 2 2
syntax val of_int64 "(uint64_t)(%1)" prec 2 syntax val of_int64 "(uint64_t)%1" prec 2 2
end end
...@@ -568,34 +568,34 @@ module mach.c.C ...@@ -568,34 +568,34 @@ module mach.c.C
syntax type ptr "%1 *" syntax type ptr "%1 *"
syntax type bool "int" (* ? *) syntax type bool "int" (* ? *)
syntax val malloc "malloc((%1) * sizeof(%v0))" prec 1 syntax val malloc "malloc(%1 * sizeof(%v0))" prec 1 3
syntax val free "free(%1)" prec 1 syntax val free "free(%1)" prec 1 15
syntax val realloc "realloc(%1, (%2) * sizeof(%v0))" prec 1 syntax val realloc "realloc(%1, %2 * sizeof(%v0))" prec 1 15 3
syntax val salloc "alloca((%1) * sizeof(%v0))" prec 1 syntax val salloc "alloca(%1 * sizeof(%v0))" prec 1 3
syntax val sfree "(void)(%1)" prec 2 syntax val sfree "(void)%1" prec 2 2
(* syntax val is_null "(%1) == NULL" *) (* syntax val is_null "(%1) == NULL" *)
syntax val is_not_null "%1" prec 0 syntax val is_not_null "%1" prec 0
syntax val null "NULL" prec 0 syntax val null "NULL" prec 0
syntax val incr "%1 + %2" prec 4 syntax val incr "%1 + %2" prec 4 4 3
syntax val get "*%1" prec 2 syntax val get "*%1" prec 2 2
syntax val get_ofs "%1[%2]" prec 1 syntax val get_ofs "%1[%2]" prec 1 1 15
syntax val set "*(%1) = %2" prec 14 syntax val set "*%1 = %2" prec 14 2 14
syntax val set_ofs "%1[%2] = %3" prec 14 syntax val set_ofs "%1[%2] = %3" prec 14 14 15 14
syntax val incr_split "%1 + %2" prec 4 syntax val incr_split "%1 + %2" prec 4 4 3
syntax val decr_split "%1 - %2" prec 4 syntax val decr_split "%1 - %2" prec 4 4 3
syntax val join "IGNORE2" syntax val join "IGNORE2"
syntax val join_r "IGNORE2" syntax val join_r "IGNORE2"
syntax val c_assert "assert ( %1 )" prec 1 syntax val c_assert "assert (%1)" prec 1 15
syntax val print_space "printf(\" \")" prec 1 syntax val print_space "printf(\" \")" prec 1
syntax val print_newline "printf(\"\\n\")" prec 1 syntax val print_newline "printf(\"\\n\")" prec 1
syntax val print_uint32 "printf(\"%#010x\",%1)" prec 1 syntax val print_uint32 "printf(\"%#010x\",%1)" prec 1 15
end end
...@@ -222,13 +222,22 @@ let check_syntax_literal _ts s = ...@@ -222,13 +222,22 @@ let check_syntax_literal _ts s =
(* if !count <> 1 then *) (* if !count <> 1 then *)
(* raise (BadSyntaxArity (1,!count)) *) (* raise (BadSyntaxArity (1,!count)) *)
let syntax_arguments s print fmt l = let syntax_arguments_prec s print pl fmt l =
let args = Array.of_list l in let args = Array.of_list l in
let precs = Array.of_list pl in
let lp = Array.length precs in
let repl_fun s b e fmt = let repl_fun s b e fmt =
let i = int_of_string (String.sub s b (e-b)) in let i = int_of_string (String.sub s b (e-b)) in
print fmt args.(i-1) in let p =
if i < lp then precs.(i)
else if lp = 0 then 0
else precs.(0) - 1 in
print p fmt args.(i-1) in
global_substitute_fmt opt_search_forward repl_fun s fmt global_substitute_fmt opt_search_forward repl_fun s fmt
let syntax_arguments s print fmt l =
syntax_arguments_prec s (fun _ f a -> print f a) [] fmt l
(* return the type arguments of a symbol application, sorted according (* return the type arguments of a symbol application, sorted according
to their (formal) names *) to their (formal) names *)
let get_type_arguments t = match t.t_node with let get_type_arguments t = match t.t_node with
...@@ -242,8 +251,11 @@ let get_type_arguments t = match t.t_node with ...@@ -242,8 +251,11 @@ let get_type_arguments t = match t.t_node with
| _ -> | _ ->
[||] [||]
let gen_syntax_arguments_typed ty_of tys_of s print_arg print_type t fmt l = let gen_syntax_arguments_typed_prec
ty_of tys_of s print_arg print_type t pl fmt l =
let args = Array.of_list l in let args = Array.of_list l in
let precs = Array.of_list pl in
let lp = Array.length precs in
let repl_fun s b e fmt = let repl_fun s b e fmt =
if s.[b] = 't' then if s.[b] = 't' then
let grp = String.sub s (b+1) (e-b-1) in let grp = String.sub s (b+1) (e-b-1) in
...@@ -258,11 +270,18 @@ let gen_syntax_arguments_typed ty_of tys_of s print_arg print_type t fmt l = ...@@ -258,11 +270,18 @@ let gen_syntax_arguments_typed ty_of tys_of s print_arg print_type t fmt l =
else else
let grp = String.sub s b (e-b) in let grp = String.sub s b (e-b) in
let i = int_of_string grp in let i = int_of_string grp in
print_arg fmt args.(i-1) in let p =
if i < lp then precs.(i)
else if lp = 0 then 0
else precs.(0) - 1 in
print_arg p fmt args.(i-1) in
global_substitute_fmt opt_search_forward repl_fun s fmt global_substitute_fmt opt_search_forward repl_fun s fmt
let syntax_arguments_typed = let syntax_arguments_typed_prec =
gen_syntax_arguments_typed t_type get_type_arguments gen_syntax_arguments_typed_prec t_type get_type_arguments
let syntax_arguments_typed s print_arg print_type t fmt l =
syntax_arguments_typed_prec s (fun _ f a -> print_arg f a) print_type t [] fmt l
let syntax_range_literal s fmt c = let syntax_range_literal s fmt c =
let f s b e fmt = let f s b e fmt =
......
...@@ -103,17 +103,25 @@ val add_rliteral_map : tdecl -> syntax_map -> syntax_map ...@@ -103,17 +103,25 @@ val add_rliteral_map : tdecl -> syntax_map -> syntax_map
val query_syntax : syntax_map -> ident -> string option val query_syntax : syntax_map -> ident -> string option
val syntax_arguments_prec : string -> (int -> 'a Pp.pp) -> int list -> 'a list Pp.pp
(** (syntax_arguments_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 *)
val syntax_arguments : string -> 'a Pp.pp -> 'a list Pp.pp val syntax_arguments : string -> 'a Pp.pp -> 'a list Pp.pp
(** (syntax_arguments templ print_arg fmt l) prints in the formatter fmt
the list l using the template templ and the printer print_arg *)
val gen_syntax_arguments_typed : val gen_syntax_arguments_typed_prec :
('a -> 'b) -> ('a -> 'b array) -> string -> 'a Pp.pp -> 'b Pp.pp -> 'a -> 'a list Pp.pp ('a -> 'b) -> ('a -> 'b array) -> string -> (int -> 'a Pp.pp)
-> 'b Pp.pp -> 'a -> int list -> 'a list Pp.pp
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
formatter fmt the list l using the template templ, the printer print_arg
and the precedence list prec_list *)
val syntax_arguments_typed : val syntax_arguments_typed :
string -> term Pp.pp -> ty Pp.pp -> term -> term list Pp.pp string -> term Pp.pp -> ty Pp.pp -> term -> term list Pp.pp
(** (syntax_arguments templ print_arg fmt l) prints in the formatter fmt
the list l using the template templ and the printer print_arg *)
val syntax_range_literal : val syntax_range_literal :
string -> Number.int_constant Pp.pp string -> Number.int_constant Pp.pp
......
...@@ -42,13 +42,11 @@ type theory_rules = { ...@@ -42,13 +42,11 @@ type theory_rules = {
thr_rules : (loc * th_rule) list; thr_rules : (loc * th_rule) list;
} }
type assoc_dir = Left | Right
type mo_rule = type mo_rule =
| MRtheory of th_rule | MRtheory of th_rule
| MRinterface of string | MRinterface of string
| MRexception of qualid * string | MRexception of qualid * string
| MRval of qualid * string * int option * assoc_dir option | MRval of qualid * string * int list
type module_rules = { type module_rules = {
mor_name : qualid; mor_name : qualid;
......
...@@ -47,9 +47,6 @@ ...@@ -47,9 +47,6 @@
"plugin", PLUGIN; "plugin", PLUGIN;
"blacklist", BLACKLIST; "blacklist", BLACKLIST;
"prec", PREC; "prec", PREC;
"assoc", ASSOC;
"left", LEFT;
"right", RIGHT;
(* WhyML *) (* WhyML *)
"module", MODULE; "module", MODULE;
"exception", EXCEPTION; "exception", EXCEPTION;
......
...@@ -30,7 +30,7 @@ ...@@ -30,7 +30,7 @@
%token FUNCTION PREDICATE TYPE PROP ALL FILENAME TRANSFORM PLUGIN %token FUNCTION PREDICATE TYPE PROP ALL FILENAME TRANSFORM PLUGIN
%token COMMA CONSTANT %token COMMA CONSTANT
%token LEFTSQ RIGHTSQ LARROW %token LEFTSQ RIGHTSQ LARROW
%token PREC ASSOC LEFT RIGHT %token PREC
%nonassoc SYNTAX REMOVE PRELUDE INTERFACE %nonassoc SYNTAX REMOVE PRELUDE INTERFACE
%nonassoc prec_pty %nonassoc prec_pty
...@@ -211,14 +211,11 @@ mrule: ...@@ -211,14 +211,11 @@ mrule:
| trule { MRtheory $1 } | trule { MRtheory $1 }
| INTERFACE STRING { MRinterface ($2) } | INTERFACE STRING { MRinterface ($2) }
| SYNTAX EXCEPTION qualid STRING { MRexception ($3, $4) } | SYNTAX EXCEPTION qualid STRING { MRexception ($3, $4) }
| SYNTAX VAL qualid STRING precedence? associativity? | SYNTAX VAL qualid STRING { MRval ($3, $4, []) }
{ MRval ($3, $4, $5, $6) } | SYNTAX VAL qualid STRING precedence
{ MRval ($3, $4, $5) }
precedence: precedence:
| PREC INTEGER { $2 } | PREC list(INTEGER) { $2 }
associativity:
| ASSOC LEFT { Left }
| ASSOC RIGHT { Right }
loc(X): X { Loc.extract ($startpos,$endpos), $1 } loc(X): X { Loc.extract ($startpos,$endpos), $1 }
...@@ -59,7 +59,7 @@ module C = struct ...@@ -59,7 +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 *)
| Esyntax of string * ty * (ty array) * (expr*ty) list * int option | 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 *)
and constant = and constant =
...@@ -431,6 +431,14 @@ module C = struct ...@@ -431,6 +431,14 @@ module C = struct
| Tsyntax (_, lty) -> List.exists should_not_escape lty | Tsyntax (_, lty) -> List.exists should_not_escape lty
| _ -> false | _ -> false
let left_assoc = function
| Band | Bor | Beq | Bne | Blt | Ble | Bgt | Bge -> true
| Bassign -> false
let right_assoc = function
| Bassign -> true
| _ -> false
end end
type info = { type info = {
...@@ -442,8 +450,7 @@ type info = { ...@@ -442,8 +450,7 @@ type info = {
syntax : Printer.syntax_map; syntax : Printer.syntax_map;
literal : Printer.syntax_map; (*TODO handle literals*) literal : Printer.syntax_map; (*TODO handle literals*)
kn : Pdecl.known_map; kn : Pdecl.known_map;
prec : (int option) Mid.t; prec : (int list) Mid.t;
assoc : (Driver_ast.assoc_dir option) Mid.t;
} }
let debug_c_extraction = Debug.register_info_flag let debug_c_extraction = Debug.register_info_flag
...@@ -490,9 +497,7 @@ module Print = struct ...@@ -490,9 +497,7 @@ module Print = struct
let rec print_ty ?(paren=false) fmt = function let rec print_ty ?(paren=false) fmt = function
| Tvoid -> fprintf fmt "void" | Tvoid -> fprintf fmt "void"
| Tsyntax (s, tl) -> | Tsyntax (s, tl) ->
syntax_arguments syntax_arguments s (print_ty ~paren:false) fmt tl
s
(print_ty ~paren:false) fmt tl
| Tptr ty -> fprintf fmt "%a *" (print_ty ~paren:true) ty | Tptr ty -> fprintf fmt "%a *" (print_ty ~paren:true) ty
(* should be handled in extract_stars *) (* should be handled in extract_stars *)
| Tarray (ty, Enothing) -> | Tarray (ty, Enothing) ->
...@@ -535,44 +540,46 @@ module Print = struct ...@@ -535,44 +540,46 @@ module Print = struct
| Eunop(u,e) -> | Eunop(u,e) ->
let p = prec_unop u in let p = prec_unop u in
if unop_postfix u if unop_postfix u
then fprintf fmt (protect_on (prec <= p) "%a%a") then fprintf fmt (protect_on (prec < p) "%a%a")
(print_expr ~prec:p) e print_unop u (print_expr ~prec:(p-1)) e print_unop u
else fprintf fmt (protect_on (prec <= p) "%a%a") else fprintf fmt (protect_on (prec < p) "%a%a")
print_unop u (print_expr ~prec:p) e print_unop u (print_expr ~prec:(p-1)) e
| Ebinop(b,e1,e2) -> | Ebinop(b,e1,e2) ->
let p = prec_binop b in let p = prec_binop b in
fprintf fmt (protect_on (prec <= p) "%a %a %a") let pleft = if left_assoc b then p else p-1 in
(print_expr ~prec:p) e1 print_binop b (print_expr ~prec:p) e2 let pright = if right_assoc b then p else p-1 in
fprintf fmt (protect_on (prec < p) "%a %a %a")
(print_expr ~prec:pleft) e1 print_binop b (print_expr ~prec:pright) e2
| Equestion(c,t,e) -> | Equestion(c,t,e) ->
fprintf fmt (protect_on (prec <= 13) "%a ? %a : %a") fprintf fmt (protect_on (prec < 13) "%a ? %a : %a")
(print_expr ~prec:13) c (print_expr ~prec:12) c
(print_expr ~prec:13) t (print_expr ~prec:15) t
(print_expr ~prec:13) e (print_expr ~prec:13) e
| 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) -> | Ecall (Esyntax (s, _, _, [],_), l) ->
(* function defined in the prelude *) (* 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) ->
fprintf fmt (protect_on (prec <= 1) "%a(%a)") fprintf fmt (protect_on (prec < 1) "%a(%a)")
(print_expr ~prec:1) e (print_list comma (print_expr ~prec:15)) l (print_expr ~prec:1) e (print_list comma (print_expr ~prec:15)) l
| Econst c -> print_const fmt c | Econst c -> print_const fmt c
| Evar id -> print_local_ident fmt id | Evar id -> print_local_ident fmt id
| Elikely e -> fprintf fmt | Elikely e -> fprintf fmt
(protect_on (prec <= 1) "__builtin_expect(%a,1)") (protect_on (prec < 1) "__builtin_expect(%a,1)")
(print_expr ~prec:15) e (print_expr ~prec:15) e
| Eunlikely e -> fprintf fmt | Eunlikely e -> fprintf fmt
(protect_on (prec <= 1) "__builtin_expect(%a,0)") (protect_on (prec < 1) "__builtin_expect(%a,0)")
(print_expr ~prec:15) e (print_expr ~prec:15) e
| Esize_expr e -> | Esize_expr e ->
fprintf fmt (protect_on (prec <= 2) "sizeof(%a)") (print_expr ~prec:15) e fprintf fmt (protect_on (prec < 2) "sizeof(%a)") (print_expr ~prec:15) e
| Esize_type ty -> | Esize_type ty ->
fprintf fmt (protect_on (prec <= 2) "sizeof(%a)") fprintf fmt (protect_on (prec < 2) "sizeof(%a)")
(print_ty ~paren:false) ty (print_ty ~paren:false) ty
| Edot (e,s) -> | Edot (e,s) ->
fprintf fmt (protect_on (prec <= 1) "%a.%s") fprintf fmt (protect_on (prec < 1) "%a.%s")
(print_expr ~prec:1) e s (print_expr ~prec:1) e s
| Eindex (e1, e2) -> | Eindex (e1, e2) ->
fprintf fmt (protect_on (prec <= 1) "%a[%a]") fprintf fmt (protect_on (prec <= 1) "%a[%a]")
...@@ -581,17 +588,20 @@ module Print = struct ...@@ -581,17 +588,20 @@ module Print = struct
| Earrow (e,s) -> | Earrow (e,s) ->
fprintf fmt (protect_on (prec <= 1) "%a->%s") fprintf fmt (protect_on (prec <= 1) "%a->%s")
(print_expr ~prec:1) e s (print_expr ~prec:1) e s
| Esyntax (s, t, args, lte, p) -> | Esyntax (s, t, args, lte, pl) ->
if s = "%1" (*identity*) if s = "%1" (*identity*)
then begin then begin
assert (List.length lte = 1); assert (List.length lte = 1);
print_expr ~prec fmt (fst (List.hd lte)) end print_expr ~prec fmt (fst (List.hd lte)) end
else else
let p = match p with Some n -> n | None -> 15 in let s =
gen_syntax_arguments_typed snd (fun _ -> args) if pl = [] || prec < List.hd pl
(if prec <= p then ("("^s^")") else s) then Format.sprintf "(%s)" s
(fun fmt (e,_t) -> print_expr ~prec:p fmt e) else s in
(print_ty ~paren:false) (C.Enothing,t) fmt lte gen_syntax_arguments_typed_prec snd (fun _ -> args)
s
(fun p fmt (e,_t) -> print_expr ~prec:p fmt e)
(print_ty ~paren:false) (C.Enothing,t) pl fmt lte
and print_const fmt = function and print_const fmt = function
| Cint s | Cfloat s | Cchar s | Cstring s -> fprintf fmt "%s" s | Cint s | Cfloat s | Cchar s | Cstring s -> fprintf fmt "%s" s
...@@ -995,11 +1005,11 @@ module MLToC = struct ...@@ -995,11 +1005,11 @@ module MLToC = struct
C.Esyntax(s,ty_of_ty info rty, rtyargs, params, p) C.Esyntax(s,ty_of_ty info rty, rtyargs, params, p)
with Not_found -> with Not_found ->
if args=[] if args=[]
then C.(Esyntax(s, Tnosyntax, [||], [], None)) (*constant*) then C.(Esyntax(s, Tnosyntax, [||], [], [])) (*constant*)
else else
(*function defined in the prelude *) (*function defined in the prelude *)
let cargs = List.map fst params in let cargs = List.map fst params in
C.(Ecall(Esyntax(s, Tnosyntax, [||], [], None), cargs)) C.(Ecall(Esyntax(s, Tnosyntax, [||], [], []), cargs))
end end
| None -> | None ->
match rs.rs_field with match rs.rs_field with
...@@ -1399,7 +1409,6 @@ let mk_info (args:Pdriver.printer_args) m = { ...@@ -1399,7 +1409,6 @@ let mk_info (args:Pdriver.printer_args) m = {
syntax = args.Pdriver.syntax; syntax = args.Pdriver.syntax;
literal = args.Pdriver.literal; literal = args.Pdriver.literal;
prec = args.Pdriver.prec; prec = args.Pdriver.prec;
assoc = args.Pdriver.assoc;
kn = m.Pmodule.mod_known } kn = m.Pmodule.mod_known }
let</