diff options
Diffstat (limited to 'gcc/ada/i-cpoint.adb')
| -rw-r--r-- | gcc/ada/i-cpoint.adb | 284 |
1 files changed, 284 insertions, 0 deletions
diff --git a/gcc/ada/i-cpoint.adb b/gcc/ada/i-cpoint.adb new file mode 100644 index 00000000000..7d4cbc8143a --- /dev/null +++ b/gcc/ada/i-cpoint.adb @@ -0,0 +1,284 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- I N T E R F A C E S . C . P O I N T E R S -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.15 $ +-- -- +-- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Interfaces.C.Strings; use Interfaces.C.Strings; +with System; use System; + +with Unchecked_Conversion; + +package body Interfaces.C.Pointers is + + type Addr is mod Memory_Size; + + function To_Pointer is new Unchecked_Conversion (Addr, Pointer); + function To_Addr is new Unchecked_Conversion (Pointer, Addr); + function To_Addr is new Unchecked_Conversion (ptrdiff_t, Addr); + function To_Ptrdiff is new Unchecked_Conversion (Addr, ptrdiff_t); + + Elmt_Size : constant ptrdiff_t := + (Element_Array'Component_Size + + Storage_Unit - 1) / Storage_Unit; + + subtype Index_Base is Index'Base; + + --------- + -- "+" -- + --------- + + function "+" (Left : in Pointer; Right : in ptrdiff_t) return Pointer is + begin + if Left = null then + raise Pointer_Error; + end if; + + return To_Pointer (To_Addr (Left) + To_Addr (Elmt_Size * Right)); + end "+"; + + function "+" (Left : in ptrdiff_t; Right : in Pointer) return Pointer is + begin + if Right = null then + raise Pointer_Error; + end if; + + return To_Pointer (To_Addr (Elmt_Size * Left) + To_Addr (Right)); + end "+"; + + --------- + -- "-" -- + --------- + + function "-" (Left : in Pointer; Right : in ptrdiff_t) return Pointer is + begin + if Left = null then + raise Pointer_Error; + end if; + + return To_Pointer (To_Addr (Left) - To_Addr (Right * Elmt_Size)); + end "-"; + + function "-" (Left : in Pointer; Right : in Pointer) return ptrdiff_t is + begin + if Left = null or else Right = null then + raise Pointer_Error; + end if; + + return To_Ptrdiff (To_Addr (Left) - To_Addr (Right)) / Elmt_Size; + end "-"; + + ---------------- + -- Copy_Array -- + ---------------- + + procedure Copy_Array + (Source : in Pointer; + Target : in Pointer; + Length : in ptrdiff_t) + is + T : Pointer := Target; + S : Pointer := Source; + + begin + if S = null or else T = null then + raise Dereference_Error; + + else + for J in 1 .. Length loop + T.all := S.all; + Increment (T); + Increment (S); + end loop; + end if; + end Copy_Array; + + --------------------------- + -- Copy_Terminated_Array -- + --------------------------- + + procedure Copy_Terminated_Array + (Source : in Pointer; + Target : in Pointer; + Limit : in ptrdiff_t := ptrdiff_t'Last; + Terminator : in Element := Default_Terminator) + is + S : Pointer := Source; + T : Pointer := Target; + L : ptrdiff_t := Limit; + + begin + if S = null or else T = null then + raise Dereference_Error; + + else + while L > 0 loop + T.all := S.all; + exit when T.all = Terminator; + Increment (T); + Increment (S); + L := L - 1; + end loop; + end if; + end Copy_Terminated_Array; + + --------------- + -- Decrement -- + --------------- + + procedure Decrement (Ref : in out Pointer) is + begin + Ref := Ref - 1; + end Decrement; + + --------------- + -- Increment -- + --------------- + + procedure Increment (Ref : in out Pointer) is + begin + Ref := Ref + 1; + end Increment; + + ----------- + -- Value -- + ----------- + + function Value + (Ref : in Pointer; + Terminator : in Element := Default_Terminator) + return Element_Array + is + P : Pointer; + L : constant Index_Base := Index'First; + H : Index_Base; + + begin + if Ref = null then + raise Dereference_Error; + + else + H := L; + P := Ref; + + loop + exit when P.all = Terminator; + H := Index_Base'Succ (H); + Increment (P); + end loop; + + declare + subtype A is Element_Array (L .. H); + + type PA is access A; + function To_PA is new Unchecked_Conversion (Pointer, PA); + + begin + return To_PA (Ref).all; + end; + end if; + end Value; + + function Value + (Ref : in Pointer; + Length : in ptrdiff_t) + return Element_Array + is + L : Index_Base; + H : Index_Base; + + begin + if Ref = null then + raise Dereference_Error; + + -- For length zero, we need to return a null slice, but we can't make + -- the bounds of this slice Index'First, since this could cause a + -- Constraint_Error if Index'First = Index'Base'First. + + elsif Length <= 0 then + declare + pragma Warnings (Off); -- kill warnings since X not assigned + X : Element_Array (Index'Succ (Index'First) .. Index'First); + pragma Warnings (On); + + begin + return X; + end; + + -- Normal case (length non-zero) + + else + L := Index'First; + H := Index'Val (Index'Pos (Index'First) + Length - 1); + + declare + subtype A is Element_Array (L .. H); + + type PA is access A; + function To_PA is new Unchecked_Conversion (Pointer, PA); + + begin + return To_PA (Ref).all; + end; + end if; + end Value; + + -------------------- + -- Virtual_Length -- + -------------------- + + function Virtual_Length + (Ref : in Pointer; + Terminator : in Element := Default_Terminator) + return ptrdiff_t + is + P : Pointer; + C : ptrdiff_t; + + begin + if Ref = null then + raise Dereference_Error; + + else + C := 0; + P := Ref; + + while P.all /= Terminator loop + C := C + 1; + Increment (P); + end loop; + + return C; + end if; + end Virtual_Length; + +end Interfaces.C.Pointers; |