1------------------------------------------------------------------------------
2--                                                                          --
3--                         GNAT COMPILER COMPONENTS                         --
4--                                                                          --
5--                 I N T E R F A C E S . C _ S T R E A M S                  --
6--                                                                          --
7--                                 B o d y                                  --
8--                                                                          --
9--          Copyright (C) 1996-2009, Free Software Foundation, Inc.         --
10--                                                                          --
11-- GNAT is free software;  you can  redistribute it  and/or modify it under --
12-- terms of the  GNU General Public License as published  by the Free Soft- --
13-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
14-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
15-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
16-- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
17--                                                                          --
18-- As a special exception under Section 7 of GPL version 3, you are granted --
19-- additional permissions described in the GCC Runtime Library Exception,   --
20-- version 3.1, as published by the Free Software Foundation.               --
21--                                                                          --
22-- You should have received a copy of the GNU General Public License and    --
23-- a copy of the GCC Runtime Library Exception along with this program;     --
24-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
25-- <http://www.gnu.org/licenses/>.                                          --
26--                                                                          --
27-- GNAT was originally developed  by the GNAT team at  New York University. --
28-- Extensive contributions were provided by Ada Core Technologies Inc.      --
29--                                                                          --
30------------------------------------------------------------------------------
31
32--  This is the Alpha/VMS version
33
34with Ada.Unchecked_Conversion;
35package body Interfaces.C_Streams is
36
37   use type System.CRTL.size_t;
38
39   --  As the functions fread, fwrite and setvbuf are too big to be inlined,
40   --  they are just wrappers to the following implementation functions.
41
42   function fread_impl
43     (buffer : voids;
44      size   : size_t;
45      count  : size_t;
46      stream : FILEs) return size_t;
47
48   function fread_impl
49     (buffer : voids;
50      index  : size_t;
51      size   : size_t;
52      count  : size_t;
53      stream : FILEs) return size_t;
54
55   function fwrite_impl
56     (buffer : voids;
57      size   : size_t;
58      count  : size_t;
59      stream : FILEs) return size_t;
60
61   function setvbuf_impl
62     (stream : FILEs;
63      buffer : chars;
64      mode   : int;
65      size   : size_t) return int;
66
67   ------------
68   -- fread --
69   ------------
70
71   function fread_impl
72     (buffer : voids;
73      size   : size_t;
74      count  : size_t;
75      stream : FILEs) return size_t
76   is
77      Get_Count : size_t := 0;
78
79      type Buffer_Type is array (size_t range 1 .. count,
80                                 size_t range 1 .. size) of Character;
81      type Buffer_Access is access Buffer_Type;
82      function To_BA is new Ada.Unchecked_Conversion (voids, Buffer_Access);
83
84      BA : constant Buffer_Access := To_BA (buffer);
85      Ch : int;
86
87   begin
88      --  This Fread goes with the Fwrite below. The C library fread sometimes
89      --  can't read fputc generated files.
90
91      for C in 1 .. count loop
92         for S in 1 .. size loop
93            Ch := fgetc (stream);
94
95            if Ch = EOF then
96               return Get_Count;
97            end if;
98
99            BA.all (C, S) := Character'Val (Ch);
100         end loop;
101
102         Get_Count := Get_Count + 1;
103      end loop;
104
105      return Get_Count;
106   end fread_impl;
107
108   function fread_impl
109     (buffer : voids;
110      index  : size_t;
111      size   : size_t;
112      count  : size_t;
113      stream : FILEs) return size_t
114   is
115      Get_Count : size_t := 0;
116
117      type Buffer_Type is array (size_t range 1 .. count,
118                                 size_t range 1 .. size) of Character;
119      type Buffer_Access is access Buffer_Type;
120      function To_BA is new Ada.Unchecked_Conversion (voids, Buffer_Access);
121
122      BA : constant Buffer_Access := To_BA (buffer);
123      Ch : int;
124
125   begin
126      --  This Fread goes with the Fwrite below. The C library fread sometimes
127      --  can't read fputc generated files.
128
129      for C in 1 + index .. count + index loop
130         for S in 1 .. size loop
131            Ch := fgetc (stream);
132
133            if Ch = EOF then
134               return Get_Count;
135            end if;
136
137            BA.all (C, S) := Character'Val (Ch);
138         end loop;
139
140         Get_Count := Get_Count + 1;
141      end loop;
142
143      return Get_Count;
144   end fread_impl;
145
146   function fread
147     (buffer : voids;
148      size   : size_t;
149      count  : size_t;
150      stream : FILEs) return size_t
151   is
152   begin
153      return fread_impl (buffer, size, count, stream);
154   end fread;
155
156   function fread
157     (buffer : voids;
158      index  : size_t;
159      size   : size_t;
160      count  : size_t;
161      stream : FILEs) return size_t
162   is
163   begin
164      return fread_impl (buffer, index, size, count, stream);
165   end fread;
166
167   ------------
168   -- fwrite --
169   ------------
170
171   function fwrite_impl
172     (buffer : voids;
173      size   : size_t;
174      count  : size_t;
175      stream : FILEs) return size_t
176   is
177      Put_Count : size_t := 0;
178
179      type Buffer_Type is array (size_t range 1 .. count,
180                                 size_t range 1 .. size) of Character;
181      type Buffer_Access is access Buffer_Type;
182      function To_BA is new Ada.Unchecked_Conversion (voids, Buffer_Access);
183
184      BA : constant Buffer_Access := To_BA (buffer);
185
186   begin
187      --  Fwrite on VMS has the undesirable effect of always generating at
188      --  least one record of output per call, regardless of buffering.  To
189      --  get around this, we do multiple fputc calls instead.
190
191      for C in 1 .. count loop
192         for S in 1 .. size loop
193            if fputc (Character'Pos (BA.all (C, S)), stream) = EOF then
194               return Put_Count;
195            end if;
196         end loop;
197
198         Put_Count := Put_Count + 1;
199      end loop;
200
201      return Put_Count;
202   end fwrite_impl;
203
204   function fwrite
205     (buffer : voids;
206      size   : size_t;
207      count  : size_t;
208      stream : FILEs) return size_t
209   is
210   begin
211      return fwrite_impl (buffer, size, count, stream);
212   end fwrite;
213
214   -------------
215   -- setvbuf --
216   -------------
217
218   function setvbuf_impl
219     (stream : FILEs;
220      buffer : chars;
221      mode   : int;
222      size   : size_t) return int
223   is
224      use type System.Address;
225
226   begin
227      --  In order for the above fwrite hack to work, we must always buffer
228      --  stdout and stderr. Is_regular_file on VMS cannot detect when
229      --  these are redirected to a file, so checking for that condition
230      --  doesn't help.
231
232      if mode = IONBF
233        and then (stream = stdout or else stream = stderr)
234      then
235         return System.CRTL.setvbuf
236           (stream, buffer, IOLBF, System.CRTL.size_t (size));
237      else
238         return System.CRTL.setvbuf
239           (stream, buffer, mode, System.CRTL.size_t (size));
240      end if;
241   end setvbuf_impl;
242
243   function setvbuf
244     (stream : FILEs;
245      buffer : chars;
246      mode   : int;
247      size   : size_t) return int
248   is
249   begin
250      return setvbuf_impl (stream, buffer, mode, size);
251   end setvbuf;
252
253end Interfaces.C_Streams;
254