Commit | Line | Data |
2304df62 |
1 | #!./miniperl |
75f92628 |
2 | |
3 | =head1 NAME |
4 | |
5 | xsubpp - compiler to convert Perl XS code into C code |
6 | |
7 | =head1 SYNOPSIS |
8 | |
b26a54d0 |
9 | B<xsubpp> [B<-v>] [B<-C++>] [B<-except>] [B<-s pattern>] [B<-prototypes>] [B<-noversioncheck>] [B<-nolinenumbers>] [B<-nooptimize>] [B<-typemap typemap>] ... file.xs |
75f92628 |
10 | |
11 | =head1 DESCRIPTION |
12 | |
b26a54d0 |
13 | This compiler is typically run by the makefiles created by L<ExtUtils::MakeMaker>. |
14 | |
75f92628 |
15 | I<xsubpp> will compile XS code into C code by embedding the constructs |
16 | necessary to let C functions manipulate Perl values and creates the glue |
17 | necessary to let Perl access those functions. The compiler uses typemaps to |
18 | determine how to map C function parameters and variables to Perl values. |
19 | |
20 | The compiler will search for typemap files called I<typemap>. It will use |
21 | the following search path to find default typemaps, with the rightmost |
22 | typemap taking precedence. |
23 | |
24 | ../../../typemap:../../typemap:../typemap:typemap |
25 | |
26 | =head1 OPTIONS |
27 | |
b26a54d0 |
28 | Note that the C<XSOPT> MakeMaker option may be used to add these options to |
29 | any makefiles generated by MakeMaker. |
30 | |
75f92628 |
31 | =over 5 |
32 | |
33 | =item B<-C++> |
34 | |
35 | Adds ``extern "C"'' to the C code. |
36 | |
0ab125c1 |
37 | =item B<-hiertype> |
38 | |
39 | Retains '::' in type names so that C++ hierachical types can be mapped. |
40 | |
75f92628 |
41 | =item B<-except> |
42 | |
43 | Adds exception handling stubs to the C code. |
44 | |
45 | =item B<-typemap typemap> |
46 | |
47 | Indicates that a user-supplied typemap should take precedence over the |
48 | default typemaps. This option may be used multiple times, with the last |
49 | typemap having the highest precedence. |
50 | |
8e07c86e |
51 | =item B<-v> |
52 | |
53 | Prints the I<xsubpp> version number to standard output, then exits. |
54 | |
8fc38fda |
55 | =item B<-prototypes> |
382b8d97 |
56 | |
8fc38fda |
57 | By default I<xsubpp> will not automatically generate prototype code for |
58 | all xsubs. This flag will enable prototypes. |
59 | |
60 | =item B<-noversioncheck> |
61 | |
62 | Disables the run time test that determines if the object file (derived |
63 | from the C<.xs> file) and the C<.pm> files have the same version |
64 | number. |
382b8d97 |
65 | |
6f1abe2b |
66 | =item B<-nolinenumbers> |
67 | |
68 | Prevents the inclusion of `#line' directives in the output. |
69 | |
b26a54d0 |
70 | =item B<-nooptimize> |
71 | |
72 | Disables certain optimizations. The only optimization that is currently |
73 | affected is the use of I<target>s by the output C code (see L<perlguts>). |
74 | This may significantly slow down the generated code, but this is the way |
75 | B<xsubpp> of 5.005 and earlier operated. |
76 | |
11416672 |
77 | =item B<-noinout> |
78 | |
79 | Disable recognition of C<IN>, C<OUT_LIST> and C<INOUT_LIST> declarations. |
80 | |
81 | =item B<-noargtypes> |
82 | |
83 | Disable recognition of ANSI-like descriptions of function signature. |
84 | |
c5be433b |
85 | =back |
75f92628 |
86 | |
87 | =head1 ENVIRONMENT |
88 | |
89 | No environment variables are used. |
90 | |
91 | =head1 AUTHOR |
92 | |
93 | Larry Wall |
94 | |
f06db76b |
95 | =head1 MODIFICATION HISTORY |
96 | |
8e07c86e |
97 | See the file F<changes.pod>. |
e50aee73 |
98 | |
75f92628 |
99 | =head1 SEE ALSO |
100 | |
55a00e51 |
101 | perl(1), perlxs(1), perlxstut(1) |
75f92628 |
102 | |
103 | =cut |
93a17b20 |
104 | |
9bdfb4d4 |
105 | require 5.002; |
774d564b |
106 | use Cwd; |
0ab125c1 |
107 | use vars qw($cplusplus $hiertype); |
7ad6fb0b |
108 | use vars '%v'; |
382b8d97 |
109 | |
01f988be |
110 | use Config; |
111 | |
aa689395 |
112 | sub Q ; |
113 | |
774d564b |
114 | # Global Constants |
774d564b |
115 | |
7817ba4d |
116 | $XSUBPP_version = "1.9508"; |
aa689395 |
117 | |
118 | my ($Is_VMS, $SymSet); |
119 | if ($^O eq 'VMS') { |
120 | $Is_VMS = 1; |
121 | # Establish set of global symbols with max length 28, since xsubpp |
122 | # will later add the 'XS_' prefix. |
123 | require ExtUtils::XSSymSet; |
124 | $SymSet = new ExtUtils::XSSymSet 28; |
125 | } |
8fc38fda |
126 | |
c07a80fd |
127 | $FH = 'File0000' ; |
8fc38fda |
128 | |
11416672 |
129 | $usage = "Usage: xsubpp [-v] [-C++] [-except] [-prototypes] [-noversioncheck] [-nolinenumbers] [-nooptimize] [-noinout] [-noargtypes] [-s pattern] [-typemap typemap]... file.xs\n"; |
f06db76b |
130 | |
c2452817 |
131 | $proto_re = "[" . quotemeta('\$%&*@;[]') . "]" ; |
93a17b20 |
132 | |
8e07c86e |
133 | $except = ""; |
8fc38fda |
134 | $WantPrototypes = -1 ; |
135 | $WantVersionChk = 1 ; |
136 | $ProtoUsed = 0 ; |
6f1abe2b |
137 | $WantLineNumbers = 1 ; |
b26a54d0 |
138 | $WantOptimize = 1 ; |
54162f5c |
139 | $Overload = 0; |
11416672 |
140 | |
141 | my $process_inout = 1; |
142 | my $process_argtypes = 1; |
143 | |
8e07c86e |
144 | SWITCH: while (@ARGV and $ARGV[0] =~ /^-./) { |
93a17b20 |
145 | $flag = shift @ARGV; |
e50aee73 |
146 | $flag =~ s/^-// ; |
ff68c719 |
147 | $spat = quotemeta shift, next SWITCH if $flag eq 's'; |
8990e307 |
148 | $cplusplus = 1, next SWITCH if $flag eq 'C++'; |
0ab125c1 |
149 | $hiertype = 1, next SWITCH if $flag eq 'hiertype'; |
382b8d97 |
150 | $WantPrototypes = 0, next SWITCH if $flag eq 'noprototypes'; |
151 | $WantPrototypes = 1, next SWITCH if $flag eq 'prototypes'; |
8fc38fda |
152 | $WantVersionChk = 0, next SWITCH if $flag eq 'noversioncheck'; |
153 | $WantVersionChk = 1, next SWITCH if $flag eq 'versioncheck'; |
c5be433b |
154 | # XXX left this in for compat |
acfe0abc |
155 | next SWITCH if $flag eq 'object_capi'; |
8e07c86e |
156 | $except = " TRY", next SWITCH if $flag eq 'except'; |
8990e307 |
157 | push(@tm,shift), next SWITCH if $flag eq 'typemap'; |
6f1abe2b |
158 | $WantLineNumbers = 0, next SWITCH if $flag eq 'nolinenumbers'; |
159 | $WantLineNumbers = 1, next SWITCH if $flag eq 'linenumbers'; |
b26a54d0 |
160 | $WantOptimize = 0, next SWITCH if $flag eq 'nooptimize'; |
161 | $WantOptimize = 1, next SWITCH if $flag eq 'optimize'; |
11416672 |
162 | $process_inout = 0, next SWITCH if $flag eq 'noinout'; |
163 | $process_inout = 1, next SWITCH if $flag eq 'inout'; |
164 | $process_argtypes = 0, next SWITCH if $flag eq 'noargtypes'; |
165 | $process_argtypes = 1, next SWITCH if $flag eq 'argtypes'; |
b26a54d0 |
166 | (print "xsubpp version $XSUBPP_version\n"), exit |
8e07c86e |
167 | if $flag eq 'v'; |
93a17b20 |
168 | die $usage; |
169 | } |
8fc38fda |
170 | if ($WantPrototypes == -1) |
171 | { $WantPrototypes = 0} |
172 | else |
173 | { $ProtoUsed = 1 } |
174 | |
175 | |
8990e307 |
176 | @ARGV == 1 or die $usage; |
c2960299 |
177 | ($dir, $filename) = $ARGV[0] =~ m#(.*)/(.*)# |
57497940 |
178 | or ($dir, $filename) = $ARGV[0] =~ m#(.*)\\(.*)# |
c2960299 |
179 | or ($dir, $filename) = $ARGV[0] =~ m#(.*[>\]])(.*)# |
8990e307 |
180 | or ($dir, $filename) = ('.', $ARGV[0]); |
181 | chdir($dir); |
774d564b |
182 | $pwd = cwd(); |
8fc38fda |
183 | |
184 | ++ $IncludedFiles{$ARGV[0]} ; |
93a17b20 |
185 | |
4230ab3f |
186 | my(@XSStack) = ({type => 'none'}); # Stack of conditionals and INCLUDEs |
187 | my($XSS_work_idx, $cpp_next_tmp) = (0, "XSubPPtmpAAAA"); |
aa689395 |
188 | |
4230ab3f |
189 | |
f06db76b |
190 | sub TrimWhitespace |
191 | { |
192 | $_[0] =~ s/^\s+|\s+$//go ; |
193 | } |
194 | |
195 | sub TidyType |
196 | { |
197 | local ($_) = @_ ; |
198 | |
199 | # rationalise any '*' by joining them into bunches and removing whitespace |
200 | s#\s*(\*+)\s*#$1#g; |
e50aee73 |
201 | s#(\*+)# $1 #g ; |
f06db76b |
202 | |
203 | # change multiple whitespace into a single space |
204 | s/\s+/ /g ; |
0ab125c1 |
205 | |
f06db76b |
206 | # trim leading & trailing whitespace |
207 | TrimWhitespace($_) ; |
208 | |
209 | $_ ; |
210 | } |
211 | |
93a17b20 |
212 | $typemap = shift @ARGV; |
8990e307 |
213 | foreach $typemap (@tm) { |
214 | die "Can't find $typemap in $pwd\n" unless -r $typemap; |
93a17b20 |
215 | } |
748a9306 |
216 | unshift @tm, qw(../../../../lib/ExtUtils/typemap ../../../lib/ExtUtils/typemap |
217 | ../../lib/ExtUtils/typemap ../../../typemap ../../typemap |
218 | ../typemap typemap); |
8990e307 |
219 | foreach $typemap (@tm) { |
dd713d92 |
220 | next unless -f $typemap ; |
f06db76b |
221 | # skip directories, binary files etc. |
0ab125c1 |
222 | warn("Warning: ignoring non-text typemap file '$typemap'\n"), next |
f06db76b |
223 | unless -T $typemap ; |
0ab125c1 |
224 | open(TYPEMAP, $typemap) |
f06db76b |
225 | or warn ("Warning: could not open typemap file '$typemap': $!\n"), next; |
e50aee73 |
226 | $mode = 'Typemap'; |
c2960299 |
227 | $junk = "" ; |
8990e307 |
228 | $current = \$junk; |
229 | while (<TYPEMAP>) { |
e50aee73 |
230 | next if /^\s*#/; |
0ab125c1 |
231 | my $line_no = $. + 1; |
8e07c86e |
232 | if (/^INPUT\s*$/) { $mode = 'Input'; $current = \$junk; next; } |
233 | if (/^OUTPUT\s*$/) { $mode = 'Output'; $current = \$junk; next; } |
234 | if (/^TYPEMAP\s*$/) { $mode = 'Typemap'; $current = \$junk; next; } |
e50aee73 |
235 | if ($mode eq 'Typemap') { |
236 | chomp; |
f06db76b |
237 | my $line = $_ ; |
238 | TrimWhitespace($_) ; |
239 | # skip blank lines and comment lines |
240 | next if /^$/ or /^#/ ; |
382b8d97 |
241 | my($type,$kind, $proto) = /^\s*(.*?\S)\s+(\S+)\s*($proto_re*)\s*$/ or |
242 | warn("Warning: File '$typemap' Line $. '$line' TYPEMAP entry needs 2 or 3 columns\n"), next; |
243 | $type = TidyType($type) ; |
244 | $type_kind{$type} = $kind ; |
245 | # prototype defaults to '$' |
93d3b392 |
246 | $proto = "\$" unless $proto ; |
0ab125c1 |
247 | warn("Warning: File '$typemap' Line $. '$line' Invalid prototype '$proto'\n") |
382b8d97 |
248 | unless ValidProtoString($proto) ; |
249 | $proto_letter{$type} = C_string($proto) ; |
8e07c86e |
250 | } |
251 | elsif (/^\s/) { |
252 | $$current .= $_; |
463ee0b2 |
253 | } |
e50aee73 |
254 | elsif ($mode eq 'Input') { |
8e07c86e |
255 | s/\s+$//; |
256 | $input_expr{$_} = ''; |
257 | $current = \$input_expr{$_}; |
93a17b20 |
258 | } |
8990e307 |
259 | else { |
8e07c86e |
260 | s/\s+$//; |
261 | $output_expr{$_} = ''; |
262 | $current = \$output_expr{$_}; |
93a17b20 |
263 | } |
8990e307 |
264 | } |
265 | close(TYPEMAP); |
266 | } |
93a17b20 |
267 | |
8990e307 |
268 | foreach $key (keys %input_expr) { |
50a63b21 |
269 | $input_expr{$key} =~ s/;*\s+\z//; |
8990e307 |
270 | } |
93a17b20 |
271 | |
14455d6c |
272 | $bal = qr[(?:(?>[^()]+)|\((??{ $bal })\))*]; # ()-balanced |
b26a54d0 |
273 | $cast = qr[(?:\(\s*SV\s*\*\s*\)\s*)?]; # Optional (SV*) cast |
14455d6c |
274 | $size = qr[,\s* (??{ $bal }) ]x; # Third arg (to setpvn) |
b26a54d0 |
275 | |
276 | foreach $key (keys %output_expr) { |
277 | use re 'eval'; |
278 | |
279 | my ($t, $with_size, $arg, $sarg) = |
280 | ($output_expr{$key} =~ |
438cc608 |
281 | m[^ \s+ sv_set ( [iunp] ) v (n)? # Type, is_setpvn |
b26a54d0 |
282 | \s* \( \s* $cast \$arg \s* , |
14455d6c |
283 | \s* ( (??{ $bal }) ) # Set from |
284 | ( (??{ $size }) )? # Possible sizeof set-from |
b26a54d0 |
285 | \) \s* ; \s* $ |
286 | ]x); |
287 | $targetable{$key} = [$t, $with_size, $arg, $sarg] if $t; |
288 | } |
289 | |
8e07c86e |
290 | $END = "!End!\n\n"; # "impossible" keyword (multiple newline) |
291 | |
292 | # Match an XS keyword |
382b8d97 |
293 | $BLOCK_re= '\s*(' . join('|', qw( |
0ab125c1 |
294 | REQUIRE BOOT CASE PREINIT INPUT INIT CODE PPCODE OUTPUT |
be3174d2 |
295 | CLEANUP ALIAS ATTRS PROTOTYPES PROTOTYPE VERSIONCHECK INCLUDE |
54162f5c |
296 | SCOPE INTERFACE INTERFACE_MACRO C_ARGS POSTCALL OVERLOAD |
382b8d97 |
297 | )) . "|$END)\\s*:"; |
8e07c86e |
298 | |
299 | # Input: ($_, @line) == unparsed input. |
300 | # Output: ($_, @line) == (rest of line, following lines). |
301 | # Return: the matched keyword if found, otherwise 0 |
302 | sub check_keyword { |
303 | $_ = shift(@line) while !/\S/ && @line; |
304 | s/^(\s*)($_[0])\s*:\s*(?:#.*)?/$1/s && $2; |
305 | } |
306 | |
efbca139 |
307 | my ($C_group_rex, $C_arg); |
f8b8e0a4 |
308 | # Group in C (no support for comments or literals) |
309 | $C_group_rex = qr/ [({\[] |
14455d6c |
310 | (?: (?> [^()\[\]{}]+ ) | (??{ $C_group_rex }) )* |
f8b8e0a4 |
311 | [)}\]] /x ; |
312 | # Chunk in C without comma at toplevel (no comments): |
313 | $C_arg = qr/ (?: (?> [^()\[\]{},"']+ ) |
14455d6c |
314 | | (??{ $C_group_rex }) |
f8b8e0a4 |
315 | | " (?: (?> [^\\"]+ ) |
316 | | \\. |
317 | )* " # String literal |
318 | | ' (?: (?> [^\\']+ ) | \\. )* ' # Char literal |
319 | )* /xs; |
8e07c86e |
320 | |
6f1abe2b |
321 | if ($WantLineNumbers) { |
322 | { |
323 | package xsubpp::counter; |
324 | sub TIEHANDLE { |
325 | my ($class, $cfile) = @_; |
326 | my $buf = ""; |
327 | $SECTION_END_MARKER = "#line --- \"$cfile\""; |
328 | $line_no = 1; |
329 | bless \$buf; |
330 | } |
331 | |
332 | sub PRINT { |
333 | my $self = shift; |
334 | for (@_) { |
335 | $$self .= $_; |
336 | while ($$self =~ s/^([^\n]*\n)//) { |
337 | my $line = $1; |
338 | ++ $line_no; |
339 | $line =~ s|^\#line\s+---(?=\s)|#line $line_no|; |
340 | print STDOUT $line; |
341 | } |
342 | } |
343 | } |
344 | |
345 | sub PRINTF { |
346 | my $self = shift; |
347 | my $fmt = shift; |
348 | $self->PRINT(sprintf($fmt, @_)); |
349 | } |
350 | |
351 | sub DESTROY { |
352 | # Not necessary if we're careful to end with a "\n" |
353 | my $self = shift; |
354 | print STDOUT $$self; |
355 | } |
356 | } |
357 | |
358 | my $cfile = $filename; |
359 | $cfile =~ s/\.xs$/.c/i or $cfile .= ".c"; |
360 | tie(*PSEUDO_STDOUT, 'xsubpp::counter', $cfile); |
361 | select PSEUDO_STDOUT; |
362 | } |
363 | |
8e07c86e |
364 | sub print_section { |
6f1abe2b |
365 | # the "do" is required for right semantics |
366 | do { $_ = shift(@line) } while !/\S/ && @line; |
0ab125c1 |
367 | |
6f1abe2b |
368 | print("#line ", $line_no[@line_no - @line -1], " \"$filename\"\n") |
d3308daf |
369 | if $WantLineNumbers && !/^\s*#\s*line\b/ && !/^#if XSubPPtmp/; |
8e07c86e |
370 | for (; defined($_) && !/^$BLOCK_re/o; $_ = shift(@line)) { |
371 | print "$_\n"; |
372 | } |
6f1abe2b |
373 | print "$xsubpp::counter::SECTION_END_MARKER\n" if $WantLineNumbers; |
8e07c86e |
374 | } |
375 | |
cfc02341 |
376 | sub merge_section { |
377 | my $in = ''; |
0ab125c1 |
378 | |
cfc02341 |
379 | while (!/\S/ && @line) { |
380 | $_ = shift(@line); |
381 | } |
0ab125c1 |
382 | |
cfc02341 |
383 | for (; defined($_) && !/^$BLOCK_re/o; $_ = shift(@line)) { |
384 | $in .= "$_\n"; |
385 | } |
386 | chomp $in; |
387 | return $in; |
388 | } |
389 | |
8fc38fda |
390 | sub process_keyword($) |
391 | { |
392 | my($pattern) = @_ ; |
393 | my $kwd ; |
394 | |
0ab125c1 |
395 | &{"${kwd}_handler"}() |
8fc38fda |
396 | while $kwd = check_keyword($pattern) ; |
397 | } |
398 | |
8e07c86e |
399 | sub CASE_handler { |
400 | blurt ("Error: `CASE:' after unconditional `CASE:'") |
401 | if $condnum && $cond eq ''; |
402 | $cond = $_; |
403 | TrimWhitespace($cond); |
404 | print " ", ($condnum++ ? " else" : ""), ($cond ? " if ($cond)\n" : "\n"); |
405 | $_ = '' ; |
406 | } |
407 | |
408 | sub INPUT_handler { |
409 | for (; !/^$BLOCK_re/o; $_ = shift(@line)) { |
410 | last if /^\s*NOT_IMPLEMENTED_YET/; |
0ab125c1 |
411 | next unless /\S/; # skip blank lines |
8e07c86e |
412 | |
413 | TrimWhitespace($_) ; |
414 | my $line = $_ ; |
415 | |
416 | # remove trailing semicolon if no initialisation |
7ad6fb0b |
417 | s/\s*;$//g unless /[=;+].*\S/ ; |
8e07c86e |
418 | |
08ff138d |
419 | # Process the length(foo) declarations |
420 | if (s/^([^=]*)\blength\(\s*(\w+)\s*\)\s*$/$1 XSauto_length_of_$2=NO_INIT/x) { |
421 | print "\tSTRLEN\tSTRLEN_length_of_$2;\n"; |
422 | $lengthof{$2} = $name; |
423 | # $islengthof{$name} = $1; |
424 | $deferred .= "\n\tXSauto_length_of_$2 = STRLEN_length_of_$2;"; |
425 | } |
426 | |
8e07c86e |
427 | # check for optional initialisation code |
428 | my $var_init = '' ; |
7ad6fb0b |
429 | $var_init = $1 if s/\s*([=;+].*)$//s ; |
8e07c86e |
430 | $var_init =~ s/"/\\"/g; |
431 | |
432 | s/\s+/ /g; |
0f568861 |
433 | my ($var_type, $var_addr, $var_name) = /^(.*?[^&\s])\s*(\&?)\s*\b(\w+)$/s |
8e07c86e |
434 | or blurt("Error: invalid argument declaration '$line'"), next; |
435 | |
436 | # Check for duplicate definitions |
437 | blurt ("Error: duplicate definition of argument '$var_name' ignored"), next |
0ab125c1 |
438 | if $arg_list{$var_name}++ |
08ff138d |
439 | or defined $argtype_seen{$var_name} and not $processing_arg_with_types; |
8e07c86e |
440 | |
441 | $thisdone |= $var_name eq "THIS"; |
442 | $retvaldone |= $var_name eq "RETVAL"; |
443 | $var_types{$var_name} = $var_type; |
ddf6bed1 |
444 | # XXXX This check is a safeguard against the unfinished conversion of |
445 | # generate_init(). When generate_init() is fixed, |
446 | # one can use 2-args map_type() unconditionally. |
447 | if ($var_type =~ / \( \s* \* \s* \) /x) { |
448 | # Function pointers are not yet supported with &output_init! |
449 | print "\t" . &map_type($var_type, $var_name); |
450 | $name_printed = 1; |
451 | } else { |
452 | print "\t" . &map_type($var_type); |
453 | $name_printed = 0; |
454 | } |
8e07c86e |
455 | $var_num = $args_match{$var_name}; |
382b8d97 |
456 | |
0ab125c1 |
457 | $proto_arg[$var_num] = ProtoString($var_type) |
8fc38fda |
458 | if $var_num ; |
0f568861 |
459 | $func_args =~ s/\b($var_name)\b/&$1/ if $var_addr; |
f8b8e0a4 |
460 | if ($var_init =~ /^[=;]\s*NO_INIT\s*;?\s*$/ |
0f568861 |
461 | or $in_out{$var_name} and $in_out{$var_name} =~ /^OUT/ |
f8b8e0a4 |
462 | and $var_init !~ /\S/) { |
ddf6bed1 |
463 | if ($name_printed) { |
464 | print ";\n"; |
465 | } else { |
9bea678f |
466 | print "\t$var_name;\n"; |
ddf6bed1 |
467 | } |
8e07c86e |
468 | } elsif ($var_init =~ /\S/) { |
ddf6bed1 |
469 | &output_init($var_type, $var_num, $var_name, $var_init, $name_printed); |
8e07c86e |
470 | } elsif ($var_num) { |
471 | # generate initialization code |
ddf6bed1 |
472 | &generate_init($var_type, $var_num, $var_name, $name_printed); |
8e07c86e |
473 | } else { |
474 | print ";\n"; |
475 | } |
476 | } |
477 | } |
478 | |
479 | sub OUTPUT_handler { |
480 | for (; !/^$BLOCK_re/o; $_ = shift(@line)) { |
481 | next unless /\S/; |
ef50df4b |
482 | if (/^\s*SETMAGIC\s*:\s*(ENABLE|DISABLE)\s*/) { |
483 | $DoSetMagic = ($1 eq "ENABLE" ? 1 : 0); |
484 | next; |
485 | } |
8e07c86e |
486 | my ($outarg, $outcode) = /^\s*(\S+)\s*(.*?)\s*$/s ; |
487 | blurt ("Error: duplicate OUTPUT argument '$outarg' ignored"), next |
488 | if $outargs{$outarg} ++ ; |
489 | if (!$gotRETVAL and $outarg eq 'RETVAL') { |
490 | # deal with RETVAL last |
491 | $RETVAL_code = $outcode ; |
492 | $gotRETVAL = 1 ; |
493 | next ; |
494 | } |
495 | blurt ("Error: OUTPUT $outarg not an argument"), next |
496 | unless defined($args_match{$outarg}); |
497 | blurt("Error: No input definition for OUTPUT argument '$outarg' - ignored"), next |
498 | unless defined $var_types{$outarg} ; |
f78230ad |
499 | $var_num = $args_match{$outarg}; |
8e07c86e |
500 | if ($outcode) { |
501 | print "\t$outcode\n"; |
f78230ad |
502 | print "\tSvSETMAGIC(ST(" , $var_num-1 , "));\n" if $DoSetMagic; |
8e07c86e |
503 | } else { |
ef50df4b |
504 | &generate_output($var_types{$outarg}, $var_num, $outarg, $DoSetMagic); |
8e07c86e |
505 | } |
0ab125c1 |
506 | delete $in_out{$outarg} # No need to auto-OUTPUT |
0f568861 |
507 | if exists $in_out{$outarg} and $in_out{$outarg} =~ /OUT$/; |
8e07c86e |
508 | } |
509 | } |
510 | |
cfc02341 |
511 | sub C_ARGS_handler() { |
512 | my $in = merge_section(); |
0ab125c1 |
513 | |
cfc02341 |
514 | TrimWhitespace($in); |
515 | $func_args = $in; |
0ab125c1 |
516 | } |
cfc02341 |
517 | |
518 | sub INTERFACE_MACRO_handler() { |
519 | my $in = merge_section(); |
0ab125c1 |
520 | |
cfc02341 |
521 | TrimWhitespace($in); |
522 | if ($in =~ /\s/) { # two |
523 | ($interface_macro, $interface_macro_set) = split ' ', $in; |
524 | } else { |
525 | $interface_macro = $in; |
526 | $interface_macro_set = 'UNKNOWN_CVT'; # catch later |
527 | } |
528 | $interface = 1; # local |
529 | $Interfaces = 1; # global |
530 | } |
531 | |
532 | sub INTERFACE_handler() { |
533 | my $in = merge_section(); |
0ab125c1 |
534 | |
cfc02341 |
535 | TrimWhitespace($in); |
0ab125c1 |
536 | |
cfc02341 |
537 | foreach (split /[\s,]+/, $in) { |
538 | $Interfaces{$_} = $_; |
539 | } |
540 | print Q<<"EOF"; |
541 | # XSFUNCTION = $interface_macro($ret_type,cv,XSANY.any_dptr); |
542 | EOF |
543 | $interface = 1; # local |
544 | $Interfaces = 1; # global |
545 | } |
546 | |
0ab125c1 |
547 | sub CLEANUP_handler() { print_section() } |
548 | sub PREINIT_handler() { print_section() } |
549 | sub POSTCALL_handler() { print_section() } |
550 | sub INIT_handler() { print_section() } |
8fc38fda |
551 | |
8e07c86e |
552 | sub GetAliases |
553 | { |
554 | my ($line) = @_ ; |
555 | my ($orig) = $line ; |
556 | my ($alias) ; |
557 | my ($value) ; |
558 | |
559 | # Parse alias definitions |
560 | # format is |
561 | # alias = value alias = value ... |
562 | |
563 | while ($line =~ s/^\s*([\w:]+)\s*=\s*(\w+)\s*//) { |
564 | $alias = $1 ; |
565 | $orig_alias = $alias ; |
566 | $value = $2 ; |
567 | |
568 | # check for optional package definition in the alias |
569 | $alias = $Packprefix . $alias if $alias !~ /::/ ; |
0ab125c1 |
570 | |
8e07c86e |
571 | # check for duplicate alias name & duplicate value |
572 | Warn("Warning: Ignoring duplicate alias '$orig_alias'") |
4230ab3f |
573 | if defined $XsubAliases{$alias} ; |
8e07c86e |
574 | |
4230ab3f |
575 | Warn("Warning: Aliases '$orig_alias' and '$XsubAliasValues{$value}' have identical values") |
576 | if $XsubAliasValues{$value} ; |
8e07c86e |
577 | |
4230ab3f |
578 | $XsubAliases = 1; |
579 | $XsubAliases{$alias} = $value ; |
580 | $XsubAliasValues{$value} = $orig_alias ; |
8e07c86e |
581 | } |
582 | |
583 | blurt("Error: Cannot parse ALIAS definitions from '$orig'") |
584 | if $line ; |
585 | } |
586 | |
be3174d2 |
587 | sub ATTRS_handler () |
588 | { |
589 | for (; !/^$BLOCK_re/o; $_ = shift(@line)) { |
590 | next unless /\S/; |
591 | TrimWhitespace($_) ; |
592 | push @Attributes, $_; |
593 | } |
594 | } |
595 | |
382b8d97 |
596 | sub ALIAS_handler () |
8e07c86e |
597 | { |
598 | for (; !/^$BLOCK_re/o; $_ = shift(@line)) { |
599 | next unless /\S/; |
600 | TrimWhitespace($_) ; |
601 | GetAliases($_) if $_ ; |
602 | } |
603 | } |
604 | |
54162f5c |
605 | sub OVERLOAD_handler() |
606 | { |
607 | for (; !/^$BLOCK_re/o; $_ = shift(@line)) { |
608 | next unless /\S/; |
609 | TrimWhitespace($_) ; |
964097f7 |
610 | while ( s/^\s*([\w:"\\)\+\-\*\/\%\<\>\.\&\|\^\!\~\{\}\=]+)\s*//) { |
54162f5c |
611 | $Overload = 1 unless $Overload; |
612 | my $overload = "$Package\::(".$1 ; |
613 | push(@InitFileCode, |
614 | " newXS(\"$overload\", XS_$Full_func_name, file$proto);\n"); |
615 | } |
616 | } |
617 | |
618 | } |
619 | |
382b8d97 |
620 | sub REQUIRE_handler () |
8e07c86e |
621 | { |
622 | # the rest of the current line should contain a version number |
623 | my ($Ver) = $_ ; |
624 | |
625 | TrimWhitespace($Ver) ; |
626 | |
627 | death ("Error: REQUIRE expects a version number") |
628 | unless $Ver ; |
629 | |
630 | # check that the version number is of the form n.n |
631 | death ("Error: REQUIRE: expected a number, got '$Ver'") |
632 | unless $Ver =~ /^\d+(\.\d*)?/ ; |
633 | |
634 | death ("Error: xsubpp $Ver (or better) required--this is only $XSUBPP_version.") |
0ab125c1 |
635 | unless $XSUBPP_version >= $Ver ; |
8e07c86e |
636 | } |
637 | |
8fc38fda |
638 | sub VERSIONCHECK_handler () |
639 | { |
640 | # the rest of the current line should contain either ENABLE or |
641 | # DISABLE |
0ab125c1 |
642 | |
8fc38fda |
643 | TrimWhitespace($_) ; |
0ab125c1 |
644 | |
8fc38fda |
645 | # check for ENABLE/DISABLE |
646 | death ("Error: VERSIONCHECK: ENABLE/DISABLE") |
647 | unless /^(ENABLE|DISABLE)/i ; |
0ab125c1 |
648 | |
8fc38fda |
649 | $WantVersionChk = 1 if $1 eq 'ENABLE' ; |
650 | $WantVersionChk = 0 if $1 eq 'DISABLE' ; |
0ab125c1 |
651 | |
8fc38fda |
652 | } |
653 | |
382b8d97 |
654 | sub PROTOTYPE_handler () |
655 | { |
7d41bd0a |
656 | my $specified ; |
657 | |
0ab125c1 |
658 | death("Error: Only 1 PROTOTYPE definition allowed per xsub") |
c07a80fd |
659 | if $proto_in_this_xsub ++ ; |
660 | |
382b8d97 |
661 | for (; !/^$BLOCK_re/o; $_ = shift(@line)) { |
662 | next unless /\S/; |
7d41bd0a |
663 | $specified = 1 ; |
382b8d97 |
664 | TrimWhitespace($_) ; |
665 | if ($_ eq 'DISABLE') { |
0ab125c1 |
666 | $ProtoThisXSUB = 0 |
382b8d97 |
667 | } |
668 | elsif ($_ eq 'ENABLE') { |
0ab125c1 |
669 | $ProtoThisXSUB = 1 |
382b8d97 |
670 | } |
671 | else { |
672 | # remove any whitespace |
673 | s/\s+//g ; |
674 | death("Error: Invalid prototype '$_'") |
675 | unless ValidProtoString($_) ; |
676 | $ProtoThisXSUB = C_string($_) ; |
677 | } |
678 | } |
c07a80fd |
679 | |
7d41bd0a |
680 | # If no prototype specified, then assume empty prototype "" |
681 | $ProtoThisXSUB = 2 unless $specified ; |
682 | |
8fc38fda |
683 | $ProtoUsed = 1 ; |
c07a80fd |
684 | |
382b8d97 |
685 | } |
686 | |
db3b9414 |
687 | sub SCOPE_handler () |
688 | { |
0ab125c1 |
689 | death("Error: Only 1 SCOPE declaration allowed per xsub") |
db3b9414 |
690 | if $scope_in_this_xsub ++ ; |
691 | |
692 | for (; !/^$BLOCK_re/o; $_ = shift(@line)) { |
693 | next unless /\S/; |
694 | TrimWhitespace($_) ; |
695 | if ($_ =~ /^DISABLE/i) { |
0ab125c1 |
696 | $ScopeThisXSUB = 0 |
db3b9414 |
697 | } |
698 | elsif ($_ =~ /^ENABLE/i) { |
0ab125c1 |
699 | $ScopeThisXSUB = 1 |
db3b9414 |
700 | } |
701 | } |
702 | |
703 | } |
704 | |
382b8d97 |
705 | sub PROTOTYPES_handler () |
706 | { |
707 | # the rest of the current line should contain either ENABLE or |
0ab125c1 |
708 | # DISABLE |
382b8d97 |
709 | |
710 | TrimWhitespace($_) ; |
711 | |
712 | # check for ENABLE/DISABLE |
713 | death ("Error: PROTOTYPES: ENABLE/DISABLE") |
714 | unless /^(ENABLE|DISABLE)/i ; |
715 | |
716 | $WantPrototypes = 1 if $1 eq 'ENABLE' ; |
717 | $WantPrototypes = 0 if $1 eq 'DISABLE' ; |
8fc38fda |
718 | $ProtoUsed = 1 ; |
382b8d97 |
719 | |
720 | } |
721 | |
8fc38fda |
722 | sub INCLUDE_handler () |
723 | { |
724 | # the rest of the current line should contain a valid filename |
0ab125c1 |
725 | |
8fc38fda |
726 | TrimWhitespace($_) ; |
0ab125c1 |
727 | |
8fc38fda |
728 | death("INCLUDE: filename missing") |
729 | unless $_ ; |
730 | |
731 | death("INCLUDE: output pipe is illegal") |
732 | if /^\s*\|/ ; |
733 | |
734 | # simple minded recursion detector |
735 | death("INCLUDE loop detected") |
736 | if $IncludedFiles{$_} ; |
737 | |
738 | ++ $IncludedFiles{$_} unless /\|\s*$/ ; |
739 | |
740 | # Save the current file context. |
4230ab3f |
741 | push(@XSStack, { |
742 | type => 'file', |
8fc38fda |
743 | LastLine => $lastline, |
744 | LastLineNo => $lastline_no, |
745 | Line => \@line, |
746 | LineNo => \@line_no, |
747 | Filename => $filename, |
c07a80fd |
748 | Handle => $FH, |
8fc38fda |
749 | }) ; |
0ab125c1 |
750 | |
c07a80fd |
751 | ++ $FH ; |
8fc38fda |
752 | |
753 | # open the new file |
c07a80fd |
754 | open ($FH, "$_") or death("Cannot open '$_': $!") ; |
0ab125c1 |
755 | |
8fc38fda |
756 | print Q<<"EOF" ; |
757 | # |
758 | #/* INCLUDE: Including '$_' from '$filename' */ |
759 | # |
760 | EOF |
761 | |
8fc38fda |
762 | $filename = $_ ; |
763 | |
0ab125c1 |
764 | # Prime the pump by reading the first |
c07a80fd |
765 | # non-blank line |
766 | |
767 | # skip leading blank lines |
768 | while (<$FH>) { |
769 | last unless /^\s*$/ ; |
770 | } |
771 | |
772 | $lastline = $_ ; |
8fc38fda |
773 | $lastline_no = $. ; |
0ab125c1 |
774 | |
8fc38fda |
775 | } |
0ab125c1 |
776 | |
8fc38fda |
777 | sub PopFile() |
778 | { |
4230ab3f |
779 | return 0 unless $XSStack[-1]{type} eq 'file' ; |
780 | |
781 | my $data = pop @XSStack ; |
8fc38fda |
782 | my $ThisFile = $filename ; |
783 | my $isPipe = ($filename =~ /\|\s*$/) ; |
0ab125c1 |
784 | |
8fc38fda |
785 | -- $IncludedFiles{$filename} |
786 | unless $isPipe ; |
787 | |
c07a80fd |
788 | close $FH ; |
8fc38fda |
789 | |
c07a80fd |
790 | $FH = $data->{Handle} ; |
8fc38fda |
791 | $filename = $data->{Filename} ; |
792 | $lastline = $data->{LastLine} ; |
793 | $lastline_no = $data->{LastLineNo} ; |
794 | @line = @{ $data->{Line} } ; |
795 | @line_no = @{ $data->{LineNo} } ; |
4230ab3f |
796 | |
8fc38fda |
797 | if ($isPipe and $? ) { |
798 | -- $lastline_no ; |
799 | print STDERR "Error reading from pipe '$ThisFile': $! in $filename, line $lastline_no\n" ; |
800 | exit 1 ; |
801 | } |
802 | |
803 | print Q<<"EOF" ; |
804 | # |
805 | #/* INCLUDE: Returning to '$filename' from '$ThisFile' */ |
806 | # |
807 | EOF |
808 | |
809 | return 1 ; |
810 | } |
811 | |
382b8d97 |
812 | sub ValidProtoString ($) |
813 | { |
814 | my($string) = @_ ; |
815 | |
816 | if ( $string =~ /^$proto_re+$/ ) { |
817 | return $string ; |
818 | } |
819 | |
820 | return 0 ; |
821 | } |
822 | |
823 | sub C_string ($) |
824 | { |
825 | my($string) = @_ ; |
826 | |
827 | $string =~ s[\\][\\\\]g ; |
828 | $string ; |
829 | } |
830 | |
831 | sub ProtoString ($) |
832 | { |
833 | my ($type) = @_ ; |
834 | |
93d3b392 |
835 | $proto_letter{$type} or "\$" ; |
382b8d97 |
836 | } |
837 | |
8e07c86e |
838 | sub check_cpp { |
839 | my @cpp = grep(/^\#\s*(?:if|e\w+)/, @line); |
840 | if (@cpp) { |
841 | my ($cpp, $cpplevel); |
842 | for $cpp (@cpp) { |
843 | if ($cpp =~ /^\#\s*if/) { |
844 | $cpplevel++; |
845 | } elsif (!$cpplevel) { |
846 | Warn("Warning: #else/elif/endif without #if in this function"); |
4230ab3f |
847 | print STDERR " (precede it with a blank line if the matching #if is outside the function)\n" |
848 | if $XSStack[-1]{type} eq 'if'; |
8e07c86e |
849 | return; |
850 | } elsif ($cpp =~ /^\#\s*endif/) { |
851 | $cpplevel--; |
852 | } |
853 | } |
854 | Warn("Warning: #if without #endif in this function") if $cpplevel; |
855 | } |
856 | } |
857 | |
858 | |
8990e307 |
859 | sub Q { |
e50aee73 |
860 | my($text) = @_; |
4633a7c4 |
861 | $text =~ s/^#//gm; |
2304df62 |
862 | $text =~ s/\[\[/{/g; |
863 | $text =~ s/\]\]/}/g; |
8990e307 |
864 | $text; |
93a17b20 |
865 | } |
866 | |
c07a80fd |
867 | open($FH, $filename) or die "cannot open $filename: $!\n"; |
c2960299 |
868 | |
f06db76b |
869 | # Identify the version of xsubpp used |
f06db76b |
870 | print <<EOM ; |
e50aee73 |
871 | /* |
0ab125c1 |
872 | * This file was generated automatically by xsubpp version $XSUBPP_version from the |
93d3b392 |
873 | * contents of $filename. Do not edit this file, edit $filename instead. |
e50aee73 |
874 | * |
0ab125c1 |
875 | * ANY CHANGES MADE HERE WILL BE LOST! |
f06db76b |
876 | * |
877 | */ |
e50aee73 |
878 | |
f06db76b |
879 | EOM |
0ab125c1 |
880 | |
6f1abe2b |
881 | |
882 | print("#line 1 \"$filename\"\n") |
883 | if $WantLineNumbers; |
f06db76b |
884 | |
e03d20b3 |
885 | firstmodule: |
c07a80fd |
886 | while (<$FH>) { |
e03d20b3 |
887 | if (/^=/) { |
7817ba4d |
888 | my $podstartline = $.; |
e03d20b3 |
889 | do { |
7817ba4d |
890 | if (/^=cut\s*$/) { |
891 | print("/* Skipped embedded POD. */\n"); |
892 | printf("#line %d \"$filename\"\n", $. + 1) |
893 | if $WantLineNumbers; |
894 | next firstmodule |
895 | } |
896 | |
e03d20b3 |
897 | } while (<$FH>); |
7817ba4d |
898 | # At this point $. is at end of file so die won't state the start |
899 | # of the problem, and as we haven't yet read any lines &death won't |
900 | # show the correct line in the message either. |
901 | die ("Error: Unterminated pod in $filename, line $podstartline\n") |
902 | unless $lastline; |
e03d20b3 |
903 | } |
e50aee73 |
904 | last if ($Module, $Package, $Prefix) = |
905 | /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/; |
01f988be |
906 | |
a0d0e21e |
907 | print $_; |
93a17b20 |
908 | } |
e50aee73 |
909 | &Exit unless defined $_; |
910 | |
cfc02341 |
911 | print "$xsubpp::counter::SECTION_END_MARKER\n" if $WantLineNumbers; |
912 | |
8fc38fda |
913 | $lastline = $_; |
914 | $lastline_no = $.; |
93a17b20 |
915 | |
c07a80fd |
916 | # Read next xsub into @line from ($lastline, <$FH>). |
2304df62 |
917 | sub fetch_para { |
918 | # parse paragraph |
4230ab3f |
919 | death ("Error: Unterminated `#if/#ifdef/#ifndef'") |
920 | if !defined $lastline && $XSStack[-1]{type} eq 'if'; |
2304df62 |
921 | @line = (); |
c2960299 |
922 | @line_no = () ; |
4230ab3f |
923 | return PopFile() if !defined $lastline; |
e50aee73 |
924 | |
925 | if ($lastline =~ |
926 | /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/) { |
927 | $Module = $1; |
8e07c86e |
928 | $Package = defined($2) ? $2 : ''; # keep -w happy |
929 | $Prefix = defined($3) ? $3 : ''; # keep -w happy |
ff68c719 |
930 | $Prefix = quotemeta $Prefix ; |
e50aee73 |
931 | ($Module_cname = $Module) =~ s/\W/_/g; |
8e07c86e |
932 | ($Packid = $Package) =~ tr/:/_/; |
e50aee73 |
933 | $Packprefix = $Package; |
8e07c86e |
934 | $Packprefix .= "::" if $Packprefix ne ""; |
2304df62 |
935 | $lastline = ""; |
e50aee73 |
936 | } |
937 | |
938 | for(;;) { |
0ab125c1 |
939 | # Skip embedded PODs |
413e5597 |
940 | while ($lastline =~ /^=/) { |
e03d20b3 |
941 | while ($lastline = <$FH>) { |
942 | last if ($lastline =~ /^=cut\s*$/); |
943 | } |
944 | death ("Error: Unterminated pod") unless $lastline; |
945 | $lastline = <$FH>; |
946 | chomp $lastline; |
947 | $lastline =~ s/^\s+$//; |
948 | } |
e50aee73 |
949 | if ($lastline !~ /^\s*#/ || |
4230ab3f |
950 | # CPP directives: |
951 | # ANSI: if ifdef ifndef elif else endif define undef |
952 | # line error pragma |
953 | # gcc: warning include_next |
954 | # obj-c: import |
955 | # others: ident (gcc notes that some cpps have this one) |
956 | $lastline =~ /^#[ \t]*(?:(?:if|ifn?def|elif|else|endif|define|undef|pragma|error|warning|line\s+\d+|ident)\b|(?:include(?:_next)?|import)\s*["<].*[>"])/) { |
e50aee73 |
957 | last if $lastline =~ /^\S/ && @line && $line[-1] eq ""; |
958 | push(@line, $lastline); |
959 | push(@line_no, $lastline_no) ; |
93a17b20 |
960 | } |
e50aee73 |
961 | |
962 | # Read next line and continuation lines |
c07a80fd |
963 | last unless defined($lastline = <$FH>); |
e50aee73 |
964 | $lastline_no = $.; |
965 | my $tmp_line; |
966 | $lastline .= $tmp_line |
c07a80fd |
967 | while ($lastline =~ /\\$/ && defined($tmp_line = <$FH>)); |
f8b8e0a4 |
968 | |
8e07c86e |
969 | chomp $lastline; |
e50aee73 |
970 | $lastline =~ s/^\s+$//; |
2304df62 |
971 | } |
e50aee73 |
972 | pop(@line), pop(@line_no) while @line && $line[-1] eq ""; |
e50aee73 |
973 | 1; |
2304df62 |
974 | } |
93a17b20 |
975 | |
c2960299 |
976 | PARAGRAPH: |
8e07c86e |
977 | while (fetch_para()) { |
e50aee73 |
978 | # Print initial preprocessor statements and blank lines |
4230ab3f |
979 | while (@line && $line[0] !~ /^[^\#]/) { |
980 | my $line = shift(@line); |
981 | print $line, "\n"; |
982 | next unless $line =~ /^\#\s*((if)(?:n?def)?|elsif|else|endif)\b/; |
983 | my $statement = $+; |
984 | if ($statement eq 'if') { |
985 | $XSS_work_idx = @XSStack; |
986 | push(@XSStack, {type => 'if'}); |
987 | } else { |
988 | death ("Error: `$statement' with no matching `if'") |
989 | if $XSStack[-1]{type} ne 'if'; |
990 | if ($XSStack[-1]{varname}) { |
991 | push(@InitFileCode, "#endif\n"); |
992 | push(@BootCode, "#endif"); |
993 | } |
994 | |
995 | my(@fns) = keys %{$XSStack[-1]{functions}}; |
996 | if ($statement ne 'endif') { |
997 | # Hide the functions defined in other #if branches, and reset. |
998 | @{$XSStack[-1]{other_functions}}{@fns} = (1) x @fns; |
999 | @{$XSStack[-1]}{qw(varname functions)} = ('', {}); |
1000 | } else { |
1001 | my($tmp) = pop(@XSStack); |
1002 | 0 while (--$XSS_work_idx |
1003 | && $XSStack[$XSS_work_idx]{type} ne 'if'); |
1004 | # Keep all new defined functions |
1005 | push(@fns, keys %{$tmp->{other_functions}}); |
1006 | @{$XSStack[$XSS_work_idx]{functions}}{@fns} = (1) x @fns; |
1007 | } |
1008 | } |
1009 | } |
e50aee73 |
1010 | |
1011 | next PARAGRAPH unless @line; |
1012 | |
4230ab3f |
1013 | if ($XSS_work_idx && !$XSStack[$XSS_work_idx]{varname}) { |
1014 | # We are inside an #if, but have not yet #defined its xsubpp variable. |
1015 | print "#define $cpp_next_tmp 1\n\n"; |
1016 | push(@InitFileCode, "#if $cpp_next_tmp\n"); |
1017 | push(@BootCode, "#if $cpp_next_tmp"); |
1018 | $XSStack[$XSS_work_idx]{varname} = $cpp_next_tmp++; |
1019 | } |
1020 | |
55497cff |
1021 | death ("Code is not inside a function" |
1022 | ." (maybe last function was ended by a blank line " |
6d087280 |
1023 | ." followed by a statement on column one?)") |
e50aee73 |
1024 | if $line[0] =~ /^\s/; |
1025 | |
2304df62 |
1026 | # initialize info arrays |
1027 | undef(%args_match); |
1028 | undef(%var_types); |
2304df62 |
1029 | undef(%defaults); |
1030 | undef($class); |
1031 | undef($static); |
1032 | undef($elipsis); |
f06db76b |
1033 | undef($wantRETVAL) ; |
f8b8e0a4 |
1034 | undef($RETVAL_no_return) ; |
f06db76b |
1035 | undef(%arg_list) ; |
382b8d97 |
1036 | undef(@proto_arg) ; |
08ff138d |
1037 | undef(@fake_INPUT_pre) ; # For length(s) generated variables |
1038 | undef(@fake_INPUT) ; |
f8b8e0a4 |
1039 | undef($processing_arg_with_types) ; |
08ff138d |
1040 | undef(%argtype_seen) ; |
0f568861 |
1041 | undef(@outlist) ; |
f8b8e0a4 |
1042 | undef(%in_out) ; |
08ff138d |
1043 | undef(%lengthof) ; |
1044 | # undef(%islengthof) ; |
c07a80fd |
1045 | undef($proto_in_this_xsub) ; |
db3b9414 |
1046 | undef($scope_in_this_xsub) ; |
cfc02341 |
1047 | undef($interface); |
f8b8e0a4 |
1048 | undef($prepush_done); |
cfc02341 |
1049 | $interface_macro = 'XSINTERFACE_FUNC' ; |
1050 | $interface_macro_set = 'XSINTERFACE_FUNC_SET' ; |
382b8d97 |
1051 | $ProtoThisXSUB = $WantPrototypes ; |
db3b9414 |
1052 | $ScopeThisXSUB = 0; |
f8b8e0a4 |
1053 | $xsreturn = 0; |
2304df62 |
1054 | |
8e07c86e |
1055 | $_ = shift(@line); |
8fc38fda |
1056 | while ($kwd = check_keyword("REQUIRE|PROTOTYPES|VERSIONCHECK|INCLUDE")) { |
1057 | &{"${kwd}_handler"}() ; |
8e07c86e |
1058 | next PARAGRAPH unless @line ; |
1059 | $_ = shift(@line); |
1060 | } |
c2960299 |
1061 | |
8e07c86e |
1062 | if (check_keyword("BOOT")) { |
1063 | &check_cpp; |
6f1abe2b |
1064 | push (@BootCode, "#line $line_no[@line_no - @line] \"$filename\"") |
1065 | if $WantLineNumbers && $line[0] !~ /^\s*#\s*line\b/; |
1066 | push (@BootCode, @line, "") ; |
c2960299 |
1067 | next PARAGRAPH ; |
a0d0e21e |
1068 | } |
c2960299 |
1069 | |
8e07c86e |
1070 | |
1071 | # extract return type, function name and arguments |
cfc02341 |
1072 | ($ret_type) = TidyType($_); |
f8b8e0a4 |
1073 | $RETVAL_no_return = 1 if $ret_type =~ s/^NO_OUTPUT\s+//; |
8e07c86e |
1074 | |
11416672 |
1075 | # Allow one-line ANSI-like declaration |
1076 | unshift @line, $2 |
1077 | if $process_argtypes |
1078 | and $ret_type =~ s/^(.*?\w.*?)\s*\b(\w+\s*\(.*)/$1/s; |
1079 | |
c2960299 |
1080 | # a function definition needs at least 2 lines |
1081 | blurt ("Error: Function definition too short '$ret_type'"), next PARAGRAPH |
1082 | unless @line ; |
1083 | |
8e07c86e |
1084 | $static = 1 if $ret_type =~ s/^static\s+//; |
1085 | |
2304df62 |
1086 | $func_header = shift(@line); |
c2960299 |
1087 | blurt ("Error: Cannot parse function definition from '$func_header'"), next PARAGRAPH |
f8b8e0a4 |
1088 | unless $func_header =~ /^(?:([\w:]*)::)?(\w+)\s*\(\s*(.*?)\s*\)\s*(const)?\s*(;\s*)?$/s; |
c2960299 |
1089 | |
8e07c86e |
1090 | ($class, $func_name, $orig_args) = ($1, $2, $3) ; |
f480b56a |
1091 | $class = "$4 $class" if $4; |
2304df62 |
1092 | ($pname = $func_name) =~ s/^($Prefix)?/$Packprefix/; |
ff68c719 |
1093 | ($clean_func_name = $func_name) =~ s/^$Prefix//; |
1094 | $Full_func_name = "${Packid}_$clean_func_name"; |
ff0cee69 |
1095 | if ($Is_VMS) { $Full_func_name = $SymSet->addsym($Full_func_name); } |
c2960299 |
1096 | |
1097 | # Check for duplicate function definition |
4230ab3f |
1098 | for $tmp (@XSStack) { |
1099 | next unless defined $tmp->{functions}{$Full_func_name}; |
ff68c719 |
1100 | Warn("Warning: duplicate function definition '$clean_func_name' detected"); |
4230ab3f |
1101 | last; |
8e07c86e |
1102 | } |
4230ab3f |
1103 | $XSStack[$XSS_work_idx]{functions}{$Full_func_name} ++ ; |
be3174d2 |
1104 | %XsubAliases = %XsubAliasValues = %Interfaces = @Attributes = (); |
ef50df4b |
1105 | $DoSetMagic = 1; |
c2960299 |
1106 | |
f8b8e0a4 |
1107 | $orig_args =~ s/\\\s*/ /g; # process line continuations |
1108 | |
08ff138d |
1109 | my %only_C_inlist; # Not in the signature of Perl function |
f8b8e0a4 |
1110 | if ($process_argtypes and $orig_args =~ /\S/) { |
1111 | my $args = "$orig_args ,"; |
14455d6c |
1112 | if ($args =~ /^( (??{ $C_arg }) , )* $ /x) { |
1113 | @args = ($args =~ /\G ( (??{ $C_arg }) ) , /xg); |
f8b8e0a4 |
1114 | for ( @args ) { |
1115 | s/^\s+//; |
1116 | s/\s+$//; |
08ff138d |
1117 | my ($arg, $default) = / ( [^=]* ) ( (?: = .* )? ) /x; |
1118 | my ($pre, $name) = ($arg =~ /(.*?) \s* |
1119 | \b ( \w+ | length\( \s*\w+\s* \) ) |
1120 | \s* $ /x); |
f8b8e0a4 |
1121 | next unless length $pre; |
1122 | my $out_type; |
1123 | my $inout_var; |
0f568861 |
1124 | if ($process_inout and s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\s+//) { |
f8b8e0a4 |
1125 | my $type = $1; |
63385af5 |
1126 | $out_type = $type if $type ne 'IN'; |
0f568861 |
1127 | $arg =~ s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\s+//; |
08ff138d |
1128 | $pre =~ s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\s+//; |
1129 | } |
1130 | my $islength; |
1131 | if ($name =~ /^length\( \s* (\w+) \s* \)\z/x) { |
1132 | $name = "XSauto_length_of_$1"; |
1133 | $islength = 1; |
1134 | die "Default value on length() argument: `$_'" |
1135 | if length $default; |
f8b8e0a4 |
1136 | } |
08ff138d |
1137 | if (length $pre or $islength) { # Has a type |
1138 | if ($islength) { |
1139 | push @fake_INPUT_pre, $arg; |
1140 | } else { |
1141 | push @fake_INPUT, $arg; |
1142 | } |
f8b8e0a4 |
1143 | # warn "pushing '$arg'\n"; |
08ff138d |
1144 | $argtype_seen{$name}++; |
1145 | $_ = "$name$default"; # Assigns to @args |
f8b8e0a4 |
1146 | } |
08ff138d |
1147 | $only_C_inlist{$_} = 1 if $out_type eq "OUTLIST" or $islength; |
0f568861 |
1148 | push @outlist, $name if $out_type =~ /OUTLIST$/; |
f8b8e0a4 |
1149 | $in_out{$name} = $out_type if $out_type; |
1150 | } |
1151 | } else { |
1152 | @args = split(/\s*,\s*/, $orig_args); |
1153 | Warn("Warning: cannot parse argument list '$orig_args', fallback to split"); |
1154 | } |
1155 | } else { |
1156 | @args = split(/\s*,\s*/, $orig_args); |
1157 | for (@args) { |
0f568861 |
1158 | if ($process_inout and s/^(IN|IN_OUTLIST|OUTLIST|IN_OUT|OUT)\s+//) { |
f8b8e0a4 |
1159 | my $out_type = $1; |
63385af5 |
1160 | next if $out_type eq 'IN'; |
08ff138d |
1161 | $only_C_inlist{$_} = 1 if $out_type eq "OUTLIST"; |
0f568861 |
1162 | push @outlist, $name if $out_type =~ /OUTLIST$/; |
f8b8e0a4 |
1163 | $in_out{$_} = $out_type; |
1164 | } |
1165 | } |
1166 | } |
a0d0e21e |
1167 | if (defined($class)) { |
683d4eee |
1168 | my $arg0 = ((defined($static) or $func_name eq 'new') |
1169 | ? "CLASS" : "THIS"); |
8e07c86e |
1170 | unshift(@args, $arg0); |
f8b8e0a4 |
1171 | ($report_args = "$arg0, $report_args") =~ s/^\w+, $/$arg0/; |
2304df62 |
1172 | } |
f8b8e0a4 |
1173 | my $extra_args = 0; |
1174 | @args_num = (); |
1175 | $num_args = 0; |
1176 | my $report_args = ''; |
1177 | foreach $i (0 .. $#args) { |
2304df62 |
1178 | if ($args[$i] =~ s/\.\.\.//) { |
1179 | $elipsis = 1; |
f8b8e0a4 |
1180 | if ($args[$i] eq '' && $i == $#args) { |
1181 | $report_args .= ", ..."; |
2304df62 |
1182 | pop(@args); |
1183 | last; |
1184 | } |
1185 | } |
08ff138d |
1186 | if ($only_C_inlist{$args[$i]}) { |
f8b8e0a4 |
1187 | push @args_num, undef; |
1188 | } else { |
1189 | push @args_num, ++$num_args; |
1190 | $report_args .= ", $args[$i]"; |
1191 | } |
8e07c86e |
1192 | if ($args[$i] =~ /^([^=]*[^\s=])\s*=\s*(.*)/s) { |
f8b8e0a4 |
1193 | $extra_args++; |
2304df62 |
1194 | $args[$i] = $1; |
1195 | $defaults{$args[$i]} = $2; |
1196 | $defaults{$args[$i]} =~ s/"/\\"/g; |
1197 | } |
93d3b392 |
1198 | $proto_arg[$i+1] = "\$" ; |
2304df62 |
1199 | } |
f8b8e0a4 |
1200 | $min_args = $num_args - $extra_args; |
1201 | $report_args =~ s/"/\\"/g; |
1202 | $report_args =~ s/^,\s+//; |
1203 | my @func_args = @args; |
1204 | shift @func_args if defined($class); |
1205 | |
1206 | for (@func_args) { |
1207 | s/^/&/ if $in_out{$_}; |
2304df62 |
1208 | } |
f8b8e0a4 |
1209 | $func_args = join(", ", @func_args); |
1210 | @args_match{@args} = @args_num; |
2304df62 |
1211 | |
8e07c86e |
1212 | $PPCODE = grep(/^\s*PPCODE\s*:/, @line); |
93d3b392 |
1213 | $CODE = grep(/^\s*CODE\s*:/, @line); |
6c5fb52b |
1214 | # Detect CODE: blocks which use ST(n)= or XST_m*(n,v) |
1215 | # to set explicit return values. |
1216 | $EXPLICIT_RETURN = ($CODE && |
1217 | ("@line" =~ /(\bST\s*\([^;]*=) | (\bXST_m\w+\s*\()/x )); |
8e07c86e |
1218 | $ALIAS = grep(/^\s*ALIAS\s*:/, @line); |
cfc02341 |
1219 | $INTERFACE = grep(/^\s*INTERFACE\s*:/, @line); |
8e07c86e |
1220 | |
f8b8e0a4 |
1221 | $xsreturn = 1 if $EXPLICIT_RETURN; |
1222 | |
2304df62 |
1223 | # print function header |
a0d0e21e |
1224 | print Q<<"EOF"; |
05ceb97a |
1225 | #XS(XS_${Full_func_name}); /* prototype to pass -Wmissing-prototypes */ |
ff68c719 |
1226 | #XS(XS_${Full_func_name}) |
2304df62 |
1227 | #[[ |
a0d0e21e |
1228 | # dXSARGS; |
93a17b20 |
1229 | EOF |
8e07c86e |
1230 | print Q<<"EOF" if $ALIAS ; |
1231 | # dXSI32; |
1232 | EOF |
cfc02341 |
1233 | print Q<<"EOF" if $INTERFACE ; |
1234 | # dXSFUNCTION($ret_type); |
1235 | EOF |
2304df62 |
1236 | if ($elipsis) { |
8e07c86e |
1237 | $cond = ($min_args ? qq(items < $min_args) : 0); |
2304df62 |
1238 | } |
1239 | elsif ($min_args == $num_args) { |
1240 | $cond = qq(items != $min_args); |
1241 | } |
1242 | else { |
1243 | $cond = qq(items < $min_args || items > $num_args); |
1244 | } |
8990e307 |
1245 | |
2304df62 |
1246 | print Q<<"EOF" if $except; |
1247 | # char errbuf[1024]; |
1248 | # *errbuf = '\0'; |
1249 | EOF |
1250 | |
0ab125c1 |
1251 | if ($ALIAS) |
8e07c86e |
1252 | { print Q<<"EOF" if $cond } |
1253 | # if ($cond) |
f8b8e0a4 |
1254 | # Perl_croak(aTHX_ "Usage: %s($report_args)", GvNAME(CvGV(cv))); |
8e07c86e |
1255 | EOF |
0ab125c1 |
1256 | else |
8e07c86e |
1257 | { print Q<<"EOF" if $cond } |
1258 | # if ($cond) |
f8b8e0a4 |
1259 | # Perl_croak(aTHX_ "Usage: $pname($report_args)"); |
93a17b20 |
1260 | EOF |
1261 | |
349b520e |
1262 | #gcc -Wall: if an xsub has no arguments and PPCODE is used |
1263 | #it is likely none of ST, XSRETURN or XSprePUSH macros are used |
1264 | #hence `ax' (setup by dXSARGS) is unused |
1265 | #XXX: could breakup the dXSARGS; into dSP;dMARK;dITEMS |
1266 | #but such a move could break third-party extensions |
1267 | print Q<<"EOF" if $PPCODE and $num_args == 0; |
1268 | # PERL_UNUSED_VAR(ax); /* -Wall */ |
1269 | EOF |
1270 | |
a0d0e21e |
1271 | print Q<<"EOF" if $PPCODE; |
1272 | # SP -= items; |
1273 | EOF |
1274 | |
2304df62 |
1275 | # Now do a block of some sort. |
93a17b20 |
1276 | |
2304df62 |
1277 | $condnum = 0; |
8e07c86e |
1278 | $cond = ''; # last CASE: condidional |
1279 | push(@line, "$END:"); |
1280 | push(@line_no, $line_no[-1]); |
1281 | $_ = ''; |
1282 | &check_cpp; |
2304df62 |
1283 | while (@line) { |
8e07c86e |
1284 | &CASE_handler if check_keyword("CASE"); |
1285 | print Q<<"EOF"; |
1286 | # $except [[ |
93a17b20 |
1287 | EOF |
1288 | |
1289 | # do initialization of input variables |
1290 | $thisdone = 0; |
1291 | $retvaldone = 0; |
463ee0b2 |
1292 | $deferred = ""; |
c2960299 |
1293 | %arg_list = () ; |
1294 | $gotRETVAL = 0; |
f06db76b |
1295 | |
8fc38fda |
1296 | INPUT_handler() ; |
54162f5c |
1297 | process_keyword("INPUT|PREINIT|INTERFACE_MACRO|C_ARGS|ALIAS|ATTRS|PROTOTYPE|SCOPE|OVERLOAD") ; |
8fc38fda |
1298 | |
db3b9414 |
1299 | print Q<<"EOF" if $ScopeThisXSUB; |
1300 | # ENTER; |
1301 | # [[ |
1302 | EOF |
1303 | |
a0d0e21e |
1304 | if (!$thisdone && defined($class)) { |
683d4eee |
1305 | if (defined($static) or $func_name eq 'new') { |
a0d0e21e |
1306 | print "\tchar *"; |
1307 | $var_types{"CLASS"} = "char *"; |
1308 | &generate_init("char *", 1, "CLASS"); |
1309 | } |
1310 | else { |
93a17b20 |
1311 | print "\t$class *"; |
1312 | $var_types{"THIS"} = "$class *"; |
1313 | &generate_init("$class *", 1, "THIS"); |
a0d0e21e |
1314 | } |
93a17b20 |
1315 | } |
1316 | |
1317 | # do code |
1318 | if (/^\s*NOT_IMPLEMENTED_YET/) { |
cea2e8a9 |
1319 | print "\n\tPerl_croak(aTHX_ \"$pname: not implemented yet\");\n"; |
4633a7c4 |
1320 | $_ = '' ; |
93a17b20 |
1321 | } else { |
1322 | if ($ret_type ne "void") { |
ddf6bed1 |
1323 | print "\t" . &map_type($ret_type, 'RETVAL') . ";\n" |
93a17b20 |
1324 | if !$retvaldone; |
1325 | $args_match{"RETVAL"} = 0; |
1326 | $var_types{"RETVAL"} = $ret_type; |
b26a54d0 |
1327 | print "\tdXSTARG;\n" |
1328 | if $WantOptimize and $targetable{$type_kind{$ret_type}}; |
93a17b20 |
1329 | } |
db3b9414 |
1330 | |
08ff138d |
1331 | if (@fake_INPUT or @fake_INPUT_pre) { |
1332 | unshift @line, @fake_INPUT_pre, @fake_INPUT, $_; |
f8b8e0a4 |
1333 | $_ = ""; |
1334 | $processing_arg_with_types = 1; |
1335 | INPUT_handler() ; |
1336 | } |
8e07c86e |
1337 | print $deferred; |
db3b9414 |
1338 | |
54162f5c |
1339 | process_keyword("INIT|ALIAS|ATTRS|PROTOTYPE|INTERFACE_MACRO|INTERFACE|C_ARGS|OVERLOAD") ; |
8e07c86e |
1340 | |
1341 | if (check_keyword("PPCODE")) { |
8fc38fda |
1342 | print_section(); |
8e07c86e |
1343 | death ("PPCODE must be last thing") if @line; |
db3b9414 |
1344 | print "\tLEAVE;\n" if $ScopeThisXSUB; |
a0d0e21e |
1345 | print "\tPUTBACK;\n\treturn;\n"; |
8e07c86e |
1346 | } elsif (check_keyword("CODE")) { |
8fc38fda |
1347 | print_section() ; |
1348 | } elsif (defined($class) and $func_name eq "DESTROY") { |
a0d0e21e |
1349 | print "\n\t"; |
8e07c86e |
1350 | print "delete THIS;\n"; |
93a17b20 |
1351 | } else { |
1352 | print "\n\t"; |
1353 | if ($ret_type ne "void") { |
463ee0b2 |
1354 | print "RETVAL = "; |
e50aee73 |
1355 | $wantRETVAL = 1; |
93a17b20 |
1356 | } |
1357 | if (defined($static)) { |
683d4eee |
1358 | if ($func_name eq 'new') { |
8fc38fda |
1359 | $func_name = "$class"; |
8e07c86e |
1360 | } else { |
1361 | print "${class}::"; |
a0d0e21e |
1362 | } |
93a17b20 |
1363 | } elsif (defined($class)) { |
683d4eee |
1364 | if ($func_name eq 'new') { |
8fc38fda |
1365 | $func_name .= " $class"; |
1366 | } else { |
93a17b20 |
1367 | print "THIS->"; |
8fc38fda |
1368 | } |
93a17b20 |
1369 | } |
e50aee73 |
1370 | $func_name =~ s/^($spat)// |
1371 | if defined($spat); |
cfc02341 |
1372 | $func_name = 'XSFUNCTION' if $interface; |
93a17b20 |
1373 | print "$func_name($func_args);\n"; |
93a17b20 |
1374 | } |
1375 | } |
1376 | |
1377 | # do output variables |
f8b8e0a4 |
1378 | $gotRETVAL = 0; # 1 if RETVAL seen in OUTPUT section; |
1379 | undef $RETVAL_code ; # code to set RETVAL (from OUTPUT section); |
1380 | # $wantRETVAL set if 'RETVAL =' autogenerated |
1381 | ($wantRETVAL, $ret_type) = (0, 'void') if $RETVAL_no_return; |
8e07c86e |
1382 | undef %outargs ; |
54162f5c |
1383 | process_keyword("POSTCALL|OUTPUT|ALIAS|ATTRS|PROTOTYPE|OVERLOAD"); |
f06db76b |
1384 | |
0f568861 |
1385 | &generate_output($var_types{$_}, $args_match{$_}, $_, $DoSetMagic) |
1386 | for grep $in_out{$_} =~ /OUT$/, keys %in_out; |
1387 | |
f06db76b |
1388 | # all OUTPUT done, so now push the return value on the stack |
8e07c86e |
1389 | if ($gotRETVAL && $RETVAL_code) { |
1390 | print "\t$RETVAL_code\n"; |
1391 | } elsif ($gotRETVAL || $wantRETVAL) { |
b26a54d0 |
1392 | my $t = $WantOptimize && $targetable{$type_kind{$ret_type}}; |
1393 | my $var = 'RETVAL'; |
1394 | my $type = $ret_type; |
1395 | |
1396 | # 0: type, 1: with_size, 2: how, 3: how_size |
1397 | if ($t and not $t->[1] and $t->[0] eq 'p') { |
1398 | # PUSHp corresponds to setpvn. Treate setpv directly |
1399 | my $what = eval qq("$t->[2]"); |
1400 | warn $@ if $@; |
1401 | |
1402 | print "\tsv_setpv(TARG, $what); XSprePUSH; PUSHTARG;\n"; |
f8b8e0a4 |
1403 | $prepush_done = 1; |
b26a54d0 |
1404 | } |
1405 | elsif ($t) { |
1406 | my $what = eval qq("$t->[2]"); |
1407 | warn $@ if $@; |
1408 | |
1409 | my $size = $t->[3]; |
1410 | $size = '' unless defined $size; |
1411 | $size = eval qq("$size"); |
1412 | warn $@ if $@; |
1413 | print "\tXSprePUSH; PUSH$t->[0]($what$size);\n"; |
f8b8e0a4 |
1414 | $prepush_done = 1; |
b26a54d0 |
1415 | } |
1416 | else { |
1417 | # RETVAL almost never needs SvSETMAGIC() |
1418 | &generate_output($ret_type, 0, 'RETVAL', 0); |
1419 | } |
8e07c86e |
1420 | } |
f06db76b |
1421 | |
f8b8e0a4 |
1422 | $xsreturn = 1 if $ret_type ne "void"; |
1423 | my $num = $xsreturn; |
0f568861 |
1424 | my $c = @outlist; |
f8b8e0a4 |
1425 | print "\tXSprePUSH;" if $c and not $prepush_done; |
1426 | print "\tEXTEND(SP,$c);\n" if $c; |
1427 | $xsreturn += $c; |
0f568861 |
1428 | generate_output($var_types{$_}, $num++, $_, 0, 1) for @outlist; |
f8b8e0a4 |
1429 | |
93a17b20 |
1430 | # do cleanup |
54162f5c |
1431 | process_keyword("CLEANUP|ALIAS|ATTRS|PROTOTYPE|OVERLOAD") ; |
8e07c86e |
1432 | |
db3b9414 |
1433 | print Q<<"EOF" if $ScopeThisXSUB; |
1434 | # ]] |
1435 | EOF |
1436 | print Q<<"EOF" if $ScopeThisXSUB and not $PPCODE; |
1437 | # LEAVE; |
1438 | EOF |
1439 | |
93a17b20 |
1440 | # print function trailer |
8e07c86e |
1441 | print Q<<EOF; |
2304df62 |
1442 | # ]] |
8e07c86e |
1443 | EOF |
1444 | print Q<<EOF if $except; |
8990e307 |
1445 | # BEGHANDLERS |
1446 | # CATCHALL |
1447 | # sprintf(errbuf, "%s: %s\\tpropagated", Xname, Xreason); |
1448 | # ENDHANDLERS |
93a17b20 |
1449 | EOF |
8e07c86e |
1450 | if (check_keyword("CASE")) { |
1451 | blurt ("Error: No `CASE:' at top of function") |
1452 | unless $condnum; |
1453 | $_ = "CASE: $_"; # Restore CASE: label |
1454 | next; |
8990e307 |
1455 | } |
8e07c86e |
1456 | last if $_ eq "$END:"; |
1457 | death(/^$BLOCK_re/o ? "Misplaced `$1:'" : "Junk at end of function"); |
2304df62 |
1458 | } |
a0d0e21e |
1459 | |
2304df62 |
1460 | print Q<<EOF if $except; |
1461 | # if (errbuf[0]) |
cea2e8a9 |
1462 | # Perl_croak(aTHX_ errbuf); |
2304df62 |
1463 | EOF |
a0d0e21e |
1464 | |
f8b8e0a4 |
1465 | if ($xsreturn) { |
93d3b392 |
1466 | print Q<<EOF unless $PPCODE; |
f8b8e0a4 |
1467 | # XSRETURN($xsreturn); |
a0d0e21e |
1468 | EOF |
93d3b392 |
1469 | } else { |
1470 | print Q<<EOF unless $PPCODE; |
1471 | # XSRETURN_EMPTY; |
1472 | EOF |
1473 | } |
a0d0e21e |
1474 | |
2304df62 |
1475 | print Q<<EOF; |
2304df62 |
1476 | #]] |
8990e307 |
1477 | # |
93a17b20 |
1478 | EOF |
382b8d97 |
1479 | |
4230ab3f |
1480 | my $newXS = "newXS" ; |
1481 | my $proto = "" ; |
1482 | |
382b8d97 |
1483 | # Build the prototype string for the xsub |
1484 | if ($ProtoThisXSUB) { |
4230ab3f |
1485 | $newXS = "newXSproto"; |
1486 | |
6f1abe2b |
1487 | if ($ProtoThisXSUB eq 2) { |
4230ab3f |
1488 | # User has specified empty prototype |
1489 | $proto = ', ""' ; |
1490 | } |
6f1abe2b |
1491 | elsif ($ProtoThisXSUB ne 1) { |
7d41bd0a |
1492 | # User has specified a prototype |
4230ab3f |
1493 | $proto = ', "' . $ProtoThisXSUB . '"'; |
382b8d97 |
1494 | } |
1495 | else { |
1496 | my $s = ';'; |
1497 | if ($min_args < $num_args) { |
0ab125c1 |
1498 | $s = ''; |
382b8d97 |
1499 | $proto_arg[$min_args] .= ";" ; |
1500 | } |
0ab125c1 |
1501 | push @proto_arg, "$s\@" |
382b8d97 |
1502 | if $elipsis ; |
0ab125c1 |
1503 | |
4230ab3f |
1504 | $proto = ', "' . join ("", @proto_arg) . '"'; |
382b8d97 |
1505 | } |
1506 | } |
1507 | |
4230ab3f |
1508 | if (%XsubAliases) { |
0ab125c1 |
1509 | $XsubAliases{$pname} = 0 |
4230ab3f |
1510 | unless defined $XsubAliases{$pname} ; |
1511 | while ( ($name, $value) = each %XsubAliases) { |
1512 | push(@InitFileCode, Q<<"EOF"); |
1513 | # cv = newXS(\"$name\", XS_$Full_func_name, file); |
1514 | # XSANY.any_i32 = $value ; |
1515 | EOF |
1516 | push(@InitFileCode, Q<<"EOF") if $proto; |
1517 | # sv_setpv((SV*)cv$proto) ; |
1518 | EOF |
1519 | } |
0ab125c1 |
1520 | } |
be3174d2 |
1521 | elsif (@Attributes) { |
1522 | push(@InitFileCode, Q<<"EOF"); |
1523 | # cv = newXS(\"$pname\", XS_$Full_func_name, file); |
1524 | # apply_attrs_string("$Package", cv, "@Attributes", 0); |
1525 | EOF |
1526 | } |
cfc02341 |
1527 | elsif ($interface) { |
1528 | while ( ($name, $value) = each %Interfaces) { |
1529 | $name = "$Package\::$name" unless $name =~ /::/; |
1530 | push(@InitFileCode, Q<<"EOF"); |
1531 | # cv = newXS(\"$name\", XS_$Full_func_name, file); |
1532 | # $interface_macro_set(cv,$value) ; |
1533 | EOF |
1534 | push(@InitFileCode, Q<<"EOF") if $proto; |
1535 | # sv_setpv((SV*)cv$proto) ; |
1536 | EOF |
1537 | } |
4230ab3f |
1538 | } |
1539 | else { |
1540 | push(@InitFileCode, |
1541 | " ${newXS}(\"$pname\", XS_$Full_func_name, file$proto);\n"); |
1542 | } |
93a17b20 |
1543 | } |
1544 | |
1545 | # print initialization routine |
7ee8c957 |
1546 | |
e3b8966e |
1547 | print Q<<"EOF"; |
e3b8966e |
1548 | ##ifdef __cplusplus |
1549 | #extern "C" |
1550 | ##endif |
7ee8c957 |
1551 | EOF |
1552 | |
8990e307 |
1553 | print Q<<"EOF"; |
05ceb97a |
1554 | #XS(boot_$Module_cname); /* prototype to pass -Wmissing-prototypes */ |
a0d0e21e |
1555 | #XS(boot_$Module_cname) |
7ee8c957 |
1556 | EOF |
1557 | |
7ee8c957 |
1558 | print Q<<"EOF"; |
2304df62 |
1559 | #[[ |
a0d0e21e |
1560 | # dXSARGS; |
c6c619a9 |
1561 | EOF |
1562 | |
1563 | #-Wall: if there is no $Full_func_name there are no xsubs in this .xs |
1564 | #so `file' is unused |
1565 | print Q<<"EOF" if $Full_func_name; |
8990e307 |
1566 | # char* file = __FILE__; |
93a17b20 |
1567 | EOF |
1568 | |
c6c619a9 |
1569 | print Q "#\n"; |
1570 | |
8fc38fda |
1571 | print Q<<"EOF" if $WantVersionChk ; |
1572 | # XS_VERSION_BOOTCHECK ; |
1573 | # |
1574 | EOF |
1575 | |
cfc02341 |
1576 | print Q<<"EOF" if defined $XsubAliases or defined $Interfaces ; |
8e07c86e |
1577 | # { |
1578 | # CV * cv ; |
1579 | # |
1580 | EOF |
1581 | |
54162f5c |
1582 | print Q<<"EOF" if ($Overload); |
1583 | # { |
1584 | # /* create the package stash */ |
1585 | # HV *hv = get_hv(\"$Package\::OVERLOAD\",TRUE); |
1586 | # SV *sv = *hv_fetch(hv,"register",8,1); |
1587 | # sv_inc(sv); |
1588 | # SvSETMAGIC(sv); |
1589 | # /* Make it findable via fetchmethod */ |
1590 | # newXS(\"$Package\::()\", NULL, file); |
1591 | # } |
1592 | EOF |
1593 | |
4230ab3f |
1594 | print @InitFileCode; |
a0d0e21e |
1595 | |
cfc02341 |
1596 | print Q<<"EOF" if defined $XsubAliases or defined $Interfaces ; |
8e07c86e |
1597 | # } |
1598 | EOF |
1599 | |
a0d0e21e |
1600 | if (@BootCode) |
1601 | { |
6f1abe2b |
1602 | print "\n /* Initialisation Section */\n\n" ; |
1603 | @line = @BootCode; |
1604 | print_section(); |
8e07c86e |
1605 | print "\n /* End of Initialisation Section */\n\n" ; |
93a17b20 |
1606 | } |
a0d0e21e |
1607 | |
e50aee73 |
1608 | print Q<<"EOF";; |
3280af22 |
1609 | # XSRETURN_YES; |
e50aee73 |
1610 | #]] |
e3b8966e |
1611 | # |
1612 | EOF |
1613 | |
0ab125c1 |
1614 | warn("Please specify prototyping behavior for $filename (see perlxs manual)\n") |
8fc38fda |
1615 | unless $ProtoUsed ; |
e50aee73 |
1616 | &Exit; |
1617 | |
93a17b20 |
1618 | sub output_init { |
ddf6bed1 |
1619 | local($type, $num, $var, $init, $name_printed) = @_; |
a0d0e21e |
1620 | local($arg) = "ST(" . ($num - 1) . ")"; |
93a17b20 |
1621 | |
7ad6fb0b |
1622 | if( $init =~ /^=/ ) { |
ddf6bed1 |
1623 | if ($name_printed) { |
1624 | eval qq/print " $init\\n"/; |
1625 | } else { |
1626 | eval qq/print "\\t$var $init\\n"/; |
1627 | } |
7ad6fb0b |
1628 | warn $@ if $@; |
1629 | } else { |
1630 | if( $init =~ s/^\+// && $num ) { |
ddf6bed1 |
1631 | &generate_init($type, $num, $var, $name_printed); |
1632 | } elsif ($name_printed) { |
1633 | print ";\n"; |
1634 | $init =~ s/^;//; |
7ad6fb0b |
1635 | } else { |
1636 | eval qq/print "\\t$var;\\n"/; |
1637 | warn $@ if $@; |
1638 | $init =~ s/^;//; |
1639 | } |
1640 | $deferred .= eval qq/"\\n\\t$init\\n"/; |
1641 | warn $@ if $@; |
1642 | } |
93a17b20 |
1643 | } |
1644 | |
c2960299 |
1645 | sub Warn |
1646 | { |
1647 | # work out the line number |
1648 | my $line_no = $line_no[@line_no - @line -1] ; |
0ab125c1 |
1649 | |
c2960299 |
1650 | print STDERR "@_ in $filename, line $line_no\n" ; |
1651 | } |
1652 | |
0ab125c1 |
1653 | sub blurt |
1654 | { |
c2960299 |
1655 | Warn @_ ; |
0ab125c1 |
1656 | $errors ++ |
c2960299 |
1657 | } |
1658 | |
1659 | sub death |
1660 | { |
1661 | Warn @_ ; |
1662 | exit 1 ; |
1663 | } |
8990e307 |
1664 | |
93a17b20 |
1665 | sub generate_init { |
2304df62 |
1666 | local($type, $num, $var) = @_; |
a0d0e21e |
1667 | local($arg) = "ST(" . ($num - 1) . ")"; |
2304df62 |
1668 | local($argoff) = $num - 1; |
1669 | local($ntype); |
1670 | local($tk); |
93a17b20 |
1671 | |
f06db76b |
1672 | $type = TidyType($type) ; |
0ab125c1 |
1673 | blurt("Error: '$type' not in typemap"), return |
c2960299 |
1674 | unless defined($type_kind{$type}); |
1675 | |
2304df62 |
1676 | ($ntype = $type) =~ s/\s*\*/Ptr/g; |
8e07c86e |
1677 | ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//; |
2304df62 |
1678 | $tk = $type_kind{$type}; |
1679 | $tk =~ s/OBJ$/REF/ if $func_name =~ /DESTROY$/; |
08ff138d |
1680 | if ($tk eq 'T_PV' and exists $lengthof{$var}) { |
1681 | print "\t$var" unless $name_printed; |
1682 | print " = ($type)SvPV($arg, STRLEN_length_of_$var);\n"; |
1683 | die "default value not supported with length(NAME) supplied" |
1684 | if defined $defaults{$var}; |
1685 | return; |
1686 | } |
0ab125c1 |
1687 | $type =~ tr/:/_/ unless $hiertype; |
615ca1f4 |
1688 | blurt("Error: No INPUT definition for type '$type', typekind '$type_kind{$type}' found"), return |
c2960299 |
1689 | unless defined $input_expr{$tk} ; |
2304df62 |
1690 | $expr = $input_expr{$tk}; |
1691 | if ($expr =~ /DO_ARRAY_ELEM/) { |
0ab125c1 |
1692 | blurt("Error: '$subtype' not in typemap"), return |
c2960299 |
1693 | unless defined($type_kind{$subtype}); |
615ca1f4 |
1694 | blurt("Error: No INPUT definition for type '$subtype', typekind '$type_kind{$subtype}' found"), return |
c2960299 |
1695 | unless defined $input_expr{$type_kind{$subtype}} ; |
2304df62 |
1696 | $subexpr = $input_expr{$type_kind{$subtype}}; |
f8c11764 |
1697 | $subexpr =~ s/\$type/\$subtype/g; |
2304df62 |
1698 | $subexpr =~ s/ntype/subtype/g; |
1699 | $subexpr =~ s/\$arg/ST(ix_$var)/g; |
1700 | $subexpr =~ s/\n\t/\n\t\t/g; |
93d3b392 |
1701 | $subexpr =~ s/is not of (.*\")/[arg %d] is not of $1, ix_$var + 1/g; |
a0d0e21e |
1702 | $subexpr =~ s/\$var/${var}[ix_$var - $argoff]/; |
2304df62 |
1703 | $expr =~ s/DO_ARRAY_ELEM/$subexpr/; |
1704 | } |
db3b9414 |
1705 | if ($expr =~ m#/\*.*scope.*\*/#i) { # "scope" in C comments |
1706 | $ScopeThisXSUB = 1; |
1707 | } |
2304df62 |
1708 | if (defined($defaults{$var})) { |
1709 | $expr =~ s/(\t+)/$1 /g; |
1710 | $expr =~ s/ /\t/g; |
ddf6bed1 |
1711 | if ($name_printed) { |
1712 | print ";\n"; |
1713 | } else { |
1714 | eval qq/print "\\t$var;\\n"/; |
1715 | warn $@ if $@; |
1716 | } |
a104f515 |
1717 | if ($defaults{$var} eq 'NO_INIT') { |
4628e4f8 |
1718 | $deferred .= eval qq/"\\n\\tif (items >= $num) {\\n$expr;\\n\\t}\\n"/; |
1719 | } else { |
1720 | $deferred .= eval qq/"\\n\\tif (items < $num)\\n\\t $var = $defaults{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/; |
1721 | } |
7ad6fb0b |
1722 | warn $@ if $@; |
08ff138d |
1723 | } elsif ($ScopeThisXSUB or $expr !~ /^\s*\$var =/) { |
ddf6bed1 |
1724 | if ($name_printed) { |
1725 | print ";\n"; |
1726 | } else { |
1727 | eval qq/print "\\t$var;\\n"/; |
1728 | warn $@ if $@; |
1729 | } |
2304df62 |
1730 | $deferred .= eval qq/"\\n$expr;\\n"/; |
7ad6fb0b |
1731 | warn $@ if $@; |
2304df62 |
1732 | } else { |
ddf6bed1 |
1733 | die "panic: do not know how to handle this branch for function pointers" |
1734 | if $name_printed; |
2304df62 |
1735 | eval qq/print "$expr;\\n"/; |
7ad6fb0b |
1736 | warn $@ if $@; |
2304df62 |
1737 | } |
93a17b20 |
1738 | } |
1739 | |
1740 | sub generate_output { |
f8b8e0a4 |
1741 | local($type, $num, $var, $do_setmagic, $do_push) = @_; |
a0d0e21e |
1742 | local($arg) = "ST(" . ($num - ($num != 0)) . ")"; |
2304df62 |
1743 | local($argoff) = $num - 1; |
1744 | local($ntype); |
93a17b20 |
1745 | |
f06db76b |
1746 | $type = TidyType($type) ; |
2304df62 |
1747 | if ($type =~ /^array\(([^,]*),(.*)\)/) { |
f8c11764 |
1748 | print "\t$arg = sv_newmortal();\n"; |
4bd3d083 |
1749 | print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1));\n"; |
ef50df4b |
1750 | print "\tSvSETMAGIC($arg);\n" if $do_setmagic; |
2304df62 |
1751 | } else { |
f06db76b |
1752 | blurt("Error: '$type' not in typemap"), return |
2304df62 |
1753 | unless defined($type_kind{$type}); |
615ca1f4 |
1754 | blurt("Error: No OUTPUT definition for type '$type', typekind '$type_kind{$type}' found"), return |
c2960299 |
1755 | unless defined $output_expr{$type_kind{$type}} ; |
2304df62 |
1756 | ($ntype = $type) =~ s/\s*\*/Ptr/g; |
1757 | $ntype =~ s/\(\)//g; |
8e07c86e |
1758 | ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//; |
2304df62 |
1759 | $expr = $output_expr{$type_kind{$type}}; |
1760 | if ($expr =~ /DO_ARRAY_ELEM/) { |
c2960299 |
1761 | blurt("Error: '$subtype' not in typemap"), return |
1762 | unless defined($type_kind{$subtype}); |
615ca1f4 |
1763 | blurt("Error: No OUTPUT definition for type '$subtype', typekind '$type_kind{$subtype}' found"), return |
c2960299 |
1764 | unless defined $output_expr{$type_kind{$subtype}} ; |
2304df62 |
1765 | $subexpr = $output_expr{$type_kind{$subtype}}; |
1766 | $subexpr =~ s/ntype/subtype/g; |
1767 | $subexpr =~ s/\$arg/ST(ix_$var)/g; |
1768 | $subexpr =~ s/\$var/${var}[ix_$var]/g; |
1769 | $subexpr =~ s/\n\t/\n\t\t/g; |
1770 | $expr =~ s/DO_ARRAY_ELEM\n/$subexpr/; |
a0d0e21e |
1771 | eval "print qq\a$expr\a"; |
7ad6fb0b |
1772 | warn $@ if $@; |
ef50df4b |
1773 | print "\t\tSvSETMAGIC(ST(ix_$var));\n" if $do_setmagic; |
2304df62 |
1774 | } |
a0d0e21e |
1775 | elsif ($var eq 'RETVAL') { |
a2baab1c |
1776 | if ($expr =~ /^\t\$arg = new/) { |
1777 | # We expect that $arg has refcnt 1, so we need to |
1778 | # mortalize it. |
a0d0e21e |
1779 | eval "print qq\a$expr\a"; |
7ad6fb0b |
1780 | warn $@ if $@; |
f8b8e0a4 |
1781 | print "\tsv_2mortal(ST($num));\n"; |
1782 | print "\tSvSETMAGIC(ST($num));\n" if $do_setmagic; |
93a17b20 |
1783 | } |
a2baab1c |
1784 | elsif ($expr =~ /^\s*\$arg\s*=/) { |
1785 | # We expect that $arg has refcnt >=1, so we need |
d689ffdd |
1786 | # to mortalize it! |
a2baab1c |
1787 | eval "print qq\a$expr\a"; |
7ad6fb0b |
1788 | warn $@ if $@; |
d689ffdd |
1789 | print "\tsv_2mortal(ST(0));\n"; |
ef50df4b |
1790 | print "\tSvSETMAGIC(ST(0));\n" if $do_setmagic; |
a2baab1c |
1791 | } |
2304df62 |
1792 | else { |
a2baab1c |
1793 | # Just hope that the entry would safely write it |
1794 | # over an already mortalized value. By |
1795 | # coincidence, something like $arg = &sv_undef |
1796 | # works too. |
8990e307 |
1797 | print "\tST(0) = sv_newmortal();\n"; |
a0d0e21e |
1798 | eval "print qq\a$expr\a"; |
7ad6fb0b |
1799 | warn $@ if $@; |
ef50df4b |
1800 | # new mortals don't have set magic |
463ee0b2 |
1801 | } |
2304df62 |
1802 | } |
f8b8e0a4 |
1803 | elsif ($do_push) { |
1804 | print "\tPUSHs(sv_newmortal());\n"; |
1805 | $arg = "ST($num)"; |
1806 | eval "print qq\a$expr\a"; |
1807 | warn $@ if $@; |
1808 | print "\tSvSETMAGIC($arg);\n" if $do_setmagic; |
1809 | } |
a0d0e21e |
1810 | elsif ($arg =~ /^ST\(\d+\)$/) { |
1811 | eval "print qq\a$expr\a"; |
7ad6fb0b |
1812 | warn $@ if $@; |
ef50df4b |
1813 | print "\tSvSETMAGIC($arg);\n" if $do_setmagic; |
a0d0e21e |
1814 | } |
2304df62 |
1815 | } |
93a17b20 |
1816 | } |
1817 | |
1818 | sub map_type { |
ddf6bed1 |
1819 | my($type, $varname) = @_; |
93a17b20 |
1820 | |
0ab125c1 |
1821 | # C++ has :: in types too so skip this |
1822 | $type =~ tr/:/_/ unless $hiertype; |
8e07c86e |
1823 | $type =~ s/^array\(([^,]*),(.*)\).*/$1 */s; |
ddf6bed1 |
1824 | if ($varname) { |
1825 | if ($varname && $type =~ / \( \s* \* (?= \s* \) ) /xg) { |
1826 | (substr $type, pos $type, 0) = " $varname "; |
1827 | } else { |
1828 | $type .= "\t$varname"; |
1829 | } |
1830 | } |
8e07c86e |
1831 | $type; |
93a17b20 |
1832 | } |
8990e307 |
1833 | |
e50aee73 |
1834 | |
1835 | sub Exit { |
ff0cee69 |
1836 | # If this is VMS, the exit status has meaning to the shell, so we |
1837 | # use a predictable value (SS$_Normal or SS$_Abort) rather than an |
1838 | # arbitrary number. |
1839 | # exit ($Is_VMS ? ($errors ? 44 : 1) : $errors) ; |
1840 | exit ($errors ? 1 : 0); |
e50aee73 |
1841 | } |