pidl: get the alignment right for uint1632 enums (NDR64)
[ira/wip.git] / pidl / lib / Parse / Pidl / Typelist.pm
1 ###################################################
2 # Samba4 parser generator for IDL structures
3 # Copyright jelmer@samba.org 2005
4 # released under the GNU GPL
5
6 package Parse::Pidl::Typelist;
7
8 require Exporter;
9 @ISA = qw(Exporter);
10 @EXPORT_OK = qw(hasType getType resolveType mapTypeName scalar_is_reference expandAlias
11                             mapScalarType addType typeIs is_signed is_scalar enum_type_fn
12                                 bitmap_type_fn mapType typeHasBody
13 );
14 use vars qw($VERSION);
15 $VERSION = '0.01';
16
17 use Parse::Pidl::Util qw(has_property);
18 use strict;
19
20 my %types = ();
21
22 my @reference_scalars = (
23         "string", "string_array", "nbt_string", 
24         "wrepl_nbt_name", "ipv4address"
25 );
26
27 # a list of known scalar types
28 my %scalars = (
29         "void"          => "void",
30         "char"          => "char",
31         "int8"          => "int8_t",
32         "uint8"         => "uint8_t",
33         "int16"         => "int16_t",
34         "uint16"        => "uint16_t",
35         "int1632"       => "int16_t",
36         "uint1632"      => "uint16_t",
37         "int32"         => "int32_t",
38         "uint32"        => "uint32_t",
39         "int3264"       => "int32_t",
40         "uint3264"      => "uint32_t",
41         "hyper"         => "uint64_t",
42         "dlong"         => "int64_t",
43         "udlong"        => "uint64_t",
44         "udlongr"       => "uint64_t",
45         "double"        => "double",
46         "pointer"       => "void*",
47         "DATA_BLOB"     => "DATA_BLOB",
48         "string"        => "const char *",
49         "string_array"  => "const char **",
50         "time_t"        => "time_t",
51         "NTTIME"        => "NTTIME",
52         "NTTIME_1sec"   => "NTTIME",
53         "NTTIME_hyper"  => "NTTIME",
54         "WERROR"        => "WERROR",
55         "NTSTATUS"      => "NTSTATUS",
56         "COMRESULT" => "COMRESULT",
57         "nbt_string"    => "const char *",
58         "wrepl_nbt_name"=> "struct nbt_name *",
59         "ipv4address"   => "const char *",
60 );
61
62 my %aliases = (
63         "error_status_t" => "uint32",
64         "boolean8" => "uint8",
65         "boolean32" => "uint32",
66         "DWORD" => "uint32",
67         "uint" => "uint32",
68         "int" => "int32",
69         "WORD" => "uint16",
70         "char" => "uint8",
71         "long" => "int32",
72         "short" => "int16",
73         "HYPER_T" => "hyper",
74         "HRESULT" => "COMRESULT",
75 );
76
77 sub expandAlias($)
78 {
79         my $name = shift;
80
81         return $aliases{$name} if defined($aliases{$name});
82
83         return $name;
84 }
85
86 # map from a IDL type to a C header type
87 sub mapScalarType($)
88 {
89         my $name = shift;
90
91         # it's a bug when a type is not in the list
92         # of known scalars or has no mapping
93         return $scalars{$name} if defined($scalars{$name});
94
95         die("Unknown scalar type $name");
96 }
97
98 sub addType($)
99 {
100         my $t = shift;
101         $types{$t->{NAME}} = $t;
102 }
103
104 sub resolveType($)
105 {
106         my ($ctype) = @_;
107
108         if (not hasType($ctype)) {
109                 # assume struct typedef
110                 return { TYPE => "TYPEDEF", NAME => $ctype, DATA => { TYPE => "STRUCT" } };
111         } else {
112                 return getType($ctype);
113         }
114
115         return $ctype;
116 }
117
118 sub getType($)
119 {
120         my $t = shift;
121         return ($t) if (ref($t) eq "HASH" and not defined($t->{NAME}));
122         return undef if not hasType($t);
123         return $types{$t->{NAME}} if (ref($t) eq "HASH");
124         return $types{$t};
125 }
126
127 sub typeIs($$)
128 {
129         my ($t,$tt) = @_;
130         
131         if (ref($t) eq "HASH") {
132                 return 1 if ($t->{TYPE} eq $tt);
133                 return 0;
134         }
135         return 1 if (hasType($t) and getType($t)->{TYPE} eq "TYPEDEF" and 
136                          getType($t)->{DATA}->{TYPE} eq $tt);
137         return 0;
138 }
139
140 sub hasType($)
141 {
142         my $t = shift;
143         if (ref($t) eq "HASH") {
144                 return 1 if (not defined($t->{NAME}));
145                 return 1 if (defined($types{$t->{NAME}}) and 
146                         $types{$t->{NAME}}->{TYPE} eq $t->{TYPE});
147                 return 0;
148         }
149         return 1 if defined($types{$t});
150         return 0;
151 }
152
153 sub is_signed($)
154 {
155     my $t = shift;
156
157     return ($t eq "int8"
158             or $t eq "int16"
159             or $t eq "int32"
160             or $t eq "dlong"
161             or $t eq "int"
162             or $t eq "long"
163             or $t eq "short");
164 }
165
166 sub is_scalar($)
167 {
168         sub is_scalar($);
169         my $type = shift;
170
171         return 1 if (ref($type) eq "HASH" and 
172                 ($type->{TYPE} eq "SCALAR" or $type->{TYPE} eq "ENUM" or 
173                  $type->{TYPE} eq "BITMAP"));
174
175         if (my $dt = getType($type)) {
176                 return is_scalar($dt->{DATA}) if ($dt->{TYPE} eq "TYPEDEF");
177                 return 1 if ($dt->{TYPE} eq "SCALAR" or $dt->{TYPE} eq "ENUM" or 
178                                  $dt->{TYPE} eq "BITMAP");
179         }
180
181         return 0;
182 }
183
184 sub scalar_is_reference($)
185 {
186         my $name = shift;
187
188         return 1 if (grep(/^$name$/, @reference_scalars));
189         return 0;
190 }
191
192 sub RegisterScalars()
193 {
194         foreach (keys %scalars) {
195                 addType({
196                         NAME => $_,
197                         TYPE => "TYPEDEF",
198                         BASEFILE => "<builtin>",
199                         DATA => {
200                                 TYPE => "SCALAR",
201                                 NAME => $_
202                         }
203                 }
204                 );
205         }
206 }
207
208 sub enum_type_fn($)
209 {
210         my $enum = shift;
211         $enum->{TYPE} eq "ENUM" or die("not an enum");
212
213         # for typedef enum { } we need to check $enum->{PARENT}
214         if (has_property($enum, "enum8bit")) {
215                 return "uint8";
216         } elsif (has_property($enum, "enum16bit")) {
217                 return "uint16";
218         } elsif (has_property($enum, "v1_enum")) {
219                 return "uint32";
220         } elsif (has_property($enum->{PARENT}, "enum8bit")) {
221                 return "uint8";
222         } elsif (has_property($enum->{PARENT}, "enum16bit")) {
223                 return "uint16";
224         } elsif (has_property($enum->{PARENT}, "v1_enum")) {
225                 return "uint32";
226         }
227         return "uint1632";
228 }
229
230 sub bitmap_type_fn($)
231 {
232         my $bitmap = shift;
233
234         $bitmap->{TYPE} eq "BITMAP" or die("not a bitmap");
235
236         if (has_property($bitmap, "bitmap8bit")) {
237                 return "uint8";
238         } elsif (has_property($bitmap, "bitmap16bit")) {
239                 return "uint16";
240         } elsif (has_property($bitmap, "bitmap64bit")) {
241                 return "hyper";
242         }
243         return "uint32";
244 }
245
246 sub typeHasBody($)
247 {
248         sub typeHasBody($);
249         my ($e) = @_;
250
251         if ($e->{TYPE} eq "TYPEDEF") {
252                 return 0 unless(defined($e->{DATA}));
253                 return typeHasBody($e->{DATA});
254         }
255
256         return defined($e->{ELEMENTS});
257 }
258
259 sub mapType($$)
260 {
261         sub mapType($$);
262         my ($t, $n) = @_;
263
264         return mapType($t->{DATA}, $n) if ($t->{TYPE} eq "TYPEDEF");
265         return mapScalarType($n) if ($t->{TYPE} eq "SCALAR");
266         return "enum $n" if ($t->{TYPE} eq "ENUM");
267         return "struct $n" if ($t->{TYPE} eq "STRUCT" or $t->{TYPE} eq "INTERFACE");
268         return "union $n" if ($t->{TYPE} eq "UNION");
269         return mapScalarType(bitmap_type_fn($t)) if ($t->{TYPE} eq "BITMAP");
270         die("Unknown type $t->{TYPE}");
271 }
272
273 sub mapTypeName($)
274 {
275         my $t = shift;
276         return "void" unless defined($t);
277         my $dt;
278         $t = expandAlias($t);
279
280         if ($dt = getType($t)) {
281                 return mapType($dt, $dt->{NAME});
282         } elsif (ref($t) eq "HASH" and defined($t->{NAME})) {
283                 return mapType($t, $t->{NAME});
284         } else {
285                 # Best guess
286                 return "struct $t";
287         }
288
289 }
290
291 sub LoadIdl($;$)
292 {
293         my $idl = shift;
294         my $basename = shift;
295
296         foreach my $x (@{$idl}) {
297                 next if $x->{TYPE} ne "INTERFACE";
298
299                 # DCOM interfaces can be types as well
300                 addType({
301                         NAME => $x->{NAME},
302                         TYPE => "TYPEDEF",
303                         DATA => $x,
304                         BASEFILE => $basename,
305                         }) if (has_property($x, "object"));
306
307                 foreach my $y (@{$x->{DATA}}) {
308                         if ($y->{TYPE} eq "TYPEDEF" 
309                                 or $y->{TYPE} eq "UNION"
310                                 or $y->{TYPE} eq "STRUCT"
311                         or $y->{TYPE} eq "ENUM"
312                         or $y->{TYPE} eq "BITMAP") {
313                                 $y->{BASEFILE} = $basename;
314                                 addType($y);
315                         }
316                 }
317         }
318 }
319
320 sub GenerateTypeLib()
321 {
322         return Parse::Pidl::Util::MyDumper(\%types);
323 }
324
325 RegisterScalars();
326
327 1;