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