gcc/ada/i-cpoint.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                I N T E R F A C E S . C . P O I N T E R S                 --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --                            $Revision: 1.15 $
  10 --                                                                          --
  11 --          Copyright (C) 1992-2001 Free Software Foundation, Inc.          --
  12 --                                                                          --
  13 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  14 -- terms of the  GNU General Public License as published  by the Free Soft- --
  15 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  17 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  19 -- for  more details.  You should have  received  a copy of the GNU General --
  20 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  21 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  22 -- MA 02111-1307, USA.                                                      --
  23 --                                                                          --
  24 -- As a special exception,  if other files  instantiate  generics from this --
  25 -- unit, or you link  this unit with other files  to produce an executable, --
  26 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  27 -- covered  by the  GNU  General  Public  License.  This exception does not --
  28 -- however invalidate  any other reasons why  the executable file  might be --
  29 -- covered by the  GNU Public License.                                      --
  30 --                                                                          --
  31 -- GNAT was originally developed  by the GNAT team at  New York University. --
  32 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
  33 --                                                                          --
  34 ------------------------------------------------------------------------------
  35
  36 with Interfaces.C.Strings; use Interfaces.C.Strings;
  37 with System;               use System;
  38
  39 with Unchecked_Conversion;
  40
  41 package body Interfaces.C.Pointers is
  42
  43    type Addr is mod Memory_Size;
  44
  45    function To_Pointer is new Unchecked_Conversion (Addr,      Pointer);
  46    function To_Addr    is new Unchecked_Conversion (Pointer,   Addr);
  47    function To_Addr    is new Unchecked_Conversion (ptrdiff_t, Addr);
  48    function To_Ptrdiff is new Unchecked_Conversion (Addr,      ptrdiff_t);
  49
  50    Elmt_Size : constant ptrdiff_t :=
  51                  (Element_Array'Component_Size
  52                    + Storage_Unit - 1) / Storage_Unit;
  53
  54    subtype Index_Base is Index'Base;
  55
  56    ---------
  57    -- "+" --
  58    ---------
  59
  60    function "+" (Left : in Pointer;   Right : in ptrdiff_t) return Pointer is
  61    begin
  62       if Left = null then
  63          raise Pointer_Error;
  64       end if;
  65
  66       return To_Pointer (To_Addr (Left) + To_Addr (Elmt_Size * Right));
  67    end "+";
  68
  69    function "+" (Left : in ptrdiff_t; Right : in Pointer) return Pointer is
  70    begin
  71       if Right = null then
  72          raise Pointer_Error;
  73       end if;
  74
  75       return To_Pointer (To_Addr (Elmt_Size * Left) + To_Addr (Right));
  76    end "+";
  77
  78    ---------
  79    -- "-" --
  80    ---------
  81
  82    function "-" (Left : in Pointer; Right : in ptrdiff_t) return Pointer is
  83    begin
  84       if Left = null then
  85          raise Pointer_Error;
  86       end if;
  87
  88       return To_Pointer (To_Addr (Left) - To_Addr (Right * Elmt_Size));
  89    end "-";
  90
  91    function "-" (Left : in Pointer; Right : in Pointer) return ptrdiff_t is
  92    begin
  93       if Left = null or else Right = null then
  94          raise Pointer_Error;
  95       end if;
  96
  97       return To_Ptrdiff (To_Addr (Left) - To_Addr (Right)) / Elmt_Size;
  98    end "-";
  99
 100    ----------------
 101    -- Copy_Array --
 102    ----------------
 103
 104    procedure Copy_Array
 105      (Source  : in Pointer;
 106       Target  : in Pointer;
 107       Length  : in ptrdiff_t)
 108    is
 109       T : Pointer := Target;
 110       S : Pointer := Source;
 111
 112    begin
 113       if S = null or else T = null then
 114          raise Dereference_Error;
 115
 116       else
 117          for J in 1 .. Length loop
 118             T.all := S.all;
 119             Increment (T);
 120             Increment (S);
 121          end loop;
 122       end if;
 123    end Copy_Array;
 124
 125    ---------------------------
 126    -- Copy_Terminated_Array --
 127    ---------------------------
 128
 129    procedure Copy_Terminated_Array
 130      (Source     : in Pointer;
 131       Target     : in Pointer;
 132       Limit      : in ptrdiff_t := ptrdiff_t'Last;
 133       Terminator : in Element := Default_Terminator)
 134    is
 135       S : Pointer   := Source;
 136       T : Pointer   := Target;
 137       L : ptrdiff_t := Limit;
 138
 139    begin
 140       if S = null or else T = null then
 141          raise Dereference_Error;
 142
 143       else
 144          while L > 0 loop
 145             T.all := S.all;
 146             exit when T.all = Terminator;
 147             Increment (T);
 148             Increment (S);
 149             L := L - 1;
 150          end loop;
 151       end if;
 152    end Copy_Terminated_Array;
 153
 154    ---------------
 155    -- Decrement --
 156    ---------------
 157
 158    procedure Decrement (Ref : in out Pointer) is
 159    begin
 160       Ref := Ref - 1;
 161    end Decrement;
 162
 163    ---------------
 164    -- Increment --
 165    ---------------
 166
 167    procedure Increment (Ref : in out Pointer) is
 168    begin
 169       Ref := Ref + 1;
 170    end Increment;
 171
 172    -----------
 173    -- Value --
 174    -----------
 175
 176    function Value
 177      (Ref        : in Pointer;
 178       Terminator : in Element := Default_Terminator)
 179       return       Element_Array
 180    is
 181       P : Pointer;
 182       L : constant Index_Base := Index'First;
 183       H : Index_Base;
 184
 185    begin
 186       if Ref = null then
 187          raise Dereference_Error;
 188
 189       else
 190          H := L;
 191          P := Ref;
 192
 193          loop
 194             exit when P.all = Terminator;
 195             H := Index_Base'Succ (H);
 196             Increment (P);
 197          end loop;
 198
 199          declare
 200             subtype A is Element_Array (L .. H);
 201
 202             type PA is access A;
 203             function To_PA is new Unchecked_Conversion (Pointer, PA);
 204
 205          begin
 206             return To_PA (Ref).all;
 207          end;
 208       end if;
 209    end Value;
 210
 211    function Value
 212      (Ref    : in Pointer;
 213       Length : in ptrdiff_t)
 214       return   Element_Array
 215    is
 216       L : Index_Base;
 217       H : Index_Base;
 218
 219    begin
 220       if Ref = null then
 221          raise Dereference_Error;
 222
 223       --  For length zero, we need to return a null slice, but we can't make
 224       --  the bounds of this slice Index'First, since this could cause a
 225       --  Constraint_Error if Index'First = Index'Base'First.
 226
 227       elsif Length <= 0 then
 228          declare
 229             pragma Warnings (Off); -- kill warnings since X not assigned
 230             X : Element_Array (Index'Succ (Index'First) .. Index'First);
 231             pragma Warnings (On);
 232
 233          begin
 234             return X;
 235          end;
 236
 237       --  Normal case (length non-zero)
 238
 239       else
 240          L := Index'First;
 241          H := Index'Val (Index'Pos (Index'First) + Length - 1);
 242
 243          declare
 244             subtype A is Element_Array (L .. H);
 245
 246             type PA is access A;
 247             function To_PA is new Unchecked_Conversion (Pointer, PA);
 248
 249          begin
 250             return To_PA (Ref).all;
 251          end;
 252       end if;
 253    end Value;
 254
 255    --------------------
 256    -- Virtual_Length --
 257    --------------------
 258
 259    function Virtual_Length
 260      (Ref        : in Pointer;
 261       Terminator : in Element := Default_Terminator)
 262       return       ptrdiff_t
 263    is
 264       P : Pointer;
 265       C : ptrdiff_t;
 266
 267    begin
 268       if Ref = null then
 269          raise Dereference_Error;
 270
 271       else
 272          C := 0;
 273          P := Ref;
 274
 275          while P.all /= Terminator loop
 276             C := C + 1;
 277             Increment (P);
 278          end loop;
 279
 280          return C;
 281       end if;
 282    end Virtual_Length;
 283
 284 end Interfaces.C.Pointers;