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