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-2004 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 2,  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.  See the GNU General Public License --
17-- for  more details.  You should have  received  a copy of the GNU General --
18-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
19-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
20-- MA 02111-1307, USA.                                                      --
21--                                                                          --
22-- As a special exception,  if other files  instantiate  generics from this --
23-- unit, or you link  this unit with other files  to produce an executable, --
24-- this  unit  does not  by itself cause  the resulting  executable  to  be --
25-- covered  by the  GNU  General  Public  License.  This exception does not --
26-- however invalidate  any other reasons why  the executable file  might be --
27-- covered by the  GNU Public License.                                      --
28--                                                                          --
29-- GNAT was originally developed  by the GNAT team at  New York University. --
30-- Extensive contributions were provided by Ada Core Technologies Inc.      --
31--                                                                          --
32------------------------------------------------------------------------------
33
34--  This is the Alpha/VMS version.
35
36with Unchecked_Conversion;
37package body Interfaces.C_Streams is
38
39   use type System.CRTL.size_t;
40
41   --  Substantial rewriting is needed here. These functions are far too
42   --  long to be inlined. They should be rewritten to be small helper
43   --  functions that are inlined, and then call the real routines.???
44
45   --  Alternatively, provide a separate spec for VMS, in which case we
46   --  could reduce the amount of junk bodies in the other cases by
47   --  interfacing directly in the spec.???
48
49   ------------
50   -- fread --
51   ------------
52
53   function fread
54     (buffer : voids;
55      size   : size_t;
56      count  : size_t;
57      stream : FILEs) return size_t
58   is
59      Get_Count : size_t := 0;
60
61      type Buffer_Type is array (size_t range 1 .. count,
62                                 size_t range 1 .. size) of Character;
63      type Buffer_Access is access Buffer_Type;
64      function To_BA is new Unchecked_Conversion (voids, Buffer_Access);
65
66      BA : constant Buffer_Access := To_BA (buffer);
67      Ch : int;
68
69   begin
70      --  This Fread goes with the Fwrite below.
71      --  The C library fread sometimes can't read fputc generated files.
72
73      for C in 1 .. count loop
74         for S in 1 .. size loop
75            Ch := fgetc (stream);
76
77            if Ch = EOF then
78               return Get_Count;
79            end if;
80
81            BA.all (C, S) := Character'Val (Ch);
82         end loop;
83
84         Get_Count := Get_Count + 1;
85      end loop;
86
87      return Get_Count;
88   end fread;
89
90   ------------
91   -- fread --
92   ------------
93
94   function fread
95     (buffer : voids;
96      index  : size_t;
97      size   : size_t;
98      count  : size_t;
99      stream : FILEs) return size_t
100   is
101      Get_Count : size_t := 0;
102
103      type Buffer_Type is array (size_t range 1 .. count,
104                                 size_t range 1 .. size) of Character;
105      type Buffer_Access is access Buffer_Type;
106      function To_BA is new Unchecked_Conversion (voids, Buffer_Access);
107
108      BA : constant Buffer_Access := To_BA (buffer);
109      Ch : int;
110
111   begin
112      --  This Fread goes with the Fwrite below.
113      --  The C library fread sometimes can't read fputc generated files.
114
115      for C in 1 + index .. count + index loop
116         for S in 1 .. size loop
117            Ch := fgetc (stream);
118
119            if Ch = EOF then
120               return Get_Count;
121            end if;
122
123            BA.all (C, S) := Character'Val (Ch);
124         end loop;
125
126         Get_Count := Get_Count + 1;
127      end loop;
128
129      return Get_Count;
130   end fread;
131
132   ------------
133   -- fwrite --
134   ------------
135
136   function fwrite
137     (buffer : voids;
138      size   : size_t;
139      count  : size_t;
140      stream : FILEs) return size_t
141   is
142      Put_Count : size_t := 0;
143
144      type Buffer_Type is array (size_t range 1 .. count,
145                                 size_t range 1 .. size) of Character;
146      type Buffer_Access is access Buffer_Type;
147      function To_BA is new Unchecked_Conversion (voids, Buffer_Access);
148
149      BA : constant Buffer_Access := To_BA (buffer);
150
151   begin
152      --  Fwrite on VMS has the undesirable effect of always generating at
153      --  least one record of output per call, regardless of buffering.  To
154      --  get around this, we do multiple fputc calls instead.
155
156      for C in 1 .. count loop
157         for S in 1 .. size loop
158            if fputc (Character'Pos (BA.all (C, S)), stream) = EOF then
159               return Put_Count;
160            end if;
161         end loop;
162
163         Put_Count := Put_Count + 1;
164      end loop;
165
166      return Put_Count;
167   end fwrite;
168
169   -------------
170   -- setvbuf --
171   -------------
172
173   function setvbuf
174     (stream : FILEs;
175      buffer : chars;
176      mode   : int;
177      size   : size_t) return int
178   is
179      use type System.Address;
180
181   begin
182      --  In order for the above fwrite hack to work, we must always buffer
183      --  stdout and stderr. Is_regular_file on VMS cannot detect when
184      --  these are redirected to a file, so checking for that condition
185      --  doesnt help.
186
187      if mode = IONBF
188        and then (stream = stdout or else stream = stderr)
189      then
190         return System.CRTL.setvbuf
191           (stream, buffer, IOLBF, System.CRTL.size_t (size));
192      else
193         return System.CRTL.setvbuf
194           (stream, buffer, mode, System.CRTL.size_t (size));
195      end if;
196   end setvbuf;
197
198end Interfaces.C_Streams;
199