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