OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes] 

2012-02-08  Robert Dewar  <dewar@adacore.com>

	* a-coinve.adb, sem_util.adb, sem_ch8.adb, a-cobove.adb,
	a-convec.adb: Minor reformatting and code reorganization.

2012-02-08  Steve Baird  <baird@adacore.com>

	* sem_cat.adb (In_Preelaborated_Unit): A child
	unit instantiation does not inherit preelaboration requirements
	from its parent.

2012-02-08  Gary Dismukes  <dismukes@adacore.com>

	* aspects.ads (type Aspect_Id): Add Aspect_Simple_Storage_Pool.
	(Impl_Defined_Aspects): Add entry for Aspect_Simple_Storage_Pool.
	(Aspect_Argument): Add Name entry for Aspect_Simple_Storage_Pool.
	(Aspect_Names): Add entry for Aspect_Simple_Storage_Pool.
	* aspects.adb (Canonical_Aspect): Add entry for
	Aspect_Simple_Storage_Pool.
	* exp_attr.adb (Expand_N_Attribute_Reference): Handle case of
	Attribute_Simple_Storage_Pool in the same way as Storage_Pool
	(add conversion, analyze/resolve). For the Storage_Size attribute,
	for the simple pool case, locate and use the simple pool type's
	Storage_Size function (if any), otherwise evaluate to zero.
	* exp_ch4.adb (Expand_N_Allocator): In the case of an allocator
	for an access type with an associated simple storage pool,
	locate and use the pool type's Allocate.
	* exp_intr.adb (Expand_Unc_Deallocation): In the case where the
	access type has a simple storage pool, locate the pool type's
	Deallocate procedure (if present) and use it as the procedure
	to call on the Free operation.
	* freeze.adb (Freeze_Entity): In the case of a full type for
	a private type defined with pragma Simple_Storage_Pool, check
	that the full type is also appropriate for the pragma. For
	a simple storage pool type, validate that the operations
	Allocate, Deallocate (if present), and Storage_Size
	(if present) are defined with appropriate expected profiles.
	(Validate_Simple_Pool_Op_Formal): New procedure
	(Validate_Simple_Pool_Operation): New procedure Add with and
	use of Rtsfind.
	* par-prag.adb: Add Pragma_Simple_Storage_Pool to case statement
	(no action required).
	* sem_attr.adb (Analyze_Attribute): For the case of the
	Storage_Pool attribute, give a warning if the prefix type has an
	associated simple storage pool, and rewrite the attribute as a
	raise of Program_Error. In the case of the Simple_Storage_Pool
	attribute, check that the prefix type has an associated simple
	storage pool, and set the attribute type to the pool's type.
	* sem_ch13.adb (Analyze_Aspect_Specifications): Add
	Aspect_Simple_Storage_Pool case choice.
	(Analyze_Attribute_Definition_Clause): Add
	Aspect_Simple_Storage_Pool to case for Ignore_Rep_Clauses
	(no action). Add handling for Simple_Storage_Pool attribute
	definition, requiring the name to denote a simple storage pool
	object.
	(Check_Aspect_At_Freeze_Point): For a simple storage pool
	aspect, set the type to that of the name specified for the aspect.
	* sem_prag.adb (Analyze_Pragma): Add handling for pragma
	Simple_Storage_Pool, requiring that it applies to a library-level
	type declared in a package declaration that is a limited private
	or limited record type.
	* sem_res.adb (Resolve_Allocator): Flag an attempt to call a
	build-in-place function in an allocator for an access type with
	a simple storage pool as unsupported.
	* snames.ads-tmpl: Add Name_Simple_Storage_Pool.
	(type Attribute_Id): Add Attribute_Simple_Storage_Pool.
	(type Pragma_Id): Add Pragma_Simple_Storage_Pool.
	* snames.adb-tmpl (Get_Pragma_Id): Handle case of
	Name_Simple_Storage_Pool.
	(Is_Pragma_Name): Return True for Name_Simple_Storage_Pool.

2012-02-08  Cyrille Comar  <comar@adacore.com>

	* projects.texi: Clarify doc for interfaces.

From-SVN: r183997
This commit is contained in:
Arnaud Charlet 2012-02-08 10:27:17 +01:00
parent 86c923c886
commit a8551b5f9c
21 changed files with 726 additions and 102 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

75
gcc/ada/ChangeLog
View File

@ -1,3 +1,78 @@
2012-02-08 Robert Dewar <dewar@adacore.com>
* a-coinve.adb, sem_util.adb, sem_ch8.adb, a-cobove.adb,
a-convec.adb: Minor reformatting and code reorganization.
2012-02-08 Steve Baird <baird@adacore.com>
* sem_cat.adb (In_Preelaborated_Unit): A child
unit instantiation does not inherit preelaboration requirements
from its parent.
2012-02-08 Gary Dismukes <dismukes@adacore.com>
* aspects.ads (type Aspect_Id): Add Aspect_Simple_Storage_Pool.
(Impl_Defined_Aspects): Add entry for Aspect_Simple_Storage_Pool.
(Aspect_Argument): Add Name entry for Aspect_Simple_Storage_Pool.
(Aspect_Names): Add entry for Aspect_Simple_Storage_Pool.
* aspects.adb (Canonical_Aspect): Add entry for
Aspect_Simple_Storage_Pool.
* exp_attr.adb (Expand_N_Attribute_Reference): Handle case of
Attribute_Simple_Storage_Pool in the same way as Storage_Pool
(add conversion, analyze/resolve). For the Storage_Size attribute,
for the simple pool case, locate and use the simple pool type's
Storage_Size function (if any), otherwise evaluate to zero.
* exp_ch4.adb (Expand_N_Allocator): In the case of an allocator
for an access type with an associated simple storage pool,
locate and use the pool type's Allocate.
* exp_intr.adb (Expand_Unc_Deallocation): In the case where the
access type has a simple storage pool, locate the pool type's
Deallocate procedure (if present) and use it as the procedure
to call on the Free operation.
* freeze.adb (Freeze_Entity): In the case of a full type for
a private type defined with pragma Simple_Storage_Pool, check
that the full type is also appropriate for the pragma. For
a simple storage pool type, validate that the operations
Allocate, Deallocate (if present), and Storage_Size
(if present) are defined with appropriate expected profiles.
(Validate_Simple_Pool_Op_Formal): New procedure
(Validate_Simple_Pool_Operation): New procedure Add with and
use of Rtsfind.
* par-prag.adb: Add Pragma_Simple_Storage_Pool to case statement
(no action required).
* sem_attr.adb (Analyze_Attribute): For the case of the
Storage_Pool attribute, give a warning if the prefix type has an
associated simple storage pool, and rewrite the attribute as a
raise of Program_Error. In the case of the Simple_Storage_Pool
attribute, check that the prefix type has an associated simple
storage pool, and set the attribute type to the pool's type.
* sem_ch13.adb (Analyze_Aspect_Specifications): Add
Aspect_Simple_Storage_Pool case choice.
(Analyze_Attribute_Definition_Clause): Add
Aspect_Simple_Storage_Pool to case for Ignore_Rep_Clauses
(no action). Add handling for Simple_Storage_Pool attribute
definition, requiring the name to denote a simple storage pool
object.
(Check_Aspect_At_Freeze_Point): For a simple storage pool
aspect, set the type to that of the name specified for the aspect.
* sem_prag.adb (Analyze_Pragma): Add handling for pragma
Simple_Storage_Pool, requiring that it applies to a library-level
type declared in a package declaration that is a limited private
or limited record type.
* sem_res.adb (Resolve_Allocator): Flag an attempt to call a
build-in-place function in an allocator for an access type with
a simple storage pool as unsupported.
* snames.ads-tmpl: Add Name_Simple_Storage_Pool.
(type Attribute_Id): Add Attribute_Simple_Storage_Pool.
(type Pragma_Id): Add Pragma_Simple_Storage_Pool.
* snames.adb-tmpl (Get_Pragma_Id): Handle case of
Name_Simple_Storage_Pool.
(Is_Pragma_Name): Return True for Name_Simple_Storage_Pool.
2012-02-08 Cyrille Comar <comar@adacore.com>
* projects.texi: Clarify doc for interfaces.
2012-02-07 Eric Botcazou <ebotcazou@adacore.com>
* gcc-interface/Make-lang.in (GCC_LINKERFLAGS): New variable.

13
gcc/ada/a-cobove.adb
View File

@ -939,8 +939,6 @@ package body Ada.Containers.Bounded_Vectors is
Array_Type => Elements_Array,
"<" => "<");
-- Start of processing for Sort
begin
if Container.Last <= Index_Type'First then
return;
@ -2238,8 +2236,9 @@ package body Ada.Containers.Bounded_Vectors is
----------------------
procedure Reverse_Elements (Container : in out Vector) is
E : Elements_Array renames Container.Elements;
Idx, Jdx : Count_Type;
E : Elements_Array renames Container.Elements;
Idx : Count_Type;
Jdx : Count_Type;
begin
if Container.Length <= 1 then
@ -2251,9 +2250,9 @@ package body Ada.Containers.Bounded_Vectors is
-- catch more things) instead of for element tampering (which will catch
-- fewer things). It's true that the elements of this vector container
-- could be safely moved around while (say) an iteration is taking place
-- (iteration only increments the busy counter), and so technically all
-- we would need here is a test for element tampering (indicated by the
-- lock counter), that's simply an artifact of our array-based
-- (iteration only increments the busy counter), and so technically
-- all we would need here is a test for element tampering (indicated
-- by the lock counter), that's simply an artifact of our array-based
-- implementation. Logically Reverse_Elements requires a check for
-- cursor tampering.

8
gcc/ada/a-coinve.adb
View File

@ -1402,8 +1402,6 @@ package body Ada.Containers.Indefinite_Vectors is
Array_Type => Elements_Array,
"<" => Is_Less);
-- Start of processing for Sort
begin
if Container.Last <= Index_Type'First then
return;
@ -3432,9 +3430,9 @@ package body Ada.Containers.Indefinite_Vectors is
-- catch more things) instead of for element tampering (which will catch
-- fewer things). It's true that the elements of this vector container
-- could be safely moved around while (say) an iteration is taking place
-- (iteration only increments the busy counter), and so technically all
-- we would need here is a test for element tampering (indicated by the
-- lock counter), that's simply an artifact of our array-based
-- (iteration only increments the busy counter), and so technically
-- all we would need here is a test for element tampering (indicated
-- by the lock counter), that's simply an artifact of our array-based
-- implementation. Logically Reverse_Elements requires a check for
-- cursor tampering.

43
gcc/ada/a-convec.adb
View File

@ -1047,8 +1047,6 @@ package body Ada.Containers.Vectors is
Array_Type => Elements_Array,
"<" => "<");
-- Start of processing for Sort
begin
if Container.Last <= Index_Type'First then
return;
@ -2994,9 +2992,9 @@ package body Ada.Containers.Vectors is
-- catch more things) instead of for element tampering (which will catch
-- fewer things). It's true that the elements of this vector container
-- could be safely moved around while (say) an iteration is taking place
-- (iteration only increments the busy counter), and so technically all
-- we would need here is a test for element tampering (indicated by the
-- lock counter), that's simply an artifact of our array-based
-- (iteration only increments the busy counter), and so technically
-- all we would need here is a test for element tampering (indicated
-- by the lock counter), that's simply an artifact of our array-based
-- implementation. Logically Reverse_Elements requires a check for
-- cursor tampering.
@ -3006,22 +3004,22 @@ package body Ada.Containers.Vectors is
end if;
declare
I, J : Index_Type;
E : Elements_Type renames Container.Elements.all;
K : Index_Type;
J : Index_Type;
E : Elements_Type renames Container.Elements.all;
begin
I := Index_Type'First;
K := Index_Type'First;
J := Container.Last;
while I < J loop
while K < J loop
declare
EI : constant Element_Type := E.EA (I);
EK : constant Element_Type := E.EA (K);
begin
E.EA (I) := E.EA (J);
E.EA (J) := EI;
E.EA (K) := E.EA (J);
E.EA (J) := EK;
end;
I := I + 1;
K := K + 1;
J := J - 1;
end loop;
end;
@ -3116,12 +3114,12 @@ package body Ada.Containers.Vectors is
Count : constant Count_Type'Base := Container.Length - Length;
begin
-- Set_Length allows the user to set the length explicitly, instead of
-- implicitly as a side-effect of deletion or insertion. If the
-- Set_Length allows the user to set the length explicitly, instead
-- of implicitly as a side-effect of deletion or insertion. If the
-- requested length is less then the current length, this is equivalent
-- to deleting items from the back end of the vector. If the requested
-- length is greater than the current length, then this is equivalent to
-- inserting "space" (nonce items) at the end.
-- length is greater than the current length, then this is equivalent
-- to inserting "space" (nonce items) at the end.
if Count >= 0 then
Container.Delete_Last (Count);
@ -3360,6 +3358,7 @@ package body Ada.Containers.Vectors is
end if;
elsif Index_Type'First <= 0 then
-- Here we can compute Last directly, in the normal way. We know that
-- No_Index is less than 0, so there is no danger of overflow when
-- adding the (positive) value of Length.
@ -3440,13 +3439,11 @@ package body Ada.Containers.Vectors is
begin
if Position.Container = null then
raise Constraint_Error with "Position cursor has no element";
end if;
if Position.Container /= Container'Unrestricted_Access then
elsif Position.Container /= Container'Unrestricted_Access then
raise Program_Error with "Position cursor denotes wrong container";
else
Update_Element (Container, Position.Index, Process);
end if;
Update_Element (Container, Position.Index, Process);
end Update_Element;
-----------

1
gcc/ada/aspects.adb
View File

@ -298,6 +298,7 @@ package body Aspects is
Aspect_Remote_Access_Type => Aspect_Remote_Access_Type,
Aspect_Read => Aspect_Read,
Aspect_Shared => Aspect_Atomic,
Aspect_Simple_Storage_Pool => Aspect_Simple_Storage_Pool,
Aspect_Size => Aspect_Size,
Aspect_Small => Aspect_Small,
Aspect_Static_Predicate => Aspect_Predicate,

4
gcc/ada/aspects.ads
View File

@ -74,6 +74,7 @@ package Aspects is
Aspect_Predicate, -- GNAT
Aspect_Priority,
Aspect_Read,
Aspect_Simple_Storage_Pool, -- GNAT
Aspect_Size,
Aspect_Small,
Aspect_Static_Predicate,
@ -186,6 +187,7 @@ package Aspects is
Aspect_Pure_Function => True,
Aspect_Remote_Access_Type => True,
Aspect_Shared => True,
Aspect_Simple_Storage_Pool => True,
Aspect_Suppress_Debug_Info => True,
Aspect_Test_Case => True,
Aspect_Universal_Data => True,
@ -277,6 +279,7 @@ package Aspects is
Aspect_Predicate => Expression,
Aspect_Priority => Expression,
Aspect_Read => Name,
Aspect_Simple_Storage_Pool => Name,
Aspect_Size => Expression,
Aspect_Small => Expression,
Aspect_Static_Predicate => Expression,
@ -364,6 +367,7 @@ package Aspects is
Aspect_Remote_Types => Name_Remote_Types,
Aspect_Shared => Name_Shared,
Aspect_Shared_Passive => Name_Shared_Passive,
Aspect_Simple_Storage_Pool => Name_Simple_Storage_Pool,
Aspect_Size => Name_Size,
Aspect_Small => Name_Small,
Aspect_Static_Predicate => Name_Static_Predicate,

87
gcc/ada/exp_attr.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2012, 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- --
@ -4217,6 +4217,17 @@ package body Exp_Attr is
when Attribute_Scaling =>
Expand_Fpt_Attribute_RI (N);
-------------------------
-- Simple_Storage_Pool --
-------------------------
when Attribute_Simple_Storage_Pool =>
Rewrite (N,
Make_Type_Conversion (Loc,
Subtype_Mark => New_Reference_To (Etype (N), Loc),
Expression => New_Reference_To (Entity (N), Loc)));
Analyze_And_Resolve (N, Typ);
----------
-- Size --
----------
@ -4475,7 +4486,10 @@ package body Exp_Attr is
-- Storage_Size --
------------------
when Attribute_Storage_Size => Storage_Size : begin
when Attribute_Storage_Size => Storage_Size : declare
Alloc_Op : Entity_Id := Empty;
begin
-- Access type case, always go to the root type
@ -4497,19 +4511,64 @@ package body Exp_Attr is
(Storage_Size_Variable (Root_Type (Ptyp)), Loc)))));
elsif Present (Associated_Storage_Pool (Root_Type (Ptyp))) then
Rewrite (N,
OK_Convert_To (Typ,
Make_Function_Call (Loc,
Name =>
New_Reference_To
(Find_Prim_Op
(Etype (Associated_Storage_Pool (Root_Type (Ptyp))),
Attribute_Name (N)),
Loc),
Parameter_Associations => New_List (
New_Reference_To
(Associated_Storage_Pool (Root_Type (Ptyp)), Loc)))));
-- If the access type is associated with a simple storage pool
-- object, then attempt to locate the optional Storage_Size
-- function of the simple storage pool type. If not found,
-- then the result will default to zero.
if Present (Get_Rep_Pragma (Root_Type (Ptyp),
Name_Simple_Storage_Pool))
then
declare
Pool_Type : constant Entity_Id :=
Base_Type (Etype (Entity (N)));
begin
Alloc_Op := Get_Name_Entity_Id (Name_Storage_Size);
while Present (Alloc_Op) loop
if Scope (Alloc_Op) = Scope (Pool_Type)
and then Present (First_Formal (Alloc_Op))
and then Etype (First_Formal (Alloc_Op)) = Pool_Type
then
exit;
end if;
Alloc_Op := Homonym (Alloc_Op);
end loop;
end;
-- In the normal Storage_Pool case, retrieve the primitive
-- function associated with the pool type.
else
Alloc_Op :=
Find_Prim_Op
(Etype (Associated_Storage_Pool (Root_Type (Ptyp))),
Attribute_Name (N));
end if;
-- If Storage_Size wasn't found (can only occur in the simple
-- storage pool case), then simply use zero for the result.
if not Present (Alloc_Op) then
Rewrite (N, Make_Integer_Literal (Loc, 0));
-- Otherwise, rewrite the allocator as a call to pool type's
-- Storage_Size function.
else
Rewrite (N,
OK_Convert_To (Typ,
Make_Function_Call (Loc,
Name =>
New_Reference_To (Alloc_Op, Loc),
Parameter_Associations => New_List (
New_Reference_To
(Associated_Storage_Pool
(Root_Type (Ptyp)), Loc)))));
end if;
else
Rewrite (N, Make_Integer_Literal (Loc, 0));

25
gcc/ada/exp_ch4.adb
View File

@ -3565,6 +3565,31 @@ package body Exp_Ch4 is
Set_Procedure_To_Call (N, RTE (RE_SS_Allocate));
end if;
-- In the case of an allocator for a simple storage pool, locate
-- and save a reference to the pool type's Allocate routine.
elsif Present (Get_Rep_Pragma
(Etype (Pool), Name_Simple_Storage_Pool))
then
declare
Alloc_Op : Entity_Id := Get_Name_Entity_Id (Name_Allocate);
Pool_Type : constant Entity_Id := Base_Type (Etype (Pool));
begin
while Present (Alloc_Op) loop
if Scope (Alloc_Op) = Scope (Pool_Type)
and then Present (First_Formal (Alloc_Op))
and then Etype (First_Formal (Alloc_Op)) = Pool_Type
then
Set_Procedure_To_Call (N, Alloc_Op);
exit;
end if;
Alloc_Op := Homonym (Alloc_Op);
end loop;
end;
elsif Is_Class_Wide_Type (Etype (Pool)) then
Set_Procedure_To_Call (N, RTE (RE_Allocate_Any));

30
gcc/ada/exp_intr.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2012, 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- --
@ -1084,6 +1084,34 @@ package body Exp_Intr is
if Is_RTE (Pool, RE_SS_Pool) then
null;
-- If the pool object is of a simple storage pool type, then attempt
-- to locate the type's Deallocate procedure, if any, and set the
-- free operation's procedure to call. If the type doesn't have a
-- Deallocate (which is allowed), then the actual will simply be set
-- to null.
elsif Present (Get_Rep_Pragma
(Etype (Pool), Name_Simple_Storage_Pool))
then
declare
Dealloc_Op : Entity_Id := Get_Name_Entity_Id (Name_Deallocate);
Pool_Type : constant Entity_Id := Base_Type (Etype (Pool));
begin
while Present (Dealloc_Op) loop
if Scope (Dealloc_Op) = Scope (Pool_Type)
and then Present (First_Formal (Dealloc_Op))
and then Etype (First_Formal (Dealloc_Op)) = Pool_Type
then
Set_Procedure_To_Call (Free_Node, Dealloc_Op);
exit;
end if;
Dealloc_Op := Homonym (Dealloc_Op);
end loop;
end;
-- Case of a class-wide pool type: make a dispatching call to
-- Deallocate through the class-wide Deallocate_Any.

276
gcc/ada/freeze.adb
View File

@ -42,6 +42,7 @@ with Nmake; use Nmake;
with Opt; use Opt;
with Restrict; use Restrict;
with Rident; use Rident;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Aux; use Sem_Aux;
with Sem_Cat; use Sem_Cat;
@ -4103,6 +4104,281 @@ package body Freeze is
end loop;
end;
end if;
-- If the type is a simple storage pool type, then this is where
-- we attempt to locate and validate its Allocate, Deallocate, and
-- Storage_Size operations (the first is required, and the latter
-- two are optional). We also verify that the full type for a
-- private type is allowed to be a simple storage pool type.
if Present (Get_Rep_Pragma (E, Name_Simple_Storage_Pool))
and then (Is_Base_Type (E) or else Has_Private_Declaration (E))
then
-- If the type is marked Has_Private_Declaration, then this is
-- a full type for a private type that was specified with the
-- pragma Simple_Storage_Pool, and here we ensure that the
-- pragma is allowed for the full type (for example, it can't
-- be an array type, or a nonlimited record type).
if Has_Private_Declaration (E) then
if (not Is_Record_Type (E)
or else not Is_Immutably_Limited_Type (E))
and then not Is_Private_Type (E)
then
Error_Msg_Name_1 := Name_Simple_Storage_Pool;
Error_Msg_N
("pragma% can only apply to full type that is an " &
"explicitly limited type", E);
end if;
end if;
Validate_Simple_Pool_Ops : declare
Pool_Type : Entity_Id renames E;
Address_Type : constant Entity_Id := RTE (RE_Address);
Stg_Cnt_Type : constant Entity_Id := RTE (RE_Storage_Count);
procedure Validate_Simple_Pool_Op_Formal
(Pool_Op : Entity_Id;
Pool_Op_Formal : in out Entity_Id;
Expected_Mode : Formal_Kind;
Expected_Type : Entity_Id;
Formal_Name : String;
OK_Formal : in out Boolean);
-- Validate one formal Pool_Op_Formal of the candidate pool
-- operation Pool_Op. The formal must be of Expected_Type
-- and have mode Expected_Mode. OK_Formal will be set to
-- False if the formal doesn't match. If OK_Formal is False
-- on entry, then the formal will effectively be ignored
-- (because validation of the pool op has already failed).
-- Upon return, Pool_Op_Formal will be updated to the next
-- formal, if any.
procedure Validate_Simple_Pool_Operation (Op_Name : Name_Id);
-- Search for and validate a simple pool operation with the
-- name Op_Name. If the name is Allocate, then there must be
-- exactly one such primitive operation for the simple pool
-- type. If the name is Deallocate or Storage_Size, then
-- there can be at most one such primitive operation. The
-- profile of the located primitive must conform to what
-- is expected for each operation.
------------------------------------
-- Validate_Simple_Pool_Op_Formal --
------------------------------------
procedure Validate_Simple_Pool_Op_Formal
(Pool_Op : Entity_Id;
Pool_Op_Formal : in out Entity_Id;
Expected_Mode : Formal_Kind;
Expected_Type : Entity_Id;
Formal_Name : String;
OK_Formal : in out Boolean)
is
begin
-- If OK_Formal is False on entry, then simply ignore
-- the formal, because an earlier formal has already
-- been flagged.
if not OK_Formal then
return;
-- If no formal is passed in, then issue an error for a
-- missing formal.
elsif not Present (Pool_Op_Formal) then
Error_Msg_NE
("simple storage pool op missing formal " &
Formal_Name & " of type&", Pool_Op, Expected_Type);
OK_Formal := False;
return;
end if;
if Etype (Pool_Op_Formal) /= Expected_Type then
-- If the pool type was expected for this formal, then
-- this will not be considered a candidate operation
-- for the simple pool, so we unset OK_Formal so that
-- the op and any later formals will be ignored.
if Expected_Type = Pool_Type then
OK_Formal := False;
return;
else
Error_Msg_NE
("wrong type for formal " & Formal_Name &
" of simple storage pool op; expected type&",
Pool_Op_Formal, Expected_Type);
end if;
end if;
-- Issue error if formal's mode is not the expected one
if Ekind (Pool_Op_Formal) /= Expected_Mode then
Error_Msg_N
("wrong mode for formal of simple storage pool op",
Pool_Op_Formal);
end if;
-- Advance to the next formal
Next_Formal (Pool_Op_Formal);
end Validate_Simple_Pool_Op_Formal;
------------------------------------
-- Validate_Simple_Pool_Operation --
------------------------------------
procedure Validate_Simple_Pool_Operation
(Op_Name : Name_Id)
is
Op : Entity_Id;
Found_Op : Entity_Id := Empty;
Formal : Entity_Id;
Is_OK : Boolean;
begin
pragma Assert
(Op_Name = Name_Allocate
or else Op_Name = Name_Deallocate
or else Op_Name = Name_Storage_Size);
Error_Msg_Name_1 := Op_Name;
-- For each homonym declared immediately in the scope
-- of the simple storage pool type, determine whether
-- the homonym is an operation of the pool type, and,
-- if so, check that its profile is as expected for
-- a simple pool operation of that name.
Op := Get_Name_Entity_Id (Op_Name);
while Present (Op) loop
if Ekind_In (Op, E_Function, E_Procedure)
and then Scope (Op) = Current_Scope
then
Formal := First_Entity (Op);
Is_OK := True;
-- The first parameter must be of the pool type
-- in order for the operation to qualify.
if Op_Name = Name_Storage_Size then
Validate_Simple_Pool_Op_Formal
(Op, Formal, E_In_Parameter, Pool_Type,
"Pool", Is_OK);
else
Validate_Simple_Pool_Op_Formal
(Op, Formal, E_In_Out_Parameter, Pool_Type,
"Pool", Is_OK);
end if;
-- If another operation with this name has already
-- been located for the type, then flag an error,
-- since we only allow the type to have a single
-- such primitive.
if Present (Found_Op) and then Is_OK then
Error_Msg_NE
("only one % operation allowed for " &
"simple storage pool type&", Op, Pool_Type);
end if;
-- In the case of Allocate and Deallocate, a formal
-- of type System.Address is required.
if Op_Name = Name_Allocate then
Validate_Simple_Pool_Op_Formal
(Op, Formal, E_Out_Parameter,
Address_Type, "Storage_Address", Is_OK);
elsif Op_Name = Name_Deallocate then
Validate_Simple_Pool_Op_Formal
(Op, Formal, E_In_Parameter,
Address_Type, "Storage_Address", Is_OK);
end if;
-- In the case of Allocate and Deallocate, formals
-- of type Storage_Count are required as the third
-- and fourth parameters.
if Op_Name /= Name_Storage_Size then
Validate_Simple_Pool_Op_Formal
(Op, Formal, E_In_Parameter,
Stg_Cnt_Type, "Size_In_Storage_Units", Is_OK);
Validate_Simple_Pool_Op_Formal
(Op, Formal, E_In_Parameter,
Stg_Cnt_Type, "Alignment", Is_OK);
end if;
-- If no mismatched formals have been found (Is_OK)
-- and no excess formals are present, then this
-- operation has been validated, so record it.
if not Present (Formal) and then Is_OK then
Found_Op := Op;
end if;
end if;
Op := Homonym (Op);
end loop;
-- There must be a valid Allocate operation for the type,
-- so issue an error if none was found.
if Op_Name = Name_Allocate
and then not Present (Found_Op)
then
Error_Msg_N ("missing % operation for simple " &
"storage pool type", Pool_Type);
elsif Present (Found_Op) then
-- Simple pool operations can't be abstract
if Is_Abstract_Subprogram (Found_Op) then
Error_Msg_N
("simple storage pool operation must not be " &
"abstract", Found_Op);
end if;
-- The Storage_Size operation must be a function with
-- Storage_Count as its result type.
if Op_Name = Name_Storage_Size then
if Ekind (Found_Op) = E_Procedure then
Error_Msg_N
("% operation must be a function", Found_Op);
elsif Etype (Found_Op) /= Stg_Cnt_Type then
Error_Msg_NE
("wrong result type for%, expected type&",
Found_Op, Stg_Cnt_Type);
end if;
-- Allocate and Deallocate must be procedures
elsif Ekind (Found_Op) = E_Function then
Error_Msg_N
("% operation must be a procedure", Found_Op);
end if;
end if;
end Validate_Simple_Pool_Operation;
-- Start of processing for Validate_Simple_Pool_Ops
begin
Validate_Simple_Pool_Operation (Name_Allocate);
Validate_Simple_Pool_Operation (Name_Deallocate);
Validate_Simple_Pool_Operation (Name_Storage_Size);
end Validate_Simple_Pool_Ops;
end if;
end if;
-- Now that all types from which E may depend are frozen, see if the

1
gcc/ada/par-prag.adb
View File

@ -1230,6 +1230,7 @@ begin
Pragma_Shared_Passive |
Pragma_Short_Circuit_And_Or |
Pragma_Short_Descriptors |
Pragma_Simple_Storage_Pool |
Pragma_Storage_Size |
Pragma_Storage_Unit |
Pragma_Static_Elaboration_Desired |

20
gcc/ada/projects.texi
View File

@ -1767,10 +1767,10 @@ language and takes a list of sources as parameter.
@table @asis
@item @b{Library_Interface}:
@cindex @code{Library_Interface}
This attribute defines an explicit subset of the units of the project.
Projects importing this library project may only "with" units whose sources
are listed in the @code{Library_Interface}. Other sources are considered
implementation units.
This attribute defines an explicit subset of the units of the project. Units
from projects importing this library project may only "with" units whose
sources are listed in the @code{Library_Interface}. Other sources are
considered implementation units.
@smallexample @c projectfile
@group
@ -1781,11 +1781,13 @@ language and takes a list of sources as parameter.
@end smallexample
@item @b{Interfaces}
This attribute defnes an explicit subset of the source files of a project.
It may be used as a replacement for attribute @code{Library_Interface}. For
multi-language library projects, it is the only way to make the project a
Stand-Alone Library project and at the same time to reduce the non Ada
interfacing sources.
This attribute defines an explicit subset of the source files of a project.
Sources from projects importing this project, can only depend on sources from
this subset. This attribute can be used on non library projects. It can also
be used as a replacement for attribute @code{Library_Interface}, in which
case, units have to be replaced by source files. For multi-language library
projects, it is the only way to make the project a Stand-Alone Library project
whose interface is not purely Ada.
@item @b{Library_Standalone}:
@cindex @code{Library_Standalone}

37
gcc/ada/sem_attr.adb
View File

@ -4528,7 +4528,8 @@ package body Sem_Attr is
-- Storage_Pool --
------------------
when Attribute_Storage_Pool => Storage_Pool :
when Attribute_Storage_Pool |
Attribute_Simple_Storage_Pool => Storage_Pool :
begin
Check_E0;
@ -4546,7 +4547,38 @@ package body Sem_Attr is
Set_Entity (N, RTE (RE_Global_Pool_Object));
end if;
Set_Etype (N, Class_Wide_Type (RTE (RE_Root_Storage_Pool)));
if Attr_Id = Attribute_Storage_Pool then
if Present (Get_Rep_Pragma (Etype (Entity (N)),
Name_Simple_Storage_Pool))
then
Error_Msg_Name_1 := Aname;
Error_Msg_N ("cannot use % attribute for type with simple " &
"storage pool?", N);
Error_Msg_N
("\Program_Error will be raised at run time?", N);
Rewrite
(N, Make_Raise_Program_Error
(Sloc (N), Reason => PE_Explicit_Raise));
end if;
Set_Etype (N, Class_Wide_Type (RTE (RE_Root_Storage_Pool)));
-- In the Simple_Storage_Pool case, verify that the pool entity is
-- actually of a simple storage pool type, and set the attribute's
-- type to the pool object's type.
else
if not Present (Get_Rep_Pragma (Etype (Entity (N)),
Name_Simple_Storage_Pool))
then
Error_Attr_P
("cannot use % attribute for type without simple " &
"storage pool");
end if;
Set_Etype (N, Etype (Entity (N)));
end if;
-- Validate_Remote_Access_To_Class_Wide_Type for attribute
-- Storage_Pool since this attribute is not defined for such
@ -7931,6 +7963,7 @@ package body Sem_Attr is
Attribute_Priority |
Attribute_Read |
Attribute_Result |
Attribute_Simple_Storage_Pool |
Attribute_Storage_Pool |
Attribute_Storage_Size |
Attribute_Storage_Unit |

13
gcc/ada/sem_cat.adb
View File

@ -486,11 +486,22 @@ package body Sem_Cat is
---------------------------
function In_Preelaborated_Unit return Boolean is
Unit_Entity : constant Entity_Id := Current_Scope;
Unit_Entity : Entity_Id := Current_Scope;
Unit_Kind : constant Node_Kind :=
Nkind (Unit (Cunit (Current_Sem_Unit)));
begin
-- If evaluating actuals for a child unit instantiation, then ignore
-- the preelaboration status of the parent; use the child instead.
if Is_Compilation_Unit (Unit_Entity)
and then Unit_Kind in N_Generic_Instantiation
and then not In_Same_Source_Unit (Unit_Entity,
Cunit (Current_Sem_Unit))
then
Unit_Entity := Cunit_Entity (Current_Sem_Unit);
end if;
-- There are no constraints on the body of Remote_Call_Interface or
-- Remote_Types packages.

81
gcc/ada/sem_ch13.adb
View File

@ -1064,23 +1064,24 @@ package body Sem_Ch13 is
-- Aspects corresponding to attribute definition clauses
when Aspect_Address |
Aspect_Alignment |
Aspect_Bit_Order |
Aspect_Component_Size |
Aspect_External_Tag |
Aspect_Input |
Aspect_Machine_Radix |
Aspect_Object_Size |
Aspect_Output |
Aspect_Read |
Aspect_Size |
Aspect_Small |
Aspect_Storage_Pool |
Aspect_Storage_Size |
Aspect_Stream_Size |
Aspect_Value_Size |
Aspect_Write =>
when Aspect_Address |
Aspect_Alignment |
Aspect_Bit_Order |
Aspect_Component_Size |
Aspect_External_Tag |
Aspect_Input |
Aspect_Machine_Radix |
Aspect_Object_Size |
Aspect_Output |
Aspect_Read |
Aspect_Size |
Aspect_Small |
Aspect_Simple_Storage_Pool |
Aspect_Storage_Pool |
Aspect_Storage_Size |
Aspect_Stream_Size |
Aspect_Value_Size |
Aspect_Write =>
-- Construct the attribute definition clause
@ -2210,13 +2211,14 @@ package body Sem_Ch13 is
-- legality, e.g. failing to provide a stream attribute for a
-- type may make a program illegal.
when Attribute_External_Tag |
Attribute_Input |
Attribute_Output |
Attribute_Read |
Attribute_Storage_Pool |
Attribute_Storage_Size |
Attribute_Write =>
when Attribute_External_Tag |
Attribute_Input |
Attribute_Output |
Attribute_Read |
Attribute_Simple_Storage_Pool |
Attribute_Storage_Pool |
Attribute_Storage_Size |
Attribute_Write =>
null;
-- Other cases are errors ("attribute& cannot be set with
@ -3163,7 +3165,7 @@ package body Sem_Ch13 is
-- Storage_Pool attribute definition clause
when Attribute_Storage_Pool => Storage_Pool : declare
when Attribute_Storage_Pool | Attribute_Simple_Storage_Pool => declare
Pool : Entity_Id;
T : Entity_Id;
@ -3194,8 +3196,24 @@ package body Sem_Ch13 is
return;
end if;
Analyze_And_Resolve
(Expr, Class_Wide_Type (RTE (RE_Root_Storage_Pool)));
if Id = Attribute_Storage_Pool then
Analyze_And_Resolve
(Expr, Class_Wide_Type (RTE (RE_Root_Storage_Pool)));
-- In the Simple_Storage_Pool case, we allow a variable of any
-- Simple_Storage_Pool type, so we Resolve without imposing an
-- expected type.
else
Analyze_And_Resolve (Expr);
if not Present (Get_Rep_Pragma
(Etype (Expr), Name_Simple_Storage_Pool))
then
Error_Msg_N
("expression must be of a simple storage pool type", Expr);
end if;
end if;
if not Denotes_Variable (Expr) then
Error_Msg_N ("storage pool must be a variable", Expr);
@ -3280,7 +3298,7 @@ package body Sem_Ch13 is
Error_Msg_N ("incorrect reference to a Storage Pool", Expr);
return;
end if;
end Storage_Pool;
end;
------------------
-- Storage_Size --
@ -6147,6 +6165,13 @@ package body Sem_Ch13 is
when Aspect_Small =>
T := Universal_Real;
-- For a simple storage pool, we have to retrieve the type of the
-- pool object associated with the aspect's corresponding attribute
-- definition clause.
when Aspect_Simple_Storage_Pool =>
T := Etype (Expression (Aspect_Rep_Item (ASN)));
when Aspect_Storage_Pool =>
T := Class_Wide_Type (RTE (RE_Root_Storage_Pool));

13
gcc/ada/sem_ch8.adb
View File

@ -2664,11 +2664,14 @@ package body Sem_Ch8 is
if not Is_Actual
and then (Old_S = New_S
or else (Nkind (Nam) /= N_Expanded_Name
and then Chars (Old_S) = Chars (New_S))
or else (Nkind (Nam) = N_Expanded_Name
and then Entity (Prefix (Nam)) = Current_Scope
and then Chars (Selector_Name (Nam)) = Chars (New_S)))
or else
(Nkind (Nam) /= N_Expanded_Name
and then Chars (Old_S) = Chars (New_S))
or else
(Nkind (Nam) = N_Expanded_Name
and then Entity (Prefix (Nam)) = Current_Scope
and then
Chars (Selector_Name (Nam)) = Chars (New_S)))
then
Error_Msg_N ("subprogram cannot rename itself", N);
end if;

60
gcc/ada/sem_prag.adb
View File

@ -13150,6 +13150,65 @@ package body Sem_Prag is
Check_Valid_Configuration_Pragma;
Short_Descriptors := True;
-------------------------
-- Simple_Storage_Pool --
-------------------------
-- pragma Simple_Storage_Pool (type_LOCAL_NAME);
when Pragma_Simple_Storage_Pool => Simple_Storage_Pool : declare
Type_Id : Node_Id;
Typ : Entity_Id;
begin
GNAT_Pragma;
Check_Arg_Count (1);
Check_Arg_Is_Library_Level_Local_Name (Arg1);
Type_Id := Get_Pragma_Arg (Arg1);
Find_Type (Type_Id);
Typ := Entity (Type_Id);
if Typ = Any_Type then
return;
end if;
-- We require the pragma to apply to a type declared in a package
-- declaration, but not (immediately) within a package body.
if Ekind (Current_Scope) /= E_Package
or else In_Package_Body (Current_Scope)
then
Error_Pragma
("pragma% can only apply to type declared immediately " &
"within a package declaration");
end if;
-- A simple storage pool type must be an immutably limited record
-- or private type. If the pragma is given for a private type,
-- the full type is similarly restricted (which is checked later
-- in Freeze_Entity).
if Is_Record_Type (Typ)
and then not Is_Immutably_Limited_Type (Typ)
then
Error_Pragma
("pragma% can only apply to explicitly limited record type");
elsif Is_Private_Type (Typ) and then not Is_Limited_Type (Typ) then
Error_Pragma
("pragma% can only apply to a private type that is limited");
elsif not Is_Record_Type (Typ)
and then not Is_Private_Type (Typ)
then
Error_Pragma
("pragma% can only apply to limited record or private type");
end if;
Record_Rep_Item (Typ, N);
end Simple_Storage_Pool;
----------------------
-- Source_File_Name --
----------------------
@ -15117,6 +15176,7 @@ package body Sem_Prag is
Pragma_Shared => -1,
Pragma_Shared_Passive => -1,
Pragma_Short_Descriptors => 0,
Pragma_Simple_Storage_Pool => 0,
Pragma_Source_File_Name => -1,
Pragma_Source_File_Name_Project => -1,
Pragma_Source_Reference => -1,

25
gcc/ada/sem_res.adb
View File

@ -4228,6 +4228,31 @@ package body Sem_Res is
Wrong_Type (Expression (E), Etype (E));
end if;
-- Calls to build-in-place functions are not currently supported in
-- allocators for access types associated with a simple storage pool.
-- Supporting such allocators may require passing additional implicit
-- parameters to build-in-place functions (or a significant revision
-- of the current b-i-p implementation to unify the handling for
-- multiple kinds of storage pools). ???
if Is_Immutably_Limited_Type (Desig_T)
and then Nkind (Expression (E)) = N_Function_Call
then
declare
Pool : constant Entity_Id
:= Associated_Storage_Pool (Root_Type (Typ));
begin
if Present (Pool)
and then Present (Get_Rep_Pragma
(Etype (Pool), Name_Simple_Storage_Pool))
then
Error_Msg_N
("limited function calls not yet supported in simple " &
"storage pool allocators", Expression (E));
end if;
end;
end if;
-- A special accessibility check is needed for allocators that
-- constrain access discriminants. The level of the type of the
-- expression used to constrain an access discriminant cannot be

8
gcc/ada/sem_util.adb
View File

@ -7138,18 +7138,14 @@ package body Sem_Util is
-- is fully initialized.
if Is_Scalar_Type (Typ) then
return
Ada_Version >= Ada_2012
and then Has_Default_Aspect (Typ);
return Ada_Version >= Ada_2012 and then Has_Default_Aspect (Typ);
elsif Is_Access_Type (Typ) then
return True;
elsif Is_Array_Type (Typ) then
if Is_Fully_Initialized_Type (Component_Type (Typ))
or else
(Ada_Version >= Ada_2012
and then Has_Default_Aspect (Typ))
or else (Ada_Version >= Ada_2012 and then Has_Default_Aspect (Typ))
then
return True;
end if;

5
gcc/ada/snames.adb-tmpl
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2012, 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- --
@ -217,6 +217,8 @@ package body Snames is
return Pragma_Priority;
elsif N = Name_Relative_Deadline then
return Pragma_Relative_Deadline;
elsif N = Name_Simple_Storage_Pool then
return Pragma_Simple_Storage_Pool;
elsif N = Name_Storage_Size then
return Pragma_Storage_Size;
elsif N = Name_Storage_Unit then
@ -414,6 +416,7 @@ package body Snames is
or else N = Name_Interface
or else N = Name_Relative_Deadline
or else N = Name_Priority
or else N = Name_Simple_Storage_Pool
or else N = Name_Storage_Size
or else N = Name_Storage_Unit;
end Is_Pragma_Name;

3
gcc/ada/snames.ads-tmpl
View File

@ -909,6 +909,7 @@ package Snames is
Name_Elab_Body : constant Name_Id := N + $; -- GNAT
Name_Elab_Spec : constant Name_Id := N + $; -- GNAT
Name_Elab_Subp_Body : constant Name_Id := N + $; -- GNAT
Name_Simple_Storage_Pool : constant Name_Id := N + $; -- GNAT
Name_Storage_Pool : constant Name_Id := N + $;
-- These attributes are the ones that return types
@ -1459,6 +1460,7 @@ package Snames is
Attribute_Elab_Body,
Attribute_Elab_Spec,
Attribute_Elab_Subp_Body,
Attribute_Simple_Storage_Pool,
Attribute_Storage_Pool,
-- Type attributes
@ -1730,6 +1732,7 @@ package Snames is
Pragma_Fast_Math,
Pragma_Interface,
Pragma_Priority,
Pragma_Simple_Storage_Pool,
Pragma_Storage_Size,
Pragma_Storage_Unit,