-- --
-- 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- --
with Sem_Ch3; use Sem_Ch3;
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch8; use Sem_Ch8;
+with Sem_Dim; use Sem_Dim;
with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
with Sem_Type; use Sem_Type;
-- Local Subprograms --
-----------------------
- procedure Alignment_Check_For_Esize_Change (Typ : Entity_Id);
- -- This routine is called after setting the Esize of type entity Typ.
- -- The purpose is to deal with the situation where an alignment has been
- -- inherited from a derived type that is no longer appropriate for the
- -- new Esize value. In this case, we reset the Alignment to unknown.
+ procedure Alignment_Check_For_Size_Change (Typ : Entity_Id; Size : Uint);
+ -- This routine is called after setting one of the sizes of type entity
+ -- Typ to Size. The purpose is to deal with the situation of a derived
+ -- type whose inherited alignment is no longer appropriate for the new
+ -- size value. In this case, we reset the Alignment to unknown.
procedure Build_Predicate_Function (Typ : Entity_Id; N : Node_Id);
-- If Typ has predicates (indicated by Has_Predicates being set for Typ,
----------------------------------------------
-- The following table collects unchecked conversions for validation.
- -- Entries are made by Validate_Unchecked_Conversion and then the
- -- call to Validate_Unchecked_Conversions does the actual error
- -- checking and posting of warnings. The reason for this delayed
- -- processing is to take advantage of back-annotations of size and
- -- alignment values performed by the back end.
+ -- Entries are made by Validate_Unchecked_Conversion and then the call
+ -- to Validate_Unchecked_Conversions does the actual error checking and
+ -- posting of warnings. The reason for this delayed processing is to take
+ -- advantage of back-annotations of size and alignment values performed by
+ -- the back end.
- -- Note: the reason we store a Source_Ptr value instead of a Node_Id
- -- is that by the time Validate_Unchecked_Conversions is called, Sprint
- -- will already have modified all Sloc values if the -gnatD option is set.
+ -- Note: the reason we store a Source_Ptr value instead of a Node_Id is
+ -- that by the time Validate_Unchecked_Conversions is called, Sprint will
+ -- already have modified all Sloc values if the -gnatD option is set.
type UC_Entry is record
Eloc : Source_Ptr; -- node used for posting warnings
-- for X'Address use Expr
- -- where Expr is of the form Y'Address or recursively is a reference
- -- to a constant of either of these forms, and X and Y are entities of
- -- objects, then if Y has a smaller alignment than X, that merits a
- -- warning about possible bad alignment. The following table collects
- -- address clauses of this kind. We put these in a table so that they
- -- can be checked after the back end has completed annotation of the
- -- alignments of objects, since we can catch more cases that way.
+ -- where Expr is of the form Y'Address or recursively is a reference to a
+ -- constant of either of these forms, and X and Y are entities of objects,
+ -- then if Y has a smaller alignment than X, that merits a warning about
+ -- possible bad alignment. The following table collects address clauses of
+ -- this kind. We put these in a table so that they can be checked after the
+ -- back end has completed annotation of the alignments of objects, since we
+ -- can catch more cases that way.
type Address_Clause_Check_Record is record
N : Node_Id;
-- Processing depends on version of Ada
-- For Ada 95, we just renumber bits within a storage unit. We do the
- -- same for Ada 83 mode, since we recognize pragma Bit_Order in Ada 83,
- -- and are free to add this extension.
+ -- same for Ada 83 mode, since we recognize the Bit_Order attribute in
+ -- Ada 83, and are free to add this extension.
if Ada_Version < Ada_2005 then
Comp := First_Component_Or_Discriminant (R);
end if;
end Adjust_Record_For_Reverse_Bit_Order;
- --------------------------------------
- -- Alignment_Check_For_Esize_Change --
- --------------------------------------
+ -------------------------------------
+ -- Alignment_Check_For_Size_Change --
+ -------------------------------------
- procedure Alignment_Check_For_Esize_Change (Typ : Entity_Id) is
+ procedure Alignment_Check_For_Size_Change (Typ : Entity_Id; Size : Uint) is
begin
-- If the alignment is known, and not set by a rep clause, and is
-- inconsistent with the size being set, then reset it to unknown,
if Known_Alignment (Typ)
and then not Has_Alignment_Clause (Typ)
- and then Esize (Typ) mod (Alignment (Typ) * SSU) /= 0
+ and then Size mod (Alignment (Typ) * SSU) /= 0
then
Init_Alignment (Typ);
end if;
- end Alignment_Check_For_Esize_Change;
+ end Alignment_Check_For_Size_Change;
-----------------------------------
-- Analyze_Aspect_Specifications --
-- Insert pragmas (except Pre/Post/Invariant/Predicate) after this node
-- The general processing involves building an attribute definition
- -- clause or a pragma node that corresponds to the access type. Then
- -- one of two things happens:
+ -- clause or a pragma node that corresponds to the aspect. Then one
+ -- of two things happens:
-- If we are required to delay the evaluation of this aspect to the
-- freeze point, we attach the corresponding pragma/attribute definition
-- or attribute definition node in either case to activate special
-- processing (e.g. not traversing the list of homonyms for inline).
- Delay_Required : Boolean;
+ Delay_Required : Boolean := False;
-- Set True if delay is required
begin
A_Id : constant Aspect_Id := Get_Aspect_Id (Nam);
Anod : Node_Id;
- Eloc : Source_Ptr := Sloc (Expr);
- -- Source location of expression, modified when we split PPC's
+ Eloc : Source_Ptr := No_Location;
+ -- Source location of expression, modified when we split PPC's. It
+ -- is set below when Expr is present.
procedure Check_False_Aspect_For_Derived_Type;
-- This procedure checks for the case of a false aspect for a
goto Continue;
end if;
+ -- Set the source location of expression, used in the case of
+ -- a failed precondition/postcondition or invariant. Note that
+ -- the source location of the expression is not usually the best
+ -- choice here. For example, it gets located on the last AND
+ -- keyword in a chain of boolean expressiond AND'ed together.
+ -- It is best to put the message on the first character of the
+ -- assertion, which is the effect of the First_Node call here.
+
+ if Present (Expr) then
+ Eloc := Sloc (First_Node (Expr));
+ end if;
+
+ -- Check restriction No_Implementation_Aspect_Specifications
+
+ if Impl_Defined_Aspects (A_Id) then
+ Check_Restriction
+ (No_Implementation_Aspect_Specifications, Aspect);
+ end if;
+
+ -- Check restriction No_Specification_Of_Aspect
+
+ Check_Restriction_No_Specification_Of_Aspect (Aspect);
+
+ -- Analyze this aspect
+
Set_Analyzed (Aspect);
Set_Entity (Aspect, E);
Ent := New_Occurrence_Of (E, Sloc (Id));
-- test allows duplicate Pre/Post's that we generate internally
-- to escape being flagged here.
- Anod := First (L);
- while Anod /= Aspect loop
- if Same_Aspect (A_Id, Get_Aspect_Id (Chars (Identifier (Anod))))
- and then Comes_From_Source (Aspect)
- then
- Error_Msg_Name_1 := Nam;
- Error_Msg_Sloc := Sloc (Anod);
+ if No_Duplicates_Allowed (A_Id) then
+ Anod := First (L);
+ while Anod /= Aspect loop
+ if Same_Aspect
+ (A_Id, Get_Aspect_Id (Chars (Identifier (Anod))))
+ and then Comes_From_Source (Aspect)
+ then
+ Error_Msg_Name_1 := Nam;
+ Error_Msg_Sloc := Sloc (Anod);
- -- Case of same aspect specified twice
+ -- Case of same aspect specified twice
- if Class_Present (Anod) = Class_Present (Aspect) then
- if not Class_Present (Anod) then
- Error_Msg_NE
- ("aspect% for & previously given#",
- Id, E);
- else
- Error_Msg_NE
- ("aspect `%''Class` for & previously given#",
- Id, E);
- end if;
+ if Class_Present (Anod) = Class_Present (Aspect) then
+ if not Class_Present (Anod) then
+ Error_Msg_NE
+ ("aspect% for & previously given#",
+ Id, E);
+ else
+ Error_Msg_NE
+ ("aspect `%''Class` for & previously given#",
+ Id, E);
+ end if;
- -- Case of Pre and Pre'Class both specified
+ -- Case of Pre and Pre'Class both specified
- elsif Nam = Name_Pre then
- if Class_Present (Aspect) then
- Error_Msg_NE
- ("aspect `Pre''Class` for & is not allowed here",
- Id, E);
- Error_Msg_NE
- ("\since aspect `Pre` previously given#",
- Id, E);
+ elsif Nam = Name_Pre then
+ if Class_Present (Aspect) then
+ Error_Msg_NE
+ ("aspect `Pre''Class` for & is not allowed here",
+ Id, E);
+ Error_Msg_NE
+ ("\since aspect `Pre` previously given#",
+ Id, E);
- else
- Error_Msg_NE
- ("aspect `Pre` for & is not allowed here",
- Id, E);
- Error_Msg_NE
- ("\since aspect `Pre''Class` previously given#",
- Id, E);
+ else
+ Error_Msg_NE
+ ("aspect `Pre` for & is not allowed here",
+ Id, E);
+ Error_Msg_NE
+ ("\since aspect `Pre''Class` previously given#",
+ Id, E);
+ end if;
end if;
+
+ -- Allowed case of X and X'Class both specified
end if;
- goto Continue;
+ Next (Anod);
+ end loop;
+ end if;
+
+ -- Check some general restrictions on language defined aspects
+
+ if not Impl_Defined_Aspects (A_Id) then
+ Error_Msg_Name_1 := Nam;
+
+ -- Not allowed for renaming declarations
+
+ if Nkind (N) in N_Renaming_Declaration then
+ Error_Msg_N
+ ("aspect % not allowed for renaming declaration",
+ Aspect);
end if;
- Next (Anod);
- end loop;
+ -- Not allowed for formal type declarations
+
+ if Nkind (N) = N_Formal_Type_Declaration then
+ Error_Msg_N
+ ("aspect % not allowed for formal type declaration",
+ Aspect);
+ end if;
+ end if;
-- Copy expression for later processing by the procedures
-- Check_Aspect_At_[Freeze_Point | End_Of_Declarations]
-- Never need to delay for boolean aspects
- Delay_Required := False;
+ pragma Assert (not Delay_Required);
-- Library unit aspects. These are boolean aspects, but we
-- have to do special things with the insertion, since the
-- If not package declaration, no delay is required
- Delay_Required := False;
+ pragma Assert (not Delay_Required);
+
+ -- Aspects related to container iterators. These aspects denote
+ -- subprograms, and thus must be delayed.
+
+ when Aspect_Constant_Indexing |
+ Aspect_Variable_Indexing =>
+
+ if not Is_Type (E) or else not Is_Tagged_Type (E) then
+ Error_Msg_N ("indexing applies to a tagged type", N);
+ end if;
+
+ Aitem :=
+ Make_Attribute_Definition_Clause (Loc,
+ Name => Ent,
+ Chars => Chars (Id),
+ Expression => Relocate_Node (Expr));
+
+ Delay_Required := True;
+ Set_Is_Delayed_Aspect (Aspect);
+
+ when Aspect_Default_Iterator |
+ Aspect_Iterator_Element =>
+
+ Aitem :=
+ Make_Attribute_Definition_Clause (Loc,
+ Name => Ent,
+ Chars => Chars (Id),
+ Expression => Relocate_Node (Expr));
+
+ Delay_Required := True;
+ Set_Is_Delayed_Aspect (Aspect);
+
+ when Aspect_Implicit_Dereference =>
+ if not Is_Type (E)
+ or else not Has_Discriminants (E)
+ then
+ Error_Msg_N
+ ("Aspect must apply to a type with discriminants", N);
+ goto Continue;
+
+ else
+ declare
+ Disc : Entity_Id;
+
+ begin
+ Disc := First_Discriminant (E);
+ while Present (Disc) loop
+ if Chars (Expr) = Chars (Disc)
+ and then Ekind (Etype (Disc)) =
+ E_Anonymous_Access_Type
+ then
+ Set_Has_Implicit_Dereference (E);
+ Set_Has_Implicit_Dereference (Disc);
+ goto Continue;
+ end if;
+
+ Next_Discriminant (Disc);
+ end loop;
+
+ -- Error if no proper access discriminant.
+
+ Error_Msg_NE
+ ("not an access discriminant of&", Expr, E);
+ end;
+
+ goto Continue;
+ end if;
-- 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_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
-- to take care of it right away.
if Nkind_In (Expr, N_Integer_Literal, N_String_Literal) then
- Delay_Required := False;
+ pragma Assert (not Delay_Required);
+ null;
else
Delay_Required := True;
Set_Is_Delayed_Aspect (Aspect);
-- We don't have to play the delay game here, since the only
-- values are check names which don't get analyzed anyway.
- Delay_Required := False;
+ pragma Assert (not Delay_Required);
+
+ when Aspect_Synchronization =>
+
+ -- The aspect corresponds to pragma Implemented.
+ -- Construct the pragma
+
+ Aitem :=
+ Make_Pragma (Loc,
+ Pragma_Argument_Associations => New_List (
+ New_Occurrence_Of (E, Loc),
+ Relocate_Node (Expr)),
+ Pragma_Identifier =>
+ Make_Identifier (Sloc (Id), Name_Implemented));
+
+ pragma Assert (not Delay_Required);
-- Aspects corresponding to pragmas with two arguments, where
-- the second argument is a local name referring to the entity,
-- We don't have to play the delay game here, since the only
-- values are ON/OFF which don't get analyzed anyway.
- Delay_Required := False;
+ pragma Assert (not Delay_Required);
-- Default_Value and Default_Component_Value aspects. These
-- are specially handled because they have no corresponding
Set_Is_Delayed_Aspect (Aspect);
Set_Has_Default_Aspect (Base_Type (Entity (Ent)));
+ if Is_Scalar_Type (E) then
+ Set_Default_Aspect_Value (Entity (Ent), Expr);
+ else
+ Set_Default_Aspect_Component_Value (Entity (Ent), Expr);
+ end if;
+
+ when Aspect_Attach_Handler =>
+ Aitem :=
+ Make_Pragma (Loc,
+ Pragma_Identifier =>
+ Make_Identifier (Sloc (Id), Name_Attach_Handler),
+ Pragma_Argument_Associations =>
+ New_List (Ent, Relocate_Node (Expr)));
+
+ Set_From_Aspect_Specification (Aitem, True);
+ Set_Corresponding_Aspect (Aitem, Aspect);
+
+ pragma Assert (not Delay_Required);
+
+ when Aspect_Priority |
+ Aspect_Interrupt_Priority |
+ Aspect_Dispatching_Domain |
+ Aspect_CPU =>
+ declare
+ Pname : Name_Id;
+
+ begin
+ if A_Id = Aspect_Priority then
+ Pname := Name_Priority;
+
+ elsif A_Id = Aspect_Interrupt_Priority then
+ Pname := Name_Interrupt_Priority;
+
+ elsif A_Id = Aspect_CPU then
+ Pname := Name_CPU;
+
+ else
+ Pname := Name_Dispatching_Domain;
+ end if;
+
+ Aitem :=
+ Make_Pragma (Loc,
+ Pragma_Identifier =>
+ Make_Identifier (Sloc (Id), Pname),
+ Pragma_Argument_Associations =>
+ New_List
+ (Make_Pragma_Argument_Association
+ (Sloc => Sloc (Id),
+ Expression => Relocate_Node (Expr))));
+
+ Set_From_Aspect_Specification (Aitem, True);
+ Set_Corresponding_Aspect (Aitem, Aspect);
+
+ pragma Assert (not Delay_Required);
+ end;
+
-- Aspects Pre/Post generate Precondition/Postcondition pragmas
-- with a first argument that is the expression, and a second
-- argument that is an informative message if the test fails.
-- we generate separate Pre/Post aspects for the separate
-- clauses. Since we allow multiple pragmas, there is no
-- problem in allowing multiple Pre/Post aspects internally.
+ -- These should be treated in reverse order (B first and
+ -- A second) since they are later inserted just after N in
+ -- the order they are treated. This way, the pragma for A
+ -- ends up preceding the pragma for B, which may have an
+ -- importance for the error raised (either constraint error
+ -- or precondition error).
-- We do not do this for Pre'Class, since we have to put
-- these conditions together in a complex OR expression
- if Pname = Name_Postcondition
- or else not Class_Present (Aspect)
+ -- We do not do this in ASIS mode, as ASIS relies on the
+ -- original node representing the complete expression, when
+ -- retrieving it through the source aspect table.
+
+ if not ASIS_Mode
+ and then (Pname = Name_Postcondition
+ or else not Class_Present (Aspect))
then
while Nkind (Expr) = N_And_Then loop
Insert_After (Aspect,
- Make_Aspect_Specification (Sloc (Right_Opnd (Expr)),
+ Make_Aspect_Specification (Sloc (Left_Opnd (Expr)),
Identifier => Identifier (Aspect),
- Expression => Relocate_Node (Right_Opnd (Expr)),
+ Expression => Relocate_Node (Left_Opnd (Expr)),
Class_Present => Class_Present (Aspect),
Split_PPC => True));
- Rewrite (Expr, Relocate_Node (Left_Opnd (Expr)));
+ Rewrite (Expr, Relocate_Node (Right_Opnd (Expr)));
Eloc := Sloc (Expr);
end loop;
end if;
end if;
Set_From_Aspect_Specification (Aitem, True);
+ Set_Corresponding_Aspect (Aitem, Aspect);
Set_Is_Delayed_Aspect (Aspect);
-- For Pre/Post cases, insert immediately after the entity
when Aspect_Invariant |
Aspect_Type_Invariant =>
- -- Check placement legality
-
- if not Nkind_In (N, N_Private_Type_Declaration,
- N_Private_Extension_Declaration)
- then
- Error_Msg_N
- ("invariant aspect must apply to a private type", N);
- end if;
+ -- Analysis of the pragma will verify placement legality:
+ -- an invariant must apply to a private type, or appear in
+ -- the private part of a spec and apply to a completion.
-- Construct the pragma
end if;
Set_From_Aspect_Specification (Aitem, True);
+ Set_Corresponding_Aspect (Aitem, Aspect);
Set_Is_Delayed_Aspect (Aspect);
-- For Invariant case, insert immediately after the entity
Aspect_Static_Predicate =>
-- Construct the pragma (always a pragma Predicate, with
- -- flags recording whether
+ -- flags recording whether it is static/dynamic).
Aitem :=
Make_Pragma (Loc,
Make_Identifier (Sloc (Id), Name_Predicate));
Set_From_Aspect_Specification (Aitem, True);
-
- -- Set special flags for dynamic/static cases
-
- if A_Id = Aspect_Dynamic_Predicate then
- Set_From_Dynamic_Predicate (Aitem);
- elsif A_Id = Aspect_Static_Predicate then
- Set_From_Static_Predicate (Aitem);
- end if;
+ Set_Corresponding_Aspect (Aitem, Aspect);
-- Make sure we have a freeze node (it might otherwise be
-- missing in cases like subtype X is Y, and we would not
-- have a place to build the predicate function).
+ -- If the type is private, indicate that its completion
+ -- has a freeze node, because that is the one that will be
+ -- visible at freeze time.
+
Set_Has_Predicates (E);
+
+ if Is_Private_Type (E)
+ and then Present (Full_View (E))
+ then
+ Set_Has_Predicates (Full_View (E));
+ Set_Has_Delayed_Aspects (Full_View (E));
+ Ensure_Freeze_Node (Full_View (E));
+ end if;
+
Ensure_Freeze_Node (E);
Set_Is_Delayed_Aspect (Aspect);
Delay_Required := True;
+
+ when Aspect_Test_Case => declare
+ Args : List_Id;
+ Comp_Expr : Node_Id;
+ Comp_Assn : Node_Id;
+ New_Expr : Node_Id;
+
+ begin
+ Args := New_List;
+
+ if Nkind (Parent (N)) = N_Compilation_Unit then
+ Error_Msg_N
+ ("incorrect placement of aspect `Test_Case`", E);
+ goto Continue;
+ end if;
+
+ if Nkind (Expr) /= N_Aggregate then
+ Error_Msg_NE
+ ("wrong syntax for aspect `Test_Case` for &", Id, E);
+ goto Continue;
+ end if;
+
+ -- Make pragma expressions refer to the original aspect
+ -- expressions through the Original_Node link. This is used
+ -- in semantic analysis for ASIS mode, so that the original
+ -- expression also gets analyzed.
+
+ Comp_Expr := First (Expressions (Expr));
+ while Present (Comp_Expr) loop
+ New_Expr := Relocate_Node (Comp_Expr);
+ Set_Original_Node (New_Expr, Comp_Expr);
+ Append
+ (Make_Pragma_Argument_Association (Sloc (Comp_Expr),
+ Expression => New_Expr),
+ Args);
+ Next (Comp_Expr);
+ end loop;
+
+ Comp_Assn := First (Component_Associations (Expr));
+ while Present (Comp_Assn) loop
+ if List_Length (Choices (Comp_Assn)) /= 1
+ or else
+ Nkind (First (Choices (Comp_Assn))) /= N_Identifier
+ then
+ Error_Msg_NE
+ ("wrong syntax for aspect `Test_Case` for &", Id, E);
+ goto Continue;
+ end if;
+
+ New_Expr := Relocate_Node (Expression (Comp_Assn));
+ Set_Original_Node (New_Expr, Expression (Comp_Assn));
+ Append (Make_Pragma_Argument_Association (
+ Sloc => Sloc (Comp_Assn),
+ Chars => Chars (First (Choices (Comp_Assn))),
+ Expression => New_Expr),
+ Args);
+ Next (Comp_Assn);
+ end loop;
+
+ -- Build the test-case pragma
+
+ Aitem :=
+ Make_Pragma (Loc,
+ Pragma_Identifier =>
+ Make_Identifier (Sloc (Id), Name_Test_Case),
+ Pragma_Argument_Associations =>
+ Args);
+
+ Set_From_Aspect_Specification (Aitem, True);
+ Set_Corresponding_Aspect (Aitem, Aspect);
+ Set_Is_Delayed_Aspect (Aspect);
+
+ -- Insert immediately after the entity declaration
+
+ Insert_After (N, Aitem);
+
+ goto Continue;
+ end;
+
+ when Aspect_Dimension =>
+ Analyze_Aspect_Dimension (N, Id, Expr);
+ goto Continue;
+
+ when Aspect_Dimension_System =>
+ Analyze_Aspect_Dimension_System (N, Id, Expr);
+ goto Continue;
+
end case;
-- If a delay is required, we delay the freeze (not much point in
if Delay_Required then
if Present (Aitem) then
Set_From_Aspect_Specification (Aitem, True);
+
+ if Nkind (Aitem) = N_Pragma then
+ Set_Corresponding_Aspect (Aitem, Aspect);
+ end if;
+
Set_Is_Delayed_Aspect (Aitem);
Set_Aspect_Rep_Item (Aspect, Aitem);
end if;
else
Set_From_Aspect_Specification (Aitem, True);
+ if Nkind (Aitem) = N_Pragma then
+ Set_Corresponding_Aspect (Aitem, Aspect);
+ end if;
+
-- If this is a compilation unit, we will put the pragma in
-- the Pragmas_After list of the N_Compilation_Unit_Aux node.
-- Here if not compilation unit case
else
- -- For Pre/Post cases, insert immediately after the entity
- -- declaration, since that is the required pragma placement.
+ case A_Id is
- if A_Id in Pre_Post_Aspects then
- Insert_After (N, Aitem);
+ -- For Pre/Post cases, insert immediately after the
+ -- entity declaration, since that is the required pragma
+ -- placement.
- -- For all other cases, insert in sequence
+ when Pre_Post_Aspects =>
+ Insert_After (N, Aitem);
- else
- Insert_After (Ins_Node, Aitem);
- Ins_Node := Aitem;
- end if;
+ -- For Priority aspects, insert into the task or
+ -- protected definition, which we need to create if it's
+ -- not there. The same applies to CPU and
+ -- Dispatching_Domain but only to tasks.
+
+ when Aspect_Priority |
+ Aspect_Interrupt_Priority |
+ Aspect_Dispatching_Domain |
+ Aspect_CPU =>
+ declare
+ T : Node_Id; -- the type declaration
+ L : List_Id; -- list of decls of task/protected
+
+ begin
+ if Nkind (N) = N_Object_Declaration then
+ T := Parent (Etype (Defining_Identifier (N)));
+ else
+ T := N;
+ end if;
+
+ if Nkind (T) = N_Protected_Type_Declaration
+ and then A_Id /= Aspect_Dispatching_Domain
+ and then A_Id /= Aspect_CPU
+ then
+ pragma Assert
+ (Present (Protected_Definition (T)));
+
+ L := Visible_Declarations
+ (Protected_Definition (T));
+
+ elsif Nkind (T) = N_Task_Type_Declaration then
+ if No (Task_Definition (T)) then
+ Set_Task_Definition
+ (T,
+ Make_Task_Definition
+ (Sloc (T),
+ Visible_Declarations => New_List,
+ End_Label => Empty));
+ end if;
+
+ L := Visible_Declarations (Task_Definition (T));
+
+ else
+ raise Program_Error;
+ end if;
+
+ Prepend (Aitem, To => L);
+
+ -- Analyze rewritten pragma. Otherwise, its
+ -- analysis is done too late, after the task or
+ -- protected object has been created.
+
+ Analyze (Aitem);
+ end;
+
+ -- For all other cases, insert in sequence
+
+ when others =>
+ Insert_After (Ins_Node, Aitem);
+ Ins_Node := Aitem;
+ end case;
end if;
end if;
end;
-- and if so gives an error message. If there is a duplicate, True is
-- returned, otherwise if there is no error, False is returned.
+ procedure Check_Indexing_Functions;
+ -- Check that the function in Constant_Indexing or Variable_Indexing
+ -- attribute has the proper type structure. If the name is overloaded,
+ -- check that all interpretations are legal.
+
+ procedure Check_Iterator_Functions;
+ -- Check that there is a single function in Default_Iterator attribute
+ -- has the proper type structure.
+
+ function Check_Primitive_Function (Subp : Entity_Id) return Boolean;
+ -- Common legality check for the previous two
+
-----------------------------------
-- Analyze_Stream_TSS_Definition --
-----------------------------------
end if;
end Analyze_Stream_TSS_Definition;
+ ------------------------------
+ -- Check_Indexing_Functions --
+ ------------------------------
+
+ procedure Check_Indexing_Functions is
+
+ procedure Check_One_Function (Subp : Entity_Id);
+ -- Check one possible interpretation
+
+ ------------------------
+ -- Check_One_Function --
+ ------------------------
+
+ procedure Check_One_Function (Subp : Entity_Id) is
+ Default_Element : constant Node_Id :=
+ Find_Aspect
+ (Etype (First_Formal (Subp)),
+ Aspect_Iterator_Element);
+
+ begin
+ if not Check_Primitive_Function (Subp) then
+ Error_Msg_NE
+ ("aspect Indexing requires a function that applies to type&",
+ Subp, Ent);
+ end if;
+
+ -- An indexing function must return either the default element of
+ -- the container, or a reference type.
+
+ if Present (Default_Element) then
+ Analyze (Default_Element);
+ if Is_Entity_Name (Default_Element)
+ and then Covers (Entity (Default_Element), Etype (Subp))
+ then
+ return;
+ end if;
+ end if;
+
+ -- Otherwise the return type must be a reference type.
+
+ if not Has_Implicit_Dereference (Etype (Subp)) then
+ Error_Msg_N
+ ("function for indexing must return a reference type", Subp);
+ end if;
+ end Check_One_Function;
+
+ -- Start of processing for Check_Indexing_Functions
+
+ begin
+ if In_Instance then
+ return;
+ end if;
+
+ Analyze (Expr);
+
+ if not Is_Overloaded (Expr) then
+ Check_One_Function (Entity (Expr));
+
+ else
+ declare
+ I : Interp_Index;
+ It : Interp;
+
+ begin
+ Get_First_Interp (Expr, I, It);
+ while Present (It.Nam) loop
+
+ -- Note that analysis will have added the interpretation
+ -- that corresponds to the dereference. We only check the
+ -- subprogram itself.
+
+ if Is_Overloadable (It.Nam) then
+ Check_One_Function (It.Nam);
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
+ end;
+ end if;
+ end Check_Indexing_Functions;
+
+ ------------------------------
+ -- Check_Iterator_Functions --
+ ------------------------------
+
+ procedure Check_Iterator_Functions is
+ Default : Entity_Id;
+
+ function Valid_Default_Iterator (Subp : Entity_Id) return Boolean;
+ -- Check one possible interpretation for validity
+
+ ----------------------------
+ -- Valid_Default_Iterator --
+ ----------------------------
+
+ function Valid_Default_Iterator (Subp : Entity_Id) return Boolean is
+ Formal : Entity_Id;
+
+ begin
+ if not Check_Primitive_Function (Subp) then
+ return False;
+ else
+ Formal := First_Formal (Subp);
+ end if;
+
+ -- False if any subsequent formal has no default expression
+
+ Formal := Next_Formal (Formal);
+ while Present (Formal) loop
+ if No (Expression (Parent (Formal))) then
+ return False;
+ end if;
+
+ Next_Formal (Formal);
+ end loop;
+
+ -- True if all subsequent formals have default expressions
+
+ return True;
+ end Valid_Default_Iterator;
+
+ -- Start of processing for Check_Iterator_Functions
+
+ begin
+ Analyze (Expr);
+
+ if not Is_Entity_Name (Expr) then
+ Error_Msg_N ("aspect Iterator must be a function name", Expr);
+ end if;
+
+ if not Is_Overloaded (Expr) then
+ if not Check_Primitive_Function (Entity (Expr)) then
+ Error_Msg_NE
+ ("aspect Indexing requires a function that applies to type&",
+ Entity (Expr), Ent);
+ end if;
+
+ if not Valid_Default_Iterator (Entity (Expr)) then
+ Error_Msg_N ("improper function for default iterator", Expr);
+ end if;
+
+ else
+ Default := Empty;
+ declare
+ I : Interp_Index;
+ It : Interp;
+
+ begin
+ Get_First_Interp (Expr, I, It);
+ while Present (It.Nam) loop
+ if not Check_Primitive_Function (It.Nam)
+ or else not Valid_Default_Iterator (It.Nam)
+ then
+ Remove_Interp (I);
+
+ elsif Present (Default) then
+ Error_Msg_N ("default iterator must be unique", Expr);
+
+ else
+ Default := It.Nam;
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
+ end;
+
+ if Present (Default) then
+ Set_Entity (Expr, Default);
+ Set_Is_Overloaded (Expr, False);
+ end if;
+ end if;
+ end Check_Iterator_Functions;
+
+ -------------------------------
+ -- Check_Primitive_Function --
+ -------------------------------
+
+ function Check_Primitive_Function (Subp : Entity_Id) return Boolean is
+ Ctrl : Entity_Id;
+
+ begin
+ if Ekind (Subp) /= E_Function then
+ return False;
+ end if;
+
+ if No (First_Formal (Subp)) then
+ return False;
+ else
+ Ctrl := Etype (First_Formal (Subp));
+ end if;
+
+ if Ctrl = Ent
+ or else Ctrl = Class_Wide_Type (Ent)
+ or else
+ (Ekind (Ctrl) = E_Anonymous_Access_Type
+ and then
+ (Designated_Type (Ctrl) = Ent
+ or else Designated_Type (Ctrl) = Class_Wide_Type (Ent)))
+ then
+ null;
+
+ else
+ return False;
+ end if;
+
+ return True;
+ end Check_Primitive_Function;
+
----------------------
-- Duplicate_Clause --
----------------------
Set_Analyzed (N, True);
end if;
- -- Process Ignore_Rep_Clauses option (we also ignore rep clauses in
- -- CodePeer mode, since they are not relevant in that context).
+ -- Ignore some selected attributes in CodePeer mode since they are not
+ -- relevant in this context.
- if Ignore_Rep_Clauses or CodePeer_Mode then
+ if CodePeer_Mode then
+ case Id is
+
+ -- Ignore Component_Size in CodePeer mode, to avoid changing the
+ -- internal representation of types by implicitly packing them.
+
+ when Attribute_Component_Size =>
+ Rewrite (N, Make_Null_Statement (Sloc (N)));
+ return;
+
+ when others =>
+ null;
+ end case;
+ end if;
+
+ -- Process Ignore_Rep_Clauses option
+
+ if Ignore_Rep_Clauses then
case Id is
-- The following should be ignored. They do not affect legality
Rewrite (N, Make_Null_Statement (Sloc (N)));
return;
- -- We do not want too ignore 'Small in CodePeer_Mode, since it
- -- has an impact on the exact computations performed.
-
- -- Perhaps 'Small should also not be ignored by
- -- Ignore_Rep_Clauses ???
+ -- Perhaps 'Small should not be ignored by Ignore_Rep_Clauses ???
when Attribute_Small =>
if Ignore_Rep_Clauses then
-- 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
U_Ent := Underlying_Type (Ent);
end if;
- -- Complete other routine error checks
+ -- Avoid cascaded error
if Etype (Nam) = Any_Type then
return;
+ -- Must be declared in current scope
+
elsif Scope (Ent) /= Current_Scope then
Error_Msg_N ("entity must be declared in this scope", Nam);
return;
+ -- Must not be a source renaming (we do have some cases where the
+ -- expander generates a renaming, and those cases are OK, in such
+ -- cases any attribute applies to the renamed object as well).
+
+ elsif Is_Object (Ent)
+ and then Present (Renamed_Object (Ent))
+ then
+ -- Case of renamed object from source, this is an error
+
+ if Comes_From_Source (Renamed_Object (Ent)) then
+ Get_Name_String (Chars (N));
+ Error_Msg_Strlen := Name_Len;
+ Error_Msg_String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
+ Error_Msg_N
+ ("~ clause not allowed for a renaming declaration "
+ & "(RM 13.1(6))", Nam);
+ return;
+
+ -- For the case of a compiler generated renaming, the attribute
+ -- definition clause applies to the renamed object created by the
+ -- expander. The easiest general way to handle this is to create a
+ -- copy of the attribute definition clause for this object.
+
+ else
+ Insert_Action (N,
+ Make_Attribute_Definition_Clause (Loc,
+ Name =>
+ New_Occurrence_Of (Entity (Renamed_Object (Ent)), Loc),
+ Chars => Chars (N),
+ Expression => Duplicate_Subexpr (Expression (N))));
+ end if;
+
+ -- If no underlying entity, use entity itself, applies to some
+ -- previously detected error cases ???
+
elsif No (U_Ent) then
U_Ent := Ent;
+ -- Cannot specify for a subtype (exception Object/Value_Size)
+
elsif Is_Type (U_Ent)
and then not Is_First_Subtype (U_Ent)
and then Id /= Attribute_Object_Size
then
Error_Msg_N ("constant overlays a variable?", Expr);
- elsif Present (Renamed_Object (U_Ent)) then
- Error_Msg_N
- ("address clause not allowed"
- & " for a renaming declaration (RM 13.1(6))", Nam);
- return;
-
-- Imported variables can have an address clause, but then
-- the import is pretty meaningless except to suppress
-- initializations, so we do not need such variables to
-- Alignment attribute definition clause
when Attribute_Alignment => Alignment : declare
- Align : constant Uint := Get_Alignment_Value (Expr);
+ Align : constant Uint := Get_Alignment_Value (Expr);
+ Max_Align : constant Uint := UI_From_Int (Maximum_Alignment);
begin
FOnly := True;
elsif Align /= No_Uint then
Set_Has_Alignment_Clause (U_Ent);
- Set_Alignment (U_Ent, Align);
+
+ -- Tagged type case, check for attempt to set alignment to a
+ -- value greater than Max_Align, and reset if so.
+
+ if Is_Tagged_Type (U_Ent) and then Align > Max_Align then
+ Error_Msg_N
+ ("?alignment for & set to Maximum_Aligment", Nam);
+ Set_Alignment (U_Ent, Max_Align);
+
+ -- All other cases
+
+ else
+ Set_Alignment (U_Ent, Align);
+ end if;
-- For an array type, U_Ent is the first subtype. In that case,
-- also set the alignment of the anonymous base type so that
end if;
end Component_Size_Case;
+ -----------------------
+ -- Constant_Indexing --
+ -----------------------
+
+ when Attribute_Constant_Indexing =>
+ Check_Indexing_Functions;
+
+ ----------------------
+ -- Default_Iterator --
+ ----------------------
+
+ when Attribute_Default_Iterator => Default_Iterator : declare
+ Func : Entity_Id;
+
+ begin
+ if not Is_Tagged_Type (U_Ent) then
+ Error_Msg_N
+ ("aspect Default_Iterator applies to tagged type", Nam);
+ end if;
+
+ Check_Iterator_Functions;
+
+ Analyze (Expr);
+
+ if not Is_Entity_Name (Expr)
+ or else Ekind (Entity (Expr)) /= E_Function
+ then
+ Error_Msg_N ("aspect Iterator must be a function", Expr);
+ else
+ Func := Entity (Expr);
+ end if;
+
+ if No (First_Formal (Func))
+ or else Etype (First_Formal (Func)) /= U_Ent
+ then
+ Error_Msg_NE
+ ("Default Iterator must be a primitive of&", Func, U_Ent);
+ end if;
+ end Default_Iterator;
+
------------------
-- External_Tag --
------------------
end if;
end External_Tag;
+ --------------------------
+ -- Implicit_Dereference --
+ --------------------------
+
+ when Attribute_Implicit_Dereference =>
+
+ -- Legality checks already performed at the point of
+ -- the type declaration, aspect is not delayed.
+
+ null;
+
-----------
-- Input --
-----------
Analyze_Stream_TSS_Definition (TSS_Stream_Input);
Set_Has_Specified_Stream_Input (Ent);
+ ----------------------
+ -- Iterator_Element --
+ ----------------------
+
+ when Attribute_Iterator_Element =>
+ Analyze (Expr);
+
+ if not Is_Entity_Name (Expr)
+ or else not Is_Type (Entity (Expr))
+ then
+ Error_Msg_N ("aspect Iterator_Element must be a type", Expr);
+ end if;
+
-------------------
-- Machine_Radix --
-------------------
Set_Esize (U_Ent, Size);
Set_Has_Object_Size_Clause (U_Ent);
- Alignment_Check_For_Esize_Change (U_Ent);
+ Alignment_Check_For_Size_Change (U_Ent, Size);
end if;
end Object_Size;
-- (object size) unset, the back end will set it from the
-- size and alignment in an appropriate manner.
+ -- In both cases, we check whether the alignment must be
+ -- reset in the wake of the size change.
+
if Is_Elementary_Type (U_Ent) then
if Size <= System_Storage_Unit then
Init_Esize (U_Ent, System_Storage_Unit);
Set_Esize (U_Ent, (Size + 63) / 64 * 64);
end if;
- Alignment_Check_For_Esize_Change (U_Ent);
+ Alignment_Check_For_Size_Change (U_Ent, Esize (U_Ent));
+ else
+ Alignment_Check_For_Size_Change (U_Ent, Size);
end if;
-- For objects, set Esize only
-- 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_Type))
+ 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 --
end if;
end Value_Size;
+ -----------------------
+ -- Variable_Indexing --
+ -----------------------
+
+ when Attribute_Variable_Indexing =>
+ Check_Indexing_Functions;
+
-----------
-- Write --
-----------
-- No statements other than code statements, pragmas, and labels.
-- Again we allow certain internally generated statements.
+ -- In Ada 2012, qualified expressions are names, and the code
+ -- statement is initially parsed as a procedure call.
+
Stmt := First (Statements (HSS));
while Present (Stmt) loop
StmtO := Original_Node (Stmt);
- if Comes_From_Source (StmtO)
+
+ -- A procedure call transformed into a code statement is OK.
+
+ if Ada_Version >= Ada_2012
+ and then Nkind (StmtO) = N_Procedure_Call_Statement
+ and then Nkind (Name (StmtO)) = N_Qualified_Expression
+ then
+ null;
+
+ elsif Comes_From_Source (StmtO)
and then not Nkind_In (StmtO, N_Pragma,
N_Label,
N_Code_Statement)
if Nkind (Ritem) = N_Aspect_Specification
and then Entity (Ritem) = E
and then Is_Delayed_Aspect (Ritem)
+ and then Scope (E) = Current_Scope
then
Check_Aspect_At_Freeze_Point (Ritem);
end if;
-- This seems dubious, this destroys the source tree in a manner
-- not detectable by ASIS ???
- if Operating_Mode = Check_Semantics
- and then ASIS_Mode
- then
+ if Operating_Mode = Check_Semantics and then ASIS_Mode then
AtM_Nod :=
Make_Attribute_Definition_Clause (Loc,
Name => New_Reference_To (Base_Type (Rectype), Loc),
-- (this is an error that will be caught elsewhere);
Append_To (Private_Decls, PBody);
+
+ -- If the invariant appears on the full view of a type, the
+ -- analysis of the private part is complete, and we must
+ -- analyze the new body explicitly.
+
+ if In_Private_Part (Current_Scope) then
+ Analyze (PBody);
+ end if;
end if;
end if;
end Build_Invariant_Procedure;
if Nkind (Ritem) = N_Pragma
and then Pragma_Name (Ritem) = Name_Predicate
then
- if From_Dynamic_Predicate (Ritem) then
- Dynamic_Predicate_Present := True;
- elsif From_Static_Predicate (Ritem) then
- Static_Predicate_Present := Ritem;
+ if Present (Corresponding_Aspect (Ritem)) then
+ case Chars (Identifier (Corresponding_Aspect (Ritem))) is
+ when Name_Dynamic_Predicate =>
+ Dynamic_Predicate_Present := True;
+ when Name_Static_Predicate =>
+ Static_Predicate_Present := Ritem;
+ when others =>
+ null;
+ end case;
end if;
-- Acquire arguments
Arg1 := Get_Pragma_Arg (Arg1);
Arg2 := Get_Pragma_Arg (Arg2);
- -- See if this predicate pragma is for the current type
+ -- See if this predicate pragma is for the current type or for
+ -- its full view. A predicate on a private completion is placed
+ -- on the partial view beause this is the visible entity that
+ -- is frozen.
- if Entity (Arg1) = Typ then
+ if Entity (Arg1) = Typ
+ or else Full_View (Entity (Arg1)) = Typ
+ then
-- We have a match, this entry is for our subtype
Set_Has_Predicates (SId);
Set_Predicate_Function (Typ, SId);
+ -- The predicate function is shared between views of a type.
+
+ if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then
+ Set_Predicate_Function (Full_View (Typ), SId);
+ end if;
+
Spec :=
Make_Function_Specification (Loc,
Defining_Unit_Name => SId,
Ident : constant Node_Id := Identifier (ASN);
Freeze_Expr : constant Node_Id := Expression (ASN);
- -- Preanalyzed expression from call to Check_Aspect_At_Freeze_Point
+ -- Expression from call to Check_Aspect_At_Freeze_Point
End_Decl_Expr : constant Node_Id := Entity (Ident);
-- Expression to be analyzed at end of declarations
Analyze (End_Decl_Expr);
Err := Entity (End_Decl_Expr) /= Entity (Freeze_Expr);
+ elsif A_Id = Aspect_Variable_Indexing or else
+ A_Id = Aspect_Constant_Indexing or else
+ A_Id = Aspect_Default_Iterator or else
+ A_Id = Aspect_Iterator_Element
+ then
+ -- Make type unfrozen before analysis, to prevent spurious errors
+ -- about late attributes.
+
+ Set_Is_Frozen (Ent, False);
+ Analyze (End_Decl_Expr);
+ Analyze (Aspect_Rep_Item (ASN));
+ Set_Is_Frozen (Ent, True);
+
+ -- If the end of declarations comes before any other freeze
+ -- point, the Freeze_Expr is not analyzed: no check needed.
+
+ Err :=
+ Analyzed (Freeze_Expr)
+ and then not In_Instance
+ and then Entity (End_Decl_Expr) /= Entity (Freeze_Expr);
+
-- All other cases
else
- Preanalyze_Spec_Expression (End_Decl_Expr, T);
+ -- In a generic context the aspect expressions have not been
+ -- preanalyzed, so do it now. There are no conformance checks
+ -- to perform in this case.
+
+ if No (T) then
+ Check_Aspect_At_Freeze_Point (ASN);
+ return;
+
+ -- The default values attributes may be defined in the private part,
+ -- and the analysis of the expression may take place when only the
+ -- partial view is visible. The expression must be scalar, so use
+ -- the full view to resolve.
+
+ elsif (A_Id = Aspect_Default_Value
+ or else
+ A_Id = Aspect_Default_Component_Value)
+ and then Is_Private_Type (T)
+ then
+ Preanalyze_Spec_Expression (End_Decl_Expr, Full_View (T));
+ else
+ Preanalyze_Spec_Expression (End_Decl_Expr, T);
+ end if;
+
Err := not Fully_Conformant_Expressions (End_Decl_Expr, Freeze_Expr);
end if;
when Boolean_Aspects =>
raise Program_Error;
+ -- Test_Case aspect applies to entries and subprograms, hence should
+ -- never be delayed.
+
+ when Aspect_Test_Case =>
+ raise Program_Error;
+
+ when Aspect_Attach_Handler =>
+ T := RTE (RE_Interrupt_ID);
+
-- Default_Value is resolved with the type entity in question
when Aspect_Default_Value =>
when Aspect_Bit_Order =>
T := RTE (RE_Bit_Order);
+ when Aspect_CPU =>
+ T := RTE (RE_CPU_Range);
+
+ when Aspect_Dispatching_Domain =>
+ T := RTE (RE_Dispatching_Domain);
+
when Aspect_External_Tag =>
T := Standard_String;
+ when Aspect_Priority | Aspect_Interrupt_Priority =>
+ T := Standard_Integer;
+
+ 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));
- when
- Aspect_Alignment |
+ when Aspect_Alignment |
Aspect_Component_Size |
Aspect_Machine_Radix |
Aspect_Object_Size |
Analyze (Expression (ASN));
return;
- -- Suppress/Unsupress/Warnings should never be delayed
+ -- Same for Iterator aspects, where the expression is a function
+ -- name. Legality rules are checked separately.
+
+ when Aspect_Constant_Indexing |
+ Aspect_Default_Iterator |
+ Aspect_Iterator_Element |
+ Aspect_Implicit_Dereference |
+ Aspect_Variable_Indexing =>
+ Analyze (Expression (ASN));
+ return;
+
+ -- Suppress/Unsuppress/Synchronization/Warnings should not be delayed
- when Aspect_Suppress |
- Aspect_Unsuppress |
- Aspect_Warnings =>
+ when Aspect_Suppress |
+ Aspect_Unsuppress |
+ Aspect_Synchronization |
+ Aspect_Warnings =>
raise Program_Error;
-- Pre/Post/Invariant/Predicate take boolean expressions
Aspect_Static_Predicate |
Aspect_Type_Invariant =>
T := Standard_Boolean;
+
+ when Aspect_Dimension |
+ Aspect_Dimension_System =>
+ raise Program_Error;
+
end case;
-- Do the preanalyze call
-- Start of processing for Rep_Item_Too_Late
begin
- -- First make sure entity is not frozen (RM 13.1(9)). Exclude imported
- -- types, which may be frozen if they appear in a representation clause
- -- for a local type.
+ -- First make sure entity is not frozen (RM 13.1(9))
if Is_Frozen (T)
+
+ -- Exclude imported types, which may be frozen if they appear in a
+ -- representation clause for a local type.
+
and then not From_With_Type (T)
+
+ -- Exclude generated entitiesa (not coming from source). The common
+ -- case is when we generate a renaming which prematurely freezes the
+ -- renamed internal entity, but we still want to be able to set copies
+ -- of attribute values such as Size/Alignment.
+
+ and then Comes_From_Source (T)
then
Too_Late;
S := First_Subtype (T);
Target := Ancestor_Subtype (Etype (Act_Unit));
-- If either type is generic, the instantiation happens within a generic
- -- unit, and there is nothing to check. The proper check
- -- will happen when the enclosing generic is instantiated.
+ -- unit, and there is nothing to check. The proper check will happen
+ -- when the enclosing generic is instantiated.
if Is_Generic_Type (Source) or else Is_Generic_Type (Target) then
return;
end if;
-- If unchecked conversion to access type, and access type is declared
- -- in the same unit as the unchecked conversion, then set the
- -- No_Strict_Aliasing flag (no strict aliasing is implicit in this
- -- situation).
+ -- in the same unit as the unchecked conversion, then set the flag
+ -- No_Strict_Aliasing (no strict aliasing is implicit here)
if Is_Access_Type (Target) and then
In_Same_Source_Unit (Target, N)
Set_No_Strict_Aliasing (Implementation_Base_Type (Target));
end if;
- -- Generate N_Validate_Unchecked_Conversion node for back end in
- -- case the back end needs to perform special validation checks.
+ -- Generate N_Validate_Unchecked_Conversion node for back end in case
+ -- the back end needs to perform special validation checks.
- -- Shouldn't this be in Exp_Ch13, since the check only gets done
- -- if we have full expansion and the back end is called ???
+ -- Shouldn't this be in Exp_Ch13, since the check only gets done if we
+ -- have full expansion and the back end is called ???
Vnode :=
Make_Validate_Unchecked_Conversion (Sloc (N));
Source : constant Entity_Id := T.Source;
Target : constant Entity_Id := T.Target;
- Source_Siz : Uint;
- Target_Siz : Uint;
+ Source_Siz : Uint;
+ Target_Siz : Uint;
begin
-- This validation check, which warns if we have unequal sizes for
OSDN Git Service
