OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-stable/] [gcc-4.5.1/] [gcc/] [ada/] [i-cstrea-vms.adb] - Blame information for rev 847

Go to most recent revision | Details | Compare with Previous | View Log

Line No. Rev Author Line
1 281 jeremybenn
------------------------------------------------------------------------------
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
 
34
with Ada.Unchecked_Conversion;
35
package 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
 
253
end Interfaces.C_Streams;

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.