← Back to branch summary

~ubuntu-branches/ubuntu/jaunty/adacontrol/jaunty

« back to all changes in this revision

Viewing changes to src/a4g_bugs.adb

  • Committer: Bazaar Package Importer
  • Author(s): Ludovic Brenta
  • Date: 2006-10-12 19:17:22 UTC
  • mfrom: (1.1.1 upstream)
  • Revision ID: james.westby@ubuntu.com-20061012191722-fo5bcn4k5r0iubgd
Tags: 1.5r24-1

* New upstream release.
* debian/control (Depends): add gnat-4.1.
  (Enhances): add gnat-gps.
* debian/adacontrol.gpr: build pfni.
* debian/rules: install the new gnat-gps plug-in, and pfni.
* debian/pfni.1: new.
* patches/gps-integration.patch: new.

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/a4g_bugs.adb
47
47
  Asis.Statements;
48
48
 
49
49
with   -- Adalog
50
 
  Thick_Queries;
 
50
  Thick_Queries,
 
51
  Utilities;   -- Only for Trace_Bug
51
52
 
52
53
package body A4G_Bugs is
53
54
   use Asis;
135
136
   -------------------------------
136
137
 
137
138
   function Corresponding_Base_Entity (Declaration : in Asis.Declaration) return Asis.Expression is
138
 
      use Asis, Asis.Elements, Asis.Expressions;
 
139
      use Asis.Elements, Asis.Expressions;
139
140
      Result : Asis.Expression := Asis.Declarations.Corresponding_Base_Entity (Declaration);
140
141
      Decl   : Asis.Declaration;
141
142
   begin
165
166
   begin
166
167
      if Defining_Name_Kind (Result) = A_Defining_Expanded_Name then
167
168
         -- Bug: missing one level of Enclosing_Element
 
169
         Trace_Bug ("A4G_Bugs.Corresponding_Called_Entity");
168
170
         return Enclosing_Element (Result);
169
171
      else
170
172
         return Result;
176
178
   -----------------------------------
177
179
 
178
180
   function Corresponding_Called_Function (Expression : in Asis.Expression) return Asis.Declaration is
179
 
      use Asis.Elements;
 
181
      use Asis.Declarations, Asis.Elements;
180
182
      Result : constant Asis.Declaration := Asis.Expressions.Corresponding_Called_Function (Expression);
181
183
   begin
 
184
      -- Special kludge for "/=" which does not return Nil_Element in some version of GNAT
 
185
      -- (although Called_Profile does not return anything)
 
186
      if Is_Nil (Result) then
 
187
         return Nil_Element;
 
188
      elsif Operator_Kind (Names (Result)(1)) = A_Not_Equal_Operator
 
189
        and then not Is_Nil (Corresponding_Equality_Operator (Result))
 
190
      then
 
191
         -- It is a predefined "/=" whose result is Boolean
 
192
         -- Note that it can only be a predefined one, per 6.6(5)
 
193
         return Nil_Element;
 
194
      end if;
 
195
 
182
196
      if Defining_Name_Kind (Result) = A_Defining_Expanded_Name then
183
197
         -- Bug: missing one level of Enclosing_Element
 
198
         Trace_Bug ("A4G_Bugs.Corresponding_Called_Function");
184
199
         return Enclosing_Element (Result);
185
200
      else
186
201
         return Result;
193
208
 
194
209
   function Corresponding_Expression_Type (Expression : in Asis.Expression) return Asis.Declaration
195
210
   is
 
211
      -- Since this is a (partial) rewriting of the function, there is no call to Trace_Bug
196
212
      use Ada.Exceptions, Asis.Declarations, Asis.Definitions, Asis.Elements, Asis.Expressions;
 
213
      use Thick_Queries;
197
214
 
198
215
      Result : Asis.Element;
199
216
      Temp   : Asis.Element;
200
 
      Name   : Asis.Expression;
201
217
   begin
202
218
      if Expression_Kind (Expression) = An_Explicit_Dereference then
203
219
         -- For An_Explicit_Dereference, ASIS returns the type of the pointer
224
240
 
225
241
               Result := Result_Profile (Result);
226
242
               Temp   := Nil_Element;
227
 
            when An_Indexed_Component =>
 
243
            when An_Indexed_Component
 
244
              | An_Explicit_Dereference
 
245
              =>
228
246
               -- The type of the name of an indexed component cannot (yet!) be anonymous
 
247
               -- Similarly, for X.all.all
229
248
               Result := Corresponding_Expression_Type (Temp);
230
249
               Temp   := Nil_Element;
231
250
            when others =>
243
262
                    | A_Single_Protected_Declaration
244
263
                    | A_Single_Task_Declaration
245
264
                    =>
246
 
                     Result := Asis.Definitions.Subtype_Mark (Object_Declaration_View (Temp));
 
265
                     Result := Subtype_Simple_Name (Object_Declaration_View (Temp));
247
266
                  when  A_Component_Declaration=>
248
 
                     Result := Asis.Definitions.Subtype_Mark (Component_Subtype_Indication
249
 
                                                              (Object_Declaration_View (Temp)));
 
267
                     Result := Subtype_Simple_Name (Component_Subtype_Indication (Object_Declaration_View (Temp)));
250
268
                  when others =>
251
269
                     -- ???
252
270
                     Raise_Exception (Program_Error'Identity,
283
301
            -- (but beware of intermediate subtyping)
284
302
            Result := Type_Declaration_View (Corresponding_First_Subtype (Result));
285
303
 
 
304
            -- Get rid of derivations
 
305
            if Type_Kind (Result) in A_Derived_Type_Definition .. A_Derived_Record_Extension_Definition then
 
306
               Result := Type_Declaration_View (Corresponding_Root_Type (Result));
 
307
            elsif Formal_Type_Kind (Result) = A_Formal_Derived_Type_Definition then
 
308
               Result := Type_Declaration_View (Corresponding_Name_Declaration (Subtype_Simple_Name (Result)));
 
309
            end if;
 
310
 
286
311
            -- Here, Result is either the definition of an access-to-object or an access-to-subprogram
287
312
            -- In the latter case, we should probably return a Nil_Element (not clear from the standard,
288
313
            -- but there is nothing else to return).
290
315
               return Nil_Element;
291
316
            end if;
292
317
 
293
 
            Result := Asis.Definitions.Subtype_Mark (Asis.Definitions.Access_To_Object_Definition
294
 
                                                     (Result));
 
318
            Result := Subtype_Simple_Name (Asis.Definitions.Access_To_Object_Definition (Result));
295
319
         end if;
296
320
 
297
321
         -- Here, Result is the name that follows "access" in the access type definition
339
363
      case Declaration_Kind (Result) is
340
364
         when A_Component_Declaration =>
341
365
            -- Bug
342
 
            Name := Asis.Definitions.Subtype_Mark (Component_Subtype_Indication
343
 
                                                   (Object_Declaration_View
344
 
                                                    (Result)));
345
 
            if Expression_Kind (Name) = A_Selected_Component then
346
 
               Name := Selector (Name);
347
 
            end if;
348
 
            Result := Corresponding_Name_Declaration (Name);
 
366
            Result := Corresponding_Name_Declaration (Subtype_Simple_Name (Component_Subtype_Indication
 
367
                                                                           (Object_Declaration_View (Result))));
349
368
 
350
369
         when A_Type_Declaration | A_Subtype_Declaration | A_Formal_Type_Declaration =>
351
370
            -- OK
360
379
               return Nil_Element;
361
380
            end if;
362
381
 
363
 
            Result := Asis.Definitions.Subtype_Mark (Result);
364
 
            if Expression_Kind (Result) = A_Selected_Component then
365
 
               Result := Selector (Result);
366
 
            end if;
367
 
            Result := Corresponding_Name_Declaration (Result);
 
382
            Result := Corresponding_Name_Declaration (Subtype_Simple_Name (Result));
368
383
 
369
384
         when Not_A_Declaration =>
370
385
            Raise_Exception (Program_Error'Identity,
378
393
      return Result;
379
394
   end Corresponding_Expression_Type;
380
395
 
 
396
   --------------------------------
 
397
   -- Corresponding_Last_Subtype --
 
398
   --------------------------------
 
399
 
 
400
   function Corresponding_Last_Subtype (Declaration : in Asis.Declaration) return Asis.Declaration is
 
401
      -- Since this is a complete rewriting of the function, there is no call to Trace_Bug
 
402
      use Asis.Declarations, Asis.Elements, Asis.Expressions, Ada.Exceptions;
 
403
      use Thick_Queries;
 
404
      Mark : Asis.Expression;
 
405
   begin
 
406
      if Declaration_Kind (Declaration) /= A_Subtype_Declaration then
 
407
         return Declaration;
 
408
      end if;
 
409
 
 
410
      Mark := Subtype_Simple_Name (Type_Declaration_View (Declaration));
 
411
      case Expression_Kind (Mark) is
 
412
         when An_Identifier =>
 
413
            return Corresponding_Name_Declaration (Mark);
 
414
         when An_Attribute_Reference =>
 
415
            Mark := Prefix (Mark);
 
416
            if Expression_Kind (Mark) = A_Selected_Component then
 
417
               Mark := Selector (Mark);
 
418
            end if;
 
419
            return Corresponding_Name_Declaration (Mark);
 
420
         when others =>
 
421
            Raise_Exception (Program_Error'Identity,
 
422
                             "Bug in Corresponding_Last_Subtype, returned "
 
423
                               & Expression_Kinds'Image (Expression_Kind (Mark)));
 
424
      end case;
 
425
   end Corresponding_Last_Subtype;
 
426
 
 
427
 
 
428
   -----------------------------
 
429
   -- Corresponding_Root_Type --
 
430
   -----------------------------
 
431
 
 
432
   function Corresponding_Root_Type (Type_Definition : in Asis.Type_Definition) return Asis.Declaration is
 
433
      -- Since this is a complete rewriting of the function, there is no call to Trace_Bug
 
434
      use Asis.Definitions, Asis.Declarations, Asis.Elements, Asis.Expressions;
 
435
      use Thick_Queries;
 
436
 
 
437
      Def  : Asis.Definition := Type_Definition;
 
438
      Decl : Asis.Declaration;
 
439
      Name : Asis.Expression;
 
440
   begin
 
441
      loop
 
442
         -- Invariant: Def is A_Derived_Type_Definition or A_Derived_Record_Extension_Definition
 
443
 
 
444
         Name := Subtype_Simple_Name (Parent_Subtype_Indication (Def));
 
445
         if Expression_Kind (Name) = An_Attribute_Reference then
 
446
            Name := Prefix (Name);
 
447
            if Expression_Kind (Name) = A_Selected_Component then
 
448
               Name := Selector (Name);
 
449
            end if;
 
450
         end if;
 
451
 
 
452
         Decl := Corresponding_First_Subtype (Corresponding_Name_Declaration (Name));
 
453
         if Declaration_Kind (Decl) /= An_Ordinary_Type_Declaration then
 
454
            return Decl;
 
455
         end if;
 
456
 
 
457
         Def := Type_Declaration_View (Decl);
 
458
         if Type_Kind (Def) not in A_Derived_Type_Definition .. A_Derived_Record_Extension_Definition then
 
459
            return Decl;
 
460
         end if;
 
461
      end loop;
 
462
   end Corresponding_Root_Type;
 
463
 
381
464
   --------------
382
465
   -- Subunits --
383
466
   --------------
418
501
      end if;
419
502
   end Subunits;
420
503
 
 
504
   ----------------
 
505
   -- Unit_Class --
 
506
   ----------------
 
507
 
 
508
   function Unit_Class (Compilation_Unit : in Asis.Compilation_Unit) return Asis.Unit_Classes is
 
509
      use Asis.Compilation_Units;
 
510
      Result : constant Asis.Unit_Classes := Asis.Compilation_Units.Unit_Class (Compilation_Unit);
 
511
   begin
 
512
      if Result = A_Public_Body and then Is_Nil (Corresponding_Declaration (Compilation_Unit)) then
 
513
         Trace_Bug ("A4G_Bugs.Unit_Class");
 
514
         return A_Public_Declaration_And_Body;
 
515
      else
 
516
         return Result;
 
517
      end if;
 
518
   end Unit_Class;
 
519
 
 
520
   ---------------
 
521
   -- Trace_Bug --
 
522
   ---------------
 
523
 
 
524
   procedure Trace_Bug (Message : Wide_String) is
 
525
      use Utilities;
 
526
   begin
 
527
      Trace ("ASIS bug workaround triggered in " & Message);  --## RULE LINE OFF No_Trace
 
528
   end Trace_Bug;
 
529
 
421
530
end A4G_Bugs;