OpenCores
URL https://opencores.org/ocsvn/openrisc_me/openrisc_me/trunk

Subversion Repositories openrisc_me

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [ada/] [i-cpoint.adb] - Blame information for rev 414

Go to most recent revision | Details | Compare with Previous | View Log

Line No. Rev Author Line
1 281 jeremybenn
------------------------------------------------------------------------------
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
--          Copyright (C) 1992-2009, 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 3,  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.                                     --
17
--                                                                          --
18
-- As a special exception under Section 7 of GPL version 3, you are granted --
19
-- additional permissions described in the GCC Runtime Library Exception,   --
20
-- version 3.1, as published by the Free Software Foundation.               --
21
--                                                                          --
22
-- You should have received a copy of the GNU General Public License and    --
23
-- a copy of the GCC Runtime Library Exception along with this program;     --
24
-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
25
-- <http://www.gnu.org/licenses/>.                                          --
26
--                                                                          --
27
-- GNAT was originally developed  by the GNAT team at  New York University. --
28
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
29
--                                                                          --
30
------------------------------------------------------------------------------
31
 
32
with Interfaces.C.Strings; use Interfaces.C.Strings;
33
with System;               use System;
34
 
35
with Ada.Unchecked_Conversion;
36
 
37
package body Interfaces.C.Pointers is
38
 
39
   type Addr is mod Memory_Size;
40
 
41
   function To_Pointer is new Ada.Unchecked_Conversion (Addr,      Pointer);
42
   function To_Addr    is new Ada.Unchecked_Conversion (Pointer,   Addr);
43
   function To_Addr    is new Ada.Unchecked_Conversion (ptrdiff_t, Addr);
44
   function To_Ptrdiff is new Ada.Unchecked_Conversion (Addr,      ptrdiff_t);
45
 
46
   Elmt_Size : constant ptrdiff_t :=
47
                 (Element_Array'Component_Size
48
                   + Storage_Unit - 1) / Storage_Unit;
49
 
50
   subtype Index_Base is Index'Base;
51
 
52
   ---------
53
   -- "+" --
54
   ---------
55
 
56
   function "+" (Left : Pointer; Right : ptrdiff_t) return Pointer is
57
   begin
58
      if Left = null then
59
         raise Pointer_Error;
60
      end if;
61
 
62
      return To_Pointer (To_Addr (Left) + To_Addr (Elmt_Size * Right));
63
   end "+";
64
 
65
   function "+" (Left : ptrdiff_t; Right : Pointer) return Pointer is
66
   begin
67
      if Right = null then
68
         raise Pointer_Error;
69
      end if;
70
 
71
      return To_Pointer (To_Addr (Elmt_Size * Left) + To_Addr (Right));
72
   end "+";
73
 
74
   ---------
75
   -- "-" --
76
   ---------
77
 
78
   function "-" (Left : Pointer; Right : ptrdiff_t) return Pointer is
79
   begin
80
      if Left = null then
81
         raise Pointer_Error;
82
      end if;
83
 
84
      return To_Pointer (To_Addr (Left) - To_Addr (Right * Elmt_Size));
85
   end "-";
86
 
87
   function "-" (Left : Pointer; Right : Pointer) return ptrdiff_t is
88
   begin
89
      if Left = null or else Right = null then
90
         raise Pointer_Error;
91
      end if;
92
 
93
      return To_Ptrdiff (To_Addr (Left) - To_Addr (Right)) / Elmt_Size;
94
   end "-";
95
 
96
   ----------------
97
   -- Copy_Array --
98
   ----------------
99
 
100
   procedure Copy_Array
101
     (Source  : Pointer;
102
      Target  : Pointer;
103
      Length  : ptrdiff_t)
104
   is
105
      T : Pointer := Target;
106
      S : Pointer := Source;
107
 
108
   begin
109
      if S = null or else T = null then
110
         raise Dereference_Error;
111
 
112
      else
113
         for J in 1 .. Length loop
114
            T.all := S.all;
115
            Increment (T);
116
            Increment (S);
117
         end loop;
118
      end if;
119
   end Copy_Array;
120
 
121
   ---------------------------
122
   -- Copy_Terminated_Array --
123
   ---------------------------
124
 
125
   procedure Copy_Terminated_Array
126
     (Source     : Pointer;
127
      Target     : Pointer;
128
      Limit      : ptrdiff_t := ptrdiff_t'Last;
129
      Terminator : Element := Default_Terminator)
130
   is
131
      S : Pointer   := Source;
132
      T : Pointer   := Target;
133
      L : ptrdiff_t := Limit;
134
 
135
   begin
136
      if S = null or else T = null then
137
         raise Dereference_Error;
138
 
139
      else
140
         while L > 0 loop
141
            T.all := S.all;
142
            exit when T.all = Terminator;
143
            Increment (T);
144
            Increment (S);
145
            L := L - 1;
146
         end loop;
147
      end if;
148
   end Copy_Terminated_Array;
149
 
150
   ---------------
151
   -- Decrement --
152
   ---------------
153
 
154
   procedure Decrement (Ref : in out Pointer) is
155
   begin
156
      Ref := Ref - 1;
157
   end Decrement;
158
 
159
   ---------------
160
   -- Increment --
161
   ---------------
162
 
163
   procedure Increment (Ref : in out Pointer) is
164
   begin
165
      Ref := Ref + 1;
166
   end Increment;
167
 
168
   -----------
169
   -- Value --
170
   -----------
171
 
172
   function Value
173
     (Ref        : Pointer;
174
      Terminator : Element := Default_Terminator) return Element_Array
175
   is
176
      P : Pointer;
177
      L : constant Index_Base := Index'First;
178
      H : Index_Base;
179
 
180
   begin
181
      if Ref = null then
182
         raise Dereference_Error;
183
 
184
      else
185
         H := L;
186
         P := Ref;
187
 
188
         loop
189
            exit when P.all = Terminator;
190
            H := Index_Base'Succ (H);
191
            Increment (P);
192
         end loop;
193
 
194
         declare
195
            subtype A is Element_Array (L .. H);
196
 
197
            type PA is access A;
198
            function To_PA is new Ada.Unchecked_Conversion (Pointer, PA);
199
 
200
         begin
201
            return To_PA (Ref).all;
202
         end;
203
      end if;
204
   end Value;
205
 
206
   function Value
207
     (Ref    : Pointer;
208
      Length : ptrdiff_t) return Element_Array
209
   is
210
      L : Index_Base;
211
      H : Index_Base;
212
 
213
   begin
214
      if Ref = null then
215
         raise Dereference_Error;
216
 
217
      --  For length zero, we need to return a null slice, but we can't make
218
      --  the bounds of this slice Index'First, since this could cause a
219
      --  Constraint_Error if Index'First = Index'Base'First.
220
 
221
      elsif Length <= 0 then
222
         declare
223
            pragma Warnings (Off); -- kill warnings since X not assigned
224
            X : Element_Array (Index'Succ (Index'First) .. Index'First);
225
            pragma Warnings (On);
226
 
227
         begin
228
            return X;
229
         end;
230
 
231
      --  Normal case (length non-zero)
232
 
233
      else
234
         L := Index'First;
235
         H := Index'Val (Index'Pos (Index'First) + Length - 1);
236
 
237
         declare
238
            subtype A is Element_Array (L .. H);
239
 
240
            type PA is access A;
241
            function To_PA is new Ada.Unchecked_Conversion (Pointer, PA);
242
 
243
         begin
244
            return To_PA (Ref).all;
245
         end;
246
      end if;
247
   end Value;
248
 
249
   --------------------
250
   -- Virtual_Length --
251
   --------------------
252
 
253
   function Virtual_Length
254
     (Ref        : Pointer;
255
      Terminator : Element := Default_Terminator) return ptrdiff_t
256
   is
257
      P : Pointer;
258
      C : ptrdiff_t;
259
 
260
   begin
261
      if Ref = null then
262
         raise Dereference_Error;
263
 
264
      else
265
         C := 0;
266
         P := Ref;
267
 
268
         while P.all /= Terminator loop
269
            C := C + 1;
270
            Increment (P);
271
         end loop;
272
 
273
         return C;
274
      end if;
275
   end Virtual_Length;
276
 
277
end Interfaces.C.Pointers;

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.