(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the GNU General Public License as published by  *)
(*  the Free Software Foundation, either version 2 of the License, or  *)
(*  (at your option) any later version.  This file is also distributed *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)
(** Typing rules and type-checking for the Compcert C language *)
Local Open Scope error_monad_scope.
Definition strict := false.
Opaque strict.
Definition size_t : type :=
if Archi.ptr64 then Tlong Unsigned noattr else Tint I32 Unsigned noattr.
Definition ptrdiff_t : type :=
if Archi.ptr64 then Tlong Signed noattr else Tint I32 Signed noattr.
(** * Operations over types *)
(** The type of a member of a composite (struct or union). The "volatile" attribute carried by the composite propagates to the type of the member, but not the "alignas" attribute. *)
Definition attr_add_volatile (vol: bool) (a: attr) :=
{| attr_volatile := a.(attr_volatile) || vol;
attr_alignas  := a.(attr_alignas) |}.
Definition type_of_member (a: attr) (f: ident) (m: members) : res type :=
do ty <- field_type f m;
OK (change_attributes (attr_add_volatile a.(attr_volatile)) ty).
(** Type-checking of arithmetic and logical operators *)
Definition type_unop (op: unary_operation) (ty: type) : res type :=
match op with
| Onotbool =>
match classify_bool ty with
| bool_default => Error (msg "operator !")
| _ => OK (Tint I32 Signed noattr)
end
| Onotint =>
match classify_notint ty with
| notint_case_i sg => OK (Tint I32 sg noattr)
| notint_case_l sg => OK (Tlong sg noattr)
| notint_default   => Error (msg "operator ~")
end
| Oneg =>
match classify_neg ty with
| neg_case_i sg => OK (Tint I32 sg noattr)
| neg_case_f => OK (Tfloat F64 noattr)
| neg_case_s => OK (Tfloat F32 noattr)
| neg_case_l sg => OK (Tlong sg noattr)
| neg_default   => Error (msg "operator prefix -")
end
| Oabsfloat =>
match classify_neg ty with
| neg_default   => Error (msg "operator __builtin_fabs")
| _             => OK (Tfloat F64 noattr)
end
end.
Definition binarith_type (ty1 ty2: type) (m: string): res type :=
match classify_binarith ty1 ty2 with
| bin_case_i sg => OK (Tint I32 sg noattr)
| bin_case_l sg => OK (Tlong sg noattr)
| bin_case_f => OK (Tfloat F64 noattr)
| bin_case_s => OK (Tfloat F32 noattr)
| bin_default   => Error (msg m)
end.
Definition binarith_int_type (ty1 ty2: type) (m: string): res type :=
match classify_binarith ty1 ty2 with
| bin_case_i sg => OK (Tint I32 sg noattr)
| bin_case_l sg => OK (Tlong sg noattr)
| _ => Error (msg m)
end.
Definition shift_op_type (ty1 ty2: type) (m: string): res type :=
match classify_shift ty1 ty2 with
| shift_case_ii sg | shift_case_il sg => OK (Tint I32 sg noattr)
| shift_case_li sg | shift_case_ll sg => OK (Tlong sg noattr)
| shift_default => Error (msg m)
end.
Definition comparison_type (ty1 ty2: type) (m: string): res type :=
match classify_cmp ty1 ty2 with
| cmp_default =>
match classify_binarith ty1 ty2 with
| bin_default => Error (msg m)
| _ => OK (Tint I32 Signed noattr)
end
| _ => OK (Tint I32 Signed noattr)
end.
Definition type_binop (op: binary_operation) (ty1 ty2: type) : res type :=
match op with
| Oadd =>
match classify_add ty1 ty2 with
| add_case_pi ty _ | add_case_ip _ ty
| add_case_pl ty   | add_case_lp ty => OK (Tpointer ty noattr)
| add_default => binarith_type ty1 ty2 "operator +"
end
| Osub =>
match classify_sub ty1 ty2 with
| sub_case_pi ty _ | sub_case_pl ty => OK (Tpointer ty noattr)
| sub_case_pp ty => OK ptrdiff_t
| sub_default => binarith_type ty1 ty2 "operator infix -"
end
| Omul => binarith_type ty1 ty2 "operator infix *"
| Odiv => binarith_type ty1 ty2 "operator /"
| Omod => binarith_int_type ty1 ty2 "operator %"
| Oand => binarith_int_type ty1 ty2 "operator &"
| Oor => binarith_int_type ty1 ty2 "operator |"
| Oxor => binarith_int_type ty1 ty2 "operator ^"
| Oshl => shift_op_type ty1 ty2 "operator <<"
| Oshr => shift_op_type ty1 ty2 "operator >>"
| Oeq => comparison_type ty1 ty2 "operator =="
| One => comparison_type ty1 ty2 "operator !="
| Olt => comparison_type ty1 ty2 "operator <"
| Ogt => comparison_type ty1 ty2 "operator >"
| Ole => comparison_type ty1 ty2 "operator <="
| Oge => comparison_type ty1 ty2 "operator >="
end.
Definition type_deref (ty: type) : res type :=
match ty with
| Tpointer tyelt _ => OK tyelt
| Tarray tyelt _ _ => OK tyelt
| Tfunction _ _ _ => OK ty
| _ => Error (msg "operator prefix *")
end.
(** Inferring the type of a conditional expression: the merge of the types of the two arms. *)
Definition attr_combine (a1 a2: attr) : attr :=
{| attr_volatile := a1.(attr_volatile) || a2.(attr_volatile);
attr_alignas :=
match a1.(attr_alignas), a2.(attr_alignas) with
| None, al2 => al2
| al1, None => al1
| Some n1, Some n2 => Some (N.max n1 n2)
end
|}.
Definition intsize_eq: forall (x y: intsize), {x=y} + {x<>y}.
Hint Resolve check_cast_sound check_bool_sound: ty.

Lemma binarith_type_cast:
forall t1 t2 m t,
binarith_type t1 t2 m = OK t -> wt_cast t1 t /\ wt_cast t2 t.