OpenCores
URL https://opencores.org/ocsvn/openrisc_me/openrisc_me/trunk

Subversion Repositories openrisc_me

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [ada/] [sem_intr.adb] - Blame information for rev 414

Go to most recent revision | Details | Compare with Previous | View Log

Line No. Rev Author Line
1 281 jeremybenn
------------------------------------------------------------------------------
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-2009, 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
 
28
with Atree;    use Atree;
29
with Einfo;    use Einfo;
30
with Errout;   use Errout;
31
with Fname;    use Fname;
32
with Lib;      use Lib;
33
with Namet;    use Namet;
34
with Sem_Eval; use Sem_Eval;
35
with Sem_Util; use Sem_Util;
36
with Sinfo;    use Sinfo;
37
with Snames;   use Snames;
38
with Stand;    use Stand;
39
with Stringt;  use Stringt;
40
with Targparm; use Targparm;
41
with Uintp;    use Uintp;
42
 
43
package body Sem_Intr is
44
 
45
   -----------------------
46
   -- Local Subprograms --
47
   -----------------------
48
 
49
   procedure Check_Exception_Function (E : Entity_Id; N : Node_Id);
50
   --  Check use of intrinsic Exception_Message, Exception_Info or
51
   --  Exception_Name, as used in the DEC compatible Current_Exceptions
52
   --  package. In each case we must have a parameterless function that
53
   --  returns type String.
54
 
55
   procedure Check_Intrinsic_Operator (E : Entity_Id; N : Node_Id);
56
   --  Check that operator is one of the binary arithmetic operators, and
57
   --  that the types involved have the same size.
58
 
59
   procedure Check_Shift (E : Entity_Id; N : Node_Id);
60
   --  Check intrinsic shift subprogram, the two arguments are the same
61
   --  as for Check_Intrinsic_Subprogram (i.e. the entity of the subprogram
62
   --  declaration, and the node for the pragma argument, used for messages)
63
 
64
   procedure Errint (Msg : String; S : Node_Id; N : Node_Id);
65
   --  Post error message for bad intrinsic, the message itself is posted
66
   --  on the appropriate spec node and another message is placed on the
67
   --  pragma itself, referring to the spec. S is the node in the spec on
68
   --  which the message is to be placed, and N is the pragma argument node.
69
 
70
   ------------------------------
71
   -- Check_Exception_Function --
72
   ------------------------------
73
 
74
   procedure Check_Exception_Function (E : Entity_Id; N : Node_Id) is
75
   begin
76
      if Ekind (E) /= E_Function
77
        and then Ekind (E) /= E_Generic_Function
78
      then
79
         Errint
80
           ("intrinsic exception subprogram must be a function", E, N);
81
 
82
      elsif Present (First_Formal (E)) then
83
         Errint
84
           ("intrinsic exception subprogram may not have parameters",
85
            E, First_Formal (E));
86
         return;
87
 
88
      elsif Etype (E) /= Standard_String then
89
         Errint
90
           ("return type of exception subprogram must be String", E, N);
91
         return;
92
      end if;
93
   end Check_Exception_Function;
94
 
95
   --------------------------
96
   -- Check_Intrinsic_Call --
97
   --------------------------
98
 
99
   procedure Check_Intrinsic_Call (N : Node_Id) is
100
      Nam  : constant Entity_Id := Entity (Name (N));
101
      Cnam : constant Name_Id   := Chars (Nam);
102
      Arg1 : constant Node_Id   := First_Actual (N);
103
 
104
   begin
105
      --  For Import_xxx calls, argument must be static string. A string
106
      --  literal is legal even in Ada83 mode, where such literals are
107
      --  not static.
108
 
109
      if Cnam = Name_Import_Address
110
           or else
111
         Cnam = Name_Import_Largest_Value
112
           or else
113
         Cnam = Name_Import_Value
114
      then
115
         if Etype (Arg1) = Any_Type
116
           or else Raises_Constraint_Error (Arg1)
117
         then
118
            null;
119
 
120
         elsif Nkind (Arg1) /= N_String_Literal
121
           and then not Is_Static_Expression (Arg1)
122
         then
123
            Error_Msg_FE
124
              ("call to & requires static string argument!", N, Nam);
125
            Why_Not_Static (Arg1);
126
 
127
         elsif String_Length (Strval (Expr_Value_S (Arg1))) = 0 then
128
            Error_Msg_NE
129
              ("call to & does not permit null string", N, Nam);
130
 
131
         elsif OpenVMS_On_Target
132
           and then String_Length (Strval (Expr_Value_S (Arg1))) > 31
133
         then
134
            Error_Msg_NE
135
              ("argument in call to & must be 31 characters or less", N, Nam);
136
         end if;
137
 
138
      --  Check for the case of freeing a non-null object which will raise
139
      --  Constraint_Error. Issue warning here, do the expansion in Exp_Intr.
140
 
141
      elsif Cnam = Name_Free
142
        and then Can_Never_Be_Null (Etype (Arg1))
143
      then
144
         Error_Msg_N
145
           ("freeing `NOT NULL` object will raise Constraint_Error?", N);
146
 
147
      --  For now, no other special checks are required
148
 
149
      else
150
         return;
151
      end if;
152
   end Check_Intrinsic_Call;
153
 
154
   ------------------------------
155
   -- Check_Intrinsic_Operator --
156
   ------------------------------
157
 
158
   procedure Check_Intrinsic_Operator (E : Entity_Id; N : Node_Id) is
159
      Ret : constant Entity_Id := Etype (E);
160
      Nam : constant Name_Id   := Chars (E);
161
      T1  : Entity_Id;
162
      T2  : Entity_Id;
163
 
164
   begin
165
      --  Arithmetic operators
166
 
167
      if Nam = Name_Op_Add
168
           or else
169
         Nam = Name_Op_Subtract
170
           or else
171
         Nam = Name_Op_Multiply
172
           or else
173
         Nam = Name_Op_Divide
174
           or else
175
         Nam = Name_Op_Rem
176
           or else
177
         Nam = Name_Op_Mod
178
           or else
179
         Nam = Name_Op_Abs
180
      then
181
         T1 := Etype (First_Formal (E));
182
 
183
         if No (Next_Formal (First_Formal (E))) then
184
 
185
            if Nam = Name_Op_Add
186
                 or else
187
               Nam = Name_Op_Subtract
188
                 or else
189
               Nam = Name_Op_Abs
190
            then
191
               T2 := T1;
192
 
193
            else
194
               --  Previous error in declaration
195
 
196
               return;
197
            end if;
198
 
199
         else
200
            T2 := Etype (Next_Formal (First_Formal (E)));
201
         end if;
202
 
203
         if Root_Type (T1) /= Root_Type (T2)
204
           or else Root_Type (T1) /= Root_Type (Ret)
205
         then
206
            Errint
207
              ("types of intrinsic operator must have the same size", E, N);
208
         end if;
209
 
210
      --  Comparison operators
211
 
212
      elsif Nam = Name_Op_Eq
213
              or else
214
            Nam = Name_Op_Ge
215
              or else
216
            Nam = Name_Op_Gt
217
              or else
218
            Nam = Name_Op_Le
219
              or else
220
            Nam = Name_Op_Lt
221
              or else
222
            Nam = Name_Op_Ne
223
      then
224
         T1 := Etype (First_Formal (E));
225
 
226
         if No (Next_Formal (First_Formal (E))) then
227
 
228
            --  Previous error in declaration
229
 
230
            return;
231
 
232
         else
233
            T2 := Etype (Next_Formal (First_Formal (E)));
234
         end if;
235
 
236
         if Root_Type (T1) /= Root_Type (T2) then
237
            Errint
238
              ("types of intrinsic operator must have the same size", E, N);
239
         end if;
240
 
241
         if Root_Type (Ret) /= Standard_Boolean then
242
            Errint
243
              ("result type of intrinsic comparison must be boolean", E, N);
244
         end if;
245
 
246
      --  Exponentiation
247
 
248
      elsif Nam = Name_Op_Expon then
249
         T1 := Etype (First_Formal (E));
250
 
251
         if No (Next_Formal (First_Formal (E))) then
252
 
253
            --  Previous error in declaration
254
 
255
            return;
256
 
257
         else
258
            T2 := Etype (Next_Formal (First_Formal (E)));
259
         end if;
260
 
261
         if not (Is_Integer_Type (T1)
262
                   or else
263
                 Is_Floating_Point_Type (T1))
264
           or else Root_Type (T1) /= Root_Type (Ret)
265
           or else Root_Type (T2) /= Root_Type (Standard_Integer)
266
         then
267
            Errint ("incorrect operands for intrinsic operator", N, E);
268
         end if;
269
 
270
      --  All other operators (are there any?) are not handled
271
 
272
      else
273
         Errint ("incorrect context for ""Intrinsic"" convention", E, N);
274
         return;
275
      end if;
276
 
277
      if not Is_Numeric_Type (T1) then
278
         Errint ("intrinsic operator can only apply to numeric types", E, N);
279
      end if;
280
   end Check_Intrinsic_Operator;
281
 
282
   --------------------------------
283
   -- Check_Intrinsic_Subprogram --
284
   --------------------------------
285
 
286
   procedure Check_Intrinsic_Subprogram (E : Entity_Id; N : Node_Id) is
287
      Spec : constant Node_Id := Specification (Unit_Declaration_Node (E));
288
      Nam  : Name_Id;
289
 
290
   begin
291
      if Present (Spec)
292
        and then Present (Generic_Parent (Spec))
293
      then
294
         Nam := Chars (Generic_Parent (Spec));
295
      else
296
         Nam := Chars (E);
297
      end if;
298
 
299
      --  Check name is valid intrinsic name
300
 
301
      Get_Name_String (Nam);
302
 
303
      if Name_Buffer (1) /= 'O'
304
        and then Nam /= Name_Asm
305
        and then Nam /= Name_To_Address
306
        and then Nam not in First_Intrinsic_Name .. Last_Intrinsic_Name
307
      then
308
         Errint ("unrecognized intrinsic subprogram", E, N);
309
 
310
      --  We always allow intrinsic specifications in language defined units
311
      --  and in expanded code. We assume that the GNAT implementors know what
312
      --  they are doing, and do not write or generate junk use of intrinsic!
313
 
314
      elsif not Comes_From_Source (E)
315
        or else not Comes_From_Source (N)
316
        or else Is_Predefined_File_Name
317
                  (Unit_File_Name (Get_Source_Unit (N)))
318
      then
319
         null;
320
 
321
      --  Shift cases. We allow user specification of intrinsic shift
322
      --  operators for any numeric types.
323
 
324
      elsif
325
        Nam = Name_Rotate_Left
326
          or else
327
        Nam = Name_Rotate_Right
328
          or else
329
        Nam = Name_Shift_Left
330
          or else
331
        Nam = Name_Shift_Right
332
          or else
333
        Nam = Name_Shift_Right_Arithmetic
334
      then
335
         Check_Shift (E, N);
336
 
337
      elsif
338
        Nam = Name_Exception_Information
339
          or else
340
        Nam = Name_Exception_Message
341
          or else
342
        Nam = Name_Exception_Name
343
      then
344
         Check_Exception_Function (E, N);
345
 
346
      elsif Nkind (E) = N_Defining_Operator_Symbol then
347
         Check_Intrinsic_Operator (E, N);
348
 
349
      elsif Nam = Name_File
350
        or else Nam = Name_Line
351
        or else Nam = Name_Source_Location
352
        or else Nam = Name_Enclosing_Entity
353
      then
354
         null;
355
 
356
      --  For now, no other intrinsic subprograms are recognized in user code
357
 
358
      else
359
         Errint ("incorrect context for ""Intrinsic"" convention", E, N);
360
      end if;
361
   end Check_Intrinsic_Subprogram;
362
 
363
   -----------------
364
   -- Check_Shift --
365
   -----------------
366
 
367
   procedure Check_Shift (E : Entity_Id; N : Node_Id) is
368
      Arg1  : Node_Id;
369
      Arg2  : Node_Id;
370
      Size  : Nat;
371
      Typ1  : Entity_Id;
372
      Typ2  : Entity_Id;
373
      Ptyp1 : Node_Id;
374
      Ptyp2 : Node_Id;
375
 
376
   begin
377
      if Ekind (E) /= E_Function
378
        and then Ekind (E) /= E_Generic_Function
379
      then
380
         Errint ("intrinsic shift subprogram must be a function", E, N);
381
         return;
382
      end if;
383
 
384
      Arg1 := First_Formal (E);
385
 
386
      if Present (Arg1) then
387
         Arg2 := Next_Formal (Arg1);
388
      else
389
         Arg2 := Empty;
390
      end if;
391
 
392
      if Arg1 = Empty or else Arg2 = Empty then
393
         Errint ("intrinsic shift function must have two arguments", E, N);
394
         return;
395
      end if;
396
 
397
      Typ1 := Etype (Arg1);
398
      Typ2 := Etype (Arg2);
399
 
400
      Ptyp1 := Parameter_Type (Parent (Arg1));
401
      Ptyp2 := Parameter_Type (Parent (Arg2));
402
 
403
      if not Is_Integer_Type (Typ1) then
404
         Errint ("first argument to shift must be integer type", Ptyp1, N);
405
         return;
406
      end if;
407
 
408
      if Typ2 /= Standard_Natural then
409
         Errint ("second argument to shift must be type Natural", Ptyp2, N);
410
         return;
411
      end if;
412
 
413
      Size := UI_To_Int (Esize (Typ1));
414
 
415
      if Size /= 8
416
        and then Size /= 16
417
        and then Size /= 32
418
        and then Size /= 64
419
      then
420
         Errint
421
           ("first argument for shift must have size 8, 16, 32 or 64",
422
             Ptyp1, N);
423
         return;
424
 
425
      elsif Non_Binary_Modulus (Typ1) then
426
         Errint
427
           ("shifts not allowed for non-binary modular types",
428
            Ptyp1, N);
429
 
430
      elsif Etype (Arg1) /= Etype (E) then
431
         Errint
432
           ("first argument of shift must match return type", Ptyp1, N);
433
         return;
434
      end if;
435
   end Check_Shift;
436
 
437
   ------------
438
   -- Errint --
439
   ------------
440
 
441
   procedure Errint (Msg : String; S : Node_Id; N : Node_Id) is
442
   begin
443
      Error_Msg_N (Msg, S);
444
      Error_Msg_N ("incorrect intrinsic subprogram, see spec", N);
445
   end Errint;
446
 
447
end Sem_Intr;

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.