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