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