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-2003 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
29with Atree;    use Atree;
30with Einfo;    use Einfo;
31with Errout;   use Errout;
32with Fname;    use Fname;
33with Lib;      use Lib;
34with Namet;    use Namet;
35with Sem_Eval; use Sem_Eval;
36with Sem_Util; use Sem_Util;
37with Sinfo;    use Sinfo;
38with Snames;   use Snames;
39with Stand;    use Stand;
40with Stringt;  use Stringt;
41with Targparm; use Targparm;
42with Uintp;    use Uintp;
43
44package 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_FE
121              ("call to & requires static string argument!", N, Nam);
122            Why_Not_Static (Arg1);
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   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 /= Name_To_Address
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
437end Sem_Intr;
438