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-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
  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 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
 480 end Gen_IL.Internals;