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 | |
6f1abe2b |
9 | B<xsubpp> [B<-v>] [B<-C++>] [B<-except>] [B<-s pattern>] [B<-prototypes>] [B<-noversioncheck>] [B<-nolinenumbers>] [B<-typemap typemap>]... file.xs |
75f92628 |
10 | |
11 | =head1 DESCRIPTION |
12 | |
13 | I<xsubpp> will compile XS code into C code by embedding the constructs |
14 | necessary to let C functions manipulate Perl values and creates the glue |
15 | necessary to let Perl access those functions. The compiler uses typemaps to |
16 | determine how to map C function parameters and variables to Perl values. |
17 | |
18 | The compiler will search for typemap files called I<typemap>. It will use |
19 | the following search path to find default typemaps, with the rightmost |
20 | typemap taking precedence. |
21 | |
22 | ../../../typemap:../../typemap:../typemap:typemap |
23 | |
24 | =head1 OPTIONS |
25 | |
26 | =over 5 |
27 | |
28 | =item B<-C++> |
29 | |
30 | Adds ``extern "C"'' to the C code. |
31 | |
32 | |
33 | =item B<-except> |
34 | |
35 | Adds exception handling stubs to the C code. |
36 | |
37 | =item B<-typemap typemap> |
38 | |
39 | Indicates that a user-supplied typemap should take precedence over the |
40 | default typemaps. This option may be used multiple times, with the last |
41 | typemap having the highest precedence. |
42 | |
8e07c86e |
43 | =item B<-v> |
44 | |
45 | Prints the I<xsubpp> version number to standard output, then exits. |
46 | |
8fc38fda |
47 | =item B<-prototypes> |
382b8d97 |
48 | |
8fc38fda |
49 | By default I<xsubpp> will not automatically generate prototype code for |
50 | all xsubs. This flag will enable prototypes. |
51 | |
52 | =item B<-noversioncheck> |
53 | |
54 | Disables the run time test that determines if the object file (derived |
55 | from the C<.xs> file) and the C<.pm> files have the same version |
56 | number. |
382b8d97 |
57 | |
6f1abe2b |
58 | =item B<-nolinenumbers> |
59 | |
60 | Prevents the inclusion of `#line' directives in the output. |
61 | |
75f92628 |
62 | =back |
63 | |
64 | =head1 ENVIRONMENT |
65 | |
66 | No environment variables are used. |
67 | |
68 | =head1 AUTHOR |
69 | |
70 | Larry Wall |
71 | |
f06db76b |
72 | =head1 MODIFICATION HISTORY |
73 | |
8e07c86e |
74 | See the file F<changes.pod>. |
e50aee73 |
75 | |
75f92628 |
76 | =head1 SEE ALSO |
77 | |
55a00e51 |
78 | perl(1), perlxs(1), perlxstut(1) |
75f92628 |
79 | |
80 | =cut |
93a17b20 |
81 | |
382b8d97 |
82 | require 5.002; |
774d564b |
83 | use Cwd; |
4230ab3f |
84 | use vars '$cplusplus'; |
382b8d97 |
85 | |
aa689395 |
86 | sub Q ; |
87 | |
774d564b |
88 | # Global Constants |
774d564b |
89 | |
ef50df4b |
90 | $XSUBPP_version = "1.9506"; |
aa689395 |
91 | |
92 | my ($Is_VMS, $SymSet); |
93 | if ($^O eq 'VMS') { |
94 | $Is_VMS = 1; |
95 | # Establish set of global symbols with max length 28, since xsubpp |
96 | # will later add the 'XS_' prefix. |
97 | require ExtUtils::XSSymSet; |
98 | $SymSet = new ExtUtils::XSSymSet 28; |
99 | } |
8fc38fda |
100 | |
c07a80fd |
101 | $FH = 'File0000' ; |
8fc38fda |
102 | |
6f1abe2b |
103 | $usage = "Usage: xsubpp [-v] [-C++] [-except] [-prototypes] [-noversioncheck] [-nolinenumbers] [-s pattern] [-typemap typemap]... file.xs\n"; |
f06db76b |
104 | |
382b8d97 |
105 | $proto_re = "[" . quotemeta('\$%&*@;') . "]" ; |
93a17b20 |
106 | |
8e07c86e |
107 | $except = ""; |
8fc38fda |
108 | $WantPrototypes = -1 ; |
109 | $WantVersionChk = 1 ; |
110 | $ProtoUsed = 0 ; |
6f1abe2b |
111 | $WantLineNumbers = 1 ; |
8e07c86e |
112 | SWITCH: while (@ARGV and $ARGV[0] =~ /^-./) { |
93a17b20 |
113 | $flag = shift @ARGV; |
e50aee73 |
114 | $flag =~ s/^-// ; |
ff68c719 |
115 | $spat = quotemeta shift, next SWITCH if $flag eq 's'; |
8990e307 |
116 | $cplusplus = 1, next SWITCH if $flag eq 'C++'; |
382b8d97 |
117 | $WantPrototypes = 0, next SWITCH if $flag eq 'noprototypes'; |
118 | $WantPrototypes = 1, next SWITCH if $flag eq 'prototypes'; |
8fc38fda |
119 | $WantVersionChk = 0, next SWITCH if $flag eq 'noversioncheck'; |
120 | $WantVersionChk = 1, next SWITCH if $flag eq 'versioncheck'; |
8e07c86e |
121 | $except = " TRY", next SWITCH if $flag eq 'except'; |
8990e307 |
122 | push(@tm,shift), next SWITCH if $flag eq 'typemap'; |
6f1abe2b |
123 | $WantLineNumbers = 0, next SWITCH if $flag eq 'nolinenumbers'; |
124 | $WantLineNumbers = 1, next SWITCH if $flag eq 'linenumbers'; |
8e07c86e |
125 | (print "xsubpp version $XSUBPP_version\n"), exit |
126 | if $flag eq 'v'; |
93a17b20 |
127 | die $usage; |
128 | } |
8fc38fda |
129 | if ($WantPrototypes == -1) |
130 | { $WantPrototypes = 0} |
131 | else |
132 | { $ProtoUsed = 1 } |
133 | |
134 | |
8990e307 |
135 | @ARGV == 1 or die $usage; |
c2960299 |
136 | ($dir, $filename) = $ARGV[0] =~ m#(.*)/(.*)# |
57497940 |
137 | or ($dir, $filename) = $ARGV[0] =~ m#(.*)\\(.*)# |
c2960299 |
138 | or ($dir, $filename) = $ARGV[0] =~ m#(.*[>\]])(.*)# |
8990e307 |
139 | or ($dir, $filename) = ('.', $ARGV[0]); |
140 | chdir($dir); |
774d564b |
141 | $pwd = cwd(); |
8fc38fda |
142 | |
143 | ++ $IncludedFiles{$ARGV[0]} ; |
93a17b20 |
144 | |
4230ab3f |
145 | my(@XSStack) = ({type => 'none'}); # Stack of conditionals and INCLUDEs |
146 | my($XSS_work_idx, $cpp_next_tmp) = (0, "XSubPPtmpAAAA"); |
aa689395 |
147 | |
4230ab3f |
148 | |
f06db76b |
149 | sub TrimWhitespace |
150 | { |
151 | $_[0] =~ s/^\s+|\s+$//go ; |
152 | } |
153 | |
154 | sub TidyType |
155 | { |
156 | local ($_) = @_ ; |
157 | |
158 | # rationalise any '*' by joining them into bunches and removing whitespace |
159 | s#\s*(\*+)\s*#$1#g; |
e50aee73 |
160 | s#(\*+)# $1 #g ; |
f06db76b |
161 | |
162 | # change multiple whitespace into a single space |
163 | s/\s+/ /g ; |
164 | |
165 | # trim leading & trailing whitespace |
166 | TrimWhitespace($_) ; |
167 | |
168 | $_ ; |
169 | } |
170 | |
93a17b20 |
171 | $typemap = shift @ARGV; |
8990e307 |
172 | foreach $typemap (@tm) { |
173 | die "Can't find $typemap in $pwd\n" unless -r $typemap; |
93a17b20 |
174 | } |
748a9306 |
175 | unshift @tm, qw(../../../../lib/ExtUtils/typemap ../../../lib/ExtUtils/typemap |
176 | ../../lib/ExtUtils/typemap ../../../typemap ../../typemap |
177 | ../typemap typemap); |
8990e307 |
178 | foreach $typemap (@tm) { |
f06db76b |
179 | next unless -e $typemap ; |
180 | # skip directories, binary files etc. |
181 | warn("Warning: ignoring non-text typemap file '$typemap'\n"), next |
182 | unless -T $typemap ; |
183 | open(TYPEMAP, $typemap) |
184 | or warn ("Warning: could not open typemap file '$typemap': $!\n"), next; |
e50aee73 |
185 | $mode = 'Typemap'; |
c2960299 |
186 | $junk = "" ; |
8990e307 |
187 | $current = \$junk; |
188 | while (<TYPEMAP>) { |
e50aee73 |
189 | next if /^\s*#/; |
e1f0c0aa |
190 | my $line_no = $. + 1; |
8e07c86e |
191 | if (/^INPUT\s*$/) { $mode = 'Input'; $current = \$junk; next; } |
192 | if (/^OUTPUT\s*$/) { $mode = 'Output'; $current = \$junk; next; } |
193 | if (/^TYPEMAP\s*$/) { $mode = 'Typemap'; $current = \$junk; next; } |
e50aee73 |
194 | if ($mode eq 'Typemap') { |
195 | chomp; |
f06db76b |
196 | my $line = $_ ; |
197 | TrimWhitespace($_) ; |
198 | # skip blank lines and comment lines |
199 | next if /^$/ or /^#/ ; |
382b8d97 |
200 | my($type,$kind, $proto) = /^\s*(.*?\S)\s+(\S+)\s*($proto_re*)\s*$/ or |
201 | warn("Warning: File '$typemap' Line $. '$line' TYPEMAP entry needs 2 or 3 columns\n"), next; |
202 | $type = TidyType($type) ; |
203 | $type_kind{$type} = $kind ; |
204 | # prototype defaults to '$' |
93d3b392 |
205 | $proto = "\$" unless $proto ; |
382b8d97 |
206 | warn("Warning: File '$typemap' Line $. '$line' Invalid prototype '$proto'\n") |
207 | unless ValidProtoString($proto) ; |
208 | $proto_letter{$type} = C_string($proto) ; |
8e07c86e |
209 | } |
210 | elsif (/^\s/) { |
211 | $$current .= $_; |
463ee0b2 |
212 | } |
e50aee73 |
213 | elsif ($mode eq 'Input') { |
8e07c86e |
214 | s/\s+$//; |
215 | $input_expr{$_} = ''; |
216 | $current = \$input_expr{$_}; |
93a17b20 |
217 | } |
8990e307 |
218 | else { |
8e07c86e |
219 | s/\s+$//; |
220 | $output_expr{$_} = ''; |
221 | $current = \$output_expr{$_}; |
93a17b20 |
222 | } |
8990e307 |
223 | } |
224 | close(TYPEMAP); |
225 | } |
93a17b20 |
226 | |
8990e307 |
227 | foreach $key (keys %input_expr) { |
228 | $input_expr{$key} =~ s/\n+$//; |
229 | } |
93a17b20 |
230 | |
8e07c86e |
231 | $END = "!End!\n\n"; # "impossible" keyword (multiple newline) |
232 | |
233 | # Match an XS keyword |
382b8d97 |
234 | $BLOCK_re= '\s*(' . join('|', qw( |
235 | REQUIRE BOOT CASE PREINIT INPUT INIT CODE PPCODE OUTPUT |
8fc38fda |
236 | CLEANUP ALIAS PROTOTYPES PROTOTYPE VERSIONCHECK INCLUDE |
db3b9414 |
237 | SCOPE |
382b8d97 |
238 | )) . "|$END)\\s*:"; |
8e07c86e |
239 | |
240 | # Input: ($_, @line) == unparsed input. |
241 | # Output: ($_, @line) == (rest of line, following lines). |
242 | # Return: the matched keyword if found, otherwise 0 |
243 | sub check_keyword { |
244 | $_ = shift(@line) while !/\S/ && @line; |
245 | s/^(\s*)($_[0])\s*:\s*(?:#.*)?/$1/s && $2; |
246 | } |
247 | |
248 | |
6f1abe2b |
249 | if ($WantLineNumbers) { |
250 | { |
251 | package xsubpp::counter; |
252 | sub TIEHANDLE { |
253 | my ($class, $cfile) = @_; |
254 | my $buf = ""; |
255 | $SECTION_END_MARKER = "#line --- \"$cfile\""; |
256 | $line_no = 1; |
257 | bless \$buf; |
258 | } |
259 | |
260 | sub PRINT { |
261 | my $self = shift; |
262 | for (@_) { |
263 | $$self .= $_; |
264 | while ($$self =~ s/^([^\n]*\n)//) { |
265 | my $line = $1; |
266 | ++ $line_no; |
267 | $line =~ s|^\#line\s+---(?=\s)|#line $line_no|; |
268 | print STDOUT $line; |
269 | } |
270 | } |
271 | } |
272 | |
273 | sub PRINTF { |
274 | my $self = shift; |
275 | my $fmt = shift; |
276 | $self->PRINT(sprintf($fmt, @_)); |
277 | } |
278 | |
279 | sub DESTROY { |
280 | # Not necessary if we're careful to end with a "\n" |
281 | my $self = shift; |
282 | print STDOUT $$self; |
283 | } |
284 | } |
285 | |
286 | my $cfile = $filename; |
287 | $cfile =~ s/\.xs$/.c/i or $cfile .= ".c"; |
288 | tie(*PSEUDO_STDOUT, 'xsubpp::counter', $cfile); |
289 | select PSEUDO_STDOUT; |
290 | } |
291 | |
8e07c86e |
292 | sub print_section { |
6f1abe2b |
293 | # the "do" is required for right semantics |
294 | do { $_ = shift(@line) } while !/\S/ && @line; |
295 | |
296 | print("#line ", $line_no[@line_no - @line -1], " \"$filename\"\n") |
d3308daf |
297 | if $WantLineNumbers && !/^\s*#\s*line\b/ && !/^#if XSubPPtmp/; |
8e07c86e |
298 | for (; defined($_) && !/^$BLOCK_re/o; $_ = shift(@line)) { |
299 | print "$_\n"; |
300 | } |
6f1abe2b |
301 | print "$xsubpp::counter::SECTION_END_MARKER\n" if $WantLineNumbers; |
8e07c86e |
302 | } |
303 | |
8fc38fda |
304 | sub process_keyword($) |
305 | { |
306 | my($pattern) = @_ ; |
307 | my $kwd ; |
308 | |
309 | &{"${kwd}_handler"}() |
310 | while $kwd = check_keyword($pattern) ; |
311 | } |
312 | |
8e07c86e |
313 | sub CASE_handler { |
314 | blurt ("Error: `CASE:' after unconditional `CASE:'") |
315 | if $condnum && $cond eq ''; |
316 | $cond = $_; |
317 | TrimWhitespace($cond); |
318 | print " ", ($condnum++ ? " else" : ""), ($cond ? " if ($cond)\n" : "\n"); |
319 | $_ = '' ; |
320 | } |
321 | |
322 | sub INPUT_handler { |
323 | for (; !/^$BLOCK_re/o; $_ = shift(@line)) { |
324 | last if /^\s*NOT_IMPLEMENTED_YET/; |
325 | next unless /\S/; # skip blank lines |
326 | |
327 | TrimWhitespace($_) ; |
328 | my $line = $_ ; |
329 | |
330 | # remove trailing semicolon if no initialisation |
331 | s/\s*;$//g unless /=/ ; |
332 | |
333 | # check for optional initialisation code |
334 | my $var_init = '' ; |
335 | $var_init = $1 if s/\s*(=.*)$//s ; |
336 | $var_init =~ s/"/\\"/g; |
337 | |
338 | s/\s+/ /g; |
339 | my ($var_type, $var_addr, $var_name) = /^(.*?[^& ]) *(\&?) *\b(\w+)$/s |
340 | or blurt("Error: invalid argument declaration '$line'"), next; |
341 | |
342 | # Check for duplicate definitions |
343 | blurt ("Error: duplicate definition of argument '$var_name' ignored"), next |
344 | if $arg_list{$var_name} ++ ; |
345 | |
346 | $thisdone |= $var_name eq "THIS"; |
347 | $retvaldone |= $var_name eq "RETVAL"; |
348 | $var_types{$var_name} = $var_type; |
349 | print "\t" . &map_type($var_type); |
350 | $var_num = $args_match{$var_name}; |
382b8d97 |
351 | |
8fc38fda |
352 | $proto_arg[$var_num] = ProtoString($var_type) |
353 | if $var_num ; |
8e07c86e |
354 | if ($var_addr) { |
355 | $var_addr{$var_name} = 1; |
356 | $func_args =~ s/\b($var_name)\b/&$1/; |
357 | } |
358 | if ($var_init =~ /^=\s*NO_INIT\s*;?\s*$/) { |
359 | print "\t$var_name;\n"; |
360 | } elsif ($var_init =~ /\S/) { |
361 | &output_init($var_type, $var_num, "$var_name $var_init"); |
362 | } elsif ($var_num) { |
363 | # generate initialization code |
364 | &generate_init($var_type, $var_num, $var_name); |
365 | } else { |
366 | print ";\n"; |
367 | } |
368 | } |
369 | } |
370 | |
371 | sub OUTPUT_handler { |
372 | for (; !/^$BLOCK_re/o; $_ = shift(@line)) { |
373 | next unless /\S/; |
ef50df4b |
374 | if (/^\s*SETMAGIC\s*:\s*(ENABLE|DISABLE)\s*/) { |
375 | $DoSetMagic = ($1 eq "ENABLE" ? 1 : 0); |
376 | next; |
377 | } |
8e07c86e |
378 | my ($outarg, $outcode) = /^\s*(\S+)\s*(.*?)\s*$/s ; |
379 | blurt ("Error: duplicate OUTPUT argument '$outarg' ignored"), next |
380 | if $outargs{$outarg} ++ ; |
381 | if (!$gotRETVAL and $outarg eq 'RETVAL') { |
382 | # deal with RETVAL last |
383 | $RETVAL_code = $outcode ; |
384 | $gotRETVAL = 1 ; |
385 | next ; |
386 | } |
387 | blurt ("Error: OUTPUT $outarg not an argument"), next |
388 | unless defined($args_match{$outarg}); |
389 | blurt("Error: No input definition for OUTPUT argument '$outarg' - ignored"), next |
390 | unless defined $var_types{$outarg} ; |
391 | if ($outcode) { |
392 | print "\t$outcode\n"; |
ef50df4b |
393 | print "\tSvSETMAGIC(ST(" . $var_num-1 . "));\n" if $DoSetMagic; |
8e07c86e |
394 | } else { |
395 | $var_num = $args_match{$outarg}; |
ef50df4b |
396 | &generate_output($var_types{$outarg}, $var_num, $outarg, $DoSetMagic); |
8e07c86e |
397 | } |
398 | } |
399 | } |
400 | |
8fc38fda |
401 | sub CLEANUP_handler() { print_section() } |
402 | sub PREINIT_handler() { print_section() } |
403 | sub INIT_handler() { print_section() } |
404 | |
8e07c86e |
405 | sub GetAliases |
406 | { |
407 | my ($line) = @_ ; |
408 | my ($orig) = $line ; |
409 | my ($alias) ; |
410 | my ($value) ; |
411 | |
412 | # Parse alias definitions |
413 | # format is |
414 | # alias = value alias = value ... |
415 | |
416 | while ($line =~ s/^\s*([\w:]+)\s*=\s*(\w+)\s*//) { |
417 | $alias = $1 ; |
418 | $orig_alias = $alias ; |
419 | $value = $2 ; |
420 | |
421 | # check for optional package definition in the alias |
422 | $alias = $Packprefix . $alias if $alias !~ /::/ ; |
423 | |
424 | # check for duplicate alias name & duplicate value |
425 | Warn("Warning: Ignoring duplicate alias '$orig_alias'") |
4230ab3f |
426 | if defined $XsubAliases{$alias} ; |
8e07c86e |
427 | |
4230ab3f |
428 | Warn("Warning: Aliases '$orig_alias' and '$XsubAliasValues{$value}' have identical values") |
429 | if $XsubAliasValues{$value} ; |
8e07c86e |
430 | |
4230ab3f |
431 | $XsubAliases = 1; |
432 | $XsubAliases{$alias} = $value ; |
433 | $XsubAliasValues{$value} = $orig_alias ; |
8e07c86e |
434 | } |
435 | |
436 | blurt("Error: Cannot parse ALIAS definitions from '$orig'") |
437 | if $line ; |
438 | } |
439 | |
382b8d97 |
440 | sub ALIAS_handler () |
8e07c86e |
441 | { |
442 | for (; !/^$BLOCK_re/o; $_ = shift(@line)) { |
443 | next unless /\S/; |
444 | TrimWhitespace($_) ; |
445 | GetAliases($_) if $_ ; |
446 | } |
447 | } |
448 | |
382b8d97 |
449 | sub REQUIRE_handler () |
8e07c86e |
450 | { |
451 | # the rest of the current line should contain a version number |
452 | my ($Ver) = $_ ; |
453 | |
454 | TrimWhitespace($Ver) ; |
455 | |
456 | death ("Error: REQUIRE expects a version number") |
457 | unless $Ver ; |
458 | |
459 | # check that the version number is of the form n.n |
460 | death ("Error: REQUIRE: expected a number, got '$Ver'") |
461 | unless $Ver =~ /^\d+(\.\d*)?/ ; |
462 | |
463 | death ("Error: xsubpp $Ver (or better) required--this is only $XSUBPP_version.") |
464 | unless $XSUBPP_version >= $Ver ; |
465 | } |
466 | |
8fc38fda |
467 | sub VERSIONCHECK_handler () |
468 | { |
469 | # the rest of the current line should contain either ENABLE or |
470 | # DISABLE |
471 | |
472 | TrimWhitespace($_) ; |
473 | |
474 | # check for ENABLE/DISABLE |
475 | death ("Error: VERSIONCHECK: ENABLE/DISABLE") |
476 | unless /^(ENABLE|DISABLE)/i ; |
477 | |
478 | $WantVersionChk = 1 if $1 eq 'ENABLE' ; |
479 | $WantVersionChk = 0 if $1 eq 'DISABLE' ; |
480 | |
481 | } |
482 | |
382b8d97 |
483 | sub PROTOTYPE_handler () |
484 | { |
7d41bd0a |
485 | my $specified ; |
486 | |
c07a80fd |
487 | death("Error: Only 1 PROTOTYPE definition allowed per xsub") |
488 | if $proto_in_this_xsub ++ ; |
489 | |
382b8d97 |
490 | for (; !/^$BLOCK_re/o; $_ = shift(@line)) { |
491 | next unless /\S/; |
7d41bd0a |
492 | $specified = 1 ; |
382b8d97 |
493 | TrimWhitespace($_) ; |
494 | if ($_ eq 'DISABLE') { |
495 | $ProtoThisXSUB = 0 |
496 | } |
497 | elsif ($_ eq 'ENABLE') { |
498 | $ProtoThisXSUB = 1 |
499 | } |
500 | else { |
501 | # remove any whitespace |
502 | s/\s+//g ; |
503 | death("Error: Invalid prototype '$_'") |
504 | unless ValidProtoString($_) ; |
505 | $ProtoThisXSUB = C_string($_) ; |
506 | } |
507 | } |
c07a80fd |
508 | |
7d41bd0a |
509 | # If no prototype specified, then assume empty prototype "" |
510 | $ProtoThisXSUB = 2 unless $specified ; |
511 | |
8fc38fda |
512 | $ProtoUsed = 1 ; |
c07a80fd |
513 | |
382b8d97 |
514 | } |
515 | |
db3b9414 |
516 | sub SCOPE_handler () |
517 | { |
518 | death("Error: Only 1 SCOPE declaration allowed per xsub") |
519 | if $scope_in_this_xsub ++ ; |
520 | |
521 | for (; !/^$BLOCK_re/o; $_ = shift(@line)) { |
522 | next unless /\S/; |
523 | TrimWhitespace($_) ; |
524 | if ($_ =~ /^DISABLE/i) { |
525 | $ScopeThisXSUB = 0 |
526 | } |
527 | elsif ($_ =~ /^ENABLE/i) { |
528 | $ScopeThisXSUB = 1 |
529 | } |
530 | } |
531 | |
532 | } |
533 | |
382b8d97 |
534 | sub PROTOTYPES_handler () |
535 | { |
536 | # the rest of the current line should contain either ENABLE or |
537 | # DISABLE |
538 | |
539 | TrimWhitespace($_) ; |
540 | |
541 | # check for ENABLE/DISABLE |
542 | death ("Error: PROTOTYPES: ENABLE/DISABLE") |
543 | unless /^(ENABLE|DISABLE)/i ; |
544 | |
545 | $WantPrototypes = 1 if $1 eq 'ENABLE' ; |
546 | $WantPrototypes = 0 if $1 eq 'DISABLE' ; |
8fc38fda |
547 | $ProtoUsed = 1 ; |
382b8d97 |
548 | |
549 | } |
550 | |
8fc38fda |
551 | sub INCLUDE_handler () |
552 | { |
553 | # the rest of the current line should contain a valid filename |
554 | |
555 | TrimWhitespace($_) ; |
556 | |
8fc38fda |
557 | death("INCLUDE: filename missing") |
558 | unless $_ ; |
559 | |
560 | death("INCLUDE: output pipe is illegal") |
561 | if /^\s*\|/ ; |
562 | |
563 | # simple minded recursion detector |
564 | death("INCLUDE loop detected") |
565 | if $IncludedFiles{$_} ; |
566 | |
567 | ++ $IncludedFiles{$_} unless /\|\s*$/ ; |
568 | |
569 | # Save the current file context. |
4230ab3f |
570 | push(@XSStack, { |
571 | type => 'file', |
8fc38fda |
572 | LastLine => $lastline, |
573 | LastLineNo => $lastline_no, |
574 | Line => \@line, |
575 | LineNo => \@line_no, |
576 | Filename => $filename, |
c07a80fd |
577 | Handle => $FH, |
8fc38fda |
578 | }) ; |
579 | |
c07a80fd |
580 | ++ $FH ; |
8fc38fda |
581 | |
582 | # open the new file |
c07a80fd |
583 | open ($FH, "$_") or death("Cannot open '$_': $!") ; |
8fc38fda |
584 | |
585 | print Q<<"EOF" ; |
586 | # |
587 | #/* INCLUDE: Including '$_' from '$filename' */ |
588 | # |
589 | EOF |
590 | |
8fc38fda |
591 | $filename = $_ ; |
592 | |
c07a80fd |
593 | # Prime the pump by reading the first |
594 | # non-blank line |
595 | |
596 | # skip leading blank lines |
597 | while (<$FH>) { |
598 | last unless /^\s*$/ ; |
599 | } |
600 | |
601 | $lastline = $_ ; |
8fc38fda |
602 | $lastline_no = $. ; |
603 | |
604 | } |
605 | |
606 | sub PopFile() |
607 | { |
4230ab3f |
608 | return 0 unless $XSStack[-1]{type} eq 'file' ; |
609 | |
610 | my $data = pop @XSStack ; |
8fc38fda |
611 | my $ThisFile = $filename ; |
612 | my $isPipe = ($filename =~ /\|\s*$/) ; |
613 | |
614 | -- $IncludedFiles{$filename} |
615 | unless $isPipe ; |
616 | |
c07a80fd |
617 | close $FH ; |
8fc38fda |
618 | |
c07a80fd |
619 | $FH = $data->{Handle} ; |
8fc38fda |
620 | $filename = $data->{Filename} ; |
621 | $lastline = $data->{LastLine} ; |
622 | $lastline_no = $data->{LastLineNo} ; |
623 | @line = @{ $data->{Line} } ; |
624 | @line_no = @{ $data->{LineNo} } ; |
4230ab3f |
625 | |
8fc38fda |
626 | if ($isPipe and $? ) { |
627 | -- $lastline_no ; |
628 | print STDERR "Error reading from pipe '$ThisFile': $! in $filename, line $lastline_no\n" ; |
629 | exit 1 ; |
630 | } |
631 | |
632 | print Q<<"EOF" ; |
633 | # |
634 | #/* INCLUDE: Returning to '$filename' from '$ThisFile' */ |
635 | # |
636 | EOF |
637 | |
638 | return 1 ; |
639 | } |
640 | |
382b8d97 |
641 | sub ValidProtoString ($) |
642 | { |
643 | my($string) = @_ ; |
644 | |
645 | if ( $string =~ /^$proto_re+$/ ) { |
646 | return $string ; |
647 | } |
648 | |
649 | return 0 ; |
650 | } |
651 | |
652 | sub C_string ($) |
653 | { |
654 | my($string) = @_ ; |
655 | |
656 | $string =~ s[\\][\\\\]g ; |
657 | $string ; |
658 | } |
659 | |
660 | sub ProtoString ($) |
661 | { |
662 | my ($type) = @_ ; |
663 | |
93d3b392 |
664 | $proto_letter{$type} or "\$" ; |
382b8d97 |
665 | } |
666 | |
8e07c86e |
667 | sub check_cpp { |
668 | my @cpp = grep(/^\#\s*(?:if|e\w+)/, @line); |
669 | if (@cpp) { |
670 | my ($cpp, $cpplevel); |
671 | for $cpp (@cpp) { |
672 | if ($cpp =~ /^\#\s*if/) { |
673 | $cpplevel++; |
674 | } elsif (!$cpplevel) { |
675 | Warn("Warning: #else/elif/endif without #if in this function"); |
4230ab3f |
676 | print STDERR " (precede it with a blank line if the matching #if is outside the function)\n" |
677 | if $XSStack[-1]{type} eq 'if'; |
8e07c86e |
678 | return; |
679 | } elsif ($cpp =~ /^\#\s*endif/) { |
680 | $cpplevel--; |
681 | } |
682 | } |
683 | Warn("Warning: #if without #endif in this function") if $cpplevel; |
684 | } |
685 | } |
686 | |
687 | |
8990e307 |
688 | sub Q { |
e50aee73 |
689 | my($text) = @_; |
4633a7c4 |
690 | $text =~ s/^#//gm; |
2304df62 |
691 | $text =~ s/\[\[/{/g; |
692 | $text =~ s/\]\]/}/g; |
8990e307 |
693 | $text; |
93a17b20 |
694 | } |
695 | |
c07a80fd |
696 | open($FH, $filename) or die "cannot open $filename: $!\n"; |
c2960299 |
697 | |
f06db76b |
698 | # Identify the version of xsubpp used |
f06db76b |
699 | print <<EOM ; |
e50aee73 |
700 | /* |
701 | * This file was generated automatically by xsubpp version $XSUBPP_version from the |
93d3b392 |
702 | * contents of $filename. Do not edit this file, edit $filename instead. |
e50aee73 |
703 | * |
704 | * ANY CHANGES MADE HERE WILL BE LOST! |
f06db76b |
705 | * |
706 | */ |
e50aee73 |
707 | |
f06db76b |
708 | EOM |
6f1abe2b |
709 | |
710 | |
711 | print("#line 1 \"$filename\"\n") |
712 | if $WantLineNumbers; |
f06db76b |
713 | |
c07a80fd |
714 | while (<$FH>) { |
e50aee73 |
715 | last if ($Module, $Package, $Prefix) = |
716 | /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/; |
a0d0e21e |
717 | print $_; |
93a17b20 |
718 | } |
e50aee73 |
719 | &Exit unless defined $_; |
720 | |
8fc38fda |
721 | $lastline = $_; |
722 | $lastline_no = $.; |
93a17b20 |
723 | |
c07a80fd |
724 | # Read next xsub into @line from ($lastline, <$FH>). |
2304df62 |
725 | sub fetch_para { |
726 | # parse paragraph |
4230ab3f |
727 | death ("Error: Unterminated `#if/#ifdef/#ifndef'") |
728 | if !defined $lastline && $XSStack[-1]{type} eq 'if'; |
2304df62 |
729 | @line = (); |
c2960299 |
730 | @line_no = () ; |
4230ab3f |
731 | return PopFile() if !defined $lastline; |
e50aee73 |
732 | |
733 | if ($lastline =~ |
734 | /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/) { |
735 | $Module = $1; |
8e07c86e |
736 | $Package = defined($2) ? $2 : ''; # keep -w happy |
737 | $Prefix = defined($3) ? $3 : ''; # keep -w happy |
ff68c719 |
738 | $Prefix = quotemeta $Prefix ; |
e50aee73 |
739 | ($Module_cname = $Module) =~ s/\W/_/g; |
8e07c86e |
740 | ($Packid = $Package) =~ tr/:/_/; |
e50aee73 |
741 | $Packprefix = $Package; |
8e07c86e |
742 | $Packprefix .= "::" if $Packprefix ne ""; |
2304df62 |
743 | $lastline = ""; |
e50aee73 |
744 | } |
745 | |
746 | for(;;) { |
747 | if ($lastline !~ /^\s*#/ || |
4230ab3f |
748 | # CPP directives: |
749 | # ANSI: if ifdef ifndef elif else endif define undef |
750 | # line error pragma |
751 | # gcc: warning include_next |
752 | # obj-c: import |
753 | # others: ident (gcc notes that some cpps have this one) |
754 | $lastline =~ /^#[ \t]*(?:(?:if|ifn?def|elif|else|endif|define|undef|pragma|error|warning|line\s+\d+|ident)\b|(?:include(?:_next)?|import)\s*["<].*[>"])/) { |
e50aee73 |
755 | last if $lastline =~ /^\S/ && @line && $line[-1] eq ""; |
756 | push(@line, $lastline); |
757 | push(@line_no, $lastline_no) ; |
93a17b20 |
758 | } |
e50aee73 |
759 | |
760 | # Read next line and continuation lines |
c07a80fd |
761 | last unless defined($lastline = <$FH>); |
e50aee73 |
762 | $lastline_no = $.; |
763 | my $tmp_line; |
764 | $lastline .= $tmp_line |
c07a80fd |
765 | while ($lastline =~ /\\$/ && defined($tmp_line = <$FH>)); |
e50aee73 |
766 | |
8e07c86e |
767 | chomp $lastline; |
e50aee73 |
768 | $lastline =~ s/^\s+$//; |
2304df62 |
769 | } |
e50aee73 |
770 | pop(@line), pop(@line_no) while @line && $line[-1] eq ""; |
e50aee73 |
771 | 1; |
2304df62 |
772 | } |
93a17b20 |
773 | |
c2960299 |
774 | PARAGRAPH: |
8e07c86e |
775 | while (fetch_para()) { |
e50aee73 |
776 | # Print initial preprocessor statements and blank lines |
4230ab3f |
777 | while (@line && $line[0] !~ /^[^\#]/) { |
778 | my $line = shift(@line); |
779 | print $line, "\n"; |
780 | next unless $line =~ /^\#\s*((if)(?:n?def)?|elsif|else|endif)\b/; |
781 | my $statement = $+; |
782 | if ($statement eq 'if') { |
783 | $XSS_work_idx = @XSStack; |
784 | push(@XSStack, {type => 'if'}); |
785 | } else { |
786 | death ("Error: `$statement' with no matching `if'") |
787 | if $XSStack[-1]{type} ne 'if'; |
788 | if ($XSStack[-1]{varname}) { |
789 | push(@InitFileCode, "#endif\n"); |
790 | push(@BootCode, "#endif"); |
791 | } |
792 | |
793 | my(@fns) = keys %{$XSStack[-1]{functions}}; |
794 | if ($statement ne 'endif') { |
795 | # Hide the functions defined in other #if branches, and reset. |
796 | @{$XSStack[-1]{other_functions}}{@fns} = (1) x @fns; |
797 | @{$XSStack[-1]}{qw(varname functions)} = ('', {}); |
798 | } else { |
799 | my($tmp) = pop(@XSStack); |
800 | 0 while (--$XSS_work_idx |
801 | && $XSStack[$XSS_work_idx]{type} ne 'if'); |
802 | # Keep all new defined functions |
803 | push(@fns, keys %{$tmp->{other_functions}}); |
804 | @{$XSStack[$XSS_work_idx]{functions}}{@fns} = (1) x @fns; |
805 | } |
806 | } |
807 | } |
e50aee73 |
808 | |
809 | next PARAGRAPH unless @line; |
810 | |
4230ab3f |
811 | if ($XSS_work_idx && !$XSStack[$XSS_work_idx]{varname}) { |
812 | # We are inside an #if, but have not yet #defined its xsubpp variable. |
813 | print "#define $cpp_next_tmp 1\n\n"; |
814 | push(@InitFileCode, "#if $cpp_next_tmp\n"); |
815 | push(@BootCode, "#if $cpp_next_tmp"); |
816 | $XSStack[$XSS_work_idx]{varname} = $cpp_next_tmp++; |
817 | } |
818 | |
55497cff |
819 | death ("Code is not inside a function" |
820 | ." (maybe last function was ended by a blank line " |
821 | ." followed by a a statement on column one?)") |
e50aee73 |
822 | if $line[0] =~ /^\s/; |
823 | |
2304df62 |
824 | # initialize info arrays |
825 | undef(%args_match); |
826 | undef(%var_types); |
827 | undef(%var_addr); |
828 | undef(%defaults); |
829 | undef($class); |
830 | undef($static); |
831 | undef($elipsis); |
f06db76b |
832 | undef($wantRETVAL) ; |
833 | undef(%arg_list) ; |
382b8d97 |
834 | undef(@proto_arg) ; |
c07a80fd |
835 | undef($proto_in_this_xsub) ; |
db3b9414 |
836 | undef($scope_in_this_xsub) ; |
382b8d97 |
837 | $ProtoThisXSUB = $WantPrototypes ; |
db3b9414 |
838 | $ScopeThisXSUB = 0; |
2304df62 |
839 | |
8e07c86e |
840 | $_ = shift(@line); |
8fc38fda |
841 | while ($kwd = check_keyword("REQUIRE|PROTOTYPES|VERSIONCHECK|INCLUDE")) { |
842 | &{"${kwd}_handler"}() ; |
8e07c86e |
843 | next PARAGRAPH unless @line ; |
844 | $_ = shift(@line); |
845 | } |
c2960299 |
846 | |
8e07c86e |
847 | if (check_keyword("BOOT")) { |
848 | &check_cpp; |
6f1abe2b |
849 | push (@BootCode, "#line $line_no[@line_no - @line] \"$filename\"") |
850 | if $WantLineNumbers && $line[0] !~ /^\s*#\s*line\b/; |
851 | push (@BootCode, @line, "") ; |
c2960299 |
852 | next PARAGRAPH ; |
a0d0e21e |
853 | } |
c2960299 |
854 | |
8e07c86e |
855 | |
856 | # extract return type, function name and arguments |
857 | my($ret_type) = TidyType($_); |
858 | |
c2960299 |
859 | # a function definition needs at least 2 lines |
860 | blurt ("Error: Function definition too short '$ret_type'"), next PARAGRAPH |
861 | unless @line ; |
862 | |
8e07c86e |
863 | $static = 1 if $ret_type =~ s/^static\s+//; |
864 | |
2304df62 |
865 | $func_header = shift(@line); |
c2960299 |
866 | blurt ("Error: Cannot parse function definition from '$func_header'"), next PARAGRAPH |
8e07c86e |
867 | unless $func_header =~ /^(?:([\w:]*)::)?(\w+)\s*\(\s*(.*?)\s*\)\s*$/s; |
c2960299 |
868 | |
8e07c86e |
869 | ($class, $func_name, $orig_args) = ($1, $2, $3) ; |
2304df62 |
870 | ($pname = $func_name) =~ s/^($Prefix)?/$Packprefix/; |
ff68c719 |
871 | ($clean_func_name = $func_name) =~ s/^$Prefix//; |
872 | $Full_func_name = "${Packid}_$clean_func_name"; |
ff0cee69 |
873 | if ($Is_VMS) { $Full_func_name = $SymSet->addsym($Full_func_name); } |
c2960299 |
874 | |
875 | # Check for duplicate function definition |
4230ab3f |
876 | for $tmp (@XSStack) { |
877 | next unless defined $tmp->{functions}{$Full_func_name}; |
ff68c719 |
878 | Warn("Warning: duplicate function definition '$clean_func_name' detected"); |
4230ab3f |
879 | last; |
8e07c86e |
880 | } |
4230ab3f |
881 | $XSStack[$XSS_work_idx]{functions}{$Full_func_name} ++ ; |
882 | %XsubAliases = %XsubAliasValues = (); |
ef50df4b |
883 | $DoSetMagic = 1; |
c2960299 |
884 | |
2304df62 |
885 | @args = split(/\s*,\s*/, $orig_args); |
a0d0e21e |
886 | if (defined($class)) { |
683d4eee |
887 | my $arg0 = ((defined($static) or $func_name eq 'new') |
888 | ? "CLASS" : "THIS"); |
8e07c86e |
889 | unshift(@args, $arg0); |
890 | ($orig_args = "$arg0, $orig_args") =~ s/^$arg0, $/$arg0/; |
2304df62 |
891 | } |
892 | $orig_args =~ s/"/\\"/g; |
893 | $min_args = $num_args = @args; |
894 | foreach $i (0..$num_args-1) { |
895 | if ($args[$i] =~ s/\.\.\.//) { |
896 | $elipsis = 1; |
897 | $min_args--; |
c2960299 |
898 | if ($args[$i] eq '' && $i == $num_args - 1) { |
2304df62 |
899 | pop(@args); |
900 | last; |
901 | } |
902 | } |
8e07c86e |
903 | if ($args[$i] =~ /^([^=]*[^\s=])\s*=\s*(.*)/s) { |
2304df62 |
904 | $min_args--; |
905 | $args[$i] = $1; |
906 | $defaults{$args[$i]} = $2; |
907 | $defaults{$args[$i]} =~ s/"/\\"/g; |
908 | } |
93d3b392 |
909 | $proto_arg[$i+1] = "\$" ; |
2304df62 |
910 | } |
a0d0e21e |
911 | if (defined($class)) { |
2304df62 |
912 | $func_args = join(", ", @args[1..$#args]); |
913 | } else { |
914 | $func_args = join(", ", @args); |
915 | } |
916 | @args_match{@args} = 1..@args; |
917 | |
8e07c86e |
918 | $PPCODE = grep(/^\s*PPCODE\s*:/, @line); |
93d3b392 |
919 | $CODE = grep(/^\s*CODE\s*:/, @line); |
6c5fb52b |
920 | # Detect CODE: blocks which use ST(n)= or XST_m*(n,v) |
921 | # to set explicit return values. |
922 | $EXPLICIT_RETURN = ($CODE && |
923 | ("@line" =~ /(\bST\s*\([^;]*=) | (\bXST_m\w+\s*\()/x )); |
8e07c86e |
924 | $ALIAS = grep(/^\s*ALIAS\s*:/, @line); |
925 | |
2304df62 |
926 | # print function header |
a0d0e21e |
927 | print Q<<"EOF"; |
ff68c719 |
928 | #XS(XS_${Full_func_name}) |
2304df62 |
929 | #[[ |
a0d0e21e |
930 | # dXSARGS; |
93a17b20 |
931 | EOF |
8e07c86e |
932 | print Q<<"EOF" if $ALIAS ; |
933 | # dXSI32; |
934 | EOF |
2304df62 |
935 | if ($elipsis) { |
8e07c86e |
936 | $cond = ($min_args ? qq(items < $min_args) : 0); |
2304df62 |
937 | } |
938 | elsif ($min_args == $num_args) { |
939 | $cond = qq(items != $min_args); |
940 | } |
941 | else { |
942 | $cond = qq(items < $min_args || items > $num_args); |
943 | } |
8990e307 |
944 | |
2304df62 |
945 | print Q<<"EOF" if $except; |
946 | # char errbuf[1024]; |
947 | # *errbuf = '\0'; |
948 | EOF |
949 | |
8e07c86e |
950 | if ($ALIAS) |
951 | { print Q<<"EOF" if $cond } |
952 | # if ($cond) |
953 | # croak("Usage: %s($orig_args)", GvNAME(CvGV(cv))); |
954 | EOF |
955 | else |
956 | { print Q<<"EOF" if $cond } |
957 | # if ($cond) |
8990e307 |
958 | # croak("Usage: $pname($orig_args)"); |
93a17b20 |
959 | EOF |
960 | |
a0d0e21e |
961 | print Q<<"EOF" if $PPCODE; |
962 | # SP -= items; |
963 | EOF |
964 | |
2304df62 |
965 | # Now do a block of some sort. |
93a17b20 |
966 | |
2304df62 |
967 | $condnum = 0; |
8e07c86e |
968 | $cond = ''; # last CASE: condidional |
969 | push(@line, "$END:"); |
970 | push(@line_no, $line_no[-1]); |
971 | $_ = ''; |
972 | &check_cpp; |
2304df62 |
973 | while (@line) { |
8e07c86e |
974 | &CASE_handler if check_keyword("CASE"); |
975 | print Q<<"EOF"; |
976 | # $except [[ |
93a17b20 |
977 | EOF |
978 | |
979 | # do initialization of input variables |
980 | $thisdone = 0; |
981 | $retvaldone = 0; |
463ee0b2 |
982 | $deferred = ""; |
c2960299 |
983 | %arg_list = () ; |
984 | $gotRETVAL = 0; |
f06db76b |
985 | |
8fc38fda |
986 | INPUT_handler() ; |
db3b9414 |
987 | process_keyword("INPUT|PREINIT|ALIAS|PROTOTYPE|SCOPE") ; |
8fc38fda |
988 | |
db3b9414 |
989 | print Q<<"EOF" if $ScopeThisXSUB; |
990 | # ENTER; |
991 | # [[ |
992 | EOF |
993 | |
a0d0e21e |
994 | if (!$thisdone && defined($class)) { |
683d4eee |
995 | if (defined($static) or $func_name eq 'new') { |
a0d0e21e |
996 | print "\tchar *"; |
997 | $var_types{"CLASS"} = "char *"; |
998 | &generate_init("char *", 1, "CLASS"); |
999 | } |
1000 | else { |
93a17b20 |
1001 | print "\t$class *"; |
1002 | $var_types{"THIS"} = "$class *"; |
1003 | &generate_init("$class *", 1, "THIS"); |
a0d0e21e |
1004 | } |
93a17b20 |
1005 | } |
1006 | |
1007 | # do code |
1008 | if (/^\s*NOT_IMPLEMENTED_YET/) { |
4633a7c4 |
1009 | print "\n\tcroak(\"$pname: not implemented yet\");\n"; |
1010 | $_ = '' ; |
93a17b20 |
1011 | } else { |
1012 | if ($ret_type ne "void") { |
1013 | print "\t" . &map_type($ret_type) . "\tRETVAL;\n" |
1014 | if !$retvaldone; |
1015 | $args_match{"RETVAL"} = 0; |
1016 | $var_types{"RETVAL"} = $ret_type; |
1017 | } |
db3b9414 |
1018 | |
8e07c86e |
1019 | print $deferred; |
db3b9414 |
1020 | |
1021 | process_keyword("INIT|ALIAS|PROTOTYPE") ; |
8e07c86e |
1022 | |
1023 | if (check_keyword("PPCODE")) { |
8fc38fda |
1024 | print_section(); |
8e07c86e |
1025 | death ("PPCODE must be last thing") if @line; |
db3b9414 |
1026 | print "\tLEAVE;\n" if $ScopeThisXSUB; |
a0d0e21e |
1027 | print "\tPUTBACK;\n\treturn;\n"; |
8e07c86e |
1028 | } elsif (check_keyword("CODE")) { |
8fc38fda |
1029 | print_section() ; |
1030 | } elsif (defined($class) and $func_name eq "DESTROY") { |
a0d0e21e |
1031 | print "\n\t"; |
8e07c86e |
1032 | print "delete THIS;\n"; |
93a17b20 |
1033 | } else { |
1034 | print "\n\t"; |
1035 | if ($ret_type ne "void") { |
463ee0b2 |
1036 | print "RETVAL = "; |
e50aee73 |
1037 | $wantRETVAL = 1; |
93a17b20 |
1038 | } |
1039 | if (defined($static)) { |
683d4eee |
1040 | if ($func_name eq 'new') { |
8fc38fda |
1041 | $func_name = "$class"; |
8e07c86e |
1042 | } else { |
1043 | print "${class}::"; |
a0d0e21e |
1044 | } |
93a17b20 |
1045 | } elsif (defined($class)) { |
683d4eee |
1046 | if ($func_name eq 'new') { |
8fc38fda |
1047 | $func_name .= " $class"; |
1048 | } else { |
93a17b20 |
1049 | print "THIS->"; |
8fc38fda |
1050 | } |
93a17b20 |
1051 | } |
e50aee73 |
1052 | $func_name =~ s/^($spat)// |
1053 | if defined($spat); |
93a17b20 |
1054 | print "$func_name($func_args);\n"; |
93a17b20 |
1055 | } |
1056 | } |
1057 | |
1058 | # do output variables |
8e07c86e |
1059 | $gotRETVAL = 0; |
1060 | undef $RETVAL_code ; |
1061 | undef %outargs ; |
8fc38fda |
1062 | process_keyword("OUTPUT|ALIAS|PROTOTYPE"); |
f06db76b |
1063 | |
1064 | # all OUTPUT done, so now push the return value on the stack |
8e07c86e |
1065 | if ($gotRETVAL && $RETVAL_code) { |
1066 | print "\t$RETVAL_code\n"; |
1067 | } elsif ($gotRETVAL || $wantRETVAL) { |
ef50df4b |
1068 | # RETVAL almost never needs SvSETMAGIC() |
1069 | &generate_output($ret_type, 0, 'RETVAL', 0); |
8e07c86e |
1070 | } |
f06db76b |
1071 | |
93a17b20 |
1072 | # do cleanup |
8fc38fda |
1073 | process_keyword("CLEANUP|ALIAS|PROTOTYPE") ; |
8e07c86e |
1074 | |
db3b9414 |
1075 | print Q<<"EOF" if $ScopeThisXSUB; |
1076 | # ]] |
1077 | EOF |
1078 | print Q<<"EOF" if $ScopeThisXSUB and not $PPCODE; |
1079 | # LEAVE; |
1080 | EOF |
1081 | |
93a17b20 |
1082 | # print function trailer |
8e07c86e |
1083 | print Q<<EOF; |
2304df62 |
1084 | # ]] |
8e07c86e |
1085 | EOF |
1086 | print Q<<EOF if $except; |
8990e307 |
1087 | # BEGHANDLERS |
1088 | # CATCHALL |
1089 | # sprintf(errbuf, "%s: %s\\tpropagated", Xname, Xreason); |
1090 | # ENDHANDLERS |
93a17b20 |
1091 | EOF |
8e07c86e |
1092 | if (check_keyword("CASE")) { |
1093 | blurt ("Error: No `CASE:' at top of function") |
1094 | unless $condnum; |
1095 | $_ = "CASE: $_"; # Restore CASE: label |
1096 | next; |
8990e307 |
1097 | } |
8e07c86e |
1098 | last if $_ eq "$END:"; |
1099 | death(/^$BLOCK_re/o ? "Misplaced `$1:'" : "Junk at end of function"); |
2304df62 |
1100 | } |
a0d0e21e |
1101 | |
2304df62 |
1102 | print Q<<EOF if $except; |
1103 | # if (errbuf[0]) |
1104 | # croak(errbuf); |
1105 | EOF |
a0d0e21e |
1106 | |
7c5b83de |
1107 | if ($ret_type ne "void" or $EXPLICIT_RETURN) { |
93d3b392 |
1108 | print Q<<EOF unless $PPCODE; |
a0d0e21e |
1109 | # XSRETURN(1); |
1110 | EOF |
93d3b392 |
1111 | } else { |
1112 | print Q<<EOF unless $PPCODE; |
1113 | # XSRETURN_EMPTY; |
1114 | EOF |
1115 | } |
a0d0e21e |
1116 | |
2304df62 |
1117 | print Q<<EOF; |
2304df62 |
1118 | #]] |
8990e307 |
1119 | # |
93a17b20 |
1120 | EOF |
382b8d97 |
1121 | |
4230ab3f |
1122 | my $newXS = "newXS" ; |
1123 | my $proto = "" ; |
1124 | |
382b8d97 |
1125 | # Build the prototype string for the xsub |
1126 | if ($ProtoThisXSUB) { |
4230ab3f |
1127 | $newXS = "newXSproto"; |
1128 | |
6f1abe2b |
1129 | if ($ProtoThisXSUB eq 2) { |
4230ab3f |
1130 | # User has specified empty prototype |
1131 | $proto = ', ""' ; |
1132 | } |
6f1abe2b |
1133 | elsif ($ProtoThisXSUB ne 1) { |
7d41bd0a |
1134 | # User has specified a prototype |
4230ab3f |
1135 | $proto = ', "' . $ProtoThisXSUB . '"'; |
382b8d97 |
1136 | } |
1137 | else { |
1138 | my $s = ';'; |
1139 | if ($min_args < $num_args) { |
1140 | $s = ''; |
1141 | $proto_arg[$min_args] .= ";" ; |
1142 | } |
4230ab3f |
1143 | push @proto_arg, "$s\@" |
382b8d97 |
1144 | if $elipsis ; |
1145 | |
4230ab3f |
1146 | $proto = ', "' . join ("", @proto_arg) . '"'; |
382b8d97 |
1147 | } |
1148 | } |
1149 | |
4230ab3f |
1150 | if (%XsubAliases) { |
1151 | $XsubAliases{$pname} = 0 |
1152 | unless defined $XsubAliases{$pname} ; |
1153 | while ( ($name, $value) = each %XsubAliases) { |
1154 | push(@InitFileCode, Q<<"EOF"); |
1155 | # cv = newXS(\"$name\", XS_$Full_func_name, file); |
1156 | # XSANY.any_i32 = $value ; |
1157 | EOF |
1158 | push(@InitFileCode, Q<<"EOF") if $proto; |
1159 | # sv_setpv((SV*)cv$proto) ; |
1160 | EOF |
1161 | } |
1162 | } |
1163 | else { |
1164 | push(@InitFileCode, |
1165 | " ${newXS}(\"$pname\", XS_$Full_func_name, file$proto);\n"); |
1166 | } |
93a17b20 |
1167 | } |
1168 | |
1169 | # print initialization routine |
8990e307 |
1170 | print Q<<"EOF"; |
4633a7c4 |
1171 | ##ifdef __cplusplus |
1172 | #extern "C" |
1173 | ##endif |
a0d0e21e |
1174 | #XS(boot_$Module_cname) |
2304df62 |
1175 | #[[ |
a0d0e21e |
1176 | # dXSARGS; |
8990e307 |
1177 | # char* file = __FILE__; |
1178 | # |
93a17b20 |
1179 | EOF |
1180 | |
8fc38fda |
1181 | print Q<<"EOF" if $WantVersionChk ; |
1182 | # XS_VERSION_BOOTCHECK ; |
1183 | # |
1184 | EOF |
1185 | |
4230ab3f |
1186 | print Q<<"EOF" if defined $XsubAliases ; |
8e07c86e |
1187 | # { |
1188 | # CV * cv ; |
1189 | # |
1190 | EOF |
1191 | |
4230ab3f |
1192 | print @InitFileCode; |
a0d0e21e |
1193 | |
4230ab3f |
1194 | print Q<<"EOF" if defined $XsubAliases ; |
8e07c86e |
1195 | # } |
1196 | EOF |
1197 | |
a0d0e21e |
1198 | if (@BootCode) |
1199 | { |
6f1abe2b |
1200 | print "\n /* Initialisation Section */\n\n" ; |
1201 | @line = @BootCode; |
1202 | print_section(); |
8e07c86e |
1203 | print "\n /* End of Initialisation Section */\n\n" ; |
93a17b20 |
1204 | } |
a0d0e21e |
1205 | |
e50aee73 |
1206 | print Q<<"EOF";; |
1207 | # ST(0) = &sv_yes; |
1208 | # XSRETURN(1); |
1209 | #]] |
1210 | EOF |
1211 | |
8fc38fda |
1212 | warn("Please specify prototyping behavior for $filename (see perlxs manual)\n") |
1213 | unless $ProtoUsed ; |
e50aee73 |
1214 | &Exit; |
1215 | |
93a17b20 |
1216 | |
1217 | sub output_init { |
2304df62 |
1218 | local($type, $num, $init) = @_; |
a0d0e21e |
1219 | local($arg) = "ST(" . ($num - 1) . ")"; |
93a17b20 |
1220 | |
2304df62 |
1221 | eval qq/print " $init\\\n"/; |
93a17b20 |
1222 | } |
1223 | |
c2960299 |
1224 | sub Warn |
1225 | { |
1226 | # work out the line number |
1227 | my $line_no = $line_no[@line_no - @line -1] ; |
1228 | |
1229 | print STDERR "@_ in $filename, line $line_no\n" ; |
1230 | } |
1231 | |
1232 | sub blurt |
1233 | { |
1234 | Warn @_ ; |
1235 | $errors ++ |
1236 | } |
1237 | |
1238 | sub death |
1239 | { |
1240 | Warn @_ ; |
1241 | exit 1 ; |
1242 | } |
8990e307 |
1243 | |
93a17b20 |
1244 | sub generate_init { |
2304df62 |
1245 | local($type, $num, $var) = @_; |
a0d0e21e |
1246 | local($arg) = "ST(" . ($num - 1) . ")"; |
2304df62 |
1247 | local($argoff) = $num - 1; |
1248 | local($ntype); |
1249 | local($tk); |
93a17b20 |
1250 | |
f06db76b |
1251 | $type = TidyType($type) ; |
c2960299 |
1252 | blurt("Error: '$type' not in typemap"), return |
1253 | unless defined($type_kind{$type}); |
1254 | |
2304df62 |
1255 | ($ntype = $type) =~ s/\s*\*/Ptr/g; |
8e07c86e |
1256 | ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//; |
2304df62 |
1257 | $tk = $type_kind{$type}; |
1258 | $tk =~ s/OBJ$/REF/ if $func_name =~ /DESTROY$/; |
8e07c86e |
1259 | $type =~ tr/:/_/; |
c2960299 |
1260 | blurt("Error: No INPUT definition for type '$type' found"), return |
1261 | unless defined $input_expr{$tk} ; |
2304df62 |
1262 | $expr = $input_expr{$tk}; |
1263 | if ($expr =~ /DO_ARRAY_ELEM/) { |
c2960299 |
1264 | blurt("Error: '$subtype' not in typemap"), return |
1265 | unless defined($type_kind{$subtype}); |
1266 | blurt("Error: No INPUT definition for type '$subtype' found"), return |
1267 | unless defined $input_expr{$type_kind{$subtype}} ; |
2304df62 |
1268 | $subexpr = $input_expr{$type_kind{$subtype}}; |
1269 | $subexpr =~ s/ntype/subtype/g; |
1270 | $subexpr =~ s/\$arg/ST(ix_$var)/g; |
1271 | $subexpr =~ s/\n\t/\n\t\t/g; |
93d3b392 |
1272 | $subexpr =~ s/is not of (.*\")/[arg %d] is not of $1, ix_$var + 1/g; |
a0d0e21e |
1273 | $subexpr =~ s/\$var/${var}[ix_$var - $argoff]/; |
2304df62 |
1274 | $expr =~ s/DO_ARRAY_ELEM/$subexpr/; |
1275 | } |
db3b9414 |
1276 | if ($expr =~ m#/\*.*scope.*\*/#i) { # "scope" in C comments |
1277 | $ScopeThisXSUB = 1; |
1278 | } |
2304df62 |
1279 | if (defined($defaults{$var})) { |
1280 | $expr =~ s/(\t+)/$1 /g; |
1281 | $expr =~ s/ /\t/g; |
1282 | eval qq/print "\\t$var;\\n"/; |
1283 | $deferred .= eval qq/"\\n\\tif (items < $num)\\n\\t $var = $defaults{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/; |
db3b9414 |
1284 | } elsif ($ScopeThisXSUB or $expr !~ /^\t\$var =/) { |
2304df62 |
1285 | eval qq/print "\\t$var;\\n"/; |
1286 | $deferred .= eval qq/"\\n$expr;\\n"/; |
1287 | } else { |
1288 | eval qq/print "$expr;\\n"/; |
1289 | } |
93a17b20 |
1290 | } |
1291 | |
1292 | sub generate_output { |
ef50df4b |
1293 | local($type, $num, $var, $do_setmagic) = @_; |
a0d0e21e |
1294 | local($arg) = "ST(" . ($num - ($num != 0)) . ")"; |
2304df62 |
1295 | local($argoff) = $num - 1; |
1296 | local($ntype); |
93a17b20 |
1297 | |
f06db76b |
1298 | $type = TidyType($type) ; |
2304df62 |
1299 | if ($type =~ /^array\(([^,]*),(.*)\)/) { |
1300 | print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1)), XFree((char *)$var);\n"; |
ef50df4b |
1301 | print "\tSvSETMAGIC($arg);\n" if $do_setmagic; |
2304df62 |
1302 | } else { |
f06db76b |
1303 | blurt("Error: '$type' not in typemap"), return |
2304df62 |
1304 | unless defined($type_kind{$type}); |
c2960299 |
1305 | blurt("Error: No OUTPUT definition for type '$type' found"), return |
1306 | unless defined $output_expr{$type_kind{$type}} ; |
2304df62 |
1307 | ($ntype = $type) =~ s/\s*\*/Ptr/g; |
1308 | $ntype =~ s/\(\)//g; |
8e07c86e |
1309 | ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//; |
2304df62 |
1310 | $expr = $output_expr{$type_kind{$type}}; |
1311 | if ($expr =~ /DO_ARRAY_ELEM/) { |
c2960299 |
1312 | blurt("Error: '$subtype' not in typemap"), return |
1313 | unless defined($type_kind{$subtype}); |
1314 | blurt("Error: No OUTPUT definition for type '$subtype' found"), return |
1315 | unless defined $output_expr{$type_kind{$subtype}} ; |
2304df62 |
1316 | $subexpr = $output_expr{$type_kind{$subtype}}; |
1317 | $subexpr =~ s/ntype/subtype/g; |
1318 | $subexpr =~ s/\$arg/ST(ix_$var)/g; |
1319 | $subexpr =~ s/\$var/${var}[ix_$var]/g; |
1320 | $subexpr =~ s/\n\t/\n\t\t/g; |
1321 | $expr =~ s/DO_ARRAY_ELEM\n/$subexpr/; |
a0d0e21e |
1322 | eval "print qq\a$expr\a"; |
ef50df4b |
1323 | print "\t\tSvSETMAGIC(ST(ix_$var));\n" if $do_setmagic; |
2304df62 |
1324 | } |
a0d0e21e |
1325 | elsif ($var eq 'RETVAL') { |
a2baab1c |
1326 | if ($expr =~ /^\t\$arg = new/) { |
1327 | # We expect that $arg has refcnt 1, so we need to |
1328 | # mortalize it. |
a0d0e21e |
1329 | eval "print qq\a$expr\a"; |
2304df62 |
1330 | print "\tsv_2mortal(ST(0));\n"; |
ef50df4b |
1331 | print "\tSvSETMAGIC(ST(0));\n" if $do_setmagic; |
93a17b20 |
1332 | } |
a2baab1c |
1333 | elsif ($expr =~ /^\s*\$arg\s*=/) { |
1334 | # We expect that $arg has refcnt >=1, so we need |
1335 | # to mortalize it. However, the extension may have |
1336 | # returned the built-in perl value, which is |
1337 | # read-only, thus not mortalizable. However, it is |
1338 | # safe to leave it as it is, since it would be |
1339 | # ignored by REFCNT_dec. Builtin values have REFCNT==0. |
1340 | eval "print qq\a$expr\a"; |
1341 | print "\tif (SvREFCNT(ST(0))) sv_2mortal(ST(0));\n"; |
ef50df4b |
1342 | print "\tSvSETMAGIC(ST(0));\n" if $do_setmagic; |
a2baab1c |
1343 | } |
2304df62 |
1344 | else { |
a2baab1c |
1345 | # Just hope that the entry would safely write it |
1346 | # over an already mortalized value. By |
1347 | # coincidence, something like $arg = &sv_undef |
1348 | # works too. |
8990e307 |
1349 | print "\tST(0) = sv_newmortal();\n"; |
a0d0e21e |
1350 | eval "print qq\a$expr\a"; |
ef50df4b |
1351 | # new mortals don't have set magic |
463ee0b2 |
1352 | } |
2304df62 |
1353 | } |
a0d0e21e |
1354 | elsif ($arg =~ /^ST\(\d+\)$/) { |
1355 | eval "print qq\a$expr\a"; |
ef50df4b |
1356 | print "\tSvSETMAGIC($arg);\n" if $do_setmagic; |
a0d0e21e |
1357 | } |
2304df62 |
1358 | } |
93a17b20 |
1359 | } |
1360 | |
1361 | sub map_type { |
e50aee73 |
1362 | my($type) = @_; |
93a17b20 |
1363 | |
8e07c86e |
1364 | $type =~ tr/:/_/; |
1365 | $type =~ s/^array\(([^,]*),(.*)\).*/$1 */s; |
1366 | $type; |
93a17b20 |
1367 | } |
8990e307 |
1368 | |
e50aee73 |
1369 | |
1370 | sub Exit { |
ff0cee69 |
1371 | # If this is VMS, the exit status has meaning to the shell, so we |
1372 | # use a predictable value (SS$_Normal or SS$_Abort) rather than an |
1373 | # arbitrary number. |
1374 | # exit ($Is_VMS ? ($errors ? 44 : 1) : $errors) ; |
1375 | exit ($errors ? 1 : 0); |
e50aee73 |
1376 | } |