+2014-08-04 Robert Dewar <dewar@adacore.com>
+
+ * exp_attr.adb (Expand_N_Attribute_Reference, case Pred):
+ Remove special test for Float'First, no longer required.
+ (Expand_N_Attribute_Reference, case Succ): Remove special test
+ for Float'First, no longer required.
+ * s-fatgen.adb (Pred): return infinity unchanged.
+ (Succ): ditto.
+
+2014-08-04 Claire Dross <dross@adacore.com>
+
+ * sem_ch12.adb (Analyze_Associations): Defaults should only be
+ used if there is no explicit match.
+ * exp_util.adb (Get_First_Parent_With_Ext_Axioms_For_Entity):
+ Also check for pragma external_axiomatization on generic units.
+
2014-08-04 Robert Dewar <dewar@adacore.com>
* checks.adb (Activate_Overflow_Check): Remove
-- Pred --
----------
- -- 1. Deal with enumeration types with holes
- -- 2. For floating-point, generate call to attribute function and deal
- -- with range checking if Check_Float_Overflow mode is set.
- -- 3. For other cases, deal with constraint checking
+ -- 1. Deal with enumeration types with holes.
+ -- 2. For floating-point, generate call to attribute function.
+ -- 3. For other cases, deal with constraint checking.
when Attribute_Pred => Pred :
declare
-- For floating-point, we transform 'Pred into a call to the Pred
-- floating-point attribute function in Fat_xxx (xxx is root type).
+ -- Note that this function takes care of the overflow case.
elsif Is_Floating_Point_Type (Ptyp) then
-
- -- Handle case of range check. The Do_Range_Check flag is set only
- -- in Check_Float_Overflow mode, and what we need is a specific
- -- check against typ'First, since that is the only overflow case.
-
- declare
- Expr : constant Node_Id := First (Exprs);
- begin
- if Do_Range_Check (Expr) then
- Set_Do_Range_Check (Expr, False);
- Insert_Action (N,
- Make_Raise_Constraint_Error (Loc,
- Condition =>
- Make_Op_Eq (Loc,
- Left_Opnd => Duplicate_Subexpr (Expr),
- Right_Opnd =>
- Make_Attribute_Reference (Loc,
- Attribute_Name => Name_First,
- Prefix =>
- New_Occurrence_Of (Base_Type (Ptyp), Loc))),
- Reason => CE_Overflow_Check_Failed),
- Suppress => All_Checks);
- end if;
- end;
-
- -- Transform into call to attribute function
-
Expand_Fpt_Attribute_R (N);
Analyze_And_Resolve (N, Typ);
-- Succ --
----------
- -- 1. Deal with enumeration types with holes
- -- 2. For floating-point, generate call to attribute function
- -- 3. For other cases, deal with constraint checking
+ -- 1. Deal with enumeration types with holes.
+ -- 2. For floating-point, generate call to attribute function.
+ -- 3. For other cases, deal with constraint checking.
when Attribute_Succ => Succ : declare
Etyp : constant Entity_Id := Base_Type (Ptyp);
-- floating-point attribute function in Fat_xxx (xxx is root type)
elsif Is_Floating_Point_Type (Ptyp) then
-
- -- Handle case of range check. The Do_Range_Check flag is set only
- -- in Check_Float_Overflow mode, and what we need is a specific
- -- check against typ'Last, since that is the only overflow case.
-
- declare
- Expr : constant Node_Id := First (Exprs);
- begin
- if Do_Range_Check (Expr) then
- Set_Do_Range_Check (Expr, False);
- Insert_Action (N,
- Make_Raise_Constraint_Error (Loc,
- Condition =>
- Make_Op_Eq (Loc,
- Left_Opnd => Duplicate_Subexpr (Expr),
- Right_Opnd =>
- Make_Attribute_Reference (Loc,
- Attribute_Name => Name_Last,
- Prefix =>
- New_Occurrence_Of (Base_Type (Ptyp), Loc))),
- Reason => CE_Overflow_Check_Failed),
- Suppress => All_Checks);
- end if;
- end;
-
- -- Transform into call to attribute function
-
Expand_Fpt_Attribute_R (N);
Analyze_And_Resolve (N, Typ);
-------------------------------------------------
function Get_First_Parent_With_Ext_Axioms_For_Entity
- (E : Entity_Id) return Entity_Id is
-
+ (E : Entity_Id) return Entity_Id
+ is
Decl : Node_Id;
begin
end if;
end if;
- -- E is the package which is externally axiomatized
+ -- E is the package or generic package which is externally axiomatized
- if Ekind (E) = E_Package
+ if Ekind_In (E, E_Package, E_Generic_Package)
and then Has_Annotate_Pragma_For_External_Axiomatization (E)
then
return E;
elsif Ekind (E) = E_Package
and then Present (Generic_Parent (Decl))
then
- return Get_First_Parent_With_Ext_Axioms_For_Entity
- (Generic_Parent (Decl));
+ return
+ Get_First_Parent_With_Ext_Axioms_For_Entity (Generic_Parent (Decl));
-- Otherwise, look at E's scope instead if present
elsif Present (Scope (E)) then
- return Get_First_Parent_With_Ext_Axioms_For_Entity
- (Scope (E));
+ return
+ Get_First_Parent_With_Ext_Axioms_For_Entity (Scope (E));
-- Else there is no such axiomatized package
-- If actual is an entity (function or operator),
-- build wrapper for it.
- if Present (Match)
- and then Nkind (Match) = N_Operator_Symbol
- then
- -- If the name is a default, find its visible
- -- entity at the point of instantiation.
+ if Present (Match) then
+ if Nkind (Match) = N_Operator_Symbol then
+ -- If the name is a default, find its visible
+ -- entity at the point of instantiation.
+
+ if Is_Entity_Name (Match)
+ and then No (Entity (Match))
+ then
+ Find_Direct_Name (Match);
+ end if;
- if Is_Entity_Name (Match)
- and then No (Entity (Match))
- then
- Find_Direct_Name (Match);
- end if;
+ Append_To
+ (Assoc,
+ Build_Wrapper
+ (Defining_Entity (Analyzed_Formal), Match));
- Append_To (Assoc,
- Build_Wrapper
- (Defining_Entity (Analyzed_Formal), Match));
+ else
+ Append_To (Assoc,
+ Instantiate_Formal_Subprogram
+ (Formal, Match, Analyzed_Formal));
+ end if;
-- Ditto if formal is an operator with a default.
projects / thirdparty / gcc.git / commitdiff
