gcc/ada/i-cstrea-vms.adb

   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-2005, 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,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, 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
  36 with Unchecked_Conversion;
  37 package body Interfaces.C_Streams is
  38
  39    use type System.CRTL.size_t;
  40
  41    --  As the functions fread, fwrite and setvbuf are too big to be inlined,
  42    --  they are just wrappers to the following implementation functions.
  43
  44    function fread_impl
  45      (buffer : voids;
  46       size   : size_t;
  47       count  : size_t;
  48       stream : FILEs) return size_t;
  49
  50    function fread_impl
  51      (buffer : voids;
  52       index  : size_t;
  53       size   : size_t;
  54       count  : size_t;
  55       stream : FILEs) return size_t;
  56
  57    function fwrite_impl
  58      (buffer : voids;
  59       size   : size_t;
  60       count  : size_t;
  61       stream : FILEs) return size_t;
  62
  63    function setvbuf_impl
  64      (stream : FILEs;
  65       buffer : chars;
  66       mode   : int;
  67       size   : size_t) return int;
  68
  69    ------------
  70    -- fread --
  71    ------------
  72
  73    function fread_impl
  74      (buffer : voids;
  75       size   : size_t;
  76       count  : size_t;
  77       stream : FILEs) return size_t
  78    is
  79       Get_Count : size_t := 0;
  80
  81       type Buffer_Type is array (size_t range 1 .. count,
  82                                  size_t range 1 .. size) of Character;
  83       type Buffer_Access is access Buffer_Type;
  84       function To_BA is new Unchecked_Conversion (voids, Buffer_Access);
  85
  86       BA : constant Buffer_Access := To_BA (buffer);
  87       Ch : int;
  88
  89    begin
  90       --  This Fread goes with the Fwrite below. The C library fread sometimes
  91       --  can't read fputc generated files.
  92
  93       for C in 1 .. count loop
  94          for S in 1 .. size loop
  95             Ch := fgetc (stream);
  96
  97             if Ch = EOF then
  98                return Get_Count;
  99             end if;
 100
 101             BA.all (C, S) := Character'Val (Ch);
 102          end loop;
 103
 104          Get_Count := Get_Count + 1;
 105       end loop;
 106
 107       return Get_Count;
 108    end fread_impl;
 109
 110    function fread_impl
 111      (buffer : voids;
 112       index  : size_t;
 113       size   : size_t;
 114       count  : size_t;
 115       stream : FILEs) return size_t
 116    is
 117       Get_Count : size_t := 0;
 118
 119       type Buffer_Type is array (size_t range 1 .. count,
 120                                  size_t range 1 .. size) of Character;
 121       type Buffer_Access is access Buffer_Type;
 122       function To_BA is new Unchecked_Conversion (voids, Buffer_Access);
 123
 124       BA : constant Buffer_Access := To_BA (buffer);
 125       Ch : int;
 126
 127    begin
 128       --  This Fread goes with the Fwrite below. The C library fread sometimes
 129       --  can't read fputc generated files.
 130
 131       for C in 1 + index .. count + index loop
 132          for S in 1 .. size loop
 133             Ch := fgetc (stream);
 134
 135             if Ch = EOF then
 136                return Get_Count;
 137             end if;
 138
 139             BA.all (C, S) := Character'Val (Ch);
 140          end loop;
 141
 142          Get_Count := Get_Count + 1;
 143       end loop;
 144
 145       return Get_Count;
 146    end fread_impl;
 147
 148    function fread
 149      (buffer : voids;
 150       size   : size_t;
 151       count  : size_t;
 152       stream : FILEs) return size_t
 153    is
 154    begin
 155       return fread_impl (buffer, size, count, stream);
 156    end fread;
 157
 158    function fread
 159      (buffer : voids;
 160       index  : size_t;
 161       size   : size_t;
 162       count  : size_t;
 163       stream : FILEs) return size_t
 164    is
 165    begin
 166       return fread_impl (buffer, index, size, count, stream);
 167    end fread;
 168
 169    ------------
 170    -- fwrite --
 171    ------------
 172
 173    function fwrite_impl
 174      (buffer : voids;
 175       size   : size_t;
 176       count  : size_t;
 177       stream : FILEs) return size_t
 178    is
 179       Put_Count : size_t := 0;
 180
 181       type Buffer_Type is array (size_t range 1 .. count,
 182                                  size_t range 1 .. size) of Character;
 183       type Buffer_Access is access Buffer_Type;
 184       function To_BA is new Unchecked_Conversion (voids, Buffer_Access);
 185
 186       BA : constant Buffer_Access := To_BA (buffer);
 187
 188    begin
 189       --  Fwrite on VMS has the undesirable effect of always generating at
 190       --  least one record of output per call, regardless of buffering.  To
 191       --  get around this, we do multiple fputc calls instead.
 192
 193       for C in 1 .. count loop
 194          for S in 1 .. size loop
 195             if fputc (Character'Pos (BA.all (C, S)), stream) = EOF then
 196                return Put_Count;
 197             end if;
 198          end loop;
 199
 200          Put_Count := Put_Count + 1;
 201       end loop;
 202
 203       return Put_Count;
 204    end fwrite_impl;
 205
 206    function fwrite
 207      (buffer : voids;
 208       size   : size_t;
 209       count  : size_t;
 210       stream : FILEs) return size_t
 211    is
 212    begin
 213       return fwrite_impl (buffer, size, count, stream);
 214    end fwrite;
 215
 216    -------------
 217    -- setvbuf --
 218    -------------
 219
 220    function setvbuf_impl
 221      (stream : FILEs;
 222       buffer : chars;
 223       mode   : int;
 224       size   : size_t) return int
 225    is
 226       use type System.Address;
 227
 228    begin
 229       --  In order for the above fwrite hack to work, we must always buffer
 230       --  stdout and stderr. Is_regular_file on VMS cannot detect when
 231       --  these are redirected to a file, so checking for that condition
 232       --  doesnt help.
 233
 234       if mode = IONBF
 235         and then (stream = stdout or else stream = stderr)
 236       then
 237          return System.CRTL.setvbuf
 238            (stream, buffer, IOLBF, System.CRTL.size_t (size));
 239       else
 240          return System.CRTL.setvbuf
 241            (stream, buffer, mode, System.CRTL.size_t (size));
 242       end if;
 243    end setvbuf_impl;
 244
 245    function setvbuf
 246      (stream : FILEs;
 247       buffer : chars;
 248       mode   : int;
 249       size   : size_t) return int
 250    is
 251    begin
 252       return setvbuf_impl (stream, buffer, mode, size);
 253    end setvbuf;
 254
 255 end Interfaces.C_Streams;