Commit | Line | Data |
---|---|---|
86530b38 AT |
1 | package Inline::C::ParseRecDescent; |
2 | use strict; | |
3 | use Carp; | |
4 | ||
5 | sub register { | |
6 | { | |
7 | extends => [qw(C)], | |
8 | overrides => [qw(get_parser)], | |
9 | } | |
10 | } | |
11 | ||
12 | sub get_parser { | |
13 | my $o = shift; | |
14 | eval { require Parse::RecDescent }; | |
15 | croak <<END if $@; | |
16 | This innvocation of Inline requires the Parse::RecDescent module. | |
17 | $@ | |
18 | END | |
19 | $main::RD_HINT++; | |
20 | Parse::RecDescent->new(grammar()) | |
21 | } | |
22 | ||
23 | sub grammar { | |
24 | <<'END'; | |
25 | ||
26 | code: part(s) | |
27 | { | |
28 | return 1; | |
29 | } | |
30 | ||
31 | part: comment | |
32 | | function_definition | |
33 | { | |
34 | my $function = $item[1][0]; | |
35 | $return = 1, last if $thisparser->{data}{done}{$function}++; | |
36 | push @{$thisparser->{data}{functions}}, $function; | |
37 | $thisparser->{data}{function}{$function}{return_type} = | |
38 | $item[1][1]; | |
39 | $thisparser->{data}{function}{$function}{arg_types} = | |
40 | [map {ref $_ ? $_->[0] : '...'} @{$item[1][2]}]; | |
41 | $thisparser->{data}{function}{$function}{arg_names} = | |
42 | [map {ref $_ ? $_->[1] : '...'} @{$item[1][2]}]; | |
43 | } | |
44 | | function_declaration | |
45 | { | |
46 | $return = 1, last unless $thisparser->{data}{AUTOWRAP}; | |
47 | my $function = $item[1][0]; | |
48 | $return = 1, last if $thisparser->{data}{done}{$function}++; | |
49 | my $dummy = 'arg1'; | |
50 | push @{$thisparser->{data}{functions}}, $function; | |
51 | $thisparser->{data}{function}{$function}{return_type} = | |
52 | $item[1][1]; | |
53 | $thisparser->{data}{function}{$function}{arg_types} = | |
54 | [map {ref $_ ? $_->[0] : '...'} @{$item[1][2]}]; | |
55 | $thisparser->{data}{function}{$function}{arg_names} = | |
56 | [map {ref $_ ? ($_->[1] || $dummy++) : '...'} @{$item[1][2]}]; | |
57 | } | |
58 | | anything_else | |
59 | ||
60 | comment: | |
61 | m{\s* // [^\n]* \n }x | |
62 | | m{\s* /\* (?:[^*]+|\*(?!/))* \*/ ([ \t]*)? }x | |
63 | ||
64 | function_definition: | |
65 | rtype IDENTIFIER '(' <leftop: arg ',' arg>(s?) ')' '{' | |
66 | { | |
67 | [@item[2,1], $item[4]] | |
68 | } | |
69 | ||
70 | function_declaration: | |
71 | rtype IDENTIFIER '(' <leftop: arg_decl ',' arg_decl>(s?) ')' ';' | |
72 | { | |
73 | [@item[2,1], $item[4]] | |
74 | } | |
75 | ||
76 | rtype: rtype1 | rtype2 | |
77 | ||
78 | rtype1: modifier(s?) TYPE star(s?) | |
79 | { | |
80 | $return = $item[2]; | |
81 | $return = join ' ',@{$item[1]},$return | |
82 | if @{$item[1]} and $item[1][0] ne 'extern'; | |
83 | $return .= join '',' ',@{$item[3]} if @{$item[3]}; | |
84 | return undef unless (defined $thisparser->{data}{typeconv} | |
85 | {valid_rtypes}{$return}); | |
86 | } | |
87 | ||
88 | rtype2: modifier(s) star(s?) | |
89 | { | |
90 | $return = join ' ',@{$item[1]}; | |
91 | $return .= join '',' ',@{$item[2]} if @{$item[2]}; | |
92 | return undef unless (defined $thisparser->{data}{typeconv} | |
93 | {valid_rtypes}{$return}); | |
94 | } | |
95 | ||
96 | arg: type IDENTIFIER {[@item[1,2]]} | |
97 | | '...' | |
98 | ||
99 | arg_decl: | |
100 | type IDENTIFIER(s?) {[$item[1], $item[2][0] || '']} | |
101 | | '...' | |
102 | ||
103 | type: type1 | type2 | |
104 | ||
105 | type1: modifier(s?) TYPE star(s?) | |
106 | { | |
107 | $return = $item[2]; | |
108 | $return = join ' ',@{$item[1]},$return if @{$item[1]}; | |
109 | $return .= join '',' ',@{$item[3]} if @{$item[3]}; | |
110 | return undef unless (defined $thisparser->{data}{typeconv} | |
111 | {valid_types}{$return}); | |
112 | } | |
113 | ||
114 | type2: modifier(s) star(s?) | |
115 | { | |
116 | $return = join ' ',@{$item[1]}; | |
117 | $return .= join '',' ',@{$item[2]} if @{$item[2]}; | |
118 | return undef unless (defined $thisparser->{data}{typeconv} | |
119 | {valid_types}{$return}); | |
120 | } | |
121 | ||
122 | modifier: | |
123 | 'unsigned' | 'long' | 'extern' | 'const' | |
124 | ||
125 | star: '*' | |
126 | ||
127 | IDENTIFIER: | |
128 | /\w+/ | |
129 | ||
130 | TYPE: /\w+/ | |
131 | ||
132 | anything_else: | |
133 | /.*/ | |
134 | ||
135 | END | |
136 | } | |
137 | ||
138 | my $hack = sub { # Appease -w using Inline::Files | |
139 | print Parse::RecDescent::IN ''; | |
140 | print Parse::RecDescent::IN ''; | |
141 | print Parse::RecDescent::TRACE_FILE ''; | |
142 | print Parse::RecDescent::TRACE_FILE ''; | |
143 | }; | |
144 | ||
145 | 1; | |
146 | ||
147 | __DATA__ | |
148 | ||
149 | =head1 NAME | |
150 | ||
151 | Inline::C::ParseRecDescent - The Classic Inline::C Parser | |
152 | ||
153 | =head1 SYNOPSIS | |
154 | ||
155 | use Inline C => DATA => | |
156 | USING => ParseRecDescent | |
157 | ||
158 | =head1 DESCRIPTION | |
159 | ||
160 | This module is Inline::C's original Parse::RecDescent based parser. It | |
161 | was previously packaged as Inline::C::grammar. | |
162 | ||
163 | Try Inline::C::ParseRegExp for an alternative. | |
164 | ||
165 | =head2 AUTHOR | |
166 | ||
167 | Brian Ingerson <ingy@ttul.org> | |
168 | ||
169 | =head1 COPYRIGHT | |
170 | ||
171 | Copyright (c) 2002. Brian Ingerson. All rights reserved. | |
172 | ||
173 | This program is free software; you can redistribute it and/or modify it | |
174 | under the same terms as Perl itself. | |
175 | ||
176 | See http://www.perl.com/perl/misc/Artistic.html | |
177 | ||
178 | =cut |