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;
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 --
-----------------------
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:
-- 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
-- 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
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;
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);
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;
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
-- 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 --
-----------------------------------
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
-- 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);
projects / gcc.git / commitdiff