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