gcc/ada/6vcstrea.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 --                                                                          --
  10 --          Copyright (C) 1996-2002 Free Software Foundation, Inc.          --
  11 --                                                                          --
  12 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  13 -- terms of the  GNU General Public License as published  by the Free Soft- --
  14 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  15 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  16 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  17 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  18 -- for  more details.  You should have  received  a copy of the GNU General --
  19 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  20 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  21 -- MA 02111-1307, USA.                                                      --
  22 --                                                                          --
  23 -- As a special exception,  if other files  instantiate  generics from this --
  24 -- unit, or you link  this unit with other files  to produce an executable, --
  25 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  26 -- covered  by the  GNU  General  Public  License.  This exception does not --
  27 -- however invalidate  any other reasons why  the executable file  might be --
  28 -- covered by the  GNU Public License.                                      --
  29 --                                                                          --
  30 -- GNAT was originally developed  by the GNAT team at  New York University. --
  31 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  32 --                                                                          --
  33 ------------------------------------------------------------------------------
  34
  35 --  This is the Alpha/VMS version.
  36
  37 with Unchecked_Conversion;
  38 package body Interfaces.C_Streams is
  39
  40    ------------
  41    -- fread --
  42    ------------
  43
  44    function fread
  45      (buffer : voids;
  46       size   : size_t;
  47       count  : size_t;
  48       stream : FILEs)
  49       return   size_t
  50    is
  51       Get_Count : size_t := 0;
  52       type Buffer_Type is array (size_t range 1 .. count,
  53                                  size_t range 1 .. size) of Character;
  54       type Buffer_Access is access Buffer_Type;
  55       function To_BA is new Unchecked_Conversion (voids, Buffer_Access);
  56       BA : Buffer_Access := To_BA (buffer);
  57       Ch : int;
  58    begin
  59
  60       --  This Fread goes with the Fwrite below.
  61       --  The C library fread sometimes can't read fputc generated files.
  62
  63       for C in 1 .. count loop
  64          for S in 1 .. size loop
  65             Ch := fgetc (stream);
  66             if Ch = EOF then
  67                return 0;
  68             end if;
  69             BA.all (C, S) := Character'Val (Ch);
  70          end loop;
  71          Get_Count := Get_Count + 1;
  72       end loop;
  73       return Get_Count;
  74    end fread;
  75
  76    ------------
  77    -- fread --
  78    ------------
  79
  80    function fread
  81      (buffer : voids;
  82       index  : size_t;
  83       size   : size_t;
  84       count  : size_t;
  85       stream : FILEs)
  86       return   size_t
  87    is
  88       Get_Count : size_t := 0;
  89       type Buffer_Type is array (size_t range 1 .. count,
  90                                  size_t range 1 .. size) of Character;
  91       type Buffer_Access is access Buffer_Type;
  92       function To_BA is new Unchecked_Conversion (voids, Buffer_Access);
  93       BA : Buffer_Access := To_BA (buffer);
  94       Ch : int;
  95    begin
  96
  97       --  This Fread goes with the Fwrite below.
  98       --  The C library fread sometimes can't read fputc generated files.
  99
 100       for C in 1 + index .. count + index loop
 101          for S in 1 .. size loop
 102             Ch := fgetc (stream);
 103             if Ch = EOF then
 104                return 0;
 105             end if;
 106             BA.all (C, S) := Character'Val (Ch);
 107          end loop;
 108          Get_Count := Get_Count + 1;
 109       end loop;
 110       return Get_Count;
 111    end fread;
 112
 113    ------------
 114    -- fwrite --
 115    ------------
 116
 117    function fwrite
 118      (buffer : voids;
 119       size   : size_t;
 120       count  : size_t;
 121       stream : FILEs)
 122       return   size_t
 123    is
 124       Put_Count : size_t := 0;
 125       type Buffer_Type is array (size_t range 1 .. count,
 126                                  size_t range 1 .. size) of Character;
 127       type Buffer_Access is access Buffer_Type;
 128       function To_BA is new Unchecked_Conversion (voids, Buffer_Access);
 129       BA : Buffer_Access := To_BA (buffer);
 130    begin
 131
 132       --  Fwrite on VMS has the undesirable effect of always generating at
 133       --  least one record of output per call, regardless of buffering.  To
 134       --  get around this, we do multiple fputc calls instead.
 135
 136       for C in 1 .. count loop
 137          for S in 1 .. size loop
 138             if fputc (Character'Pos (BA.all (C, S)), stream) = EOF then
 139                exit;
 140             end if;
 141          end loop;
 142          Put_Count := Put_Count + 1;
 143       end loop;
 144       return Put_Count;
 145    end fwrite;
 146
 147    -------------
 148    -- setvbuf --
 149    -------------
 150
 151    function setvbuf
 152      (stream : FILEs;
 153       buffer : chars;
 154       mode   : int;
 155       size   : size_t)
 156       return   int
 157    is
 158       function C_setvbuf
 159         (stream : FILEs;
 160          buffer : chars;
 161          mode   : int;
 162          size   : size_t)
 163          return   int;
 164       pragma Import (C, C_setvbuf, "setvbuf");
 165
 166       use type System.Address;
 167    begin
 168
 169       --  In order for the above fwrite hack to work, we must always buffer
 170       --  stdout and stderr. Is_regular_file on VMS cannot detect when
 171       --  these are redirected to a file, so checking for that condition
 172       --  doesn't help.
 173
 174       if mode = IONBF
 175         and then (stream = stdout or else stream = stderr)
 176       then
 177          return C_setvbuf (stream, buffer, IOLBF, size);
 178       else
 179          return C_setvbuf (stream, buffer, mode, size);
 180       end if;
 181    end setvbuf;
 182
 183 end Interfaces.C_Streams;