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-2010, 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_Eval; use Sem_Eval;
  35 with Sem_Util; use Sem_Util;
  36 with Sinfo;    use Sinfo;
  37 with Snames;   use Snames;
  38 with Stand;    use Stand;
  39 with Stringt;  use Stringt;
  40 with Targparm; use Targparm;
  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       Cnam : constant Name_Id   := Chars (Nam);
 100       Arg1 : constant Node_Id   := First_Actual (N);
 101
 102    begin
 103       --  For Import_xxx calls, argument must be static string. A string
 104       --  literal is legal even in Ada83 mode, where such literals are
 105       --  not static.
 106
 107       if Cnam = Name_Import_Address
 108            or else
 109          Cnam = Name_Import_Largest_Value
 110            or else
 111          Cnam = Name_Import_Value
 112       then
 113          if Etype (Arg1) = Any_Type
 114            or else Raises_Constraint_Error (Arg1)
 115          then
 116             null;
 117
 118          elsif Nkind (Arg1) /= N_String_Literal
 119            and then not Is_Static_Expression (Arg1)
 120          then
 121             Error_Msg_FE
 122               ("call to & requires static string argument!", N, Nam);
 123             Why_Not_Static (Arg1);
 124
 125          elsif String_Length (Strval (Expr_Value_S (Arg1))) = 0 then
 126             Error_Msg_NE
 127               ("call to & does not permit null string", N, Nam);
 128
 129          elsif OpenVMS_On_Target
 130            and then String_Length (Strval (Expr_Value_S (Arg1))) > 31
 131          then
 132             Error_Msg_NE
 133               ("argument in call to & must be 31 characters or less", N, Nam);
 134          end if;
 135
 136       --  Check for the case of freeing a non-null object which will raise
 137       --  Constraint_Error. Issue warning here, do the expansion in Exp_Intr.
 138
 139       elsif Cnam = Name_Free
 140         and then Can_Never_Be_Null (Etype (Arg1))
 141       then
 142          Error_Msg_N
 143            ("freeing `NOT NULL` object will raise Constraint_Error?", N);
 144
 145       --  For now, no other special checks are required
 146
 147       else
 148          return;
 149       end if;
 150    end Check_Intrinsic_Call;
 151
 152    ------------------------------
 153    -- Check_Intrinsic_Operator --
 154    ------------------------------
 155
 156    procedure Check_Intrinsic_Operator (E : Entity_Id; N : Node_Id) is
 157       Ret : constant Entity_Id := Etype (E);
 158       Nam : constant Name_Id   := Chars (E);
 159       T1  : Entity_Id;
 160       T2  : Entity_Id;
 161
 162    begin
 163       --  Arithmetic operators
 164
 165       if Nam = Name_Op_Add
 166            or else
 167          Nam = Name_Op_Subtract
 168            or else
 169          Nam = Name_Op_Multiply
 170            or else
 171          Nam = Name_Op_Divide
 172            or else
 173          Nam = Name_Op_Rem
 174            or else
 175          Nam = Name_Op_Mod
 176            or else
 177          Nam = Name_Op_Abs
 178       then
 179          T1 := Etype (First_Formal (E));
 180
 181          if No (Next_Formal (First_Formal (E))) then
 182
 183             if Nam = Name_Op_Add
 184                  or else
 185                Nam = Name_Op_Subtract
 186                  or else
 187                Nam = Name_Op_Abs
 188             then
 189                T2 := T1;
 190
 191             else
 192                --  Previous error in declaration
 193
 194                return;
 195             end if;
 196
 197          else
 198             T2 := Etype (Next_Formal (First_Formal (E)));
 199          end if;
 200
 201          if Root_Type (T1) = Root_Type (T2)
 202            or else Root_Type (T1) = Root_Type (Ret)
 203          then
 204             --  Same types, predefined operator will apply
 205
 206             null;
 207
 208          elsif Is_Integer_Type (Underlying_Type (T1))
 209            and then Is_Integer_Type (Underlying_Type (T2))
 210            and then Is_Integer_Type (Underlying_Type (Ret))
 211          then
 212             --  Expansion will introduce conversions if sizes are not equal
 213
 214             null;
 215
 216          else
 217             Errint
 218               ("types of intrinsic operator operands do not match", E, N);
 219          end if;
 220
 221       --  Comparison operators
 222
 223       elsif Nam = Name_Op_Eq
 224               or else
 225             Nam = Name_Op_Ge
 226               or else
 227             Nam = Name_Op_Gt
 228               or else
 229             Nam = Name_Op_Le
 230               or else
 231             Nam = Name_Op_Lt
 232               or else
 233             Nam = Name_Op_Ne
 234       then
 235          T1 := Etype (First_Formal (E));
 236
 237          if No (Next_Formal (First_Formal (E))) then
 238
 239             --  Previous error in declaration
 240
 241             return;
 242
 243          else
 244             T2 := Etype (Next_Formal (First_Formal (E)));
 245          end if;
 246
 247          if Root_Type (T1) /= Root_Type (T2) then
 248             Errint
 249               ("types of intrinsic operator must have the same size", E, N);
 250          end if;
 251
 252          if Root_Type (Ret) /= Standard_Boolean then
 253             Errint
 254               ("result type of intrinsic comparison must be boolean", E, N);
 255          end if;
 256
 257       --  Exponentiation
 258
 259       elsif Nam = Name_Op_Expon then
 260          T1 := Etype (First_Formal (E));
 261
 262          if No (Next_Formal (First_Formal (E))) then
 263
 264             --  Previous error in declaration
 265
 266             return;
 267
 268          else
 269             T2 := Etype (Next_Formal (First_Formal (E)));
 270          end if;
 271
 272          if not (Is_Integer_Type (T1)
 273                    or else
 274                  Is_Floating_Point_Type (T1))
 275            or else Root_Type (T1) /= Root_Type (Ret)
 276            or else Root_Type (T2) /= Root_Type (Standard_Integer)
 277          then
 278             Errint ("incorrect operands for intrinsic operator", N, E);
 279          end if;
 280
 281       --  All other operators (are there any?) are not handled
 282
 283       else
 284          Errint ("incorrect context for ""Intrinsic"" convention", E, N);
 285          return;
 286       end if;
 287
 288       if not Is_Numeric_Type (Underlying_Type (T1)) then
 289          Errint ("intrinsic operator can only apply to numeric types", E, N);
 290       end if;
 291    end Check_Intrinsic_Operator;
 292
 293    --------------------------------
 294    -- Check_Intrinsic_Subprogram --
 295    --------------------------------
 296
 297    procedure Check_Intrinsic_Subprogram (E : Entity_Id; N : Node_Id) is
 298       Spec : constant Node_Id := Specification (Unit_Declaration_Node (E));
 299       Nam  : Name_Id;
 300
 301    begin
 302       if Present (Spec)
 303         and then Present (Generic_Parent (Spec))
 304       then
 305          Nam := Chars (Generic_Parent (Spec));
 306       else
 307          Nam := Chars (E);
 308       end if;
 309
 310       --  Check name is valid intrinsic name
 311
 312       Get_Name_String (Nam);
 313
 314       if Name_Buffer (1) /= 'O'
 315         and then Nam /= Name_Asm
 316         and then Nam /= Name_To_Address
 317         and then Nam not in First_Intrinsic_Name .. Last_Intrinsic_Name
 318       then
 319          Errint ("unrecognized intrinsic subprogram", E, N);
 320
 321       --  We always allow intrinsic specifications in language defined units
 322       --  and in expanded code. We assume that the GNAT implementors know what
 323       --  they are doing, and do not write or generate junk use of intrinsic!
 324
 325       elsif not Comes_From_Source (E)
 326         or else not Comes_From_Source (N)
 327         or else Is_Predefined_File_Name
 328                   (Unit_File_Name (Get_Source_Unit (N)))
 329       then
 330          null;
 331
 332       --  Shift cases. We allow user specification of intrinsic shift
 333       --  operators for any numeric types.
 334
 335       elsif
 336         Nam = Name_Rotate_Left
 337           or else
 338         Nam = Name_Rotate_Right
 339           or else
 340         Nam = Name_Shift_Left
 341           or else
 342         Nam = Name_Shift_Right
 343           or else
 344         Nam = Name_Shift_Right_Arithmetic
 345       then
 346          Check_Shift (E, N);
 347
 348       elsif
 349         Nam = Name_Exception_Information
 350           or else
 351         Nam = Name_Exception_Message
 352           or else
 353         Nam = Name_Exception_Name
 354       then
 355          Check_Exception_Function (E, N);
 356
 357       elsif Nkind (E) = N_Defining_Operator_Symbol then
 358          Check_Intrinsic_Operator (E, N);
 359
 360       elsif Nam = Name_File
 361         or else Nam = Name_Line
 362         or else Nam = Name_Source_Location
 363         or else Nam = Name_Enclosing_Entity
 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       Size := UI_To_Int (Esize (Typ1));
 423
 424       if Size /= 8
 425         and then Size /= 16
 426         and then Size /= 32
 427         and then Size /= 64
 428       then
 429          Errint
 430            ("first argument for shift must have size 8, 16, 32 or 64",
 431              Ptyp1, N);
 432          return;
 433
 434       elsif Non_Binary_Modulus (Typ1) then
 435          Errint
 436            ("shifts not allowed for non-binary modular types",
 437             Ptyp1, N);
 438
 439       elsif Etype (Arg1) /= Etype (E) then
 440          Errint
 441            ("first argument of shift must match return type", Ptyp1, N);
 442          return;
 443       end if;
 444    end Check_Shift;
 445
 446    ------------
 447    -- Errint --
 448    ------------
 449
 450    procedure Errint (Msg : String; S : Node_Id; N : Node_Id) is
 451    begin
 452       Error_Msg_N (Msg, S);
 453       Error_Msg_N ("incorrect intrinsic subprogram, see spec", N);
 454    end Errint;
 455
 456 end Sem_Intr;