diff options
| -rw-r--r-- | gcc/ada/debug.adb | 5 | ||||
| -rw-r--r-- | gcc/ada/exp_attr.adb | 30 | ||||
| -rw-r--r-- | gcc/ada/exp_put_image.adb | 53 | ||||
| -rw-r--r-- | gcc/ada/libgnat/s-putima.adb | 23 | ||||
| -rw-r--r-- | gcc/ada/namet.adb | 12 | ||||
| -rw-r--r-- | gcc/ada/sinfo.ads | 2 |
6 files changed, 61 insertions, 64 deletions
diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index 1d614eb..63b14b2 100644 --- a/gcc/ada/debug.adb +++ b/gcc/ada/debug.adb @@ -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 diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index a7b9007..182ce15 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -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); diff --git a/gcc/ada/exp_put_image.adb b/gcc/ada/exp_put_image.adb index 0d13258..4d63e39 100644 --- a/gcc/ada/exp_put_image.adb +++ b/gcc/ada/exp_put_image.adb @@ -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. diff --git a/gcc/ada/libgnat/s-putima.adb b/gcc/ada/libgnat/s-putima.adb index 50597b2..2f976ac 100644 --- a/gcc/ada/libgnat/s-putima.adb +++ b/gcc/ada/libgnat/s-putima.adb @@ -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; diff --git a/gcc/ada/namet.adb b/gcc/ada/namet.adb index 60c1050..6cc05bb 100644 --- a/gcc/ada/namet.adb +++ b/gcc/ada/namet.adb @@ -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 diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index d0739b8..7bec540 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -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 |