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-2005, 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 2,  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 COPYING.  If not, write --
  19 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, USA.                                              --
  21 --                                                                          --
  22 -- GNAT was originally developed  by the GNAT team at  New York University. --
  23 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  24 --                                                                          --
  25 ------------------------------------------------------------------------------
  26
  27 --  Processing for intrinsic subprogram declarations
  28
  29 with Atree;    use Atree;
  30 with Einfo;    use Einfo;
  31 with Errout;   use Errout;
  32 with Fname;    use Fname;
  33 with Lib;      use Lib;
  34 with Namet;    use Namet;
  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
  58    --  that the types involved have the same size.
  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 Ekind (E) /= E_Function
  78         and then Ekind (E) /= E_Generic_Function
  79       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       Cnam : constant Name_Id   := Chars (Nam);
 103       Arg1 : constant Node_Id   := First_Actual (N);
 104
 105    begin
 106       --  For Import_xxx calls, argument must be static string
 107
 108       if Cnam = Name_Import_Address
 109            or else
 110          Cnam = Name_Import_Largest_Value
 111            or else
 112          Cnam = Name_Import_Value
 113       then
 114          if Etype (Arg1) = Any_Type
 115            or else Raises_Constraint_Error (Arg1)
 116          then
 117             null;
 118
 119          elsif not Is_Static_Expression (Arg1) then
 120             Error_Msg_FE
 121               ("call to & requires static string argument!", N, Nam);
 122             Why_Not_Static (Arg1);
 123
 124          elsif String_Length (Strval (Expr_Value_S (Arg1))) = 0 then
 125             Error_Msg_NE
 126               ("call to & does not permit null string", N, Nam);
 127
 128          elsif OpenVMS_On_Target
 129            and then String_Length (Strval (Expr_Value_S (Arg1))) > 31
 130          then
 131             Error_Msg_NE
 132               ("argument in call to & must be 31 characters or less", N, Nam);
 133          end if;
 134
 135       --  Check for the case of freeing a non-null object which will raise
 136       --  Constaint_Error. Issue warning here, do the expansion in Exp_Intr.
 137
 138       elsif Cnam = Name_Free
 139         and then Can_Never_Be_Null (Etype (Arg1))
 140       then
 141          Error_Msg_N
 142            ("freeing `NOT NULL` object will raise Constraint_Error?", N);
 143
 144       --  For now, no other special checks are required
 145
 146       else
 147          return;
 148       end if;
 149    end Check_Intrinsic_Call;
 150
 151    ------------------------------
 152    -- Check_Intrinsic_Operator --
 153    ------------------------------
 154
 155    procedure Check_Intrinsic_Operator (E : Entity_Id; N : Node_Id) is
 156       Ret : constant Entity_Id := Etype (E);
 157       Nam : constant Name_Id   := Chars (E);
 158       T1  : Entity_Id;
 159       T2  : Entity_Id;
 160
 161    begin
 162       --  Aritnmetic operators
 163
 164       if Nam = Name_Op_Add
 165            or else
 166          Nam = Name_Op_Subtract
 167            or else
 168          Nam = Name_Op_Multiply
 169            or else
 170          Nam = Name_Op_Divide
 171            or else
 172          Nam = Name_Op_Rem
 173            or else
 174          Nam = Name_Op_Mod
 175            or else
 176          Nam = Name_Op_Abs
 177       then
 178          T1 := Etype (First_Formal (E));
 179
 180          if No (Next_Formal (First_Formal (E))) then
 181
 182             if Nam = Name_Op_Add
 183                  or else
 184                Nam = Name_Op_Subtract
 185                  or else
 186                Nam = Name_Op_Abs
 187             then
 188                T2 := T1;
 189
 190             else
 191                --  Previous error in declaration
 192
 193                return;
 194             end if;
 195
 196          else
 197             T2 := Etype (Next_Formal (First_Formal (E)));
 198          end if;
 199
 200          if Root_Type (T1) /= Root_Type (T2)
 201            or else Root_Type (T1) /= Root_Type (Ret)
 202          then
 203             Errint
 204               ("types of intrinsic operator must have the same size", E, N);
 205          end if;
 206
 207       --  Comparison operators
 208
 209       elsif Nam = Name_Op_Eq
 210               or else
 211             Nam = Name_Op_Ge
 212               or else
 213             Nam = Name_Op_Gt
 214               or else
 215             Nam = Name_Op_Le
 216               or else
 217             Nam = Name_Op_Lt
 218               or else
 219             Nam = Name_Op_Ne
 220       then
 221          T1 := Etype (First_Formal (E));
 222
 223          if No (Next_Formal (First_Formal (E))) then
 224
 225             --  Previous error in declaration
 226
 227             return;
 228
 229          else
 230             T2 := Etype (Next_Formal (First_Formal (E)));
 231          end if;
 232
 233          if Root_Type (T1) /= Root_Type (T2) then
 234             Errint
 235               ("types of intrinsic operator must have the same size", E, N);
 236          end if;
 237
 238          if Root_Type (Ret) /= Standard_Boolean then
 239             Errint
 240               ("result type of intrinsic comparison must be boolean", E, N);
 241          end if;
 242
 243       --  Exponentiation
 244
 245       elsif Nam = Name_Op_Expon then
 246          T1 := Etype (First_Formal (E));
 247
 248          if No (Next_Formal (First_Formal (E))) then
 249
 250             --  Previous error in declaration
 251
 252             return;
 253
 254          else
 255             T2 := Etype (Next_Formal (First_Formal (E)));
 256          end if;
 257
 258          if not (Is_Integer_Type (T1)
 259                    or else
 260                  Is_Floating_Point_Type (T1))
 261            or else Root_Type (T1) /= Root_Type (Ret)
 262            or else Root_Type (T2) /= Root_Type (Standard_Integer)
 263          then
 264             Errint ("incorrect operands for intrinsic operator", N, E);
 265          end if;
 266
 267       --  All other operators (are there any?) are not handled
 268
 269       else
 270          Errint ("incorrect context for ""Intrinsic"" convention", E, N);
 271          return;
 272       end if;
 273
 274       if not Is_Numeric_Type (T1) then
 275          Errint ("intrinsic operator can only apply to numeric types", E, N);
 276       end if;
 277    end Check_Intrinsic_Operator;
 278
 279    --------------------------------
 280    -- Check_Intrinsic_Subprogram --
 281    --------------------------------
 282
 283    procedure Check_Intrinsic_Subprogram (E : Entity_Id; N : Node_Id) is
 284       Spec : constant Node_Id := Specification (Unit_Declaration_Node (E));
 285       Nam  : Name_Id;
 286
 287    begin
 288       if Present (Spec)
 289         and then Present (Generic_Parent (Spec))
 290       then
 291          Nam := Chars (Generic_Parent (Spec));
 292       else
 293          Nam := Chars (E);
 294       end if;
 295
 296       --  Check name is valid intrinsic name
 297
 298       Get_Name_String (Nam);
 299
 300       if Name_Buffer (1) /= 'O'
 301         and then Nam /= Name_Asm
 302         and then Nam /= Name_To_Address
 303         and then Nam not in First_Intrinsic_Name .. Last_Intrinsic_Name
 304       then
 305          Errint ("unrecognized intrinsic subprogram", E, N);
 306
 307       --  We always allow intrinsic specifications in language defined units
 308       --  and in expanded code. We assume that the GNAT implemetors know what
 309       --  they are doing, and do not write or generate junk use of intrinsic!
 310
 311       elsif not Comes_From_Source (E)
 312         or else not Comes_From_Source (N)
 313         or else Is_Predefined_File_Name
 314                   (Unit_File_Name (Get_Source_Unit (N)))
 315       then
 316          null;
 317
 318       --  Shift cases. We allow user specification of intrinsic shift
 319       --  operators for any numeric types.
 320
 321       elsif
 322         Nam = Name_Rotate_Left
 323           or else
 324         Nam = Name_Rotate_Right
 325           or else
 326         Nam = Name_Shift_Left
 327           or else
 328         Nam = Name_Shift_Right
 329           or else
 330         Nam = Name_Shift_Right_Arithmetic
 331       then
 332          Check_Shift (E, N);
 333
 334       elsif
 335         Nam = Name_Exception_Information
 336           or else
 337         Nam = Name_Exception_Message
 338           or else
 339         Nam = Name_Exception_Name
 340       then
 341          Check_Exception_Function (E, N);
 342
 343       elsif Nkind (E) = N_Defining_Operator_Symbol then
 344          Check_Intrinsic_Operator (E, N);
 345
 346       elsif Nam = Name_File
 347         or else Nam = Name_Line
 348         or else Nam = Name_Source_Location
 349         or else Nam = Name_Enclosing_Entity
 350       then
 351          null;
 352
 353       --  For now, no other intrinsic subprograms are recognized in user code
 354
 355       else
 356          Errint ("incorrect context for ""Intrinsic"" convention", E, N);
 357       end if;
 358    end Check_Intrinsic_Subprogram;
 359
 360    -----------------
 361    -- Check_Shift --
 362    -----------------
 363
 364    procedure Check_Shift (E : Entity_Id; N : Node_Id) is
 365       Arg1  : Node_Id;
 366       Arg2  : Node_Id;
 367       Size  : Nat;
 368       Typ1  : Entity_Id;
 369       Typ2  : Entity_Id;
 370       Ptyp1 : Node_Id;
 371       Ptyp2 : Node_Id;
 372
 373    begin
 374       if Ekind (E) /= E_Function
 375         and then Ekind (E) /= E_Generic_Function
 376       then
 377          Errint ("intrinsic shift subprogram must be a function", E, N);
 378          return;
 379       end if;
 380
 381       Arg1 := First_Formal (E);
 382
 383       if Present (Arg1) then
 384          Arg2 := Next_Formal (Arg1);
 385       else
 386          Arg2 := Empty;
 387       end if;
 388
 389       if Arg1 = Empty or else Arg2 = Empty then
 390          Errint ("intrinsic shift function must have two arguments", E, N);
 391          return;
 392       end if;
 393
 394       Typ1 := Etype (Arg1);
 395       Typ2 := Etype (Arg2);
 396
 397       Ptyp1 := Parameter_Type (Parent (Arg1));
 398       Ptyp2 := Parameter_Type (Parent (Arg2));
 399
 400       if not Is_Integer_Type (Typ1) then
 401          Errint ("first argument to shift must be integer type", Ptyp1, N);
 402          return;
 403       end if;
 404
 405       if Typ2 /= Standard_Natural then
 406          Errint ("second argument to shift must be type Natural", Ptyp2, N);
 407          return;
 408       end if;
 409
 410       Size := UI_To_Int (Esize (Typ1));
 411
 412       if Size /= 8
 413         and then Size /= 16
 414         and then Size /= 32
 415         and then Size /= 64
 416       then
 417          Errint
 418            ("first argument for shift must have size 8, 16, 32 or 64",
 419              Ptyp1, N);
 420          return;
 421
 422       elsif Is_Modular_Integer_Type (Typ1)
 423         and then Non_Binary_Modulus (Typ1)
 424       then
 425          Errint
 426            ("shifts not allowed for non-binary modular types",
 427             Ptyp1, N);
 428
 429       elsif Etype (Arg1) /= Etype (E) then
 430          Errint
 431            ("first argument of shift must match return type", Ptyp1, N);
 432          return;
 433       end if;
 434    end Check_Shift;
 435
 436    ------------
 437    -- Errint --
 438    ------------
 439
 440    procedure Errint (Msg : String; S : Node_Id; N : Node_Id) is
 441    begin
 442       Error_Msg_N (Msg, S);
 443       Error_Msg_N ("incorrect intrinsic subprogram, see spec", N);
 444    end Errint;
 445
 446 end Sem_Intr;