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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [sem_intr.adb] - Blame information for rev 706

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 706 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-2011, 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_Aux;  use Sem_Aux;
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;
43
 
44
package 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
            return;
275
         else
276
            T2 := Etype (Next_Formal (First_Formal (E)));
277
         end if;
278
 
279
         if Root_Type (T1) /= Root_Type (T2) then
280
            Errint
281
              ("types of intrinsic operator must have the same size", E, N);
282
         end if;
283
 
284
         if Root_Type (Ret) /= Standard_Boolean then
285
            Errint
286
              ("result type of intrinsic comparison must be boolean", E, N);
287
         end if;
288
 
289
      --  Exponentiation
290
 
291
      elsif Nam = Name_Op_Expon then
292
         T1 := Etype (First_Formal (E));
293
 
294
         if No (Next_Formal (First_Formal (E))) then
295
 
296
            --  Previous error in declaration
297
 
298
            return;
299
 
300
         else
301
            T2 := Etype (Next_Formal (First_Formal (E)));
302
         end if;
303
 
304
         if not (Is_Integer_Type (T1)
305
                   or else
306
                 Is_Floating_Point_Type (T1))
307
           or else Root_Type (T1) /= Root_Type (Ret)
308
           or else Root_Type (T2) /= Root_Type (Standard_Integer)
309
         then
310
            Errint ("incorrect operands for intrinsic operator", N, E);
311
         end if;
312
 
313
      --  All other operators (are there any?) are not handled
314
 
315
      else
316
         Errint ("incorrect context for ""Intrinsic"" convention", E, N);
317
         return;
318
      end if;
319
 
320
      --  The type must be fully defined and numeric.
321
 
322
      if No (Underlying_Type (T1))
323
        or else not Is_Numeric_Type (Underlying_Type (T1))
324
      then
325
         Errint ("intrinsic operator can only apply to numeric types", E, N);
326
      end if;
327
   end Check_Intrinsic_Operator;
328
 
329
   --------------------------------
330
   -- Check_Intrinsic_Subprogram --
331
   --------------------------------
332
 
333
   procedure Check_Intrinsic_Subprogram (E : Entity_Id; N : Node_Id) is
334
      Spec : constant Node_Id := Specification (Unit_Declaration_Node (E));
335
      Nam  : Name_Id;
336
 
337
   begin
338
      if Present (Spec)
339
        and then Present (Generic_Parent (Spec))
340
      then
341
         Nam := Chars (Generic_Parent (Spec));
342
      else
343
         Nam := Chars (E);
344
      end if;
345
 
346
      --  Check name is valid intrinsic name
347
 
348
      Get_Name_String (Nam);
349
 
350
      if Name_Buffer (1) /= 'O'
351
        and then Nam /= Name_Asm
352
        and then Nam /= Name_To_Address
353
        and then Nam not in First_Intrinsic_Name .. Last_Intrinsic_Name
354
      then
355
         Errint ("unrecognized intrinsic subprogram", E, N);
356
 
357
      --  We always allow intrinsic specifications in language defined units
358
      --  and in expanded code. We assume that the GNAT implementors know what
359
      --  they are doing, and do not write or generate junk use of intrinsic!
360
 
361
      elsif not Comes_From_Source (E)
362
        or else not Comes_From_Source (N)
363
        or else Is_Predefined_File_Name
364
                  (Unit_File_Name (Get_Source_Unit (N)))
365
      then
366
         null;
367
 
368
      --  Shift cases. We allow user specification of intrinsic shift
369
      --  operators for any numeric types.
370
 
371
      elsif
372
        Nam = Name_Rotate_Left
373
          or else
374
        Nam = Name_Rotate_Right
375
          or else
376
        Nam = Name_Shift_Left
377
          or else
378
        Nam = Name_Shift_Right
379
          or else
380
        Nam = Name_Shift_Right_Arithmetic
381
      then
382
         Check_Shift (E, N);
383
 
384
      elsif
385
        Nam = Name_Exception_Information
386
          or else
387
        Nam = Name_Exception_Message
388
          or else
389
        Nam = Name_Exception_Name
390
      then
391
         Check_Exception_Function (E, N);
392
 
393
      elsif Nkind (E) = N_Defining_Operator_Symbol then
394
         Check_Intrinsic_Operator (E, N);
395
 
396
      elsif Nam = Name_File
397
        or else Nam = Name_Line
398
        or else Nam = Name_Source_Location
399
        or else Nam = Name_Enclosing_Entity
400
      then
401
         null;
402
 
403
      --  For now, no other intrinsic subprograms are recognized in user code
404
 
405
      else
406
         Errint ("incorrect context for ""Intrinsic"" convention", E, N);
407
      end if;
408
   end Check_Intrinsic_Subprogram;
409
 
410
   -----------------
411
   -- Check_Shift --
412
   -----------------
413
 
414
   procedure Check_Shift (E : Entity_Id; N : Node_Id) is
415
      Arg1  : Node_Id;
416
      Arg2  : Node_Id;
417
      Size  : Nat;
418
      Typ1  : Entity_Id;
419
      Typ2  : Entity_Id;
420
      Ptyp1 : Node_Id;
421
      Ptyp2 : Node_Id;
422
 
423
   begin
424
      if not Ekind_In (E, E_Function, E_Generic_Function) then
425
         Errint ("intrinsic shift subprogram must be a function", E, N);
426
         return;
427
      end if;
428
 
429
      Arg1 := First_Formal (E);
430
 
431
      if Present (Arg1) then
432
         Arg2 := Next_Formal (Arg1);
433
      else
434
         Arg2 := Empty;
435
      end if;
436
 
437
      if Arg1 = Empty or else Arg2 = Empty then
438
         Errint ("intrinsic shift function must have two arguments", E, N);
439
         return;
440
      end if;
441
 
442
      Typ1 := Etype (Arg1);
443
      Typ2 := Etype (Arg2);
444
 
445
      Ptyp1 := Parameter_Type (Parent (Arg1));
446
      Ptyp2 := Parameter_Type (Parent (Arg2));
447
 
448
      if not Is_Integer_Type (Typ1) then
449
         Errint ("first argument to shift must be integer type", Ptyp1, N);
450
         return;
451
      end if;
452
 
453
      if Typ2 /= Standard_Natural then
454
         Errint ("second argument to shift must be type Natural", Ptyp2, N);
455
         return;
456
      end if;
457
 
458
      --  type'Size (not 'Object_Size!) must be one of the allowed values
459
 
460
      Size := UI_To_Int (RM_Size (Typ1));
461
 
462
      if Size /= 8  and then
463
         Size /= 16 and then
464
         Size /= 32 and then
465
         Size /= 64
466
      then
467
         Errint
468
           ("first argument for shift must have size 8, 16, 32 or 64",
469
             Ptyp1, N);
470
         return;
471
 
472
      elsif Non_Binary_Modulus (Typ1) then
473
         Errint
474
           ("shifts not allowed for non-binary modular types", Ptyp1, N);
475
 
476
      elsif Etype (Arg1) /= Etype (E) then
477
         Errint
478
           ("first argument of shift must match return type", Ptyp1, N);
479
         return;
480
      end if;
481
   end Check_Shift;
482
 
483
   ------------
484
   -- Errint --
485
   ------------
486
 
487
   procedure Errint (Msg : String; S : Node_Id; N : Node_Id) is
488
   begin
489
      Error_Msg_N (Msg, S);
490
      Error_Msg_N ("incorrect intrinsic subprogram, see spec", N);
491
   end Errint;
492
 
493
end Sem_Intr;

powered by: WebSVN 2.1.0

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