1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
11 -- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
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. --
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). --
27 ------------------------------------------------------------------------------
29 -- Processing for intrinsic subprogram declarations
31 with Atree
; use Atree
;
32 with Einfo
; use Einfo
;
33 with Errout
; use Errout
;
34 with Fname
; use Fname
;
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
;
46 package body Sem_Intr
is
48 -----------------------
49 -- Local Subprograms --
50 -----------------------
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.
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.
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)
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.
73 ------------------------------
74 -- Check_Exception_Function --
75 ------------------------------
77 procedure Check_Exception_Function
(E
: Entity_Id
; N
: Node_Id
) is
79 if Ekind
(E
) /= E_Function
80 and then Ekind
(E
) /= E_Generic_Function
83 ("intrinsic exception subprogram must be a function", E
, N
);
85 elsif Present
(First_Formal
(E
)) then
87 ("intrinsic exception subprogram may not have parameters",
91 elsif Etype
(E
) /= Standard_String
then
93 ("return type of exception subprogram must be String", E
, N
);
96 end Check_Exception_Function
;
98 --------------------------
99 -- Check_Intrinsic_Call --
100 --------------------------
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
);
108 -- For Import_xxx calls, argument must be static string
110 if Cnam
= Name_Import_Address
112 Cnam
= Name_Import_Largest_Value
114 Cnam
= Name_Import_Value
116 if Etype
(Arg1
) = Any_Type
117 or else Raises_Constraint_Error
(Arg1
)
121 elsif not Is_Static_Expression
(Arg1
) then
123 ("call to & requires static string argument", N
, Nam
);
125 elsif String_Length
(Strval
(Expr_Value_S
(Arg1
))) = 0 then
127 ("call to & does not permit null string", N
, Nam
);
129 elsif OpenVMS_On_Target
130 and then String_Length
(Strval
(Expr_Value_S
(Arg1
))) > 31
133 ("argument in call to & must be 31 characters or less", N
, Nam
);
136 -- For now, no other special checks are required
141 end Check_Intrinsic_Call
;
143 ------------------------------
144 -- Check_Intrinsic_Operator --
145 ------------------------------
147 procedure Check_Intrinsic_Operator
(E
: Entity_Id
; N
: Node_Id
) is
148 Nam
: Name_Id
:= Chars
(E
);
151 Ret
: constant Entity_Id
:= Etype
(E
);
155 or else Nam
= Name_Op_Subtract
156 or else Nam
= Name_Op_Multiply
157 or else Nam
= Name_Op_Divide
159 T1
:= Etype
(First_Formal
(E
));
161 if No
(Next_Formal
(First_Formal
(E
))) then
163 -- previous error in declaration.
167 T2
:= Etype
(Next_Formal
(First_Formal
(E
)));
170 if Root_Type
(T1
) /= Root_Type
(T2
)
171 or else Root_Type
(T1
) /= Root_Type
(Ret
)
174 "types of intrinsic operator must have the same size", E
, N
);
176 elsif not Is_Numeric_Type
(T1
) then
178 " intrinsic operator can only apply to numeric types", E
, N
);
182 Errint
("incorrect context for ""Intrinsic"" convention", E
, N
);
184 end Check_Intrinsic_Operator
;
186 --------------------------------
187 -- Check_Intrinsic_Subprogram --
188 --------------------------------
190 procedure Check_Intrinsic_Subprogram
(E
: Entity_Id
; N
: Node_Id
) is
191 Spec
: constant Node_Id
:= Specification
(Unit_Declaration_Node
(E
));
196 and then Present
(Generic_Parent
(Spec
))
198 Nam
:= Chars
(Generic_Parent
(Spec
));
203 -- Check name is valid intrinsic name
205 Get_Name_String
(Nam
);
207 if Name_Buffer
(1) /= 'O'
208 and then Nam
/= Name_Asm
209 and then Nam
not in First_Intrinsic_Name
.. Last_Intrinsic_Name
211 Errint
("unrecognized intrinsic subprogram", E
, N
);
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!
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
)))
224 -- Shift cases. We allow user specification of intrinsic shift
225 -- operators for any numeric types.
228 Nam
= Name_Rotate_Left
230 Nam
= Name_Rotate_Right
232 Nam
= Name_Shift_Left
234 Nam
= Name_Shift_Right
236 Nam
= Name_Shift_Right_Arithmetic
241 Nam
= Name_Exception_Information
243 Nam
= Name_Exception_Message
245 Nam
= Name_Exception_Name
247 Check_Exception_Function
(E
, N
);
249 elsif Nkind
(E
) = N_Defining_Operator_Symbol
then
250 Check_Intrinsic_Operator
(E
, N
);
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
259 -- For now, no other intrinsic subprograms are recognized in user code
262 Errint
("incorrect context for ""Intrinsic"" convention", E
, N
);
264 end Check_Intrinsic_Subprogram
;
270 procedure Check_Shift
(E
: Entity_Id
; N
: Node_Id
) is
280 if Ekind
(E
) /= E_Function
281 and then Ekind
(E
) /= E_Generic_Function
283 Errint
("intrinsic shift subprogram must be a function", E
, N
);
287 Arg1
:= First_Formal
(E
);
289 if Present
(Arg1
) then
290 Arg2
:= Next_Formal
(Arg1
);
295 if Arg1
= Empty
or else Arg2
= Empty
then
296 Errint
("intrinsic shift function must have two arguments", E
, N
);
300 Typ1
:= Etype
(Arg1
);
301 Typ2
:= Etype
(Arg2
);
303 Ptyp1
:= Parameter_Type
(Parent
(Arg1
));
304 Ptyp2
:= Parameter_Type
(Parent
(Arg2
));
306 if not Is_Integer_Type
(Typ1
) then
307 Errint
("first argument to shift must be integer type", Ptyp1
, N
);
311 if Typ2
/= Standard_Natural
then
312 Errint
("second argument to shift must be type Natural", Ptyp2
, N
);
316 Size
:= UI_To_Int
(Esize
(Typ1
));
324 ("first argument for shift must have size 8, 16, 32 or 64",
328 elsif Is_Modular_Integer_Type
(Typ1
)
329 and then Non_Binary_Modulus
(Typ1
)
332 ("shifts not allowed for non-binary modular types",
335 elsif Etype
(Arg1
) /= Etype
(E
) then
337 ("first argument of shift must match return type", Ptyp1
, N
);
346 procedure Errint
(Msg
: String; S
: Node_Id
; N
: Node_Id
) is
348 Error_Msg_N
(Msg
, S
);
349 Error_Msg_N
("incorrect intrinsic subprogram, see spec", N
);