-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2010, 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; use Sem;
with Sem_Aux; use Sem_Aux;
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;
with Ttypes; use Ttypes;
with Tbuild; use Tbuild;
with Urealp; use Urealp;
+with Warnsw; use Warnsw;
with GNAT.Heap_Sort_G;
-- 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.
- -----------------------
- -- Local Subprograms --
- -----------------------
-
- procedure Build_Predicate_Function
- (Typ : Entity_Id;
- FDecl : out Node_Id;
- FBody : out Node_Id);
+ procedure Build_Predicate_Function (Typ : Entity_Id; N : Node_Id);
-- If Typ has predicates (indicated by Has_Predicates being set for Typ,
-- then either there are pragma Invariant entries on the rep chain for the
- -- type (note that Predicate aspects are converted to pragam Predicate), or
- -- there are inherited aspects from a parent type, or ancestor subtypes,
- -- or interfaces. This procedure builds the spec and body for the Predicate
- -- function that tests these predicates, returning them in PDecl and Pbody
- -- and setting Predicate_Procedure for Typ. In some error situations no
- -- procedure is built, in which case PDecl/PBody are empty on return.
+ -- type (note that Predicate aspects are converted to pragma Predicate), or
+ -- there are inherited aspects from a parent type, or ancestor subtypes.
+ -- This procedure builds the spec and body for the Predicate function that
+ -- tests these predicates. N is the freeze node for the type. The spec of
+ -- the function is inserted before the freeze node, and the body of the
+ -- function is inserted after the freeze node.
+
+ procedure Build_Static_Predicate
+ (Typ : Entity_Id;
+ Expr : Node_Id;
+ Nam : Name_Id);
+ -- Given a predicated type Typ, where Typ is a discrete static subtype,
+ -- whose predicate expression is Expr, tests if Expr is a static predicate,
+ -- and if so, builds the predicate range list. Nam is the name of the one
+ -- argument to the predicate function. Occurrences of the type name in the
+ -- predicate expression have been replaced by identifier references to this
+ -- name, which is unique, so any identifier with Chars matching Nam must be
+ -- a reference to the type. If the predicate is non-static, this procedure
+ -- returns doing nothing. If the predicate is static, then the predicate
+ -- list is stored in Static_Predicate (Typ), and the Expr is rewritten as
+ -- a canonicalized membership operation.
function Get_Alignment_Value (Expr : Node_Id) return Uint;
-- Given the expression for an alignment value, returns the corresponding
-- renaming_as_body. For tagged types, the specification is one of the
-- primitive specs.
+ generic
+ with procedure Replace_Type_Reference (N : Node_Id);
+ procedure Replace_Type_References_Generic (N : Node_Id; TName : Name_Id);
+ -- This is used to scan an expression for a predicate or invariant aspect
+ -- replacing occurrences of the name TName (the name of the subtype to
+ -- which the aspect applies) with appropriate references to the parameter
+ -- of the predicate function or invariant procedure. The procedure passed
+ -- as a generic parameter does the actual replacement of node N, which is
+ -- either a simple direct reference to TName, or a selected component that
+ -- represents an appropriately qualified occurrence of TName.
+
procedure Set_Biased
(E : Entity_Id;
N : Node_Id;
----------------------------------------------
-- 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;
-- The entity of the object being overlaid
Off : Boolean;
- -- Whether the address is offseted within Y
+ -- Whether the address is offset within Y
end record;
package Address_Clause_Checks is new Table.Table (
-- 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);
declare
Fbit : constant Uint :=
Static_Integer (First_Bit (CC));
+ Lbit : constant Uint :=
+ Static_Integer (Last_Bit (CC));
begin
- -- Case of component with size > max machine scalar
+ -- Case of component with last bit >= max machine scalar
- if Esize (Comp) > Max_Machine_Scalar_Size then
+ if Lbit >= Max_Machine_Scalar_Size then
- -- Must begin on byte boundary
+ -- This is allowed only if first bit is zero, and
+ -- last bit + 1 is a multiple of storage unit size.
- if Fbit mod SSU /= 0 then
- Error_Msg_N
- ("illegal first bit value for "
- & "reverse bit order",
- First_Bit (CC));
- Error_Msg_Uint_1 := SSU;
- Error_Msg_Uint_2 := Max_Machine_Scalar_Size;
+ if Fbit = 0 and then (Lbit + 1) mod SSU = 0 then
- Error_Msg_N
- ("\must be a multiple of ^ "
- & "if size greater than ^",
- First_Bit (CC));
+ -- This is the case to give a warning if enabled
- -- Must end on byte boundary
+ if Warn_On_Reverse_Bit_Order then
+ Error_Msg_N
+ ("multi-byte field specified with "
+ & " non-standard Bit_Order?", CC);
+
+ if Bytes_Big_Endian then
+ Error_Msg_N
+ ("\bytes are not reversed "
+ & "(component is big-endian)?", CC);
+ else
+ Error_Msg_N
+ ("\bytes are not reversed "
+ & "(component is little-endian)?", CC);
+ end if;
+ end if;
- elsif Esize (Comp) mod SSU /= 0 then
- Error_Msg_N
- ("illegal last bit value for "
- & "reverse bit order",
- Last_Bit (CC));
- Error_Msg_Uint_1 := SSU;
- Error_Msg_Uint_2 := Max_Machine_Scalar_Size;
+ -- Give error message for RM 13.4.1(10) violation
- Error_Msg_N
- ("\must be a multiple of ^ if size "
- & "greater than ^",
- Last_Bit (CC));
+ else
+ Error_Msg_FE
+ ("machine scalar rules not followed for&",
+ First_Bit (CC), Comp);
- -- OK, give warning if enabled
+ Error_Msg_Uint_1 := Lbit;
+ Error_Msg_Uint_2 := Max_Machine_Scalar_Size;
+ Error_Msg_F
+ ("\last bit (^) exceeds maximum machine "
+ & "scalar size (^)",
+ First_Bit (CC));
- elsif Warn_On_Reverse_Bit_Order then
- Error_Msg_N
- ("multi-byte field specified with "
- & " non-standard Bit_Order?", CC);
+ if (Lbit + 1) mod SSU /= 0 then
+ Error_Msg_Uint_1 := SSU;
+ Error_Msg_F
+ ("\and is not a multiple of Storage_Unit (^) "
+ & "(RM 13.4.1(10))",
+ First_Bit (CC));
- if Bytes_Big_Endian then
- Error_Msg_N
- ("\bytes are not reversed "
- & "(component is big-endian)?", CC);
else
- Error_Msg_N
- ("\bytes are not reversed "
- & "(component is little-endian)?", CC);
+ Error_Msg_Uint_1 := Fbit;
+ Error_Msg_F
+ ("\and first bit (^) is non-zero "
+ & "(RM 13.4.1(10))",
+ First_Bit (CC));
end if;
end if;
- -- Case where size is not greater than max machine
- -- scalar. For now, we just count these.
+ -- OK case of machine scalar related component clause,
+ -- For now, just count them.
else
Num_CC := Num_CC + 1;
-- Start of processing for Sort_CC
begin
- -- Collect the component clauses
+ -- Collect the machine scalar relevant component clauses
Num_CC := 0;
Comp := First_Component_Or_Discriminant (R);
while Present (Comp) loop
- if Present (Component_Clause (Comp))
- and then Esize (Comp) <= Max_Machine_Scalar_Size
- then
- Num_CC := Num_CC + 1;
- Comps (Num_CC) := Comp;
- end if;
+ declare
+ CC : constant Node_Id := Component_Clause (Comp);
+
+ begin
+ -- Collect only component clauses whose last bit is less
+ -- than machine scalar size. Any component clause whose
+ -- last bit exceeds this value does not take part in
+ -- machine scalar layout considerations. The test for
+ -- Error_Posted makes sure we exclude component clauses
+ -- for which we already posted an error.
+
+ if Present (CC)
+ and then not Error_Posted (Last_Bit (CC))
+ and then Static_Integer (Last_Bit (CC)) <
+ Max_Machine_Scalar_Size
+ then
+ Num_CC := Num_CC + 1;
+ Comps (Num_CC) := Comp;
+ end if;
+ end;
Next_Component_Or_Discriminant (Comp);
end loop;
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 --
-----------------------------------
- procedure Analyze_Aspect_Specifications
- (N : Node_Id;
- E : Entity_Id;
- L : List_Id)
- is
+ procedure Analyze_Aspect_Specifications (N : Node_Id; E : Entity_Id) is
Aspect : Node_Id;
Aitem : Node_Id;
Ent : Node_Id;
+ L : constant List_Id := Aspect_Specifications (N);
+
Ins_Node : Node_Id := N;
-- 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 preanalyze the relevant argument, and then attach
- -- the corresponding pragma/attribute definition clause to the aspect
- -- specification node, which is then placed in the Rep Item chain.
- -- In this case we mark the entity with the Has_Delayed_Aspects flag,
- -- and we evaluate the rep item at the freeze point.
+ -- freeze point, we attach the corresponding pragma/attribute definition
+ -- clause to the aspect specification node, which is then placed in the
+ -- Rep Item chain. In this case we mark the entity by setting the flag
+ -- Has_Delayed_Aspects and we evaluate the rep item at the freeze point.
-- If no delay is required, we just insert the pragma or attribute
-- after the declaration, and it will get processed by the normal
-- 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
- -- Return if no aspects
-
- if L = No_List then
- return;
- end if;
-
- -- Return if already analyzed (avoids duplicate calls in some cases
- -- where type declarations get rewritten and proessed twice).
-
- if Analyzed (N) then
- return;
- end if;
+ pragma Assert (Present (L));
- -- Loop through apsects
+ -- Loop through aspects
Aspect := First (L);
- while Present (Aspect) loop
+ Aspect_Loop : while Present (Aspect) loop
declare
Loc : constant Source_Ptr := Sloc (Aspect);
Id : constant Node_Id := Identifier (Aspect);
Nam : constant Name_Id := Chars (Id);
A_Id : constant Aspect_Id := Get_Aspect_Id (Nam);
Anod : Node_Id;
- T : Entity_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
+ -- derived type, which improperly tries to cancel an aspect
+ -- inherited from the parent;
+
+ -----------------------------------------
+ -- Check_False_Aspect_For_Derived_Type --
+ -----------------------------------------
+
+ procedure Check_False_Aspect_For_Derived_Type is
+ begin
+ -- We are only checking derived types
+
+ if not Is_Derived_Type (E) then
+ return;
+ end if;
+
+ case A_Id is
+ when Aspect_Atomic | Aspect_Shared =>
+ if not Is_Atomic (E) then
+ return;
+ end if;
+
+ when Aspect_Atomic_Components =>
+ if not Has_Atomic_Components (E) then
+ return;
+ end if;
+
+ when Aspect_Discard_Names =>
+ if not Discard_Names (E) then
+ return;
+ end if;
+
+ when Aspect_Pack =>
+ if not Is_Packed (E) then
+ return;
+ end if;
+
+ when Aspect_Unchecked_Union =>
+ if not Is_Unchecked_Union (E) then
+ return;
+ end if;
+
+ when Aspect_Volatile =>
+ if not Is_Volatile (E) then
+ return;
+ end if;
+
+ when Aspect_Volatile_Components =>
+ if not Has_Volatile_Components (E) then
+ return;
+ end if;
+
+ when others =>
+ return;
+ end case;
+
+ -- Fall through means we are canceling an inherited aspect
+
+ Error_Msg_Name_1 := Nam;
+ Error_Msg_NE
+ ("derived type& inherits aspect%, cannot cancel", Expr, E);
+ end Check_False_Aspect_For_Derived_Type;
+
+ -- Start of processing for Aspect_Loop
begin
+ -- Skip aspect if already analyzed (not clear if this is needed)
+
+ if Analyzed (Aspect) then
+ 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 Nam = 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]
+
+ Set_Entity (Id, New_Copy_Tree (Expr));
-- Processing based on specific aspect
raise Program_Error;
-- Aspects taking an optional boolean argument. For all of
- -- these we just create a matching pragma and insert it,
- -- setting flag Cancel_Aspect if the expression is False.
-
- when Aspect_Ada_2005 |
- Aspect_Ada_2012 |
- Aspect_Atomic |
- Aspect_Atomic_Components |
- Aspect_Discard_Names |
- Aspect_Favor_Top_Level |
- Aspect_Inline |
- Aspect_Inline_Always |
- Aspect_No_Return |
- Aspect_Pack |
- Aspect_Persistent_BSS |
- Aspect_Preelaborable_Initialization |
- Aspect_Pure_Function |
- Aspect_Shared |
- Aspect_Suppress_Debug_Info |
- Aspect_Unchecked_Union |
- Aspect_Universal_Aliasing |
- Aspect_Unmodified |
- Aspect_Unreferenced |
- Aspect_Unreferenced_Objects |
- Aspect_Volatile |
- Aspect_Volatile_Components =>
+ -- these we just create a matching pragma and insert it, if
+ -- the expression is missing or set to True. If the expression
+ -- is False, we can ignore the aspect with the exception that
+ -- in the case of a derived type, we must check for an illegal
+ -- attempt to cancel an inherited aspect.
- -- Build corresponding pragma node
+ when Boolean_Aspects =>
+ Set_Is_Boolean_Aspect (Aspect);
+
+ if Present (Expr)
+ and then Is_False (Static_Boolean (Expr))
+ then
+ Check_False_Aspect_For_Derived_Type;
+ goto Continue;
+ end if;
+
+ -- If True, build corresponding pragma node
Aitem :=
Make_Pragma (Loc,
Pragma_Identifier =>
Make_Identifier (Sloc (Id), Chars (Id)));
- -- Deal with missing expression case, delay never needed
-
- if No (Expr) then
- Delay_Required := False;
+ -- Never need to delay for boolean aspects
- -- Expression is present
+ pragma Assert (not Delay_Required);
- else
- Preanalyze_Spec_Expression (Expr, Standard_Boolean);
+ -- Library unit aspects. These are boolean aspects, but we
+ -- have to do special things with the insertion, since the
+ -- pragma belongs inside the declarations of a package.
- -- If preanalysis gives a static expression, we don't
- -- need to delay (this will happen often in practice).
+ when Library_Unit_Aspects =>
+ if Present (Expr)
+ and then Is_False (Static_Boolean (Expr))
+ then
+ goto Continue;
+ end if;
- if Is_OK_Static_Expression (Expr) then
- Delay_Required := False;
+ -- Build corresponding pragma node
- if Is_False (Expr_Value (Expr)) then
- Set_Aspect_Cancel (Aitem);
- end if;
+ Aitem :=
+ Make_Pragma (Loc,
+ Pragma_Argument_Associations => New_List (Ent),
+ Pragma_Identifier =>
+ Make_Identifier (Sloc (Id), Chars (Id)));
- -- If we don't get a static expression, then delay, the
- -- expression may turn out static by freeze time.
+ -- This requires special handling in the case of a package
+ -- declaration, the pragma needs to be inserted in the list
+ -- of declarations for the associated package. There is no
+ -- issue of visibility delay for these aspects.
+ if Nkind (N) = N_Package_Declaration then
+ if Nkind (Parent (N)) /= N_Compilation_Unit then
+ Error_Msg_N
+ ("incorrect context for library unit aspect&", Id);
else
- Delay_Required := True;
+ Prepend
+ (Aitem, Visible_Declarations (Specification (N)));
end if;
+
+ goto Continue;
end if;
- -- Aspects corresponding to attribute definition clauses
+ -- If not package declaration, no delay is required
- when Aspect_Address |
- Aspect_Alignment |
- Aspect_Bit_Order |
- Aspect_Component_Size |
- Aspect_External_Tag |
- Aspect_Machine_Radix |
- Aspect_Object_Size |
- Aspect_Size |
- Aspect_Storage_Pool |
- Aspect_Storage_Size |
- Aspect_Stream_Size |
- Aspect_Value_Size =>
-
- -- Preanalyze the expression with the appropriate type
+ pragma Assert (not Delay_Required);
- case A_Id is
- when Aspect_Address =>
- T := RTE (RE_Address);
- when Aspect_Bit_Order =>
- T := RTE (RE_Bit_Order);
- when Aspect_External_Tag =>
- T := Standard_String;
- when Aspect_Storage_Pool =>
- T := Class_Wide_Type (RTE (RE_Root_Storage_Pool));
- when others =>
- T := Any_Integer;
- end case;
+ -- Aspects related to container iterators. These aspects denote
+ -- subprograms, and thus must be delayed.
- Preanalyze_Spec_Expression (Expr, T);
+ when Aspect_Constant_Indexing |
+ Aspect_Variable_Indexing =>
- -- Construct the attribute definition clause
+ 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,
Chars => Chars (Id),
Expression => Relocate_Node (Expr));
- -- We do not need a delay if we have a static expression
+ 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
- if Is_OK_Static_Expression (Expression (Aitem)) then
- Delay_Required := False;
+ 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
+
+ Aitem :=
+ Make_Attribute_Definition_Clause (Loc,
+ Name => Ent,
+ Chars => Chars (Id),
+ Expression => Relocate_Node (Expr));
- -- Here a delay is required
+ -- A delay is required except in the common case where
+ -- the expression is a literal, in which case it is fine
+ -- to take care of it right away.
+ if Nkind_In (Expr, N_Integer_Literal, N_String_Literal) then
+ pragma Assert (not Delay_Required);
+ null;
else
Delay_Required := True;
+ Set_Is_Delayed_Aspect (Aspect);
end if;
-- Aspects corresponding to pragmas with two arguments, where
-- the first argument is a local name referring to the entity,
- -- and the second argument is the aspect definition expression.
+ -- and the second argument is the aspect definition expression
+ -- which is an expression that does not get analyzed.
when Aspect_Suppress |
Aspect_Unsuppress =>
Aitem :=
Make_Pragma (Loc,
Pragma_Argument_Associations => New_List (
- New_Occurrence_Of (E, Eloc),
+ New_Occurrence_Of (E, Loc),
Relocate_Node (Expr)),
Pragma_Identifier =>
Make_Identifier (Sloc (Id), Chars (Id)));
-- 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;
-
- -- Aspects corresponding to stream routines
+ pragma Assert (not Delay_Required);
- when Aspect_Input |
- Aspect_Output |
- Aspect_Read |
- Aspect_Write =>
+ when Aspect_Synchronization =>
- -- Construct the attribute definition clause
+ -- The aspect corresponds to pragma Implemented.
+ -- Construct the pragma
Aitem :=
- Make_Attribute_Definition_Clause (Loc,
- Name => Ent,
- Chars => Chars (Id),
- Expression => Relocate_Node (Expr));
-
- -- These are always delayed (typically the subprogram that
- -- is referenced cannot have been declared yet, since it has
- -- a reference to the type for which this aspect is defined.
+ Make_Pragma (Loc,
+ Pragma_Argument_Associations => New_List (
+ New_Occurrence_Of (E, Loc),
+ Relocate_Node (Expr)),
+ Pragma_Identifier =>
+ Make_Identifier (Sloc (Id), Name_Implemented));
- Delay_Required := True;
+ pragma Assert (not Delay_Required);
-- Aspects corresponding to pragmas with two arguments, where
-- the second argument is a local name referring to the entity,
Make_Pragma (Loc,
Pragma_Argument_Associations => New_List (
Relocate_Node (Expr),
- New_Occurrence_Of (E, Eloc)),
+ New_Occurrence_Of (E, Loc)),
Pragma_Identifier =>
Make_Identifier (Sloc (Id), Chars (Id)),
Class_Present => Class_Present (Aspect));
-- We don't have to play the delay game here, since the only
- -- values are check names which don't get analyzed anyway.
+ -- values are ON/OFF which don't get analyzed anyway.
+
+ pragma Assert (not Delay_Required);
+
+ -- Default_Value and Default_Component_Value aspects. These
+ -- are specially handled because they have no corresponding
+ -- pragmas or attributes.
+
+ when Aspect_Default_Value | Aspect_Default_Component_Value =>
+ Error_Msg_Name_1 := Chars (Id);
+
+ if not Is_Type (E) then
+ Error_Msg_N ("aspect% can only apply to a type", Id);
+ goto Continue;
+
+ elsif not Is_First_Subtype (E) then
+ Error_Msg_N ("aspect% cannot apply to subtype", Id);
+ goto Continue;
+
+ elsif A_Id = Aspect_Default_Value
+ and then not Is_Scalar_Type (E)
+ then
+ Error_Msg_N
+ ("aspect% can only be applied to scalar type", Id);
+ goto Continue;
+
+ elsif A_Id = Aspect_Default_Component_Value then
+ if not Is_Array_Type (E) then
+ Error_Msg_N
+ ("aspect% can only be applied to array type", Id);
+ goto Continue;
+ elsif not Is_Scalar_Type (Component_Type (E)) then
+ Error_Msg_N
+ ("aspect% requires scalar components", Id);
+ goto Continue;
+ end if;
+ end if;
+
+ Aitem := Empty;
+ Delay_Required := True;
+ 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;
- Delay_Required := False;
+ 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
-- required pragma placement. The processing for the pragmas
-- takes care of the required delay.
- when Aspect_Pre | Aspect_Post => declare
+ when Pre_Post_Aspects => declare
Pname : Name_Id;
begin
- if A_Id = Aspect_Pre then
+ if A_Id = Aspect_Pre or else A_Id = Aspect_Precondition then
Pname := Name_Precondition;
else
Pname := Name_Postcondition;
-- 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;
Aitem :=
Make_Pragma (Loc,
Pragma_Identifier =>
- Make_Identifier (Sloc (Id),
- Chars => Pname),
+ Make_Identifier (Sloc (Id), Pname),
Class_Present => Class_Present (Aspect),
Split_PPC => Split_PPC (Aspect),
Pragma_Argument_Associations => New_List (
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
-- declaration, since that is the required pragma placement.
end;
-- Invariant aspects generate a corresponding pragma with a
- -- first argument that is the entity, and the second argument
- -- is the expression and anthird argument with an appropriate
+ -- first argument that is the entity, a second argument that is
+ -- the expression and a third argument that is an appropriate
-- message. This is inserted right after the declaration, to
-- get the required pragma placement. The pragma processing
-- takes care of the required delay.
- when Aspect_Invariant =>
+ when Aspect_Invariant |
+ Aspect_Type_Invariant =>
+
+ -- 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
-- declaration. We do not have to worry about delay issues
-- Predicate aspects generate a corresponding pragma with a
-- first argument that is the entity, and the second argument
- -- is the expression. This is inserted immediately after the
- -- declaration, to get the required pragma placement. The
- -- pragma processing takes care of the required delay.
+ -- is the expression.
- when Aspect_Predicate =>
+ when Aspect_Dynamic_Predicate |
+ Aspect_Predicate |
+ Aspect_Static_Predicate =>
- -- Construct the pragma
+ -- Construct the pragma (always a pragma Predicate, with
+ -- flags recording whether it is static/dynamic).
Aitem :=
Make_Pragma (Loc,
Make_Identifier (Sloc (Id), Name_Predicate));
Set_From_Aspect_Specification (Aitem, True);
+ 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).
- Ensure_Freeze_Node (E);
+ -- 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.
- -- For Predicate case, insert immediately after the entity
- -- declaration. We do not have to worry about delay issues
- -- since the pragma processing takes care of this.
+ Set_Has_Predicates (E);
- Insert_After (N, Aitem);
- goto Continue;
- end case;
+ 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;
- Set_From_Aspect_Specification (Aitem, True);
+ 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
-- delaying the aspect if we don't delay the freeze!). The pragma
- -- or clause is then attached to the aspect specification which
- -- is placed in the rep item list.
+ -- or attribute clause if there is one is then attached to the
+ -- aspect specification which is placed in the rep item list.
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;
+
Ensure_Freeze_Node (E);
- Set_Is_Delayed_Aspect (Aitem);
Set_Has_Delayed_Aspects (E);
- Set_Aspect_Rep_Item (Aspect, Aitem);
Record_Rep_Item (E, Aspect);
-- If no delay required, insert the pragma/clause in the tree
else
- -- For Pre/Post cases, insert immediately after the entity
- -- declaration, since that is the required pragma placement.
+ Set_From_Aspect_Specification (Aitem, True);
- if A_Id = Aspect_Pre or else A_Id = Aspect_Post then
- Insert_After (N, Aitem);
+ 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.
+
+ if Nkind (Parent (Ins_Node)) = N_Compilation_Unit then
+ declare
+ Aux : constant Node_Id :=
+ Aux_Decls_Node (Parent (Ins_Node));
+
+ begin
+ pragma Assert (Nkind (Aux) = N_Compilation_Unit_Aux);
+
+ if No (Pragmas_After (Aux)) then
+ Set_Pragmas_After (Aux, Empty_List);
+ end if;
+
+ -- For Pre_Post put at start of list, otherwise at end
+
+ if A_Id in Pre_Post_Aspects then
+ Prepend (Aitem, Pragmas_After (Aux));
+ else
+ Append (Aitem, Pragmas_After (Aux));
+ end if;
+ end;
- -- For all other cases, insert in sequence
+ -- Here if not compilation unit case
else
- Insert_After (Ins_Node, Aitem);
- Ins_Node := Aitem;
+ case A_Id is
+
+ -- For Pre/Post cases, insert immediately after the
+ -- entity declaration, since that is the required pragma
+ -- placement.
+
+ when Pre_Post_Aspects =>
+ Insert_After (N, Aitem);
+
+ -- 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;
- <<Continue>>
- Next (Aspect);
- end loop;
+ <<Continue>>
+ Next (Aspect);
+ end loop Aspect_Loop;
end Analyze_Aspect_Specifications;
-----------------------
Attr : constant Name_Id := Chars (N);
Expr : constant Node_Id := Expression (N);
Id : constant Attribute_Id := Get_Attribute_Id (Attr);
- Ent : Entity_Id;
+
+ Ent : Entity_Id;
+ -- The entity of Nam after it is analyzed. In the case of an incomplete
+ -- type, this is the underlying type.
+
U_Ent : Entity_Id;
+ -- The underlying entity to which the attribute applies. Generally this
+ -- is the Underlying_Type of Ent, except in the case where the clause
+ -- applies to full view of incomplete type or private type in which case
+ -- U_Ent is just a copy of Ent.
FOnly : Boolean := False;
-- Reset to True for subtype specific attribute (Alignment, Size)
-- 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 --
-----------------------------------
Pnam : Entity_Id;
Is_Read : constant Boolean := (TSS_Nam = TSS_Stream_Read);
+ -- True for Read attribute, false for other attributes
function Has_Good_Profile (Subp : Entity_Id) return Boolean;
-- Return true if the entity is a subprogram with an appropriate
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 --
----------------------
-- Start of processing for Analyze_Attribute_Definition_Clause
begin
+ -- The following code is a defense against recursion. Not clear that
+ -- this can happen legitimately, but perhaps some error situations
+ -- can cause it, and we did see this recursion during testing.
+
+ if Analyzed (N) then
+ return;
+ else
+ Set_Analyzed (N, True);
+ end if;
+
+ -- Ignore some selected attributes in CodePeer mode since they are not
+ -- relevant in this context.
+
+ 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
Attribute_Machine_Radix |
Attribute_Object_Size |
Attribute_Size |
- Attribute_Small |
Attribute_Stream_Size |
Attribute_Value_Size =>
-
Rewrite (N, Make_Null_Statement (Sloc (N)));
return;
+ -- Perhaps 'Small should not be ignored by Ignore_Rep_Clauses ???
+
+ when Attribute_Small =>
+ if Ignore_Rep_Clauses then
+ Rewrite (N, Make_Null_Statement (Sloc (N)));
+ return;
+ end if;
+
-- The following should not be ignored, because in the first place
-- they are reasonably portable, and should not cause problems in
-- compiling code from another target, and also they do affect
-- 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
-- check till after code generation to take full advantage
-- of the annotation done by the back end. This entry is
-- only made if the address clause comes from source.
+
-- If the entity has a generic type, the check will be
-- performed in the instance if the actual type justifies
-- it, and we do not insert the clause in the table 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;
- ------------------
- -- External_Tag --
- ------------------
+ -----------------------
+ -- 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 --
+ ------------------
when Attribute_External_Tag => External_Tag :
begin
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;
("size cannot be given for unconstrained array", Nam);
elsif Size /= No_Uint then
-
if VM_Target /= No_VM and then not GNAT_Mode then
-- Size clause is not handled properly on VM targets.
if Is_Type (U_Ent) then
Set_RM_Size (U_Ent, Size);
- -- For scalar types, increase Object_Size to power of 2, but
- -- not less than a storage unit in any case (i.e., normally
+ -- For elementary types, increase Object_Size to power of 2,
+ -- but not less than a storage unit in any case (normally
-- this means it will be byte addressable).
- if Is_Scalar_Type (U_Ent) then
+ -- For all other types, nothing else to do, we leave Esize
+ -- (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);
elsif Size <= 16 then
Set_Esize (U_Ent, (Size + 63) / 64 * 64);
end if;
- -- For all other types, object size = value size. The
- -- backend will adjust as needed.
-
+ Alignment_Check_For_Size_Change (U_Ent, Esize (U_Ent));
else
- Set_Esize (U_Ent, Size);
+ Alignment_Check_For_Size_Change (U_Ent, Size);
end if;
- Alignment_Check_For_Esize_Change (U_Ent);
-
-- For objects, set Esize only
else
-- 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);
end if;
-- The Stack_Bounded_Pool is used internally for implementing
- -- access types with a Storage_Size. Since it only work
- -- properly when used on one specific type, we need to check
- -- that it is not hijacked improperly:
+ -- access types with a Storage_Size. Since it only work properly
+ -- when used on one specific type, we need to check that it is not
+ -- hijacked improperly:
+
-- type T is access Integer;
-- for T'Storage_Size use n;
-- type Q is access Float;
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 --
-----------
("attribute& cannot be set with definition clause", N);
end case;
- -- The test for the type being frozen must be performed after
- -- any expression the clause has been analyzed since the expression
- -- itself might cause freezing that makes the clause illegal.
+ -- The test for the type being frozen must be performed after any
+ -- expression the clause has been analyzed since the expression itself
+ -- might cause freezing that makes the clause illegal.
if Rep_Item_Too_Late (U_Ent, N, FOnly) then
return;
-- 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)
Assoc : Node_Id;
Choice : Node_Id;
Val : Uint;
- Err : Boolean := False;
+
+ Err : Boolean := False;
+ -- Set True to avoid cascade errors and crashes on incorrect source code
Lo : constant Uint := Expr_Value (Type_Low_Bound (Universal_Integer));
Hi : constant Uint := Expr_Value (Type_High_Bound (Universal_Integer));
Err := True;
elsif Nkind (Choice) = N_Range then
+
-- ??? should allow zero/one element range here
+
Error_Msg_N ("range not allowed here", Choice);
Err := True;
else
Analyze_And_Resolve (Choice, Enumtype);
- if Is_Entity_Name (Choice)
- and then Is_Type (Entity (Choice))
- then
- Error_Msg_N ("subtype name not allowed here", Choice);
+ if Error_Posted (Choice) then
Err := True;
- -- ??? should allow static subtype with zero/one entry
+ end if;
- elsif Etype (Choice) = Base_Type (Enumtype) then
- if not Is_Static_Expression (Choice) then
- Flag_Non_Static_Expr
- ("non-static expression used for choice!", Choice);
+ if not Err then
+ if Is_Entity_Name (Choice)
+ and then Is_Type (Entity (Choice))
+ then
+ Error_Msg_N ("subtype name not allowed here", Choice);
Err := True;
- else
- Elit := Expr_Value_E (Choice);
+ -- ??? should allow static subtype with zero/one entry
- if Present (Enumeration_Rep_Expr (Elit)) then
- Error_Msg_Sloc := Sloc (Enumeration_Rep_Expr (Elit));
- Error_Msg_NE
- ("representation for& previously given#",
- Choice, Elit);
+ elsif Etype (Choice) = Base_Type (Enumtype) then
+ if not Is_Static_Expression (Choice) then
+ Flag_Non_Static_Expr
+ ("non-static expression used for choice!", Choice);
Err := True;
- end if;
- Set_Enumeration_Rep_Expr (Elit, Expression (Assoc));
+ else
+ Elit := Expr_Value_E (Choice);
+
+ if Present (Enumeration_Rep_Expr (Elit)) then
+ Error_Msg_Sloc :=
+ Sloc (Enumeration_Rep_Expr (Elit));
+ Error_Msg_NE
+ ("representation for& previously given#",
+ Choice, Elit);
+ Err := True;
+ end if;
- Expr := Expression (Assoc);
- Val := Static_Integer (Expr);
+ Set_Enumeration_Rep_Expr (Elit, Expression (Assoc));
- if Val = No_Uint then
- Err := True;
+ Expr := Expression (Assoc);
+ Val := Static_Integer (Expr);
- elsif Val < Lo or else Hi < Val then
- Error_Msg_N ("value outside permitted range", Expr);
- Err := True;
- end if;
+ if Val = No_Uint then
+ Err := True;
+
+ elsif Val < Lo or else Hi < Val then
+ Error_Msg_N ("value outside permitted range", Expr);
+ Err := True;
+ end if;
- Set_Enumeration_Rep (Elit, Val);
+ Set_Enumeration_Rep (Elit, Val);
+ end if;
end if;
end if;
end if;
-- If we have a type with predicates, build predicate function
if Is_Type (E) and then Has_Predicates (E) then
+ Build_Predicate_Function (E, N);
+ end if;
+
+ -- If type has delayed aspects, this is where we do the preanalysis at
+ -- the freeze point, as part of the consistent visibility check. Note
+ -- that this must be done after calling Build_Predicate_Function or
+ -- Build_Invariant_Procedure since these subprograms fix occurrences of
+ -- the subtype name in the saved expression so that they will not cause
+ -- trouble in the preanalysis.
+
+ if Has_Delayed_Aspects (E) then
declare
- FDecl : Node_Id;
- FBody : Node_Id;
+ Ritem : Node_Id;
begin
- Build_Predicate_Function (E, FDecl, FBody);
+ -- Look for aspect specification entries for this entity
+
+ Ritem := First_Rep_Item (E);
+ while Present (Ritem) loop
+ 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;
- if Present (FDecl) then
- Insert_After (N, FBody);
- Insert_After (N, FDecl);
- end if;
+ Next_Rep_Item (Ritem);
+ end loop;
end;
end if;
end Analyze_Freeze_Entity;
-- 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),
Lbit := Lbit + UI_From_Int (SSU) * Posit;
if Has_Size_Clause (Rectype)
- and then Esize (Rectype) <= Lbit
+ and then RM_Size (Rectype) <= Lbit
then
Error_Msg_N
("bit number out of range of specified size",
-- ...
-- end typInvariant;
- procedure Build_Invariant_Procedure
- (Typ : Entity_Id;
- PDecl : out Node_Id;
- PBody : out Node_Id)
- is
+ procedure Build_Invariant_Procedure (Typ : Entity_Id; N : Node_Id) is
Loc : constant Source_Ptr := Sloc (Typ);
Stmts : List_Id;
Spec : Node_Id;
SId : Entity_Id;
+ PDecl : Node_Id;
+ PBody : Node_Id;
+
+ Visible_Decls : constant List_Id := Visible_Declarations (N);
+ Private_Decls : constant List_Id := Private_Declarations (N);
procedure Add_Invariants (T : Entity_Id; Inherit : Boolean);
-- Appends statements to Stmts for any invariants in the rep item chain
Object_Name : constant Name_Id := New_Internal_Name ('I');
-- Name for argument of invariant procedure
+ Object_Entity : constant Node_Id :=
+ Make_Defining_Identifier (Loc, Object_Name);
+ -- The procedure declaration entity for the argument
+
--------------------
-- Add_Invariants --
--------------------
Assoc : List_Id;
Str : String_Id;
- function Replace_Node (N : Node_Id) return Traverse_Result;
- -- Process single node for traversal to replace type references
-
- procedure Replace_Type is new Traverse_Proc (Replace_Node);
- -- Traverse an expression changing every occurrence of an entity
- -- reference to type T with a reference to the object argument.
-
- ------------------
- -- Replace_Node --
- ------------------
-
- function Replace_Node (N : Node_Id) return Traverse_Result is
+ procedure Replace_Type_Reference (N : Node_Id);
+ -- Replace a single occurrence N of the subtype name with a reference
+ -- to the formal of the predicate function. N can be an identifier
+ -- referencing the subtype, or a selected component, representing an
+ -- appropriately qualified occurrence of the subtype name.
+
+ procedure Replace_Type_References is
+ new Replace_Type_References_Generic (Replace_Type_Reference);
+ -- Traverse an expression replacing all occurrences of the subtype
+ -- name with appropriate references to the object that is the formal
+ -- parameter of the predicate function. Note that we must ensure
+ -- that the type and entity information is properly set in the
+ -- replacement node, since we will do a Preanalyze call of this
+ -- expression without proper visibility of the procedure argument.
+
+ ----------------------------
+ -- Replace_Type_Reference --
+ ----------------------------
+
+ procedure Replace_Type_Reference (N : Node_Id) is
begin
- -- Case of entity name referencing the type
+ -- Invariant'Class, replace with T'Class (obj)
- if Is_Entity_Name (N)
- and then Entity (N) = T
- then
- -- Invariant'Class, replace with T'Class (obj)
-
- if Class_Present (Ritem) then
- Rewrite (N,
- Make_Type_Conversion (Loc,
- Subtype_Mark =>
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (T, Loc),
- Attribute_Name => Name_Class),
- Expression =>
- Make_Identifier (Loc,
- Chars => Object_Name)));
-
- -- Invariant, replace with obj
-
- else
- Rewrite (N,
- Make_Identifier (Loc,
- Chars => Object_Name));
- end if;
-
- -- All done with this node
+ if Class_Present (Ritem) then
+ Rewrite (N,
+ Make_Type_Conversion (Loc,
+ Subtype_Mark =>
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (T, Loc),
+ Attribute_Name => Name_Class),
+ Expression => Make_Identifier (Loc, Object_Name)));
- return Skip;
+ Set_Entity (Expression (N), Object_Entity);
+ Set_Etype (Expression (N), Typ);
- -- Not an instance of the type entity, keep going
+ -- Invariant, replace with obj
else
- return OK;
+ Rewrite (N, Make_Identifier (Loc, Object_Name));
+ Set_Entity (N, Object_Entity);
+ Set_Etype (N, Typ);
end if;
- end Replace_Node;
+ end Replace_Type_Reference;
-- Start of processing for Add_Invariants
-- We need to replace any occurrences of the name of the type
-- with references to the object, converted to type'Class in
- -- the case of Invariant'Class aspects. We do this by first
- -- doing a preanalysis, to identify all the entities, then
- -- we traverse looking for the type entity, and doing the
- -- necessary substitution. The preanalysis is done with the
- -- special OK_To_Reference flag set on the type, so that if
- -- we get an occurrence of this type, it will be reognized
- -- as legitimate.
-
- Set_OK_To_Reference (T, True);
- Preanalyze_Spec_Expression (Exp, Standard_Boolean);
- Set_OK_To_Reference (T, False);
+ -- the case of Invariant'Class aspects.
+
+ Replace_Type_References (Exp, Chars (T));
+
+ -- If this invariant comes from an aspect, find the aspect
+ -- specification, and replace the saved expression because
+ -- we need the subtype references replaced for the calls to
+ -- Preanalyze_Spec_Expressin in Check_Aspect_At_Freeze_Point
+ -- and Check_Aspect_At_End_Of_Declarations.
+
+ if From_Aspect_Specification (Ritem) then
+ declare
+ Aitem : Node_Id;
- -- Do the traversal
+ begin
+ -- Loop to find corresponding aspect, note that this
+ -- must be present given the pragma is marked delayed.
- Replace_Type (Exp);
+ Aitem := Next_Rep_Item (Ritem);
+ while Present (Aitem) loop
+ if Nkind (Aitem) = N_Aspect_Specification
+ and then Aspect_Rep_Item (Aitem) = Ritem
+ then
+ Set_Entity
+ (Identifier (Aitem), New_Copy_Tree (Exp));
+ exit;
+ end if;
+
+ Aitem := Next_Rep_Item (Aitem);
+ end loop;
+ end;
+ end if;
+
+ -- Now we need to preanalyze the expression to properly capture
+ -- the visibility in the visible part. The expression will not
+ -- be analyzed for real until the body is analyzed, but that is
+ -- at the end of the private part and has the wrong visibility.
+
+ Set_Parent (Exp, N);
+ Preanalyze_Spec_Expression (Exp, Standard_Boolean);
-- Build first two arguments for Check pragma
Assoc := New_List (
Make_Pragma_Argument_Association (Loc,
- Expression =>
- Make_Identifier (Loc,
- Chars => Name_Invariant)),
- Make_Pragma_Argument_Association (Loc,
- Expression => Exp));
+ Expression => Make_Identifier (Loc, Name_Invariant)),
+ Make_Pragma_Argument_Association (Loc, Expression => Exp));
-- Add message if present in Invariant pragma
Append_To (Stmts,
Make_Pragma (Loc,
Pragma_Identifier =>
- Make_Identifier (Loc,
- Chars => Name_Check),
+ Make_Identifier (Loc, Name_Check),
Pragma_Argument_Associations => Assoc));
-- If Inherited case and option enabled, output info msg. Note
Stmts := No_List;
PDecl := Empty;
PBody := Empty;
+ Set_Etype (Object_Entity, Typ);
-- Add invariants for the current type
-- Build procedure declaration
- pragma Assert (Has_Invariants (Typ));
SId :=
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Chars (Typ), "Invariant"));
Defining_Unit_Name => SId,
Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc,
- Chars => Object_Name),
- Parameter_Type =>
- New_Occurrence_Of (Typ, Loc))));
+ Defining_Identifier => Object_Entity,
+ Parameter_Type => New_Occurrence_Of (Typ, Loc))));
- PDecl :=
- Make_Subprogram_Declaration (Loc,
- Specification => Spec);
+ PDecl := Make_Subprogram_Declaration (Loc, Specification => Spec);
-- Build procedure body
Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier =>
- Make_Defining_Identifier (Loc,
- Chars => Object_Name),
- Parameter_Type =>
- New_Occurrence_Of (Typ, Loc))));
+ Make_Defining_Identifier (Loc, Object_Name),
+ Parameter_Type => New_Occurrence_Of (Typ, Loc))));
PBody :=
Make_Subprogram_Body (Loc,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Stmts));
+
+ -- Insert procedure declaration and spec at the appropriate points.
+ -- Skip this if there are no private declarations (that's an error
+ -- that will be diagnosed elsewhere, and there is no point in having
+ -- an invariant procedure set if the full declaration is missing).
+
+ if Present (Private_Decls) then
+
+ -- The spec goes at the end of visible declarations, but they have
+ -- already been analyzed, so we need to explicitly do the analyze.
+
+ Append_To (Visible_Decls, PDecl);
+ Analyze (PDecl);
+
+ -- The body goes at the end of the private declarations, which we
+ -- have not analyzed yet, so we do not need to perform an explicit
+ -- analyze call. We skip this if there are no private declarations
+ -- (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;
-- inherited. Note that we do NOT generate Check pragmas, that's because we
-- use this function even if checks are off, e.g. for membership tests.
- procedure Build_Predicate_Function
- (Typ : Entity_Id;
- FDecl : out Node_Id;
- FBody : out Node_Id)
- is
+ procedure Build_Predicate_Function (Typ : Entity_Id; N : Node_Id) is
Loc : constant Source_Ptr := Sloc (Typ);
Spec : Node_Id;
SId : Entity_Id;
+ FDecl : Node_Id;
+ FBody : Node_Id;
Expr : Node_Id;
-- This is the expression for the return statement in the function. It
-- Inheritance of predicates for the parent type is done by calling the
-- Predicate_Function of the parent type, using Add_Call above.
- procedure Build_Static_Predicate;
- -- This function is called to process a static predicate, and put it in
- -- canonical form and store it in Static_Predicate (Typ).
-
Object_Name : constant Name_Id := New_Internal_Name ('I');
-- Name for argument of Predicate procedure
+ Object_Entity : constant Entity_Id :=
+ Make_Defining_Identifier (Loc, Object_Name);
+ -- The entity for the spec entity for the argument
+
+ Dynamic_Predicate_Present : Boolean := False;
+ -- Set True if a dynamic predicate is present, results in the entire
+ -- predicate being considered dynamic even if it looks static
+
+ Static_Predicate_Present : Node_Id := Empty;
+ -- Set to N_Pragma node for a static predicate if one is encountered.
+
--------------
-- Add_Call --
--------------
Exp :=
Make_Predicate_Call
- (T,
- Convert_To (T,
- Make_Identifier (Loc, Chars => Object_Name)));
+ (T, Convert_To (T, Make_Identifier (Loc, Object_Name)));
-- Add call to evolving expression, using AND THEN if needed
Right_Opnd => Exp);
end if;
- -- Output info message on inheritance if required
-
- if Opt.List_Inherited_Aspects then
+ -- Output info message on inheritance if required. Note we do not
+ -- give this information for generic actual types, since it is
+ -- unwelcome noise in that case in instantiations. We also
+ -- generally suppress the message in instantiations, and also
+ -- if it involves internal names.
+
+ if Opt.List_Inherited_Aspects
+ and then not Is_Generic_Actual_Type (Typ)
+ and then Instantiation_Depth (Sloc (Typ)) = 0
+ and then not Is_Internal_Name (Chars (T))
+ and then not Is_Internal_Name (Chars (Typ))
+ then
Error_Msg_Sloc := Sloc (Predicate_Function (T));
Error_Msg_Node_2 := T;
Error_Msg_N ("?info: & inherits predicate from & #", Typ);
Arg1 : Node_Id;
Arg2 : Node_Id;
- function Replace_Node (N : Node_Id) return Traverse_Result;
- -- Process single node for traversal to replace type references
+ procedure Replace_Type_Reference (N : Node_Id);
+ -- Replace a single occurrence N of the subtype name with a reference
+ -- to the formal of the predicate function. N can be an identifier
+ -- referencing the subtype, or a selected component, representing an
+ -- appropriately qualified occurrence of the subtype name.
- procedure Replace_Type is new Traverse_Proc (Replace_Node);
- -- Traverse an expression changing every occurrence of an entity
- -- reference to type T with a reference to the object argument.
+ procedure Replace_Type_References is
+ new Replace_Type_References_Generic (Replace_Type_Reference);
+ -- Traverse an expression changing every occurrence of an identifier
+ -- whose name matches the name of the subtype with a reference to
+ -- the formal parameter of the predicate function.
- ------------------
- -- Replace_Node --
- ------------------
+ ----------------------------
+ -- Replace_Type_Reference --
+ ----------------------------
- function Replace_Node (N : Node_Id) return Traverse_Result is
+ procedure Replace_Type_Reference (N : Node_Id) is
begin
- -- Case of entity name referencing the type
-
- if Is_Entity_Name (N) and then Entity (N) = Typ then
-
- -- Replace with object
-
- Rewrite (N,
- Make_Identifier (Loc,
- Chars => Object_Name));
-
- -- All done with this node
-
- return Skip;
-
- -- Not an occurrence of the type entity, keep going
-
- else
- return OK;
- end if;
- end Replace_Node;
+ Rewrite (N, Make_Identifier (Loc, Object_Name));
+ Set_Entity (N, Object_Entity);
+ Set_Etype (N, Typ);
+ end Replace_Type_Reference;
-- Start of processing for Add_Predicates
if Nkind (Ritem) = N_Pragma
and then Pragma_Name (Ritem) = Name_Predicate
then
+ 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 := First (Pragma_Argument_Associations (Ritem));
Arg2 := Next (Arg1);
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
- -- First We need to replace any occurrences of the name of
- -- the type with references to the object. We do this by
- -- first doing a preanalysis, to identify all the entities,
- -- then we traverse looking for the type entity, doing the
- -- needed substitution. The preanalysis is done with the
- -- special OK_To_Reference flag set on the type, so that if
- -- we get an occurrence of this type, it will be recognized
- -- as legitimate.
+ -- We need to replace any occurrences of the name of the
+ -- type with references to the object.
- Set_OK_To_Reference (Typ, True);
- Preanalyze_Spec_Expression (Arg2, Standard_Boolean);
- Set_OK_To_Reference (Typ, False);
- Replace_Type (Arg2);
+ Replace_Type_References (Arg2, Chars (Typ));
- -- OK, replacement complete, now we can add the expression
+ -- If this predicate comes from an aspect, find the aspect
+ -- specification, and replace the saved expression because
+ -- we need the subtype references replaced for the calls to
+ -- Preanalyze_Spec_Expressin in Check_Aspect_At_Freeze_Point
+ -- and Check_Aspect_At_End_Of_Declarations.
+
+ if From_Aspect_Specification (Ritem) then
+ declare
+ Aitem : Node_Id;
+
+ begin
+ -- Loop to find corresponding aspect, note that this
+ -- must be present given the pragma is marked delayed.
+
+ Aitem := Next_Rep_Item (Ritem);
+ loop
+ if Nkind (Aitem) = N_Aspect_Specification
+ and then Aspect_Rep_Item (Aitem) = Ritem
+ then
+ Set_Entity
+ (Identifier (Aitem), New_Copy_Tree (Arg2));
+ exit;
+ end if;
+
+ Aitem := Next_Rep_Item (Aitem);
+ end loop;
+ end;
+ end if;
+
+ -- Now we can add the expression
if No (Expr) then
Expr := Relocate_Node (Arg2);
- -- There already was a predicate, so add to it
+ -- There already was a predicate, so add to it
+
+ else
+ Expr :=
+ Make_And_Then (Loc,
+ Left_Opnd => Relocate_Node (Expr),
+ Right_Opnd => Relocate_Node (Arg2));
+ end if;
+ end if;
+ end if;
+
+ Next_Rep_Item (Ritem);
+ end loop;
+ end Add_Predicates;
+
+ -- Start of processing for Build_Predicate_Function
+
+ begin
+ -- Initialize for construction of statement list
+
+ Expr := Empty;
+
+ -- Return if already built or if type does not have predicates
+
+ if not Has_Predicates (Typ)
+ or else Present (Predicate_Function (Typ))
+ then
+ return;
+ end if;
+
+ -- Add Predicates for the current type
+
+ Add_Predicates;
+
+ -- Add predicates for ancestor if present
+
+ declare
+ Atyp : constant Entity_Id := Nearest_Ancestor (Typ);
+ begin
+ if Present (Atyp) then
+ Add_Call (Atyp);
+ end if;
+ end;
+
+ -- If we have predicates, build the function
+
+ if Present (Expr) then
+
+ -- Build function declaration
+
+ pragma Assert (Has_Predicates (Typ));
+ SId :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Chars (Typ), "Predicate"));
+ 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,
+ Parameter_Specifications => New_List (
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => Object_Entity,
+ Parameter_Type => New_Occurrence_Of (Typ, Loc))),
+ Result_Definition =>
+ New_Occurrence_Of (Standard_Boolean, Loc));
+
+ FDecl := Make_Subprogram_Declaration (Loc, Specification => Spec);
+
+ -- Build function body
+
+ SId :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Chars (Typ), "Predicate"));
+
+ Spec :=
+ Make_Function_Specification (Loc,
+ Defining_Unit_Name => SId,
+ Parameter_Specifications => New_List (
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Object_Name),
+ Parameter_Type =>
+ New_Occurrence_Of (Typ, Loc))),
+ Result_Definition =>
+ New_Occurrence_Of (Standard_Boolean, Loc));
+
+ FBody :=
+ Make_Subprogram_Body (Loc,
+ Specification => Spec,
+ Declarations => Empty_List,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (
+ Make_Simple_Return_Statement (Loc,
+ Expression => Expr))));
+
+ -- Insert declaration before freeze node and body after
+
+ Insert_Before_And_Analyze (N, FDecl);
+ Insert_After_And_Analyze (N, FBody);
+
+ -- Deal with static predicate case
+
+ if Ekind_In (Typ, E_Enumeration_Subtype,
+ E_Modular_Integer_Subtype,
+ E_Signed_Integer_Subtype)
+ and then Is_Static_Subtype (Typ)
+ and then not Dynamic_Predicate_Present
+ then
+ Build_Static_Predicate (Typ, Expr, Object_Name);
+
+ if Present (Static_Predicate_Present)
+ and No (Static_Predicate (Typ))
+ then
+ Error_Msg_F
+ ("expression does not have required form for "
+ & "static predicate",
+ Next (First (Pragma_Argument_Associations
+ (Static_Predicate_Present))));
+ end if;
+ end if;
+ end if;
+ end Build_Predicate_Function;
+
+ ----------------------------
+ -- Build_Static_Predicate --
+ ----------------------------
+
+ procedure Build_Static_Predicate
+ (Typ : Entity_Id;
+ Expr : Node_Id;
+ Nam : Name_Id)
+ is
+ Loc : constant Source_Ptr := Sloc (Expr);
+
+ Non_Static : exception;
+ -- Raised if something non-static is found
+
+ Btyp : constant Entity_Id := Base_Type (Typ);
+
+ BLo : constant Uint := Expr_Value (Type_Low_Bound (Btyp));
+ BHi : constant Uint := Expr_Value (Type_High_Bound (Btyp));
+ -- Low bound and high bound value of base type of Typ
+
+ TLo : constant Uint := Expr_Value (Type_Low_Bound (Typ));
+ THi : constant Uint := Expr_Value (Type_High_Bound (Typ));
+ -- Low bound and high bound values of static subtype Typ
+
+ type REnt is record
+ Lo, Hi : Uint;
+ end record;
+ -- One entry in a Rlist value, a single REnt (range entry) value
+ -- denotes one range from Lo to Hi. To represent a single value
+ -- range Lo = Hi = value.
+
+ type RList is array (Nat range <>) of REnt;
+ -- A list of ranges. The ranges are sorted in increasing order,
+ -- and are disjoint (there is a gap of at least one value between
+ -- each range in the table). A value is in the set of ranges in
+ -- Rlist if it lies within one of these ranges
+
+ False_Range : constant RList :=
+ RList'(1 .. 0 => REnt'(No_Uint, No_Uint));
+ -- An empty set of ranges represents a range list that can never be
+ -- satisfied, since there are no ranges in which the value could lie,
+ -- so it does not lie in any of them. False_Range is a canonical value
+ -- for this empty set, but general processing should test for an Rlist
+ -- with length zero (see Is_False predicate), since other null ranges
+ -- may appear which must be treated as False.
+
+ True_Range : constant RList := RList'(1 => REnt'(BLo, BHi));
+ -- Range representing True, value must be in the base range
+
+ function "and" (Left, Right : RList) return RList;
+ -- And's together two range lists, returning a range list. This is
+ -- a set intersection operation.
+
+ function "or" (Left, Right : RList) return RList;
+ -- Or's together two range lists, returning a range list. This is a
+ -- set union operation.
+
+ function "not" (Right : RList) return RList;
+ -- Returns complement of a given range list, i.e. a range list
+ -- representing all the values in TLo .. THi that are not in the
+ -- input operand Right.
+
+ function Build_Val (V : Uint) return Node_Id;
+ -- Return an analyzed N_Identifier node referencing this value, suitable
+ -- for use as an entry in the Static_Predicate list. This node is typed
+ -- with the base type.
+
+ function Build_Range (Lo, Hi : Uint) return Node_Id;
+ -- Return an analyzed N_Range node referencing this range, suitable
+ -- for use as an entry in the Static_Predicate list. This node is typed
+ -- with the base type.
+
+ function Get_RList (Exp : Node_Id) return RList;
+ -- This is a recursive routine that converts the given expression into
+ -- a list of ranges, suitable for use in building the static predicate.
+
+ function Is_False (R : RList) return Boolean;
+ pragma Inline (Is_False);
+ -- Returns True if the given range list is empty, and thus represents
+ -- a False list of ranges that can never be satisfied.
+
+ function Is_True (R : RList) return Boolean;
+ -- Returns True if R trivially represents the True predicate by having
+ -- a single range from BLo to BHi.
+
+ function Is_Type_Ref (N : Node_Id) return Boolean;
+ pragma Inline (Is_Type_Ref);
+ -- Returns if True if N is a reference to the type for the predicate in
+ -- the expression (i.e. if it is an identifier whose Chars field matches
+ -- the Nam given in the call).
+
+ function Lo_Val (N : Node_Id) return Uint;
+ -- Given static expression or static range from a Static_Predicate list,
+ -- gets expression value or low bound of range.
+
+ function Hi_Val (N : Node_Id) return Uint;
+ -- Given static expression or static range from a Static_Predicate list,
+ -- gets expression value of high bound of range.
+
+ function Membership_Entry (N : Node_Id) return RList;
+ -- Given a single membership entry (range, value, or subtype), returns
+ -- the corresponding range list. Raises Static_Error if not static.
+
+ function Membership_Entries (N : Node_Id) return RList;
+ -- Given an element on an alternatives list of a membership operation,
+ -- returns the range list corresponding to this entry and all following
+ -- entries (i.e. returns the "or" of this list of values).
+
+ function Stat_Pred (Typ : Entity_Id) return RList;
+ -- Given a type, if it has a static predicate, then return the predicate
+ -- as a range list, otherwise raise Non_Static.
+
+ -----------
+ -- "and" --
+ -----------
+
+ function "and" (Left, Right : RList) return RList is
+ FEnt : REnt;
+ -- First range of result
+
+ SLeft : Nat := Left'First;
+ -- Start of rest of left entries
+
+ SRight : Nat := Right'First;
+ -- Start of rest of right entries
+
+ begin
+ -- If either range is True, return the other
+
+ if Is_True (Left) then
+ return Right;
+ elsif Is_True (Right) then
+ return Left;
+ end if;
+
+ -- If either range is False, return False
+
+ if Is_False (Left) or else Is_False (Right) then
+ return False_Range;
+ end if;
+
+ -- Loop to remove entries at start that are disjoint, and thus
+ -- just get discarded from the result entirely.
+
+ loop
+ -- If no operands left in either operand, result is false
+
+ if SLeft > Left'Last or else SRight > Right'Last then
+ return False_Range;
+
+ -- Discard first left operand entry if disjoint with right
+
+ elsif Left (SLeft).Hi < Right (SRight).Lo then
+ SLeft := SLeft + 1;
+
+ -- Discard first right operand entry if disjoint with left
+
+ elsif Right (SRight).Hi < Left (SLeft).Lo then
+ SRight := SRight + 1;
+
+ -- Otherwise we have an overlapping entry
+
+ else
+ exit;
+ end if;
+ end loop;
+
+ -- Now we have two non-null operands, and first entries overlap.
+ -- The first entry in the result will be the overlapping part of
+ -- these two entries.
+
+ FEnt := REnt'(Lo => UI_Max (Left (SLeft).Lo, Right (SRight).Lo),
+ Hi => UI_Min (Left (SLeft).Hi, Right (SRight).Hi));
+
+ -- Now we can remove the entry that ended at a lower value, since
+ -- its contribution is entirely contained in Fent.
+
+ if Left (SLeft).Hi <= Right (SRight).Hi then
+ SLeft := SLeft + 1;
+ else
+ SRight := SRight + 1;
+ end if;
+
+ -- Compute result by concatenating this first entry with the "and"
+ -- of the remaining parts of the left and right operands. Note that
+ -- if either of these is empty, "and" will yield empty, so that we
+ -- will end up with just Fent, which is what we want in that case.
+
+ return
+ FEnt & (Left (SLeft .. Left'Last) and Right (SRight .. Right'Last));
+ end "and";
+
+ -----------
+ -- "not" --
+ -----------
+
+ function "not" (Right : RList) return RList is
+ begin
+ -- Return True if False range
+
+ if Is_False (Right) then
+ return True_Range;
+ end if;
+
+ -- Return False if True range
+
+ if Is_True (Right) then
+ return False_Range;
+ end if;
+
+ -- Here if not trivial case
+
+ declare
+ Result : RList (1 .. Right'Length + 1);
+ -- May need one more entry for gap at beginning and end
+
+ Count : Nat := 0;
+ -- Number of entries stored in Result
+
+ begin
+ -- Gap at start
+
+ if Right (Right'First).Lo > TLo then
+ Count := Count + 1;
+ Result (Count) := REnt'(TLo, Right (Right'First).Lo - 1);
+ end if;
+
+ -- Gaps between ranges
+
+ for J in Right'First .. Right'Last - 1 loop
+ Count := Count + 1;
+ Result (Count) :=
+ REnt'(Right (J).Hi + 1, Right (J + 1).Lo - 1);
+ end loop;
+
+ -- Gap at end
+
+ if Right (Right'Last).Hi < THi then
+ Count := Count + 1;
+ Result (Count) := REnt'(Right (Right'Last).Hi + 1, THi);
+ end if;
+
+ return Result (1 .. Count);
+ end;
+ end "not";
+
+ ----------
+ -- "or" --
+ ----------
+
+ function "or" (Left, Right : RList) return RList is
+ FEnt : REnt;
+ -- First range of result
+
+ SLeft : Nat := Left'First;
+ -- Start of rest of left entries
+
+ SRight : Nat := Right'First;
+ -- Start of rest of right entries
+
+ begin
+ -- If either range is True, return True
+
+ if Is_True (Left) or else Is_True (Right) then
+ return True_Range;
+ end if;
+
+ -- If either range is False (empty), return the other
+
+ if Is_False (Left) then
+ return Right;
+ elsif Is_False (Right) then
+ return Left;
+ end if;
+
+ -- Initialize result first entry from left or right operand
+ -- depending on which starts with the lower range.
+
+ if Left (SLeft).Lo < Right (SRight).Lo then
+ FEnt := Left (SLeft);
+ SLeft := SLeft + 1;
+ else
+ FEnt := Right (SRight);
+ SRight := SRight + 1;
+ end if;
+
+ -- This loop eats ranges from left and right operands that
+ -- are contiguous with the first range we are gathering.
+
+ loop
+ -- Eat first entry in left operand if contiguous or
+ -- overlapped by gathered first operand of result.
+
+ if SLeft <= Left'Last
+ and then Left (SLeft).Lo <= FEnt.Hi + 1
+ then
+ FEnt.Hi := UI_Max (FEnt.Hi, Left (SLeft).Hi);
+ SLeft := SLeft + 1;
+
+ -- Eat first entry in right operand if contiguous or
+ -- overlapped by gathered right operand of result.
+
+ elsif SRight <= Right'Last
+ and then Right (SRight).Lo <= FEnt.Hi + 1
+ then
+ FEnt.Hi := UI_Max (FEnt.Hi, Right (SRight).Hi);
+ SRight := SRight + 1;
+
+ -- All done if no more entries to eat!
+
+ else
+ exit;
+ end if;
+ end loop;
+
+ -- Obtain result as the first entry we just computed, concatenated
+ -- to the "or" of the remaining results (if one operand is empty,
+ -- this will just concatenate with the other
+
+ return
+ FEnt & (Left (SLeft .. Left'Last) or Right (SRight .. Right'Last));
+ end "or";
+
+ -----------------
+ -- Build_Range --
+ -----------------
+
+ function Build_Range (Lo, Hi : Uint) return Node_Id is
+ Result : Node_Id;
+ begin
+ if Lo = Hi then
+ return Build_Val (Hi);
+ else
+ Result :=
+ Make_Range (Loc,
+ Low_Bound => Build_Val (Lo),
+ High_Bound => Build_Val (Hi));
+ Set_Etype (Result, Btyp);
+ Set_Analyzed (Result);
+ return Result;
+ end if;
+ end Build_Range;
+
+ ---------------
+ -- Build_Val --
+ ---------------
+
+ function Build_Val (V : Uint) return Node_Id is
+ Result : Node_Id;
+
+ begin
+ if Is_Enumeration_Type (Typ) then
+ Result := Get_Enum_Lit_From_Pos (Typ, V, Loc);
+ else
+ Result := Make_Integer_Literal (Loc, V);
+ end if;
+
+ Set_Etype (Result, Btyp);
+ Set_Is_Static_Expression (Result);
+ Set_Analyzed (Result);
+ return Result;
+ end Build_Val;
+
+ ---------------
+ -- Get_RList --
+ ---------------
+
+ function Get_RList (Exp : Node_Id) return RList is
+ Op : Node_Kind;
+ Val : Uint;
+
+ begin
+ -- Static expression can only be true or false
+
+ if Is_OK_Static_Expression (Exp) then
+
+ -- For False
+
+ if Expr_Value (Exp) = 0 then
+ return False_Range;
+ else
+ return True_Range;
+ end if;
+ end if;
+
+ -- Otherwise test node type
+
+ Op := Nkind (Exp);
+
+ case Op is
+
+ -- And
+
+ when N_Op_And | N_And_Then =>
+ return Get_RList (Left_Opnd (Exp))
+ and
+ Get_RList (Right_Opnd (Exp));
+
+ -- Or
+
+ when N_Op_Or | N_Or_Else =>
+ return Get_RList (Left_Opnd (Exp))
+ or
+ Get_RList (Right_Opnd (Exp));
+
+ -- Not
+
+ when N_Op_Not =>
+ return not Get_RList (Right_Opnd (Exp));
+
+ -- Comparisons of type with static value
+
+ when N_Op_Compare =>
+ -- Type is left operand
+
+ if Is_Type_Ref (Left_Opnd (Exp))
+ and then Is_OK_Static_Expression (Right_Opnd (Exp))
+ then
+ Val := Expr_Value (Right_Opnd (Exp));
+
+ -- Typ is right operand
+
+ elsif Is_Type_Ref (Right_Opnd (Exp))
+ and then Is_OK_Static_Expression (Left_Opnd (Exp))
+ then
+ Val := Expr_Value (Left_Opnd (Exp));
+
+ -- Invert sense of comparison
+
+ case Op is
+ when N_Op_Gt => Op := N_Op_Lt;
+ when N_Op_Lt => Op := N_Op_Gt;
+ when N_Op_Ge => Op := N_Op_Le;
+ when N_Op_Le => Op := N_Op_Ge;
+ when others => null;
+ end case;
+
+ -- Other cases are non-static
+
+ else
+ raise Non_Static;
+ end if;
+
+ -- Construct range according to comparison operation
+
+ case Op is
+ when N_Op_Eq =>
+ return RList'(1 => REnt'(Val, Val));
+
+ when N_Op_Ge =>
+ return RList'(1 => REnt'(Val, BHi));
+
+ when N_Op_Gt =>
+ return RList'(1 => REnt'(Val + 1, BHi));
+
+ when N_Op_Le =>
+ return RList'(1 => REnt'(BLo, Val));
+
+ when N_Op_Lt =>
+ return RList'(1 => REnt'(BLo, Val - 1));
+
+ when N_Op_Ne =>
+ return RList'(REnt'(BLo, Val - 1),
+ REnt'(Val + 1, BHi));
+
+ when others =>
+ raise Program_Error;
+ end case;
+
+ -- Membership (IN)
+
+ when N_In =>
+ if not Is_Type_Ref (Left_Opnd (Exp)) then
+ raise Non_Static;
+ end if;
+
+ if Present (Right_Opnd (Exp)) then
+ return Membership_Entry (Right_Opnd (Exp));
+ else
+ return Membership_Entries (First (Alternatives (Exp)));
+ end if;
+
+ -- Negative membership (NOT IN)
+
+ when N_Not_In =>
+ if not Is_Type_Ref (Left_Opnd (Exp)) then
+ raise Non_Static;
+ end if;
+
+ if Present (Right_Opnd (Exp)) then
+ return not Membership_Entry (Right_Opnd (Exp));
+ else
+ return not Membership_Entries (First (Alternatives (Exp)));
+ end if;
+
+ -- Function call, may be call to static predicate
+
+ when N_Function_Call =>
+ if Is_Entity_Name (Name (Exp)) then
+ declare
+ Ent : constant Entity_Id := Entity (Name (Exp));
+ begin
+ if Has_Predicates (Ent) then
+ return Stat_Pred (Etype (First_Formal (Ent)));
+ end if;
+ end;
+ end if;
+
+ -- Other function call cases are non-static
+
+ raise Non_Static;
+
+ -- Qualified expression, dig out the expression
+
+ when N_Qualified_Expression =>
+ return Get_RList (Expression (Exp));
+
+ -- Xor operator
+
+ when N_Op_Xor =>
+ return (Get_RList (Left_Opnd (Exp))
+ and not Get_RList (Right_Opnd (Exp)))
+ or (Get_RList (Right_Opnd (Exp))
+ and not Get_RList (Left_Opnd (Exp)));
+
+ -- Any other node type is non-static
+
+ when others =>
+ raise Non_Static;
+ end case;
+ end Get_RList;
+
+ ------------
+ -- Hi_Val --
+ ------------
+
+ function Hi_Val (N : Node_Id) return Uint is
+ begin
+ if Is_Static_Expression (N) then
+ return Expr_Value (N);
+ else
+ pragma Assert (Nkind (N) = N_Range);
+ return Expr_Value (High_Bound (N));
+ end if;
+ end Hi_Val;
+
+ --------------
+ -- Is_False --
+ --------------
+
+ function Is_False (R : RList) return Boolean is
+ begin
+ return R'Length = 0;
+ end Is_False;
+
+ -------------
+ -- Is_True --
+ -------------
+
+ function Is_True (R : RList) return Boolean is
+ begin
+ return R'Length = 1
+ and then R (R'First).Lo = BLo
+ and then R (R'First).Hi = BHi;
+ end Is_True;
+
+ -----------------
+ -- Is_Type_Ref --
+ -----------------
+
+ function Is_Type_Ref (N : Node_Id) return Boolean is
+ begin
+ return Nkind (N) = N_Identifier and then Chars (N) = Nam;
+ end Is_Type_Ref;
+
+ ------------
+ -- Lo_Val --
+ ------------
+
+ function Lo_Val (N : Node_Id) return Uint is
+ begin
+ if Is_Static_Expression (N) then
+ return Expr_Value (N);
+ else
+ pragma Assert (Nkind (N) = N_Range);
+ return Expr_Value (Low_Bound (N));
+ end if;
+ end Lo_Val;
+
+ ------------------------
+ -- Membership_Entries --
+ ------------------------
+
+ function Membership_Entries (N : Node_Id) return RList is
+ begin
+ if No (Next (N)) then
+ return Membership_Entry (N);
+ else
+ return Membership_Entry (N) or Membership_Entries (Next (N));
+ end if;
+ end Membership_Entries;
+
+ ----------------------
+ -- Membership_Entry --
+ ----------------------
+
+ function Membership_Entry (N : Node_Id) return RList is
+ Val : Uint;
+ SLo : Uint;
+ SHi : Uint;
+
+ begin
+ -- Range case
+
+ if Nkind (N) = N_Range then
+ if not Is_Static_Expression (Low_Bound (N))
+ or else
+ not Is_Static_Expression (High_Bound (N))
+ then
+ raise Non_Static;
+ else
+ SLo := Expr_Value (Low_Bound (N));
+ SHi := Expr_Value (High_Bound (N));
+ return RList'(1 => REnt'(SLo, SHi));
+ end if;
+
+ -- Static expression case
+
+ elsif Is_Static_Expression (N) then
+ Val := Expr_Value (N);
+ return RList'(1 => REnt'(Val, Val));
+
+ -- Identifier (other than static expression) case
+
+ else pragma Assert (Nkind (N) = N_Identifier);
+
+ -- Type case
+
+ if Is_Type (Entity (N)) then
+
+ -- If type has predicates, process them
+
+ if Has_Predicates (Entity (N)) then
+ return Stat_Pred (Entity (N));
+
+ -- For static subtype without predicates, get range
+
+ elsif Is_Static_Subtype (Entity (N)) then
+ SLo := Expr_Value (Type_Low_Bound (Entity (N)));
+ SHi := Expr_Value (Type_High_Bound (Entity (N)));
+ return RList'(1 => REnt'(SLo, SHi));
+
+ -- Any other type makes us non-static
+
+ else
+ raise Non_Static;
+ end if;
+
+ -- Any other kind of identifier in predicate (e.g. a non-static
+ -- expression value) means this is not a static predicate.
- else
- Expr :=
- Make_And_Then (Loc,
- Left_Opnd => Relocate_Node (Expr),
- Right_Opnd => Relocate_Node (Arg2));
- end if;
- end if;
+ else
+ raise Non_Static;
end if;
+ end if;
+ end Membership_Entry;
- Next_Rep_Item (Ritem);
- end loop;
- end Add_Predicates;
+ ---------------
+ -- Stat_Pred --
+ ---------------
- ----------------------------
- -- Build_Static_Predicate --
- ----------------------------
+ function Stat_Pred (Typ : Entity_Id) return RList is
+ begin
+ -- Not static if type does not have static predicates
- procedure Build_Static_Predicate is
- Exp : Node_Id;
- Alt : Node_Id;
+ if not Has_Predicates (Typ)
+ or else No (Static_Predicate (Typ))
+ then
+ raise Non_Static;
+ end if;
- Non_Static : Boolean := False;
- -- Set True if something non-static is found
+ -- Otherwise we convert the predicate list to a range list
- Plist : List_Id := No_List;
- -- The entries in Plist are either static expressions which represent
- -- a possible value, or ranges of values. Subtype marks don't appear,
- -- since we expand them out.
+ declare
+ Result : RList (1 .. List_Length (Static_Predicate (Typ)));
+ P : Node_Id;
- Lo, Hi : Uint;
- -- Low bound and high bound values of static subtype of Typ
+ begin
+ P := First (Static_Predicate (Typ));
+ for J in Result'Range loop
+ Result (J) := REnt'(Lo_Val (P), Hi_Val (P));
+ Next (P);
+ end loop;
- procedure Process_Entry (N : Node_Id);
- -- Process one entry (range or value or subtype mark)
+ return Result;
+ end;
+ end Stat_Pred;
- -------------------
- -- Process_Entry --
- -------------------
+ -- Start of processing for Build_Static_Predicate
- procedure Process_Entry (N : Node_Id) is
- SLo, SHi : Uint;
- -- Low and high bounds of range in list
+ begin
+ -- Now analyze the expression to see if it is a static predicate
- P : Node_Id;
+ declare
+ Ranges : constant RList := Get_RList (Expr);
+ -- Range list from expression if it is static
- function Build_Val (V : Uint) return Node_Id;
- -- Return an analyzed N_Identifier node referencing this value
+ Plist : List_Id;
- function Build_Range (Lo, Hi : Uint) return Node_Id;
- -- Return an analyzed N_Range node referencing this range
+ begin
+ -- Convert range list into a form for the static predicate. In the
+ -- Ranges array, we just have raw ranges, these must be converted
+ -- to properly typed and analyzed static expressions or range nodes.
- function Lo_Val (N : Node_Id) return Uint;
- -- Given static expression or static range, gets expression value
- -- or low bound of range.
+ -- Note: here we limit ranges to the ranges of the subtype, so that
+ -- a predicate is always false for values outside the subtype. That
+ -- seems fine, such values are invalid anyway, and considering them
+ -- to fail the predicate seems allowed and friendly, and furthermore
+ -- simplifies processing for case statements and loops.
- function Hi_Val (N : Node_Id) return Uint;
- -- Given static expression or static range, gets expression value
- -- of high bound of range.
+ Plist := New_List;
- -----------------
- -- Build_Range --
- -----------------
+ for J in Ranges'Range loop
+ declare
+ Lo : Uint := Ranges (J).Lo;
+ Hi : Uint := Ranges (J).Hi;
- function Build_Range (Lo, Hi : Uint) return Node_Id is
- Result : Node_Id;
begin
- if Lo = Hi then
- return Build_Val (Hi);
- else
- Result :=
- Make_Range (Sloc (N),
- Low_Bound => Build_Val (Lo),
- High_Bound => Build_Val (Hi));
- Set_Etype (Result, Typ);
- Set_Analyzed (Result);
- return Result;
- end if;
- end Build_Range;
+ -- Ignore completely out of range entry
- ---------------
- -- Build_Val --
- ---------------
+ if Hi < TLo or else Lo > THi then
+ null;
- function Build_Val (V : Uint) return Node_Id is
- Result : Node_Id;
+ -- Otherwise process entry
- begin
- if Is_Enumeration_Type (Typ) then
- Result := Get_Enum_Lit_From_Pos (Typ, V, Sloc (N));
else
- Result := Make_Integer_Literal (Sloc (N), Intval => V);
- end if;
+ -- Adjust out of range value to subtype range
- Set_Etype (Result, Typ);
- Set_Is_Static_Expression (Result);
- Set_Analyzed (Result);
- return Result;
- end Build_Val;
+ if Lo < TLo then
+ Lo := TLo;
+ end if;
- ------------
- -- Hi_Val --
- ------------
+ if Hi > THi then
+ Hi := THi;
+ end if;
- function Hi_Val (N : Node_Id) return Uint is
- begin
- if Nkind (N) = N_Identifier then
- return Expr_Value (N);
- else
- return Expr_Value (High_Bound (N));
+ -- Convert range into required form
+
+ if Lo = Hi then
+ Append_To (Plist, Build_Val (Lo));
+ else
+ Append_To (Plist, Build_Range (Lo, Hi));
+ end if;
end if;
- end Hi_Val;
+ end;
+ end loop;
- ------------
- -- Lo_Val --
- ------------
+ -- Processing was successful and all entries were static, so now we
+ -- can store the result as the predicate list.
- function Lo_Val (N : Node_Id) return Uint is
- begin
- if Nkind (N) = N_Identifier then
- return Expr_Value (N);
- else
- return Expr_Value (Low_Bound (N));
- end if;
- end Lo_Val;
+ Set_Static_Predicate (Typ, Plist);
- -- Start of processing for Process_Entry
+ -- The processing for static predicates put the expression into
+ -- canonical form as a series of ranges. It also eliminated
+ -- duplicates and collapsed and combined ranges. We might as well
+ -- replace the alternatives list of the right operand of the
+ -- membership test with the static predicate list, which will
+ -- usually be more efficient.
+
+ declare
+ New_Alts : constant List_Id := New_List;
+ Old_Node : Node_Id;
+ New_Node : Node_Id;
begin
- -- Range case
+ Old_Node := First (Plist);
+ while Present (Old_Node) loop
+ New_Node := New_Copy (Old_Node);
- if Nkind (N) = N_Range then
- if not Is_Static_Expression (Low_Bound (N))
- or else
- not Is_Static_Expression (High_Bound (N))
- then
- Non_Static := True;
- return;
- else
- SLo := Lo_Val (N);
- SHi := Hi_Val (N);
+ if Nkind (New_Node) = N_Range then
+ Set_Low_Bound (New_Node, New_Copy (Low_Bound (Old_Node)));
+ Set_High_Bound (New_Node, New_Copy (High_Bound (Old_Node)));
end if;
- -- Identifier case
+ Append_To (New_Alts, New_Node);
+ Next (Old_Node);
+ end loop;
- else pragma Assert (Nkind (N) = N_Identifier);
+ -- If empty list, replace by False
- -- Static expression case
+ if Is_Empty_List (New_Alts) then
+ Rewrite (Expr, New_Occurrence_Of (Standard_False, Loc));
- if Is_Static_Expression (N) then
- SLo := Lo_Val (N);
- SHi := Hi_Val (N);
+ -- Else replace by set membership test
- -- Type case
+ else
+ Rewrite (Expr,
+ Make_In (Loc,
+ Left_Opnd => Make_Identifier (Loc, Nam),
+ Right_Opnd => Empty,
+ Alternatives => New_Alts));
+
+ -- Resolve new expression in function context
+
+ Install_Formals (Predicate_Function (Typ));
+ Push_Scope (Predicate_Function (Typ));
+ Analyze_And_Resolve (Expr, Standard_Boolean);
+ Pop_Scope;
+ end if;
+ end;
+ end;
- elsif Is_Type (Entity (N)) then
+ -- If non-static, return doing nothing
- -- If type has static predicates, process them recursively
+ exception
+ when Non_Static =>
+ return;
+ end Build_Static_Predicate;
- if Present (Static_Predicate (Entity (N))) then
- P := First (Static_Predicate (Entity (N)));
- while Present (P) loop
- Process_Entry (P);
+ -----------------------------------------
+ -- Check_Aspect_At_End_Of_Declarations --
+ -----------------------------------------
- if Non_Static then
- return;
- else
- Next (P);
- end if;
- end loop;
+ procedure Check_Aspect_At_End_Of_Declarations (ASN : Node_Id) is
+ Ent : constant Entity_Id := Entity (ASN);
+ Ident : constant Node_Id := Identifier (ASN);
- return;
+ Freeze_Expr : constant Node_Id := Expression (ASN);
+ -- Expression from call to Check_Aspect_At_Freeze_Point
- -- For static subtype without predicates, get range
+ End_Decl_Expr : constant Node_Id := Entity (Ident);
+ -- Expression to be analyzed at end of declarations
- elsif Is_Static_Subtype (Entity (N))
- and then not Has_Predicates (Entity (N))
- then
- SLo := Expr_Value (Type_Low_Bound (Entity (N)));
- SHi := Expr_Value (Type_High_Bound (Entity (N)));
+ T : constant Entity_Id := Etype (Freeze_Expr);
+ -- Type required for preanalyze call
- -- Any other type makes us non-static
+ A_Id : constant Aspect_Id := Get_Aspect_Id (Chars (Ident));
- else
- Non_Static := True;
- return;
- end if;
+ Err : Boolean;
+ -- Set False if error
- -- Any other kind of identifier in predicate (e.g. a non-static
- -- expression value) means this is not a static predicate.
+ -- On entry to this procedure, Entity (Ident) contains a copy of the
+ -- original expression from the aspect, saved for this purpose, and
+ -- but Expression (Ident) is a preanalyzed copy of the expression,
+ -- preanalyzed just after the freeze point.
- else
- Non_Static := True;
- return;
- end if;
- end if;
+ begin
+ -- Case of stream attributes, just have to compare entities
- -- Here with SLo and SHi set for (possibly single element) range
- -- of entry to insert in Plist. Non-static if out of range.
+ if A_Id = Aspect_Input or else
+ A_Id = Aspect_Output or else
+ A_Id = Aspect_Read or else
+ A_Id = Aspect_Write
+ then
+ Analyze (End_Decl_Expr);
+ Err := Entity (End_Decl_Expr) /= Entity (Freeze_Expr);
- if SLo < Lo or else SHi > Hi then
- Non_Static := True;
- return;
- end if;
+ 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.
- -- If no Plist currently, create it
+ Set_Is_Frozen (Ent, False);
+ Analyze (End_Decl_Expr);
+ Analyze (Aspect_Rep_Item (ASN));
+ Set_Is_Frozen (Ent, True);
- if No (Plist) then
- Plist := New_List (Build_Range (SLo, SHi));
- return;
+ -- If the end of declarations comes before any other freeze
+ -- point, the Freeze_Expr is not analyzed: no check needed.
- -- Otherwise search Plist for insertion point
+ Err :=
+ Analyzed (Freeze_Expr)
+ and then not In_Instance
+ and then Entity (End_Decl_Expr) /= Entity (Freeze_Expr);
- else
- P := First (Plist);
- loop
- -- Case of inserting before current entry
+ -- All other cases
- if SHi < Lo_Val (P) - 1 then
- Insert_Before (P, Build_Range (SLo, SHi));
- exit;
+ else
+ -- 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.
- -- Case of belongs past current entry
+ if No (T) then
+ Check_Aspect_At_Freeze_Point (ASN);
+ return;
- elsif SLo > Hi_Val (P) + 1 then
+ -- 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.
- -- End of list case
+ 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;
- if No (Next (P)) then
- Append_To (Plist, Build_Range (SLo, SHi));
- exit;
+ Err := not Fully_Conformant_Expressions (End_Decl_Expr, Freeze_Expr);
+ end if;
- -- Else just move to next item on list
+ -- Output error message if error
- else
- Next (P);
- end if;
+ if Err then
+ Error_Msg_NE
+ ("visibility of aspect for& changes after freeze point",
+ ASN, Ent);
+ Error_Msg_NE
+ ("?info: & is frozen here, aspects evaluated at this point",
+ Freeze_Node (Ent), Ent);
+ end if;
+ end Check_Aspect_At_End_Of_Declarations;
- -- Case of extending current entyr, and in overlap cases
- -- may also eat up entries past this one.
+ ----------------------------------
+ -- Check_Aspect_At_Freeze_Point --
+ ----------------------------------
- else
- declare
- New_Lo : constant Uint := UI_Min (Lo_Val (P), SLo);
- New_Hi : Uint := UI_Max (Hi_Val (P), SHi);
+ procedure Check_Aspect_At_Freeze_Point (ASN : Node_Id) is
+ Ident : constant Node_Id := Identifier (ASN);
+ -- Identifier (use Entity field to save expression)
- begin
- -- See if there are entries past us that we eat up
+ T : Entity_Id;
+ -- Type required for preanalyze call
- while Present (Next (P))
- and then Lo_Val (Next (P)) <= New_Hi + 1
- loop
- New_Hi := Hi_Val (Next (P));
- Remove (Next (P));
- end loop;
+ A_Id : constant Aspect_Id := Get_Aspect_Id (Chars (Ident));
- -- We now need to replace the current node P with
- -- a new entry New_Lo .. New_Hi.
+ begin
+ -- On entry to this procedure, Entity (Ident) contains a copy of the
+ -- original expression from the aspect, saved for this purpose.
- Insert_After (P, Build_Range (New_Lo, New_Hi));
- Remove (P);
- exit;
- end;
- end if;
- end loop;
- end if;
- end Process_Entry;
+ -- On exit from this procedure Entity (Ident) is unchanged, still
+ -- containing that copy, but Expression (Ident) is a preanalyzed copy
+ -- of the expression, preanalyzed just after the freeze point.
- -- Start of processing for Build_Static_Predicate
+ -- Make a copy of the expression to be preanalyed
- begin
- -- Immediately non-static if our subtype is non static, or we
- -- do not have an appropriate discrete subtype in the first place.
+ Set_Expression (ASN, New_Copy_Tree (Entity (Ident)));
- if not Ekind_In (Typ, E_Enumeration_Subtype,
- E_Modular_Integer_Subtype,
- E_Signed_Integer_Subtype)
- or else not Is_Static_Subtype (Typ)
- then
- return;
- end if;
+ -- Find type for preanalyze call
- Lo := Expr_Value (Type_Low_Bound (Typ));
- Hi := Expr_Value (Type_High_Bound (Typ));
+ case A_Id is
- -- Check if we have membership predicate
+ -- No_Aspect should be impossible
- if Nkind (Expr) = N_In then
- Exp := Expr;
+ when No_Aspect =>
+ raise Program_Error;
- -- Allow qualified expression with membership predicate inside
+ -- Library unit aspects should be impossible (never delayed)
- elsif Nkind (Expr) = N_Qualified_Expression
- and then Nkind (Expression (Expr)) = N_In
- then
- Exp := Expression (Expr);
+ when Library_Unit_Aspects =>
+ raise Program_Error;
- -- Anything else cannot be a static predicate
+ -- Aspects taking an optional boolean argument. Should be impossible
+ -- since these are never delayed.
- else
- return;
- end if;
+ when Boolean_Aspects =>
+ raise Program_Error;
- -- We have a membership operation, so we have a potentially static
- -- predicate, collect and canonicalize the entries in the list.
+ -- Test_Case aspect applies to entries and subprograms, hence should
+ -- never be delayed.
- if Present (Right_Opnd (Exp)) then
- Process_Entry (Right_Opnd (Exp));
+ when Aspect_Test_Case =>
+ raise Program_Error;
- if Non_Static then
- return;
- end if;
+ when Aspect_Attach_Handler =>
+ T := RTE (RE_Interrupt_ID);
- else
- Alt := First (Alternatives (Exp));
- while Present (Alt) loop
- Process_Entry (Alt);
+ -- Default_Value is resolved with the type entity in question
- if Non_Static then
- return;
- end if;
+ when Aspect_Default_Value =>
+ T := Entity (ASN);
- Next (Alt);
- end loop;
- end if;
+ -- Default_Component_Value is resolved with the component type
- -- Processing was successful and all entries were static, so
- -- now we can store the result as the predicate list.
+ when Aspect_Default_Component_Value =>
+ T := Component_Type (Entity (ASN));
- Set_Static_Predicate (Typ, Plist);
- end Build_Static_Predicate;
+ -- Aspects corresponding to attribute definition clauses
- -- Start of processing for Build_Predicate_Function
+ when Aspect_Address =>
+ T := RTE (RE_Address);
- begin
- -- Initialize for construction of statement list
+ when Aspect_Bit_Order =>
+ T := RTE (RE_Bit_Order);
- Expr := Empty;
- FDecl := Empty;
- FBody := Empty;
+ when Aspect_CPU =>
+ T := RTE (RE_CPU_Range);
- -- Return if already built or if type does not have predicates
+ when Aspect_Dispatching_Domain =>
+ T := RTE (RE_Dispatching_Domain);
- if not Has_Predicates (Typ)
- or else Present (Predicate_Function (Typ))
- then
- return;
- end if;
+ when Aspect_External_Tag =>
+ T := Standard_String;
- -- Add Predicates for the current type
+ when Aspect_Priority | Aspect_Interrupt_Priority =>
+ T := Standard_Integer;
- Add_Predicates;
+ when Aspect_Small =>
+ T := Universal_Real;
- -- Add predicates for ancestor if present
+ -- For a simple storage pool, we have to retrieve the type of the
+ -- pool object associated with the aspect's corresponding attribute
+ -- definition clause.
- declare
- Atyp : constant Entity_Id := Nearest_Ancestor (Typ);
- begin
- if Present (Atyp) then
- Add_Call (Atyp);
- end if;
- end;
+ when Aspect_Simple_Storage_Pool =>
+ T := Etype (Expression (Aspect_Rep_Item (ASN)));
- -- If we have predicates, build the function
+ when Aspect_Storage_Pool =>
+ T := Class_Wide_Type (RTE (RE_Root_Storage_Pool));
- if Present (Expr) then
+ when Aspect_Alignment |
+ Aspect_Component_Size |
+ Aspect_Machine_Radix |
+ Aspect_Object_Size |
+ Aspect_Size |
+ Aspect_Storage_Size |
+ Aspect_Stream_Size |
+ Aspect_Value_Size =>
+ T := Any_Integer;
- -- Deal with static predicate case
+ -- Stream attribute. Special case, the expression is just an entity
+ -- that does not need any resolution, so just analyze.
- Build_Static_Predicate;
+ when Aspect_Input |
+ Aspect_Output |
+ Aspect_Read |
+ Aspect_Write =>
+ Analyze (Expression (ASN));
+ return;
- -- Build function declaration
+ -- Same for Iterator aspects, where the expression is a function
+ -- name. Legality rules are checked separately.
- pragma Assert (Has_Predicates (Typ));
- SId :=
- Make_Defining_Identifier (Loc,
- Chars => New_External_Name (Chars (Typ), "Predicate"));
- Set_Has_Predicates (SId);
- Set_Predicate_Function (Typ, SId);
+ when Aspect_Constant_Indexing |
+ Aspect_Default_Iterator |
+ Aspect_Iterator_Element |
+ Aspect_Implicit_Dereference |
+ Aspect_Variable_Indexing =>
+ Analyze (Expression (ASN));
+ return;
- Spec :=
- Make_Function_Specification (Loc,
- Defining_Unit_Name => SId,
- Parameter_Specifications => New_List (
- Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Chars => Object_Name),
- Parameter_Type => New_Occurrence_Of (Typ, Loc))),
- Result_Definition =>
- New_Occurrence_Of (Standard_Boolean, Loc));
+ -- Suppress/Unsuppress/Synchronization/Warnings should not be delayed
- FDecl :=
- Make_Subprogram_Declaration (Loc,
- Specification => Spec);
+ when Aspect_Suppress |
+ Aspect_Unsuppress |
+ Aspect_Synchronization |
+ Aspect_Warnings =>
+ raise Program_Error;
- -- Build function body
+ -- Pre/Post/Invariant/Predicate take boolean expressions
- SId :=
- Make_Defining_Identifier (Loc,
- Chars => New_External_Name (Chars (Typ), "Predicate"));
+ when Aspect_Dynamic_Predicate |
+ Aspect_Invariant |
+ Aspect_Pre |
+ Aspect_Precondition |
+ Aspect_Post |
+ Aspect_Postcondition |
+ Aspect_Predicate |
+ Aspect_Static_Predicate |
+ Aspect_Type_Invariant =>
+ T := Standard_Boolean;
- Spec :=
- Make_Function_Specification (Loc,
- Defining_Unit_Name => SId,
- Parameter_Specifications => New_List (
- Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Chars => Object_Name),
- Parameter_Type =>
- New_Occurrence_Of (Typ, Loc))),
- Result_Definition =>
- New_Occurrence_Of (Standard_Boolean, Loc));
+ when Aspect_Dimension |
+ Aspect_Dimension_System =>
+ raise Program_Error;
- FBody :=
- Make_Subprogram_Body (Loc,
- Specification => Spec,
- Declarations => Empty_List,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (
- Make_Simple_Return_Statement (Loc,
- Expression => Expr))));
- end if;
- end Build_Predicate_Function;
+ end case;
+
+ -- Do the preanalyze call
+
+ Preanalyze_Spec_Expression (Expression (ASN), T);
+ end Check_Aspect_At_Freeze_Point;
-----------------------------------
-- Check_Constant_Address_Clause --
Set_Component_Clause (Fent,
Make_Component_Clause (Loc,
- Component_Name =>
- Make_Identifier (Loc,
- Chars => Name_uTag),
-
- Position =>
- Make_Integer_Literal (Loc,
- Intval => Uint_0),
-
- First_Bit =>
- Make_Integer_Literal (Loc,
- Intval => Uint_0),
+ Component_Name => Make_Identifier (Loc, Name_uTag),
+ Position => Make_Integer_Literal (Loc, Uint_0),
+ First_Bit => Make_Integer_Literal (Loc, Uint_0),
Last_Bit =>
Make_Integer_Literal (Loc,
UI_From_Int (System_Address_Size))));
-- Check bit position out of range of specified size
if Has_Size_Clause (Rectype)
- and then Esize (Rectype) <= Lbit
+ and then RM_Size (Rectype) <= Lbit
then
Error_Msg_N
("bit number out of range of specified size",
else
Subp_Id :=
- Make_Defining_Identifier (Loc,
- Chars => New_External_Name (Sname, 'V'));
+ Make_Defining_Identifier (Loc, New_External_Name (Sname, 'V'));
Subp_Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Subp_Id,
if Is_Incomplete_Or_Private_Type (T)
and then No (Underlying_Type (T))
+ and then
+ (Nkind (N) /= N_Pragma
+ or else Get_Pragma_Id (N) /= Pragma_Import)
then
Error_Msg_N
("representation item must be after full type declaration", N);
-- 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);
return False;
end Rep_Item_Too_Late;
+ -------------------------------------
+ -- Replace_Type_References_Generic --
+ -------------------------------------
+
+ procedure Replace_Type_References_Generic (N : Node_Id; TName : Name_Id) is
+
+ function Replace_Node (N : Node_Id) return Traverse_Result;
+ -- Processes a single node in the traversal procedure below, checking
+ -- if node N should be replaced, and if so, doing the replacement.
+
+ procedure Replace_Type_Refs is new Traverse_Proc (Replace_Node);
+ -- This instantiation provides the body of Replace_Type_References
+
+ ------------------
+ -- Replace_Node --
+ ------------------
+
+ function Replace_Node (N : Node_Id) return Traverse_Result is
+ S : Entity_Id;
+ P : Node_Id;
+
+ begin
+ -- Case of identifier
+
+ if Nkind (N) = N_Identifier then
+
+ -- If not the type name, all done with this node
+
+ if Chars (N) /= TName then
+ return Skip;
+
+ -- Otherwise do the replacement and we are done with this node
+
+ else
+ Replace_Type_Reference (N);
+ return Skip;
+ end if;
+
+ -- Case of selected component (which is what a qualification
+ -- looks like in the unanalyzed tree, which is what we have.
+
+ elsif Nkind (N) = N_Selected_Component then
+
+ -- If selector name is not our type, keeping going (we might
+ -- still have an occurrence of the type in the prefix).
+
+ if Nkind (Selector_Name (N)) /= N_Identifier
+ or else Chars (Selector_Name (N)) /= TName
+ then
+ return OK;
+
+ -- Selector name is our type, check qualification
+
+ else
+ -- Loop through scopes and prefixes, doing comparison
+
+ S := Current_Scope;
+ P := Prefix (N);
+ loop
+ -- Continue if no more scopes or scope with no name
+
+ if No (S) or else Nkind (S) not in N_Has_Chars then
+ return OK;
+ end if;
+
+ -- Do replace if prefix is an identifier matching the
+ -- scope that we are currently looking at.
+
+ if Nkind (P) = N_Identifier
+ and then Chars (P) = Chars (S)
+ then
+ Replace_Type_Reference (N);
+ return Skip;
+ end if;
+
+ -- Go check scope above us if prefix is itself of the
+ -- form of a selected component, whose selector matches
+ -- the scope we are currently looking at.
+
+ if Nkind (P) = N_Selected_Component
+ and then Nkind (Selector_Name (P)) = N_Identifier
+ and then Chars (Selector_Name (P)) = Chars (S)
+ then
+ S := Scope (S);
+ P := Prefix (P);
+
+ -- For anything else, we don't have a match, so keep on
+ -- going, there are still some weird cases where we may
+ -- still have a replacement within the prefix.
+
+ else
+ return OK;
+ end if;
+ end loop;
+ end if;
+
+ -- Continue for any other node kind
+
+ else
+ return OK;
+ end if;
+ end Replace_Node;
+
+ begin
+ Replace_Type_Refs (N);
+ end Replace_Type_References_Generic;
+
-------------------------
-- Same_Representation --
-------------------------
and then Known_Component_Size (T2)
and then Component_Size (T1) = Component_Size (T2)
then
- return True;
+ if VM_Target = No_VM then
+ return True;
+
+ -- In VM targets the representation of arrays with aliased
+ -- components differs from arrays with non-aliased components
+
+ else
+ return Has_Aliased_Components (Base_Type (T1))
+ =
+ Has_Aliased_Components (Base_Type (T2));
+ end if;
end if;
end if;
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
