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