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