* 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.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@183997
138bc75d-0d04-0410-961f-
82ee72b054a4
+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.
Array_Type => Elements_Array,
"<" => "<");
- -- Start of processing for Sort
-
begin
if Container.Last <= Index_Type'First then
return;
----------------------
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
-- 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.
Array_Type => Elements_Array,
"<" => Is_Less);
- -- Start of processing for Sort
-
begin
if Container.Last <= Index_Type'First then
return;
-- 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.
Array_Type => Elements_Array,
"<" => "<");
- -- Start of processing for Sort
-
begin
if Container.Last <= Index_Type'First then
return;
-- 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.
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;
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);
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.
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;
-----------
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,
Aspect_Predicate, -- GNAT
Aspect_Priority,
Aspect_Read,
+ Aspect_Simple_Storage_Pool, -- GNAT
Aspect_Size,
Aspect_Small,
Aspect_Static_Predicate,
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,
Aspect_Predicate => Expression,
Aspect_Priority => Expression,
Aspect_Read => Name,
+ Aspect_Simple_Storage_Pool => Name,
Aspect_Size => Expression,
Aspect_Small => Expression,
Aspect_Static_Predicate => Expression,
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,
-- --
-- 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- --
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 --
----------
-- 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
(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));
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));
-- --
-- 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- --
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.
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;
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
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 |
@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
@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}
-- Storage_Pool --
------------------
- when Attribute_Storage_Pool => Storage_Pool :
+ when Attribute_Storage_Pool |
+ Attribute_Simple_Storage_Pool => Storage_Pool :
begin
Check_E0;
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
Attribute_Priority |
Attribute_Read |
Attribute_Result |
+ Attribute_Simple_Storage_Pool |
Attribute_Storage_Pool |
Attribute_Storage_Size |
Attribute_Storage_Unit |
---------------------------
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.
-- 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
-- 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
-- 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;
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);
Error_Msg_N ("incorrect reference to a Storage Pool", Expr);
return;
end if;
- end Storage_Pool;
+ end;
------------------
-- Storage_Size --
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));
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;
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 --
----------------------
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,
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
-- 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;
-- --
-- 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- --
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
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;
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
Attribute_Elab_Body,
Attribute_Elab_Spec,
Attribute_Elab_Subp_Body,
+ Attribute_Simple_Storage_Pool,
Attribute_Storage_Pool,
-- Type attributes
Pragma_Fast_Math,
Pragma_Interface,
Pragma_Priority,
+ Pragma_Simple_Storage_Pool,
Pragma_Storage_Size,
Pragma_Storage_Unit,
OSDN Git Service
