gcc/ada/gen_il-internals.adb

   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-2023, 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
  26 package 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 Assignment_OK =>
 261             return "Assignment_OK";
 262          when Backwards_OK =>
 263             return "Backwards_OK";
 264          when BIP_Initialization_Call =>
 265             return "BIP_Initialization_Call";
 266          when Body_Needed_For_SAL =>
 267             return "Body_Needed_For_SAL";
 268          when Conversion_OK =>
 269             return "Conversion_OK";
 270          when CR_Discriminant =>
 271             return "CR_Discriminant";
 272          when DTC_Entity =>
 273             return "DTC_Entity";
 274          when DT_Entry_Count =>
 275             return "DT_Entry_Count";
 276          when DT_Offset_To_Top_Func =>
 277             return "DT_Offset_To_Top_Func";
 278          when DT_Position =>
 279             return "DT_Position";
 280          when Forwards_OK =>
 281             return "Forwards_OK";
 282          when Has_Inherited_DIC =>
 283             return "Has_Inherited_DIC";
 284          when Has_Own_DIC =>
 285             return "Has_Own_DIC";
 286          when Has_RACW =>
 287             return "Has_RACW";
 288          when Has_SP_Choice =>
 289             return "Has_SP_Choice";
 290          when Ignore_SPARK_Mode_Pragmas =>
 291             return "Ignore_SPARK_Mode_Pragmas";
 292          when Is_CPP_Class =>
 293             return "Is_CPP_Class";
 294          when Is_CUDA_Kernel =>
 295             return "Is_CUDA_Kernel";
 296          when Is_DIC_Procedure =>
 297             return "Is_DIC_Procedure";
 298          when Is_Discrim_SO_Function =>
 299             return "Is_Discrim_SO_Function";
 300          when Is_Elaboration_Checks_OK_Id =>
 301             return "Is_Elaboration_Checks_OK_Id";
 302          when Is_Elaboration_Checks_OK_Node =>
 303             return "Is_Elaboration_Checks_OK_Node";
 304          when Is_Elaboration_Warnings_OK_Id =>
 305             return "Is_Elaboration_Warnings_OK_Id";
 306          when Is_Elaboration_Warnings_OK_Node =>
 307             return "Is_Elaboration_Warnings_OK_Node";
 308          when Is_Known_Guaranteed_ABE =>
 309             return "Is_Known_Guaranteed_ABE";
 310          when Is_RACW_Stub_Type =>
 311             return "Is_RACW_Stub_Type";
 312          when Is_SPARK_Mode_On_Node =>
 313             return "Is_SPARK_Mode_On_Node";
 314          when Local_Raise_Not_OK =>
 315             return "Local_Raise_Not_OK";
 316          when LSP_Subprogram =>
 317             return "LSP_Subprogram";
 318          when OK_To_Rename =>
 319             return "OK_To_Rename";
 320          when Referenced_As_LHS =>
 321             return "Referenced_As_LHS";
 322          when RM_Size =>
 323             return "RM_Size";
 324          when SCIL_Controlling_Tag =>
 325             return "SCIL_Controlling_Tag";
 326          when SCIL_Entity =>
 327             return "SCIL_Entity";
 328          when SCIL_Tag_Value =>
 329             return "SCIL_Tag_Value";
 330          when SCIL_Target_Prim =>
 331             return "SCIL_Target_Prim";
 332          when Shift_Count_OK =>
 333             return "Shift_Count_OK";
 334          when SPARK_Aux_Pragma =>
 335             return "SPARK_Aux_Pragma";
 336          when SPARK_Aux_Pragma_Inherited =>
 337             return "SPARK_Aux_Pragma_Inherited";
 338          when SPARK_Pragma =>
 339             return "SPARK_Pragma";
 340          when SPARK_Pragma_Inherited =>
 341             return "SPARK_Pragma_Inherited";
 342          when Split_PPC =>
 343             return "Split_PPC";
 344          when SSO_Set_High_By_Default =>
 345             return "SSO_Set_High_By_Default";
 346          when SSO_Set_Low_By_Default =>
 347             return "SSO_Set_Low_By_Default";
 348          when TSS_Elist =>
 349             return "TSS_Elist";
 350
 351          when others =>
 352             return Capitalize (F'Img);
 353       end case;
 354    end Image;
 355
 356    function Image (Default : Field_Default_Value) return String is
 357      (Capitalize (Default'Img));
 358
 359    -----------------
 360    -- Value_Image --
 361    -----------------
 362
 363    function Value_Image (Default : Field_Default_Value) return String is
 364    begin
 365       if Default = No_Default then
 366          return Image (Default);
 367
 368       else
 369          --  Strip off the prefix
 370
 371          declare
 372             Im : constant String := Image (Default);
 373             Prefix : constant String := "Default_";
 374          begin
 375             pragma Assert (Im (1 .. Prefix'Length) = Prefix);
 376             return Im (Prefix'Length + 1 .. Im'Last);
 377          end;
 378       end if;
 379    end Value_Image;
 380
 381    -------------------
 382    -- Iterate_Types --
 383    -------------------
 384
 385    procedure Iterate_Types
 386      (Root  : Node_Or_Entity_Type;
 387       Pre, Post : not null access procedure (T : Node_Or_Entity_Type) :=
 388         Nil'Access)
 389    is
 390       procedure Recursive (T : Node_Or_Entity_Type);
 391       --  Recursive walk
 392
 393       procedure Recursive (T : Node_Or_Entity_Type) is
 394       begin
 395          Pre (T);
 396
 397          for Child of Type_Table (T).Children loop
 398             Recursive (Child);
 399          end loop;
 400
 401          Post (T);
 402       end Recursive;
 403
 404    begin
 405       Recursive (Root);
 406    end Iterate_Types;
 407
 408    -------------------
 409    -- Is_Descendant --
 410    -------------------
 411
 412    function Is_Descendant (Ancestor, Descendant : Node_Or_Entity_Type)
 413      return Boolean is
 414    begin
 415       if Ancestor = Descendant then
 416          return True;
 417
 418       elsif Descendant in Root_Type then
 419          return False;
 420
 421       else
 422          return Is_Descendant (Ancestor, Type_Table (Descendant).Parent);
 423       end if;
 424    end Is_Descendant;
 425
 426    ------------------------
 427    -- Put_Type_Hierarchy --
 428    ------------------------
 429
 430    procedure Put_Type_Hierarchy (S : in out Sink; Root : Root_Type) is
 431       Level : Natural := 0;
 432
 433       function Indentation return String is ((1 .. 3 * Level => ' '));
 434       --  Indentation string of space characters. We can't use the Indent
 435       --  primitive, because we want this indentation after the "--".
 436
 437       procedure Pre (T : Node_Or_Entity_Type);
 438       procedure Post (T : Node_Or_Entity_Type);
 439       --  Pre and Post actions passed to Iterate_Types
 440
 441       procedure Pre (T : Node_Or_Entity_Type) is
 442       begin
 443          Put (S, "--  " & Indentation & Image (T) & LF);
 444          Level := Level + 1;
 445       end Pre;
 446
 447       procedure Post (T : Node_Or_Entity_Type) is
 448       begin
 449          Level := Level - 1;
 450
 451          --  Put out an "end" line only if there are many descendants, for
 452          --  an arbitrary definition of "many".
 453
 454          if Num_Concrete_Descendants (T) > 10 then
 455             Put (S, "--  " & Indentation & "end " & Image (T) & LF);
 456          end if;
 457       end Post;
 458
 459       N_Or_E : constant String :=
 460         (case Root is
 461            when Node_Kind => "nodes",
 462            when others => "entities");  -- Entity_Kind
 463
 464    --  Start of processing for Put_Type_Hierarchy
 465
 466    begin
 467       Put (S, "--  Type hierarchy for " & N_Or_E & LF);
 468       Put (S, "--" & LF);
 469
 470       Iterate_Types (Root, Pre'Access, Post'Access);
 471
 472       Put (S, "--" & LF);
 473       Put (S, "--  End type hierarchy for " & N_Or_E & LF & LF);
 474    end Put_Type_Hierarchy;
 475
 476 end Gen_IL.Internals;