+2017-10-09 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_unit.adb (Find_Enclosing_Scope): Do not treat a block statement
+ as a scoping construct when it is byproduct of exception handling.
+
+2017-10-09 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sinfo.ads: Update table Is_Syntactic_Field to reflect the nature of
+ semantic field Target of node N_Call_Marker.
+
+2017-10-09 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_res.adb (Resolve_Allocator): Reject properly an allocator that
+ attempts to copy a limited value, when the allocator is the expression
+ in an expression function.
+
+2017-10-09 Joel Brobecker <brobecker@adacore.com>
+
+ * doc/share/conf.py: Tell the style checker that this is a Python
+ fragment, and therefore that pyflakes should not be run to validate
+ this file.
+
+2017-10-09 Eric Botcazou <ebotcazou@adacore.com>
+
+ * einfo.ads (Is_Boolean_Type): Add pragma Inline.
+ (Is_Entity_Name): Likewise.
+ (Is_String_Type): Likewise.
+ * sem_type.adb (Full_View_Covers): Do not test Is_Private_Type here
+ and remove useless comparisons on the base types.
+ (Covers): Use simple tests for Standard_Void_Type. Move up cheap tests
+ on T2. Always test Is_Private_Type before Full_View_Covers.
+
+2017-10-09 Bob Duff <duff@adacore.com>
+
+ * exp_ch4.adb: Minor refactoring.
+
2017-10-09 Javier Miranda <miranda@adacore.com>
* sem_ch3.adb (Replace_Components): Browse the list of discriminants,
# -*- coding: utf-8 -*-
+# Style_Check:Python_Fragment (meaning no pyflakes check)
#
# GNAT build configuration file
pragma Inline (Base_Type);
pragma Inline (Is_Base_Type);
+ pragma Inline (Is_Boolean_Type);
pragma Inline (Is_Controlled);
+ pragma Inline (Is_Entity_Name);
pragma Inline (Is_Package_Or_Generic_Package);
pragma Inline (Is_Packed_Array);
+ pragma Inline (Is_String_Type);
pragma Inline (Is_Subprogram_Or_Generic_Subprogram);
pragma Inline (Is_Volatile);
pragma Inline (Is_Wrapper_Package);
-- Convert_To_Assignments --
----------------------------
- function Is_Build_In_Place_Aggregate_Return (N : Node_Id) return Boolean is
- P : Node_Id := Parent (N);
- begin
- while Nkind (P) = N_Qualified_Expression loop
- P := Parent (P);
- end loop;
-
- if Nkind (P) = N_Simple_Return_Statement then
- null;
- elsif Nkind (Parent (P)) = N_Extended_Return_Statement then
- P := Parent (P);
- else
- return False;
- end if;
-
- return Is_Build_In_Place_Function
- (Return_Applies_To (Return_Statement_Entity (P)));
- end Is_Build_In_Place_Aggregate_Return;
-
procedure Convert_To_Assignments (N : Node_Id; Typ : Entity_Id) is
Loc : constant Source_Ptr := Sloc (N);
T : Entity_Id;
Unc_Decl :=
not Is_Entity_Name (Object_Definition (Parent_Node))
or else (Nkind (N) = N_Aggregate
- and then Has_Discriminants
- (Entity (Object_Definition (Parent_Node))))
+ and then
+ Has_Discriminants
+ (Entity (Object_Definition (Parent_Node))))
or else Is_Class_Wide_Type
(Entity (Object_Definition (Parent_Node)));
end if;
-- individual assignments to the given components.
procedure Expand_N_Extension_Aggregate (N : Node_Id) is
- Loc : constant Source_Ptr := Sloc (N);
A : constant Node_Id := Ancestor_Part (N);
+ Loc : constant Source_Ptr := Sloc (N);
Typ : constant Entity_Id := Etype (N);
begin
return False;
end Has_Default_Init_Comps;
+ ----------------------------------------
+ -- Is_Build_In_Place_Aggregate_Return --
+ ----------------------------------------
+
+ function Is_Build_In_Place_Aggregate_Return (N : Node_Id) return Boolean is
+ P : Node_Id := Parent (N);
+
+ begin
+ while Nkind (P) = N_Qualified_Expression loop
+ P := Parent (P);
+ end loop;
+
+ if Nkind (P) = N_Simple_Return_Statement then
+ null;
+
+ elsif Nkind (Parent (P)) = N_Extended_Return_Statement then
+ P := Parent (P);
+
+ else
+ return False;
+ end if;
+
+ return
+ Is_Build_In_Place_Function
+ (Return_Applies_To (Return_Statement_Entity (P)));
+ end Is_Build_In_Place_Aggregate_Return;
+
--------------------------
-- Is_Delayed_Aggregate --
--------------------------
Set_Tag : Entity_Id := Empty;
function Build_Assignment
- (Id : Entity_Id; Default : Node_Id) return List_Id;
+ (Id : Entity_Id;
+ Default : Node_Id) return List_Id;
-- Build an assignment statement that assigns the default expression to
-- its corresponding record component if defined. The left-hand side of
-- the assignment is marked Assignment_OK so that initialization of
----------------------
function Build_Assignment
- (Id : Entity_Id; Default : Node_Id) return List_Id
+ (Id : Entity_Id;
+ Default : Node_Id) return List_Id
is
Default_Loc : constant Source_Ptr := Sloc (Default);
- Typ : constant Entity_Id := Underlying_Type (Etype (Id));
+ Typ : constant Entity_Id := Underlying_Type (Etype (Id));
Adj_Call : Node_Id;
Exp : Node_Id := Default;
if Kind = N_Attribute_Reference
and then Nam_In (Attribute_Name (Default), Name_Unchecked_Access,
- Name_Unrestricted_Access)
+ Name_Unrestricted_Access)
and then Is_Entity_Name (Prefix (Default))
and then Is_Type (Entity (Prefix (Default)))
and then Entity (Prefix (Default)) = Rec_Type
Expression =>
Unchecked_Convert_To (RTE (RE_Tag),
New_Occurrence_Of
- (Node
- (First_Elmt
- (Access_Disp_Table (Underlying_Type (Typ)))),
+ (Node (First_Elmt (Access_Disp_Table (Underlying_Type
+ (Typ)))),
Default_Loc))));
end if;
elsif Nkind (Expr_Q) = N_Reference
and then Is_Build_In_Place_Function_Call (Prefix (Expr_Q))
and then not Is_Expanded_Build_In_Place_Call
- (Unqual_Conv (Prefix (Expr_Q)))
+ (Unqual_Conv (Prefix (Expr_Q)))
then
Make_Build_In_Place_Call_In_Anonymous_Context (Prefix (Expr_Q));
-- allocated in place, delay checks until assignments are
-- made, because the discriminants are not initialized.
- if Nkind (Expr) = N_Allocator and then No_Initialization (Expr)
+ if Nkind (Expr) = N_Allocator
+ and then No_Initialization (Expr)
then
null;
if Is_Build_In_Place_Result_Type (Typ)
and then Nkind (Parent (N)) = N_Extended_Return_Statement
- and then not Is_Definite_Subtype
- (Etype (Return_Applies_To
- (Return_Statement_Entity (Parent (N)))))
+ and then
+ not Is_Definite_Subtype (Etype (Return_Applies_To
+ (Return_Statement_Entity (Parent (N)))))
then
null;
Typ : constant Entity_Id := Etype (N);
Actions : List_Id;
- Cnn : Entity_Id;
Decl : Node_Id;
Expr : Node_Id;
New_If : Node_Id;
New_N : Node_Id;
- Ptr_Typ : Entity_Id;
begin
-- Check for MINIMIZED/ELIMINATED overflow mode
Process_If_Case_Statements (N, Then_Actions (N));
Process_If_Case_Statements (N, Else_Actions (N));
- -- Generate:
- -- type Ann is access all Typ;
-
- Ptr_Typ := Make_Temporary (Loc, 'A');
-
- Insert_Action (N,
- Make_Full_Type_Declaration (Loc,
- Defining_Identifier => Ptr_Typ,
- Type_Definition =>
- Make_Access_To_Object_Definition (Loc,
- All_Present => True,
- Subtype_Indication => New_Occurrence_Of (Typ, Loc))));
+ declare
+ Cnn : constant Entity_Id := Make_Temporary (Loc, 'C', N);
+ Ptr_Typ : constant Entity_Id := Make_Temporary (Loc, 'A');
+ begin
+ -- Generate:
+ -- type Ann is access all Typ;
- -- Generate:
- -- Cnn : Ann;
+ Insert_Action (N,
+ Make_Full_Type_Declaration (Loc,
+ Defining_Identifier => Ptr_Typ,
+ Type_Definition =>
+ Make_Access_To_Object_Definition (Loc,
+ All_Present => True,
+ Subtype_Indication => New_Occurrence_Of (Typ, Loc))));
- Cnn := Make_Temporary (Loc, 'C', N);
+ -- Generate:
+ -- Cnn : Ann;
- Decl :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => Cnn,
- Object_Definition => New_Occurrence_Of (Ptr_Typ, Loc));
+ Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Cnn,
+ Object_Definition => New_Occurrence_Of (Ptr_Typ, Loc));
- -- Generate:
- -- if Cond then
- -- Cnn := <Thenx>'Unrestricted_Access;
- -- else
- -- Cnn := <Elsex>'Unrestricted_Access;
- -- end if;
+ -- Generate:
+ -- if Cond then
+ -- Cnn := <Thenx>'Unrestricted_Access;
+ -- else
+ -- Cnn := <Elsex>'Unrestricted_Access;
+ -- end if;
- New_If :=
- Make_Implicit_If_Statement (N,
- Condition => Relocate_Node (Cond),
- Then_Statements => New_List (
- Make_Assignment_Statement (Sloc (Thenx),
- Name => New_Occurrence_Of (Cnn, Sloc (Thenx)),
- Expression =>
- Make_Attribute_Reference (Loc,
- Prefix => Relocate_Node (Thenx),
- Attribute_Name => Name_Unrestricted_Access))),
+ New_If :=
+ Make_Implicit_If_Statement (N,
+ Condition => Relocate_Node (Cond),
+ Then_Statements => New_List (
+ Make_Assignment_Statement (Sloc (Thenx),
+ Name => New_Occurrence_Of (Cnn, Sloc (Thenx)),
+ Expression =>
+ Make_Attribute_Reference (Loc,
+ Prefix => Relocate_Node (Thenx),
+ Attribute_Name => Name_Unrestricted_Access))),
- Else_Statements => New_List (
- Make_Assignment_Statement (Sloc (Elsex),
- Name => New_Occurrence_Of (Cnn, Sloc (Elsex)),
- Expression =>
- Make_Attribute_Reference (Loc,
- Prefix => Relocate_Node (Elsex),
- Attribute_Name => Name_Unrestricted_Access))));
+ Else_Statements => New_List (
+ Make_Assignment_Statement (Sloc (Elsex),
+ Name => New_Occurrence_Of (Cnn, Sloc (Elsex)),
+ Expression =>
+ Make_Attribute_Reference (Loc,
+ Prefix => Relocate_Node (Elsex),
+ Attribute_Name => Name_Unrestricted_Access))));
- -- Preserve the original context for which the if statement is being
- -- generated. This is needed by the finalization machinery to prevent
- -- the premature finalization of controlled objects found within the
- -- if statement.
+ -- Preserve the original context for which the if statement is
+ -- being generated. This is needed by the finalization machinery
+ -- to prevent the premature finalization of controlled objects
+ -- found within the if statement.
- Set_From_Conditional_Expression (New_If);
+ Set_From_Conditional_Expression (New_If);
- New_N :=
- Make_Explicit_Dereference (Loc,
- Prefix => New_Occurrence_Of (Cnn, Loc));
+ New_N :=
+ Make_Explicit_Dereference (Loc,
+ Prefix => New_Occurrence_Of (Cnn, Loc));
+ end;
-- If the result is an unconstrained array and the if expression is in a
-- context other than the initializing expression of the declaration of
-- and replace the if expression by a reference to Cnn
- Cnn := Make_Temporary (Loc, 'C', N);
-
- Decl :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => Cnn,
- Object_Definition => New_Occurrence_Of (Typ, Loc));
+ declare
+ Cnn : constant Node_Id := Make_Temporary (Loc, 'C', N);
+ begin
+ Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Cnn,
+ Object_Definition => New_Occurrence_Of (Typ, Loc));
- New_If :=
- Make_Implicit_If_Statement (N,
- Condition => Relocate_Node (Cond),
+ New_If :=
+ Make_Implicit_If_Statement (N,
+ Condition => Relocate_Node (Cond),
- Then_Statements => New_List (
- Make_Assignment_Statement (Sloc (Thenx),
- Name => New_Occurrence_Of (Cnn, Sloc (Thenx)),
- Expression => Relocate_Node (Thenx))),
+ Then_Statements => New_List (
+ Make_Assignment_Statement (Sloc (Thenx),
+ Name => New_Occurrence_Of (Cnn, Sloc (Thenx)),
+ Expression => Relocate_Node (Thenx))),
- Else_Statements => New_List (
- Make_Assignment_Statement (Sloc (Elsex),
- Name => New_Occurrence_Of (Cnn, Sloc (Elsex)),
- Expression => Relocate_Node (Elsex))));
+ Else_Statements => New_List (
+ Make_Assignment_Statement (Sloc (Elsex),
+ Name => New_Occurrence_Of (Cnn, Sloc (Elsex)),
+ Expression => Relocate_Node (Elsex))));
- Set_Assignment_OK (Name (First (Then_Statements (New_If))));
- Set_Assignment_OK (Name (First (Else_Statements (New_If))));
+ Set_Assignment_OK (Name (First (Then_Statements (New_If))));
+ Set_Assignment_OK (Name (First (Else_Statements (New_If))));
- New_N := New_Occurrence_Of (Cnn, Loc);
+ New_N := New_Occurrence_Of (Cnn, Loc);
+ end;
-- Regular path using Expression_With_Actions
Advance : out Node_Id;
New_Loop : out Node_Id)
is
- Loc : constant Source_Ptr := Sloc (N);
- Stats : constant List_Id := Statements (N);
- Typ : constant Entity_Id := Base_Type (Etype (Container));
+ Loc : constant Source_Ptr := Sloc (N);
+ Stats : constant List_Id := Statements (N);
+ Typ : constant Entity_Id := Base_Type (Etype (Container));
+
+ Has_Element_Op : constant Entity_Id :=
+ Get_Iterable_Type_Primitive (Typ, Name_Has_Element);
First_Op : Entity_Id;
Next_Op : Entity_Id;
- Has_Element_Op : constant Entity_Id :=
- Get_Iterable_Type_Primitive (Typ, Name_Has_Element);
begin
-- Use the proper set of primitives depending on the direction of
-- iteration. The legality of a reverse iteration has been checked
else
First_Op := Get_Iterable_Type_Primitive (Typ, Name_First);
Next_Op := Get_Iterable_Type_Primitive (Typ, Name_Next);
- null;
end if;
-- Declaration for Cursor
procedure Expand_Call (N : Node_Id) is
Post_Call : List_Id;
+
begin
- pragma Assert
- (Nkind_In (N, N_Function_Call, N_Procedure_Call_Statement,
- N_Entry_Call_Statement));
+ pragma Assert (Nkind_In (N, N_Entry_Call_Statement,
+ N_Function_Call,
+ N_Procedure_Call_Statement));
+
Expand_Call_Helper (N, Post_Call);
Insert_Post_Call_Actions (N, Post_Call);
end Expand_Call;
if not Is_Build_In_Place_Function_Call (Call_Node)
and then
(No (First_Formal (Subp))
- or else
- not Is_Concurrent_Record_Type (Etype (First_Formal (Subp))))
+ or else
+ not Is_Concurrent_Record_Type (Etype (First_Formal (Subp))))
then
Expand_Ctrl_Function_Call (Call_Node);
-- intermediate result after its use.
elsif Is_Build_In_Place_Function_Call (Call_Node)
- and then
- Nkind_In (Parent (Unqual_Conv (Call_Node)),
- N_Attribute_Reference,
- N_Function_Call,
- N_Indexed_Component,
- N_Object_Renaming_Declaration,
- N_Procedure_Call_Statement,
- N_Selected_Component,
- N_Slice)
+ and then Nkind_In (Parent (Unqual_Conv (Call_Node)),
+ N_Attribute_Reference,
+ N_Function_Call,
+ N_Indexed_Component,
+ N_Object_Renaming_Declaration,
+ N_Procedure_Call_Statement,
+ N_Selected_Component,
+ N_Slice)
then
Establish_Transient_Scope (Call_Node, Sec_Stack => True);
end if;
pragma Assert
(Comes_From_Extended_Return_Statement (N)
- or else not Is_Build_In_Place_Function_Call (Exp)
- or else Is_Build_In_Place_Function (Scope_Id));
+ or else not Is_Build_In_Place_Function_Call (Exp)
+ or else Is_Build_In_Place_Function (Scope_Id));
if not Comes_From_Extended_Return_Statement (N)
and then Is_Build_In_Place_Function (Scope_Id)
raise Program_Error;
end if;
- declare
- Result : constant Boolean := Is_Build_In_Place_Function (Function_Id);
- begin
- return Result;
- end;
+ return Is_Build_In_Place_Function (Function_Id);
end Is_Build_In_Place_Function_Call;
-----------------------
Return_Obj_Access := Make_Temporary (Loc, 'R');
Set_Etype (Return_Obj_Access, Acc_Type);
Set_Can_Never_Be_Null (Acc_Type, False);
- -- It gets initialized to null, so we can't have that.
+ -- It gets initialized to null, so we can't have that
-- When the result subtype is constrained, the return object is
-- allocated on the caller side, and access to it is passed to the
(Assign : Node_Id;
Function_Call : Node_Id)
is
- Lhs : constant Node_Id := Name (Assign);
- Func_Call : constant Node_Id := Unqual_Conv (Function_Call);
- Func_Id : Entity_Id;
+ Func_Call : constant Node_Id := Unqual_Conv (Function_Call);
+ Lhs : constant Node_Id := Name (Assign);
Loc : constant Source_Ptr := Sloc (Function_Call);
+ Func_Id : Entity_Id;
Obj_Decl : Node_Id;
Obj_Id : Entity_Id;
Ptr_Typ : Entity_Id;
-- Add a conversion if it's the wrong type
if Etype (New_Expr) /= Ptr_Typ then
- New_Expr := Make_Unchecked_Type_Conversion (Loc,
- New_Occurrence_Of (Ptr_Typ, Loc), New_Expr);
+ New_Expr :=
+ Make_Unchecked_Type_Conversion (Loc,
+ New_Occurrence_Of (Ptr_Typ, Loc), New_Expr);
end if;
Obj_Id := Make_Temporary (Loc, 'R', New_Expr);
function Get_Function_Id (Func_Call : Node_Id) return Entity_Id;
-- Get the value of Function_Id, below
+ ---------------------
+ -- Get_Function_Id --
+ ---------------------
+
function Get_Function_Id (Func_Call : Node_Id) return Entity_Id is
begin
if Is_Entity_Name (Name (Func_Call)) then
end if;
end Get_Function_Id;
- Func_Call : constant Node_Id := Unqual_Conv (Function_Call);
- Function_Id : constant Entity_Id := Get_Function_Id (Func_Call);
- Result_Subt : constant Entity_Id := Etype (Function_Id);
+ -- Local variables
- Obj_Def_Id : constant Entity_Id := Defining_Identifier (Obj_Decl);
- Obj_Typ : constant Entity_Id := Etype (Obj_Def_Id);
- Encl_Func : constant Entity_Id := Enclosing_Subprogram (Obj_Def_Id);
- Loc : constant Source_Ptr := Sloc (Function_Call);
- Obj_Loc : constant Source_Ptr := Sloc (Obj_Decl);
+ Func_Call : constant Node_Id := Unqual_Conv (Function_Call);
+ Function_Id : constant Entity_Id := Get_Function_Id (Func_Call);
+ Loc : constant Source_Ptr := Sloc (Function_Call);
+ Obj_Loc : constant Source_Ptr := Sloc (Obj_Decl);
+ Obj_Def_Id : constant Entity_Id := Defining_Identifier (Obj_Decl);
+ Obj_Typ : constant Entity_Id := Etype (Obj_Def_Id);
+ Encl_Func : constant Entity_Id := Enclosing_Subprogram (Obj_Def_Id);
+ Result_Subt : constant Entity_Id := Etype (Function_Id);
Call_Deref : Node_Id;
Caller_Object : Node_Id;
Def_Id : Entity_Id;
+ Designated_Type : Entity_Id;
Fmaster_Actual : Node_Id := Empty;
Pool_Actual : Node_Id;
- Designated_Type : Entity_Id;
Ptr_Typ : Entity_Id;
Ptr_Typ_Decl : Node_Id;
Pass_Caller_Acc : Boolean := False;
Definite : constant Boolean :=
Caller_Known_Size (Func_Call, Result_Subt)
- and then not Is_Class_Wide_Type (Obj_Typ);
+ and then not Is_Class_Wide_Type (Obj_Typ);
-- In the case of "X : T'Class := F(...);", where F returns a
-- Caller_Known_Size (specific) tagged type, we treat it as
-- indefinite, because the code for the Definite case below sets the
-- the result object is in a different (transient) scope, so won't cause
-- freezing.
- if Definite
- and then not Is_Return_Object (Obj_Def_Id)
- then
+ if Definite and then not Is_Return_Object (Obj_Def_Id) then
Insert_After_And_Analyze (Obj_Decl, Ptr_Typ_Decl);
else
Insert_Action (Obj_Decl, Ptr_Typ_Decl);
Pass_Caller_Acc := True;
-- When the enclosing function has a BIP_Alloc_Form formal then we
- -- pass it along to the callee (such as when the enclosing
- -- function has an unconstrained or tagged result type).
+ -- pass it along to the callee (such as when the enclosing function
+ -- has an unconstrained or tagged result type).
if Needs_BIP_Alloc_Form (Encl_Func) then
if RTE_Available (RE_Root_Storage_Pool_Ptr) then
Make_Unchecked_Type_Conversion (Loc,
Subtype_Mark =>
New_Occurrence_Of
- (Etype
- (Build_In_Place_Formal
- (Function_Id, BIP_Object_Access)),
+ (Etype (Build_In_Place_Formal
+ (Function_Id, BIP_Object_Access)),
Loc),
Expression =>
New_Occurrence_Of
Set_Etype (Def_Id, Ptr_Typ);
Set_Is_Known_Non_Null (Def_Id);
- if Nkind_In
- (Function_Call, N_Type_Conversion, N_Unchecked_Type_Conversion)
+ if Nkind_In (Function_Call, N_Type_Conversion,
+ N_Unchecked_Type_Conversion)
then
Res_Decl :=
Make_Object_Declaration (Loc,
Constant_Present => True,
Object_Definition => New_Occurrence_Of (Ptr_Typ, Loc),
Expression =>
- Make_Unchecked_Type_Conversion (Loc,
- New_Occurrence_Of (Ptr_Typ, Loc),
- Make_Reference (Loc, Relocate_Node (Func_Call))));
+ Make_Unchecked_Type_Conversion (Loc,
+ New_Occurrence_Of (Ptr_Typ, Loc),
+ Make_Reference (Loc, Relocate_Node (Func_Call))));
else
Res_Decl :=
Make_Object_Declaration (Loc,
-- itself the return expression of an enclosing BIP function, then mark
-- the object as having no initialization.
- if Definite
- and then not Is_Return_Object (Obj_Def_Id)
- then
+ if Definite and then not Is_Return_Object (Obj_Def_Id) then
+
-- The related object declaration is encased in a transient block
-- because the build-in-place function call contains at least one
-- nested function call that produces a controlled transient
Rewrite (Obj_Decl,
Make_Object_Renaming_Declaration (Obj_Loc,
Defining_Identifier => Make_Temporary (Obj_Loc, 'D'),
- Subtype_Mark =>
+ Subtype_Mark =>
New_Occurrence_Of (Designated_Type, Obj_Loc),
- Name => Call_Deref));
+ Name => Call_Deref));
-- At this point, Defining_Identifier (Obj_Decl) is no longer equal
-- to Obj_Def_Id.
then
On_Object_Declaration := True;
return
- Unqual_BIP_Function_Call (Expression (Parent (Entity (Expr))));
+ Unqual_BIP_Function_Call (Expression (Parent (Entity (Expr))));
-- Recurse to handle calls to displace the pointer to the object to
-- reference a secondary dispatch table.
begin
if Nkind (Expr) = N_Identifier and then No (Entity (Expr)) then
- -- Can happen for X'Elab_Spec in the binder-generated file.
+
+ -- Can happen for X'Elab_Spec in the binder-generated file
+
return Empty;
end if;
-- stack.
elsif Is_RTE (Pool_Id, RE_SS_Pool)
- or else
- (Nkind (Expr) = N_Allocator
- and then Is_RTE (Storage_Pool (Expr), RE_SS_Pool))
+ or else (Nkind (Expr) = N_Allocator
+ and then Is_RTE (Storage_Pool (Expr), RE_SS_Pool))
then
return;
return False;
end Valid_Ancestor_Type;
+ ------------------------------
+ -- Transform_BIP_Assignment --
+ ------------------------------
+
procedure Transform_BIP_Assignment (Typ : Entity_Id) is
- Loc : constant Source_Ptr := Sloc (N);
- Def_Id : constant Entity_Id := Make_Temporary (Loc, 'Y', A);
- Obj_Decl : constant Node_Id :=
- Make_Object_Declaration
- (Loc,
- Defining_Identifier => Def_Id,
- Constant_Present => True,
- Object_Definition => New_Occurrence_Of (Typ, Loc),
- Expression => A,
- Has_Init_Expression => True);
+ Loc : constant Source_Ptr := Sloc (N);
+ Def_Id : constant Entity_Id := Make_Temporary (Loc, 'Y', A);
+ Obj_Decl : constant Node_Id :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Def_Id,
+ Constant_Present => True,
+ Object_Definition => New_Occurrence_Of (Typ, Loc),
+ Expression => A,
+ Has_Init_Expression => True);
begin
Set_Etype (Def_Id, Typ);
Set_Ancestor_Part (N, New_Occurrence_Of (Def_Id, Loc));
or else No (First_Formal (Entity (N)))
or else Etype (First_Formal (Entity (N))) /= Typ
then
- Error_Msg_N ("iterable primitive must be local function name "
- & "whose first formal is an iterable type", N);
+ Error_Msg_N
+ ("iterable primitive must be local function name whose first "
+ & "formal is an iterable type", N);
return;
end if;
Ent := Entity (N);
- F1 := First_Formal (Ent);
+ F1 := First_Formal (Ent);
- if Nam = Name_First
- or else Nam = Name_Last
- then
+ if Nam = Name_First or else Nam = Name_Last then
-- First or Last (Container) => Cursor
-- Has_Element (Container, Cursor) => Boolean
F2 := Next_Formal (F1);
+
if Etype (F2) /= Cursor
or else Etype (Ent) /= Standard_Boolean
or else Present (Next_Formal (F2))
then
Error_Msg_N ("no match for Element iterable primitive", N);
end if;
- null;
else
raise Program_Error;
end if;
else
- -- Overloaded case: find subprogram with proper signature.
- -- Caller will report error if no match is found.
+ -- Overloaded case: find subprogram with proper signature. Caller
+ -- will report error if no match is found.
declare
I : Interp_Index;
elsif No (Has_Element_Id) then
Error_Msg_N ("match for Has_Element primitive not found", ASN);
- elsif No (Element_Id)
- or else No (Last_Id)
- then
- null; -- Optional.
+ elsif No (Element_Id) or else No (Last_Id) then
+ null; -- optional
end if;
end Validate_Iterable_Aspect;
Set_Is_Limited_Record (Def_Id, Is_Limited_Record (T));
if Has_Discrs
- and then not Is_Empty_Elmt_List (Elist)
- and then not For_Access
+ and then not Is_Empty_Elmt_List (Elist)
+ and then not For_Access
then
Create_Constrained_Components (Def_Id, Related_Nod, T, Elist);
+
elsif not For_Access then
Set_Cloned_Subtype (Def_Id, T);
end if;
-- Add_Global_Declaration in this case. This can happen if we have a
-- build-in-place library function.
- if (Nkind (Nod) in N_Entity
- and then Is_Compilation_Unit (Nod))
+ if (Nkind (Nod) in N_Entity and then Is_Compilation_Unit (Nod))
or else
(Nkind (Nod) = N_Defining_Program_Unit_Name
- and then Is_Compilation_Unit (Defining_Identifier (Nod)))
+ and then Is_Compilation_Unit (Defining_Identifier (Nod)))
then
Add_Global_Declaration (IR);
else
else
Error_Msg_N
- ("illegal context for call"
- & " to function with limited result", Exp);
+ ("illegal context for call to function with limited "
+ & "result", Exp);
end if;
else
Error_Msg_N
- ("initialization of limited object requires aggregate "
- & "or function call", Exp);
+ ("initialization of limited object requires aggregate or "
+ & "function call", Exp);
end if;
end if;
end if;
-- assignment statements that are really initializations. These are
-- marked No_Ctrl_Actions.
- function Should_Transform_BIP_Assignment
- (Typ : Entity_Id) return Boolean
- is
- Result : Boolean;
- begin
- if Expander_Active
- and then not Is_Limited_View (Typ)
- and then Is_Build_In_Place_Result_Type (Typ)
- and then not No_Ctrl_Actions (N)
- then
- -- This function is called early, before name resolution is
- -- complete, so we have to deal with things that might turn into
- -- function calls later. N_Function_Call and N_Op nodes are the
- -- obvious case. An N_Identifier or N_Expanded_Name is a
- -- parameterless function call if it denotes a function.
- -- Finally, an attribute reference can be a function call.
-
- case Nkind (Unqual_Conv (Rhs)) is
- when N_Function_Call | N_Op =>
- Result := True;
- when N_Identifier | N_Expanded_Name =>
- case Ekind (Entity (Unqual_Conv (Rhs))) is
- when E_Function | E_Operator =>
- Result := True;
- when others =>
- Result := False;
- end case;
- when N_Attribute_Reference =>
- Result := Attribute_Name (Unqual_Conv (Rhs)) = Name_Input;
- -- T'Input will turn into a call whose result type is T
- when others =>
- Result := False;
- end case;
- else
- Result := False;
- end if;
- return Result;
- end Should_Transform_BIP_Assignment;
-
- procedure Transform_BIP_Assignment (Typ : Entity_Id) is
- -- Tranform "X : [constant] T := F (...);" into:
- --
- -- Temp : constant T := F (...);
- -- X := Temp;
-
- Loc : constant Source_Ptr := Sloc (N);
- Def_Id : constant Entity_Id := Make_Temporary (Loc, 'Y', Rhs);
- Obj_Decl : constant Node_Id :=
- Make_Object_Declaration
- (Loc,
- Defining_Identifier => Def_Id,
- Constant_Present => True,
- Object_Definition => New_Occurrence_Of (Typ, Loc),
- Expression => Rhs,
- Has_Init_Expression => True);
- begin
- Set_Etype (Def_Id, Typ);
- Set_Expression (N, New_Occurrence_Of (Def_Id, Loc));
-
- -- At this point, Rhs is no longer equal to Expression (N), so:
-
- Rhs := Expression (N);
-
- Insert_Action (N, Obj_Decl);
- end Transform_BIP_Assignment;
-
-------------------------------
-- Diagnose_Non_Variable_Lhs --
-------------------------------
Opnd_Type : in out Entity_Id)
is
Decl : Node_Id;
+
begin
Require_Entity (Opnd);
or else
(Ekind (Entity (Opnd)) = E_Variable
and then Nkind (Parent (Entity (Opnd))) =
- N_Object_Renaming_Declaration
+ N_Object_Renaming_Declaration
and then Nkind (Parent (Parent (Entity (Opnd)))) =
- N_Accept_Statement))
+ N_Accept_Statement))
then
Opnd_Type := Get_Actual_Subtype (Opnd);
end if;
end Set_Assignment_Type;
+ -------------------------------------
+ -- Should_Transform_BIP_Assignment --
+ -------------------------------------
+
+ function Should_Transform_BIP_Assignment
+ (Typ : Entity_Id) return Boolean
+ is
+ Result : Boolean;
+
+ begin
+ if Expander_Active
+ and then not Is_Limited_View (Typ)
+ and then Is_Build_In_Place_Result_Type (Typ)
+ and then not No_Ctrl_Actions (N)
+ then
+ -- This function is called early, before name resolution is
+ -- complete, so we have to deal with things that might turn into
+ -- function calls later. N_Function_Call and N_Op nodes are the
+ -- obvious case. An N_Identifier or N_Expanded_Name is a
+ -- parameterless function call if it denotes a function.
+ -- Finally, an attribute reference can be a function call.
+
+ case Nkind (Unqual_Conv (Rhs)) is
+ when N_Function_Call
+ | N_Op
+ =>
+ Result := True;
+
+ when N_Expanded_Name
+ | N_Identifier
+ =>
+ case Ekind (Entity (Unqual_Conv (Rhs))) is
+ when E_Function
+ | E_Operator
+ =>
+ Result := True;
+
+ when others =>
+ Result := False;
+ end case;
+
+ when N_Attribute_Reference =>
+ Result := Attribute_Name (Unqual_Conv (Rhs)) = Name_Input;
+ -- T'Input will turn into a call whose result type is T
+
+ when others =>
+ Result := False;
+ end case;
+ else
+ Result := False;
+ end if;
+
+ return Result;
+ end Should_Transform_BIP_Assignment;
+
+ ------------------------------
+ -- Transform_BIP_Assignment --
+ ------------------------------
+
+ procedure Transform_BIP_Assignment (Typ : Entity_Id) is
+
+ -- Tranform "X : [constant] T := F (...);" into:
+ --
+ -- Temp : constant T := F (...);
+ -- X := Temp;
+
+ Loc : constant Source_Ptr := Sloc (N);
+ Def_Id : constant Entity_Id := Make_Temporary (Loc, 'Y', Rhs);
+ Obj_Decl : constant Node_Id :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Def_Id,
+ Constant_Present => True,
+ Object_Definition => New_Occurrence_Of (Typ, Loc),
+ Expression => Rhs,
+ Has_Init_Expression => True);
+
+ begin
+ Set_Etype (Def_Id, Typ);
+ Set_Expression (N, New_Occurrence_Of (Def_Id, Loc));
+
+ -- At this point, Rhs is no longer equal to Expression (N), so:
+
+ Rhs := Expression (N);
+
+ Insert_Action (N, Obj_Decl);
+ end Transform_BIP_Assignment;
+
-- Local variables
T1 : Entity_Id;
end if;
end if;
- -- Deal with build-in-place calls for nonlimited types.
- -- We don't do this later, because resolving the rhs
- -- tranforms it incorrectly for build-in-place.
+ -- Deal with build-in-place calls for nonlimited types. We don't do this
+ -- later, because resolving the rhs tranforms it incorrectly for build-
+ -- in-place.
if Should_Transform_BIP_Assignment (Typ => T1) then
Transform_BIP_Assignment (Typ => T1);
end if;
+
pragma Assert (not Should_Transform_BIP_Assignment (Typ => T1));
-- The resulting assignment type is T1, so now we will resolve the left
Resolve (Lhs, T1);
- -- Cases where Lhs is not a variable
-
-- Cases where Lhs is not a variable. In an instance or an inlined body
-- no need for further check because assignment was legal in template.
if Is_Array_Type (Typ)
or else Is_Reversible_Iterator (Typ)
or else
- (Present (Find_Aspect (Typ, Aspect_Iterable))
- and then Present
+ (Present (Find_Aspect (Typ, Aspect_Iterable))
+ and then
+ Present
(Get_Iterable_Type_Primitive (Typ, Name_Previous)))
then
null;
-- If we haven't already traversed Node, then mark it and traverse
-- it.
- procedure Scan_Subprogram_Refs (Node : Node_Id) is
- begin
- if not Traversed_Table.Get (Node) then
- Traversed_Table.Set (Node, True);
- Traverse_And_Scan_Subprogram_Refs (Node);
- end if;
- end Scan_Subprogram_Refs;
-
--------------------
-- Has_Referencer --
--------------------
return OK;
end Scan_Subprogram_Ref;
+ --------------------------
+ -- Scan_Subprogram_Refs --
+ --------------------------
+
+ procedure Scan_Subprogram_Refs (Node : Node_Id) is
+ begin
+ if not Traversed_Table.Get (Node) then
+ Traversed_Table.Set (Node, True);
+ Traverse_And_Scan_Subprogram_Refs (Node);
+ end if;
+ end Scan_Subprogram_Refs;
+
-- Local variables
Discard : Boolean;
-- are explicitly marked as coming from source but do not need to be
-- checked for limited initialization. To exclude this case, ensure
-- that the parent of the allocator is a source node.
+ -- The return statement constructed for an Expression_Function does
+ -- not come from source but requires a limited check.
if Is_Limited_Type (Etype (E))
and then Comes_From_Source (N)
- and then Comes_From_Source (Parent (N))
+ and then
+ (Comes_From_Source (Parent (N))
+ or else
+ (Ekind (Current_Scope) = E_Function
+ and then Nkind
+ (Original_Node (Unit_Declaration_Node (Current_Scope)))
+ = N_Expression_Function))
and then not In_Instance_Body
then
if not OK_For_Limited_Init (Etype (E), Expression (E)) then
function Full_View_Covers (Typ1, Typ2 : Entity_Id) return Boolean is
begin
- return
- Is_Private_Type (Typ1)
- and then
- ((Present (Full_View (Typ1))
- and then Covers (Full_View (Typ1), Typ2))
- or else (Present (Underlying_Full_View (Typ1))
- and then Covers (Underlying_Full_View (Typ1), Typ2))
- or else Base_Type (Typ1) = Typ2
- or else Base_Type (Typ2) = Typ1);
+ if Present (Full_View (Typ1))
+ and then Covers (Full_View (Typ1), Typ2)
+ then
+ return True;
+
+ elsif Present (Underlying_Full_View (Typ1))
+ and then Covers (Underlying_Full_View (Typ1), Typ2)
+ then
+ return True;
+
+ else
+ return False;
+ end if;
end Full_View_Covers;
-----------------
-- Standard_Void_Type is a special entity that has some, but not all,
-- properties of types.
- if (T1 = Standard_Void_Type) /= (T2 = Standard_Void_Type) then
+ if T1 = Standard_Void_Type or else T2 = Standard_Void_Type then
return False;
end if;
or else (T2 = Universal_Real and then Is_Real_Type (T1))
or else (T2 = Universal_Fixed and then Is_Fixed_Point_Type (T1))
or else (T2 = Any_Fixed and then Is_Fixed_Point_Type (T1))
- or else (T2 = Any_String and then Is_String_Type (T1))
or else (T2 = Any_Character and then Is_Character_Type (T1))
+ or else (T2 = Any_String and then Is_String_Type (T1))
or else (T2 = Any_Access and then Is_Access_Type (T1))
then
return True;
-- task_type or protected_type that implements the interface.
elsif Ada_Version >= Ada_2005
+ and then Is_Concurrent_Type (T2)
and then Is_Class_Wide_Type (T1)
and then Is_Interface (Etype (T1))
- and then Is_Concurrent_Type (T2)
and then Interface_Present_In_Ancestor
(Typ => BT2, Iface => Etype (T1))
then
-- object T2 implementing T1.
elsif Ada_Version >= Ada_2005
+ and then Is_Tagged_Type (T2)
and then Is_Class_Wide_Type (T1)
and then Is_Interface (Etype (T1))
- and then Is_Tagged_Type (T2)
then
if Interface_Present_In_Ancestor (Typ => T2,
Iface => Etype (T1))
-- whether a partial and a full view match. Verify that types are
-- legal, to prevent cascaded errors.
- elsif In_Instance
- and then (Full_View_Covers (T1, T2) or else Full_View_Covers (T2, T1))
- then
- return True;
-
- elsif Is_Type (T2)
- and then Is_Generic_Actual_Type (T2)
+ elsif Is_Private_Type (T1)
+ and then (In_Instance
+ or else (Is_Type (T2) and then Is_Generic_Actual_Type (T2)))
and then Full_View_Covers (T1, T2)
then
return True;
- elsif Is_Type (T1)
- and then Is_Generic_Actual_Type (T1)
+ elsif Is_Private_Type (T2)
+ and then (In_Instance
+ or else (Is_Type (T1) and then Is_Generic_Actual_Type (T1)))
and then Full_View_Covers (T2, T1)
then
return True;
-- Special cases
- -- Blocks, loops, and return statements have artificial scopes
+ -- Blocks carry either a source or an internally-generated scope,
+ -- unless the block is a byproduct of exception handling.
- when N_Block_Statement
- | N_Loop_Statement
- =>
+ when N_Block_Statement =>
+ if not Exception_Junk (Par) then
+ return Entity (Identifier (Par));
+ end if;
+
+ -- Loops carry an internally-generated scope
+
+ when N_Loop_Statement =>
return Entity (Identifier (Par));
+ -- Extended return statements carry an internally-generated scope
+
when N_Extended_Return_Statement =>
return Return_Statement_Entity (Par);
N := Next (Actual_Id);
if Nkind (N) = N_Parameter_Association then
+
-- In case of a build-in-place call, the call will no longer be a
-- call; it will have been rewritten.
- if Nkind_In (Parent (Actual_Id),
- N_Entry_Call_Statement,
- N_Function_Call,
- N_Procedure_Call_Statement)
+ if Nkind_In (Parent (Actual_Id), N_Entry_Call_Statement,
+ N_Function_Call,
+ N_Procedure_Call_Statement)
then
return First_Named_Actual (Parent (Actual_Id));
else
return "unknown subprogram";
end if;
- if Nkind (Ent) = N_Defining_Program_Unit_Name then
-
- -- If the subprogram is a child unit, use its simple name to
- -- start the construction of the fully qualified name.
+ -- If the subprogram is a child unit, use its simple name to start the
+ -- construction of the fully qualified name.
+ if Nkind (Ent) = N_Defining_Program_Unit_Name then
Append_Entity_Name (Buf, Defining_Identifier (Ent));
-
else
Append_Entity_Name (Buf, Ent);
end if;
+
return +Buf;
end Subprogram_Name;
5 => False), -- SCIL_Tag_Value (Node5-Sem)
N_Call_Marker =>
- (1 => True, -- Target (Node1-Sem)
+ (1 => False, -- Target (Node1-Sem)
2 => False, -- unused
3 => False, -- unused
4 => False, -- unused
projects / gcc.git / commitdiff