1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
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. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 -- Processing for intrinsic subprogram declarations
29 with Atree; use Atree;
30 with Einfo; use Einfo;
31 with Errout; use Errout;
32 with Fname; use Fname;
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;
44 package body Sem_Intr is
46 -----------------------
47 -- Local Subprograms --
48 -----------------------
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.
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.
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)
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.
71 ------------------------------
72 -- Check_Exception_Function --
73 ------------------------------
75 procedure Check_Exception_Function (E : Entity_Id; N : Node_Id) is
77 if Ekind (E) /= E_Function
78 and then Ekind (E) /= E_Generic_Function
81 ("intrinsic exception subprogram must be a function", E, N);
83 elsif Present (First_Formal (E)) then
85 ("intrinsic exception subprogram may not have parameters",
89 elsif Etype (E) /= Standard_String then
91 ("return type of exception subprogram must be String", E, N);
94 end Check_Exception_Function;
96 --------------------------
97 -- Check_Intrinsic_Call --
98 --------------------------
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);
106 -- For Import_xxx calls, argument must be static string
108 if Cnam = Name_Import_Address
110 Cnam = Name_Import_Largest_Value
112 Cnam = Name_Import_Value
114 if Etype (Arg1) = Any_Type
115 or else Raises_Constraint_Error (Arg1)
119 elsif not Is_Static_Expression (Arg1) then
121 ("call to & requires static string argument!", N, Nam);
122 Why_Not_Static (Arg1);
124 elsif String_Length (Strval (Expr_Value_S (Arg1))) = 0 then
126 ("call to & does not permit null string", N, Nam);
128 elsif OpenVMS_On_Target
129 and then String_Length (Strval (Expr_Value_S (Arg1))) > 31
132 ("argument in call to & must be 31 characters or less", N, Nam);
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.
138 elsif Cnam = Name_Free
139 and then Can_Never_Be_Null (Etype (Arg1))
142 ("freeing `NOT NULL` object will raise Constraint_Error?", N);
144 -- For now, no other special checks are required
149 end Check_Intrinsic_Call;
151 ------------------------------
152 -- Check_Intrinsic_Operator --
153 ------------------------------
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);
162 -- Aritnmetic operators
166 Nam = Name_Op_Subtract
168 Nam = Name_Op_Multiply
178 T1 := Etype (First_Formal (E));
180 if No (Next_Formal (First_Formal (E))) then
184 Nam = Name_Op_Subtract
191 -- Previous error in declaration
197 T2 := Etype (Next_Formal (First_Formal (E)));
200 if Root_Type (T1) /= Root_Type (T2)
201 or else Root_Type (T1) /= Root_Type (Ret)
204 ("types of intrinsic operator must have the same size", E, N);
207 -- Comparison operators
209 elsif Nam = Name_Op_Eq
221 T1 := Etype (First_Formal (E));
223 if No (Next_Formal (First_Formal (E))) then
225 -- Previous error in declaration
230 T2 := Etype (Next_Formal (First_Formal (E)));
233 if Root_Type (T1) /= Root_Type (T2) then
235 ("types of intrinsic operator must have the same size", E, N);
238 if Root_Type (Ret) /= Standard_Boolean then
240 ("result type of intrinsic comparison must be boolean", E, N);
245 elsif Nam = Name_Op_Expon then
246 T1 := Etype (First_Formal (E));
248 if No (Next_Formal (First_Formal (E))) then
250 -- Previous error in declaration
255 T2 := Etype (Next_Formal (First_Formal (E)));
258 if not (Is_Integer_Type (T1)
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)
264 Errint ("incorrect operands for intrinsic operator", N, E);
267 -- All other operators (are there any?) are not handled
270 Errint ("incorrect context for ""Intrinsic"" convention", E, N);
274 if not Is_Numeric_Type (T1) then
275 Errint ("intrinsic operator can only apply to numeric types", E, N);
277 end Check_Intrinsic_Operator;
279 --------------------------------
280 -- Check_Intrinsic_Subprogram --
281 --------------------------------
283 procedure Check_Intrinsic_Subprogram (E : Entity_Id; N : Node_Id) is
284 Spec : constant Node_Id := Specification (Unit_Declaration_Node (E));
289 and then Present (Generic_Parent (Spec))
291 Nam := Chars (Generic_Parent (Spec));
296 -- Check name is valid intrinsic name
298 Get_Name_String (Nam);
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
305 Errint ("unrecognized intrinsic subprogram", E, N);
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!
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)))
318 -- Shift cases. We allow user specification of intrinsic shift
319 -- operators for any numeric types.
322 Nam = Name_Rotate_Left
324 Nam = Name_Rotate_Right
326 Nam = Name_Shift_Left
328 Nam = Name_Shift_Right
330 Nam = Name_Shift_Right_Arithmetic
335 Nam = Name_Exception_Information
337 Nam = Name_Exception_Message
339 Nam = Name_Exception_Name
341 Check_Exception_Function (E, N);
343 elsif Nkind (E) = N_Defining_Operator_Symbol then
344 Check_Intrinsic_Operator (E, N);
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
353 -- For now, no other intrinsic subprograms are recognized in user code
356 Errint ("incorrect context for ""Intrinsic"" convention", E, N);
358 end Check_Intrinsic_Subprogram;
364 procedure Check_Shift (E : Entity_Id; N : Node_Id) is
374 if Ekind (E) /= E_Function
375 and then Ekind (E) /= E_Generic_Function
377 Errint ("intrinsic shift subprogram must be a function", E, N);
381 Arg1 := First_Formal (E);
383 if Present (Arg1) then
384 Arg2 := Next_Formal (Arg1);
389 if Arg1 = Empty or else Arg2 = Empty then
390 Errint ("intrinsic shift function must have two arguments", E, N);
394 Typ1 := Etype (Arg1);
395 Typ2 := Etype (Arg2);
397 Ptyp1 := Parameter_Type (Parent (Arg1));
398 Ptyp2 := Parameter_Type (Parent (Arg2));
400 if not Is_Integer_Type (Typ1) then
401 Errint ("first argument to shift must be integer type", Ptyp1, N);
405 if Typ2 /= Standard_Natural then
406 Errint ("second argument to shift must be type Natural", Ptyp2, N);
410 Size := UI_To_Int (Esize (Typ1));
418 ("first argument for shift must have size 8, 16, 32 or 64",
422 elsif Is_Modular_Integer_Type (Typ1)
423 and then Non_Binary_Modulus (Typ1)
426 ("shifts not allowed for non-binary modular types",
429 elsif Etype (Arg1) /= Etype (E) then
431 ("first argument of shift must match return type", Ptyp1, N);
440 procedure Errint (Msg : String; S : Node_Id; N : Node_Id) is
442 Error_Msg_N (Msg, S);
443 Error_Msg_N ("incorrect intrinsic subprogram, see spec", N);