+2014-08-01 Robert Dewar <dewar@adacore.com>
+
+ * sem_ch8.adb: Minor reformatting.
+
+2014-08-01 Yannick Moy <moy@adacore.com>
+
+ * sem_ch13.adb (Insert_Pragma): Add special case for precondition
+ pragmas from aspects, which need to be inserted in proper order.
+
+2014-08-01 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_aggr.adb (Expand_Record_Aggregate, Init_Hidden_Discriminants):
+ Handle properly a type extension that constrains a discriminated
+ derived type that renames other discriminants of an ancestor.
+
+2014-08-01 Thomas Quinot <quinot@adacore.com>
+
+ * s-pack06.adb, s-pack10.adb, s-pack03.ads, s-pack12.adb, s-pack14.ads,
+ s-pack25.adb: Fix minor inconsistencies and typos.
+
2014-08-01 Hristian Kirtchev <kirtchev@adacore.com>
* sem_ch8.adb (Analyze_Subprogram_Renaming): Alphabetize
procedure Init_Hidden_Discriminants (Typ : Entity_Id; List : List_Id);
-- If Typ is derived, and constrains discriminants of the parent type,
-- these discriminants are not components of the aggregate, and must be
- -- initialized. The assignments are appended to List.
+ -- initialized. The assignments are appended to List. The same is done
+ -- if Typ derives fron an already constrained subtype of a discriminated
+ -- parent type.
function Get_Explicit_Discriminant_Value (D : Entity_Id) return Node_Id;
-- If the ancestor part is an unconstrained type and further ancestors
begin
Btype := Base_Type (Typ);
+
+ -- The constraints on the hidden discriminants, if present, are
+ -- kep in the Stored_Constraint list of the type itself, or in
+ -- that of the base type.
+
while Is_Derived_Type (Btype)
- and then Present (Stored_Constraint (Btype))
+ and then (Present (Stored_Constraint (Btype))
+ or else Present (Stored_Constraint (Typ)))
loop
Parent_Type := Etype (Btype);
+ if not Has_Discriminants (Parent_Type) then
+ return;
+ end if;
Disc := First_Discriminant (Parent_Type);
- Discr_Val := First_Elmt (Stored_Constraint (Base_Type (Typ)));
+
+ -- We know that one of the stored-constraint lists is present.
+
+ if Present (Stored_Constraint (Btype)) then
+ Discr_Val := First_Elmt (Stored_Constraint (Btype));
+ else
+ Discr_Val := First_Elmt (Stored_Constraint (Typ));
+ end if;
+
while Present (Discr_Val) loop
-- Only those discriminants of the parent that are not
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- --
------------------------------------------------------------------------------
--- Handing of packed arrays with Component_Size = 3
+-- Handling of packed arrays with Component_Size = 3
package System.Pack_03 is
pragma Preelaborate;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
procedure Set_06 (Arr : System.Address; N : Natural; E : Bits_06) is
C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8));
-
begin
case N07 (Uns (N) mod 8) is
when 0 => C.E0 := E;
procedure SetU_06 (Arr : System.Address; N : Natural; E : Bits_06) is
C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8));
-
begin
case N07 (Uns (N) mod 8) is
when 0 => C.E0 := E;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
procedure Set_10 (Arr : System.Address; N : Natural; E : Bits_10) is
C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8));
-
begin
case N07 (Uns (N) mod 8) is
when 0 => C.E0 := E;
procedure SetU_10 (Arr : System.Address; N : Natural; E : Bits_10) is
C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8));
-
begin
case N07 (Uns (N) mod 8) is
when 0 => C.E0 := E;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
procedure Set_12 (Arr : System.Address; N : Natural; E : Bits_12) is
C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8));
-
begin
case N07 (Uns (N) mod 8) is
when 0 => C.E0 := E;
procedure SetU_12 (Arr : System.Address; N : Natural; E : Bits_12) is
C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8));
-
begin
case N07 (Uns (N) mod 8) is
when 0 => C.E0 := E;
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- --
------------------------------------------------------------------------------
--- Handing of packed arrays with Component_Size = 14
+-- Handling of packed arrays with Component_Size = 14
package System.Pack_14 is
pragma Preelaborate;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
function Get_25 (Arr : System.Address; N : Natural) return Bits_25 is
C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8));
-
begin
case N07 (Uns (N) mod 8) is
when 0 => return C.E0;
procedure Set_25 (Arr : System.Address; N : Natural; E : Bits_25) is
C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8));
-
begin
case N07 (Uns (N) mod 8) is
when 0 => C.E0 := E;
-- the proper insertion point. As a result the order of pragmas
-- is the same as the order of aspects.
+ -- As precondition pragmas generated from conjuncts in the
+ -- precondition aspect are presented in reverse order to
+ -- Insert_Pragma, insert them in the correct order here by not
+ -- skipping previously inserted precondition pragmas when the
+ -- current pragma is a precondition.
+
Decl := First (Declarations (N));
while Present (Decl) loop
if Nkind (Decl) = N_Pragma
and then From_Aspect_Specification (Decl)
+ and then not (Get_Pragma_Id (Decl) = Pragma_Precondition
+ and then
+ Get_Pragma_Id (Prag) = Pragma_Precondition)
then
Next (Decl);
else
-- type with unknown discriminants and a generic primitive operation of
-- the said type with a box require special processing when the actual
-- is a class-wide type:
-
+ --
-- generic
-- type Formal_Typ (<>) is private;
-- with procedure Prim_Op (Param : Formal_Typ) is <>;
-- package Gen is ...
-
+ --
-- package Inst is new Gen (Actual_Typ'Class);
-
+ --
-- In this case the general renaming mechanism used in the prologue of
-- an instance no longer applies:
-
+ --
-- procedure Prim_Op (Param : Formal_Typ) renames Prim_Op;
-
+ --
-- The above is replaced the following wrapper/renaming combination:
-
+ --
-- procedure Prim_Op (Param : Formal_Typ) is -- wrapper
-- begin
-- Prim_Op (Param); -- primitive
-- end Wrapper;
-
+ --
-- procedure Dummy (Param : Formal_Typ) renames Prim_Op;
-
+ --
-- This transformation applies only if there is no explicit visible
-- class-wide operation at the point of the instantiation. Ren_Id is
-- the entity of the renaming declaration. Wrap_Id is the entity of
while Present (Formal) loop
Append_To (Actuals,
Make_Identifier (Loc, Chars (Defining_Identifier (Formal))));
-
Next (Formal);
end loop;
projects / gcc.git / commitdiff