public inbox for gcc-cvs@sourceware.org
help / color / mirror / Atom feed
* [gcc r12-5658] [Ada] Storage error on untagged prefixed subprogram calls with -gnatX
@ 2021-12-01 10:25 Pierre-Marie de Rodat
0 siblings, 0 replies; only message in thread
From: Pierre-Marie de Rodat @ 2021-12-01 10:25 UTC (permalink / raw)
To: gcc-cvs
https://gcc.gnu.org/g:7b4069fb7c00564523f822c7fd94210862eeeae4
commit r12-5658-g7b4069fb7c00564523f822c7fd94210862eeeae4
Author: Gary Dismukes <dismukes@adacore.com>
Date: Fri Nov 5 19:30:05 2021 -0400
[Ada] Storage error on untagged prefixed subprogram calls with -gnatX
gcc/ada/
* sem_ch3.adb (Analyze_Full_Type_Declaration): If the full type
has a primitives list but its base type doesn't, set the base
type's list to the full type's list (covers certain constrained
cases, such as for arrays).
(Analyze_Incomplete_Type_Decl): Unconditionally initialize an
incomplete type's primitives list.
(Analyze_Subtype_Declaration): Unconditionally set a subtype's
primitives list to the base type's list, so the lists are
shared.
(Build_Derived_Private_Type): Unconditionally initialize a
derived private type's list to a new empty list.
(Build_Derived_Record_Type): Unconditionally initialize a
derived record type's list to a new empty list (now a single
call for tagged and untagged cases).
(Derived_Type_Declaration): Unconditionally initialize a derived
type's list to a new empty list in error cases (when Parent_Type
is undefined or illegal).
(Process_Full_View): Unconditionally copy the primitive
operations from the private view to the full view (rather than
conditioning it on whether extensions are enabled).
* sem_ch7.adb (New_Private_Type): Unconditionally initialize an
untagged private type's primitives list to a new empty list.
Diff:
---
gcc/ada/sem_ch3.adb | 118 ++++++++++++++++++++++++++++------------------------
gcc/ada/sem_ch7.adb | 12 +++---
2 files changed, 70 insertions(+), 60 deletions(-)
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index 569e0199dde..edcc1ca26cb 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -3308,33 +3308,41 @@ package body Sem_Ch3 is
-- needed. T may be E_Void in cases of earlier errors, and in that
-- case we bypass this.
- if Ekind (T) /= E_Void
- and then not Present (Direct_Primitive_Operations (T))
- then
- if Etype (T) = T then
- Set_Direct_Primitive_Operations (T, New_Elmt_List);
+ if Ekind (T) /= E_Void then
+ if not Present (Direct_Primitive_Operations (T)) then
+ if Etype (T) = T then
+ Set_Direct_Primitive_Operations (T, New_Elmt_List);
+
+ -- If Etype of T is the base type (as opposed to a parent type)
+ -- and already has an associated list of primitive operations,
+ -- then set T's primitive list to the base type's list. Otherwise,
+ -- create a new empty primitives list and share the list between
+ -- T and its base type. The lists need to be shared in common.
- -- If Etype of T is the base type (as opposed to a parent type) and
- -- already has an associated list of primitive operations, then set
- -- T's primitive list to the base type's list. Otherwise, create a
- -- new empty primitives list and share the list between T and its
- -- base type. The lists need to be shared in common between the two.
+ elsif Etype (T) = Base_Type (T) then
- elsif Etype (T) = Base_Type (T) then
+ if not Present (Direct_Primitive_Operations (Base_Type (T)))
+ then
+ Set_Direct_Primitive_Operations
+ (Base_Type (T), New_Elmt_List);
+ end if;
- if not Present (Direct_Primitive_Operations (Base_Type (T))) then
Set_Direct_Primitive_Operations
- (Base_Type (T), New_Elmt_List);
- end if;
+ (T, Direct_Primitive_Operations (Base_Type (T)));
- Set_Direct_Primitive_Operations
- (T, Direct_Primitive_Operations (Base_Type (T)));
+ -- Case where the Etype is a parent type, so we need a new
+ -- primitives list for T.
- -- Case where the Etype is a parent type, so we need a new primitives
- -- list for T.
+ else
+ Set_Direct_Primitive_Operations (T, New_Elmt_List);
+ end if;
- else
- Set_Direct_Primitive_Operations (T, New_Elmt_List);
+ -- If T already has a Direct_Primitive_Operations list but its
+ -- base type doesn't then set the base type's list to T's list.
+
+ elsif not Present (Direct_Primitive_Operations (Base_Type (T))) then
+ Set_Direct_Primitive_Operations
+ (Base_Type (T), Direct_Primitive_Operations (T));
end if;
end if;
@@ -3509,15 +3517,13 @@ package body Sem_Ch3 is
Make_Class_Wide_Type (T);
end if;
- -- For tagged types, or when prefixed-call syntax is allowed for
- -- untagged types, initialize the list of primitive operations to
- -- an empty list.
+ -- Initialize the list of primitive operations to an empty list,
+ -- to cover tagged types as well as untagged types. For untagged
+ -- types this is used either to analyze the call as legal when
+ -- Extensions_Allowed is True, or to issue a better error message
+ -- otherwise.
- if Tagged_Present (N)
- or else Extensions_Allowed
- then
- Set_Direct_Primitive_Operations (T, New_Elmt_List);
- end if;
+ Set_Direct_Primitive_Operations (T, New_Elmt_List);
Set_Stored_Constraint (T, No_Elist);
@@ -5802,18 +5808,17 @@ package body Sem_Ch3 is
Inherit_Predicate_Flags (Id, T);
end if;
- -- When prefixed calls are enabled for untagged types, the subtype
- -- shares the primitive operations of its base type.
-
- if Extensions_Allowed then
- Set_Direct_Primitive_Operations
- (Id, Direct_Primitive_Operations (Base_Type (T)));
- end if;
-
if Etype (Id) = Any_Type then
goto Leave;
end if;
+ -- When prefixed calls are enabled for untagged types, the subtype
+ -- shares the primitive operations of its base type. Do this even
+ -- when Extensions_Allowed is False to issue better error messages.
+
+ Set_Direct_Primitive_Operations
+ (Id, Direct_Primitive_Operations (Base_Type (T)));
+
-- Some common processing on all types
Set_Size_Info (Id, T);
@@ -8290,6 +8295,14 @@ package body Sem_Ch3 is
Set_Etype (Base_Type (Derived_Type), Base_Type (Parent_Type));
if Derive_Subps then
+ -- Initialize the list of primitive operations to an empty list,
+ -- to cover tagged types as well as untagged types. For untagged
+ -- types this is used either to analyze the call as legal when
+ -- Extensions_Allowed is True, or to issue a better error message
+ -- otherwise.
+
+ Set_Direct_Primitive_Operations (Derived_Type, New_Elmt_List);
+
Derive_Subprograms (Parent_Type, Derived_Type);
end if;
@@ -9640,18 +9653,17 @@ package body Sem_Ch3 is
end;
end if;
- -- When prefixed-call syntax is allowed for untagged types, initialize
- -- the list of primitive operations to an empty list.
+ -- Initialize the list of primitive operations to an empty list,
+ -- to cover tagged types as well as untagged types. For untagged
+ -- types this is used either to analyze the call as legal when
+ -- Extensions_Allowed is True, or to issue a better error message
+ -- otherwise.
- if Extensions_Allowed and then not Is_Tagged then
- Set_Direct_Primitive_Operations (Derived_Type, New_Elmt_List);
- end if;
+ Set_Direct_Primitive_Operations (Derived_Type, New_Elmt_List);
-- Set fields for tagged types
if Is_Tagged then
- Set_Direct_Primitive_Operations (Derived_Type, New_Elmt_List);
-
-- All tagged types defined in Ada.Finalization are controlled
if Chars (Scope (Derived_Type)) = Name_Finalization
@@ -17211,15 +17223,13 @@ package body Sem_Ch3 is
Set_Etype (T, Any_Type);
Set_Scalar_Range (T, Scalar_Range (Any_Type));
- -- For tagged types, or when prefixed-call syntax is allowed for
- -- untagged types, initialize the list of primitive operations to
- -- an empty list.
+ -- Initialize the list of primitive operations to an empty list,
+ -- to cover tagged types as well as untagged types. For untagged
+ -- types this is used either to analyze the call as legal when
+ -- Extensions_Allowed is True, or to issue a better error message
+ -- otherwise.
- if (Is_Tagged_Type (T) and then Is_Record_Type (T))
- or else Extensions_Allowed
- then
- Set_Direct_Primitive_Operations (T, New_Elmt_List);
- end if;
+ Set_Direct_Primitive_Operations (T, New_Elmt_List);
return;
end if;
@@ -21440,10 +21450,10 @@ package body Sem_Ch3 is
end if;
-- For untagged types, copy the primitives across from the private
- -- view to the full view (when extensions are allowed), for support
- -- of prefixed calls (when extensions are enabled).
+ -- view to the full view, for support of prefixed calls when
+ -- extensions are enabled, and better error messages otherwise.
- elsif Extensions_Allowed then
+ else
Priv_List := Primitive_Operations (Priv_T);
Prim_Elmt := First_Elmt (Priv_List);
diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb
index a0bddb19288..95d7ad4c1cd 100644
--- a/gcc/ada/sem_ch7.adb
+++ b/gcc/ada/sem_ch7.adb
@@ -2633,13 +2633,13 @@ package body Sem_Ch7 is
elsif Abstract_Present (Def) then
Error_Msg_N ("only a tagged type can be abstract", N);
- -- When extensions are enabled, we initialize the primitive operations
- -- list of an untagged private type to an empty element list. (Note:
- -- This could be done for all private types and shared with the tagged
- -- case above, but for now we do it separately when the feature of
- -- prefixed calls for untagged types is enabled.)
+ -- We initialize the primitive operations list of an untagged private
+ -- type to an empty element list. Do this even when Extensions_Allowed
+ -- is False to issue better error messages. (Note: This could be done
+ -- for all private types and shared with the tagged case above, but
+ -- for now we do it separately.)
- elsif Extensions_Allowed then
+ else
Set_Direct_Primitive_Operations (Id, New_Elmt_List);
end if;
end New_Private_Type;
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2021-12-01 10:25 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2021-12-01 10:25 [gcc r12-5658] [Ada] Storage error on untagged prefixed subprogram calls with -gnatX Pierre-Marie de Rodat
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).