gcc/ada/sem_intr.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                             S E M _ I N T R                              --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2024, 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 --  Processing for intrinsic subprogram declarations
  27
  28 with Atree;          use Atree;
  29 with Einfo;          use Einfo;
  30 with Einfo.Entities; use Einfo.Entities;
  31 with Einfo.Utils;    use Einfo.Utils;
  32 with Errout;         use Errout;
  33 with Lib;            use Lib;
  34 with Namet;          use Namet;
  35 with Opt;            use Opt;
  36 with Sem_Aux;        use Sem_Aux;
  37 with Sem_Eval;       use Sem_Eval;
  38 with Sem_Util;       use Sem_Util;
  39 with Sinfo;          use Sinfo;
  40 with Sinfo.Nodes;    use Sinfo.Nodes;
  41 with Sinfo.Utils;    use Sinfo.Utils;
  42 with Snames;         use Snames;
  43 with Stand;          use Stand;
  44 with Stringt;        use Stringt;
  45 with Ttypes;         use Ttypes;
  46 with Uintp;          use Uintp;
  47
  48 package body Sem_Intr is
  49
  50    -----------------------
  51    -- Local Subprograms --
  52    -----------------------
  53
  54    procedure Check_Exception_Function (E : Entity_Id; N : Node_Id);
  55    --  Check use of intrinsic Exception_Message, Exception_Info or
  56    --  Exception_Name, as used in the DEC compatible Current_Exceptions
  57    --  package. In each case we must have a parameterless function that
  58    --  returns type String.
  59
  60    procedure Check_Intrinsic_Operator (E : Entity_Id; N : Node_Id);
  61    --  Check that operator is one of the binary arithmetic operators, and that
  62    --  the types involved both have underlying integer types.
  63
  64    procedure Check_Shift (E : Entity_Id; N : Node_Id);
  65    --  Check intrinsic shift subprogram, the two arguments are the same
  66    --  as for Check_Intrinsic_Subprogram (i.e. the entity of the subprogram
  67    --  declaration, and the node for the pragma argument, used for messages).
  68
  69    procedure Errint
  70      (Msg : String; S : Node_Id; N : Node_Id; Relaxed : Boolean := False);
  71    --  Post error message for bad intrinsic, the message itself is posted
  72    --  on the appropriate spec node and another message is placed on the
  73    --  pragma itself, referring to the spec. S is the node in the spec on
  74    --  which the message is to be placed, and N is the pragma argument node.
  75    --  Relaxed is True if the message should not be emitted in
  76    --  Relaxed_RM_Semantics mode.
  77
  78    ------------------------------
  79    -- Check_Exception_Function --
  80    ------------------------------
  81
  82    procedure Check_Exception_Function (E : Entity_Id; N : Node_Id) is
  83    begin
  84       if Ekind (E) not in E_Function | E_Generic_Function then
  85          Errint
  86            ("intrinsic exception subprogram must be a function", E, N);
  87
  88       elsif Present (First_Formal (E)) then
  89          Errint
  90            ("intrinsic exception subprogram may not have parameters",
  91             E, First_Formal (E));
  92          return;
  93
  94       elsif Etype (E) /= Standard_String then
  95          Errint
  96            ("return type of exception subprogram must be String", E, N);
  97          return;
  98       end if;
  99    end Check_Exception_Function;
 100
 101    --------------------------
 102    -- Check_Intrinsic_Call --
 103    --------------------------
 104
 105    procedure Check_Intrinsic_Call (N : Node_Id) is
 106       Nam  : constant Entity_Id := Entity (Name (N));
 107       Arg1 : constant Node_Id   := First_Actual (N);
 108       Typ  : Entity_Id;
 109       Rtyp : Entity_Id := Empty;
 110       Cnam : Name_Id;
 111       Unam : Node_Id;
 112
 113    begin
 114       --  Set argument type if argument present
 115
 116       if Present (Arg1) then
 117          Typ := Etype (Arg1);
 118          Rtyp := Underlying_Type (Root_Type (Typ));
 119       end if;
 120
 121       --  Set intrinsic name (getting original name in the generic case)
 122
 123       Unam := Ultimate_Alias (Nam);
 124
 125       if Present (Parent (Unam))
 126         and then Present (Generic_Parent (Parent (Unam)))
 127       then
 128          Cnam := Chars (Generic_Parent (Parent (Unam)));
 129       else
 130          Cnam := Chars (Nam);
 131       end if;
 132
 133       --  For Import_xxx calls, argument must be static string. A string
 134       --  literal is legal even in Ada 83 mode, where such literals are
 135       --  not static.
 136
 137       if Cnam in Name_Import_Address
 138                | Name_Import_Largest_Value
 139                | Name_Import_Value
 140       then
 141          if Etype (Arg1) = Any_Type
 142            or else Raises_Constraint_Error (Arg1)
 143          then
 144             null;
 145
 146          elsif Nkind (Arg1) /= N_String_Literal
 147            and then not Is_OK_Static_Expression (Arg1)
 148          then
 149             Error_Msg_FE
 150               ("call to & requires static string argument!", N, Nam);
 151             Why_Not_Static (Arg1);
 152
 153          elsif String_Length (Strval (Expr_Value_S (Arg1))) = 0 then
 154             Error_Msg_NE
 155               ("call to & does not permit null string", N, Nam);
 156          end if;
 157
 158       --  Check for the case of freeing a non-null object which will raise
 159       --  Constraint_Error. Issue warning here, do the expansion in Exp_Intr.
 160
 161       elsif Cnam = Name_Unchecked_Deallocation
 162         and then Can_Never_Be_Null (Etype (Arg1))
 163       then
 164          Error_Msg_N
 165            ("freeing `NOT NULL` object will raise Constraint_Error??", N);
 166
 167       --  For unchecked deallocation, error to deallocate from empty pool.
 168       --  Note: this test used to be in Exp_Intr as a warning, but AI 157
 169       --  issues a binding interpretation that this should be an error, and
 170       --  consequently it needs to be done in the semantic analysis so that
 171       --  the error is issued even in semantics only mode.
 172
 173       elsif Cnam = Name_Unchecked_Deallocation
 174         and then No_Pool_Assigned (Rtyp)
 175       then
 176          Error_Msg_N ("deallocation from empty storage pool!", N);
 177
 178       --  For now, no other special checks are required
 179
 180       else
 181          return;
 182       end if;
 183    end Check_Intrinsic_Call;
 184
 185    ------------------------------
 186    -- Check_Intrinsic_Operator --
 187    ------------------------------
 188
 189    procedure Check_Intrinsic_Operator (E : Entity_Id; N : Node_Id) is
 190       Ret : constant Entity_Id := Etype (E);
 191       Nam : constant Name_Id   := Chars (E);
 192       T1  : Entity_Id;
 193       T2  : Entity_Id;
 194
 195    begin
 196       --  Arithmetic operators
 197
 198       if Nam in Name_Op_Add    | Name_Op_Subtract | Name_Op_Multiply |
 199                 Name_Op_Divide | Name_Op_Rem      | Name_Op_Mod      |
 200                 Name_Op_Abs
 201       then
 202          T1 := Etype (First_Formal (E));
 203
 204          if No (Next_Formal (First_Formal (E))) then
 205             if Nam in Name_Op_Add | Name_Op_Subtract | Name_Op_Abs then
 206                T2 := T1;
 207
 208             --  Previous error in declaration
 209
 210             else
 211                return;
 212             end if;
 213
 214          else
 215             T2 := Etype (Next_Formal (First_Formal (E)));
 216          end if;
 217
 218          --  Same types, predefined operator will apply
 219
 220          if Root_Type (T1) = Root_Type (T2)
 221            or else Root_Type (T1) = Root_Type (Ret)
 222          then
 223             null;
 224
 225          --  Expansion will introduce conversions if sizes are not equal
 226
 227          elsif Is_Integer_Type (Underlying_Type (T1))
 228            and then Is_Integer_Type (Underlying_Type (T2))
 229            and then Is_Integer_Type (Underlying_Type (Ret))
 230          then
 231             null;
 232
 233          else
 234             Errint
 235               ("types of intrinsic operator operands do not match", E, N);
 236          end if;
 237
 238       --  Comparison operators
 239
 240       elsif Nam in Name_Op_Eq | Name_Op_Ge | Name_Op_Gt | Name_Op_Le |
 241                    Name_Op_Lt | Name_Op_Ne
 242       then
 243          T1 := Etype (First_Formal (E));
 244
 245          --  Return if previous error in declaration, otherwise get T2 type
 246
 247          if No (Next_Formal (First_Formal (E))) then
 248             Check_Error_Detected;
 249             return;
 250
 251          else
 252             T2 := Etype (Next_Formal (First_Formal (E)));
 253          end if;
 254
 255          if Root_Type (T1) /= Root_Type (T2) then
 256             Errint
 257               ("types of intrinsic operator must have the same size", E, N);
 258          end if;
 259
 260          if Root_Type (Ret) /= Standard_Boolean then
 261             Errint
 262               ("result type of intrinsic comparison must be boolean", E, N);
 263          end if;
 264
 265       --  Exponentiation
 266
 267       elsif Nam = Name_Op_Expon then
 268          T1 := Etype (First_Formal (E));
 269
 270          if No (Next_Formal (First_Formal (E))) then
 271
 272             --  Previous error in declaration
 273
 274             return;
 275
 276          else
 277             T2 := Etype (Next_Formal (First_Formal (E)));
 278          end if;
 279
 280          if not (Is_Integer_Type (T1)
 281                    or else
 282                  Is_Floating_Point_Type (T1))
 283            or else Root_Type (T1) /= Root_Type (Ret)
 284            or else Root_Type (T2) /= Root_Type (Standard_Integer)
 285          then
 286             Errint ("incorrect operands for intrinsic operator", N, E);
 287          end if;
 288
 289       --  All other operators (are there any?) are not handled
 290
 291       else
 292          Errint ("incorrect context for ""Intrinsic"" convention", E, N);
 293          return;
 294       end if;
 295
 296       --  The type must be fully defined and numeric.
 297
 298       if No (Underlying_Type (T1))
 299         or else not Is_Numeric_Type (Underlying_Type (T1))
 300       then
 301          Errint ("intrinsic operator can only apply to numeric types", E, N);
 302       end if;
 303    end Check_Intrinsic_Operator;
 304
 305    --------------------------------
 306    -- Check_Intrinsic_Subprogram --
 307    --------------------------------
 308
 309    procedure Check_Intrinsic_Subprogram (E : Entity_Id; N : Node_Id) is
 310       Spec : constant Node_Id := Specification (Unit_Declaration_Node (E));
 311       Nam  : Name_Id;
 312
 313    begin
 314       if Present (Spec)
 315         and then Present (Generic_Parent (Spec))
 316       then
 317          Nam := Chars (Generic_Parent (Spec));
 318       else
 319          Nam := Chars (E);
 320       end if;
 321
 322       --  Check name is valid intrinsic name
 323
 324       Get_Name_String (Nam);
 325
 326       if Name_Buffer (1) /= 'O'
 327         and then Nam /= Name_Asm
 328         and then Nam /= Name_To_Address
 329         and then Nam not in First_Intrinsic_Name .. Last_Intrinsic_Name
 330       then
 331          Errint ("unrecognized intrinsic subprogram", E, N);
 332
 333       --  Shift cases. We allow user specification of intrinsic shift operators
 334       --  for any numeric types.
 335
 336       elsif Nam in Name_Rotate_Left | Name_Rotate_Right | Name_Shift_Left |
 337                    Name_Shift_Right | Name_Shift_Right_Arithmetic
 338       then
 339          Check_Shift (E, N);
 340
 341       --  We always allow intrinsic specifications in language defined units
 342       --  and in expanded code. We assume that the GNAT implementors know what
 343       --  they are doing, and do not write or generate junk use of intrinsic.
 344
 345       elsif not Comes_From_Source (E)
 346         or else not Comes_From_Source (N)
 347         or else In_Predefined_Unit (N)
 348       then
 349          null;
 350
 351       --  Exception functions
 352
 353       elsif Nam in Name_Exception_Information
 354                  | Name_Exception_Message
 355                  | Name_Exception_Name
 356       then
 357          Check_Exception_Function (E, N);
 358
 359       --  Intrinsic operators
 360
 361       elsif Nkind (E) = N_Defining_Operator_Symbol then
 362          Check_Intrinsic_Operator (E, N);
 363
 364       --  Source_Location and navigation functions
 365
 366       elsif Nam in Name_File
 367                  | Name_Line
 368                  | Name_Source_Location
 369                  | Name_Enclosing_Entity
 370                  | Name_Compilation_ISO_Date
 371                  | Name_Compilation_Date
 372                  | Name_Compilation_Time
 373       then
 374          null;
 375
 376       --  For now, no other intrinsic subprograms are recognized in user code
 377
 378       else
 379          Errint ("incorrect context for ""Intrinsic"" convention", E, N);
 380       end if;
 381    end Check_Intrinsic_Subprogram;
 382
 383    -----------------
 384    -- Check_Shift --
 385    -----------------
 386
 387    procedure Check_Shift (E : Entity_Id; N : Node_Id) is
 388       Arg1  : Node_Id;
 389       Arg2  : Node_Id;
 390       Size  : Nat;
 391       Typ1  : Entity_Id;
 392       Typ2  : Entity_Id;
 393       Ptyp1 : Node_Id;
 394       Ptyp2 : Node_Id;
 395
 396    begin
 397       if Ekind (E) not in E_Function | E_Generic_Function then
 398          Errint ("intrinsic shift subprogram must be a function", E, N);
 399          return;
 400       end if;
 401
 402       Arg1 := First_Formal (E);
 403
 404       if Present (Arg1) then
 405          Arg2 := Next_Formal (Arg1);
 406       else
 407          Arg2 := Empty;
 408       end if;
 409
 410       if Arg1 = Empty or else Arg2 = Empty then
 411          Errint ("intrinsic shift function must have two arguments", E, N);
 412          return;
 413       end if;
 414
 415       Typ1 := Etype (Arg1);
 416       Typ2 := Etype (Arg2);
 417
 418       Ptyp1 := Parameter_Type (Parent (Arg1));
 419       Ptyp2 := Parameter_Type (Parent (Arg2));
 420
 421       if not Is_Integer_Type (Typ1) then
 422          Errint ("first argument to shift must be integer type", Ptyp1, N);
 423          return;
 424       end if;
 425
 426       if Typ2 /= Standard_Natural then
 427          Errint ("second argument to shift must be type Natural", Ptyp2, N);
 428          return;
 429       end if;
 430
 431       --  type'Size (not 'Object_Size) must be one of the allowed values
 432
 433       Size := UI_To_Int (RM_Size (Typ1));
 434
 435       if Size /= 8  and then
 436          Size /= 16 and then
 437          Size /= 32 and then
 438          Size /= 64 and then
 439          Size /= System_Max_Integer_Size
 440       then
 441          if System_Max_Integer_Size > 64 then
 442             Errint
 443               ("first argument for shift must have size 8, 16, 32, 64 or 128",
 444                Ptyp1, N, Relaxed => True);
 445          else
 446             Errint
 447               ("first argument for shift must have size 8, 16, 32 or 64",
 448                Ptyp1, N, Relaxed => True);
 449          end if;
 450          return;
 451
 452       elsif Non_Binary_Modulus (Typ1) then
 453          Errint ("shifts not allowed for nonbinary modular types", Ptyp1, N);
 454
 455       --  For modular type, modulus must be 2**8, 2**16, 2**32, or 2**64.
 456       --  Don't apply to generic types, since we may not have a modulus value.
 457
 458       elsif Is_Modular_Integer_Type (Typ1)
 459         and then not Is_Generic_Type (Typ1)
 460         and then Modulus (Typ1) /= Uint_2 ** 8
 461         and then Modulus (Typ1) /= Uint_2 ** 16
 462         and then Modulus (Typ1) /= Uint_2 ** 32
 463         and then Modulus (Typ1) /= Uint_2 ** 64
 464         and then Modulus (Typ1) /= Uint_2 ** System_Max_Binary_Modulus_Power
 465       then
 466          if System_Max_Binary_Modulus_Power > 64 then
 467             Errint
 468               ("modular type for shift must have modulus of 2'*'*8, "
 469                & "2'*'*16, 2'*'*32, 2'*'*64 or 2'*'*128", Ptyp1, N,
 470                Relaxed => True);
 471          else
 472             Errint
 473               ("modular type for shift must have modulus of 2'*'*8, "
 474                & "2'*'*16, 2'*'*32, or 2'*'*64", Ptyp1, N,
 475                Relaxed => True);
 476          end if;
 477
 478       elsif Etype (Arg1) /= Etype (E) then
 479          Errint
 480            ("first argument of shift must match return type", Ptyp1, N);
 481          return;
 482       end if;
 483
 484       Set_Has_Shift_Operator (Base_Type (Typ1));
 485    end Check_Shift;
 486
 487    ------------
 488    -- Errint --
 489    ------------
 490
 491    procedure Errint
 492      (Msg : String; S : Node_Id; N : Node_Id; Relaxed : Boolean := False) is
 493    begin
 494       --  Ignore errors on Intrinsic in Relaxed_RM_Semantics mode where we can
 495       --  be more liberal.
 496
 497       if not (Relaxed and Relaxed_RM_Semantics) then
 498          Error_Msg_N (Msg, S);
 499          Error_Msg_N ("incorrect intrinsic subprogram, see spec", N);
 500       end if;
 501    end Errint;
 502
 503 end Sem_Intr;