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-2012, 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 3,  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 COPYING3.  If not, go to --
19-- http://www.gnu.org/licenses for a complete copy of the license.          --
20--                                                                          --
21-- GNAT was originally developed  by the GNAT team at  New York University. --
22-- Extensive contributions were provided by Ada Core Technologies Inc.      --
23--                                                                          --
24------------------------------------------------------------------------------
25
26--  Processing for intrinsic subprogram declarations
27
28with Atree;    use Atree;
29with Einfo;    use Einfo;
30with Errout;   use Errout;
31with Fname;    use Fname;
32with Lib;      use Lib;
33with Namet;    use Namet;
34with Sem_Aux;  use Sem_Aux;
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 that
58   --  the types involved both have underlying integer types.
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 not Ekind_In (E, E_Function, E_Generic_Function) then
78         Errint
79           ("intrinsic exception subprogram must be a function", E, N);
80
81      elsif Present (First_Formal (E)) then
82         Errint
83           ("intrinsic exception subprogram may not have parameters",
84            E, First_Formal (E));
85         return;
86
87      elsif Etype (E) /= Standard_String then
88         Errint
89           ("return type of exception subprogram must be String", E, N);
90         return;
91      end if;
92   end Check_Exception_Function;
93
94   --------------------------
95   -- Check_Intrinsic_Call --
96   --------------------------
97
98   procedure Check_Intrinsic_Call (N : Node_Id) is
99      Nam  : constant Entity_Id := Entity (Name (N));
100      Arg1 : constant Node_Id   := First_Actual (N);
101      Typ  : Entity_Id;
102      Rtyp : Entity_Id;
103      Cnam : Name_Id;
104      Unam : Node_Id;
105
106   begin
107      --  Set argument type if argument present
108
109      if Present (Arg1) then
110         Typ := Etype (Arg1);
111         Rtyp := Underlying_Type (Root_Type (Typ));
112      end if;
113
114      --  Set intrinsic name (getting original name in the generic case)
115
116      Unam := Ultimate_Alias (Nam);
117
118      if Present (Parent (Unam))
119        and then Present (Generic_Parent (Parent (Unam)))
120      then
121         Cnam := Chars (Generic_Parent (Parent (Unam)));
122      else
123         Cnam := Chars (Nam);
124      end if;
125
126      --  For Import_xxx calls, argument must be static string. A string
127      --  literal is legal even in Ada 83 mode, where such literals are
128      --  not static.
129
130      if Cnam = Name_Import_Address
131           or else
132         Cnam = Name_Import_Largest_Value
133           or else
134         Cnam = Name_Import_Value
135      then
136         if Etype (Arg1) = Any_Type
137           or else Raises_Constraint_Error (Arg1)
138         then
139            null;
140
141         elsif Nkind (Arg1) /= N_String_Literal
142           and then not Is_Static_Expression (Arg1)
143         then
144            Error_Msg_FE
145              ("call to & requires static string argument!", N, Nam);
146            Why_Not_Static (Arg1);
147
148         elsif String_Length (Strval (Expr_Value_S (Arg1))) = 0 then
149            Error_Msg_NE
150              ("call to & does not permit null string", N, Nam);
151
152         elsif OpenVMS_On_Target
153           and then String_Length (Strval (Expr_Value_S (Arg1))) > 31
154         then
155            Error_Msg_NE
156              ("argument in call to & must be 31 characters or less", N, Nam);
157         end if;
158
159      --  Check for the case of freeing a non-null object which will raise
160      --  Constraint_Error. Issue warning here, do the expansion in Exp_Intr.
161
162      elsif Cnam = Name_Unchecked_Deallocation
163        and then Can_Never_Be_Null (Etype (Arg1))
164      then
165         Error_Msg_N
166           ("freeing `NOT NULL` object will raise Constraint_Error??", N);
167
168      --  For unchecked deallocation, error to deallocate from empty pool.
169      --  Note: this test used to be in Exp_Intr as a warning, but AI 157
170      --  issues a binding interpretation that this should be an error, and
171      --  consequently it needs to be done in the semantic analysis so that
172      --  the error is issued even in semantics only mode.
173
174      elsif Cnam = Name_Unchecked_Deallocation
175        and then No_Pool_Assigned (Rtyp)
176      then
177         Error_Msg_N ("deallocation from empty storage pool!", N);
178
179      --  For now, no other special checks are required
180
181      else
182         return;
183      end if;
184   end Check_Intrinsic_Call;
185
186   ------------------------------
187   -- Check_Intrinsic_Operator --
188   ------------------------------
189
190   procedure Check_Intrinsic_Operator (E : Entity_Id; N : Node_Id) is
191      Ret : constant Entity_Id := Etype (E);
192      Nam : constant Name_Id   := Chars (E);
193      T1  : Entity_Id;
194      T2  : Entity_Id;
195
196   begin
197      --  Arithmetic operators
198
199      if Nam = Name_Op_Add
200           or else
201         Nam = Name_Op_Subtract
202           or else
203         Nam = Name_Op_Multiply
204           or else
205         Nam = Name_Op_Divide
206           or else
207         Nam = Name_Op_Rem
208           or else
209         Nam = Name_Op_Mod
210           or else
211         Nam = Name_Op_Abs
212      then
213         T1 := Etype (First_Formal (E));
214
215         if No (Next_Formal (First_Formal (E))) then
216
217            if Nam = Name_Op_Add
218                 or else
219               Nam = Name_Op_Subtract
220                 or else
221               Nam = Name_Op_Abs
222            then
223               T2 := T1;
224
225            --  Previous error in declaration
226
227            else
228               return;
229            end if;
230
231         else
232            T2 := Etype (Next_Formal (First_Formal (E)));
233         end if;
234
235         --  Same types, predefined operator will apply
236
237         if Root_Type (T1) = Root_Type (T2)
238           or else Root_Type (T1) = Root_Type (Ret)
239         then
240            null;
241
242         --  Expansion will introduce conversions if sizes are not equal
243
244         elsif Is_Integer_Type (Underlying_Type (T1))
245           and then Is_Integer_Type (Underlying_Type (T2))
246           and then Is_Integer_Type (Underlying_Type (Ret))
247         then
248            null;
249
250         else
251            Errint
252              ("types of intrinsic operator operands do not match", E, N);
253         end if;
254
255      --  Comparison operators
256
257      elsif Nam = Name_Op_Eq
258              or else
259            Nam = Name_Op_Ge
260              or else
261            Nam = Name_Op_Gt
262              or else
263            Nam = Name_Op_Le
264              or else
265            Nam = Name_Op_Lt
266              or else
267            Nam = Name_Op_Ne
268      then
269         T1 := Etype (First_Formal (E));
270
271         --  Return if previous error in declaration, otherwise get T2 type
272
273         if No (Next_Formal (First_Formal (E))) then
274            Check_Error_Detected;
275            return;
276
277         else
278            T2 := Etype (Next_Formal (First_Formal (E)));
279         end if;
280
281         if Root_Type (T1) /= Root_Type (T2) then
282            Errint
283              ("types of intrinsic operator must have the same size", E, N);
284         end if;
285
286         if Root_Type (Ret) /= Standard_Boolean then
287            Errint
288              ("result type of intrinsic comparison must be boolean", E, N);
289         end if;
290
291      --  Exponentiation
292
293      elsif Nam = Name_Op_Expon then
294         T1 := Etype (First_Formal (E));
295
296         if No (Next_Formal (First_Formal (E))) then
297
298            --  Previous error in declaration
299
300            return;
301
302         else
303            T2 := Etype (Next_Formal (First_Formal (E)));
304         end if;
305
306         if not (Is_Integer_Type (T1)
307                   or else
308                 Is_Floating_Point_Type (T1))
309           or else Root_Type (T1) /= Root_Type (Ret)
310           or else Root_Type (T2) /= Root_Type (Standard_Integer)
311         then
312            Errint ("incorrect operands for intrinsic operator", N, E);
313         end if;
314
315      --  All other operators (are there any?) are not handled
316
317      else
318         Errint ("incorrect context for ""Intrinsic"" convention", E, N);
319         return;
320      end if;
321
322      --  The type must be fully defined and numeric.
323
324      if No (Underlying_Type (T1))
325        or else not Is_Numeric_Type (Underlying_Type (T1))
326      then
327         Errint ("intrinsic operator can only apply to numeric types", E, N);
328      end if;
329   end Check_Intrinsic_Operator;
330
331   --------------------------------
332   -- Check_Intrinsic_Subprogram --
333   --------------------------------
334
335   procedure Check_Intrinsic_Subprogram (E : Entity_Id; N : Node_Id) is
336      Spec : constant Node_Id := Specification (Unit_Declaration_Node (E));
337      Nam  : Name_Id;
338
339   begin
340      if Present (Spec)
341        and then Present (Generic_Parent (Spec))
342      then
343         Nam := Chars (Generic_Parent (Spec));
344      else
345         Nam := Chars (E);
346      end if;
347
348      --  Check name is valid intrinsic name
349
350      Get_Name_String (Nam);
351
352      if Name_Buffer (1) /= 'O'
353        and then Nam /= Name_Asm
354        and then Nam /= Name_To_Address
355        and then Nam not in First_Intrinsic_Name .. Last_Intrinsic_Name
356      then
357         Errint ("unrecognized intrinsic subprogram", E, N);
358
359      --  We always allow intrinsic specifications in language defined units
360      --  and in expanded code. We assume that the GNAT implementors know what
361      --  they are doing, and do not write or generate junk use of intrinsic!
362
363      elsif not Comes_From_Source (E)
364        or else not Comes_From_Source (N)
365        or else Is_Predefined_File_Name
366                  (Unit_File_Name (Get_Source_Unit (N)))
367      then
368         null;
369
370      --  Shift cases. We allow user specification of intrinsic shift
371      --  operators for any numeric types.
372
373      elsif
374        Nam = Name_Rotate_Left
375          or else
376        Nam = Name_Rotate_Right
377          or else
378        Nam = Name_Shift_Left
379          or else
380        Nam = Name_Shift_Right
381          or else
382        Nam = Name_Shift_Right_Arithmetic
383      then
384         Check_Shift (E, N);
385
386      elsif
387        Nam = Name_Exception_Information
388          or else
389        Nam = Name_Exception_Message
390          or else
391        Nam = Name_Exception_Name
392      then
393         Check_Exception_Function (E, N);
394
395      elsif Nkind (E) = N_Defining_Operator_Symbol then
396         Check_Intrinsic_Operator (E, N);
397
398      elsif Nam = Name_File
399        or else Nam = Name_Line
400        or else Nam = Name_Source_Location
401        or else Nam = Name_Enclosing_Entity
402      then
403         null;
404
405      --  For now, no other intrinsic subprograms are recognized in user code
406
407      else
408         Errint ("incorrect context for ""Intrinsic"" convention", E, N);
409      end if;
410   end Check_Intrinsic_Subprogram;
411
412   -----------------
413   -- Check_Shift --
414   -----------------
415
416   procedure Check_Shift (E : Entity_Id; N : Node_Id) is
417      Arg1  : Node_Id;
418      Arg2  : Node_Id;
419      Size  : Nat;
420      Typ1  : Entity_Id;
421      Typ2  : Entity_Id;
422      Ptyp1 : Node_Id;
423      Ptyp2 : Node_Id;
424
425   begin
426      if not Ekind_In (E, E_Function, E_Generic_Function) then
427         Errint ("intrinsic shift subprogram must be a function", E, N);
428         return;
429      end if;
430
431      Arg1 := First_Formal (E);
432
433      if Present (Arg1) then
434         Arg2 := Next_Formal (Arg1);
435      else
436         Arg2 := Empty;
437      end if;
438
439      if Arg1 = Empty or else Arg2 = Empty then
440         Errint ("intrinsic shift function must have two arguments", E, N);
441         return;
442      end if;
443
444      Typ1 := Etype (Arg1);
445      Typ2 := Etype (Arg2);
446
447      Ptyp1 := Parameter_Type (Parent (Arg1));
448      Ptyp2 := Parameter_Type (Parent (Arg2));
449
450      if not Is_Integer_Type (Typ1) then
451         Errint ("first argument to shift must be integer type", Ptyp1, N);
452         return;
453      end if;
454
455      if Typ2 /= Standard_Natural then
456         Errint ("second argument to shift must be type Natural", Ptyp2, N);
457         return;
458      end if;
459
460      --  type'Size (not 'Object_Size!) must be one of the allowed values
461
462      Size := UI_To_Int (RM_Size (Typ1));
463
464      if Size /= 8  and then
465         Size /= 16 and then
466         Size /= 32 and then
467         Size /= 64
468      then
469         Errint
470           ("first argument for shift must have size 8, 16, 32 or 64",
471             Ptyp1, N);
472         return;
473
474      elsif Non_Binary_Modulus (Typ1) then
475         Errint
476           ("shifts not allowed for non-binary modular types", Ptyp1, N);
477
478      elsif Etype (Arg1) /= Etype (E) then
479         Errint
480           ("first argument of shift must match return type", Ptyp1, N);
481         return;
482      end if;
483   end Check_Shift;
484
485   ------------
486   -- Errint --
487   ------------
488
489   procedure Errint (Msg : String; S : Node_Id; N : Node_Id) is
490   begin
491      Error_Msg_N (Msg, S);
492      Error_Msg_N ("incorrect intrinsic subprogram, see spec", N);
493   end Errint;
494
495end Sem_Intr;
496