------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- SYSTEM.PUT_IMAGES --
-- --
-- B o d y --
-- --
-- Copyright (C) 2020-2023, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Ada.Strings.Text_Buffers.Utils;
use Ada.Strings.Text_Buffers;
use Ada.Strings.Text_Buffers.Utils;
with Ada.Unchecked_Conversion;
package body System.Put_Images is
generic
type Integer_Type is range <>;
type Unsigned_Type is mod <>;
Base : Unsigned_Type;
package Generic_Integer_Images is
pragma Assert (Integer_Type'Size = Unsigned_Type'Size);
pragma Assert (Base in 2 .. 36);
procedure Put_Image (S : in out Sink'Class; X : Integer_Type);
procedure Put_Image (S : in out Sink'Class; X : Unsigned_Type);
private
subtype Digit is Unsigned_Type range 0 .. Base - 1;
end Generic_Integer_Images;
package body Generic_Integer_Images is
A : constant := Character'Pos ('a');
Z : constant := Character'Pos ('0');
function Digit_To_Character (X : Digit) return Character is
(Character'Val (if X < 10 then X + Z else X + A - 10));
procedure Put_Digits (S : in out Sink'Class; X : Unsigned_Type);
-- Put just the digits of X, without any leading minus sign or space.
procedure Put_Digits (S : in out Sink'Class; X : Unsigned_Type) is
begin
if X >= Base then
Put_Digits (S, X / Base); -- recurse
Put_7bit (S, Digit_To_Character (X mod Base));
else
Put_7bit (S, Digit_To_Character (X));
end if;
end Put_Digits;
procedure Put_Image (S : in out Sink'Class; X : Integer_Type) is
begin
-- Put the space or the minus sign, then pass the absolute value to
-- Put_Digits.
if X >= 0 then
Put_7bit (S, ' ');
Put_Digits (S, Unsigned_Type (X));
else
Put_7bit (S, '-');
Put_Digits (S, -Unsigned_Type'Mod (X));
-- Convert to Unsigned_Type before negating, to avoid overflow
-- on Integer_Type'First.
end if;
end Put_Image;
procedure Put_Image (S : in out Sink'Class; X : Unsigned_Type) is
begin
Put_7bit (S, ' ');
Put_Digits (S, X);
end Put_Image;
end Generic_Integer_Images;
package Integer_Images is new Generic_Integer_Images
(Integer, Unsigned, Base => 10);
package LL_Integer_Images is new Generic_Integer_Images
(Long_Long_Integer, Long_Long_Unsigned, Base => 10);
package LLL_Integer_Images is new Generic_Integer_Images
(Long_Long_Long_Integer, Long_Long_Long_Unsigned, Base => 10);
procedure Put_Image_Integer (S : in out Sink'Class; X : Integer)
renames Integer_Images.Put_Image;
procedure Put_Image_Long_Long_Integer
(S : in out Sink'Class; X : Long_Long_Integer)
renames LL_Integer_Images.Put_Image;
procedure Put_Image_Long_Long_Long_Integer
(S : in out Sink'Class; X : Long_Long_Long_Integer)
renames LLL_Integer_Images.Put_Image;
procedure Put_Image_Unsigned (S : in out Sink'Class; X : Unsigned)
renames Integer_Images.Put_Image;
procedure Put_Image_Long_Long_Unsigned
(S : in out Sink'Class; X : Long_Long_Unsigned)
renames LL_Integer_Images.Put_Image;
procedure Put_Image_Long_Long_Long_Unsigned
(S : in out Sink'Class; X : Long_Long_Long_Unsigned)
renames LLL_Integer_Images.Put_Image;
type Signed_Address is range -Memory_Size / 2 .. Memory_Size / 2 - 1;
type Unsigned_Address is mod Memory_Size;
package Hex is new Generic_Integer_Images
(Signed_Address, Unsigned_Address, Base => 16);
generic
type Designated (<>) is private;
type Pointer is access all Designated;
procedure Put_Image_Pointer
(S : in out Sink'Class; X : Pointer; Type_Kind : String);
procedure Put_Image_Pointer
(S : in out Sink'Class; X : Pointer; Type_Kind : String)
is
function Cast is new Ada.Unchecked_Conversion
(System.Address, Unsigned_Address);
begin
if X = null then
Put_UTF_8 (S, "null");
else
Put_UTF_8 (S, "(");
Put_UTF_8 (S, Type_Kind);
Hex.Put_Image (S, Cast (X.all'Address));
Put_UTF_8 (S, ")");
end if;
end Put_Image_Pointer;
procedure Thin_Instance is new Put_Image_Pointer (Byte, Thin_Pointer);
procedure Put_Image_Thin_Pointer
(S : in out Sink'Class; X : Thin_Pointer)
is
begin
Thin_Instance (S, X, "access");
end Put_Image_Thin_Pointer;
procedure Fat_Instance is new Put_Image_Pointer (Byte_String, Fat_Pointer);
procedure Put_Image_Fat_Pointer
(S : in out Sink'Class; X : Fat_Pointer)
is
begin
Fat_Instance (S, X, "access");
end Put_Image_Fat_Pointer;
procedure Put_Image_Access_Subp (S : in out Sink'Class; X : Thin_Pointer) is
begin
Thin_Instance (S, X, "access subprogram");
end Put_Image_Access_Subp;
procedure Put_Image_Access_Prot_Subp
(S : in out Sink'Class; X : Thin_Pointer)
is
begin
Thin_Instance (S, X, "access protected subprogram");
end Put_Image_Access_Prot_Subp;
procedure Put_Image_String
(S : in out Sink'Class;
X : String;
With_Delimiters : Boolean := True) is
begin
if With_Delimiters then
Put_UTF_8 (S, """");
end if;
for C of X loop
if C = '"' and then With_Delimiters then
Put_UTF_8 (S, """");
end if;
Put_Character (S, C);
end loop;
if With_Delimiters then
Put_UTF_8 (S, """");
end if;
end Put_Image_String;
procedure Put_Image_Wide_String
(S : in out Sink'Class;
X : Wide_String;
With_Delimiters : Boolean := True) is
begin
if With_Delimiters then
Put_UTF_8 (S, """");
end if;
for C of X loop
if C = '"' and then With_Delimiters then
Put_UTF_8 (S, """");
end if;
Put_Wide_Character (S, C);
end loop;
if With_Delimiters then
Put_UTF_8 (S, """");
end if;
end Put_Image_Wide_String;
procedure Put_Image_Wide_Wide_String
(S : in out Sink'Class;
X : Wide_Wide_String;
With_Delimiters : Boolean := True) is
begin
if With_Delimiters then
Put_UTF_8 (S, """");
end if;
for C of X loop
if C = '"' and then With_Delimiters then
Put_UTF_8 (S, """");
end if;
Put_Wide_Wide_Character (S, C);
end loop;
if With_Delimiters then
Put_UTF_8 (S, """");
end if;
end Put_Image_Wide_Wide_String;
procedure Array_Before (S : in out Sink'Class) is
begin
New_Line (S);
Put_7bit (S, '[');
Increase_Indent (S, 1);
end Array_Before;
procedure Array_Between (S : in out Sink'Class) is
begin
Put_7bit (S, ',');
New_Line (S);
end Array_Between;
procedure Array_After (S : in out Sink'Class) is
begin
Decrease_Indent (S, 1);
Put_7bit (S, ']');
end Array_After;
procedure Simple_Array_Between (S : in out Sink'Class) is
begin
Put_7bit (S, ',');
if Column (S) > 60 then
New_Line (S);
else
Put_7bit (S, ' ');
end if;
end Simple_Array_Between;
procedure Record_Before (S : in out Sink'Class) is
begin
New_Line (S);
Put_7bit (S, '(');
Increase_Indent (S, 1);
end Record_Before;
procedure Record_Between (S : in out Sink'Class) is
begin
Put_7bit (S, ',');
New_Line (S);
end Record_Between;
procedure Record_After (S : in out Sink'Class) is
begin
Decrease_Indent (S, 1);
Put_7bit (S, ')');
end Record_After;
procedure Put_Arrow (S : in out Sink'Class) is
begin
Put_UTF_8 (S, " => ");
end Put_Arrow;
procedure Put_Image_Unknown (S : in out Sink'Class; Type_Name : String) is
begin
Put_UTF_8 (S, "{");
Put (S, Type_Name);
Put_UTF_8 (S, " object}");
end Put_Image_Unknown;
end System.Put_Images;