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