1 ------------------------------------------------------------------------------
3 -- GNAT RUNTIME COMPONENTS --
10 -- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
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. --
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. --
30 -- GNAT was originally developed by the GNAT team at New York University. --
31 -- Extensive contributions were provided by Ada Core Technologies Inc. --
33 ------------------------------------------------------------------------------
36 with Unchecked_Conversion
;
39 pragma Elaborate_All
(GNAT
.HTable
);
41 package body Ada
.Tags
is
43 -- Structure of the GNAT Dispatch Table
45 -- +----------------------+
46 -- | TSD pointer ---|-----> Type Specific Data
47 -- +----------------------+ +-------------------+
48 -- | table of | | inheritance depth |
49 -- : primitive ops : +-------------------+
50 -- | pointers | | expanded name |
51 -- +----------------------+ +-------------------+
53 -- +-------------------+
54 -- | Hash table link |
55 -- +-------------------+
56 -- | Remotely Callable |
57 -- +-------------------+
58 -- | Rec Ctrler offset |
59 -- +-------------------+
63 -- +-------------------+
65 subtype Cstring
is String (Positive);
66 type Cstring_Ptr
is access all Cstring
;
67 type Tag_Table
is array (Natural range <>) of Tag
;
68 pragma Suppress_Initialization
(Tag_Table
);
70 type Wide_Boolean
is (False, True);
71 for Wide_Boolean
'Size use Standard
'Address_Size;
73 type Type_Specific_Data
is record
75 Expanded_Name
: Cstring_Ptr
;
76 External_Tag
: Cstring_Ptr
;
78 Remotely_Callable
: Wide_Boolean
;
79 RC_Offset
: SSE
.Storage_Offset
;
80 Ancestor_Tags
: Tag_Table
(Natural);
83 type Dispatch_Table
is record
84 TSD
: Type_Specific_Data_Ptr
;
85 Prims_Ptr
: Address_Array
(Positive);
88 -------------------------------------------
89 -- Unchecked Conversions for Tag and TSD --
90 -------------------------------------------
92 function To_Type_Specific_Data_Ptr
is
93 new Unchecked_Conversion
(S
.Address
, Type_Specific_Data_Ptr
);
95 function To_Address
is
96 new Unchecked_Conversion
(Type_Specific_Data_Ptr
, S
.Address
);
98 ---------------------------------------------
99 -- Unchecked Conversions for String Fields --
100 ---------------------------------------------
102 function To_Cstring_Ptr
is
103 new Unchecked_Conversion
(S
.Address
, Cstring_Ptr
);
105 function To_Address
is
106 new Unchecked_Conversion
(Cstring_Ptr
, S
.Address
);
108 -----------------------
109 -- Local Subprograms --
110 -----------------------
112 function Length
(Str
: Cstring_Ptr
) return Natural;
113 -- Length of string represented by the given pointer (treating the
114 -- string as a C-style string, which is Nul terminated).
116 -------------------------
117 -- External_Tag_HTable --
118 -------------------------
120 type HTable_Headers
is range 1 .. 64;
122 -- The following internal package defines the routines used for
123 -- the instantiation of a new GNAT.HTable.Static_HTable (see
124 -- below). See spec in g-htable.ads for details of usage.
126 package HTable_Subprograms
is
127 procedure Set_HT_Link
(T
: Tag
; Next
: Tag
);
128 function Get_HT_Link
(T
: Tag
) return Tag
;
129 function Hash
(F
: S
.Address
) return HTable_Headers
;
130 function Equal
(A
, B
: S
.Address
) return Boolean;
131 end HTable_Subprograms
;
133 package External_Tag_HTable
is new GNAT
.HTable
.Static_HTable
(
134 Header_Num
=> HTable_Headers
,
135 Element
=> Dispatch_Table
,
138 Set_Next
=> HTable_Subprograms
.Set_HT_Link
,
139 Next
=> HTable_Subprograms
.Get_HT_Link
,
141 Get_Key
=> Get_External_Tag
,
142 Hash
=> HTable_Subprograms
.Hash
,
143 Equal
=> HTable_Subprograms
.Equal
);
145 ------------------------
146 -- HTable_Subprograms --
147 ------------------------
149 -- Bodies of routines for hash table instantiation
151 package body HTable_Subprograms
is
157 function Equal
(A
, B
: S
.Address
) return Boolean is
158 Str1
: Cstring_Ptr
:= To_Cstring_Ptr
(A
);
159 Str2
: Cstring_Ptr
:= To_Cstring_Ptr
(B
);
164 if Str1
(J
) /= Str2
(J
) then
167 elsif Str1
(J
) = ASCII
.NUL
then
180 function Get_HT_Link
(T
: Tag
) return Tag
is
182 return T
.TSD
.HT_Link
;
189 function Hash
(F
: S
.Address
) return HTable_Headers
is
190 function H
is new GNAT
.HTable
.Hash
(HTable_Headers
);
191 Str
: Cstring_Ptr
:= To_Cstring_Ptr
(F
);
192 Res
: constant HTable_Headers
:= H
(Str
(1 .. Length
(Str
)));
202 procedure Set_HT_Link
(T
: Tag
; Next
: Tag
) is
204 T
.TSD
.HT_Link
:= Next
;
207 end HTable_Subprograms
;
213 -- Canonical implementation of Classwide Membership corresponding to:
217 -- Each dispatch table contains a reference to a table of ancestors
218 -- (Ancestor_Tags) and a count of the level of inheritance "Idepth" .
220 -- Obj is in Typ'Class if Typ'Tag is in the table of ancestors that are
221 -- contained in the dispatch table referenced by Obj'Tag . Knowing the
222 -- level of inheritance of both types, this can be computed in constant
223 -- time by the formula:
225 -- Obj'tag.TSD.Ancestor_Tags (Obj'tag.TSD.Idepth - Typ'tag.TSD.Idepth)
228 function CW_Membership
(Obj_Tag
: Tag
; Typ_Tag
: Tag
) return Boolean is
229 Pos
: constant Integer := Obj_Tag
.TSD
.Idepth
- Typ_Tag
.TSD
.Idepth
;
232 return Pos
>= 0 and then Obj_Tag
.TSD
.Ancestor_Tags
(Pos
) = Typ_Tag
;
239 function Expanded_Name
(T
: Tag
) return String is
240 Result
: Cstring_Ptr
:= T
.TSD
.Expanded_Name
;
243 return Result
(1 .. Length
(Result
));
250 function External_Tag
(T
: Tag
) return String is
251 Result
: Cstring_Ptr
:= T
.TSD
.External_Tag
;
254 return Result
(1 .. Length
(Result
));
257 -----------------------
258 -- Get_Expanded_Name --
259 -----------------------
261 function Get_Expanded_Name
(T
: Tag
) return S
.Address
is
263 return To_Address
(T
.TSD
.Expanded_Name
);
264 end Get_Expanded_Name
;
266 ----------------------
267 -- Get_External_Tag --
268 ----------------------
270 function Get_External_Tag
(T
: Tag
) return S
.Address
is
272 return To_Address
(T
.TSD
.External_Tag
);
273 end Get_External_Tag
;
275 ---------------------------
276 -- Get_Inheritance_Depth --
277 ---------------------------
279 function Get_Inheritance_Depth
(T
: Tag
) return Natural is
282 end Get_Inheritance_Depth
;
284 -------------------------
285 -- Get_Prim_Op_Address --
286 -------------------------
288 function Get_Prim_Op_Address
294 return T
.Prims_Ptr
(Position
);
295 end Get_Prim_Op_Address
;
301 function Get_RC_Offset
(T
: Tag
) return SSE
.Storage_Offset
is
303 return T
.TSD
.RC_Offset
;
306 ---------------------------
307 -- Get_Remotely_Callable --
308 ---------------------------
310 function Get_Remotely_Callable
(T
: Tag
) return Boolean is
312 return T
.TSD
.Remotely_Callable
= True;
313 end Get_Remotely_Callable
;
319 function Get_TSD
(T
: Tag
) return S
.Address
is
321 return To_Address
(T
.TSD
);
331 Entry_Count
: Natural)
334 if Old_T
/= null then
335 New_T
.Prims_Ptr
(1 .. Entry_Count
) :=
336 Old_T
.Prims_Ptr
(1 .. Entry_Count
);
344 procedure Inherit_TSD
(Old_TSD
: S
.Address
; New_Tag
: Tag
) is
345 TSD
: constant Type_Specific_Data_Ptr
:=
346 To_Type_Specific_Data_Ptr
(Old_TSD
);
347 New_TSD
: Type_Specific_Data
renames New_Tag
.TSD
.all;
351 New_TSD
.Idepth
:= TSD
.Idepth
+ 1;
352 New_TSD
.Ancestor_Tags
(1 .. New_TSD
.Idepth
)
353 := TSD
.Ancestor_Tags
(0 .. TSD
.Idepth
);
358 New_TSD
.Ancestor_Tags
(0) := New_Tag
;
365 function Internal_Tag
(External
: String) return Tag
is
366 Ext_Copy
: aliased String (External
'First .. External
'Last + 1);
370 -- Make a copy of the string representing the external tag with
373 Ext_Copy
(External
'Range) := External
;
374 Ext_Copy
(Ext_Copy
'Last) := ASCII
.NUL
;
375 Res
:= External_Tag_HTable
.Get
(Ext_Copy
'Address);
379 Msg1
: constant String := "unknown tagged type: ";
380 Msg2
: String (1 .. Msg1
'Length + External
'Length);
383 Msg2
(1 .. Msg1
'Length) := Msg1
;
384 Msg2
(Msg1
'Length + 1 .. Msg1
'Length + External
'Length) :=
386 Ada
.Exceptions
.Raise_Exception
(Tag_Error
'Identity, Msg2
);
397 function Length
(Str
: Cstring_Ptr
) return Natural is
401 while Str
(Len
) /= ASCII
.Nul
loop
412 -- Fake type with a tag as first component. Should match the
413 -- layout of all tagged types.
419 type T_Ptr
is access all T
;
421 function To_T_Ptr
is new Unchecked_Conversion
(S
.Address
, T_Ptr
);
423 -- The profile of the implicitly defined _size primitive
425 type Acc_Size
is access function (A
: S
.Address
) return Long_Long_Integer;
426 function To_Acc_Size
is new Unchecked_Conversion
(S
.Address
, Acc_Size
);
428 function Parent_Size
(Obj
: S
.Address
) return SSE
.Storage_Count
is
430 -- Get the tag of the object
432 Obj_Tag
: constant Tag
:= To_T_Ptr
(Obj
).A
;
434 -- Get the tag of the parent type through the dispatch table
436 Parent_Tag
: constant Tag
:= Obj_Tag
.TSD
.Ancestor_Tags
(1);
438 -- Get an access to the _size primitive of the parent. We assume that
439 -- it is always in the first slot of the distatch table
441 F
: constant Acc_Size
:= To_Acc_Size
(Parent_Tag
.Prims_Ptr
(1));
444 -- Here we compute the size of the _parent field of the object
446 return SSE
.Storage_Count
(F
.all (Obj
));
453 procedure Register_Tag
(T
: Tag
) is
455 External_Tag_HTable
.Set
(T
);
458 -----------------------
459 -- Set_Expanded_Name --
460 -----------------------
462 procedure Set_Expanded_Name
(T
: Tag
; Value
: S
.Address
) is
464 T
.TSD
.Expanded_Name
:= To_Cstring_Ptr
(Value
);
465 end Set_Expanded_Name
;
467 ----------------------
468 -- Set_External_Tag --
469 ----------------------
471 procedure Set_External_Tag
(T
: Tag
; Value
: S
.Address
) is
473 T
.TSD
.External_Tag
:= To_Cstring_Ptr
(Value
);
474 end Set_External_Tag
;
476 ---------------------------
477 -- Set_Inheritance_Depth --
478 ---------------------------
480 procedure Set_Inheritance_Depth
485 T
.TSD
.Idepth
:= Value
;
486 end Set_Inheritance_Depth
;
488 -------------------------
489 -- Set_Prim_Op_Address --
490 -------------------------
492 procedure Set_Prim_Op_Address
498 T
.Prims_Ptr
(Position
) := Value
;
499 end Set_Prim_Op_Address
;
505 procedure Set_RC_Offset
(T
: Tag
; Value
: SSE
.Storage_Offset
) is
507 T
.TSD
.RC_Offset
:= Value
;
510 ---------------------------
511 -- Set_Remotely_Callable --
512 ---------------------------
514 procedure Set_Remotely_Callable
(T
: Tag
; Value
: Boolean) is
517 T
.TSD
.Remotely_Callable
:= True;
519 T
.TSD
.Remotely_Callable
:= False;
521 end Set_Remotely_Callable
;
527 procedure Set_TSD
(T
: Tag
; Value
: S
.Address
) is
529 T
.TSD
:= To_Type_Specific_Data_Ptr
(Value
);