1------------------------------------------------------------------------------ 2-- -- 3-- GNAT RUNTIME COMPONENTS -- 4-- -- 5-- A D A . T A G S -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2002 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 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. -- 21-- -- 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. -- 28-- -- 29-- GNAT was originally developed by the GNAT team at New York University. -- 30-- Extensive contributions were provided by Ada Core Technologies Inc. -- 31-- -- 32------------------------------------------------------------------------------ 33 34with Ada.Exceptions; 35 36with System.HTable; 37 38with Unchecked_Conversion; 39 40pragma Elaborate_All (System.HTable); 41 42package body Ada.Tags is 43 44-- Structure of the GNAT Dispatch Table 45 46-- +----------------------+ 47-- | TSD pointer ---|-----> Type Specific Data 48-- +----------------------+ +-------------------+ 49-- | table of | | inheritance depth | 50-- : primitive ops : +-------------------+ 51-- | pointers | | expanded name | 52-- +----------------------+ +-------------------+ 53-- | external tag | 54-- +-------------------+ 55-- | Hash table link | 56-- +-------------------+ 57-- | Remotely Callable | 58-- +-------------------+ 59-- | Rec Ctrler offset | 60-- +-------------------+ 61-- | table of | 62-- : ancestor : 63-- | tags | 64-- +-------------------+ 65 66 subtype Cstring is String (Positive); 67 type Cstring_Ptr is access all Cstring; 68 type Tag_Table is array (Natural range <>) of Tag; 69 pragma Suppress_Initialization (Tag_Table); 70 71 type Wide_Boolean is new Boolean; 72 -- This name should probably be changed sometime ??? and indeed 73 -- probably this field could simply be of type Standard.Boolean. 74 75 type Type_Specific_Data is record 76 Idepth : Natural; 77 Expanded_Name : Cstring_Ptr; 78 External_Tag : Cstring_Ptr; 79 HT_Link : Tag; 80 Remotely_Callable : Wide_Boolean; 81 RC_Offset : SSE.Storage_Offset; 82 Ancestor_Tags : Tag_Table (Natural); 83 end record; 84 85 type Dispatch_Table is record 86 TSD : Type_Specific_Data_Ptr; 87 Prims_Ptr : Address_Array (Positive); 88 end record; 89 90 ------------------------------------------- 91 -- Unchecked Conversions for Tag and TSD -- 92 ------------------------------------------- 93 94 function To_Type_Specific_Data_Ptr is 95 new Unchecked_Conversion (S.Address, Type_Specific_Data_Ptr); 96 97 function To_Address is 98 new Unchecked_Conversion (Type_Specific_Data_Ptr, S.Address); 99 100 --------------------------------------------- 101 -- Unchecked Conversions for String Fields -- 102 --------------------------------------------- 103 104 function To_Cstring_Ptr is 105 new Unchecked_Conversion (S.Address, Cstring_Ptr); 106 107 function To_Address is 108 new Unchecked_Conversion (Cstring_Ptr, S.Address); 109 110 ----------------------- 111 -- Local Subprograms -- 112 ----------------------- 113 114 function Length (Str : Cstring_Ptr) return Natural; 115 -- Length of string represented by the given pointer (treating the 116 -- string as a C-style string, which is Nul terminated). 117 118 ------------------------- 119 -- External_Tag_HTable -- 120 ------------------------- 121 122 type HTable_Headers is range 1 .. 64; 123 124 -- The following internal package defines the routines used for 125 -- the instantiation of a new System.HTable.Static_HTable (see 126 -- below). See spec in g-htable.ads for details of usage. 127 128 package HTable_Subprograms is 129 procedure Set_HT_Link (T : Tag; Next : Tag); 130 function Get_HT_Link (T : Tag) return Tag; 131 function Hash (F : S.Address) return HTable_Headers; 132 function Equal (A, B : S.Address) return Boolean; 133 end HTable_Subprograms; 134 135 package External_Tag_HTable is new System.HTable.Static_HTable ( 136 Header_Num => HTable_Headers, 137 Element => Dispatch_Table, 138 Elmt_Ptr => Tag, 139 Null_Ptr => null, 140 Set_Next => HTable_Subprograms.Set_HT_Link, 141 Next => HTable_Subprograms.Get_HT_Link, 142 Key => S.Address, 143 Get_Key => Get_External_Tag, 144 Hash => HTable_Subprograms.Hash, 145 Equal => HTable_Subprograms.Equal); 146 147 ------------------------ 148 -- HTable_Subprograms -- 149 ------------------------ 150 151 -- Bodies of routines for hash table instantiation 152 153 package body HTable_Subprograms is 154 155 ----------- 156 -- Equal -- 157 ----------- 158 159 function Equal (A, B : S.Address) return Boolean is 160 Str1 : constant Cstring_Ptr := To_Cstring_Ptr (A); 161 Str2 : constant Cstring_Ptr := To_Cstring_Ptr (B); 162 J : Integer := 1; 163 164 begin 165 loop 166 if Str1 (J) /= Str2 (J) then 167 return False; 168 169 elsif Str1 (J) = ASCII.NUL then 170 return True; 171 172 else 173 J := J + 1; 174 end if; 175 end loop; 176 end Equal; 177 178 ----------------- 179 -- Get_HT_Link -- 180 ----------------- 181 182 function Get_HT_Link (T : Tag) return Tag is 183 begin 184 return T.TSD.HT_Link; 185 end Get_HT_Link; 186 187 ---------- 188 -- Hash -- 189 ---------- 190 191 function Hash (F : S.Address) return HTable_Headers is 192 function H is new System.HTable.Hash (HTable_Headers); 193 Str : constant Cstring_Ptr := To_Cstring_Ptr (F); 194 Res : constant HTable_Headers := H (Str (1 .. Length (Str))); 195 196 begin 197 return Res; 198 end Hash; 199 200 ----------------- 201 -- Set_HT_Link -- 202 ----------------- 203 204 procedure Set_HT_Link (T : Tag; Next : Tag) is 205 begin 206 T.TSD.HT_Link := Next; 207 end Set_HT_Link; 208 209 end HTable_Subprograms; 210 211 -------------------- 212 -- CW_Membership -- 213 -------------------- 214 215 -- Canonical implementation of Classwide Membership corresponding to: 216 217 -- Obj in Typ'Class 218 219 -- Each dispatch table contains a reference to a table of ancestors 220 -- (Ancestor_Tags) and a count of the level of inheritance "Idepth" . 221 222 -- Obj is in Typ'Class if Typ'Tag is in the table of ancestors that are 223 -- contained in the dispatch table referenced by Obj'Tag . Knowing the 224 -- level of inheritance of both types, this can be computed in constant 225 -- time by the formula: 226 227 -- Obj'tag.TSD.Ancestor_Tags (Obj'tag.TSD.Idepth - Typ'tag.TSD.Idepth) 228 -- = Typ'tag 229 230 function CW_Membership (Obj_Tag : Tag; Typ_Tag : Tag) return Boolean is 231 Pos : constant Integer := Obj_Tag.TSD.Idepth - Typ_Tag.TSD.Idepth; 232 233 begin 234 return Pos >= 0 and then Obj_Tag.TSD.Ancestor_Tags (Pos) = Typ_Tag; 235 end CW_Membership; 236 237 ------------------- 238 -- Expanded_Name -- 239 ------------------- 240 241 function Expanded_Name (T : Tag) return String is 242 Result : constant Cstring_Ptr := T.TSD.Expanded_Name; 243 244 begin 245 return Result (1 .. Length (Result)); 246 end Expanded_Name; 247 248 ------------------ 249 -- External_Tag -- 250 ------------------ 251 252 function External_Tag (T : Tag) return String is 253 Result : constant Cstring_Ptr := T.TSD.External_Tag; 254 255 begin 256 return Result (1 .. Length (Result)); 257 end External_Tag; 258 259 ----------------------- 260 -- Get_Expanded_Name -- 261 ----------------------- 262 263 function Get_Expanded_Name (T : Tag) return S.Address is 264 begin 265 return To_Address (T.TSD.Expanded_Name); 266 end Get_Expanded_Name; 267 268 ---------------------- 269 -- Get_External_Tag -- 270 ---------------------- 271 272 function Get_External_Tag (T : Tag) return S.Address is 273 begin 274 return To_Address (T.TSD.External_Tag); 275 end Get_External_Tag; 276 277 --------------------------- 278 -- Get_Inheritance_Depth -- 279 --------------------------- 280 281 function Get_Inheritance_Depth (T : Tag) return Natural is 282 begin 283 return T.TSD.Idepth; 284 end Get_Inheritance_Depth; 285 286 ------------------------- 287 -- Get_Prim_Op_Address -- 288 ------------------------- 289 290 function Get_Prim_Op_Address 291 (T : Tag; 292 Position : Positive) 293 return S.Address 294 is 295 begin 296 return T.Prims_Ptr (Position); 297 end Get_Prim_Op_Address; 298 299 ------------------- 300 -- Get_RC_Offset -- 301 ------------------- 302 303 function Get_RC_Offset (T : Tag) return SSE.Storage_Offset is 304 begin 305 return T.TSD.RC_Offset; 306 end Get_RC_Offset; 307 308 --------------------------- 309 -- Get_Remotely_Callable -- 310 --------------------------- 311 312 function Get_Remotely_Callable (T : Tag) return Boolean is 313 begin 314 return T.TSD.Remotely_Callable = True; 315 end Get_Remotely_Callable; 316 317 ------------- 318 -- Get_TSD -- 319 ------------- 320 321 function Get_TSD (T : Tag) return S.Address is 322 begin 323 return To_Address (T.TSD); 324 end Get_TSD; 325 326 ---------------- 327 -- Inherit_DT -- 328 ---------------- 329 330 procedure Inherit_DT 331 (Old_T : Tag; 332 New_T : Tag; 333 Entry_Count : Natural) 334 is 335 begin 336 if Old_T /= null then 337 New_T.Prims_Ptr (1 .. Entry_Count) := 338 Old_T.Prims_Ptr (1 .. Entry_Count); 339 end if; 340 end Inherit_DT; 341 342 ----------------- 343 -- Inherit_TSD -- 344 ----------------- 345 346 procedure Inherit_TSD (Old_TSD : S.Address; New_Tag : Tag) is 347 TSD : constant Type_Specific_Data_Ptr := 348 To_Type_Specific_Data_Ptr (Old_TSD); 349 New_TSD : Type_Specific_Data renames New_Tag.TSD.all; 350 351 begin 352 if TSD /= null then 353 New_TSD.Idepth := TSD.Idepth + 1; 354 New_TSD.Ancestor_Tags (1 .. New_TSD.Idepth) 355 := TSD.Ancestor_Tags (0 .. TSD.Idepth); 356 else 357 New_TSD.Idepth := 0; 358 end if; 359 360 New_TSD.Ancestor_Tags (0) := New_Tag; 361 end Inherit_TSD; 362 363 ------------------ 364 -- Internal_Tag -- 365 ------------------ 366 367 function Internal_Tag (External : String) return Tag is 368 Ext_Copy : aliased String (External'First .. External'Last + 1); 369 Res : Tag; 370 371 begin 372 -- Make a copy of the string representing the external tag with 373 -- a null at the end 374 375 Ext_Copy (External'Range) := External; 376 Ext_Copy (Ext_Copy'Last) := ASCII.NUL; 377 Res := External_Tag_HTable.Get (Ext_Copy'Address); 378 379 if Res = null then 380 declare 381 Msg1 : constant String := "unknown tagged type: "; 382 Msg2 : String (1 .. Msg1'Length + External'Length); 383 384 begin 385 Msg2 (1 .. Msg1'Length) := Msg1; 386 Msg2 (Msg1'Length + 1 .. Msg1'Length + External'Length) := 387 External; 388 Ada.Exceptions.Raise_Exception (Tag_Error'Identity, Msg2); 389 end; 390 end if; 391 392 return Res; 393 end Internal_Tag; 394 395 ------------ 396 -- Length -- 397 ------------ 398 399 function Length (Str : Cstring_Ptr) return Natural is 400 Len : Integer := 1; 401 402 begin 403 while Str (Len) /= ASCII.Nul loop 404 Len := Len + 1; 405 end loop; 406 407 return Len - 1; 408 end Length; 409 410 ----------------- 411 -- Parent_Size -- 412 ----------------- 413 414 type Acc_Size is access function (A : S.Address) return Long_Long_Integer; 415 function To_Acc_Size is new Unchecked_Conversion (S.Address, Acc_Size); 416 -- The profile of the implicitly defined _size primitive 417 418 function Parent_Size 419 (Obj : S.Address; 420 T : Tag) 421 return SSE.Storage_Count is 422 423 Parent_Tag : constant Tag := T.TSD.Ancestor_Tags (1); 424 -- The tag of the parent type through the dispatch table 425 426 F : constant Acc_Size := To_Acc_Size (Parent_Tag.Prims_Ptr (1)); 427 -- Access to the _size primitive of the parent. We assume that 428 -- it is always in the first slot of the distatch table 429 430 begin 431 -- Here we compute the size of the _parent field of the object 432 433 return SSE.Storage_Count (F.all (Obj)); 434 end Parent_Size; 435 436 ---------------- 437 -- Parent_Tag -- 438 ---------------- 439 440 function Parent_Tag (T : Tag) return Tag is 441 begin 442 return T.TSD.Ancestor_Tags (1); 443 end Parent_Tag; 444 445 ------------------ 446 -- Register_Tag -- 447 ------------------ 448 449 procedure Register_Tag (T : Tag) is 450 begin 451 External_Tag_HTable.Set (T); 452 end Register_Tag; 453 454 ----------------------- 455 -- Set_Expanded_Name -- 456 ----------------------- 457 458 procedure Set_Expanded_Name (T : Tag; Value : S.Address) is 459 begin 460 T.TSD.Expanded_Name := To_Cstring_Ptr (Value); 461 end Set_Expanded_Name; 462 463 ---------------------- 464 -- Set_External_Tag -- 465 ---------------------- 466 467 procedure Set_External_Tag (T : Tag; Value : S.Address) is 468 begin 469 T.TSD.External_Tag := To_Cstring_Ptr (Value); 470 end Set_External_Tag; 471 472 --------------------------- 473 -- Set_Inheritance_Depth -- 474 --------------------------- 475 476 procedure Set_Inheritance_Depth 477 (T : Tag; 478 Value : Natural) 479 is 480 begin 481 T.TSD.Idepth := Value; 482 end Set_Inheritance_Depth; 483 484 ------------------------- 485 -- Set_Prim_Op_Address -- 486 ------------------------- 487 488 procedure Set_Prim_Op_Address 489 (T : Tag; 490 Position : Positive; 491 Value : S.Address) 492 is 493 begin 494 T.Prims_Ptr (Position) := Value; 495 end Set_Prim_Op_Address; 496 497 ------------------- 498 -- Set_RC_Offset -- 499 ------------------- 500 501 procedure Set_RC_Offset (T : Tag; Value : SSE.Storage_Offset) is 502 begin 503 T.TSD.RC_Offset := Value; 504 end Set_RC_Offset; 505 506 --------------------------- 507 -- Set_Remotely_Callable -- 508 --------------------------- 509 510 procedure Set_Remotely_Callable (T : Tag; Value : Boolean) is 511 begin 512 if Value then 513 T.TSD.Remotely_Callable := True; 514 else 515 T.TSD.Remotely_Callable := False; 516 end if; 517 end Set_Remotely_Callable; 518 519 ------------- 520 -- Set_TSD -- 521 ------------- 522 523 procedure Set_TSD (T : Tag; Value : S.Address) is 524 begin 525 T.TSD := To_Type_Specific_Data_Ptr (Value); 526 end Set_TSD; 527 528end Ada.Tags; 529