1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- S N A M E S -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2012, 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 32with Debug; use Debug; 33with Opt; use Opt; 34with Table; 35with Types; use Types; 36 37package body Snames is 38 39 -- Table used to record convention identifiers 40 41 type Convention_Id_Entry is record 42 Name : Name_Id; 43 Convention : Convention_Id; 44 end record; 45 46 package Convention_Identifiers is new Table.Table ( 47 Table_Component_Type => Convention_Id_Entry, 48 Table_Index_Type => Int, 49 Table_Low_Bound => 1, 50 Table_Initial => 50, 51 Table_Increment => 200, 52 Table_Name => "Name_Convention_Identifiers"); 53 54 -- Table of names to be set by Initialize. Each name is terminated by a 55 -- single #, and the end of the list is marked by a null entry, i.e. by 56 -- two # marks in succession. Note that the table does not include the 57 -- entries for a-z, since these are initialized by Namet itself. 58 59 Preset_Names : constant String := 60!! TEMPLATE INSERTION POINT 61 "#"; 62 63 --------------------- 64 -- Generated Names -- 65 --------------------- 66 67 -- This section lists the various cases of generated names which are 68 -- built from existing names by adding unique leading and/or trailing 69 -- upper case letters. In some cases these names are built recursively, 70 -- in particular names built from types may be built from types which 71 -- themselves have generated names. In this list, xxx represents an 72 -- existing name to which identifying letters are prepended or appended, 73 -- and a trailing n represents a serial number in an external name that 74 -- has some semantic significance (e.g. the n'th index type of an array). 75 76 -- xxxA access type for formal xxx in entry param record (Exp_Ch9) 77 -- xxxB tag table for tagged type xxx (Exp_Ch3) 78 -- xxxB task body procedure for task xxx (Exp_Ch9) 79 -- xxxD dispatch table for tagged type xxx (Exp_Ch3) 80 -- xxxD discriminal for discriminant xxx (Sem_Ch3) 81 -- xxxDn n'th discr check function for rec type xxx (Exp_Ch3) 82 -- xxxE elaboration boolean flag for task xxx (Exp_Ch9) 83 -- xxxE dispatch table pointer type for tagged type xxx (Exp_Ch3) 84 -- xxxE parameters for accept body for entry xxx (Exp_Ch9) 85 -- xxxFn n'th primitive of a tagged type (named xxx) (Exp_Ch3) 86 -- xxxJ tag table type index for tagged type xxx (Exp_Ch3) 87 -- xxxM master Id value for access type xxx (Exp_Ch3) 88 -- xxxP tag table pointer type for tagged type xxx (Exp_Ch3) 89 -- xxxP parameter record type for entry xxx (Exp_Ch9) 90 -- xxxPA access to parameter record type for entry xxx (Exp_Ch9) 91 -- xxxPn pointer type for n'th primitive of tagged type xxx (Exp_Ch3) 92 -- xxxR dispatch table pointer for tagged type xxx (Exp_Ch3) 93 -- xxxT tag table type for tagged type xxx (Exp_Ch3) 94 -- xxxT literal table for enumeration type xxx (Sem_Ch3) 95 -- xxxV type for task value record for task xxx (Exp_Ch9) 96 -- xxxX entry index constant (Exp_Ch9) 97 -- xxxY dispatch table type for tagged type xxx (Exp_Ch3) 98 -- xxxZ size variable for task xxx (Exp_Ch9) 99 100 -- TSS names 101 102 -- xxxDA deep adjust routine for type xxx (Exp_TSS) 103 -- xxxDF deep finalize routine for type xxx (Exp_TSS) 104 -- xxxDI deep initialize routine for type xxx (Exp_TSS) 105 -- xxxEQ composite equality routine for record type xxx (Exp_TSS) 106 -- xxxFA PolyORB/DSA From_Any converter for type xxx (Exp_TSS) 107 -- xxxIP initialization procedure for type xxx (Exp_TSS) 108 -- xxxRA RAS type access routine for type xxx (Exp_TSS) 109 -- xxxRD RAS type dereference routine for type xxx (Exp_TSS) 110 -- xxxRP Rep to Pos conversion for enumeration type xxx (Exp_TSS) 111 -- xxxSA array/slice assignment for controlled comp. arrays (Exp_TSS) 112 -- xxxSI stream input attribute subprogram for type xxx (Exp_TSS) 113 -- xxxSO stream output attribute subprogram for type xxx (Exp_TSS) 114 -- xxxSR stream read attribute subprogram for type xxx (Exp_TSS) 115 -- xxxSW stream write attribute subprogram for type xxx (Exp_TSS) 116 -- xxxTA PolyORB/DSA To_Any converter for type xxx (Exp_TSS) 117 -- xxxTC PolyORB/DSA Typecode for type xxx (Exp_TSS) 118 119 -- Implicit type names 120 121 -- TxxxT type of literal table for enumeration type xxx (Sem_Ch3) 122 123 -- (Note: this list is not complete or accurate ???) 124 125 ---------------------- 126 -- Get_Attribute_Id -- 127 ---------------------- 128 129 function Get_Attribute_Id (N : Name_Id) return Attribute_Id is 130 begin 131 if N = Name_CPU then 132 return Attribute_CPU; 133 elsif N = Name_Dispatching_Domain then 134 return Attribute_Dispatching_Domain; 135 elsif N = Name_Interrupt_Priority then 136 return Attribute_Interrupt_Priority; 137 else 138 return Attribute_Id'Val (N - First_Attribute_Name); 139 end if; 140 end Get_Attribute_Id; 141 142 ----------------------- 143 -- Get_Convention_Id -- 144 ----------------------- 145 146 function Get_Convention_Id (N : Name_Id) return Convention_Id is 147 begin 148 case N is 149 when Name_Ada => return Convention_Ada; 150 when Name_Ada_Pass_By_Copy => return Convention_Ada_Pass_By_Copy; 151 when Name_Ada_Pass_By_Reference => return 152 Convention_Ada_Pass_By_Reference; 153 when Name_Assembler => return Convention_Assembler; 154 when Name_C => return Convention_C; 155 when Name_CIL => return Convention_CIL; 156 when Name_COBOL => return Convention_COBOL; 157 when Name_CPP => return Convention_CPP; 158 when Name_Fortran => return Convention_Fortran; 159 when Name_Intrinsic => return Convention_Intrinsic; 160 when Name_Java => return Convention_Java; 161 when Name_Stdcall => return Convention_Stdcall; 162 when Name_Stubbed => return Convention_Stubbed; 163 164 -- If no direct match, then we must have a convention 165 -- identifier pragma that has specified this name. 166 167 when others => 168 for J in 1 .. Convention_Identifiers.Last loop 169 if N = Convention_Identifiers.Table (J).Name then 170 return Convention_Identifiers.Table (J).Convention; 171 end if; 172 end loop; 173 174 raise Program_Error; 175 end case; 176 end Get_Convention_Id; 177 178 ------------------------- 179 -- Get_Convention_Name -- 180 ------------------------- 181 182 function Get_Convention_Name (C : Convention_Id) return Name_Id is 183 begin 184 case C is 185 when Convention_Ada => return Name_Ada; 186 when Convention_Ada_Pass_By_Copy => return Name_Ada_Pass_By_Copy; 187 when Convention_Ada_Pass_By_Reference => 188 return Name_Ada_Pass_By_Reference; 189 when Convention_Assembler => return Name_Assembler; 190 when Convention_C => return Name_C; 191 when Convention_CIL => return Name_CIL; 192 when Convention_COBOL => return Name_COBOL; 193 when Convention_CPP => return Name_CPP; 194 when Convention_Entry => return Name_Entry; 195 when Convention_Fortran => return Name_Fortran; 196 when Convention_Intrinsic => return Name_Intrinsic; 197 when Convention_Java => return Name_Java; 198 when Convention_Protected => return Name_Protected; 199 when Convention_Stdcall => return Name_Stdcall; 200 when Convention_Stubbed => return Name_Stubbed; 201 end case; 202 end Get_Convention_Name; 203 204 --------------------------- 205 -- Get_Locking_Policy_Id -- 206 --------------------------- 207 208 function Get_Locking_Policy_Id (N : Name_Id) return Locking_Policy_Id is 209 begin 210 return Locking_Policy_Id'Val (N - First_Locking_Policy_Name); 211 end Get_Locking_Policy_Id; 212 213 ------------------- 214 -- Get_Pragma_Id -- 215 ------------------- 216 217 function Get_Pragma_Id (N : Name_Id) return Pragma_Id is 218 begin 219 case N is 220 when Name_CPU => 221 return Pragma_CPU; 222 when Name_Default_Scalar_Storage_Order => 223 return Pragma_Default_Scalar_Storage_Order; 224 when Name_Dispatching_Domain => 225 return Pragma_Dispatching_Domain; 226 when Name_Fast_Math => 227 return Pragma_Fast_Math; 228 when Name_Interface => 229 return Pragma_Interface; 230 when Name_Interrupt_Priority => 231 return Pragma_Interrupt_Priority; 232 when Name_Lock_Free => 233 return Pragma_Lock_Free; 234 when Name_Priority => 235 return Pragma_Priority; 236 when Name_Storage_Size => 237 return Pragma_Storage_Size; 238 when Name_Storage_Unit => 239 return Pragma_Storage_Unit; 240 when First_Pragma_Name .. Last_Pragma_Name => 241 return Pragma_Id'Val (N - First_Pragma_Name); 242 when others => 243 return Unknown_Pragma; 244 end case; 245 end Get_Pragma_Id; 246 247 --------------------------- 248 -- Get_Queuing_Policy_Id -- 249 --------------------------- 250 251 function Get_Queuing_Policy_Id (N : Name_Id) return Queuing_Policy_Id is 252 begin 253 return Queuing_Policy_Id'Val (N - First_Queuing_Policy_Name); 254 end Get_Queuing_Policy_Id; 255 256 ------------------------------------ 257 -- Get_Task_Dispatching_Policy_Id -- 258 ------------------------------------ 259 260 function Get_Task_Dispatching_Policy_Id 261 (N : Name_Id) return Task_Dispatching_Policy_Id 262 is 263 begin 264 return Task_Dispatching_Policy_Id'Val 265 (N - First_Task_Dispatching_Policy_Name); 266 end Get_Task_Dispatching_Policy_Id; 267 268 ---------------- 269 -- Initialize -- 270 ---------------- 271 272 procedure Initialize is 273 P_Index : Natural; 274 Discard_Name : Name_Id; 275 276 begin 277 P_Index := Preset_Names'First; 278 loop 279 Name_Len := 0; 280 while Preset_Names (P_Index) /= '#' loop 281 Name_Len := Name_Len + 1; 282 Name_Buffer (Name_Len) := Preset_Names (P_Index); 283 P_Index := P_Index + 1; 284 end loop; 285 286 -- We do the Name_Find call to enter the name into the table, but 287 -- we don't need to do anything with the result, since we already 288 -- initialized all the preset names to have the right value (we 289 -- are depending on the order of the names and Preset_Names). 290 291 Discard_Name := Name_Find; 292 P_Index := P_Index + 1; 293 exit when Preset_Names (P_Index) = '#'; 294 end loop; 295 296 -- Make sure that number of names in standard table is correct. If this 297 -- check fails, run utility program XSNAMES to construct a new properly 298 -- matching version of the body. 299 300 pragma Assert (Discard_Name = Last_Predefined_Name); 301 302 -- Initialize the convention identifiers table with the standard set of 303 -- synonyms that we recognize for conventions. 304 305 Convention_Identifiers.Init; 306 307 Convention_Identifiers.Append ((Name_Asm, Convention_Assembler)); 308 Convention_Identifiers.Append ((Name_Assembly, Convention_Assembler)); 309 310 Convention_Identifiers.Append ((Name_Default, Convention_C)); 311 Convention_Identifiers.Append ((Name_External, Convention_C)); 312 313 Convention_Identifiers.Append ((Name_C_Plus_Plus, Convention_CPP)); 314 315 Convention_Identifiers.Append ((Name_DLL, Convention_Stdcall)); 316 Convention_Identifiers.Append ((Name_Win32, Convention_Stdcall)); 317 end Initialize; 318 319 ----------------------- 320 -- Is_Attribute_Name -- 321 ----------------------- 322 323 function Is_Attribute_Name (N : Name_Id) return Boolean is 324 begin 325 -- Don't consider Name_Elab_Subp_Body to be a valid attribute name 326 -- unless we are working in CodePeer mode. 327 328 return N in First_Attribute_Name .. Last_Attribute_Name 329 and then (CodePeer_Mode or else N /= Name_Elab_Subp_Body); 330 end Is_Attribute_Name; 331 332 ---------------------------------- 333 -- Is_Configuration_Pragma_Name -- 334 ---------------------------------- 335 336 function Is_Configuration_Pragma_Name (N : Name_Id) return Boolean is 337 begin 338 return N in First_Pragma_Name .. Last_Configuration_Pragma_Name 339 or else N = Name_Default_Scalar_Storage_Order 340 or else N = Name_Fast_Math; 341 end Is_Configuration_Pragma_Name; 342 343 ------------------------ 344 -- Is_Convention_Name -- 345 ------------------------ 346 347 function Is_Convention_Name (N : Name_Id) return Boolean is 348 begin 349 -- Check if this is one of the standard conventions 350 351 if N in First_Convention_Name .. Last_Convention_Name 352 or else N = Name_C 353 then 354 return True; 355 356 -- Otherwise check if it is in convention identifier table 357 358 else 359 for J in 1 .. Convention_Identifiers.Last loop 360 if N = Convention_Identifiers.Table (J).Name then 361 return True; 362 end if; 363 end loop; 364 365 return False; 366 end if; 367 end Is_Convention_Name; 368 369 ------------------------------ 370 -- Is_Entity_Attribute_Name -- 371 ------------------------------ 372 373 function Is_Entity_Attribute_Name (N : Name_Id) return Boolean is 374 begin 375 return N in First_Entity_Attribute_Name .. Last_Entity_Attribute_Name; 376 end Is_Entity_Attribute_Name; 377 378 -------------------------------- 379 -- Is_Function_Attribute_Name -- 380 -------------------------------- 381 382 function Is_Function_Attribute_Name (N : Name_Id) return Boolean is 383 begin 384 return N in 385 First_Renamable_Function_Attribute .. 386 Last_Renamable_Function_Attribute; 387 end Is_Function_Attribute_Name; 388 389 --------------------- 390 -- Is_Keyword_Name -- 391 --------------------- 392 393 function Is_Keyword_Name (N : Name_Id) return Boolean is 394 begin 395 return Get_Name_Table_Byte (N) /= 0 396 and then (Ada_Version >= Ada_95 397 or else N not in Ada_95_Reserved_Words) 398 and then (Ada_Version >= Ada_2005 399 or else N not in Ada_2005_Reserved_Words 400 or else (Debug_Flag_Dot_DD and then N = Name_Overriding)) 401 -- Accept 'overriding' keywords if -gnatd.D is used, 402 -- for compatibility with Ada 95 compilers implementing 403 -- only this Ada 2005 extension. 404 and then (Ada_Version >= Ada_2012 405 or else N not in Ada_2012_Reserved_Words); 406 end Is_Keyword_Name; 407 408 -------------------------------- 409 -- Is_Internal_Attribute_Name -- 410 -------------------------------- 411 412 function Is_Internal_Attribute_Name (N : Name_Id) return Boolean is 413 begin 414 return 415 N in First_Internal_Attribute_Name .. Last_Internal_Attribute_Name; 416 end Is_Internal_Attribute_Name; 417 418 ---------------------------- 419 -- Is_Locking_Policy_Name -- 420 ---------------------------- 421 422 function Is_Locking_Policy_Name (N : Name_Id) return Boolean is 423 begin 424 return N in First_Locking_Policy_Name .. Last_Locking_Policy_Name; 425 end Is_Locking_Policy_Name; 426 427 ------------------------------------- 428 -- Is_Partition_Elaboration_Policy -- 429 ------------------------------------- 430 431 function Is_Partition_Elaboration_Policy_Name 432 (N : Name_Id) return Boolean 433 is 434 begin 435 return N in First_Partition_Elaboration_Policy_Name .. 436 Last_Partition_Elaboration_Policy_Name; 437 end Is_Partition_Elaboration_Policy_Name; 438 439 ----------------------------- 440 -- Is_Operator_Symbol_Name -- 441 ----------------------------- 442 443 function Is_Operator_Symbol_Name (N : Name_Id) return Boolean is 444 begin 445 return N in First_Operator_Name .. Last_Operator_Name; 446 end Is_Operator_Symbol_Name; 447 448 -------------------- 449 -- Is_Pragma_Name -- 450 -------------------- 451 452 function Is_Pragma_Name (N : Name_Id) return Boolean is 453 begin 454 return N in First_Pragma_Name .. Last_Pragma_Name 455 or else N = Name_CPU 456 or else N = Name_Default_Scalar_Storage_Order 457 or else N = Name_Dispatching_Domain 458 or else N = Name_Fast_Math 459 or else N = Name_Interface 460 or else N = Name_Interrupt_Priority 461 or else N = Name_Lock_Free 462 or else N = Name_Relative_Deadline 463 or else N = Name_Priority 464 or else N = Name_Storage_Size 465 or else N = Name_Storage_Unit; 466 end Is_Pragma_Name; 467 468 --------------------------------- 469 -- Is_Procedure_Attribute_Name -- 470 --------------------------------- 471 472 function Is_Procedure_Attribute_Name (N : Name_Id) return Boolean is 473 begin 474 return N in First_Procedure_Attribute .. Last_Procedure_Attribute; 475 end Is_Procedure_Attribute_Name; 476 477 ---------------------------- 478 -- Is_Queuing_Policy_Name -- 479 ---------------------------- 480 481 function Is_Queuing_Policy_Name (N : Name_Id) return Boolean is 482 begin 483 return N in First_Queuing_Policy_Name .. Last_Queuing_Policy_Name; 484 end Is_Queuing_Policy_Name; 485 486 ------------------------------------- 487 -- Is_Task_Dispatching_Policy_Name -- 488 ------------------------------------- 489 490 function Is_Task_Dispatching_Policy_Name (N : Name_Id) return Boolean is 491 begin 492 return N in First_Task_Dispatching_Policy_Name .. 493 Last_Task_Dispatching_Policy_Name; 494 end Is_Task_Dispatching_Policy_Name; 495 496 ---------------------------- 497 -- Is_Type_Attribute_Name -- 498 ---------------------------- 499 500 function Is_Type_Attribute_Name (N : Name_Id) return Boolean is 501 begin 502 return N in First_Type_Attribute_Name .. Last_Type_Attribute_Name; 503 end Is_Type_Attribute_Name; 504 505 ---------------------------------- 506 -- Record_Convention_Identifier -- 507 ---------------------------------- 508 509 procedure Record_Convention_Identifier 510 (Id : Name_Id; 511 Convention : Convention_Id) 512 is 513 begin 514 Convention_Identifiers.Append ((Id, Convention)); 515 end Record_Convention_Identifier; 516 517end Snames; 518