File Coverage

blib/lib/Tangence/Compiler/Parser.pm
Criterion Covered Total %
statement 153 154 99.3
branch 24 36 66.6
condition 3 3 100.0
subroutine 33 33 100.0
pod 8 15 53.3
total 221 241 91.7


line stmt bran cond sub pod time code
1             # You may distribute under the terms of either the GNU General Public License
2             # or the Artistic License (the same terms as Perl itself)
3             #
4             # (C) Paul Evans, 2011-2021 -- leonerd@leonerd.org.uk
5              
6 13     13   59443 use v5.26;
  13         50  
7 13     13   547 use Object::Pad 0.41;
  13         8546  
  13         61  
8              
9             package Tangence::Compiler::Parser 0.28;
10 13     13   7412 class Tangence::Compiler::Parser isa Parser::MGC;
  13         251208  
  13         978  
11              
12 13     13   8251 use Syntax::Keyword::Dynamically;
  13         8793  
  13         77  
13 13     13   1080 use Syntax::Keyword::Match;
  13         675  
  13         86  
14              
15 13     13   734 use File::Basename qw( dirname );
  13         32  
  13         1033  
16              
17 13     13   2070 use Tangence::Constants;
  13         52  
  13         3575  
18              
19             # Parsing is simpler if we treat Package.Name as a simple identifier
20 13     13   92 use constant pattern_ident => qr/[[:alnum:]_][\w.]*/;
  13         21  
  13         1033  
21              
22 13     13   73 use constant pattern_comment => qr/#.*\n/;
  13         21  
  13         45741  
23              
24             =head1 NAME
25              
26             C - parse C interface definition files
27              
28             =head1 DESCRIPTION
29              
30             This subclass of L parses a L interface definition and
31             returns a metadata tree.
32              
33             =cut
34              
35             =head1 GRAMMAR
36              
37             The top level of an interface definition file contains C directives
38             and C and C definitions.
39              
40             =head2 include
41              
42             An C directive imports the definitions from another file, named
43             relative to the current file.
44              
45             include "filename.tan"
46              
47             =head2 class
48              
49             A C definition defines the set of methods, events and properties
50             defined by a named class.
51              
52             class N {
53             ...
54             }
55              
56             The contents of the class block will be a list of C, C, C
57             and C declarations.
58              
59             =head2 struct
60              
61             A C definition defines the list of fields contained within a named
62             structure type.
63              
64             struct N {
65             ...
66             }
67              
68             The contents of the struct block will be a list of C declarations.
69              
70             =cut
71              
72             has $_package;
73              
74             # Parser::MGC version 0.20 adds this method. Before then, this workaround is
75             # known to be safe
76             if( $Parser::MGC::VERSION < 0.20 ) {
77 2     2   4 *filename = sub ( $self ) { $self->{filename} };
  2         4  
  2         3  
  2         139  
78             }
79              
80             method parse
81 15     15 0 2407 {
82 15         103 dynamically $_package = \my %package;
83              
84 15         86 while( !$self->at_eos ) {
85             match( $self->token_kw(qw( class struct include )) : eq ) {
86             case( 'class' ) {
87 15         2392 my $classname = $self->token_ident;
88              
89 15 50       810 exists $package{$classname} and
90             $self->fail( "Already have a class or struct called $classname" );
91              
92 15         62 my $class = $self->make_class( name => $classname );
93 15         40 $package{$classname} = $class;
94              
95 15     15   156 $self->scope_of( '{', sub { $self->parse_classblock( $class ) }, '}' ),
  15         1319  
96             }
97             case( 'struct' ) {
98 11         816 my $structname = $self->token_ident;
99              
100 11 50       547 exists $package{$structname} and
101             $self->fail( "Already have a class or struct called $structname" );
102              
103 11         52 my $struct = $self->make_struct( name => $structname );
104 11         33 $package{$structname} = $struct;
105              
106 11     11   65 $self->scope_of( '{', sub { $self->parse_structblock( $struct ) }, '}' ),
  11         767  
107             }
108             case( 'include' ) {
109 2         361 my $filename = dirname($self->filename) . "/" . $self->token_string;
110              
111 2         237 my $subparser = (ref $self)->new;
112 2         11 my $included = $subparser->from_file( $filename );
113              
114 2         50 foreach my $classname ( keys %$included ) {
115 2 50       6 exists $package{$classname} and
116             $self->fail( "Cannot include '$filename' as class $classname collides" );
117              
118 2         23 $package{$classname} = $included->{$classname};
119             }
120             }
121 28 100       1765 default {
    100          
    50          
122 0         0 $self->fail( "Expected keyword, found $_" );
123             }
124             }
125             }
126              
127 15         1119 return \%package;
128             }
129              
130             =head2 method
131              
132             A C declaration defines one method in the class, giving its name (N)
133             and types of its arguments and and return (T).
134              
135             method N(T, T, ...) -> T;
136              
137             =head2 event
138              
139             An C declaration defines one event raised by the class, giving its name
140             (N) and types of its arguments (T).
141              
142             event N(T, T, ...);
143              
144             =head2 prop
145              
146             A C declaration defines one property supported by the class, giving its
147             name (N), dimension (D) and type (T). It may be declared as a C
148             property.
149              
150             [smashed] prop N = D of T;
151              
152             Scalar properties may omit the C, by supplying just the type
153              
154             [smashed] prop N = T;
155              
156             =head2 isa
157              
158             An C declaration declares a superclass of the class, by its name (C)
159              
160             isa C;
161              
162             =cut
163              
164 15         28 method parse_classblock ( $class )
  15         26  
  15         25  
165 15     15 0 50 {
166 15         58 my %methods;
167             my %events;
168 15         0 my %properties;
169 15         0 my @superclasses;
170              
171 15         48 while( !$self->at_eos ) {
172             match( $_ = $self->token_kw(qw( method event prop smashed isa )) : eq ) {
173             case( 'method' ) {
174 24         1743 my $methodname = $self->token_ident;
175              
176 24 50       1144 exists $methods{$methodname} and
177             $self->fail( "Already have a method called $methodname" );
178              
179 24         115 my $args = $self->parse_arglist;
180 24         1679 my $ret;
181              
182             $self->maybe( sub {
183 24     24   281 $self->expect( '->' );
184              
185 13         556 $ret = $self->parse_type;
186 24         125 } );
187              
188 24         891 $methods{$methodname} = $self->make_method(
189             class => $class,
190             name => $methodname,
191             arguments => $args,
192             ret => $ret,
193             );
194             }
195              
196             case( 'event' ) {
197 13         1019 my $eventname = $self->token_ident;
198              
199 13 50       652 exists $events{$eventname} and
200             $self->fail( "Already have an event called $eventname" );
201              
202 13         45 my $args = $self->parse_arglist;
203              
204 13         840 $events{$eventname} = $self->make_event(
205             class => $class,
206             name => $eventname,
207             arguments => $args,
208             );
209             }
210              
211             case( 'smashed' ), case( 'prop' ) {
212 92         6600 my $smashed = 0;
213              
214 92 100       209 if( $_ eq 'smashed' ) {
215 24         44 $smashed = 1;
216 24         89 $self->expect( 'prop' );
217             }
218              
219 92         1205 my $propname = $self->token_ident;
220              
221 92 50       4408 exists $properties{$propname} and
222             $self->fail( "Already have a property called $propname" );
223              
224 92         240 $self->expect( '=' );
225              
226 92         3703 my $dim = DIM_SCALAR;
227             $self->maybe( sub {
228 92     92   1068 $dim = $self->parse_dim;
229 55         124 $self->expect( 'of' );
230 92         486 } );
231              
232 92         6271 my $type = $self->parse_type;
233              
234 92         499 $properties{$propname} = $self->make_property(
235             class => $class,
236             name => $propname,
237             smashed => $smashed,
238             dimension => $dim,
239             type => $type,
240             );
241             }
242              
243 131 100 100     7993 case( 'isa' ) {
    100          
    100          
    50          
244 2         146 my $supername = $self->token_ident;
245              
246 2 50       101 my $super = $_package->{$supername} or
247             $self->fail( "Unrecognised superclass $supername" );
248              
249 2         12 push @superclasses, $super;
250             }
251             }
252              
253 131         344 $self->expect( ';' );
254             }
255              
256             $class->define(
257 15         1062 methods => \%methods,
258             events => \%events,
259             properties => \%properties,
260             superclasses => \@superclasses,
261             );
262             }
263              
264             method parse_arglist
265 37     37 0 96 {
266             return $self->scope_of(
267             "(",
268 37     37   2205 sub { $self->list_of( ",", \&parse_arg ) },
269 37         172 ")",
270             );
271             }
272              
273             method parse_arg
274 48     48 0 2367 {
275 48         73 my $name;
276 48         142 my $type = $self->parse_type;
277             $self->maybe( sub {
278 48     48   565 $name = $self->token_ident;
279 48         406 } );
280 48         2667 return $self->make_argument( name => $name, type => $type );
281             }
282              
283 11         37 method parse_structblock ( $struct )
  11         28  
  11         22  
284 11     11 0 55 {
285 11         26 my @fields;
286             my %fieldnames;
287              
288 11         49 while( !$self->at_eos ) {
289             match( $self->token_kw(qw( field )) : eq ) {
290 55 50       3269 case( 'field' ) {
291 55         3522 my $fieldname = $self->token_ident;
292              
293 55 50       2641 exists $fieldnames{$fieldname} and
294             $self->fail( "Already have a field called $fieldname" );
295              
296 55         137 $self->expect( '=' );
297              
298 55         2229 my $type = $self->parse_type;
299              
300 55         330 push @fields, $self->make_field(
301             name => $fieldname,
302             type => $type,
303             );
304 55         137 $fieldnames{$fieldname}++;
305             }
306             }
307 55         132 $self->expect( ';' );
308             }
309              
310             $struct->define(
311 11         759 fields => \@fields,
312             );
313             }
314              
315             =head2 Types
316              
317             The following basic type names are recognised
318              
319             bool int str obj any
320             s8 s16 s32 s64 u8 u16 u32 u64
321              
322             Aggregate types may be formed of any type (T) by
323              
324             list(T) dict(T)
325              
326             =cut
327              
328             my @basic_types = qw(
329             bool
330             int
331             s8 s16 s32 s64 u8 u16 u32 u64
332             float
333             float16 float32 float64
334             str
335             obj
336             any
337             );
338              
339             method parse_type
340 219     219 0 1089 {
341             $self->any_of(
342             sub {
343 219     219   2672 my $aggregate = $self->token_kw(qw( list dict ));
344              
345 11         785 $self->commit;
346              
347 11         104 my $membertype = $self->scope_of( "(", \&parse_type, ")" );
348              
349 11         484 return $self->make_type( $aggregate => $membertype );
350             },
351             sub {
352 208     208   22407 my $typename = $self->token_ident;
353              
354 208 50       10288 grep { $_ eq $typename } @basic_types or
  3536         4737  
355             $self->fail( "'$typename' is not a typename" );
356              
357 208         555 return $self->make_type( $typename );
358             },
359 219         1128 );
360             }
361              
362             my %dimensions = (
363             scalar => DIM_SCALAR,
364             hash => DIM_HASH,
365             queue => DIM_QUEUE,
366             array => DIM_ARRAY,
367             objset => DIM_OBJSET,
368             );
369              
370             method parse_dim
371 92     92 0 211 {
372 92         321 my $dimname = $self->token_kw( keys %dimensions );
373              
374 55         4271 return $dimensions{$dimname};
375             }
376              
377             =head1 SUBCLASS METHODS
378              
379             If this class is subclassed, the following methods may be overridden to
380             customise the behaviour. They allow the subclass to return different objects
381             in the syntax tree.
382              
383             =cut
384              
385             =head2 make_class
386              
387             $class = $parser->make_class( name => $name )
388              
389             Return a new instance of L to go in a package. The
390             parser will call C on it.
391              
392             =cut
393              
394             method make_class
395 3     3 1 7 {
396 3         406 require Tangence::Meta::Class;
397 3         24 return Tangence::Meta::Class->new( @_ );
398             }
399              
400             =head2 make_struct
401              
402             $struct = $parser->make_struct( name => $name )
403              
404             Return a new instance of L to go in a package. The
405             parser will call C on it.
406              
407             =cut
408              
409             method make_struct
410 1     1 1 3 {
411 1         435 require Tangence::Meta::Struct;
412 1         9 return Tangence::Meta::Struct->new( @_ );
413             }
414              
415             =head2 make_method
416              
417             $method = $parser->make_method( %args )
418              
419             =head2 make_event
420              
421             $event = $parser->make_event( %args )
422              
423             =head2 make_property
424              
425             $property = $parser->make_property( %args )
426              
427             Return a new instance of L, L
428             or L to go in a class.
429              
430             =cut
431              
432             method make_method
433 24     24 1 62 {
434 24         490 require Tangence::Meta::Method;
435 24         166 return Tangence::Meta::Method->new( @_ );
436             }
437              
438             method make_event
439 13     13 1 41 {
440 13         437 require Tangence::Meta::Event;
441 13         119 return Tangence::Meta::Event->new( @_ );
442             }
443              
444             method make_property
445 10     10 1 19 {
446 10         426 require Tangence::Meta::Property;
447 10         47 return Tangence::Meta::Property->new( @_ );
448             }
449              
450             =head2 make_argument
451              
452             $argument = $parser->make_argument( %args )
453              
454             Return a new instance of L to use for a method
455             or event argument.
456              
457             =cut
458              
459             method make_argument
460 48     48 1 112 {
461 48         612 require Tangence::Meta::Argument;
462 48         271 return Tangence::Meta::Argument->new( @_ );
463             }
464              
465             =head2 make_field
466              
467             $field = $parser->make_field( %args )
468              
469             Return a new instance of L to use for a structure type.
470              
471             =cut
472              
473             method make_field
474 55     55 1 135 {
475 55         649 require Tangence::Meta::Field;
476 55         274 return Tangence::Meta::Field->new( @_ );
477             }
478              
479             =head2 make_type
480              
481             $type = $parser->make_type( $primitive_name )
482              
483             $type = $parser->make_type( $aggregate_name => $member_type )
484              
485             Return an instance of L representing the given
486             primitive or aggregate type name. An implementation is allowed to use
487             singleton objects and return identical objects for the same primitive name or
488             aggregate and member type.
489              
490             =cut
491              
492             method make_type
493 24     24 1 54 {
494 24         531 require Tangence::Meta::Type;
495 24         75 return Tangence::Meta::Type->make( @_ );
496             }
497              
498             =head1 AUTHOR
499              
500             Paul Evans
501              
502             =cut
503              
504             0x55AA;