1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- G E N _ I L . U T I L S -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2020-2021, 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. 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 COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26package body Gen_IL.Internals is 27 28 --------- 29 -- Nil -- 30 --------- 31 32 procedure Nil (T : Node_Or_Entity_Type) is 33 begin 34 null; 35 end Nil; 36 37 -------------------- 38 -- Node_Or_Entity -- 39 -------------------- 40 41 function Node_Or_Entity (Root : Root_Type) return String is 42 begin 43 if Root = Node_Kind then 44 return "Node"; 45 else 46 return "Entity"; 47 end if; 48 end Node_Or_Entity; 49 50 ------------------------------ 51 -- Num_Concrete_Descendants -- 52 ------------------------------ 53 54 function Num_Concrete_Descendants 55 (T : Node_Or_Entity_Type) return Natural is 56 begin 57 return Concrete_Type'Pos (Type_Table (T).Last) - 58 Concrete_Type'Pos (Type_Table (T).First) + 1; 59 end Num_Concrete_Descendants; 60 61 function First_Abstract (Root : Root_Type) return Abstract_Type is 62 (case Root is 63 when Node_Kind => Abstract_Node'First, 64 when others => Abstract_Entity'First); -- Entity_Kind 65 function Last_Abstract (Root : Root_Type) return Abstract_Type is 66 (case Root is 67 when Node_Kind => Abstract_Node'Last, 68 when others => Abstract_Entity'Last); -- Entity_Kind 69 70 function First_Concrete (Root : Root_Type) return Concrete_Type is 71 (case Root is 72 when Node_Kind => Concrete_Node'First, 73 when others => Concrete_Entity'First); -- Entity_Kind 74 function Last_Concrete (Root : Root_Type) return Concrete_Type is 75 (case Root is 76 when Node_Kind => Concrete_Node'Last, 77 when others => Concrete_Entity'Last); -- Entity_Kind 78 79 function First_Field (Root : Root_Type) return Field_Enum is 80 (case Root is 81 when Node_Kind => Node_Field'First, 82 when others => Entity_Field'First); -- Entity_Kind 83 function Last_Field (Root : Root_Type) return Field_Enum is 84 (case Root is 85 when Node_Kind => Node_Field'Last, 86 when others => Entity_Field'Last); -- Entity_Kind 87 88 ----------------------- 89 -- Verify_Type_Table -- 90 ----------------------- 91 92 procedure Verify_Type_Table is 93 begin 94 for T in Node_Or_Entity_Type loop 95 if Type_Table (T) /= null then 96 if not Type_Table (T).Is_Union then 97 case T is 98 when Concrete_Node | Concrete_Entity => 99 pragma Assert (Type_Table (T).First = T); 100 pragma Assert (Type_Table (T).Last = T); 101 102 when Abstract_Node | Abstract_Entity => 103 pragma Assert 104 (Type_Table (T).First < Type_Table (T).Last); 105 106 when Type_Boundaries => 107 null; 108 end case; 109 end if; 110 end if; 111 end loop; 112 end Verify_Type_Table; 113 114 -------------- 115 -- Id_Image -- 116 -------------- 117 118 function Id_Image (T : Type_Enum) return String is 119 begin 120 case T is 121 when Flag => 122 return "Boolean"; 123 when Node_Kind => 124 return "Node_Id"; 125 when Entity_Kind => 126 return "Entity_Id"; 127 when Node_Kind_Type => 128 return "Node_Kind"; 129 when Entity_Kind_Type => 130 return "Entity_Kind"; 131 when others => 132 return Image (T) & "_Id"; 133 end case; 134 end Id_Image; 135 136 ---------------------- 137 -- Get_Set_Id_Image -- 138 ---------------------- 139 140 function Get_Set_Id_Image (T : Type_Enum) return String is 141 begin 142 case T is 143 when Node_Kind => 144 return "Node_Id"; 145 when Entity_Kind => 146 return "Entity_Id"; 147 when Node_Kind_Type => 148 return "Node_Kind"; 149 when Entity_Kind_Type => 150 return "Entity_Kind"; 151 when others => 152 return Image (T); 153 end case; 154 end Get_Set_Id_Image; 155 156 ----------- 157 -- Image -- 158 ----------- 159 160 function Image (T : Opt_Type_Enum) return String is 161 begin 162 case T is 163 -- We special case the following; otherwise the compiler will give 164 -- "wrong case" warnings in compiler code. 165 166 when N_Pop_xxx_Label => 167 return "N_Pop_xxx_Label"; 168 169 when N_Push_Pop_xxx_Label => 170 return "N_Push_Pop_xxx_Label"; 171 172 when N_Push_xxx_Label => 173 return "N_Push_xxx_Label"; 174 175 when N_Raise_xxx_Error => 176 return "N_Raise_xxx_Error"; 177 178 when N_SCIL_Node => 179 return "N_SCIL_Node"; 180 181 when N_SCIL_Dispatch_Table_Tag_Init => 182 return "N_SCIL_Dispatch_Table_Tag_Init"; 183 184 when N_SCIL_Dispatching_Call => 185 return "N_SCIL_Dispatching_Call"; 186 187 when N_SCIL_Membership_Test => 188 return "N_SCIL_Membership_Test"; 189 190 when others => 191 return Capitalize (T'Img); 192 end case; 193 end Image; 194 195 ------------------ 196 -- Image_Sans_N -- 197 ------------------ 198 199 function Image_Sans_N (T : Opt_Type_Enum) return String is 200 Im : constant String := Image (T); 201 pragma Assert (Im (1 .. 2) = "N_"); 202 begin 203 return Im (3 .. Im'Last); 204 end Image_Sans_N; 205 206 ------------------------- 207 -- Put_Types_With_Bars -- 208 ------------------------- 209 210 procedure Put_Types_With_Bars (S : in out Sink; U : Type_Vector) is 211 First_Time : Boolean := True; 212 begin 213 Increase_Indent (S, 3); 214 215 for T of U loop 216 if First_Time then 217 First_Time := False; 218 else 219 Put (S, LF & "| "); 220 end if; 221 222 Put (S, Image (T)); 223 end loop; 224 225 Decrease_Indent (S, 3); 226 end Put_Types_With_Bars; 227 228 ---------------------------- 229 -- Put_Type_Ids_With_Bars -- 230 ---------------------------- 231 232 procedure Put_Type_Ids_With_Bars (S : in out Sink; U : Type_Vector) is 233 First_Time : Boolean := True; 234 begin 235 Increase_Indent (S, 3); 236 237 for T of U loop 238 if First_Time then 239 First_Time := False; 240 else 241 Put (S, LF & "| "); 242 end if; 243 244 Put (S, Id_Image (T)); 245 end loop; 246 247 Decrease_Indent (S, 3); 248 end Put_Type_Ids_With_Bars; 249 250 ----------- 251 -- Image -- 252 ----------- 253 254 function Image (F : Opt_Field_Enum) return String is 255 begin 256 case F is 257 -- Special cases for the same reason as in the above Image 258 -- function for Opt_Type_Enum. 259 260 when Alloc_For_BIP_Return => 261 return "Alloc_For_BIP_Return"; 262 when Assignment_OK => 263 return "Assignment_OK"; 264 when Backwards_OK => 265 return "Backwards_OK"; 266 when BIP_Initialization_Call => 267 return "BIP_Initialization_Call"; 268 when Body_Needed_For_SAL => 269 return "Body_Needed_For_SAL"; 270 when Conversion_OK => 271 return "Conversion_OK"; 272 when CR_Discriminant => 273 return "CR_Discriminant"; 274 when DTC_Entity => 275 return "DTC_Entity"; 276 when DT_Entry_Count => 277 return "DT_Entry_Count"; 278 when DT_Offset_To_Top_Func => 279 return "DT_Offset_To_Top_Func"; 280 when DT_Position => 281 return "DT_Position"; 282 when Forwards_OK => 283 return "Forwards_OK"; 284 when Has_Inherited_DIC => 285 return "Has_Inherited_DIC"; 286 when Has_Own_DIC => 287 return "Has_Own_DIC"; 288 when Has_RACW => 289 return "Has_RACW"; 290 when Has_SP_Choice => 291 return "Has_SP_Choice"; 292 when Ignore_SPARK_Mode_Pragmas => 293 return "Ignore_SPARK_Mode_Pragmas"; 294 when Is_Constr_Subt_For_UN_Aliased => 295 return "Is_Constr_Subt_For_UN_Aliased"; 296 when Is_CPP_Class => 297 return "Is_CPP_Class"; 298 when Is_CUDA_Kernel => 299 return "Is_CUDA_Kernel"; 300 when Is_DIC_Procedure => 301 return "Is_DIC_Procedure"; 302 when Is_Discrim_SO_Function => 303 return "Is_Discrim_SO_Function"; 304 when Is_Elaboration_Checks_OK_Id => 305 return "Is_Elaboration_Checks_OK_Id"; 306 when Is_Elaboration_Checks_OK_Node => 307 return "Is_Elaboration_Checks_OK_Node"; 308 when Is_Elaboration_Warnings_OK_Id => 309 return "Is_Elaboration_Warnings_OK_Id"; 310 when Is_Elaboration_Warnings_OK_Node => 311 return "Is_Elaboration_Warnings_OK_Node"; 312 when Is_Known_Guaranteed_ABE => 313 return "Is_Known_Guaranteed_ABE"; 314 when Is_RACW_Stub_Type => 315 return "Is_RACW_Stub_Type"; 316 when Is_SPARK_Mode_On_Node => 317 return "Is_SPARK_Mode_On_Node"; 318 when Local_Raise_Not_OK => 319 return "Local_Raise_Not_OK"; 320 when LSP_Subprogram => 321 return "LSP_Subprogram"; 322 when OK_To_Rename => 323 return "OK_To_Rename"; 324 when Referenced_As_LHS => 325 return "Referenced_As_LHS"; 326 when RM_Size => 327 return "RM_Size"; 328 when SCIL_Controlling_Tag => 329 return "SCIL_Controlling_Tag"; 330 when SCIL_Entity => 331 return "SCIL_Entity"; 332 when SCIL_Tag_Value => 333 return "SCIL_Tag_Value"; 334 when SCIL_Target_Prim => 335 return "SCIL_Target_Prim"; 336 when Shift_Count_OK => 337 return "Shift_Count_OK"; 338 when SPARK_Aux_Pragma => 339 return "SPARK_Aux_Pragma"; 340 when SPARK_Aux_Pragma_Inherited => 341 return "SPARK_Aux_Pragma_Inherited"; 342 when SPARK_Pragma => 343 return "SPARK_Pragma"; 344 when SPARK_Pragma_Inherited => 345 return "SPARK_Pragma_Inherited"; 346 when Split_PPC => 347 return "Split_PPC"; 348 when SSO_Set_High_By_Default => 349 return "SSO_Set_High_By_Default"; 350 when SSO_Set_Low_By_Default => 351 return "SSO_Set_Low_By_Default"; 352 when TSS_Elist => 353 return "TSS_Elist"; 354 355 when others => 356 return Capitalize (F'Img); 357 end case; 358 end Image; 359 360 function Image (Default : Field_Default_Value) return String is 361 (Capitalize (Default'Img)); 362 363 ----------------- 364 -- Value_Image -- 365 ----------------- 366 367 function Value_Image (Default : Field_Default_Value) return String is 368 begin 369 if Default = No_Default then 370 return Image (Default); 371 372 else 373 -- Strip off the prefix 374 375 declare 376 Im : constant String := Image (Default); 377 Prefix : constant String := "Default_"; 378 begin 379 pragma Assert (Im (1 .. Prefix'Length) = Prefix); 380 return Im (Prefix'Length + 1 .. Im'Last); 381 end; 382 end if; 383 end Value_Image; 384 385 ------------------- 386 -- Iterate_Types -- 387 ------------------- 388 389 procedure Iterate_Types 390 (Root : Node_Or_Entity_Type; 391 Pre, Post : not null access procedure (T : Node_Or_Entity_Type) := 392 Nil'Access) 393 is 394 procedure Recursive (T : Node_Or_Entity_Type); 395 -- Recursive walk 396 397 procedure Recursive (T : Node_Or_Entity_Type) is 398 begin 399 Pre (T); 400 401 for Child of Type_Table (T).Children loop 402 Recursive (Child); 403 end loop; 404 405 Post (T); 406 end Recursive; 407 408 begin 409 Recursive (Root); 410 end Iterate_Types; 411 412 ------------------- 413 -- Is_Descendant -- 414 ------------------- 415 416 function Is_Descendant (Ancestor, Descendant : Node_Or_Entity_Type) 417 return Boolean is 418 begin 419 if Ancestor = Descendant then 420 return True; 421 422 elsif Descendant in Root_Type then 423 return False; 424 425 else 426 return Is_Descendant (Ancestor, Type_Table (Descendant).Parent); 427 end if; 428 end Is_Descendant; 429 430 ------------------------ 431 -- Put_Type_Hierarchy -- 432 ------------------------ 433 434 procedure Put_Type_Hierarchy (S : in out Sink; Root : Root_Type) is 435 Level : Natural := 0; 436 437 function Indentation return String is ((1 .. 3 * Level => ' ')); 438 -- Indentation string of space characters. We can't use the Indent 439 -- primitive, because we want this indentation after the "--". 440 441 procedure Pre (T : Node_Or_Entity_Type); 442 procedure Post (T : Node_Or_Entity_Type); 443 -- Pre and Post actions passed to Iterate_Types 444 445 procedure Pre (T : Node_Or_Entity_Type) is 446 begin 447 Put (S, "-- " & Indentation & Image (T) & LF); 448 Level := Level + 1; 449 end Pre; 450 451 procedure Post (T : Node_Or_Entity_Type) is 452 begin 453 Level := Level - 1; 454 455 -- Put out an "end" line only if there are many descendants, for 456 -- an arbitrary definition of "many". 457 458 if Num_Concrete_Descendants (T) > 10 then 459 Put (S, "-- " & Indentation & "end " & Image (T) & LF); 460 end if; 461 end Post; 462 463 N_Or_E : constant String := 464 (case Root is 465 when Node_Kind => "nodes", 466 when others => "entities"); -- Entity_Kind 467 468 -- Start of processing for Put_Type_Hierarchy 469 470 begin 471 Put (S, "-- Type hierarchy for " & N_Or_E & LF); 472 Put (S, "--" & LF); 473 474 Iterate_Types (Root, Pre'Access, Post'Access); 475 476 Put (S, "--" & LF); 477 Put (S, "-- End type hierarchy for " & N_Or_E & LF & LF); 478 end Put_Type_Hierarchy; 479 480end Gen_IL.Internals; 481