xref: /petsc/lib/petsc/bin/maint/abi-compliance-checker/modules/Internals/TypeAttr.pm (revision e8b6250908b962c387f7ab2e7b38caaa661b5fa1) 
1###########################################################################
2# A module to handle type attributes
3#
4# Copyright (C) 2015-2018 Andrey Ponomarenko's ABI Laboratory
5#
6# Written by Andrey Ponomarenko
7#
8# This library is free software; you can redistribute it and/or
9# modify it under the terms of the GNU Lesser General Public
10# License as published by the Free Software Foundation; either
11# version 2.1 of the License, or (at your option) any later version.
12#
13# This library is distributed in the hope that it will be useful,
14# but WITHOUT ANY WARRANTY; without even the implied warranty of
15# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
16# Lesser General Public License for more details.
17#
18# You should have received a copy of the GNU Lesser General Public
19# License along with this library; if not, write to the Free Software
20# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,
21# MA  02110-1301 USA
22###########################################################################
23use strict;
24
25my %Cache;
26
27my %TypeSpecAttributes = (
28    "Const" => 1,
29    "Volatile" => 1,
30    "ConstVolatile" => 1,
31    "Restrict" => 1,
32    "Typedef" => 1
33);
34
35my (%TypeInfo, %TName_Tid) = ();
36
37sub initAliases_TypeAttr($)
38{
39    my $LVer = $_[0];
40
41    $TypeInfo{$LVer} = $In::ABI{$LVer}{"TypeInfo"};
42    $TName_Tid{$LVer} = $In::ABI{$LVer}{"TName_Tid"};
43}
44
45sub getTypeIdByName($$)
46{
47    my ($TypeName, $LVer) = @_;
48    return $TName_Tid{$LVer}{formatName($TypeName, "T")};
49}
50
51sub getShortClass($$)
52{
53    my ($TypeId, $LVer) = @_;
54    my $TypeName = $TypeInfo{$LVer}{$TypeId}{"Name"};
55    if($TypeInfo{$LVer}{$TypeId}{"Type"}!~/Intrinsic|Class|Struct|Union|Enum/) {
56        $TypeName = uncoverTypedefs($TypeName, $LVer);
57    }
58    if(my $NameSpace = $TypeInfo{$LVer}{$TypeId}{"NameSpace"}) {
59        $TypeName=~s/\A(struct |)\Q$NameSpace\E\:\://g;
60    }
61    return $TypeName;
62}
63
64sub goToFirst($$$)
65{
66    my ($TypeId, $LVer, $Type_Type) = @_;
67
68    if(defined $Cache{"goToFirst"}{$TypeId}{$LVer}{$Type_Type}) {
69        return %{$Cache{"goToFirst"}{$TypeId}{$LVer}{$Type_Type}};
70    }
71    if(not $TypeInfo{$LVer}{$TypeId}) {
72        return ();
73    }
74    my %Type = %{$TypeInfo{$LVer}{$TypeId}};
75    if(not $Type{"Type"}) {
76        return ();
77    }
78    if($Type{"Type"} ne $Type_Type)
79    {
80        if(not $Type{"BaseType"}) {
81            return ();
82        }
83        %Type = goToFirst($Type{"BaseType"}, $LVer, $Type_Type);
84    }
85    $Cache{"goToFirst"}{$TypeId}{$LVer}{$Type_Type} = \%Type;
86    return %Type;
87}
88
89sub getPureType($$)
90{
91    my ($TypeId, $LVer) = @_;
92    if(not $TypeInfo{$LVer}{$TypeId}) {
93        return ();
94    }
95    if(defined $Cache{"getPureType"}{$TypeId}{$LVer}) {
96        return %{$Cache{"getPureType"}{$TypeId}{$LVer}};
97    }
98    my %Type = %{$TypeInfo{$LVer}{$TypeId}};
99    if(not $Type{"BaseType"}) {
100        return %Type;
101    }
102    if($TypeSpecAttributes{$Type{"Type"}}) {
103        %Type = getPureType($Type{"BaseType"}, $LVer);
104    }
105    $Cache{"getPureType"}{$TypeId}{$LVer} = \%Type;
106    return %Type;
107}
108
109sub getPLevel($$)
110{
111    my ($TypeId, $LVer) = @_;
112
113    if(defined $Cache{"getPLevel"}{$TypeId}{$LVer}) {
114        return $Cache{"getPLevel"}{$TypeId}{$LVer};
115    }
116    if(not $TypeInfo{$LVer}{$TypeId}) {
117        return 0;
118    }
119    my %Type = %{$TypeInfo{$LVer}{$TypeId}};
120    if($Type{"Type"}=~/FuncPtr|FieldPtr/) {
121        return 1;
122    }
123    my $PLevel = 0;
124    if($Type{"Type"} =~/Pointer|Ref|FuncPtr|FieldPtr/) {
125        $PLevel += 1;
126    }
127    if(not $Type{"BaseType"}) {
128        return $PLevel;
129    }
130    $PLevel += getPLevel($Type{"BaseType"}, $LVer);
131    $Cache{"getPLevel"}{$TypeId}{$LVer} = $PLevel;
132    return $PLevel;
133}
134
135sub getBaseType($$)
136{
137    my ($TypeId, $LVer) = @_;
138
139    if(defined $Cache{"getBaseType"}{$TypeId}{$LVer}) {
140        return %{$Cache{"getBaseType"}{$TypeId}{$LVer}};
141    }
142    if(not $TypeInfo{$LVer}{$TypeId}) {
143        return ();
144    }
145    my %Type = %{$TypeInfo{$LVer}{$TypeId}};
146    if(not $Type{"BaseType"}) {
147        return %Type;
148    }
149    %Type = getBaseType($Type{"BaseType"}, $LVer);
150    $Cache{"getBaseType"}{$TypeId}{$LVer} = \%Type;
151    return %Type;
152}
153
154sub getOneStepBaseType($$)
155{
156    my ($TypeId, $LVer) = @_;
157
158    if(not $TypeInfo{$LVer}{$TypeId}) {
159        return ();
160    }
161
162    my %Type = %{$TypeInfo{$LVer}{$TypeId}};
163    if(not $Type{"BaseType"}) {
164        return %Type;
165    }
166    if(my $BTid = $Type{"BaseType"})
167    {
168        if($TypeInfo{$LVer}{$BTid}) {
169            return %{$TypeInfo{$LVer}{$BTid}};
170        }
171
172        # something is going wrong
173        return ();
174    }
175
176    return %Type;
177}
178
179sub getType($$)
180{
181    my ($TypeId, $LVer) = @_;
182
183    if(not $TypeInfo{$LVer}{$TypeId}) {
184        return ();
185    }
186    return %{$TypeInfo{$LVer}{$TypeId}};
187}
188
189sub getBaseTypeQual($$)
190{
191    my ($TypeId, $LVer) = @_;
192    if(not $TypeInfo{$LVer}{$TypeId}) {
193        return "";
194    }
195    my %Type = %{$TypeInfo{$LVer}{$TypeId}};
196    if(not $Type{"BaseType"}) {
197        return "";
198    }
199    my $Qual = "";
200    if($Type{"Type"} eq "Pointer") {
201        $Qual .= "*";
202    }
203    elsif($Type{"Type"} eq "Ref") {
204        $Qual .= "&";
205    }
206    elsif($Type{"Type"} eq "ConstVolatile") {
207        $Qual .= "const volatile";
208    }
209    elsif($Type{"Type"} eq "Const"
210    or $Type{"Type"} eq "Volatile"
211    or $Type{"Type"} eq "Restrict") {
212        $Qual .= lc($Type{"Type"});
213    }
214    my $BQual = getBaseTypeQual($Type{"BaseType"}, $LVer);
215    return $BQual.$Qual;
216}
217
218sub isCopyingClass($$)
219{
220    my ($TypeId, $LVer) = @_;
221    return $TypeInfo{$LVer}{$TypeId}{"Copied"};
222}
223
224sub getSubClasses($$$)
225{
226    my ($ClassId, $LVer, $Recursive) = @_;
227    if(not defined $In::ABI{$LVer}{"Class_SubClasses"}{$ClassId}) {
228        return ();
229    }
230
231    my @Subs = ();
232    foreach my $SubId (keys(%{$In::ABI{$LVer}{"Class_SubClasses"}{$ClassId}}))
233    {
234        if($Recursive)
235        {
236            foreach my $SubSubId (getSubClasses($SubId, $LVer, $Recursive)) {
237                push(@Subs, $SubSubId);
238            }
239        }
240        push(@Subs, $SubId);
241    }
242    return @Subs;
243}
244
245sub getBaseClasses($$$)
246{
247    my ($ClassId, $LVer, $Recursive) = @_;
248    my %ClassType = getType($ClassId, $LVer);
249    if(not defined $ClassType{"Base"}) {
250        return ();
251    }
252
253    my @Bases = ();
254    foreach my $BaseId (sort {$ClassType{"Base"}{$a}{"pos"}<=>$ClassType{"Base"}{$b}{"pos"}}
255    keys(%{$ClassType{"Base"}}))
256    {
257        if($Recursive)
258        {
259            foreach my $SubBaseId (getBaseClasses($BaseId, $LVer, $Recursive)) {
260                push(@Bases, $SubBaseId);
261            }
262        }
263        push(@Bases, $BaseId);
264    }
265    return @Bases;
266}
267
268return 1;
269