aboutsummaryrefslogtreecommitdiff
path: root/gcc/ada
diff options
context:
space:
mode:
authorArnaud Charlet <charlet@gcc.gnu.org>2015-01-06 11:20:44 +0100
committerArnaud Charlet <charlet@gcc.gnu.org>2015-01-06 11:20:44 +0100
commit1a779058e1ebd6e68771f25062e95f3bb7ff48ab (patch)
tree19e553bfc8fc773dca0168fb2791706a2c396f13 /gcc/ada
parent375cbc2bec0b70a3e54f02248f3a139ef5929419 (diff)
downloadgcc-1a779058e1ebd6e68771f25062e95f3bb7ff48ab.zip
gcc-1a779058e1ebd6e68771f25062e95f3bb7ff48ab.tar.gz
gcc-1a779058e1ebd6e68771f25062e95f3bb7ff48ab.tar.bz2
[multiple changes]
2015-01-06 Thomas Quinot <quinot@adacore.com> * freeze.adb (Set_SSO_From_Defaults): When setting scalar storage order to native from default, make sure to also adjust bit order. * exp_aggr.adb: Minor reformatting. 2015-01-06 Robert Dewar <dewar@adacore.com> * s-valllu.adb, s-valllu.ads, s-valuti.ads, s-valuns.adb, s-valuns.ads, s-valrea.adb, s-valrea.ads: Add some additional guards for Str'Last = Positive'Last. 2015-01-06 Ed Schonberg <schonberg@adacore.com> * sem_ch12.adb, sem_ch8.adb: Ongoing work for wrappers for actual subprograms. 2015-01-06 Javier Miranda <miranda@adacore.com> * exp_disp.adb (Expand_Interface_Conversion): Reapply patch. From-SVN: r219250
Diffstat (limited to 'gcc/ada')
-rw-r--r--gcc/ada/ChangeLog21
-rw-r--r--gcc/ada/exp_aggr.adb8
-rw-r--r--gcc/ada/exp_disp.adb19
-rw-r--r--gcc/ada/freeze.adb30
-rw-r--r--gcc/ada/s-valllu.adb7
-rw-r--r--gcc/ada/s-valllu.ads7
-rw-r--r--gcc/ada/s-valrea.adb7
-rw-r--r--gcc/ada/s-valrea.ads6
-rw-r--r--gcc/ada/s-valuns.adb7
-rw-r--r--gcc/ada/s-valuns.ads7
-rw-r--r--gcc/ada/s-valuti.ads9
-rw-r--r--gcc/ada/sem_ch12.adb353
-rw-r--r--gcc/ada/sem_ch8.adb9
13 files changed, 271 insertions, 219 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 43db02d..196f083 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,5 +1,26 @@
2015-01-06 Thomas Quinot <quinot@adacore.com>
+ * freeze.adb (Set_SSO_From_Defaults): When setting scalar storage
+ order to native from default, make sure to also adjust bit order.
+ * exp_aggr.adb: Minor reformatting.
+
+2015-01-06 Robert Dewar <dewar@adacore.com>
+
+ * s-valllu.adb, s-valllu.ads, s-valuti.ads, s-valuns.adb, s-valuns.ads,
+ s-valrea.adb, s-valrea.ads: Add some additional guards for
+ Str'Last = Positive'Last.
+
+2015-01-06 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch12.adb, sem_ch8.adb: Ongoing work for wrappers for actual
+ subprograms.
+
+2015-01-06 Javier Miranda <miranda@adacore.com>
+
+ * exp_disp.adb (Expand_Interface_Conversion): Reapply patch.
+
+2015-01-06 Thomas Quinot <quinot@adacore.com>
+
* sem_util.ads: Minor reformatting.
* sem_cat.adb (In_RCI_Visible_Declarations): Change back to...
(In_RCI_Declaration) Return to old name, as proper checking of
diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb
index 25c8db3..abf870b 100644
--- a/gcc/ada/exp_aggr.adb
+++ b/gcc/ada/exp_aggr.adb
@@ -239,10 +239,10 @@ package body Exp_Aggr is
-- Packed_Array_Aggregate_Handled, we set this parameter to True, since
-- these are cases we handle in there.
- -- It would seem worthwhile to have a higher default value for Max_Others_
- -- replicate, but aggregates in the compiler make this impossible: the
- -- compiler bootstrap fails if Max_Others_Replicate is greater than 25.
- -- This is unexpected ???
+ -- It would seem useful to have a higher default for Max_Others_Replicate,
+ -- but aggregates in the compiler make this impossible: the compiler
+ -- bootstrap fails if Max_Others_Replicate is greater than 25. This
+ -- is unexpected ???
procedure Expand_Array_Aggregate (N : Node_Id);
-- This is the top-level routine to perform array aggregate expansion.
diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb
index 99105e0..905311b 100644
--- a/gcc/ada/exp_disp.adb
+++ b/gcc/ada/exp_disp.adb
@@ -1138,6 +1138,25 @@ package body Exp_Disp is
Operand_Typ := Base_Type (Corresponding_Record_Type (Operand_Typ));
end if;
+ -- No displacement of the pointer to the object needed when the type of
+ -- the operand is not an interface type and the interface is one of
+ -- its parent types (since they share the primary dispatch table).
+
+ declare
+ Opnd : Entity_Id := Operand_Typ;
+
+ begin
+ if Is_Access_Type (Opnd) then
+ Opnd := Designated_Type (Opnd);
+ end if;
+
+ if not Is_Interface (Opnd)
+ and then Is_Ancestor (Iface_Typ, Opnd, Use_Full_View => True)
+ then
+ return;
+ end if;
+ end;
+
-- Evaluate if we can statically displace the pointer to the object
declare
diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb
index e87b1f4..7ac51e8 100644
--- a/gcc/ada/freeze.adb
+++ b/gcc/ada/freeze.adb
@@ -7748,6 +7748,8 @@ package body Freeze is
--------------------------
procedure Set_SSO_From_Default (T : Entity_Id) is
+ Reversed : Boolean;
+
begin
-- Set default SSO for an array or record base type, except in case of
-- a type extension (which always inherits the SSO of its parent type).
@@ -7758,31 +7760,35 @@ package body Freeze is
and then not (Is_Tagged_Type (T)
and then Is_Derived_Type (T))))
then
- if ((Bytes_Big_Endian and then SSO_Set_Low_By_Default (T))
- or else
- ((not Bytes_Big_Endian) and then SSO_Set_High_By_Default (T)))
+ Reversed :=
+ (Bytes_Big_Endian and then SSO_Set_Low_By_Default (T))
+ or else
+ (not Bytes_Big_Endian and then SSO_Set_High_By_Default (T));
+
+ if (SSO_Set_Low_By_Default (T) or else SSO_Set_High_By_Default (T))
- -- For a record type, if native bit order is specified explicitly,
- -- then never set reverse SSO from default.
+ -- For a record type, if bit order is specified explicitly, then
+ -- do not set SSO from default if not consistent.
and then not
(Is_Record_Type (T)
and then Has_Rep_Item (T, Name_Bit_Order)
- and then not Reverse_Bit_Order (T))
+ and then Reverse_Bit_Order (T) /= Reversed)
then
-- If flags cause reverse storage order, then set the result. Note
-- that we would have ignored the pragma setting the non default
-- storage order in any case, hence the assertion at this point.
- pragma Assert (Support_Nondefault_SSO_On_Target);
- Set_Reverse_Storage_Order (T);
+ pragma Assert
+ (not Reversed or else Support_Nondefault_SSO_On_Target);
+
+ Set_Reverse_Storage_Order (T, Reversed);
- -- For a record type, also set reversed bit order. Note that if
- -- a bit order has been specified explicitly, then this is a
- -- no-op, as per the guard above.
+ -- For a record type, also set reversed bit order. Note: if a bit
+ -- order has been specified explicitly, then this is a no-op.
if Is_Record_Type (T) then
- Set_Reverse_Bit_Order (T);
+ Set_Reverse_Bit_Order (T, Reversed);
end if;
end if;
end if;
diff --git a/gcc/ada/s-valllu.adb b/gcc/ada/s-valllu.adb
index 90ce099..a641be3 100644
--- a/gcc/ada/s-valllu.adb
+++ b/gcc/ada/s-valllu.adb
@@ -65,6 +65,13 @@ package body System.Val_LLU is
-- Digit value
begin
+ -- We do not tolerate strings with Str'Last = Positive'Last
+
+ if Str'Last = Positive'Last then
+ raise Program_Error with
+ "string upper bound is Positive'Last, not supported";
+ end if;
+
P := Ptr.all;
Uval := Character'Pos (Str (P)) - Character'Pos ('0');
P := P + 1;
diff --git a/gcc/ada/s-valllu.ads b/gcc/ada/s-valllu.ads
index 72b9d52..3977e95 100644
--- a/gcc/ada/s-valllu.ads
+++ b/gcc/ada/s-valllu.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2014, 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- --
@@ -66,6 +66,10 @@ package System.Val_LLU is
-- Note: if Str is empty, i.e. if Max is less than Ptr, then this is a
-- special case of an all-blank string, and Ptr is unchanged, and hence
-- is greater than Max as required in this case.
+ --
+ -- Note: this routine should not be called with Str'Last = Positive'Last.
+ -- If this occurs Program_Error is raised with a message noting that this
+ -- case is not supported. Most such cases are eliminated by the caller.
function Scan_Long_Long_Unsigned
(Str : String;
@@ -73,6 +77,7 @@ package System.Val_LLU is
Max : Integer) return System.Unsigned_Types.Long_Long_Unsigned;
-- Same as Scan_Raw_Long_Long_Unsigned, except scans optional leading
-- blanks, and an optional leading plus sign.
+ --
-- Note: if a minus sign is present, Constraint_Error will be raised.
-- Note: trailing blanks are not scanned.
diff --git a/gcc/ada/s-valrea.adb b/gcc/ada/s-valrea.adb
index b7be0ca..005643a 100644
--- a/gcc/ada/s-valrea.adb
+++ b/gcc/ada/s-valrea.adb
@@ -152,6 +152,13 @@ package body System.Val_Real is
-- Start of processing for System.Scan_Real
begin
+ -- We do not tolerate strings with Str'Last = Positive'Last
+
+ if Str'Last = Positive'Last then
+ raise Program_Error with
+ "string upper bound is Positive'Last, not supported";
+ end if;
+
-- We call the floating-point processor reset routine so that we can
-- be sure the floating-point processor is properly set for conversion
-- calls. This is notably need on Windows, where calls to the operating
diff --git a/gcc/ada/s-valrea.ads b/gcc/ada/s-valrea.ads
index 637e70a..8d3603f 100644
--- a/gcc/ada/s-valrea.ads
+++ b/gcc/ada/s-valrea.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2014, 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- --
@@ -60,6 +60,10 @@ package System.Val_Real is
-- Note: if Str is null, i.e. if Max is less than Ptr, then this is a
-- special case of an all-blank string, and Ptr is unchanged, and hence
-- is greater than Max as required in this case.
+ --
+ -- Note: this routine should not be called with Str'Last = Positive'Last.
+ -- If this occurs Program_Error is raised with a message noting that this
+ -- case is not supported. Most such cases are eliminated by the caller.
function Value_Real (Str : String) return Long_Long_Float;
-- Used in computing X'Value (Str) where X is a floating-point type or an
diff --git a/gcc/ada/s-valuns.adb b/gcc/ada/s-valuns.adb
index 47e89be..b679807 100644
--- a/gcc/ada/s-valuns.adb
+++ b/gcc/ada/s-valuns.adb
@@ -65,6 +65,13 @@ package body System.Val_Uns is
-- Digit value
begin
+ -- We do not tolerate strings with Str'Last = Positive'Last
+
+ if Str'Last = Positive'Last then
+ raise Program_Error with
+ "string upper bound is Positive'Last, not supported";
+ end if;
+
P := Ptr.all;
Uval := Character'Pos (Str (P)) - Character'Pos ('0');
P := P + 1;
diff --git a/gcc/ada/s-valuns.ads b/gcc/ada/s-valuns.ads
index fa378bb..54df937 100644
--- a/gcc/ada/s-valuns.ads
+++ b/gcc/ada/s-valuns.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2014, 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- --
@@ -66,6 +66,10 @@ package System.Val_Uns is
-- Note: if Str is empty, i.e. if Max is less than Ptr, then this is a
-- special case of an all-blank string, and Ptr is unchanged, and hence
-- is greater than Max as required in this case.
+ --
+ -- Note: this routine should not be called with Str'Last = Positive'Last.
+ -- If this occurs Program_Error is raised with a message noting that this
+ -- case is not supported. Most such cases are eliminated by the caller.
function Scan_Unsigned
(Str : String;
@@ -73,6 +77,7 @@ package System.Val_Uns is
Max : Integer) return System.Unsigned_Types.Unsigned;
-- Same as Scan_Raw_Unsigned, except scans optional leading
-- blanks, and an optional leading plus sign.
+ --
-- Note: if a minus sign is present, Constraint_Error will be raised.
-- Note: trailing blanks are not scanned.
diff --git a/gcc/ada/s-valuti.ads b/gcc/ada/s-valuti.ads
index e69af0f..a2db343 100644
--- a/gcc/ada/s-valuti.ads
+++ b/gcc/ada/s-valuti.ads
@@ -71,6 +71,9 @@ package System.Val_Util is
-- special case of an all-blank string, and Ptr is unchanged, and hence
-- is greater than Max as required in this case. Constraint_Error is also
-- raised in this case.
+ --
+ -- This routine must not be called with Str'Last = Positive'Last. There is
+ -- no check for this case, the caller must ensure this condition is met.
procedure Scan_Plus_Sign
(Str : String;
@@ -95,6 +98,9 @@ package System.Val_Util is
-- returning a suitable large value. If the base is zero, then any value
-- is allowed, and otherwise the large value will either cause underflow
-- or overflow during the scaling process which is fine.
+ --
+ -- This routine must not be called with Str'Last = Positive'Last. There is
+ -- no check for this case, the caller must ensure this condition is met.
procedure Scan_Trailing_Blanks (Str : String; P : Positive);
-- Checks that the remainder of the field Str (P .. Str'Last) is all
@@ -113,5 +119,8 @@ package System.Val_Util is
-- where the underscore is invalid, Constraint_Error is raised with Ptr
-- set appropriately, otherwise control returns with P incremented past
-- the underscore.
+ --
+ -- This routine must not be called with Str'Last = Positive'Last. There is
+ -- no check for this case, the caller must ensure this condition is met.
end System.Val_Util;
diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb
index 1d2a64b..5d1ac9d 100644
--- a/gcc/ada/sem_ch12.adb
+++ b/gcc/ada/sem_ch12.adb
@@ -1207,7 +1207,8 @@ package body Sem_Ch12 is
if No (Found_Assoc) then
Default :=
Make_Generic_Association (Loc,
- Selector_Name => New_Occurrence_Of (Id, Loc),
+ Selector_Name =>
+ New_Occurrence_Of (Id, Loc),
Explicit_Generic_Actual_Parameter => Empty);
Set_Box_Present (Default);
Append (Default, Default_Formals);
@@ -1421,10 +1422,10 @@ package body Sem_Ch12 is
Error_Msg_Sloc := Sloc (Gen_Unit);
Error_Msg_NE
("missing actual&",
- Instantiation_Node,
- Defining_Identifier (Formal));
- Error_Msg_NE ("\in instantiation of & declared#",
- Instantiation_Node, Gen_Unit);
+ Instantiation_Node, Defining_Identifier (Formal));
+ Error_Msg_NE
+ ("\in instantiation of & declared#",
+ Instantiation_Node, Gen_Unit);
Abandon_Instantiation (Instantiation_Node);
end if;
@@ -1575,9 +1576,9 @@ package body Sem_Ch12 is
when N_Formal_Package_Declaration =>
Match :=
- Matching_Actual (
- Defining_Identifier (Formal),
- Defining_Identifier (Original_Node (Analyzed_Formal)));
+ Matching_Actual
+ (Defining_Identifier (Formal),
+ Defining_Identifier (Original_Node (Analyzed_Formal)));
if No (Match) then
if Partial_Parameterization then
@@ -1587,9 +1588,10 @@ package body Sem_Ch12 is
Error_Msg_Sloc := Sloc (Gen_Unit);
Error_Msg_NE
("missing actual&",
- Instantiation_Node, Defining_Identifier (Formal));
- Error_Msg_NE ("\in instantiation of & declared#",
- Instantiation_Node, Gen_Unit);
+ Instantiation_Node, Defining_Identifier (Formal));
+ Error_Msg_NE
+ ("\in instantiation of & declared#",
+ Instantiation_Node, Gen_Unit);
Abandon_Instantiation (Instantiation_Node);
end if;
@@ -1632,14 +1634,13 @@ package body Sem_Ch12 is
if Present (Selector_Name (Actual)) then
Error_Msg_NE
- ("unmatched actual&",
- Actual, Selector_Name (Actual));
- Error_Msg_NE ("\in instantiation of& declared#",
- Actual, Gen_Unit);
+ ("unmatched actual &", Actual, Selector_Name (Actual));
+ Error_Msg_NE
+ ("\in instantiation of & declared#", Actual, Gen_Unit);
else
Error_Msg_NE
- ("unmatched actual in instantiation of& declared#",
- Actual, Gen_Unit);
+ ("unmatched actual in instantiation of & declared#",
+ Actual, Gen_Unit);
end if;
end if;
@@ -1681,9 +1682,10 @@ package body Sem_Ch12 is
Subp := Node (Elmt);
New_D :=
Make_Generic_Association (Sloc (Subp),
- Selector_Name => New_Occurrence_Of (Subp, Sloc (Subp)),
- Explicit_Generic_Actual_Parameter =>
- New_Occurrence_Of (Subp, Sloc (Subp)));
+ Selector_Name =>
+ New_Occurrence_Of (Subp, Sloc (Subp)),
+ Explicit_Generic_Actual_Parameter =>
+ New_Occurrence_Of (Subp, Sloc (Subp)));
Mark_Rewrite_Insertion (New_D);
Append_To (Actuals, New_D);
Next_Elmt (Elmt);
@@ -1750,8 +1752,8 @@ package body Sem_Ch12 is
then
Error_Msg_N
("in a formal, a subtype indication can only be "
- & "a subtype mark (RM 12.5.3(3))",
- Subtype_Indication (Component_Definition (Def)));
+ & "a subtype mark (RM 12.5.3(3))",
+ Subtype_Indication (Component_Definition (Def)));
end if;
end Analyze_Formal_Array_Type;
@@ -1888,10 +1890,10 @@ package body Sem_Ch12 is
else
New_N :=
Make_Full_Type_Declaration (Loc,
- Defining_Identifier => T,
+ Defining_Identifier => T,
Discriminant_Specifications =>
Discriminant_Specifications (Parent (T)),
- Type_Definition =>
+ Type_Definition =>
Make_Derived_Type_Definition (Loc,
Subtype_Indication => Subtype_Mark (Def)));
@@ -2031,7 +2033,7 @@ package body Sem_Ch12 is
New_N :=
Make_Full_Type_Declaration (Loc,
Defining_Identifier => T,
- Type_Definition => Def);
+ Type_Definition => Def);
Rewrite (N, New_N);
Analyze (N);
@@ -2092,8 +2094,7 @@ package body Sem_Ch12 is
elsif Can_Never_Be_Null (T) then
Error_Msg_NE
- ("`NOT NULL` not allowed (& already excludes null)",
- N, T);
+ ("`NOT NULL` not allowed (& already excludes null)", N, T);
end if;
end if;
@@ -2394,10 +2395,10 @@ package body Sem_Ch12 is
Restore_Env;
goto Leave;
- elsif Gen_Unit = Current_Scope then
+ elsif Gen_Unit = Current_Scope then
Error_Msg_N
("generic package cannot be used as a formal package of itself",
- Gen_Id);
+ Gen_Id);
Restore_Env;
goto Leave;
@@ -2410,14 +2411,12 @@ package body Sem_Ch12 is
Error_Msg_N
("generic parent cannot be used as formal package "
- & "of a child unit",
- Gen_Id);
+ & "of a child unit", Gen_Id);
else
Error_Msg_N
("generic package cannot be used as a formal package "
- & "within itself",
- Gen_Id);
+ & "within itself", Gen_Id);
Restore_Env;
goto Leave;
end if;
@@ -2439,7 +2438,7 @@ package body Sem_Ch12 is
if Chars (Gen_Name) = Chars (Pack_Id) then
Error_Msg_NE
("& is hidden within declaration of formal package",
- Gen_Id, Gen_Name);
+ Gen_Id, Gen_Name);
end if;
end;
@@ -2503,9 +2502,8 @@ package body Sem_Ch12 is
Set_Inner_Instances (Formal, New_Elmt_List);
Push_Scope (Formal);
- if Is_Child_Unit (Gen_Unit)
- and then Parent_Installed
- then
+ if Is_Child_Unit (Gen_Unit) and then Parent_Installed then
+
-- Similarly, we have to make the name of the formal visible in the
-- parent instance, to resolve properly fully qualified names that
-- may appear in the generic unit. The parent instance has been
@@ -2538,15 +2536,11 @@ package body Sem_Ch12 is
begin
E := First_Entity (Formal);
while Present (E) loop
- if Associations
- and then not Is_Generic_Formal (E)
- then
+ if Associations and then not Is_Generic_Formal (E) then
Set_Is_Hidden (E);
end if;
- if Ekind (E) = E_Package
- and then Renamed_Entity (E) = Formal
- then
+ if Ekind (E) = E_Package and then Renamed_Entity (E) = Formal then
Set_Is_Hidden (E);
exit;
end if;
@@ -2697,8 +2691,8 @@ package body Sem_Ch12 is
and then Is_Incomplete_Type (Ctrl_Type)
then
Error_Msg_NE
- ("controlling type of abstract formal subprogram cannot " &
- "be incomplete type", N, Ctrl_Type);
+ ("controlling type of abstract formal subprogram cannot "
+ & "be incomplete type", N, Ctrl_Type);
else
Check_Controlling_Formals (Ctrl_Type, Nam);
@@ -2974,7 +2968,6 @@ package body Sem_Ch12 is
-- caller.
Gen_Parm_Decl := First (Generic_Formal_Declarations (N));
-
while Present (Gen_Parm_Decl) loop
Analyze (Gen_Parm_Decl);
Next (Gen_Parm_Decl);
@@ -3011,13 +3004,12 @@ package body Sem_Ch12 is
Defining_Unit_Name =>
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Chars (Defining_Entity (N)), "GH")),
- Name => Make_Identifier (Loc, Chars (Defining_Entity (N))));
+ Name =>
+ Make_Identifier (Loc, Chars (Defining_Entity (N))));
if Present (Decls) then
Decl := First (Decls);
- while Present (Decl)
- and then Nkind (Decl) = N_Pragma
- loop
+ while Present (Decl) and then Nkind (Decl) = N_Pragma loop
Next (Decl);
end loop;
@@ -3229,8 +3221,9 @@ package body Sem_Ch12 is
if Is_Abstract_Type (Designated_Type (Result_Type))
and then Ada_Version >= Ada_2012
then
- Error_Msg_N ("generic function cannot have an access result"
- & " that designates an abstract type", Spec);
+ Error_Msg_N
+ ("generic function cannot have an access result "
+ & "that designates an abstract type", Spec);
end if;
else
@@ -3423,7 +3416,8 @@ package body Sem_Ch12 is
if Nkind (Defining_Unit_Name (N)) = N_Defining_Program_Unit_Name then
Act_Decl_Name :=
Make_Defining_Program_Unit_Name (Loc,
- Name => New_Copy_Tree (Name (Defining_Unit_Name (N))),
+ Name =>
+ New_Copy_Tree (Name (Defining_Unit_Name (N))),
Defining_Identifier => Act_Decl_Id);
else
Act_Decl_Name := Act_Decl_Id;
@@ -3643,8 +3637,7 @@ package body Sem_Ch12 is
begin
ASN1 := First (Aspect_Specifications (N));
while Present (ASN1) loop
- if Chars (Identifier (ASN1))
- = Name_Default_Storage_Pool
+ if Chars (Identifier (ASN1)) = Name_Default_Storage_Pool
then
-- If generic carries a default storage pool, remove
-- it in favor of the instance one.
@@ -3694,7 +3687,6 @@ package body Sem_Ch12 is
and then not Is_Child_Unit (Gen_Unit)
then
Scop := Scope (Gen_Unit);
-
while Present (Scop)
and then Scop /= Standard_Standard
loop
@@ -4274,10 +4266,7 @@ package body Sem_Ch12 is
-- must be made invisible as well.
S := Current_Scope;
-
- while Present (S)
- and then S /= Standard_Standard
- loop
+ while Present (S) and then S /= Standard_Standard loop
if Is_Generic_Instance (S)
and then (In_Package_Body (S)
or else Ekind_In (S, E_Procedure, E_Function))
@@ -4302,9 +4291,8 @@ package body Sem_Ch12 is
or else (Ekind (Curr_Unit) = E_Package_Body
and then S = Spec_Entity (Curr_Unit))
or else (Ekind (Curr_Unit) = E_Subprogram_Body
- and then S =
- Corresponding_Spec
- (Unit_Declaration_Node (Curr_Unit)))
+ and then S = Corresponding_Spec
+ (Unit_Declaration_Node (Curr_Unit)))
then
Removed := True;
@@ -4409,9 +4397,7 @@ package body Sem_Ch12 is
Par : Entity_Id;
begin
Par := Scope (Curr_Scope);
- while (Present (Par))
- and then Par /= Standard_Standard
- loop
+ while (Present (Par)) and then Par /= Standard_Standard loop
Install_Private_Declarations (Par);
Par := Scope (Par);
end loop;
@@ -4424,9 +4410,7 @@ package body Sem_Ch12 is
-- scopes (and those local to the child unit itself) need to be
-- installed explicitly.
- if Is_Child_Unit (Curr_Unit)
- and then Removed
- then
+ if Is_Child_Unit (Curr_Unit) and then Removed then
for J in reverse 1 .. Num_Inner + 1 loop
Scope_Stack.Table (Scope_Stack.Last - J + 1).First_Use_Clause :=
Use_Clauses (J);
@@ -4968,11 +4952,11 @@ package body Sem_Ch12 is
and then Is_Controlling_Formal (Formal)
and then not Can_Never_Be_Null (Formal)
then
- Error_Msg_NE ("access parameter& is controlling,",
- N, Formal);
Error_Msg_NE
- ("\corresponding parameter of & must be"
- & " explicitly null-excluding", N, Gen_Id);
+ ("access parameter& is controlling,", N, Formal);
+ Error_Msg_NE
+ ("\corresponding parameter of & must be "
+ & "explicitly null-excluding", N, Gen_Id);
end if;
Next_Formal (Formal);
@@ -5129,6 +5113,7 @@ package body Sem_Ch12 is
Actual_Subp : Entity_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (Formal_Subp);
+ Ret_Type : constant Entity_Id := Get_Instance_Of (Etype (Formal_Subp));
Actuals : List_Id;
Decl : Node_Id;
Func_Name : Node_Id;
@@ -5150,12 +5135,7 @@ package body Sem_Ch12 is
Actuals := New_List;
Profile := New_List;
- if Present (Actual_Subp) then
- Act_F := First_Formal (Actual_Subp);
- else
- Act_F := Empty;
- end if;
-
+ Act_F := First_Formal (Actual_Subp);
Form_F := First_Formal (Formal_Subp);
while Present (Form_F) loop
@@ -5166,7 +5146,8 @@ package body Sem_Ch12 is
New_F := Make_Defining_Identifier (Loc, Chars (Form_F));
- Parm_Type := New_Occurrence_Of (Etype (Act_F), Loc);
+ Parm_Type :=
+ New_Occurrence_Of (Get_Instance_Of (Etype (Form_F)), Loc);
Append_To (Profile,
Make_Parameter_Specification (Loc,
@@ -5185,8 +5166,7 @@ package body Sem_Ch12 is
Make_Function_Specification (Loc,
Defining_Unit_Name => Func,
Parameter_Specifications => Profile,
- Result_Definition =>
- Make_Identifier (Loc, Chars (Etype (Formal_Subp))));
+ Result_Definition => New_Occurrence_Of (Ret_Type, Loc));
Decl :=
Make_Expression_Function (Loc,
@@ -5526,7 +5506,8 @@ package body Sem_Ch12 is
-- original name.
elsif Is_Entity_Name (Original_Node (Constant_Value (Ent))) then
- Ent := Entity (Original_Node (Constant_Value (Ent)));
+ Ent := Entity (Original_Node (Constant_Value (Ent)));
+
else
return False;
end if;
@@ -5574,9 +5555,7 @@ package body Sem_Ch12 is
-- Start of processing for Check_Formal_Package_Instance
begin
- while Present (E1)
- and then Present (E2)
- loop
+ while Present (E1) and then Present (E2) loop
exit when Ekind (E1) = E_Package
and then Renamed_Entity (E1) = Renamed_Entity (Actual_Pack);
@@ -5597,9 +5576,7 @@ package body Sem_Ch12 is
and then not Comes_From_Source (E1)
and then Chars (E1) /= Chars (E2)
then
- while Present (E1)
- and then Chars (E1) /= Chars (E2)
- loop
+ while Present (E1) and then Chars (E1) /= Chars (E2) loop
Next_Entity (E1);
end loop;
end if;
@@ -5631,9 +5608,7 @@ package body Sem_Ch12 is
-- If E2 is a formal type declaration, it is a defaulted parameter
-- and needs no checking.
- if not Is_Itype (E1)
- and then not Is_Itype (E2)
- then
+ if not Is_Itype (E1) and then not Is_Itype (E2) then
Check_Mismatch
(not Is_Type (E2)
or else Etype (E1) /= Etype (E2)
@@ -5694,15 +5669,15 @@ package body Sem_Ch12 is
(not Same_Instantiated_Constant
(Entity (Expr1), Entity (Expr2)));
end if;
+
else
Check_Mismatch (True);
end if;
elsif Is_Entity_Name (Original_Node (Expr1))
and then Is_Entity_Name (Expr2)
- and then
- Same_Instantiated_Constant
- (Entity (Original_Node (Expr1)), Entity (Expr2))
+ and then Same_Instantiated_Constant
+ (Entity (Original_Node (Expr1)), Entity (Expr2))
then
null;
@@ -6026,10 +6001,10 @@ package body Sem_Ch12 is
begin
if Is_Wrapper_Package (Instance) then
Gen_Id :=
- Generic_Parent
- (Specification
- (Unit_Declaration_Node
- (Related_Instance (Instance))));
+ Generic_Parent
+ (Specification
+ (Unit_Declaration_Node
+ (Related_Instance (Instance))));
else
Gen_Id :=
Generic_Parent (Package_Specification (Instance));
@@ -6409,8 +6384,7 @@ package body Sem_Ch12 is
and then Is_Generic_Unit (Scope (Renamed_Object (E)))
and then Nkind (Name (Parent (E))) = N_Expanded_Name
then
- Rewrite (Gen_Id,
- New_Copy_Tree (Name (Parent (E))));
+ Rewrite (Gen_Id, New_Copy_Tree (Name (Parent (E))));
Inst_Par := Entity (Prefix (Gen_Id));
if not In_Open_Scopes (Inst_Par) then
@@ -6458,7 +6432,7 @@ package body Sem_Ch12 is
Error_Msg_Node_2 := Scope (Act_Decl_Id);
Error_Msg_NE
("generic unit & is implicitly declared in &",
- Defining_Unit_Name (N), Gen_Unit);
+ Defining_Unit_Name (N), Gen_Unit);
Error_Msg_N ("\instance must have different name",
Defining_Unit_Name (N));
end if;
@@ -6616,9 +6590,8 @@ package body Sem_Ch12 is
if Nkind (Actual) = N_Subtype_Declaration then
Gen_T := Generic_Parent_Type (Actual);
- if Present (Gen_T)
- and then Is_Tagged_Type (Gen_T)
- then
+ if Present (Gen_T) and then Is_Tagged_Type (Gen_T) then
+
-- Traverse the list of primitives of the actual types
-- searching for hidden primitives that are visible in the
-- corresponding generic formal; leave them visible and
@@ -6677,7 +6650,7 @@ package body Sem_Ch12 is
Error_Msg_Node_2 := Inner;
Error_Msg_NE
("circular Instantiation: & instantiated within &!",
- N, Scop);
+ N, Scop);
return True;
elsif Node (Elmt) = Inner then
@@ -6687,7 +6660,7 @@ package body Sem_Ch12 is
Error_Msg_Node_2 := Inner;
Error_Msg_NE
("circular Instantiation: & instantiated within &!",
- N, Node (Elmt));
+ N, Node (Elmt));
return True;
end if;
@@ -7195,9 +7168,7 @@ package body Sem_Ch12 is
Rt : Entity_Id;
begin
- if Present (T)
- and then Is_Private_Type (T)
- then
+ if Present (T) and then Is_Private_Type (T) then
Switch_View (T);
end if;
@@ -7256,9 +7227,8 @@ package body Sem_Ch12 is
-- Retrieve the allocator node in the generic copy
Acc_T := Etype (Parent (Parent (T)));
- if Present (Acc_T)
- and then Is_Private_Type (Acc_T)
- then
+
+ if Present (Acc_T) and then Is_Private_Type (Acc_T) then
Switch_View (Acc_T);
end if;
end if;
@@ -7321,9 +7291,8 @@ package body Sem_Ch12 is
and then Instantiating
then
-- If the string is declared in an outer scope, the string_literal
- -- subtype created for it may have the wrong scope. We force the
- -- reanalysis of the constant to generate a new itype in the proper
- -- context.
+ -- subtype created for it may have the wrong scope. Force reanalysis
+ -- of the constant to generate a new itype in the proper context.
Set_Etype (New_N, Empty);
Set_Analyzed (New_N, False);
@@ -7857,7 +7826,8 @@ package body Sem_Ch12 is
and then Earlier (Inst_Node, Gen_Body)
then
if Nkind (Enc_G) = N_Package_Body then
- E_G_Id := Corresponding_Spec (Enc_G);
+ E_G_Id :=
+ Corresponding_Spec (Enc_G);
else pragma Assert (Nkind (Enc_G) = N_Package_Body_Stub);
E_G_Id :=
Corresponding_Spec (Proper_Body (Unit (Library_Unit (Enc_G))));
@@ -7925,6 +7895,7 @@ package body Sem_Ch12 is
begin
if Res /= Assoc_Null then
return Generic_Renamings.Table (Res).Act_Id;
+
else
-- On exit, entity is not instantiated: not a generic parameter, or
-- else parameter of an inner generic unit.
@@ -8110,9 +8081,10 @@ package body Sem_Ch12 is
Inst : Node_Id) return Boolean
is
Decls : constant Node_Id := Parent (F_Node);
- Nod : Node_Id := Parent (Inst);
+ Nod : Node_Id;
begin
+ Nod := Parent (Inst);
while Present (Nod) loop
if Nod = Decls then
return True;
@@ -8326,9 +8298,7 @@ package body Sem_Ch12 is
begin
S := Scope (Gen);
- while Present (S)
- and then S /= Standard_Standard
- loop
+ while Present (S) and then S /= Standard_Standard loop
if Is_Generic_Instance (S)
and then In_Same_Source_Unit (S, N)
then
@@ -8386,9 +8356,7 @@ package body Sem_Ch12 is
-- In these three cases the freeze node of the previous
-- instance is not relevant.
- while Present (Scop)
- and then Scop /= Standard_Standard
- loop
+ while Present (Scop) and then Scop /= Standard_Standard loop
exit when Scop = Par_I
or else
(Is_Generic_Instance (Scop)
@@ -8405,8 +8373,8 @@ package body Sem_Ch12 is
-- the current scope as well.
elsif Present (Next (N))
- and then Nkind_In (Next (N),
- N_Subprogram_Body, N_Package_Body)
+ and then Nkind_In (Next (N), N_Subprogram_Body,
+ N_Package_Body)
and then Comes_From_Source (Next (N))
then
null;
@@ -8419,7 +8387,7 @@ package body Sem_Ch12 is
-- Current instance is within an unrelated body
elsif Present (Enclosing_N)
- and then Enclosing_N /= Enclosing_Body (Par_I)
+ and then Enclosing_N /= Enclosing_Body (Par_I)
then
null;
@@ -8597,11 +8565,11 @@ package body Sem_Ch12 is
(Gen_Unit = Act_Unit
and then (Nkind_In (Gen_Unit, N_Package_Declaration,
N_Generic_Package_Declaration)
- or else (Gen_Unit = Body_Unit
- and then True_Sloc (N) < Sloc (Orig_Body)))
+ or else (Gen_Unit = Body_Unit
+ and then True_Sloc (N) < Sloc (Orig_Body)))
and then Is_In_Main_Unit (Gen_Unit)
and then (Scope (Act_Id) = Scope (Gen_Id)
- or else In_Same_Enclosing_Subp));
+ or else In_Same_Enclosing_Subp));
-- If this is an early instantiation, the freeze node is placed after
-- the generic body. Otherwise, if the generic appears in an instance,
@@ -8784,6 +8752,7 @@ package body Sem_Ch12 is
end if;
Next_Entity (E);
+
if Present (Gen_E) then
Next_Entity (Gen_E);
end if;
@@ -8904,9 +8873,8 @@ package body Sem_Ch12 is
First_Gen := Gen_Par;
- while Present (Gen_Par)
- and then Is_Child_Unit (Gen_Par)
- loop
+ while Present (Gen_Par) and then Is_Child_Unit (Gen_Par) loop
+
-- Load grandparent instance as well
Inst_Node := Get_Package_Instantiation_Node (Inst_Par);
@@ -9411,8 +9379,8 @@ package body Sem_Ch12 is
Defining_Unit_Name => New_Copy (Defining_Identifier (Formal)),
Name => New_Occurrence_Of (Actual_Pack, Loc));
- Set_Associated_Formal_Package (Defining_Unit_Name (Nod),
- Defining_Identifier (Formal));
+ Set_Associated_Formal_Package
+ (Defining_Unit_Name (Nod), Defining_Identifier (Formal));
Decls := New_List (Nod);
-- If the formal F has a box, then the generic declarations are
@@ -9551,8 +9519,8 @@ package body Sem_Ch12 is
Append_To (Decls,
Make_Package_Instantiation (Sloc (Actual),
- Defining_Unit_Name => I_Pack,
- Name =>
+ Defining_Unit_Name => I_Pack,
+ Name =>
New_Occurrence_Of
(Get_Instance_Of (Gen_Parent), Sloc (Actual)),
Generic_Associations =>
@@ -9640,7 +9608,7 @@ package body Sem_Ch12 is
end if;
Error_Msg_NE
- ("expect subprogram or entry name in instantiation of&",
+ ("expect subprogram or entry name in instantiation of &",
Instantiation_Node, Formal_Sub);
Abandon_Instantiation (Instantiation_Node);
end Valid_Actual_Subprogram;
@@ -9924,11 +9892,11 @@ package body Sem_Ch12 is
if No (Actual) then
Error_Msg_NE
- ("missing actual&",
+ ("missing actual &",
Instantiation_Node, Gen_Obj);
Error_Msg_NE
("\in instantiation of & declared#",
- Instantiation_Node, Scope (A_Gen_Obj));
+ Instantiation_Node, Scope (A_Gen_Obj));
Abandon_Instantiation (Instantiation_Node);
end if;
@@ -10023,8 +9991,7 @@ package body Sem_Ch12 is
Resolve (Actual, Ftyp);
if not Denotes_Variable (Actual) then
- Error_Msg_NE
- ("actual for& must be a variable", Actual, Gen_Obj);
+ Error_Msg_NE ("actual for& must be a variable", Actual, Gen_Obj);
elsif Base_Type (Ftyp) /= Base_Type (Etype (Actual)) then
@@ -10220,9 +10187,8 @@ package body Sem_Ch12 is
if Ada_Version >= Ada_2005
and then Present (Actual_Decl)
- and then
- Nkind_In (Actual_Decl, N_Formal_Object_Declaration,
- N_Object_Declaration)
+ and then Nkind_In (Actual_Decl, N_Formal_Object_Declaration,
+ N_Object_Declaration)
and then Nkind (Analyzed_Formal) = N_Formal_Object_Declaration
and then not Has_Null_Exclusion (Actual_Decl)
and then Has_Null_Exclusion (Analyzed_Formal)
@@ -10509,8 +10475,7 @@ package body Sem_Ch12 is
if Nkind (Defining_Unit_Name (Act_Spec)) =
N_Defining_Program_Unit_Name
then
- Set_Scope
- (Defining_Entity (Inst_Node), Scope (Act_Decl_Id));
+ Set_Scope (Defining_Entity (Inst_Node), Scope (Act_Decl_Id));
end if;
end if;
@@ -10791,7 +10756,7 @@ package body Sem_Ch12 is
-- If there is a formal subprogram with the same name as the unit
-- itself, do not add this renaming declaration. This is a temporary
- -- fix for one ACVC test. ???
+ -- fix for one ACATS test. ???
Prev_Formal := First_Entity (Pack_Id);
while Present (Prev_Formal) loop
@@ -10993,7 +10958,7 @@ package body Sem_Ch12 is
then
Error_Msg_NE
("actual for& cannot be a type with predicate",
- Instantiation_Node, A_Gen_T);
+ Instantiation_Node, A_Gen_T);
elsif No_Dynamic_Predicate_On_Actual (A_Gen_T)
and then Has_Predicates (Act_T)
@@ -11001,7 +10966,7 @@ package body Sem_Ch12 is
then
Error_Msg_NE
("actual for& cannot be a type with a dynamic predicate",
- Instantiation_Node, A_Gen_T);
+ Instantiation_Node, A_Gen_T);
end if;
end Diagnose_Predicated_Actual;
@@ -11473,9 +11438,9 @@ package body Sem_Ch12 is
elsif Nkind (Parent (Act_T)) = N_Full_Type_Declaration
and then Nkind (Type_Definition (Parent (Act_T))) =
- N_Derived_Type_Definition
- and then not Synchronized_Present (Type_Definition
- (Parent (Act_T)))
+ N_Derived_Type_Definition
+ and then not Synchronized_Present
+ (Type_Definition (Parent (Act_T)))
then
Error_Msg_N
("actual of synchronized type must be synchronized", Actual);
@@ -11506,16 +11471,14 @@ package body Sem_Ch12 is
and then not Unknown_Discriminants_Present (Formal)
and then Is_Indefinite_Subtype (Act_T)
then
- Error_Msg_N
- ("actual subtype must be constrained", Actual);
+ Error_Msg_N ("actual subtype must be constrained", Actual);
Abandon_Instantiation (Actual);
end if;
if not Unknown_Discriminants_Present (Formal) then
if Is_Constrained (Ancestor) then
if not Is_Constrained (Act_T) then
- Error_Msg_N
- ("actual subtype must be constrained", Actual);
+ Error_Msg_N ("actual subtype must be constrained", Actual);
Abandon_Instantiation (Actual);
end if;
@@ -11559,8 +11522,8 @@ package body Sem_Ch12 is
No (Corresponding_Discriminant (Actual_Discr))
then
Error_Msg_NE
- ("discriminant & does not correspond " &
- "to ancestor discriminant", Actual, Actual_Discr);
+ ("discriminant & does not correspond "
+ & "to ancestor discriminant", Actual, Actual_Discr);
Abandon_Instantiation (Actual);
end if;
@@ -11711,13 +11674,13 @@ package body Sem_Ch12 is
Anc_F_Type := Etype (Anc_Formal);
Act_F_Type := Etype (Act_Formal);
- if Ekind (Anc_F_Type)
- = E_Anonymous_Access_Type
+ if Ekind (Anc_F_Type) =
+ E_Anonymous_Access_Type
then
Anc_F_Type := Designated_Type (Anc_F_Type);
- if Ekind (Act_F_Type)
- = E_Anonymous_Access_Type
+ if Ekind (Act_F_Type) =
+ E_Anonymous_Access_Type
then
Act_F_Type :=
Designated_Type (Act_F_Type);
@@ -11769,14 +11732,14 @@ package body Sem_Ch12 is
Anc_F_Type := Etype (Anc_Subp);
Act_F_Type := Etype (Act_Subp);
- if Ekind (Anc_F_Type)
- = E_Anonymous_Access_Type
+ if Ekind (Anc_F_Type) =
+ E_Anonymous_Access_Type
then
Anc_F_Type :=
Designated_Type (Anc_F_Type);
- if Ekind (Act_F_Type)
- = E_Anonymous_Access_Type
+ if Ekind (Act_F_Type) =
+ E_Anonymous_Access_Type
then
Act_F_Type :=
Designated_Type (Act_F_Type);
@@ -11804,9 +11767,8 @@ package body Sem_Ch12 is
and then Anc_F_Type /= Act_F_Type
and then
Has_Controlling_Result (Anc_Subp)
- and then
- not Is_Tagged_Ancestor
- (Anc_F_Type, Act_F_Type)
+ and then not Is_Tagged_Ancestor
+ (Anc_F_Type, Act_F_Type)
then
Subprograms_Correspond := False;
end if;
@@ -11818,10 +11780,9 @@ package body Sem_Ch12 is
if Subprograms_Correspond then
Error_Msg_NE
- ("abstract subprogram & overrides " &
- "nonabstract subprogram of ancestor",
- Actual,
- Act_Subp);
+ ("abstract subprogram & overrides "
+ & "nonabstract subprogram of ancestor",
+ Actual, Act_Subp);
end if;
end if;
end if;
@@ -11853,8 +11814,8 @@ package body Sem_Ch12 is
null;
else
Error_Msg_NE
- ("actual for non-limited & cannot be a limited type", Actual,
- Gen_T);
+ ("actual for non-limited & cannot be a limited type",
+ Actual, Gen_T);
Explain_Limited_Type (Act_T, Actual);
Abandon_Instantiation (Actual);
end if;
@@ -11964,7 +11925,7 @@ package body Sem_Ch12 is
if not Is_Interface (Act_T) then
Error_Msg_NE
("actual for formal interface type must be an interface",
- Actual, Gen_T);
+ Actual, Gen_T);
elsif Is_Limited_Type (Act_T) /= Is_Limited_Type (A_Gen_T)
or else Is_Task_Interface (A_Gen_T) /= Is_Task_Interface (Act_T)
@@ -12162,7 +12123,7 @@ package body Sem_Ch12 is
if not Is_Discrete_Type (Act_T) then
Error_Msg_NE
("expect discrete type in instantiation of&",
- Actual, Gen_T);
+ Actual, Gen_T);
Abandon_Instantiation (Actual);
end if;
@@ -12275,9 +12236,8 @@ package body Sem_Ch12 is
Set_Generic_Parent_Type (Decl_Node, Ancestor);
end if;
- elsif Nkind_In (Def,
- N_Formal_Private_Type_Definition,
- N_Formal_Incomplete_Type_Definition)
+ elsif Nkind_In (Def, N_Formal_Private_Type_Definition,
+ N_Formal_Incomplete_Type_Definition)
then
Set_Generic_Parent_Type (Decl_Node, A_Gen_T);
end if;
@@ -12474,8 +12434,8 @@ package body Sem_Ch12 is
and then Nkind (True_Parent) /= N_Compilation_Unit
loop
if Nkind (True_Parent) = N_Package_Declaration
- and then
- Nkind (Original_Node (True_Parent)) = N_Package_Instantiation
+ and then
+ Nkind (Original_Node (True_Parent)) = N_Package_Instantiation
then
-- Parent is a compilation unit that is an instantiation.
-- Instantiation node has been replaced with package decl.
@@ -12993,8 +12953,9 @@ package body Sem_Ch12 is
-- provide additional warning which might explain the error.
Set_Is_Immediately_Visible (Cur, Vis);
- Error_Msg_NE ("& hides outer unit with the same name??",
- N, Defining_Unit_Name (N));
+ Error_Msg_NE
+ ("& hides outer unit with the same name??",
+ N, Defining_Unit_Name (N));
end if;
Abandon_Instantiation (Act);
@@ -14102,8 +14063,8 @@ package body Sem_Ch12 is
Make_Explicit_Dereference (Loc,
Prefix => Make_Function_Call (Loc,
Name =>
- New_Occurrence_Of (Entity (Name (Prefix (N2))),
- Loc))));
+ New_Occurrence_Of
+ (Entity (Name (Prefix (N2))), Loc))));
else
Set_Associated_Node (N, Empty);
@@ -14144,6 +14105,7 @@ package body Sem_Ch12 is
if No (N2) then
Typ := Empty;
+
else
Typ := Etype (N2);
@@ -14183,11 +14145,12 @@ package body Sem_Ch12 is
and then Comes_From_Source (Typ)
then
if Is_Immediately_Visible (Scope (Typ)) then
- Nam := Make_Selected_Component (Loc,
- Prefix =>
- Make_Identifier (Loc, Chars (Scope (Typ))),
- Selector_Name =>
- Make_Identifier (Loc, Chars (Typ)));
+ Nam :=
+ Make_Selected_Component (Loc,
+ Prefix =>
+ Make_Identifier (Loc, Chars (Scope (Typ))),
+ Selector_Name =>
+ Make_Identifier (Loc, Chars (Typ)));
else
Nam := Make_Identifier (Loc, Chars (Typ));
end if;
@@ -14195,7 +14158,7 @@ package body Sem_Ch12 is
Qual :=
Make_Qualified_Expression (Loc,
Subtype_Mark => Nam,
- Expression => Relocate_Node (N));
+ Expression => Relocate_Node (N));
end if;
end if;
@@ -14472,8 +14435,8 @@ package body Sem_Ch12 is
end case;
if not OK then
- Error_Msg_N ("attribute reference has wrong profile for subprogram",
- Def);
+ Error_Msg_N
+ ("attribute reference has wrong profile for subprogram", Def);
end if;
end Valid_Default_Attribute;
diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb
index 413fe90..2f22a9a 100644
--- a/gcc/ada/sem_ch8.adb
+++ b/gcc/ada/sem_ch8.adb
@@ -3457,19 +3457,18 @@ package body Sem_Ch8 is
-- points of call within an instance. Wrappers are generated if formal
-- subprogram is subject to axiomatization.
+ -- The types in the wrapper profiles are obtained from (instances of)
+ -- the types of the formal subprogram.
+
if Is_Actual
and then GNATprove_Mode
and then Present (Containing_Package_With_Ext_Axioms (Formal_Spec))
and then not Inside_A_Generic
then
if Ekind (Old_S) = E_Function then
- Rewrite (N, Build_Function_Wrapper (New_S, Old_S));
+ Rewrite (N, Build_Function_Wrapper (Formal_Spec, Old_S));
Analyze (N);
- -- For wrappers of operators, the types are obtained from (the
- -- instances of) the types of the formal subprogram, not from the
- -- actual subprogram, that carries predefined types.
-
elsif Ekind (Old_S) = E_Operator then
Rewrite (N, Build_Operator_Wrapper (Formal_Spec, Old_S));
Analyze (N);