| ------------------------------------------------------------------------------ |
| -- -- |
| -- 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; |
