diff options
| -rw-r--r-- | gcc/ada/exp_attr.adb | 3 | ||||
| -rw-r--r-- | gcc/ada/exp_put_image.adb | 52 | ||||
| -rw-r--r-- | gcc/ada/exp_put_image.ads | 10 | ||||
| -rw-r--r-- | gcc/ada/libgnat/a-stouut.adb | 29 | ||||
| -rw-r--r-- | gcc/ada/opt.ads | 4 | ||||
| -rw-r--r-- | gcc/ada/scng.adb | 6 | ||||
| -rw-r--r-- | gcc/ada/sem_ch10.adb | 11 |
7 files changed, 80 insertions, 35 deletions
diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index fc7aefa..5faa1ce 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -5471,9 +5471,6 @@ package body Exp_Attr is if No (Pname) then if Is_Tagged_Type (U_Type) and then Is_Derived_Type (U_Type) then Pname := Find_Optional_Prim_Op (U_Type, TSS_Put_Image); - pragma Assert - (Has_Interfaces (U_Type) -- ????interfaces not yet supported - or else Enable_Put_Image (U_Type) = Present (Pname)); else Pname := Find_Inherited_TSS (U_Type, TSS_Put_Image); end if; diff --git a/gcc/ada/exp_put_image.adb b/gcc/ada/exp_put_image.adb index 286640d..0d13258 100644 --- a/gcc/ada/exp_put_image.adb +++ b/gcc/ada/exp_put_image.adb @@ -44,6 +44,9 @@ with Uintp; use Uintp; package body Exp_Put_Image is + Tagged_Put_Image_Enabled : constant Boolean := False; + -- ???Set True to enable Put_Image for at least some tagged types + ----------------------- -- Local Subprograms -- ----------------------- @@ -816,12 +819,6 @@ package body Exp_Put_Image is function Enable_Put_Image (Typ : Entity_Id) return Boolean is begin - -- Disable in pre-2020 versions for now??? - - if Ada_Version < Ada_2020 then - return False; - end if; - -- There's a bit of a chicken&egg problem. The compiler is likely to -- have trouble if we refer to the Put_Image of Sink itself, because -- Sink is part of the parameter profile: @@ -846,14 +843,37 @@ package body Exp_Put_Image is -- Put_Image on tagged types triggers some bugs. -- -- Put_Image doesn't work for private types whose full type is real. + -- Disable for all real types, for simplicity. + -- + -- Put_Image doesn't work for access-to-protected types, because of + -- confusion over their size. Disable for all access-to-subprogram + -- types, just in case. if Is_Remote_Types (Scope (Typ)) or else (Is_Tagged_Type (Typ) and then In_Predefined_Unit (Typ)) + or else (Is_Tagged_Type (Typ) and then not Tagged_Put_Image_Enabled) or else Is_Real_Type (Typ) + or else Is_Access_Subprogram_Type (Typ) then return False; end if; + -- End of workarounds. + + -- No sense in generating code for Put_Image if there are errors. This + -- avoids certain cascade errors. + + if Total_Errors_Detected > 0 then + return False; + end if; + + -- If type Sink is unavailable in this runtime, disable Put_Image + -- altogether. + + if No_Run_Time_Mode or else not RTE_Available (RE_Sink) then + return False; + end if; + -- ???Disable Put_Image on type Sink declared in -- Ada.Strings.Text_Output. Note that we can't call Is_RTU on -- Ada_Strings_Text_Output, because it's not known yet (we might be @@ -911,9 +931,25 @@ package body Exp_Put_Image is -- Preload_Sink -- ------------------ - procedure Preload_Sink is + procedure Preload_Sink (Compilation_Unit : Node_Id) is begin - if RTE_Available (RE_Sink) then + -- We can't call RTE (RE_Sink) for at least some predefined units, + -- because it would introduce cyclic dependences. The package where Sink + -- is declared, for example, and things it depends on. + -- + -- It's only needed for tagged types, so don't do it unless 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. + -- + -- Don't do it if type Sink is unavailable in the runtime. + + if not In_Predefined_Unit (Compilation_Unit) + and then Tagged_Put_Image_Enabled + and then Tagged_Seen + and then not No_Run_Time_Mode + and then RTE_Available (RE_Sink) + then declare Ignore : constant Entity_Id := RTE (RE_Sink); begin diff --git a/gcc/ada/exp_put_image.ads b/gcc/ada/exp_put_image.ads index 6b5f6b0..3ee8f8b 100644 --- a/gcc/ada/exp_put_image.ads +++ b/gcc/ada/exp_put_image.ads @@ -85,10 +85,10 @@ package Exp_Put_Image is function Build_Unknown_Put_Image_Call (N : Node_Id) return Node_Id; -- Build a call to Put_Image_Unknown - procedure Preload_Sink; - -- Call RTE (RE_Sink), to load the packages involved in Put_Image. We - -- need to do this explicitly, fairly early during compilation, because - -- otherwise it happens during freezing, which triggers visibility bugs - -- in generic instantiations. + procedure Preload_Sink (Compilation_Unit : Node_Id); + -- Call RTE (RE_Sink) if necessary, to load the packages involved in + -- Put_Image. We need to do this explicitly, fairly early during + -- compilation, because otherwise it happens during freezing, which + -- triggers visibility bugs in generic instantiations. end Exp_Put_Image; diff --git a/gcc/ada/libgnat/a-stouut.adb b/gcc/ada/libgnat/a-stouut.adb index 9d5d163..89d6c6e 100644 --- a/gcc/ada/libgnat/a-stouut.adb +++ b/gcc/ada/libgnat/a-stouut.adb @@ -40,6 +40,10 @@ package body Ada.Strings.Text_Output.Utils is procedure Adjust_Column (S : in out Sink'Class) with Inline; -- Adjust the column for a non-NL character. + procedure Put_UTF_8_Outline (S : in out Sink'Class; Item : UTF_8); + -- Out-of-line portion of Put_UTF_8. This exists solely to make Put_UTF_8 + -- small enough to reasonably inline it. + procedure Full (S : in out Sink'Class) is begin pragma Assert (S.Last = S.Chunk_Length); @@ -132,16 +136,9 @@ package body Ada.Strings.Text_Output.Utils is end if; end Put_Wide_Wide_Character; - procedure Put_UTF_8 (S : in out Sink'Class; Item : UTF_8) is + procedure Put_UTF_8_Outline (S : in out Sink'Class; Item : UTF_8) is begin - Adjust_Column (S); - - if S.Last + Item'Length < S.Chunk_Length then - -- Item fits in current chunk - - S.Cur_Chunk.Chars (S.Last + 1 .. S.Last + Item'Length) := Item; - S.Last := S.Last + Item'Length; - elsif S.Last + Item'Length = S.Chunk_Length then + if S.Last + Item'Length = S.Chunk_Length then -- Item fits exactly in current chunk S.Cur_Chunk.Chars (S.Last + 1 .. S.Last + Item'Length) := Item; @@ -168,6 +165,20 @@ package body Ada.Strings.Text_Output.Utils is Put_UTF_8 (S, Right); -- This might call Full, but probably not. end; end if; + end Put_UTF_8_Outline; + + procedure Put_UTF_8 (S : in out Sink'Class; Item : UTF_8) is + begin + Adjust_Column (S); + + if S.Last + Item'Length < S.Chunk_Length then + -- Item fits in current chunk + + S.Cur_Chunk.Chars (S.Last + 1 .. S.Last + Item'Length) := Item; + S.Last := S.Last + Item'Length; + else + Put_UTF_8_Outline (S, Item); + end if; end Put_UTF_8; procedure Put_UTF_8_Lines (S : in out Sink'Class; Item : UTF_8_Lines) is diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads index b25266a..864b60b 100644 --- a/gcc/ada/opt.ads +++ b/gcc/ada/opt.ads @@ -2178,6 +2178,10 @@ package Opt is -- be in the spec of Expander, but it is referenced by Errout, and it -- really seems wrong for Errout to depend on Expander. + Tagged_Seen : Boolean := False; + -- Set True by the parser if the "tagged" reserved word is seen. This is + -- needed in Exp_Put_Image (see that package for documentation). + ----------------------------------- -- Modes for Formal Verification -- ----------------------------------- diff --git a/gcc/ada/scng.adb b/gcc/ada/scng.adb index 46d1f8e..fd3dacc 100644 --- a/gcc/ada/scng.adb +++ b/gcc/ada/scng.adb @@ -2568,6 +2568,12 @@ package body Scng is Accumulate_Token_Checksum; Token := Token_Type'Val (Get_Name_Table_Byte (Token_Name)); + -- See Exp_Put_Image for documentation of Tagged_Seen + + if Token = Tok_Tagged then + Tagged_Seen := True; + end if; + -- Keyword style checks if Style_Check then diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index a4de98b..28f4674 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -622,16 +622,7 @@ package body Sem_Ch10 is -- Start of processing for Analyze_Compilation_Unit begin - -- We can't call Preload_Sink for at least some predefined units, - -- because it would introduce cyclic dependences. The package where Sink - -- is declared, for example, and things it depends on. See Exp_Put_Image - -- for documentation. We don't call Preload_Sink in pre-2020 Ada - -- versions, because the default Put_Image is disabled in those - -- versions, at least for now. - - if Ada_Version >= Ada_2020 and then not In_Predefined_Unit (N) then - Exp_Put_Image.Preload_Sink; - end if; + Exp_Put_Image.Preload_Sink (N); Process_Compilation_Unit_Pragmas (N); |