Commit 09de883e authored by Raphaël Rieu-Helft's avatar Raphaël Rieu-Helft

Merge branch 'c_literals' into 'master'

Use syntax literal driver entries for C number constants

See merge request !107
parents b5ff7fcf a9d3d6c7
......@@ -23,7 +23,7 @@ end
module mach.int.Int32
syntax type int32 "int32_t"
syntax literal int32 "%d"
syntax literal int32 "%c"
syntax val (+) "%1 + %2" prec 4 4 3
syntax val (-) "%1 - %2" prec 4 4 3
......@@ -49,7 +49,7 @@ end
module mach.int.UInt32
syntax literal uint32 "0x%8xU"
syntax literal uint32 "%cU"
syntax val (+) "%1 + %2" prec 4 4 3
syntax val (-) "%1 - %2" prec 4 4 3
......@@ -181,7 +181,7 @@ struct __lsld32_result
struct __lsld32_result lsld32(uint32_t x, uint32_t cnt);
"
syntax literal uint32 "0x%8xU"
syntax literal uint32 "%cU"
syntax val (+) "%1 + %2" prec 4 4 3
syntax val (-) "%1 - %2" prec 4 4 3
......@@ -223,7 +223,7 @@ end
module mach.int.Int64
syntax type int64 "int64_t"
syntax literal int64 "%dL"
syntax literal int64 "INT64_C(%c)"
syntax val (+) "%1 + %2" prec 4 4 3
syntax val (-) "%1 - %2" prec 4 4 3
......@@ -250,7 +250,7 @@ end
module mach.int.UInt64
syntax literal uint64 "0x%16xUL"
syntax literal uint64 "UINT64_C(%c)"
syntax val (+) "%1 + %2" prec 4 4 3
syntax val (-) "%1 - %2" prec 4 4 3
......@@ -505,7 +505,7 @@ static struct __lsld64_result lsld64(uint64_t x, uint64_t cnt)
return result;
}
"
syntax literal uint64 "0x%16xUL"
syntax literal uint64 "UINT64_C(%c)"
syntax val uint64_max "0xffffffffffffffffUL" prec 0
......
......@@ -137,7 +137,7 @@ let opt_search_forward_literal_format s pos =
end;
while !i < l && is_digit s.[!i] do incr i done;
begin match s.[!i] with
| 'b' | 'x' | 'o' | 'd' -> incr i; raise Exit
| 'b' | 'x' | 'o' | 'd' | 'c' -> incr i; raise Exit
| _ -> ()
end;
end;
......@@ -283,36 +283,42 @@ let syntax_arguments_typed_prec =
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 ?(cb=None) s fmt c =
let f s b e fmt =
let v = c.Number.il_int in
let base = match s.[e-1] with
| 'x' -> 16
| 'd' -> 10
| 'o' -> 8
| 'b' -> 2
| _ -> assert false
in
let digits =
if e > b + 1 then
Some (int_of_string (String.sub s b (e-b-1)))
else
None
in
if base = 10 then begin
if BigInt.lt v BigInt.zero then fprintf fmt "-";
Number.print_in_base base digits fmt (BigInt.abs v)
end
else
let v =
if BigInt.lt v BigInt.zero then
match digits with
| Some d ->
BigInt.add (BigInt.pow_int_pos base d) v
| None -> failwith ("number of digits must be given for printing negative literals in base " ^ string_of_int base)
else v
try
let v = c.Number.il_int in
let base = match s.[e-1] with
| 'x' -> 16
| 'd' -> 10
| 'o' -> 8
| 'b' -> 2
| 'c' -> raise Exit
| _ -> assert false
in
let digits =
if e > b + 1 then
Some (int_of_string (String.sub s b (e-b-1)))
else
None
in
Number.print_in_base base digits fmt v
if base = 10 then begin
if BigInt.lt v BigInt.zero then fprintf fmt "-";
Number.print_in_base base digits fmt (BigInt.abs v)
end
else
let v =
if BigInt.lt v BigInt.zero then
match digits with
| Some d ->
BigInt.add (BigInt.pow_int_pos base d) v
| None -> failwith ("number of digits must be given for printing negative literals in base " ^ string_of_int base)
else v
in
Number.print_in_base base digits fmt v
with Exit ->
match cb with
| Some cb -> cb fmt c
| None -> failwith ("custom format string with no callback passed")
in
global_substitute_fmt opt_search_forward_literal_format f s fmt
......
......@@ -124,7 +124,7 @@ val syntax_arguments_typed :
string -> term Pp.pp -> ty Pp.pp -> term -> term list Pp.pp
val syntax_range_literal :
string -> Number.int_constant Pp.pp
?cb:(Number.int_constant Pp.pp option) -> string -> Number.int_constant Pp.pp
val syntax_float_literal :
string -> Number.float_format -> Number.real_constant Pp.pp
......
......@@ -924,30 +924,33 @@ module MLToC = struct
let e = C.Evar id in
([], expr_or_return env e)
| Mltree.Econst ic ->
let open Number in
let open Number in
let print fmt ic =
let n = ic.il_int in
let n =
if BigInt.lt n BigInt.zero then BigInt.to_string n
else
match ic.il_kind with
| ILitHex -> Format.asprintf "0x%a" (print_in_base 16 None) n
| ILitOct -> Format.asprintf "0%a" (print_in_base 8 None) n
| _ -> BigInt.to_string n in
let suf =
match e.e_ity with
| I i ->
begin match (ty_of_ity i).ty_node with
| Tyapp ({ts_def = Range { ir_lower = l; ir_upper = h }},_) ->
let open BigInt in
let unsigned = eq l zero in
if (le min32 l) && (le h max32) then ""
else if unsigned && (le h maxu32) then "u"
else if (le min64 l) && (le h max64) then "l"
else if unsigned && (le h maxu64) then "ul"
else raise (Unsupported "unknown number format")
| _ -> raise (Unsupported "non-range integer constant") end
| _ -> assert false in
let e = C.(Econst (Cint (n^suf))) in
if BigInt.lt n BigInt.zero
then
(* default to base 10 for negative literals *)
Format.fprintf fmt "-%a" (print_in_base 10 None) (BigInt.abs n)
else
match ic.il_kind with
| ILitHex | ILitBin -> Format.fprintf fmt "0x%a" (print_in_base 16 None) n
| ILitOct -> Format.fprintf fmt "0%a" (print_in_base 8 None) n
| ILitDec | ILitUnk ->
(* default to base 10 *)
Format.fprintf fmt "%a" (print_in_base 10 None) n in
let s = match e.e_ity with
| I i ->
let ts = match (ty_of_ity i) with
| { ty_node = Tyapp (ts, []) } -> ts
| _ -> assert false in
begin match query_syntax info.literal ts.ts_name with
| Some st ->
Format.asprintf "%a" (syntax_range_literal ~cb:(Some print) st) ic
| _ ->
let s = ts.ts_name.id_string in
raise (Unsupported ("unspecified number format for type "^s)) end
| _ -> assert false in
let e = C.(Econst (Cint s)) in
([], expr_or_return env e)
| Eapp (rs, el)
when is_struct_constructor info rs
......
......@@ -188,7 +188,7 @@ let print_in_base radix digits fmt i =
let d,m = BigInt.euclidean_div_mod i radix in
aux (digits - 1) d;
Format.pp_print_char fmt (char_of_int (BigInt.to_int m)) in
aux (Opt.get_def 0 digits) i
aux (Opt.get_def 1 digits) i
let to_small_integer i =
BigInt.to_int i.il_int
......
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