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 --                                                                          --
  10 --          Copyright (C) 1992-2001 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 with Interfaces.C.Strings; use Interfaces.C.Strings;
  36 with System;               use System;
  37
  38 with Unchecked_Conversion;
  39
  40 package body Interfaces.C.Pointers is
  41
  42    type Addr is mod Memory_Size;
  43
  44    function To_Pointer is new Unchecked_Conversion (Addr,      Pointer);
  45    function To_Addr    is new Unchecked_Conversion (Pointer,   Addr);
  46    function To_Addr    is new Unchecked_Conversion (ptrdiff_t, Addr);
  47    function To_Ptrdiff is new Unchecked_Conversion (Addr,      ptrdiff_t);
  48
  49    Elmt_Size : constant ptrdiff_t :=
  50                  (Element_Array'Component_Size
  51                    + Storage_Unit - 1) / Storage_Unit;
  52
  53    subtype Index_Base is Index'Base;
  54
  55    ---------
  56    -- "+" --
  57    ---------
  58
  59    function "+" (Left : in Pointer;   Right : in ptrdiff_t) return Pointer is
  60    begin
  61       if Left = null then
  62          raise Pointer_Error;
  63       end if;
  64
  65       return To_Pointer (To_Addr (Left) + To_Addr (Elmt_Size * Right));
  66    end "+";
  67
  68    function "+" (Left : in ptrdiff_t; Right : in Pointer) return Pointer is
  69    begin
  70       if Right = null then
  71          raise Pointer_Error;
  72       end if;
  73
  74       return To_Pointer (To_Addr (Elmt_Size * Left) + To_Addr (Right));
  75    end "+";
  76
  77    ---------
  78    -- "-" --
  79    ---------
  80
  81    function "-" (Left : in Pointer; Right : in ptrdiff_t) return Pointer is
  82    begin
  83       if Left = null then
  84          raise Pointer_Error;
  85       end if;
  86
  87       return To_Pointer (To_Addr (Left) - To_Addr (Right * Elmt_Size));
  88    end "-";
  89
  90    function "-" (Left : in Pointer; Right : in Pointer) return ptrdiff_t is
  91    begin
  92       if Left = null or else Right = null then
  93          raise Pointer_Error;
  94       end if;
  95
  96       return To_Ptrdiff (To_Addr (Left) - To_Addr (Right)) / Elmt_Size;
  97    end "-";
  98
  99    ----------------
 100    -- Copy_Array --
 101    ----------------
 102
 103    procedure Copy_Array
 104      (Source  : in Pointer;
 105       Target  : in Pointer;
 106       Length  : in ptrdiff_t)
 107    is
 108       T : Pointer := Target;
 109       S : Pointer := Source;
 110
 111    begin
 112       if S = null or else T = null then
 113          raise Dereference_Error;
 114
 115       else
 116          for J in 1 .. Length loop
 117             T.all := S.all;
 118             Increment (T);
 119             Increment (S);
 120          end loop;
 121       end if;
 122    end Copy_Array;
 123
 124    ---------------------------
 125    -- Copy_Terminated_Array --
 126    ---------------------------
 127
 128    procedure Copy_Terminated_Array
 129      (Source     : in Pointer;
 130       Target     : in Pointer;
 131       Limit      : in ptrdiff_t := ptrdiff_t'Last;
 132       Terminator : in Element := Default_Terminator)
 133    is
 134       S : Pointer   := Source;
 135       T : Pointer   := Target;
 136       L : ptrdiff_t := Limit;
 137
 138    begin
 139       if S = null or else T = null then
 140          raise Dereference_Error;
 141
 142       else
 143          while L > 0 loop
 144             T.all := S.all;
 145             exit when T.all = Terminator;
 146             Increment (T);
 147             Increment (S);
 148             L := L - 1;
 149          end loop;
 150       end if;
 151    end Copy_Terminated_Array;
 152
 153    ---------------
 154    -- Decrement --
 155    ---------------
 156
 157    procedure Decrement (Ref : in out Pointer) is
 158    begin
 159       Ref := Ref - 1;
 160    end Decrement;
 161
 162    ---------------
 163    -- Increment --
 164    ---------------
 165
 166    procedure Increment (Ref : in out Pointer) is
 167    begin
 168       Ref := Ref + 1;
 169    end Increment;
 170
 171    -----------
 172    -- Value --
 173    -----------
 174
 175    function Value
 176      (Ref        : in Pointer;
 177       Terminator : in Element := Default_Terminator)
 178       return       Element_Array
 179    is
 180       P : Pointer;
 181       L : constant Index_Base := Index'First;
 182       H : Index_Base;
 183
 184    begin
 185       if Ref = null then
 186          raise Dereference_Error;
 187
 188       else
 189          H := L;
 190          P := Ref;
 191
 192          loop
 193             exit when P.all = Terminator;
 194             H := Index_Base'Succ (H);
 195             Increment (P);
 196          end loop;
 197
 198          declare
 199             subtype A is Element_Array (L .. H);
 200
 201             type PA is access A;
 202             function To_PA is new Unchecked_Conversion (Pointer, PA);
 203
 204          begin
 205             return To_PA (Ref).all;
 206          end;
 207       end if;
 208    end Value;
 209
 210    function Value
 211      (Ref    : in Pointer;
 212       Length : in ptrdiff_t)
 213       return   Element_Array
 214    is
 215       L : Index_Base;
 216       H : Index_Base;
 217
 218    begin
 219       if Ref = null then
 220          raise Dereference_Error;
 221
 222       --  For length zero, we need to return a null slice, but we can't make
 223       --  the bounds of this slice Index'First, since this could cause a
 224       --  Constraint_Error if Index'First = Index'Base'First.
 225
 226       elsif Length <= 0 then
 227          declare
 228             pragma Warnings (Off); -- kill warnings since X not assigned
 229             X : Element_Array (Index'Succ (Index'First) .. Index'First);
 230             pragma Warnings (On);
 231
 232          begin
 233             return X;
 234          end;
 235
 236       --  Normal case (length non-zero)
 237
 238       else
 239          L := Index'First;
 240          H := Index'Val (Index'Pos (Index'First) + Length - 1);
 241
 242          declare
 243             subtype A is Element_Array (L .. H);
 244
 245             type PA is access A;
 246             function To_PA is new Unchecked_Conversion (Pointer, PA);
 247
 248          begin
 249             return To_PA (Ref).all;
 250          end;
 251       end if;
 252    end Value;
 253
 254    --------------------
 255    -- Virtual_Length --
 256    --------------------
 257
 258    function Virtual_Length
 259      (Ref        : in Pointer;
 260       Terminator : in Element := Default_Terminator)
 261       return       ptrdiff_t
 262    is
 263       P : Pointer;
 264       C : ptrdiff_t;
 265
 266    begin
 267       if Ref = null then
 268          raise Dereference_Error;
 269
 270       else
 271          C := 0;
 272          P := Ref;
 273
 274          while P.all /= Terminator loop
 275             C := C + 1;
 276             Increment (P);
 277          end loop;
 278
 279          return C;
 280       end if;
 281    end Virtual_Length;
 282
 283 end Interfaces.C.Pointers;