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 --                                                                          --
  10 --          Copyright (C) 1992-2001 Free Software Foundation, Inc.          --
  11 --                                                                          --
  12 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  13 -- terms of the  GNU General Public License as published  by the Free Soft- --
  14 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  15 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  16 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  17 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  18 -- for  more details.  You should have  received  a copy of the GNU General --
  19 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  20 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  21 -- MA 02111-1307, USA.                                                      --
  22 --                                                                          --
  23 -- GNAT was originally developed  by the GNAT team at  New York University. --
  24 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
  25 --                                                                          --
  26 ------------------------------------------------------------------------------
  27
  28 --  Processing for intrinsic subprogram declarations
  29
  30 with Atree;    use Atree;
  31 with Einfo;    use Einfo;
  32 with Errout;   use Errout;
  33 with Fname;    use Fname;
  34 with Lib;      use Lib;
  35 with Namet;    use Namet;
  36 with Sem_Eval; use Sem_Eval;
  37 with Sem_Util; use Sem_Util;
  38 with Sinfo;    use Sinfo;
  39 with Snames;   use Snames;
  40 with Stand;    use Stand;
  41 with Stringt;  use Stringt;
  42 with Targparm; use Targparm;
  43 with Uintp;    use Uintp;
  44
  45 package body Sem_Intr is
  46
  47    -----------------------
  48    -- Local Subprograms --
  49    -----------------------
  50
  51    procedure Check_Exception_Function (E : Entity_Id; N : Node_Id);
  52    --  Check use of intrinsic Exception_Message, Exception_Info or
  53    --  Exception_Name, as used in the DEC compatible Current_Exceptions
  54    --  package. In each case we must have a parameterless function that
  55    --  returns type String.
  56
  57    procedure Check_Intrinsic_Operator (E : Entity_Id; N : Node_Id);
  58    --  Check that operator is one of the binary arithmetic operators, and
  59    --  that the types involved have the same size.
  60
  61    procedure Check_Shift (E : Entity_Id; N : Node_Id);
  62    --  Check intrinsic shift subprogram, the two arguments are the same
  63    --  as for Check_Intrinsic_Subprogram (i.e. the entity of the subprogram
  64    --  declaration, and the node for the pragma argument, used for messages)
  65
  66    procedure Errint (Msg : String; S : Node_Id; N : Node_Id);
  67    --  Post error message for bad intrinsic, the message itself is posted
  68    --  on the appropriate spec node and another message is placed on the
  69    --  pragma itself, referring to the spec. S is the node in the spec on
  70    --  which the message is to be placed, and N is the pragma argument node.
  71
  72    ------------------------------
  73    -- Check_Exception_Function --
  74    ------------------------------
  75
  76    procedure Check_Exception_Function (E : Entity_Id; N : Node_Id) is
  77    begin
  78       if Ekind (E) /= E_Function
  79         and then Ekind (E) /= E_Generic_Function
  80       then
  81          Errint
  82            ("intrinsic exception subprogram must be a function", E, N);
  83
  84       elsif Present (First_Formal (E)) then
  85          Errint
  86            ("intrinsic exception subprogram may not have parameters",
  87             E, First_Formal (E));
  88          return;
  89
  90       elsif Etype (E) /= Standard_String then
  91          Errint
  92            ("return type of exception subprogram must be String", E, N);
  93          return;
  94       end if;
  95    end Check_Exception_Function;
  96
  97    --------------------------
  98    -- Check_Intrinsic_Call --
  99    --------------------------
 100
 101    procedure Check_Intrinsic_Call (N : Node_Id) is
 102       Nam  : constant Entity_Id := Entity (Name (N));
 103       Cnam : constant Name_Id   := Chars (Nam);
 104       Arg1 : constant Node_Id   := First_Actual (N);
 105
 106    begin
 107       --  For Import_xxx calls, argument must be static string
 108
 109       if Cnam = Name_Import_Address
 110            or else
 111          Cnam = Name_Import_Largest_Value
 112            or else
 113          Cnam = Name_Import_Value
 114       then
 115          if Etype (Arg1) = Any_Type
 116            or else Raises_Constraint_Error (Arg1)
 117          then
 118             null;
 119
 120          elsif not Is_Static_Expression (Arg1) then
 121             Error_Msg_NE
 122               ("call to & requires static string argument", N, Nam);
 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       --  For now, no other special checks are required
 136
 137       else
 138          return;
 139       end if;
 140    end Check_Intrinsic_Call;
 141
 142    ------------------------------
 143    -- Check_Intrinsic_Operator --
 144    ------------------------------
 145
 146    procedure Check_Intrinsic_Operator (E : Entity_Id; N : Node_Id) is
 147       Ret : constant Entity_Id := Etype (E);
 148       Nam : constant Name_Id   := Chars (E);
 149       T1  : Entity_Id;
 150       T2  : Entity_Id;
 151
 152    begin
 153       --  Aritnmetic operators
 154
 155       if Nam = Name_Op_Add
 156            or else
 157          Nam = Name_Op_Subtract
 158            or else
 159          Nam = Name_Op_Multiply
 160            or else
 161          Nam = Name_Op_Divide
 162            or else
 163          Nam = Name_Op_Rem
 164            or else
 165          Nam = Name_Op_Mod
 166            or else
 167          Nam = Name_Op_Abs
 168       then
 169          T1 := Etype (First_Formal (E));
 170
 171          if No (Next_Formal (First_Formal (E))) then
 172
 173             if Nam = Name_Op_Add
 174                  or else
 175                Nam = Name_Op_Subtract
 176                  or else
 177                Nam = Name_Op_Abs
 178             then
 179                T2 := T1;
 180
 181             else
 182                --  Previous error in declaration
 183
 184                return;
 185             end if;
 186
 187          else
 188             T2 := Etype (Next_Formal (First_Formal (E)));
 189          end if;
 190
 191          if Root_Type (T1) /= Root_Type (T2)
 192            or else Root_Type (T1) /= Root_Type (Ret)
 193          then
 194             Errint
 195               ("types of intrinsic operator must have the same size", E, N);
 196          end if;
 197
 198       --  Comparison operators
 199
 200       elsif Nam = Name_Op_Eq
 201               or else
 202             Nam = Name_Op_Ge
 203               or else
 204             Nam = Name_Op_Gt
 205               or else
 206             Nam = Name_Op_Le
 207               or else
 208             Nam = Name_Op_Lt
 209               or else
 210             Nam = Name_Op_Ne
 211       then
 212          T1 := Etype (First_Formal (E));
 213
 214          if No (Next_Formal (First_Formal (E))) then
 215
 216             --  Previous error in declaration
 217
 218             return;
 219
 220          else
 221             T2 := Etype (Next_Formal (First_Formal (E)));
 222          end if;
 223
 224          if Root_Type (T1) /= Root_Type (T2) then
 225             Errint
 226               ("types of intrinsic operator must have the same size", E, N);
 227          end if;
 228
 229          if Root_Type (Ret) /= Standard_Boolean then
 230             Errint
 231               ("result type of intrinsic comparison must be boolean", E, N);
 232          end if;
 233
 234       --  Exponentiation
 235
 236       elsif Nam = Name_Op_Expon then
 237          T1 := Etype (First_Formal (E));
 238
 239          if No (Next_Formal (First_Formal (E))) then
 240
 241             --  Previous error in declaration
 242
 243             return;
 244
 245          else
 246             T2 := Etype (Next_Formal (First_Formal (E)));
 247          end if;
 248
 249          if not (Is_Integer_Type (T1)
 250                    or else
 251                  Is_Floating_Point_Type (T1))
 252            or else Root_Type (T1) /= Root_Type (Ret)
 253            or else Root_Type (T2) /= Root_Type (Standard_Integer)
 254          then
 255             Errint ("incorrect operands for intrinsic operator", N, E);
 256          end if;
 257
 258       --  All other operators (are there any?) are not handled
 259
 260       else
 261          Errint ("incorrect context for ""Intrinsic"" convention", E, N);
 262          return;
 263       end if;
 264
 265       if not Is_Numeric_Type (T1) then
 266          Errint ("intrinsic operator can only apply to numeric types", E, N);
 267       end if;
 268
 269    end Check_Intrinsic_Operator;
 270
 271    --------------------------------
 272    -- Check_Intrinsic_Subprogram --
 273    --------------------------------
 274
 275    procedure Check_Intrinsic_Subprogram (E : Entity_Id; N : Node_Id) is
 276       Spec : constant Node_Id := Specification (Unit_Declaration_Node (E));
 277       Nam  : Name_Id;
 278
 279    begin
 280       if Present (Spec)
 281         and then Present (Generic_Parent (Spec))
 282       then
 283          Nam := Chars (Generic_Parent (Spec));
 284       else
 285          Nam := Chars (E);
 286       end if;
 287
 288       --  Check name is valid intrinsic name
 289
 290       Get_Name_String (Nam);
 291
 292       if Name_Buffer (1) /= 'O'
 293         and then Nam /= Name_Asm
 294         and then Nam not in First_Intrinsic_Name .. Last_Intrinsic_Name
 295       then
 296          Errint ("unrecognized intrinsic subprogram", E, N);
 297
 298       --  We always allow intrinsic specifications in language defined units
 299       --  and in expanded code. We assume that the GNAT implemetors know what
 300       --  they are doing, and do not write or generate junk use of intrinsic!
 301
 302       elsif not Comes_From_Source (E)
 303         or else not Comes_From_Source (N)
 304         or else Is_Predefined_File_Name
 305                   (Unit_File_Name (Get_Source_Unit (N)))
 306       then
 307          null;
 308
 309       --  Shift cases. We allow user specification of intrinsic shift
 310       --  operators for any numeric types.
 311
 312       elsif
 313         Nam = Name_Rotate_Left
 314           or else
 315         Nam = Name_Rotate_Right
 316           or else
 317         Nam = Name_Shift_Left
 318           or else
 319         Nam = Name_Shift_Right
 320           or else
 321         Nam = Name_Shift_Right_Arithmetic
 322       then
 323          Check_Shift (E, N);
 324
 325       elsif
 326         Nam = Name_Exception_Information
 327           or else
 328         Nam = Name_Exception_Message
 329           or else
 330         Nam = Name_Exception_Name
 331       then
 332          Check_Exception_Function (E, N);
 333
 334       elsif Nkind (E) = N_Defining_Operator_Symbol then
 335          Check_Intrinsic_Operator (E, N);
 336
 337       elsif Nam = Name_File
 338         or else Nam = Name_Line
 339         or else Nam = Name_Source_Location
 340         or else Nam = Name_Enclosing_Entity
 341       then
 342          null;
 343
 344       --  For now, no other intrinsic subprograms are recognized in user code
 345
 346       else
 347          Errint ("incorrect context for ""Intrinsic"" convention", E, N);
 348       end if;
 349    end Check_Intrinsic_Subprogram;
 350
 351    -----------------
 352    -- Check_Shift --
 353    -----------------
 354
 355    procedure Check_Shift (E : Entity_Id; N : Node_Id) is
 356       Arg1  : Node_Id;
 357       Arg2  : Node_Id;
 358       Size  : Nat;
 359       Typ1  : Entity_Id;
 360       Typ2  : Entity_Id;
 361       Ptyp1 : Node_Id;
 362       Ptyp2 : Node_Id;
 363
 364    begin
 365       if Ekind (E) /= E_Function
 366         and then Ekind (E) /= E_Generic_Function
 367       then
 368          Errint ("intrinsic shift subprogram must be a function", E, N);
 369          return;
 370       end if;
 371
 372       Arg1 := First_Formal (E);
 373
 374       if Present (Arg1) then
 375          Arg2 := Next_Formal (Arg1);
 376       else
 377          Arg2 := Empty;
 378       end if;
 379
 380       if Arg1 = Empty or else Arg2 = Empty then
 381          Errint ("intrinsic shift function must have two arguments", E, N);
 382          return;
 383       end if;
 384
 385       Typ1 := Etype (Arg1);
 386       Typ2 := Etype (Arg2);
 387
 388       Ptyp1 := Parameter_Type (Parent (Arg1));
 389       Ptyp2 := Parameter_Type (Parent (Arg2));
 390
 391       if not Is_Integer_Type (Typ1) then
 392          Errint ("first argument to shift must be integer type", Ptyp1, N);
 393          return;
 394       end if;
 395
 396       if Typ2 /= Standard_Natural then
 397          Errint ("second argument to shift must be type Natural", Ptyp2, N);
 398          return;
 399       end if;
 400
 401       Size := UI_To_Int (Esize (Typ1));
 402
 403       if Size /= 8
 404         and then Size /= 16
 405         and then Size /= 32
 406         and then Size /= 64
 407       then
 408          Errint
 409            ("first argument for shift must have size 8, 16, 32 or 64",
 410              Ptyp1, N);
 411          return;
 412
 413       elsif Is_Modular_Integer_Type (Typ1)
 414         and then Non_Binary_Modulus (Typ1)
 415       then
 416          Errint
 417            ("shifts not allowed for non-binary modular types",
 418             Ptyp1, N);
 419
 420       elsif Etype (Arg1) /= Etype (E) then
 421          Errint
 422            ("first argument of shift must match return type", Ptyp1, N);
 423          return;
 424       end if;
 425    end Check_Shift;
 426
 427    ------------
 428    -- Errint --
 429    ------------
 430
 431    procedure Errint (Msg : String; S : Node_Id; N : Node_Id) is
 432    begin
 433       Error_Msg_N (Msg, S);
 434       Error_Msg_N ("incorrect intrinsic subprogram, see spec", N);
 435    end Errint;
 436
 437 end Sem_Intr;