OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[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.
This commit is contained in:
Gary Dismukes 2021-11-05 19:30:05 -04:00 committed by Pierre-Marie de Rodat
parent ab59968427
commit 7b4069fb7c
2 changed files with 70 additions and 60 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

118
gcc/ada/sem_ch3.adb
View File

@ -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 between the two.
-- 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.
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);
(T, Direct_Primitive_Operations (Base_Type (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;
-- 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
(T, Direct_Primitive_Operations (Base_Type (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);
(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);

12
gcc/ada/sem_ch7.adb
View File

@ -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;