diff options
author | Bob Duff <duff@adacore.com> | 2023-03-27 18:07:17 -0400 |
---|---|---|
committer | Marc Poulhiès <poulhies@adacore.com> | 2023-05-26 09:29:19 +0200 |
commit | 53d45e492ebb88a84d6440e7db089d5f78610274 (patch) | |
tree | 8aab9d89ce2967d3af7a22e4fd470bcc35dfe6de /gcc | |
parent | fa4b7069a0dfd28b58c718cf8b2060df47a39641 (diff) | |
download | gcc-53d45e492ebb88a84d6440e7db089d5f78610274.zip gcc-53d45e492ebb88a84d6440e7db089d5f78610274.tar.gz gcc-53d45e492ebb88a84d6440e7db089d5f78610274.tar.bz2 |
ada: Fix crash on 'Img as generic actual function
'Image is allowed as an actual for a generic formal function.
This patch fixes a crash when 'Img is used instead of 'Image
in that context.
Misc cleanups.
gcc/ada/
* exp_put_image.adb (Build_Image_Call): Treat 'Img the same as
'Image.
* exp_imgv.adb (Expand_Image_Attribute): If Discard_Names, expand
to 'Image instead of 'Img.
* snames.ads-tmpl, par-ch4.adb, sem_attr.adb, sem_attr.ads:
Cleanups: Rename Attribute_Class_Array to be Attribute_Set. Remove
unnecessary qualifications. DRY: Don't repeat "True".
Diffstat (limited to 'gcc')
-rw-r--r-- | gcc/ada/exp_imgv.adb | 9 | ||||
-rw-r--r-- | gcc/ada/exp_put_image.adb | 4 | ||||
-rw-r--r-- | gcc/ada/par-ch4.adb | 22 | ||||
-rw-r--r-- | gcc/ada/sem_attr.adb | 25 | ||||
-rw-r--r-- | gcc/ada/sem_attr.ads | 4 | ||||
-rw-r--r-- | gcc/ada/snames.ads-tmpl | 2 |
6 files changed, 33 insertions, 33 deletions
diff --git a/gcc/ada/exp_imgv.adb b/gcc/ada/exp_imgv.adb index 257f65b..a31ce1d 100644 --- a/gcc/ada/exp_imgv.adb +++ b/gcc/ada/exp_imgv.adb @@ -762,7 +762,7 @@ package body Exp_Imgv is -- Snn (1 .. Pnn) then occurs as in the other cases. A special case is -- when pragma Discard_Names applies, in which case we replace expr by: - -- (rt'Pos (expr))'Img + -- (rt'Pos (expr))'Image -- So that the result is a space followed by the decimal value for the -- position of the enumeration value in the enumeration type. @@ -1211,8 +1211,8 @@ package body Exp_Imgv is or else No (Lit_Strings (Rtyp)) then -- When pragma Discard_Names applies to the first subtype, build - -- (Long_Long_Integer (Pref'Pos (Expr)))'Img. The conversion is - -- there to avoid applying 'Img directly in Universal_Integer, + -- (Long_Long_Integer (Pref'Pos (Expr)))'Image. The conversion is + -- there to avoid applying 'Image directly in Universal_Integer, -- which can be a very large type. See also the handling of 'Val. Rewrite (N, @@ -1223,8 +1223,7 @@ package body Exp_Imgv is Prefix => Pref, Attribute_Name => Name_Pos, Expressions => New_List (Expr))), - Attribute_Name => - Name_Img)); + Attribute_Name => Name_Image)); Analyze_And_Resolve (N, Standard_String); return; diff --git a/gcc/ada/exp_put_image.adb b/gcc/ada/exp_put_image.adb index c194237..9eda323 100644 --- a/gcc/ada/exp_put_image.adb +++ b/gcc/ada/exp_put_image.adb @@ -1126,7 +1126,9 @@ package body Exp_Put_Image is -- Attribute names that will be mapped to the corresponding result types -- and functions. - Attribute_Name_Id : constant Name_Id := Attribute_Name (N); + Attribute_Name_Id : constant Name_Id := + (if Attribute_Name (N) = Name_Img then Name_Image + else Attribute_Name (N)); Result_Typ : constant Entity_Id := (case Image_Name_Id'(Attribute_Name_Id) is diff --git a/gcc/ada/par-ch4.adb b/gcc/ada/par-ch4.adb index 2505eb6..52f2b02 100644 --- a/gcc/ada/par-ch4.adb +++ b/gcc/ada/par-ch4.adb @@ -34,17 +34,17 @@ package body Ch4 is -- Attributes that cannot have arguments - Is_Parameterless_Attribute : constant Attribute_Class_Array := - (Attribute_Base => True, - Attribute_Body_Version => True, - Attribute_Class => True, - Attribute_External_Tag => True, - Attribute_Img => True, - Attribute_Loop_Entry => True, - Attribute_Old => True, - Attribute_Result => True, - Attribute_Stub_Type => True, - Attribute_Version => True, + Is_Parameterless_Attribute : constant Attribute_Set := + (Attribute_Base | + Attribute_Body_Version | + Attribute_Class | + Attribute_External_Tag | + Attribute_Img | + Attribute_Loop_Entry | + Attribute_Old | + Attribute_Result | + Attribute_Stub_Type | + Attribute_Version | Attribute_Type_Key => True, others => False); -- This map contains True for parameterless attributes that return a string diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 3910327..8257d4b 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -104,8 +104,8 @@ package body Sem_Attr is -- In Ada 83 mode, these are the only recognized attributes. In other Ada -- modes all these attributes are recognized, even if removed in Ada 95. - Attribute_83 : constant Attribute_Class_Array := Attribute_Class_Array'( - Attribute_Address | + Attribute_83 : constant Attribute_Set := + (Attribute_Address | Attribute_Aft | Attribute_Alignment | Attribute_Base | @@ -153,8 +153,8 @@ package body Sem_Attr is -- RM which are not defined in Ada 95. These are recognized in Ada 95 mode, -- but in Ada 95 they are considered to be implementation defined. - Attribute_05 : constant Attribute_Class_Array := Attribute_Class_Array'( - Attribute_Machine_Rounding | + Attribute_05 : constant Attribute_Set := + (Attribute_Machine_Rounding | Attribute_Mod | Attribute_Priority | Attribute_Stream_Size | @@ -165,8 +165,8 @@ package body Sem_Attr is -- RM which are not defined in Ada 2005. These are recognized in Ada 95 -- and Ada 2005 modes, but are considered to be implementation defined. - Attribute_12 : constant Attribute_Class_Array := Attribute_Class_Array'( - Attribute_First_Valid | + Attribute_12 : constant Attribute_Set := + (Attribute_First_Valid | Attribute_Has_Same_Storage | Attribute_Last_Valid | Attribute_Max_Alignment_For_Allocation => True, @@ -176,10 +176,10 @@ package body Sem_Attr is -- RM which are not defined in Ada 2012. These are recognized in Ada -- 95/2005/2012 modes, but are considered to be implementation defined. - Attribute_22 : constant Attribute_Class_Array := Attribute_Class_Array'( - Attribute_Enum_Rep | - Attribute_Enum_Val => True, - Attribute_Index => True, + Attribute_22 : constant Attribute_Set := + (Attribute_Enum_Rep | + Attribute_Enum_Val | + Attribute_Index | Attribute_Preelaborable_Initialization => True, others => False); @@ -187,9 +187,8 @@ package body Sem_Attr is -- of their prefixes or result in an access value. Such prefixes can be -- considered as lvalues. - Attribute_Name_Implies_Lvalue_Prefix : constant Attribute_Class_Array := - Attribute_Class_Array'( - Attribute_Access | + Attribute_Name_Implies_Lvalue_Prefix : constant Attribute_Set := + (Attribute_Access | Attribute_Address | Attribute_Input | Attribute_Read | diff --git a/gcc/ada/sem_attr.ads b/gcc/ada/sem_attr.ads index b7a0571..f383ab5 100644 --- a/gcc/ada/sem_attr.ads +++ b/gcc/ada/sem_attr.ads @@ -46,8 +46,8 @@ package Sem_Attr is -- in GNAT, as well as constructing an array of flags indicating which -- attributes these are. - Attribute_Impl_Def : constant Attribute_Class_Array := - Attribute_Class_Array'( + Attribute_Impl_Def : constant Attribute_Set := + ( ------------------ -- Abort_Signal -- diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index 9868d97..9d17b43 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -1643,7 +1643,7 @@ package Snames is subtype Internal_Attribute_Id is Attribute_Id range Attribute_CPU .. Attribute_Interrupt_Priority; - type Attribute_Class_Array is array (Attribute_Id) of Boolean; + type Attribute_Set is array (Attribute_Id) of Boolean; -- Type used to build attribute classification flag arrays ------------------------------------ |