[Ada] Enable Put_Image in pre-Ada-2020 modes
2020-06-12 Bob Duff <duff@adacore.com> gcc/ada/ * exp_attr.adb (Put_Image): Remove assertion. This assertion is False in mixed-Ada-version programs. * exp_put_image.adb (Tagged_Put_Image_Enabled): New flag to make it easy to experiment with Put_Image on tagged types. False in this version. (Enable_Put_Image): Enable in pre-2020. Workarounds: Disable for tagged types if Tagged_Put_Image_Enabled is False. Disable for access-to-subprogram types. Disable if errors have been detected, or Sink is unavailable. (Preload_Sink): Move all conditionals here, from Sem_Ch10, so they can be nearby related code in Enable_Put_Image. Load Sink only if we have seen a tagged type. This removes the dilemma about calling Preload_Sink when compiling the compiler, which caused unwanted dependences. * exp_put_image.ads (Preload_Sink): New formal Compilation_Unit, needed to move all conditionals here, from Sem_Ch10. * libgnat/a-stouut.adb (Put_UTF_8): Make this suitable for inlining, so we don't get warnings about inlining in some tests. And so it can be inlined! * opt.ads (Tagged_Seen): New flag (see Preload_Sink). * scng.adb (Scan): Set new Tagged_Seen flag. * sem_ch10.adb (Analyze_Compilation_Unit): Move conditionals and comments regarding Preload_Sink into Preload_Sink.
This commit is contained in:
Bob Duff
Pierre-Marie de Rodat
parent
3961bedab9
commit
a3483a77e5
7 changed files with 80 additions and 35 deletions
|
|
@ -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;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 --
|
||||
-----------------------------------
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue