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