1-- GHDL Run Time (GRT) stdio subprograms for GRT types. 2-- Copyright (C) 2002 - 2014 Tristan Gingold 3-- 4-- This program is free software: you can redistribute it and/or modify 5-- it under the terms of the GNU General Public License as published by 6-- the Free Software Foundation, either version 2 of the License, or 7-- (at your option) any later version. 8-- 9-- This program is distributed in the hope that it will be useful, 10-- but WITHOUT ANY WARRANTY; without even the implied warranty of 11-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12-- GNU General Public License for more details. 13-- 14-- You should have received a copy of the GNU General Public License 15-- along with this program. If not, see <gnu.org/licenses>. 16-- 17-- As a special exception, if other files instantiate generics from this 18-- unit, or you link this unit with other files to produce an executable, 19-- this unit does not by itself cause the resulting executable to be 20-- covered by the GNU General Public License. This exception does not 21-- however invalidate any other reasons why the executable file might be 22-- covered by the GNU Public License. 23with Grt.C; use Grt.C; 24 25package body Grt.Astdio is 26 procedure Put (Stream : FILEs; Str : String) 27 is 28 S : size_t; 29 pragma Unreferenced (S); 30 begin 31 S := fwrite (Str'Address, Str'Length, 1, Stream); 32 end Put; 33 34 procedure Put (Stream : FILEs; C : Character) 35 is 36 R : int; 37 pragma Unreferenced (R); 38 begin 39 R := fputc (Character'Pos (C), Stream); 40 end Put; 41 42 procedure Put (Stream : FILEs; Str : Ghdl_C_String) 43 is 44 Len : Natural; 45 S : size_t; 46 pragma Unreferenced (S); 47 begin 48 Len := strlen (Str); 49 S := fwrite (Str (1)'Address, size_t (Len), 1, Stream); 50 end Put; 51 52 procedure New_Line (Stream : FILEs) is 53 begin 54 Put (Stream, Nl); 55 end New_Line; 56 57 procedure Put_Line (Stream : FILEs; Str : String) is 58 begin 59 Put (Stream, Str); 60 New_Line (Stream); 61 end Put_Line; 62 63 procedure Put (Str : String) 64 is 65 S : size_t; 66 pragma Unreferenced (S); 67 begin 68 S := fwrite (Str'Address, Str'Length, 1, stdout); 69 end Put; 70 71 procedure Put (C : Character) 72 is 73 R : int; 74 pragma Unreferenced (R); 75 begin 76 R := fputc (Character'Pos (C), stdout); 77 end Put; 78 79 procedure Put (Str : Ghdl_C_String) 80 is 81 Len : Natural; 82 S : size_t; 83 pragma Unreferenced (S); 84 begin 85 Len := strlen (Str); 86 S := fwrite (Str (1)'Address, size_t (Len), 1, stdout); 87 end Put; 88 89 procedure New_Line is 90 begin 91 Put (Nl); 92 end New_Line; 93 94 procedure Put_Line (Str : String) 95 is 96 begin 97 Put (Str); 98 New_Line; 99 end Put_Line; 100 101 generic 102 type Ntype is range <>; 103 Max_Len : Natural; 104 procedure Put_Ntype (Stream : FILEs; N : Ntype); 105 106 procedure Put_Ntype (Stream : FILEs; N : Ntype) 107 is 108 Str : String (1 .. Max_Len); 109 P : Natural := Str'Last; 110 V : Ntype; 111 begin 112 -- V is negativ. 113 if N > 0 then 114 V := -N; 115 else 116 V := N; 117 end if; 118 loop 119 Str (P) := Character'Val (48 - (V rem 10)); -- V is <= 0. 120 V := V / 10; 121 exit when V = 0; 122 P := P - 1; 123 end loop; 124 if N < 0 then 125 P := P - 1; 126 Str (P) := '-'; 127 end if; 128 Put (Stream, Str (P .. Max_Len)); 129 end Put_Ntype; 130 131 generic 132 type Utype is mod <>; 133 Max_Len : Natural; 134 procedure Put_Utype (Stream : FILEs; N : Utype); 135 136 procedure Put_Utype (Stream : FILEs; N : Utype) 137 is 138 Str : String (1 .. Max_Len); 139 P : Natural := Str'Last; 140 V : Utype := N; 141 begin 142 loop 143 Str (P) := Character'Val (48 + (V rem 10)); 144 V := V / 10; 145 exit when V = 0; 146 P := P - 1; 147 end loop; 148 Put (Stream, Str (P .. Max_Len)); 149 end Put_Utype; 150 151 procedure Put_I32_1 is new Put_Ntype (Ntype => Ghdl_I32, Max_Len => 11); 152 procedure Put_I32 (Stream : FILEs; I32 : Ghdl_I32) renames Put_I32_1; 153 154 procedure Put_U32_1 is new Put_Utype (Utype => Ghdl_U32, Max_Len => 11); 155 procedure Put_U32 (Stream : FILEs; U32 : Ghdl_U32) renames Put_U32_1; 156 157 procedure Put_I64_1 is new Put_Ntype (Ntype => Ghdl_I64, Max_Len => 20); 158 procedure Put_I64 (Stream : FILEs; I64 : Ghdl_I64) renames Put_I64_1; 159 160 procedure Put_U64_1 is new Put_Utype (Utype => Ghdl_U64, Max_Len => 20); 161 procedure Put_U64 (Stream : FILEs; U64 : Ghdl_U64) renames Put_U64_1; 162 163 procedure Put_F64 (Stream : FILEs; F64 : Ghdl_F64) 164 is 165 procedure Fprintf_G (Stream : FILEs; 166 Arg : Ghdl_F64); 167 pragma Import (C, Fprintf_G, "__ghdl_fprintf_g"); 168 begin 169 Fprintf_G (Stream, F64); 170 end Put_F64; 171 172 Hex_Map : constant array (0 .. 15) of Character := "0123456789ABCDEF"; 173 174 procedure Put (Stream : FILEs; Addr : System.Address) 175 is 176 Res : String (1 .. System.Word_Size / 4); 177 Val : Integer_Address := To_Integer (Addr); 178 begin 179 for I in reverse Res'Range loop 180 Res (I) := Hex_Map (Natural (Val and 15)); 181 Val := Val / 16; 182 end loop; 183 Put (Stream, Res); 184 end Put; 185 186end Grt.Astdio; 187