1 ------------------------------------------------------------------------------
3 -- GNAT RUNTIME COMPONENTS --
9 -- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
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 2, 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. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, USA. --
22 -- As a special exception, if other files instantiate generics from this --
23 -- unit, or you link this unit with other files to produce an executable, --
24 -- this unit does not by itself cause the resulting executable to be --
25 -- covered by the GNU General Public License. This exception does not --
26 -- however invalidate any other reasons why the executable file might be --
27 -- covered by the GNU Public License. --
29 -- GNAT was originally developed by the GNAT team at New York University. --
30 -- Extensive contributions were provided by Ada Core Technologies Inc. --
32 ------------------------------------------------------------------------------
38 with Unchecked_Conversion;
40 pragma Elaborate_All (System.HTable);
42 package body Ada.Tags is
44 -- Structure of the GNAT Dispatch Table
46 -- +----------------------+
47 -- | TSD pointer ---|-----> Type Specific Data
48 -- +----------------------+ +-------------------+
49 -- | table of | | inheritance depth |
50 -- : primitive ops : +-------------------+
51 -- | pointers | | expanded name |
52 -- +----------------------+ +-------------------+
54 -- +-------------------+
55 -- | Hash table link |
56 -- +-------------------+
57 -- | Remotely Callable |
58 -- +-------------------+
59 -- | Rec Ctrler offset |
60 -- +-------------------+
64 -- +-------------------+
66 subtype Cstring is String (Positive);
67 type Cstring_Ptr is access all Cstring;
69 type Tag_Table is array (Natural range <>) of Tag;
70 pragma Suppress_Initialization (Tag_Table);
71 pragma Suppress (Index_Check, On => Tag_Table);
72 -- We suppress index checks because the declared size in the record
73 -- below is a dummy size of one (see below).
75 type Wide_Boolean is new Boolean;
76 -- This name should probably be changed sometime ??? and indeed
77 -- probably this field could simply be of type Standard.Boolean.
79 type Type_Specific_Data is record
81 Expanded_Name : Cstring_Ptr;
82 External_Tag : Cstring_Ptr;
84 Remotely_Callable : Wide_Boolean;
85 RC_Offset : SSE.Storage_Offset;
86 Ancestor_Tags : Tag_Table (0 .. 1);
88 -- The size of the Ancestor_Tags array actually depends on the tagged
89 -- type to which it applies. We are using the same mechanism as for
90 -- the Prims_Ptr array in the Dispatch_Table record. See comments
91 -- below for more details.
93 type Dispatch_Table is record
94 TSD : Type_Specific_Data_Ptr;
95 Prims_Ptr : Address_Array (1 .. 1);
97 -- The size of the Prims_Ptr array actually depends on the tagged
98 -- type to which it applies. For each tagged type, the expander
99 -- computes the actual array size, and allocates the Dispatch_Table
100 -- record accordingly.
102 -- To avoid the use of discriminants to define the actual size
103 -- of the dispatch table, we used to declare the tag as a pointer
104 -- to a record that contains an arbitrary array of addresses, using
105 -- Positive as its index. This ensures that there are never range
106 -- checks when accessing the dispatch table, but it prevents GDB
107 -- from displaying tagged types properly. A better approach is
108 -- to declare this record type as holding a small number of addresses,
109 -- and to explicitly suppress checks on it.
111 -- Note that in both cases, this type is never allocated, and serves
112 -- only to declare the corresponding access type.
114 ---------------------------------------------
115 -- Unchecked Conversions for String Fields --
116 ---------------------------------------------
118 function To_Cstring_Ptr is
119 new Unchecked_Conversion (System.Address, Cstring_Ptr);
121 function To_Address is
122 new Unchecked_Conversion (Cstring_Ptr, System.Address);
124 -----------------------
125 -- Local Subprograms --
126 -----------------------
128 function Length (Str : Cstring_Ptr) return Natural;
129 -- Length of string represented by the given pointer (treating the
130 -- string as a C-style string, which is Nul terminated).
132 -------------------------
133 -- External_Tag_HTable --
134 -------------------------
136 type HTable_Headers is range 1 .. 64;
138 -- The following internal package defines the routines used for
139 -- the instantiation of a new System.HTable.Static_HTable (see
140 -- below). See spec in g-htable.ads for details of usage.
142 package HTable_Subprograms is
143 procedure Set_HT_Link (T : Tag; Next : Tag);
144 function Get_HT_Link (T : Tag) return Tag;
145 function Hash (F : System.Address) return HTable_Headers;
146 function Equal (A, B : System.Address) return Boolean;
147 end HTable_Subprograms;
149 package External_Tag_HTable is new System.HTable.Static_HTable (
150 Header_Num => HTable_Headers,
151 Element => Dispatch_Table,
154 Set_Next => HTable_Subprograms.Set_HT_Link,
155 Next => HTable_Subprograms.Get_HT_Link,
156 Key => System.Address,
157 Get_Key => Get_External_Tag,
158 Hash => HTable_Subprograms.Hash,
159 Equal => HTable_Subprograms.Equal);
161 ------------------------
162 -- HTable_Subprograms --
163 ------------------------
165 -- Bodies of routines for hash table instantiation
167 package body HTable_Subprograms is
173 function Equal (A, B : System.Address) return Boolean is
174 Str1 : constant Cstring_Ptr := To_Cstring_Ptr (A);
175 Str2 : constant Cstring_Ptr := To_Cstring_Ptr (B);
180 if Str1 (J) /= Str2 (J) then
183 elsif Str1 (J) = ASCII.NUL then
196 function Get_HT_Link (T : Tag) return Tag is
198 return T.TSD.HT_Link;
205 function Hash (F : System.Address) return HTable_Headers is
206 function H is new System.HTable.Hash (HTable_Headers);
207 Str : constant Cstring_Ptr := To_Cstring_Ptr (F);
208 Res : constant HTable_Headers := H (Str (1 .. Length (Str)));
217 procedure Set_HT_Link (T : Tag; Next : Tag) is
219 T.TSD.HT_Link := Next;
222 end HTable_Subprograms;
228 -- Canonical implementation of Classwide Membership corresponding to:
232 -- Each dispatch table contains a reference to a table of ancestors
233 -- (Ancestor_Tags) and a count of the level of inheritance "Idepth" .
235 -- Obj is in Typ'Class if Typ'Tag is in the table of ancestors that are
236 -- contained in the dispatch table referenced by Obj'Tag . Knowing the
237 -- level of inheritance of both types, this can be computed in constant
238 -- time by the formula:
240 -- Obj'tag.TSD.Ancestor_Tags (Obj'tag.TSD.Idepth - Typ'tag.TSD.Idepth)
243 function CW_Membership (Obj_Tag : Tag; Typ_Tag : Tag) return Boolean is
244 Pos : constant Integer := Obj_Tag.TSD.Idepth - Typ_Tag.TSD.Idepth;
246 return Pos >= 0 and then Obj_Tag.TSD.Ancestor_Tags (Pos) = Typ_Tag;
253 function Expanded_Name (T : Tag) return String is
254 Result : constant Cstring_Ptr := T.TSD.Expanded_Name;
256 return Result (1 .. Length (Result));
263 function External_Tag (T : Tag) return String is
264 Result : constant Cstring_Ptr := T.TSD.External_Tag;
266 return Result (1 .. Length (Result));
269 -----------------------
270 -- Get_Expanded_Name --
271 -----------------------
273 function Get_Expanded_Name (T : Tag) return System.Address is
275 return To_Address (T.TSD.Expanded_Name);
276 end Get_Expanded_Name;
278 ----------------------
279 -- Get_External_Tag --
280 ----------------------
282 function Get_External_Tag (T : Tag) return System.Address is
284 return To_Address (T.TSD.External_Tag);
285 end Get_External_Tag;
287 ---------------------------
288 -- Get_Inheritance_Depth --
289 ---------------------------
291 function Get_Inheritance_Depth (T : Tag) return Natural is
294 end Get_Inheritance_Depth;
296 -------------------------
297 -- Get_Prim_Op_Address --
298 -------------------------
300 function Get_Prim_Op_Address
302 Position : Positive) return System.Address
305 return T.Prims_Ptr (Position);
306 end Get_Prim_Op_Address;
312 function Get_RC_Offset (T : Tag) return SSE.Storage_Offset is
314 return T.TSD.RC_Offset;
317 ---------------------------
318 -- Get_Remotely_Callable --
319 ---------------------------
321 function Get_Remotely_Callable (T : Tag) return Boolean is
323 return T.TSD.Remotely_Callable = True;
324 end Get_Remotely_Callable;
330 function Get_TSD (T : Tag) return System.Address is
332 return To_Address (T.TSD);
342 Entry_Count : Natural)
345 if Old_T /= null then
346 New_T.Prims_Ptr (1 .. Entry_Count) :=
347 Old_T.Prims_Ptr (1 .. Entry_Count);
355 procedure Inherit_TSD (Old_TSD : System.Address; New_Tag : Tag) is
356 TSD : constant Type_Specific_Data_Ptr :=
357 To_Type_Specific_Data_Ptr (Old_TSD);
358 New_TSD : Type_Specific_Data renames New_Tag.TSD.all;
362 New_TSD.Idepth := TSD.Idepth + 1;
363 New_TSD.Ancestor_Tags (1 .. New_TSD.Idepth)
364 := TSD.Ancestor_Tags (0 .. TSD.Idepth);
369 New_TSD.Ancestor_Tags (0) := New_Tag;
376 function Internal_Tag (External : String) return Tag is
377 Ext_Copy : aliased String (External'First .. External'Last + 1);
381 -- Make a copy of the string representing the external tag with
384 Ext_Copy (External'Range) := External;
385 Ext_Copy (Ext_Copy'Last) := ASCII.NUL;
386 Res := External_Tag_HTable.Get (Ext_Copy'Address);
390 Msg1 : constant String := "unknown tagged type: ";
391 Msg2 : String (1 .. Msg1'Length + External'Length);
394 Msg2 (1 .. Msg1'Length) := Msg1;
395 Msg2 (Msg1'Length + 1 .. Msg1'Length + External'Length) :=
397 Ada.Exceptions.Raise_Exception (Tag_Error'Identity, Msg2);
408 function Length (Str : Cstring_Ptr) return Natural is
412 while Str (Len) /= ASCII.Nul loop
424 is access function (A : System.Address) return Long_Long_Integer;
426 function To_Acc_Size is new Unchecked_Conversion (System.Address, Acc_Size);
427 -- The profile of the implicitly defined _size primitive
430 (Obj : System.Address;
431 T : Tag) return SSE.Storage_Count
433 Parent_Tag : constant Tag := T.TSD.Ancestor_Tags (1);
434 -- The tag of the parent type through the dispatch table
436 F : constant Acc_Size := To_Acc_Size (Parent_Tag.Prims_Ptr (1));
437 -- Access to the _size primitive of the parent. We assume that
438 -- it is always in the first slot of the distatch table
441 -- Here we compute the size of the _parent field of the object
443 return SSE.Storage_Count (F.all (Obj));
450 function Parent_Tag (T : Tag) return Tag is
452 return T.TSD.Ancestor_Tags (1);
459 procedure Register_Tag (T : Tag) is
461 External_Tag_HTable.Set (T);
464 -----------------------
465 -- Set_Expanded_Name --
466 -----------------------
468 procedure Set_Expanded_Name (T : Tag; Value : System.Address) is
470 T.TSD.Expanded_Name := To_Cstring_Ptr (Value);
471 end Set_Expanded_Name;
473 ----------------------
474 -- Set_External_Tag --
475 ----------------------
477 procedure Set_External_Tag (T : Tag; Value : System.Address) is
479 T.TSD.External_Tag := To_Cstring_Ptr (Value);
480 end Set_External_Tag;
482 ---------------------------
483 -- Set_Inheritance_Depth --
484 ---------------------------
486 procedure Set_Inheritance_Depth
491 T.TSD.Idepth := Value;
492 end Set_Inheritance_Depth;
494 -------------------------
495 -- Set_Prim_Op_Address --
496 -------------------------
498 procedure Set_Prim_Op_Address
501 Value : System.Address)
504 T.Prims_Ptr (Position) := Value;
505 end Set_Prim_Op_Address;
511 procedure Set_RC_Offset (T : Tag; Value : SSE.Storage_Offset) is
513 T.TSD.RC_Offset := Value;
516 ---------------------------
517 -- Set_Remotely_Callable --
518 ---------------------------
520 procedure Set_Remotely_Callable (T : Tag; Value : Boolean) is
523 T.TSD.Remotely_Callable := True;
525 T.TSD.Remotely_Callable := False;
527 end Set_Remotely_Callable;
533 procedure Set_TSD (T : Tag; Value : System.Address) is
535 T.TSD := To_Type_Specific_Data_Ptr (Value);