function Entity_Hash (E : Entity_Id) return Entity_Hashed_Range;
-- Hash function for hash table
+ procedure Traverse_Declaration_Or_Statement
+ (N : Node_Id;
+ Process : Node_Processing;
+ Inside_Stubs : Boolean);
procedure Traverse_Declarations_Or_Statements
(L : List_Id;
Process : Node_Processing;
procedure Add_SPARK_Scope (N : Node_Id) is
E : constant Entity_Id := Defining_Entity (N);
Loc : constant Source_Ptr := Sloc (E);
+
+ -- The character describing the kind of scope is chosen to be the same
+ -- as the one describing the corresponding entity in cross references,
+ -- see Xref_Entity_Letters in lib-xrefs.ads
+
Typ : Character;
begin
end if;
case Ekind (E) is
- when E_Function | E_Generic_Function =>
- Typ := 'V';
-
- when E_Procedure | E_Generic_Procedure =>
- Typ := 'U';
-
- when E_Subprogram_Body =>
- declare
- Spec : Node_Id;
-
- begin
- Spec := Parent (E);
-
- if Nkind (Spec) = N_Defining_Program_Unit_Name then
- Spec := Parent (Spec);
- end if;
-
- if Nkind (Spec) = N_Function_Specification then
- Typ := 'V';
- else
- pragma Assert
- (Nkind (Spec) = N_Procedure_Specification);
- Typ := 'U';
- end if;
- end;
-
- when E_Package | E_Package_Body | E_Generic_Package =>
- Typ := 'K';
+ when E_Entry
+ | E_Function
+ | E_Generic_Function
+ | E_Generic_Package
+ | E_Generic_Procedure
+ | E_Package
+ | E_Procedure
+ =>
+ Typ := Xref_Entity_Letters (Ekind (E));
+
+ when E_Package_Body
+ | E_Subprogram_Body
+ =>
+ Typ := Xref_Entity_Letters (Ekind (Unique_Entity (E)));
when E_Void =>
- -- Compilation of prj-attr.adb with -gnatn creates a node with
- -- entity E_Void for the package defined at a-charac.ads16:13
+ -- Compilation of prj-attr.adb with -gnatn creates a node with
+ -- entity E_Void for the package defined at a-charac.ads16:13.
-- ??? TBD
return;
procedure Detect_And_Add_SPARK_Scope (N : Node_Id) is
begin
- if Nkind_In (N, N_Subprogram_Declaration,
+ if Nkind_In (N, N_Entry_Body,
+ N_Entry_Declaration,
+ N_Package_Body,
+ N_Package_Body_Stub,
+ N_Package_Declaration,
N_Subprogram_Body,
N_Subprogram_Body_Stub,
- N_Package_Declaration,
- N_Package_Body)
+ N_Subprogram_Declaration)
then
Add_SPARK_Scope (N);
end if;
-- Traverse the unit
- if Nkind (Lu) = N_Subprogram_Body then
- Traverse_Subprogram_Body (Lu, Process, Inside_Stubs);
-
- elsif Nkind (Lu) = N_Subprogram_Declaration then
- null;
-
- elsif Nkind (Lu) = N_Package_Declaration then
- Traverse_Package_Declaration (Lu, Process, Inside_Stubs);
-
- elsif Nkind (Lu) = N_Package_Body then
- Traverse_Package_Body (Lu, Process, Inside_Stubs);
-
- elsif Nkind (Lu) = N_Protected_Body then
- Traverse_Protected_Body (Lu, Process, Inside_Stubs);
-
- -- All other cases of compilation units (e.g. renamings), are not
- -- declarations, or else generic declarations which are ignored.
-
- else
- null;
- end if;
+ Traverse_Declaration_Or_Statement (Lu, Process, Inside_Stubs);
end Traverse_Compilation_Unit;
- -----------------------------------------
- -- Traverse_Declarations_Or_Statements --
- -----------------------------------------
+ ---------------------------------------
+ -- Traverse_Declaration_Or_Statement --
+ ---------------------------------------
- procedure Traverse_Declarations_Or_Statements
- (L : List_Id;
+ procedure Traverse_Declaration_Or_Statement
+ (N : Node_Id;
Process : Node_Processing;
Inside_Stubs : Boolean)
is
- N : Node_Id;
-
begin
- -- Loop through statements or declarations
-
- N := First (L);
- while Present (N) loop
- -- Call Process on all declarations
-
- if Nkind (N) in N_Declaration
- or else
- Nkind (N) in N_Later_Decl_Item
- then
- Process (N);
- end if;
-
- case Nkind (N) is
-
- -- Package declaration
-
- when N_Package_Declaration =>
- Traverse_Package_Declaration (N, Process, Inside_Stubs);
-
- -- Package body
-
- when N_Package_Body =>
- if Ekind (Defining_Entity (N)) /= E_Generic_Package then
- Traverse_Package_Body (N, Process, Inside_Stubs);
- end if;
+ case Nkind (N) is
+ when N_Package_Declaration =>
+ Traverse_Package_Declaration (N, Process, Inside_Stubs);
- when N_Package_Body_Stub =>
- if Present (Library_Unit (N)) then
- declare
- Body_N : constant Node_Id := Get_Body_From_Stub (N);
- begin
- if Inside_Stubs
- and then
- Ekind (Defining_Entity (Body_N)) /= E_Generic_Package
- then
- Traverse_Package_Body (Body_N, Process, Inside_Stubs);
- end if;
- end;
- end if;
-
- -- Subprogram declaration
+ when N_Package_Body =>
+ if Ekind (Defining_Entity (N)) /= E_Generic_Package then
+ Traverse_Package_Body (N, Process, Inside_Stubs);
+ end if;
- when N_Subprogram_Declaration =>
- null;
+ when N_Package_Body_Stub =>
+ if Present (Library_Unit (N)) then
+ declare
+ Body_N : constant Node_Id := Get_Body_From_Stub (N);
+ begin
+ if Inside_Stubs
+ and then
+ Ekind (Defining_Entity (Body_N)) /= E_Generic_Package
+ then
+ Traverse_Package_Body (Body_N, Process, Inside_Stubs);
+ end if;
+ end;
+ end if;
- -- Subprogram body
+ when N_Subprogram_Declaration =>
+ null;
- when N_Subprogram_Body =>
- if not Is_Generic_Subprogram (Defining_Entity (N)) then
- Traverse_Subprogram_Body (N, Process, Inside_Stubs);
- end if;
+ when N_Entry_Body
+ | N_Subprogram_Body
+ =>
+ if not Is_Generic_Subprogram (Defining_Entity (N)) then
+ Traverse_Subprogram_Body (N, Process, Inside_Stubs);
+ end if;
- when N_Subprogram_Body_Stub =>
- if Present (Library_Unit (N)) then
- declare
- Body_N : constant Node_Id := Get_Body_From_Stub (N);
- begin
- if Inside_Stubs
- and then
- not Is_Generic_Subprogram (Defining_Entity (Body_N))
- then
- Traverse_Subprogram_Body
- (Body_N, Process, Inside_Stubs);
- end if;
- end;
- end if;
+ when N_Subprogram_Body_Stub =>
+ if Present (Library_Unit (N)) then
+ declare
+ Body_N : constant Node_Id := Get_Body_From_Stub (N);
+ begin
+ if Inside_Stubs
+ and then
+ not Is_Generic_Subprogram (Defining_Entity (Body_N))
+ then
+ Traverse_Subprogram_Body (Body_N, Process, Inside_Stubs);
+ end if;
+ end;
+ end if;
- -- Protected unit
+ when N_Protected_Definition =>
+ Traverse_Declarations_Or_Statements
+ (Visible_Declarations (N), Process, Inside_Stubs);
+ Traverse_Declarations_Or_Statements
+ (Private_Declarations (N), Process, Inside_Stubs);
- when N_Protected_Definition =>
- Traverse_Declarations_Or_Statements
- (Visible_Declarations (N), Process, Inside_Stubs);
- Traverse_Declarations_Or_Statements
- (Private_Declarations (N), Process, Inside_Stubs);
+ when N_Protected_Body =>
+ Traverse_Protected_Body (N, Process, Inside_Stubs);
- when N_Protected_Body =>
- Traverse_Protected_Body (N, Process, Inside_Stubs);
+ when N_Protected_Body_Stub =>
+ if Present (Library_Unit (N)) then
+ declare
+ Body_N : constant Node_Id := Get_Body_From_Stub (N);
+ begin
+ if Inside_Stubs then
+ Traverse_Declarations_Or_Statements
+ (Declarations (Body_N), Process, Inside_Stubs);
+ end if;
+ end;
+ end if;
- when N_Protected_Body_Stub =>
- if Present (Library_Unit (N)) then
- declare
- Body_N : constant Node_Id := Get_Body_From_Stub (N);
- begin
- if Inside_Stubs then
- Traverse_Declarations_Or_Statements
- (Declarations (Body_N), Process, Inside_Stubs);
- end if;
- end;
- end if;
+ when N_Task_Definition =>
+ Traverse_Declarations_Or_Statements
+ (Visible_Declarations (N), Process, Inside_Stubs);
+ Traverse_Declarations_Or_Statements
+ (Private_Declarations (N), Process, Inside_Stubs);
- -- Task unit
+ when N_Task_Body =>
+ Traverse_Declarations_Or_Statements
+ (Declarations (N), Process, Inside_Stubs);
+ Traverse_Handled_Statement_Sequence
+ (Handled_Statement_Sequence (N), Process, Inside_Stubs);
- when N_Task_Definition =>
- Traverse_Declarations_Or_Statements
- (Visible_Declarations (N), Process, Inside_Stubs);
- Traverse_Declarations_Or_Statements
- (Private_Declarations (N), Process, Inside_Stubs);
+ when N_Task_Body_Stub =>
+ if Present (Library_Unit (N)) then
+ declare
+ Body_N : constant Node_Id := Get_Body_From_Stub (N);
+ begin
+ if Inside_Stubs then
+ Traverse_Declarations_Or_Statements
+ (Declarations (Body_N), Process, Inside_Stubs);
+ Traverse_Handled_Statement_Sequence
+ (Handled_Statement_Sequence (Body_N), Process,
+ Inside_Stubs);
+ end if;
+ end;
+ end if;
- when N_Task_Body =>
- Traverse_Declarations_Or_Statements
- (Declarations (N), Process, Inside_Stubs);
- Traverse_Handled_Statement_Sequence
- (Handled_Statement_Sequence (N), Process, Inside_Stubs);
+ when N_Block_Statement =>
+ Traverse_Declarations_Or_Statements
+ (Declarations (N), Process, Inside_Stubs);
+ Traverse_Handled_Statement_Sequence
+ (Handled_Statement_Sequence (N), Process, Inside_Stubs);
- when N_Task_Body_Stub =>
- if Present (Library_Unit (N)) then
- declare
- Body_N : constant Node_Id := Get_Body_From_Stub (N);
- begin
- if Inside_Stubs then
- Traverse_Declarations_Or_Statements
- (Declarations (Body_N), Process, Inside_Stubs);
- Traverse_Handled_Statement_Sequence
- (Handled_Statement_Sequence (Body_N), Process,
- Inside_Stubs);
- end if;
- end;
- end if;
+ when N_If_Statement =>
- -- Block statement
+ -- Traverse the statements in the THEN part
- when N_Block_Statement =>
- Traverse_Declarations_Or_Statements
- (Declarations (N), Process, Inside_Stubs);
- Traverse_Handled_Statement_Sequence
- (Handled_Statement_Sequence (N), Process, Inside_Stubs);
+ Traverse_Declarations_Or_Statements
+ (Then_Statements (N), Process, Inside_Stubs);
- when N_If_Statement =>
+ -- Loop through ELSIF parts if present
- -- Traverse the statements in the THEN part
+ if Present (Elsif_Parts (N)) then
+ declare
+ Elif : Node_Id := First (Elsif_Parts (N));
- Traverse_Declarations_Or_Statements
- (Then_Statements (N), Process, Inside_Stubs);
+ begin
+ while Present (Elif) loop
+ Traverse_Declarations_Or_Statements
+ (Then_Statements (Elif), Process, Inside_Stubs);
+ Next (Elif);
+ end loop;
+ end;
+ end if;
- -- Loop through ELSIF parts if present
+ -- Finally traverse the ELSE statements if present
- if Present (Elsif_Parts (N)) then
- declare
- Elif : Node_Id := First (Elsif_Parts (N));
+ Traverse_Declarations_Or_Statements
+ (Else_Statements (N), Process, Inside_Stubs);
- begin
- while Present (Elif) loop
- Traverse_Declarations_Or_Statements
- (Then_Statements (Elif), Process, Inside_Stubs);
- Next (Elif);
- end loop;
- end;
- end if;
+ when N_Case_Statement =>
- -- Finally traverse the ELSE statements if present
+ -- Process case branches
- Traverse_Declarations_Or_Statements
- (Else_Statements (N), Process, Inside_Stubs);
+ declare
+ Alt : Node_Id;
+ begin
+ Alt := First (Alternatives (N));
+ while Present (Alt) loop
+ Traverse_Declarations_Or_Statements
+ (Statements (Alt), Process, Inside_Stubs);
+ Next (Alt);
+ end loop;
+ end;
- -- Case statement
+ when N_Extended_Return_Statement =>
+ Traverse_Handled_Statement_Sequence
+ (Handled_Statement_Sequence (N), Process, Inside_Stubs);
- when N_Case_Statement =>
+ when N_Loop_Statement =>
+ Traverse_Declarations_Or_Statements
+ (Statements (N), Process, Inside_Stubs);
- -- Process case branches
+ -- Generic declarations are ignored
- declare
- Alt : Node_Id;
- begin
- Alt := First (Alternatives (N));
- while Present (Alt) loop
- Traverse_Declarations_Or_Statements
- (Statements (Alt), Process, Inside_Stubs);
- Next (Alt);
- end loop;
- end;
+ when others =>
+ null;
+ end case;
+ end Traverse_Declaration_Or_Statement;
- -- Extended return statement
+ -----------------------------------------
+ -- Traverse_Declarations_Or_Statements --
+ -----------------------------------------
- when N_Extended_Return_Statement =>
- Traverse_Handled_Statement_Sequence
- (Handled_Statement_Sequence (N), Process, Inside_Stubs);
+ procedure Traverse_Declarations_Or_Statements
+ (L : List_Id;
+ Process : Node_Processing;
+ Inside_Stubs : Boolean)
+ is
+ N : Node_Id;
- -- Loop
+ begin
+ -- Loop through statements or declarations
- when N_Loop_Statement =>
- Traverse_Declarations_Or_Statements
- (Statements (N), Process, Inside_Stubs);
+ N := First (L);
+ while Present (N) loop
+ -- Call Process on all declarations
- -- Generic declarations are ignored
+ if Nkind (N) in N_Declaration
+ or else
+ Nkind (N) in N_Later_Decl_Item
+ then
+ Process (N);
+ end if;
- when others =>
- null;
- end case;
+ Traverse_Declaration_Or_Statement (N, Process, Inside_Stubs);
Next (N);
end loop;
return;
end if;
- -- Special processing for cases where the prefix is an object. For
- -- this purpose, a string literal counts as an object (attributes
- -- of string literals can only appear in generated code).
+ -- Special processing for cases where the prefix is an object. For this
+ -- purpose, a string literal counts as an object (attributes of string
+ -- literals can only appear in generated code).
if Is_Object_Reference (P) or else Nkind (P) = N_String_Literal then
-- For Component_Size, the prefix is an array object, and we apply
- -- the attribute to the type of the object. This is allowed for
- -- both unconstrained and constrained arrays, since the bounds
- -- have no influence on the value of this attribute.
+ -- the attribute to the type of the object. This is allowed for both
+ -- unconstrained and constrained arrays, since the bounds have no
+ -- influence on the value of this attribute.
if Id = Attribute_Component_Size then
P_Entity := Etype (P);
+ -- For Enum_Rep, evaluation depends on the nature of the prefix and
+ -- the optional argument.
+
+ elsif Id = Attribute_Enum_Rep then
+ if Is_Entity_Name (P) then
+
+ -- The prefix denotes a constant or an enumeration literal, the
+ -- attribute can be folded.
+
+ if Ekind_In (Entity (P), E_Constant, E_Enumeration_Literal) then
+ P_Entity := Etype (P);
+
+ -- The prefix denotes an enumeration type. Folding can occur
+ -- when the argument is a constant or an enumeration literal.
+
+ elsif Is_Enumeration_Type (Entity (P))
+ and then Present (E1)
+ and then Is_Entity_Name (E1)
+ and then Ekind_In (Entity (E1), E_Constant,
+ E_Enumeration_Literal)
+ then
+ P_Entity := Etype (P);
+
+ -- Otherwise the attribute must be expanded into a conversion
+ -- and evaluated at runtime.
+
+ else
+ Check_Expressions;
+ return;
+ end if;
+
+ -- Otherwise the attribute is illegal, do not attempt to perform
+ -- any kind of folding.
+
+ else
+ return;
+ end if;
+
-- For First and Last, the prefix is an array object, and we apply
-- the attribute to the type of the array, but we need a constrained
-- type for this, so we use the actual subtype if available.
-- Enum_Rep --
--------------
- when Attribute_Enum_Rep =>
+ when Attribute_Enum_Rep => Enum_Rep : declare
+ Val : Node_Id;
+
+ begin
+ -- The attribute appears in the form
+
+ -- Enum_Typ'Enum_Rep (Const)
+ -- Enum_Typ'Enum_Rep (Enum_Lit)
+
+ if Present (E1) then
+ Val := E1;
+
+ -- Otherwise the prefix denotes a constant or enumeration literal
+
+ -- Const'Enum_Rep
+ -- Enum_Lit'Enum_Rep
+
+ else
+ Val := P;
+ end if;
-- For an enumeration type with a non-standard representation use
-- the Enumeration_Rep field of the proper constant. Note that this
if Is_Enumeration_Type (P_Type)
and then Has_Non_Standard_Rep (P_Type)
then
- Fold_Uint (N, Enumeration_Rep (Expr_Value_E (E1)), Static);
+ Fold_Uint (N, Enumeration_Rep (Expr_Value_E (Val)), Static);
- -- For enumeration types with standard representations and all
- -- other cases (i.e. all integer and modular types), Enum_Rep
- -- is equivalent to Pos.
+ -- For enumeration types with standard representations and all other
+ -- cases (i.e. all integer and modular types), Enum_Rep is equivalent
+ -- to Pos.
else
- Fold_Uint (N, Expr_Value (E1), Static);
+ Fold_Uint (N, Expr_Value (Val), Static);
end if;
+ end Enum_Rep;
--------------
-- Enum_Val --
projects / gcc.git / commitdiff