projects / p5sagit/p5-mst-13.2.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | history | HEAD
This is my patch patch.1n for perl5.001.
[p5sagit/p5-mst-13.2.git] / lib / ExtUtils / xsubpp
CommitLineData
2304df62 1#!./miniperl
75f92628 2
3=head1 NAME
4
5xsubpp - compiler to convert Perl XS code into C code
6
7=head1 SYNOPSIS
8
8e07c86e 9B<xsubpp> [B<-v>] [B<-C++>] [B<-except>] [B<-s pattern>] [B<-typemap typemap>]... file.xs
75f92628 10
11=head1 DESCRIPTION
12
13I<xsubpp> will compile XS code into C code by embedding the constructs
14necessary to let C functions manipulate Perl values and creates the glue
15necessary to let Perl access those functions. The compiler uses typemaps to
16determine how to map C function parameters and variables to Perl values.
17
18The compiler will search for typemap files called I<typemap>. It will use
19the following search path to find default typemaps, with the rightmost
20typemap taking precedence.
21
22 ../../../typemap:../../typemap:../typemap:typemap
23
24=head1 OPTIONS
25
26=over 5
27
28=item B<-C++>
29
30Adds ``extern "C"'' to the C code.
31
32
33=item B<-except>
34
35Adds exception handling stubs to the C code.
36
37=item B<-typemap typemap>
38
39Indicates that a user-supplied typemap should take precedence over the
40default typemaps. This option may be used multiple times, with the last
41typemap having the highest precedence.
42
8e07c86e 43=item B<-v>
44
45Prints the I<xsubpp> version number to standard output, then exits.
46
75f92628 47=back
48
49=head1 ENVIRONMENT
50
51No environment variables are used.
52
53=head1 AUTHOR
54
55Larry Wall
56
f06db76b 57=head1 MODIFICATION HISTORY
58
8e07c86e 59See the file F<changes.pod>.
e50aee73 60
75f92628 61=head1 SEE ALSO
62
e50aee73 63perl(1), perlapi(1)
75f92628 64
65=cut
93a17b20 66
f06db76b 67# Global Constants
8e07c86e 68$XSUBPP_version = "1.922";
69require 5.001;
f06db76b 70
8e07c86e 71$usage = "Usage: xsubpp [-v] [-C++] [-except] [-s pattern] [-typemap typemap]... file.xs\n";
93a17b20 72
8e07c86e 73$except = "";
74SWITCH: while (@ARGV and $ARGV[0] =~ /^-./) {
93a17b20 75 $flag = shift @ARGV;
e50aee73 76 $flag =~ s/^-// ;
8990e307 77 $spat = shift, next SWITCH if $flag eq 's';
78 $cplusplus = 1, next SWITCH if $flag eq 'C++';
8e07c86e 79 $except = " TRY", next SWITCH if $flag eq 'except';
8990e307 80 push(@tm,shift), next SWITCH if $flag eq 'typemap';
8e07c86e 81 (print "xsubpp version $XSUBPP_version\n"), exit
82 if $flag eq 'v';
93a17b20 83 die $usage;
84}
8990e307 85@ARGV == 1 or die $usage;
e50aee73 86chomp($pwd = `pwd`);
748a9306 87# Check for error message from VMS
88if ($pwd =~ /unrecognized command verb/) { $Is_VMS = 1; $pwd = $ENV{DEFAULT} }
c2960299 89($dir, $filename) = $ARGV[0] =~ m#(.*)/(.*)#
90 or ($dir, $filename) = $ARGV[0] =~ m#(.*[>\]])(.*)#
8990e307 91 or ($dir, $filename) = ('.', $ARGV[0]);
92chdir($dir);
93a17b20 93
f06db76b 94sub TrimWhitespace
95{
96 $_[0] =~ s/^\s+|\s+$//go ;
97}
98
99sub TidyType
100{
101 local ($_) = @_ ;
102
103 # rationalise any '*' by joining them into bunches and removing whitespace
104 s#\s*(\*+)\s*#$1#g;
e50aee73 105 s#(\*+)# $1 #g ;
f06db76b 106
107 # change multiple whitespace into a single space
108 s/\s+/ /g ;
109
110 # trim leading & trailing whitespace
111 TrimWhitespace($_) ;
112
113 $_ ;
114}
115
93a17b20 116$typemap = shift @ARGV;
8990e307 117foreach $typemap (@tm) {
118 die "Can't find $typemap in $pwd\n" unless -r $typemap;
93a17b20 119}
748a9306 120unshift @tm, qw(../../../../lib/ExtUtils/typemap ../../../lib/ExtUtils/typemap
121 ../../lib/ExtUtils/typemap ../../../typemap ../../typemap
122 ../typemap typemap);
8990e307 123foreach $typemap (@tm) {
f06db76b 124 next unless -e $typemap ;
125 # skip directories, binary files etc.
126 warn("Warning: ignoring non-text typemap file '$typemap'\n"), next
127 unless -T $typemap ;
128 open(TYPEMAP, $typemap)
129 or warn ("Warning: could not open typemap file '$typemap': $!\n"), next;
e50aee73 130 $mode = 'Typemap';
c2960299 131 $junk = "" ;
8990e307 132 $current = \$junk;
133 while (<TYPEMAP>) {
e50aee73 134 next if /^\s*#/;
8e07c86e 135 if (/^INPUT\s*$/) { $mode = 'Input'; $current = \$junk; next; }
136 if (/^OUTPUT\s*$/) { $mode = 'Output'; $current = \$junk; next; }
137 if (/^TYPEMAP\s*$/) { $mode = 'Typemap'; $current = \$junk; next; }
e50aee73 138 if ($mode eq 'Typemap') {
139 chomp;
f06db76b 140 my $line = $_ ;
141 TrimWhitespace($_) ;
142 # skip blank lines and comment lines
143 next if /^$/ or /^#/ ;
8e07c86e 144 my($type,$kind) = /^\s*(.*?\S)\s+(\S+)\s*$/ or
145 warn("Warning: File '$typemap' Line $. '$line' TYPEMAP entry needs 2 columns\n"), next;
146 $type_kind{TidyType($type)} = $kind ;
147 }
148 elsif (/^\s/) {
149 $$current .= $_;
463ee0b2 150 }
e50aee73 151 elsif ($mode eq 'Input') {
8e07c86e 152 s/\s+$//;
153 $input_expr{$_} = '';
154 $current = \$input_expr{$_};
93a17b20 155 }
8990e307 156 else {
8e07c86e 157 s/\s+$//;
158 $output_expr{$_} = '';
159 $current = \$output_expr{$_};
93a17b20 160 }
8990e307 161 }
162 close(TYPEMAP);
163}
93a17b20 164
8990e307 165foreach $key (keys %input_expr) {
166 $input_expr{$key} =~ s/\n+$//;
167}
93a17b20 168
8e07c86e 169$END = "!End!\n\n"; # "impossible" keyword (multiple newline)
170
171# Match an XS keyword
172$BLOCK_re= "\\s*(REQUIRE|BOOT|CASE|PREINIT|INPUT|INIT|CODE|PPCODE|OUTPUT|CLEANUP|ALIAS|$END)\\s*:";
173
174# Input: ($_, @line) == unparsed input.
175# Output: ($_, @line) == (rest of line, following lines).
176# Return: the matched keyword if found, otherwise 0
177sub check_keyword {
178 $_ = shift(@line) while !/\S/ && @line;
179 s/^(\s*)($_[0])\s*:\s*(?:#.*)?/$1/s && $2;
180}
181
182
183sub print_section {
184 $_ = shift(@line) while !/\S/ && @line;
185 for (; defined($_) && !/^$BLOCK_re/o; $_ = shift(@line)) {
186 print "$_\n";
187 }
188}
189
190sub CASE_handler {
191 blurt ("Error: `CASE:' after unconditional `CASE:'")
192 if $condnum && $cond eq '';
193 $cond = $_;
194 TrimWhitespace($cond);
195 print " ", ($condnum++ ? " else" : ""), ($cond ? " if ($cond)\n" : "\n");
196 $_ = '' ;
197}
198
199sub INPUT_handler {
200 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
201 last if /^\s*NOT_IMPLEMENTED_YET/;
202 next unless /\S/; # skip blank lines
203
204 TrimWhitespace($_) ;
205 my $line = $_ ;
206
207 # remove trailing semicolon if no initialisation
208 s/\s*;$//g unless /=/ ;
209
210 # check for optional initialisation code
211 my $var_init = '' ;
212 $var_init = $1 if s/\s*(=.*)$//s ;
213 $var_init =~ s/"/\\"/g;
214
215 s/\s+/ /g;
216 my ($var_type, $var_addr, $var_name) = /^(.*?[^& ]) *(\&?) *\b(\w+)$/s
217 or blurt("Error: invalid argument declaration '$line'"), next;
218
219 # Check for duplicate definitions
220 blurt ("Error: duplicate definition of argument '$var_name' ignored"), next
221 if $arg_list{$var_name} ++ ;
222
223 $thisdone |= $var_name eq "THIS";
224 $retvaldone |= $var_name eq "RETVAL";
225 $var_types{$var_name} = $var_type;
226 print "\t" . &map_type($var_type);
227 $var_num = $args_match{$var_name};
228 if ($var_addr) {
229 $var_addr{$var_name} = 1;
230 $func_args =~ s/\b($var_name)\b/&$1/;
231 }
232 if ($var_init =~ /^=\s*NO_INIT\s*;?\s*$/) {
233 print "\t$var_name;\n";
234 } elsif ($var_init =~ /\S/) {
235 &output_init($var_type, $var_num, "$var_name $var_init");
236 } elsif ($var_num) {
237 # generate initialization code
238 &generate_init($var_type, $var_num, $var_name);
239 } else {
240 print ";\n";
241 }
242 }
243}
244
245sub OUTPUT_handler {
246 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
247 next unless /\S/;
248 my ($outarg, $outcode) = /^\s*(\S+)\s*(.*?)\s*$/s ;
249 blurt ("Error: duplicate OUTPUT argument '$outarg' ignored"), next
250 if $outargs{$outarg} ++ ;
251 if (!$gotRETVAL and $outarg eq 'RETVAL') {
252 # deal with RETVAL last
253 $RETVAL_code = $outcode ;
254 $gotRETVAL = 1 ;
255 next ;
256 }
257 blurt ("Error: OUTPUT $outarg not an argument"), next
258 unless defined($args_match{$outarg});
259 blurt("Error: No input definition for OUTPUT argument '$outarg' - ignored"), next
260 unless defined $var_types{$outarg} ;
261 if ($outcode) {
262 print "\t$outcode\n";
263 } else {
264 $var_num = $args_match{$outarg};
265 &generate_output($var_types{$outarg}, $var_num, $outarg);
266 }
267 }
268}
269
270sub GetAliases
271{
272 my ($line) = @_ ;
273 my ($orig) = $line ;
274 my ($alias) ;
275 my ($value) ;
276
277 # Parse alias definitions
278 # format is
279 # alias = value alias = value ...
280
281 while ($line =~ s/^\s*([\w:]+)\s*=\s*(\w+)\s*//) {
282 $alias = $1 ;
283 $orig_alias = $alias ;
284 $value = $2 ;
285
286 # check for optional package definition in the alias
287 $alias = $Packprefix . $alias if $alias !~ /::/ ;
288
289 # check for duplicate alias name & duplicate value
290 Warn("Warning: Ignoring duplicate alias '$orig_alias'")
291 if defined $XsubAliases{$pname}{$alias} ;
292
293 Warn("Warning: Aliases '$orig_alias' and '$XsubAliasValues{$pname}{$value}' have identical values")
294 if $XsubAliasValues{$pname}{$value} ;
295
296 $XsubAliases{$pname}{$alias} = $value ;
297 $XsubAliasValues{$pname}{$value} = $orig_alias ;
298 }
299
300 blurt("Error: Cannot parse ALIAS definitions from '$orig'")
301 if $line ;
302}
303
304sub ALIAS_handler
305{
306 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
307 next unless /\S/;
308 TrimWhitespace($_) ;
309 GetAliases($_) if $_ ;
310 }
311}
312
313sub REQUIRE_handler
314{
315 # the rest of the current line should contain a version number
316 my ($Ver) = $_ ;
317
318 TrimWhitespace($Ver) ;
319
320 death ("Error: REQUIRE expects a version number")
321 unless $Ver ;
322
323 # check that the version number is of the form n.n
324 death ("Error: REQUIRE: expected a number, got '$Ver'")
325 unless $Ver =~ /^\d+(\.\d*)?/ ;
326
327 death ("Error: xsubpp $Ver (or better) required--this is only $XSUBPP_version.")
328 unless $XSUBPP_version >= $Ver ;
329}
330
331sub check_cpp {
332 my @cpp = grep(/^\#\s*(?:if|e\w+)/, @line);
333 if (@cpp) {
334 my ($cpp, $cpplevel);
335 for $cpp (@cpp) {
336 if ($cpp =~ /^\#\s*if/) {
337 $cpplevel++;
338 } elsif (!$cpplevel) {
339 Warn("Warning: #else/elif/endif without #if in this function");
340 return;
341 } elsif ($cpp =~ /^\#\s*endif/) {
342 $cpplevel--;
343 }
344 }
345 Warn("Warning: #if without #endif in this function") if $cpplevel;
346 }
347}
348
349
8990e307 350sub Q {
e50aee73 351 my($text) = @_;
8990e307 352 $text =~ tr/#//d;
2304df62 353 $text =~ s/\[\[/{/g;
354 $text =~ s/\]\]/}/g;
8990e307 355 $text;
93a17b20 356}
357
c2960299 358open(F, $filename) or die "cannot open $filename: $!\n";
359
f06db76b 360# Identify the version of xsubpp used
f06db76b 361print <<EOM ;
e50aee73 362/*
363 * This file was generated automatically by xsubpp version $XSUBPP_version from the
364 * contents of $filename. Don't edit this file, edit $filename instead.
365 *
366 * ANY CHANGES MADE HERE WILL BE LOST!
f06db76b 367 *
368 */
e50aee73 369
f06db76b 370EOM
371
372
93a17b20 373while (<F>) {
e50aee73 374 last if ($Module, $Package, $Prefix) =
375 /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/;
a0d0e21e 376 print $_;
93a17b20 377}
e50aee73 378&Exit unless defined $_;
379
380my $lastline = $_;
381my $lastline_no = $.;
93a17b20 382
e50aee73 383
384# Read next xsub into @line from ($lastline, <F>).
2304df62 385sub fetch_para {
386 # parse paragraph
387 @line = ();
c2960299 388 @line_no = () ;
e50aee73 389 return 0 unless defined $lastline;
390
391 if ($lastline =~
392 /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/) {
393 $Module = $1;
8e07c86e 394 $Package = defined($2) ? $2 : ''; # keep -w happy
395 $Prefix = defined($3) ? $3 : ''; # keep -w happy
e50aee73 396 ($Module_cname = $Module) =~ s/\W/_/g;
8e07c86e 397 ($Packid = $Package) =~ tr/:/_/;
e50aee73 398 $Packprefix = $Package;
8e07c86e 399 $Packprefix .= "::" if $Packprefix ne "";
2304df62 400 $lastline = "";
e50aee73 401 }
402
403 for(;;) {
404 if ($lastline !~ /^\s*#/ ||
8e07c86e 405 $lastline =~ /^#[ \t]*(?:(?:if|ifn?def|else|elif|endif|define|undef|pragma)\b|include\s*["<].*[>"])/) {
e50aee73 406 last if $lastline =~ /^\S/ && @line && $line[-1] eq "";
407 push(@line, $lastline);
408 push(@line_no, $lastline_no) ;
93a17b20 409 }
e50aee73 410
411 # Read next line and continuation lines
412 last unless defined($lastline = <F>);
413 $lastline_no = $.;
414 my $tmp_line;
415 $lastline .= $tmp_line
8e07c86e 416 while ($lastline =~ /\\$/ && defined($tmp_line = <F>));
e50aee73 417
8e07c86e 418 chomp $lastline;
e50aee73 419 $lastline =~ s/^\s+$//;
2304df62 420 }
e50aee73 421 pop(@line), pop(@line_no) while @line && $line[-1] eq "";
e50aee73 422 1;
2304df62 423}
93a17b20 424
c2960299 425PARAGRAPH:
8e07c86e 426while (fetch_para()) {
e50aee73 427 # Print initial preprocessor statements and blank lines
428 print shift(@line), "\n"
429 while @line && $line[0] !~ /^[^\#]/;
430
431 next PARAGRAPH unless @line;
432
433 death ("Code is not inside a function")
434 if $line[0] =~ /^\s/;
435
2304df62 436 # initialize info arrays
437 undef(%args_match);
438 undef(%var_types);
439 undef(%var_addr);
440 undef(%defaults);
441 undef($class);
442 undef($static);
443 undef($elipsis);
f06db76b 444 undef($wantRETVAL) ;
445 undef(%arg_list) ;
2304df62 446
8e07c86e 447 $_ = shift(@line);
448 if (check_keyword("REQUIRE")) {
449 REQUIRE_handler() ;
450 next PARAGRAPH unless @line ;
451 $_ = shift(@line);
452 }
c2960299 453
8e07c86e 454 if (check_keyword("BOOT")) {
455 &check_cpp;
456 push (@BootCode, $_, @line, "") ;
c2960299 457 next PARAGRAPH ;
a0d0e21e 458 }
c2960299 459
8e07c86e 460
461 # extract return type, function name and arguments
462 my($ret_type) = TidyType($_);
463
c2960299 464 # a function definition needs at least 2 lines
465 blurt ("Error: Function definition too short '$ret_type'"), next PARAGRAPH
466 unless @line ;
467
8e07c86e 468 $static = 1 if $ret_type =~ s/^static\s+//;
469
2304df62 470 $func_header = shift(@line);
c2960299 471 blurt ("Error: Cannot parse function definition from '$func_header'"), next PARAGRAPH
8e07c86e 472 unless $func_header =~ /^(?:([\w:]*)::)?(\w+)\s*\(\s*(.*?)\s*\)\s*$/s;
c2960299 473
8e07c86e 474 ($class, $func_name, $orig_args) = ($1, $2, $3) ;
2304df62 475 ($pname = $func_name) =~ s/^($Prefix)?/$Packprefix/;
c2960299 476
477 # Check for duplicate function definition
8e07c86e 478 if (defined $Func_name{"${Packid}_$func_name"} ) {
479 Warn("Warning: duplicate function definition '$func_name' detected")
480 }
481 else {
482 push(@Func_name, "${Packid}_$func_name");
483 push(@Func_pname, $pname);
484 }
c2960299 485 $Func_name{"${Packid}_$func_name"} ++ ;
486
2304df62 487 @args = split(/\s*,\s*/, $orig_args);
a0d0e21e 488 if (defined($class)) {
8e07c86e 489 my $arg0 = (defined($static) ? "CLASS" : "THIS");
490 unshift(@args, $arg0);
491 ($orig_args = "$arg0, $orig_args") =~ s/^$arg0, $/$arg0/;
2304df62 492 }
493 $orig_args =~ s/"/\\"/g;
494 $min_args = $num_args = @args;
495 foreach $i (0..$num_args-1) {
496 if ($args[$i] =~ s/\.\.\.//) {
497 $elipsis = 1;
498 $min_args--;
c2960299 499 if ($args[$i] eq '' && $i == $num_args - 1) {
2304df62 500 pop(@args);
501 last;
502 }
503 }
8e07c86e 504 if ($args[$i] =~ /^([^=]*[^\s=])\s*=\s*(.*)/s) {
2304df62 505 $min_args--;
506 $args[$i] = $1;
507 $defaults{$args[$i]} = $2;
508 $defaults{$args[$i]} =~ s/"/\\"/g;
509 }
510 }
a0d0e21e 511 if (defined($class)) {
2304df62 512 $func_args = join(", ", @args[1..$#args]);
513 } else {
514 $func_args = join(", ", @args);
515 }
516 @args_match{@args} = 1..@args;
517
8e07c86e 518 $PPCODE = grep(/^\s*PPCODE\s*:/, @line);
519 $ALIAS = grep(/^\s*ALIAS\s*:/, @line);
520
2304df62 521 # print function header
a0d0e21e 522 print Q<<"EOF";
523#XS(XS_${Packid}_$func_name)
2304df62 524#[[
a0d0e21e 525# dXSARGS;
93a17b20 526EOF
8e07c86e 527 print Q<<"EOF" if $ALIAS ;
528# dXSI32;
529EOF
2304df62 530 if ($elipsis) {
8e07c86e 531 $cond = ($min_args ? qq(items < $min_args) : 0);
2304df62 532 }
533 elsif ($min_args == $num_args) {
534 $cond = qq(items != $min_args);
535 }
536 else {
537 $cond = qq(items < $min_args || items > $num_args);
538 }
8990e307 539
2304df62 540 print Q<<"EOF" if $except;
541# char errbuf[1024];
542# *errbuf = '\0';
543EOF
544
8e07c86e 545 if ($ALIAS)
546 { print Q<<"EOF" if $cond }
547# if ($cond)
548# croak("Usage: %s($orig_args)", GvNAME(CvGV(cv)));
549EOF
550 else
551 { print Q<<"EOF" if $cond }
552# if ($cond)
8990e307 553# croak("Usage: $pname($orig_args)");
93a17b20 554EOF
555
a0d0e21e 556 print Q<<"EOF" if $PPCODE;
557# SP -= items;
558EOF
559
2304df62 560 # Now do a block of some sort.
93a17b20 561
2304df62 562 $condnum = 0;
8e07c86e 563 $cond = ''; # last CASE: condidional
564 push(@line, "$END:");
565 push(@line_no, $line_no[-1]);
566 $_ = '';
567 &check_cpp;
2304df62 568 while (@line) {
8e07c86e 569 &CASE_handler if check_keyword("CASE");
570 print Q<<"EOF";
571# $except [[
93a17b20 572EOF
573
574 # do initialization of input variables
575 $thisdone = 0;
576 $retvaldone = 0;
463ee0b2 577 $deferred = "";
c2960299 578 %arg_list = () ;
579 $gotRETVAL = 0;
f06db76b 580
8e07c86e 581 &INPUT_handler;
582 my $kwd;
583 while ($kwd = check_keyword("INPUT|PREINIT")) {
584 if ($kwd eq 'PREINIT') { &print_section; } else { &INPUT_handler; }
93a17b20 585 }
a0d0e21e 586 if (!$thisdone && defined($class)) {
587 if (defined($static)) {
588 print "\tchar *";
589 $var_types{"CLASS"} = "char *";
590 &generate_init("char *", 1, "CLASS");
591 }
592 else {
93a17b20 593 print "\t$class *";
594 $var_types{"THIS"} = "$class *";
595 &generate_init("$class *", 1, "THIS");
a0d0e21e 596 }
93a17b20 597 }
598
599 # do code
600 if (/^\s*NOT_IMPLEMENTED_YET/) {
463ee0b2 601 print "\ncroak(\"$pname: not implemented yet\");\n";
93a17b20 602 } else {
603 if ($ret_type ne "void") {
604 print "\t" . &map_type($ret_type) . "\tRETVAL;\n"
605 if !$retvaldone;
606 $args_match{"RETVAL"} = 0;
607 $var_types{"RETVAL"} = $ret_type;
608 }
8e07c86e 609 print $deferred;
610 while ($kwd = check_keyword("INIT|ALIAS")) {
611 if ($kwd eq 'INIT') {
612 &print_section
613 }
614 else {
615 ALIAS_handler
616 }
617 }
618
619 if (check_keyword("PPCODE")) {
620 &print_section;
621 death ("PPCODE must be last thing") if @line;
a0d0e21e 622 print "\tPUTBACK;\n\treturn;\n";
8e07c86e 623 } elsif (check_keyword("CODE")) {
624 &print_section;
a0d0e21e 625 } elsif ($func_name eq "DESTROY") {
a0d0e21e 626 print "\n\t";
8e07c86e 627 print "delete THIS;\n";
93a17b20 628 } else {
629 print "\n\t";
630 if ($ret_type ne "void") {
463ee0b2 631 print "RETVAL = ";
e50aee73 632 $wantRETVAL = 1;
93a17b20 633 }
634 if (defined($static)) {
a0d0e21e 635 if ($func_name =~ /^new/) {
636 $func_name = "$class";
8e07c86e 637 } else {
638 print "${class}::";
a0d0e21e 639 }
93a17b20 640 } elsif (defined($class)) {
641 print "THIS->";
642 }
e50aee73 643 $func_name =~ s/^($spat)//
644 if defined($spat);
93a17b20 645 print "$func_name($func_args);\n";
93a17b20 646 }
647 }
648
649 # do output variables
8e07c86e 650 $gotRETVAL = 0;
651 undef $RETVAL_code ;
652 undef %outargs ;
653 &OUTPUT_handler while check_keyword("OUTPUT");
f06db76b 654
655 # all OUTPUT done, so now push the return value on the stack
8e07c86e 656 if ($gotRETVAL && $RETVAL_code) {
657 print "\t$RETVAL_code\n";
658 } elsif ($gotRETVAL || $wantRETVAL) {
659 &generate_output($ret_type, 0, 'RETVAL');
660 }
f06db76b 661
93a17b20 662 # do cleanup
8e07c86e 663 &print_section while check_keyword("CLEANUP");
664
93a17b20 665 # print function trailer
8e07c86e 666 print Q<<EOF;
2304df62 667# ]]
8e07c86e 668EOF
669 print Q<<EOF if $except;
8990e307 670# BEGHANDLERS
671# CATCHALL
672# sprintf(errbuf, "%s: %s\\tpropagated", Xname, Xreason);
673# ENDHANDLERS
93a17b20 674EOF
8e07c86e 675 if (check_keyword("CASE")) {
676 blurt ("Error: No `CASE:' at top of function")
677 unless $condnum;
678 $_ = "CASE: $_"; # Restore CASE: label
679 next;
8990e307 680 }
8e07c86e 681 last if $_ eq "$END:";
682 death(/^$BLOCK_re/o ? "Misplaced `$1:'" : "Junk at end of function");
2304df62 683 }
a0d0e21e 684
2304df62 685 print Q<<EOF if $except;
686# if (errbuf[0])
687# croak(errbuf);
688EOF
a0d0e21e 689
690 print Q<<EOF unless $PPCODE;
691# XSRETURN(1);
692EOF
693
2304df62 694 print Q<<EOF;
2304df62 695#]]
8990e307 696#
93a17b20 697EOF
698}
699
700# print initialization routine
8990e307 701print qq/extern "C"\n/ if $cplusplus;
702print Q<<"EOF";
a0d0e21e 703#XS(boot_$Module_cname)
2304df62 704#[[
a0d0e21e 705# dXSARGS;
8990e307 706# char* file = __FILE__;
707#
93a17b20 708EOF
709
8e07c86e 710print Q<<"EOF" if defined %XsubAliases ;
711# {
712# CV * cv ;
713#
714EOF
715
93a17b20 716for (@Func_name) {
2304df62 717 $pname = shift(@Func_pname);
8e07c86e 718
719 if ($XsubAliases{$pname}) {
720 $XsubAliases{$pname}{$pname} = 0
721 unless defined $XsubAliases{$pname}{$pname} ;
722 while ( ($name, $value) = each %{$XsubAliases{$pname}}) {
723 print Q<<"EOF" ;
724# cv = newXS(\"$name\", XS_$_, file);
725# XSANY.any_i32 = $value ;
726EOF
727 }
728 }
729 else {
730 print " newXS(\"$pname\", XS_$_, file);\n";
731 }
a0d0e21e 732}
733
8e07c86e 734print Q<<"EOF" if defined %XsubAliases ;
735# }
736EOF
737
a0d0e21e 738if (@BootCode)
739{
8e07c86e 740 print "\n /* Initialisation Section */\n" ;
a0d0e21e 741 print grep (s/$/\n/, @BootCode) ;
8e07c86e 742 print "\n /* End of Initialisation Section */\n\n" ;
93a17b20 743}
a0d0e21e 744
e50aee73 745print Q<<"EOF";;
746# ST(0) = &sv_yes;
747# XSRETURN(1);
748#]]
749EOF
750
751&Exit;
752
93a17b20 753
754sub output_init {
2304df62 755 local($type, $num, $init) = @_;
a0d0e21e 756 local($arg) = "ST(" . ($num - 1) . ")";
93a17b20 757
2304df62 758 eval qq/print " $init\\\n"/;
93a17b20 759}
760
c2960299 761sub Warn
762{
763 # work out the line number
764 my $line_no = $line_no[@line_no - @line -1] ;
765
766 print STDERR "@_ in $filename, line $line_no\n" ;
767}
768
769sub blurt
770{
771 Warn @_ ;
772 $errors ++
773}
774
775sub death
776{
777 Warn @_ ;
778 exit 1 ;
779}
8990e307 780
93a17b20 781sub generate_init {
2304df62 782 local($type, $num, $var) = @_;
a0d0e21e 783 local($arg) = "ST(" . ($num - 1) . ")";
2304df62 784 local($argoff) = $num - 1;
785 local($ntype);
786 local($tk);
93a17b20 787
f06db76b 788 $type = TidyType($type) ;
c2960299 789 blurt("Error: '$type' not in typemap"), return
790 unless defined($type_kind{$type});
791
2304df62 792 ($ntype = $type) =~ s/\s*\*/Ptr/g;
8e07c86e 793 ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;
2304df62 794 $tk = $type_kind{$type};
795 $tk =~ s/OBJ$/REF/ if $func_name =~ /DESTROY$/;
8e07c86e 796 $type =~ tr/:/_/;
c2960299 797 blurt("Error: No INPUT definition for type '$type' found"), return
798 unless defined $input_expr{$tk} ;
2304df62 799 $expr = $input_expr{$tk};
800 if ($expr =~ /DO_ARRAY_ELEM/) {
c2960299 801 blurt("Error: '$subtype' not in typemap"), return
802 unless defined($type_kind{$subtype});
803 blurt("Error: No INPUT definition for type '$subtype' found"), return
804 unless defined $input_expr{$type_kind{$subtype}} ;
2304df62 805 $subexpr = $input_expr{$type_kind{$subtype}};
806 $subexpr =~ s/ntype/subtype/g;
807 $subexpr =~ s/\$arg/ST(ix_$var)/g;
808 $subexpr =~ s/\n\t/\n\t\t/g;
809 $subexpr =~ s/is not of (.*")/[arg %d] is not of $1, ix_$var + 1/g;
a0d0e21e 810 $subexpr =~ s/\$var/${var}[ix_$var - $argoff]/;
2304df62 811 $expr =~ s/DO_ARRAY_ELEM/$subexpr/;
812 }
813 if (defined($defaults{$var})) {
814 $expr =~ s/(\t+)/$1 /g;
815 $expr =~ s/ /\t/g;
816 eval qq/print "\\t$var;\\n"/;
817 $deferred .= eval qq/"\\n\\tif (items < $num)\\n\\t $var = $defaults{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/;
818 } elsif ($expr !~ /^\t\$var =/) {
819 eval qq/print "\\t$var;\\n"/;
820 $deferred .= eval qq/"\\n$expr;\\n"/;
821 } else {
822 eval qq/print "$expr;\\n"/;
823 }
93a17b20 824}
825
826sub generate_output {
2304df62 827 local($type, $num, $var) = @_;
a0d0e21e 828 local($arg) = "ST(" . ($num - ($num != 0)) . ")";
2304df62 829 local($argoff) = $num - 1;
830 local($ntype);
93a17b20 831
f06db76b 832 $type = TidyType($type) ;
2304df62 833 if ($type =~ /^array\(([^,]*),(.*)\)/) {
834 print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1)), XFree((char *)$var);\n";
835 } else {
f06db76b 836 blurt("Error: '$type' not in typemap"), return
2304df62 837 unless defined($type_kind{$type});
c2960299 838 blurt("Error: No OUTPUT definition for type '$type' found"), return
839 unless defined $output_expr{$type_kind{$type}} ;
2304df62 840 ($ntype = $type) =~ s/\s*\*/Ptr/g;
841 $ntype =~ s/\(\)//g;
8e07c86e 842 ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;
2304df62 843 $expr = $output_expr{$type_kind{$type}};
844 if ($expr =~ /DO_ARRAY_ELEM/) {
c2960299 845 blurt("Error: '$subtype' not in typemap"), return
846 unless defined($type_kind{$subtype});
847 blurt("Error: No OUTPUT definition for type '$subtype' found"), return
848 unless defined $output_expr{$type_kind{$subtype}} ;
2304df62 849 $subexpr = $output_expr{$type_kind{$subtype}};
850 $subexpr =~ s/ntype/subtype/g;
851 $subexpr =~ s/\$arg/ST(ix_$var)/g;
852 $subexpr =~ s/\$var/${var}[ix_$var]/g;
853 $subexpr =~ s/\n\t/\n\t\t/g;
854 $expr =~ s/DO_ARRAY_ELEM\n/$subexpr/;
a0d0e21e 855 eval "print qq\a$expr\a";
2304df62 856 }
a0d0e21e 857 elsif ($var eq 'RETVAL') {
2304df62 858 if ($expr =~ /^\t\$arg = /) {
a0d0e21e 859 eval "print qq\a$expr\a";
2304df62 860 print "\tsv_2mortal(ST(0));\n";
93a17b20 861 }
2304df62 862 else {
8990e307 863 print "\tST(0) = sv_newmortal();\n";
a0d0e21e 864 eval "print qq\a$expr\a";
463ee0b2 865 }
2304df62 866 }
a0d0e21e 867 elsif ($arg =~ /^ST\(\d+\)$/) {
868 eval "print qq\a$expr\a";
869 }
2304df62 870 }
93a17b20 871}
872
873sub map_type {
e50aee73 874 my($type) = @_;
93a17b20 875
8e07c86e 876 $type =~ tr/:/_/;
877 $type =~ s/^array\(([^,]*),(.*)\).*/$1 */s;
878 $type;
93a17b20 879}
8990e307 880
e50aee73 881
882sub Exit {
748a9306 883# If this is VMS, the exit status has meaning to the shell, so we
884# use a predictable value (SS$_Abort) rather than an arbitrary
885# number.
e50aee73 886 exit ($Is_VMS ? 44 : $errors) ;
887}
Unnamed repository; edit this file to name it for gitweb.