← Back to branch summary

~ubuntu-branches/ubuntu/hardy/asis/hardy-proposed

« back to all changes in this revision

Viewing changes to tools/gnatelim/asis-extensions-homonyms.adb

  • Committer: Bazaar Package Importer
  • Author(s): Ludovic Brenta
  • Date: 2006-08-08 23:02:17 UTC
  • mfrom: (3.1.6 edgy)
  • Revision ID: james.westby@ubuntu.com-20060808230217-8j3ts1m8i83e0apm
Tags: 2005-5

debian/control: add support for alpha and s390.

Show diffs side-by-side

added added

removed removed

Lines of Context:
tools/gnatelim/asis-extensions-homonyms.adb
 
1
------------------------------------------------------------------------------
 
2
--                                                                          --
 
3
--                           GNATELIM COMPONENTS                            --
 
4
--                                                                          --
 
5
--             A S I S . E X T E N S I O N S . H O M O N Y M S              --
 
6
--                                                                          --
 
7
--                         P a c k a g e   B o d y                          --
 
8
--                                                                          --
 
9
--                                                                          --
 
10
--           Copyright (C) 2002-2003 Ada Core Technologies, Inc.            --
 
11
--                                                                          --
 
12
-- GNATELIM  is  free software;  you can  redistribute it and/or  modify it --
 
13
-- under the terms of the  GNU  General Public License  as published by the --
 
14
-- Free Software Foundation; either version 2 or (at your option) any later --
 
15
-- version. GNATELIM is distributed in the hope that it will be useful, but --
 
16
-- WITHOUT ANY WARRANTY; without even the implied warranty of  MERCHANTABI- --
 
17
-- LITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public Li- --
 
18
-- cense for  more details.  You should  have  received  a copy of the  GNU --
 
19
-- General Public License distributed with GNAT; see file COPYING.  If not, --
 
20
-- write to  the  Free  Software  Foundation,  59 Temple Place - Suite 330, --
 
21
-- Boston, MA 02111-1307, USA.                                              --
 
22
--                                                                          --
 
23
-- The original version  of  Gnatelim  was developed by  Alain  Le  Guennec --
 
24
-- It is now maintained by Ada Core Technologies Inc  (http://www.gnat.com) --
 
25
--                                                                          --
 
26
------------------------------------------------------------------------------
 
27
 
 
28
with Atree;    use Atree;
 
29
with Einfo;    use Einfo;
 
30
with Sinfo;    use Sinfo;
 
31
 
 
32
package body Asis.Extensions.Homonyms is
 
33
 
 
34
   -----------------
 
35
   -- Has_Homonym --
 
36
   -----------------
 
37
 
 
38
   function Has_Homonym (E : Asis.Element) return Boolean is
 
39
 
 
40
      function Has_Homonym_Internal (Entity : Entity_Id) return Boolean;
 
41
      --  Returns true if a given Entity in GNAT tree corresponds to the
 
42
      --  subprogram that has a homonym in the same scope. Derived from
 
43
      --  exp_dbug.adb
 
44
 
 
45
      --------------------------
 
46
      -- Has_Homonym_Internal --
 
47
      --------------------------
 
48
 
 
49
      function Has_Homonym_Internal (Entity : Entity_Id) return Boolean is
 
50
         E  : Entity_Id := Entity;
 
51
 
 
52
      begin
 
53
 
 
54
         --  If this is a child unit, we want the child
 
55
 
 
56
         if Nkind (E) = N_Defining_Program_Unit_Name then
 
57
            E := Defining_Identifier (Entity);
 
58
         end if;
 
59
 
 
60
         --  If the entity is a subprogram instance that is not a compilation
 
61
         --  unit, go to the original Ada entity
 
62
 
 
63
         if Is_Generic_Instance (E)
 
64
           and then Is_Subprogram (E)
 
65
           and then not Is_Compilation_Unit (Scope (E))
 
66
         then
 
67
            E := Related_Instance (Scope (E));
 
68
         end if;
 
69
 
 
70
         return Has_Homonym (E);
 
71
 
 
72
      end Has_Homonym_Internal;
 
73
 
 
74
   begin
 
75
 
 
76
      return Has_Homonym_Internal (E.R_Node);
 
77
 
 
78
   end Has_Homonym;
 
79
 
 
80
   --------------------
 
81
   -- Homonym_Number --
 
82
   --------------------
 
83
 
 
84
   function Homonym_Number (E : Asis.Element) return Natural is
 
85
 
 
86
      function Homonym_Number_Internal (Entity : Entity_Id) return Natural;
 
87
      --  Returns the homonym number of a given entity or zero if the entity
 
88
      --  has no homonyms
 
89
 
 
90
      -----------------------------
 
91
      -- Homonym_Number_Internal --
 
92
      -----------------------------
 
93
 
 
94
      function Homonym_Number_Internal (Entity : Entity_Id) return Natural is
 
95
         E  : Entity_Id := Entity;
 
96
 
 
97
      begin
 
98
 
 
99
         --  If this is a child unit, we want the child
 
100
 
 
101
         if Nkind (E) = N_Defining_Program_Unit_Name then
 
102
            E := Defining_Identifier (Entity);
 
103
         end if;
 
104
 
 
105
         --  If the entity is a subprogram instance that is not a compilation
 
106
         --  unit, go to the original Ada entity
 
107
 
 
108
         if Is_Generic_Instance (E)
 
109
           and then Is_Subprogram (E)
 
110
           and then not Is_Compilation_Unit (Scope (E))
 
111
         then
 
112
            E := Related_Instance (Scope (E));
 
113
         end if;
 
114
 
 
115
         if Has_Homonym (E) then
 
116
            declare
 
117
               H  : Entity_Id := Homonym (E);
 
118
               Nr : Natural := 1;
 
119
 
 
120
            begin
 
121
               while Present (H) loop
 
122
                  if Scope (H) = Scope (E) then
 
123
                     Nr := Nr + 1;
 
124
                  end if;
 
125
 
 
126
                  H := Homonym (H);
 
127
               end loop;
 
128
               return Nr;
 
129
            end;
 
130
         else
 
131
            return 0;
 
132
         end if;
 
133
      end Homonym_Number_Internal;
 
134
 
 
135
   begin
 
136
 
 
137
      return Homonym_Number_Internal (E.R_Node);
 
138
 
 
139
   end Homonym_Number;
 
140
 
 
141
end Asis.Extensions.Homonyms;