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

[Ada] Put_Image improvements for strings

Browse Source 
2020-06-15  Bob Duff  <duff@adacore.com>

gcc/ada/

	* exp_attr.adb (Put_Image): Use underlying type for strings.
	Remove unchecked union processing.
	* exp_put_image.adb (Tagged_Put_Image_Enabled): Use -gnatd_z to
	enable default Put_Image for tagged types.  This allows testing
	that feature.
	(Build_String_Put_Image_Call): Set Conversion_OK flag.
	(Make_Component_List_Attributes): Remove unchecked union
	processing.
	(Enable_Put_Image): Disable for unchecked unions.  Enable for
	nonscalar types (which were mistakenly disabled in earlier
	changes).
	* debug.adb: Document -gnatd_z switch.
	* libgnat/s-putima.adb (Put_Image_String, Put_Image_Wide_String,
	Put_Image_Wide_Wide_String): Double double-quote characters.
	Forget about special handling of control characters for now --
	that's rare enough to not be a priority, and it's not clear what
	the right thing to do is anyway.
	* namet.adb: Minor: Improve debugger-friendliness.
	* sinfo.ads: Minor: Add "???" comment.
This commit is contained in:
Bob Duff 2020-03-30 10:14:27 -04:00 committed by Pierre-Marie de Rodat
parent 6c04efdd9c
commit eb72521915
6 changed files with 61 additions and 64 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
gcc/ada/debug.adb
View File

@ -170,7 +170,7 @@ package body Debug is
-- d_w
-- d_x
-- d_y
-- d_z
-- d_z Enable Put_Image on tagged types
-- d_A Stop generation of ALI file
-- d_B
@ -993,6 +993,9 @@ package body Debug is
-- a call to routine Ada.Synchronous_Task_Control.Suspend_Until_True
-- or Ada.Synchronous_Barriers.Wait_For_Release.
-- d_z Enable the default Put_Image on tagged types that are not
-- predefined.
-- d_A Do not generate ALI files by setting Opt.Disable_ALI_File.
-- d_F The compiler encodes the full path from an invocation construct to

30
gcc/ada/exp_attr.adb
View File

@ -5505,20 +5505,7 @@ package body Exp_Attr is
Analyze (N);
return;
-- ???It would be nice to call Build_String_Put_Image_Call below
-- if U_Type is a standard string type, but it currently generates
-- something like:
--
-- Put_Image_String (Sink, String (X));
--
-- so if X is of a private type whose full type is "new String",
-- then the type conversion is illegal. To fix that, we would need
-- to do unchecked conversions of access values, taking care to
-- deal with thin and fat pointers properly. For now, we just fall
-- back to Build_Array_Put_Image_Procedure in these cases, so the
-- following says "Root_Type (Entity (Pref))" instead of "U_Type".
elsif Is_Standard_String_Type (Root_Type (Entity (Pref))) then
elsif Is_Standard_String_Type (U_Type) then
Rewrite (N, Build_String_Put_Image_Call (N));
Analyze (N);
return;
@ -5558,21 +5545,6 @@ package body Exp_Attr is
else
pragma Assert (Is_Record_Type (U_Type));
-- Program_Error is raised when calling the default
-- implementation of the Put_Image attribute of an
-- Unchecked_Union type. ???It would be friendlier to print a
-- canned string. See handling of unchecked unions in
-- exp_put_image.adb (which is not reachable).
if Is_Unchecked_Union (Base_Type (U_Type)) then
Rewrite (N,
Make_Raise_Program_Error (Loc,
Reason => PE_Unchecked_Union_Restriction));
Set_Etype (N, Standard_Void_Type);
return;
end if;
Build_Record_Put_Image_Procedure
(Loc, Full_Base (U_Type), Decl, Pname);
Insert_Action (N, Decl);

53
gcc/ada/exp_put_image.adb
View File

@ -27,6 +27,7 @@ with Atree; use Atree;
with Einfo; use Einfo;
with Exp_Tss; use Exp_Tss;
with Exp_Util;
with Debug; use Debug;
with Lib; use Lib;
with Namet; use Namet;
with Nlists; use Nlists;
@ -44,7 +45,7 @@ with Uintp; use Uintp;
package body Exp_Put_Image is
Tagged_Put_Image_Enabled : constant Boolean := False;
Tagged_Put_Image_Enabled : Boolean renames Debug_Flag_Underscore_Z;
-- ???Set True to enable Put_Image for at least some tagged types
-----------------------
@ -410,18 +411,21 @@ package body Exp_Put_Image is
-- Convert parameter to the required type (i.e. the type of the
-- corresponding parameter), and call the appropriate routine.
-- We set the Conversion_OK flag in case the type is private.
declare
Libent : constant Entity_Id := RTE (Lib_RE);
Conv : constant Node_Id :=
OK_Convert_To
(Etype (Next_Formal (First_Formal (Libent))),
Relocate_Node (Item));
begin
return
Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (Libent, Loc),
Parameter_Associations => New_List (
Relocate_Node (Sink),
Convert_To
(Etype (Next_Formal (First_Formal (Libent))),
Relocate_Node (Item))));
Conv));
end;
end Build_String_Put_Image_Call;
@ -585,24 +589,11 @@ package body Exp_Put_Image is
-- selector, since there are cases in which we make a reference
-- to a hidden discriminant that is not visible.
-- If the enclosing record is an unchecked_union, we use the
-- default expressions for the discriminant (it must exist)
-- because we cannot generate a reference to it, given that it is
-- not stored. ????This seems unfriendly. It should just print
-- "(unchecked union)" instead. (Note that this code is
-- unreachable -- see exp_attr.)
if Is_Unchecked_Union (Scope (Entity (Name (VP)))) then
D_Ref :=
New_Copy_Tree
(Discriminant_Default_Value (Entity (Name (VP))));
else
D_Ref :=
Make_Selected_Component (Loc,
Prefix => Make_Identifier (Loc, Name_V),
Selector_Name =>
New_Occurrence_Of (Entity (Name (VP)), Loc));
end if;
D_Ref :=
Make_Selected_Component (Loc,
Prefix => Make_Identifier (Loc, Name_V),
Selector_Name =>
New_Occurrence_Of (Entity (Name (VP)), Loc));
Append_To (Result,
Make_Case_Statement (Loc,
@ -715,8 +706,6 @@ package body Exp_Put_Image is
(Make_Identifier (Loc, Name_S))));
-- Generate Put_Images for the discriminants of the type
-- If the type is an unchecked union, use the default values of
-- the discriminants, because they are not stored.
Append_List_To (Stms,
Make_Component_Attributes (Discriminant_Specifications (Type_Decl)));
@ -901,7 +890,15 @@ package body Exp_Put_Image is
return False;
end if;
return Is_Scalar_Type (Typ) or else not In_Predefined_Unit (Typ);
-- Disable for unchecked unions, because there is no way to know the
-- discriminant value, and therefore no way to know which components
-- should be printed.
if Is_Unchecked_Union (Typ) then
return False;
end if;
return True;
end Enable_Put_Image;
---------------------------------
@ -941,6 +938,12 @@ package body Exp_Put_Image is
-- enabled for tagged types, and we've seen a tagged type. Note that
-- Tagged_Seen is set True by the parser if the "tagged" reserved word
-- is seen; this flag tells us whether we have any tagged types.
-- It's unfortunate to have this Tagged_Seen processing so scattered
-- about, but we need to know if there are tagged types where this is
-- called in Analyze_Compilation_Unit, before we have analyzed any type
-- declarations. This mechanism also prevents doing RTE (RE_Sink) when
-- compiling the compiler itself. Packages Ada.Strings.Text_Output and
-- friends are not included in the compiler.
--
-- Don't do it if type Sink is unavailable in the runtime.

23
gcc/ada/libgnat/s-putima.adb
View File

@ -142,17 +142,25 @@ package body System.Put_Images is
procedure Put_Image_String (S : in out Sink'Class; X : String) is
begin
-- ????We should double double quotes, and maybe do something nice with
-- control characters.
Put_UTF_8 (S, """");
Put_String (S, X);
for C of X loop
if C = '"' then
Put_UTF_8 (S, """");
end if;
Put_Character (S, C);
end loop;
Put_UTF_8 (S, """");
end Put_Image_String;
procedure Put_Image_Wide_String (S : in out Sink'Class; X : Wide_String) is
begin
Put_UTF_8 (S, """");
Put_Wide_String (S, X);
for C of X loop
if C = '"' then
Put_UTF_8 (S, """");
end if;
Put_Wide_Character (S, C);
end loop;
Put_UTF_8 (S, """");
end Put_Image_Wide_String;
@ -160,7 +168,12 @@ package body System.Put_Images is
(S : in out Sink'Class; X : Wide_Wide_String) is
begin
Put_UTF_8 (S, """");
Put_Wide_Wide_String (S, X);
for C of X loop
if C = '"' then
Put_UTF_8 (S, """");
end if;
Put_Wide_Wide_Character (S, C);
end loop;
Put_UTF_8 (S, """");
end Put_Image_Wide_Wide_String;

12
gcc/ada/namet.adb
View File

@ -1179,11 +1179,13 @@ package body Namet is
Hash_Index : Hash_Index_Type;
-- Computed hash index
Result : Valid_Name_Id;
begin
-- Quick handling for one character names
if Buf.Length = 1 then
return Valid_Name_Id (First_Name_Id + Character'Pos (Buf.Chars (1)));
Result := First_Name_Id + Character'Pos (Buf.Chars (1));
-- Otherwise search hash table for existing matching entry
@ -1210,7 +1212,8 @@ package body Namet is
end if;
end loop;
return New_Id;
Result := New_Id;
goto Done;
-- Current entry in hash chain does not match
@ -1248,8 +1251,11 @@ package body Namet is
Name_Chars.Append (ASCII.NUL);
return Name_Entries.Last;
Result := Name_Entries.Last;
end if;
<<Done>>
return Result;
end Name_Find;
function Name_Find (S : String) return Valid_Name_Id is

2
gcc/ada/sinfo.ads
View File

@ -1029,7 +1029,7 @@ package Sinfo is
-- Present in N_Raise_Expression nodes that appear in the body of the
-- special predicateM function used to test a predicate in the context
-- of a membership test, where raise expression results in returning a
-- value of False rather than raising an exception.
-- value of False rather than raising an exception.???obsolete flag
-- Corresponding_Aspect (Node3-Sem)
-- Present in N_Pragma node. Used to point back to the source aspect from