X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FExtUtils%2Fxsubpp;h=98bb7397f66f4150a129f24e025f3ef9ee6840f0;hb=8c7f0036c6170bb0e341d84874bdb51f472a6afb;hp=378e4811ac8554e46ff4732d637fc4690eeefff9;hpb=cfc02341d853e4bc320d3abf8ac8ac1c7c3ecaa5;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/ExtUtils/xsubpp b/lib/ExtUtils/xsubpp index 378e481..98bb739 100755 --- a/lib/ExtUtils/xsubpp +++ b/lib/ExtUtils/xsubpp @@ -6,10 +6,12 @@ xsubpp - compiler to convert Perl XS code into C code =head1 SYNOPSIS -B [B<-v>] [B<-C++>] [B<-except>] [B<-s pattern>] [B<-prototypes>] [B<-noversioncheck>] [B<-nolinenumbers>] [B<-typemap typemap>] [B<-object_capi>]... file.xs +B [B<-v>] [B<-C++>] [B<-except>] [B<-s pattern>] [B<-prototypes>] [B<-noversioncheck>] [B<-nolinenumbers>] [B<-nooptimize>] [B<-typemap typemap>] ... file.xs =head1 DESCRIPTION +This compiler is typically run by the makefiles created by L. + I will compile XS code into C code by embedding the constructs necessary to let C functions manipulate Perl values and creates the glue necessary to let Perl access those functions. The compiler uses typemaps to @@ -23,13 +25,15 @@ typemap taking precedence. =head1 OPTIONS +Note that the C MakeMaker option may be used to add these options to +any makefiles generated by MakeMaker. + =over 5 =item B<-C++> Adds ``extern "C"'' to the C code. - =item B<-except> Adds exception handling stubs to the C code. @@ -59,11 +63,22 @@ number. Prevents the inclusion of `#line' directives in the output. -=item B<-object_capi> +=item B<-nooptimize> + +Disables certain optimizations. The only optimization that is currently +affected is the use of Is by the output C code (see L). +This may significantly slow down the generated code, but this is the way +B of 5.005 and earlier operated. + +=item B<-noinout> + +Disable recognition of C, C and C declarations. + +=item B<-noargtypes> -Compile code as C in a PERL_OBJECT environment. +Disable recognition of ANSI-like descriptions of function signature. -back +=back =head1 ENVIRONMENT @@ -86,6 +101,7 @@ perl(1), perlxs(1), perlxstut(1) require 5.002; use Cwd; use vars '$cplusplus'; +use vars '%v'; use Config; @@ -93,7 +109,7 @@ sub Q ; # Global Constants -$XSUBPP_version = "1.9507"; +$XSUBPP_version = "1.9508"; my ($Is_VMS, $SymSet); if ($^O eq 'VMS') { @@ -106,17 +122,20 @@ if ($^O eq 'VMS') { $FH = 'File0000' ; -$usage = "Usage: xsubpp [-v] [-C++] [-except] [-prototypes] [-noversioncheck] [-nolinenumbers] [-s pattern] [-typemap typemap]... file.xs\n"; +$usage = "Usage: xsubpp [-v] [-C++] [-except] [-prototypes] [-noversioncheck] [-nolinenumbers] [-nooptimize] [-noinout] [-noargtypes] [-s pattern] [-typemap typemap]... file.xs\n"; -$proto_re = "[" . quotemeta('\$%&*@;') . "]" ; -# mjn -$OBJ = 1 if $Config{'ccflags'} =~ /PERL_OBJECT/i; +$proto_re = "[" . quotemeta('\$%&*@;[]') . "]" ; $except = ""; $WantPrototypes = -1 ; $WantVersionChk = 1 ; $ProtoUsed = 0 ; $WantLineNumbers = 1 ; +$WantOptimize = 1 ; + +my $process_inout = 1; +my $process_argtypes = 1; + SWITCH: while (@ARGV and $ARGV[0] =~ /^-./) { $flag = shift @ARGV; $flag =~ s/^-// ; @@ -126,12 +145,19 @@ SWITCH: while (@ARGV and $ARGV[0] =~ /^-./) { $WantPrototypes = 1, next SWITCH if $flag eq 'prototypes'; $WantVersionChk = 0, next SWITCH if $flag eq 'noversioncheck'; $WantVersionChk = 1, next SWITCH if $flag eq 'versioncheck'; - $WantCAPI = 1, next SWITCH if $flag eq 'object_capi'; + # XXX left this in for compat + next SWITCH if $flag eq 'object_capi'; $except = " TRY", next SWITCH if $flag eq 'except'; push(@tm,shift), next SWITCH if $flag eq 'typemap'; $WantLineNumbers = 0, next SWITCH if $flag eq 'nolinenumbers'; $WantLineNumbers = 1, next SWITCH if $flag eq 'linenumbers'; - (print "xsubpp version $XSUBPP_version\n"), exit + $WantOptimize = 0, next SWITCH if $flag eq 'nooptimize'; + $WantOptimize = 1, next SWITCH if $flag eq 'optimize'; + $process_inout = 0, next SWITCH if $flag eq 'noinout'; + $process_inout = 1, next SWITCH if $flag eq 'inout'; + $process_argtypes = 0, next SWITCH if $flag eq 'noargtypes'; + $process_argtypes = 1, next SWITCH if $flag eq 'argtypes'; + (print "xsubpp version $XSUBPP_version\n"), exit if $flag eq 'v'; die $usage; } @@ -185,7 +211,7 @@ unshift @tm, qw(../../../../lib/ExtUtils/typemap ../../../lib/ExtUtils/typemap ../../lib/ExtUtils/typemap ../../../typemap ../../typemap ../typemap typemap); foreach $typemap (@tm) { - next unless -e $typemap ; + next unless -f $typemap ; # skip directories, binary files etc. warn("Warning: ignoring non-text typemap file '$typemap'\n"), next unless -T $typemap ; @@ -237,13 +263,31 @@ foreach $key (keys %input_expr) { $input_expr{$key} =~ s/\n+$//; } +$bal = qr[(?:(?>[^()]+)|\((??{ $bal })\))*]; # ()-balanced +$cast = qr[(?:\(\s*SV\s*\*\s*\)\s*)?]; # Optional (SV*) cast +$size = qr[,\s* (??{ $bal }) ]x; # Third arg (to setpvn) + +foreach $key (keys %output_expr) { + use re 'eval'; + + my ($t, $with_size, $arg, $sarg) = + ($output_expr{$key} =~ + m[^ \s+ sv_set ( [iunp] ) v (n)? # Type, is_setpvn + \s* \( \s* $cast \$arg \s* , + \s* ( (??{ $bal }) ) # Set from + ( (??{ $size }) )? # Possible sizeof set-from + \) \s* ; \s* $ + ]x); + $targetable{$key} = [$t, $with_size, $arg, $sarg] if $t; +} + $END = "!End!\n\n"; # "impossible" keyword (multiple newline) # Match an XS keyword $BLOCK_re= '\s*(' . join('|', qw( REQUIRE BOOT CASE PREINIT INPUT INIT CODE PPCODE OUTPUT - CLEANUP ALIAS PROTOTYPES PROTOTYPE VERSIONCHECK INCLUDE - SCOPE INTERFACE INTERFACE_MACRO C_ARGS + CLEANUP ALIAS ATTRS PROTOTYPES PROTOTYPE VERSIONCHECK INCLUDE + SCOPE INTERFACE INTERFACE_MACRO C_ARGS POSTCALL )) . "|$END)\\s*:"; # Input: ($_, @line) == unparsed input. @@ -254,6 +298,19 @@ sub check_keyword { s/^(\s*)($_[0])\s*:\s*(?:#.*)?/$1/s && $2; } +my ($C_group_rex, $C_arg); +# Group in C (no support for comments or literals) +$C_group_rex = qr/ [({\[] + (?: (?> [^()\[\]{}]+ ) | (??{ $C_group_rex }) )* + [)}\]] /x ; +# Chunk in C without comma at toplevel (no comments): +$C_arg = qr/ (?: (?> [^()\[\]{},"']+ ) + | (??{ $C_group_rex }) + | " (?: (?> [^\\"]+ ) + | \\. + )* " # String literal + | ' (?: (?> [^\\']+ ) | \\. )* ' # Char literal + )* /xs; if ($WantLineNumbers) { { @@ -351,40 +408,54 @@ sub INPUT_handler { my $line = $_ ; # remove trailing semicolon if no initialisation - s/\s*;$//g unless /=/ ; + s/\s*;$//g unless /[=;+].*\S/ ; # check for optional initialisation code my $var_init = '' ; - $var_init = $1 if s/\s*(=.*)$//s ; + $var_init = $1 if s/\s*([=;+].*)$//s ; $var_init =~ s/"/\\"/g; s/\s+/ /g; - my ($var_type, $var_addr, $var_name) = /^(.*?[^& ]) *(\&?) *\b(\w+)$/s + my ($var_type, $var_addr, $var_name) = /^(.*?[^&\s])\s*(\&?)\s*\b(\w+)$/s or blurt("Error: invalid argument declaration '$line'"), next; # Check for duplicate definitions blurt ("Error: duplicate definition of argument '$var_name' ignored"), next - if $arg_list{$var_name} ++ ; + if $arg_list{$var_name}++ + or defined $arg_types{$var_name} and not $processing_arg_with_types; $thisdone |= $var_name eq "THIS"; $retvaldone |= $var_name eq "RETVAL"; $var_types{$var_name} = $var_type; - print "\t" . &map_type($var_type); + # XXXX This check is a safeguard against the unfinished conversion of + # generate_init(). When generate_init() is fixed, + # one can use 2-args map_type() unconditionally. + if ($var_type =~ / \( \s* \* \s* \) /x) { + # Function pointers are not yet supported with &output_init! + print "\t" . &map_type($var_type, $var_name); + $name_printed = 1; + } else { + print "\t" . &map_type($var_type); + $name_printed = 0; + } $var_num = $args_match{$var_name}; $proto_arg[$var_num] = ProtoString($var_type) if $var_num ; - if ($var_addr) { - $var_addr{$var_name} = 1; - $func_args =~ s/\b($var_name)\b/&$1/; - } - if ($var_init =~ /^=\s*NO_INIT\s*;?\s*$/) { + $func_args =~ s/\b($var_name)\b/&$1/ if $var_addr; + if ($var_init =~ /^[=;]\s*NO_INIT\s*;?\s*$/ + or $in_out{$var_name} and $in_out{$var_name} =~ /^OUT/ + and $var_init !~ /\S/) { + if ($name_printed) { + print ";\n"; + } else { print "\t$var_name;\n"; + } } elsif ($var_init =~ /\S/) { - &output_init($var_type, $var_num, "$var_name $var_init"); + &output_init($var_type, $var_num, $var_name, $var_init, $name_printed); } elsif ($var_num) { # generate initialization code - &generate_init($var_type, $var_num, $var_name); + &generate_init($var_type, $var_num, $var_name, $name_printed); } else { print ";\n"; } @@ -418,6 +489,8 @@ sub OUTPUT_handler { } else { &generate_output($var_types{$outarg}, $var_num, $outarg, $DoSetMagic); } + delete $in_out{$outarg} # No need to auto-OUTPUT + if exists $in_out{$outarg} and $in_out{$outarg} =~ /OUT$/; } } @@ -459,6 +532,7 @@ EOF sub CLEANUP_handler() { print_section() } sub PREINIT_handler() { print_section() } +sub POSTCALL_handler() { print_section() } sub INIT_handler() { print_section() } sub GetAliases @@ -496,6 +570,15 @@ sub GetAliases if $line ; } +sub ATTRS_handler () +{ + for (; !/^$BLOCK_re/o; $_ = shift(@line)) { + next unless /\S/; + TrimWhitespace($_) ; + push @Attributes, $_; + } +} + sub ALIAS_handler () { for (; !/^$BLOCK_re/o; $_ = shift(@line)) { @@ -770,13 +853,28 @@ EOM print("#line 1 \"$filename\"\n") if $WantLineNumbers; +firstmodule: while (<$FH>) { + if (/^=/) { + my $podstartline = $.; + do { + if (/^=cut\s*$/) { + print("/* Skipped embedded POD. */\n"); + printf("#line %d \"$filename\"\n", $. + 1) + if $WantLineNumbers; + next firstmodule + } + + } while (<$FH>); + # At this point $. is at end of file so die won't state the start + # of the problem, and as we haven't yet read any lines &death won't + # show the correct line in the message either. + die ("Error: Unterminated pod in $filename, line $podstartline\n") + unless $lastline; + } last if ($Module, $Package, $Prefix) = /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/; - if ($OBJ) { - s/#if(?:def|\s+defined)\s+(\(__cplusplus\)|__cplusplus)/#if defined(__cplusplus) && !defined(PERL_OBJECT)/; - } print $_; } &Exit unless defined $_; @@ -809,6 +907,16 @@ sub fetch_para { } for(;;) { + # Skip embedded PODs + while ($lastline =~ /^=/) { + while ($lastline = <$FH>) { + last if ($lastline =~ /^=cut\s*$/); + } + death ("Error: Unterminated pod") unless $lastline; + $lastline = <$FH>; + chomp $lastline; + $lastline =~ s/^\s+$//; + } if ($lastline !~ /^\s*#/ || # CPP directives: # ANSI: if ifdef ifndef elif else endif define undef @@ -828,7 +936,7 @@ sub fetch_para { my $tmp_line; $lastline .= $tmp_line while ($lastline =~ /\\$/ && defined($tmp_line = <$FH>)); - + chomp $lastline; $lastline =~ s/^\s+$//; } @@ -883,27 +991,34 @@ while (fetch_para()) { death ("Code is not inside a function" ." (maybe last function was ended by a blank line " - ." followed by a a statement on column one?)") + ." followed by a statement on column one?)") if $line[0] =~ /^\s/; # initialize info arrays undef(%args_match); undef(%var_types); - undef(%var_addr); undef(%defaults); undef($class); undef($static); undef($elipsis); undef($wantRETVAL) ; + undef($RETVAL_no_return) ; undef(%arg_list) ; undef(@proto_arg) ; + undef(@arg_with_types) ; + undef($processing_arg_with_types) ; + undef(%arg_types) ; + undef(@outlist) ; + undef(%in_out) ; undef($proto_in_this_xsub) ; undef($scope_in_this_xsub) ; undef($interface); + undef($prepush_done); $interface_macro = 'XSINTERFACE_FUNC' ; $interface_macro_set = 'XSINTERFACE_FUNC_SET' ; $ProtoThisXSUB = $WantPrototypes ; $ScopeThisXSUB = 0; + $xsreturn = 0; $_ = shift(@line); while ($kwd = check_keyword("REQUIRE|PROTOTYPES|VERSIONCHECK|INCLUDE")) { @@ -923,6 +1038,12 @@ while (fetch_para()) { # extract return type, function name and arguments ($ret_type) = TidyType($_); + $RETVAL_no_return = 1 if $ret_type =~ s/^NO_OUTPUT\s+//; + + # Allow one-line ANSI-like declaration + unshift @line, $2 + if $process_argtypes + and $ret_type =~ s/^(.*?\w.*?)\s*\b(\w+\s*\(.*)/$1/s; # a function definition needs at least 2 lines blurt ("Error: Function definition too short '$ret_type'"), next PARAGRAPH @@ -932,9 +1053,10 @@ while (fetch_para()) { $func_header = shift(@line); blurt ("Error: Cannot parse function definition from '$func_header'"), next PARAGRAPH - unless $func_header =~ /^(?:([\w:]*)::)?(\w+)\s*\(\s*(.*?)\s*\)\s*$/s; + unless $func_header =~ /^(?:([\w:]*)::)?(\w+)\s*\(\s*(.*?)\s*\)\s*(const)?\s*(;\s*)?$/s; ($class, $func_name, $orig_args) = ($1, $2, $3) ; + $class = "$4 $class" if $4; ($pname = $func_name) =~ s/^($Prefix)?/$Packprefix/; ($clean_func_name = $func_name) =~ s/^$Prefix//; $Full_func_name = "${Packid}_$clean_func_name"; @@ -947,41 +1069,101 @@ while (fetch_para()) { last; } $XSStack[$XSS_work_idx]{functions}{$Full_func_name} ++ ; - %XsubAliases = %XsubAliasValues = %Interfaces = (); + %XsubAliases = %XsubAliasValues = %Interfaces = @Attributes = (); $DoSetMagic = 1; - @args = split(/\s*,\s*/, $orig_args); + $orig_args =~ s/\\\s*/ /g; # process line continuations + + my %only_outlist; + if ($process_argtypes and $orig_args =~ /\S/) { + my $args = "$orig_args ,"; + if ($args =~ /^( (??{ $C_arg }) , )* $ /x) { + @args = ($args =~ /\G ( (??{ $C_arg }) ) , /xg); + for ( @args ) { + s/^\s+//; + s/\s+$//; + my $arg = $_; + my $default; + ($arg, $default) = / ( [^=]* ) ( (?: = .* )? ) /x; + my ($pre, $name) = ($arg =~ /(.*?) \s* \b(\w+) \s* $ /x); + next unless length $pre; + my $out_type; + my $inout_var; + if ($process_inout and s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\s+//) { + my $type = $1; + $out_type = $type if $type ne 'IN'; + $arg =~ s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\s+//; + } + if (/\W/) { # Has a type + push @arg_with_types, $arg; + # warn "pushing '$arg'\n"; + $arg_types{$name} = $arg; + $_ = "$name$default"; + } + $only_outlist{$_} = 1 if $out_type eq "OUTLIST"; + push @outlist, $name if $out_type =~ /OUTLIST$/; + $in_out{$name} = $out_type if $out_type; + } + } else { + @args = split(/\s*,\s*/, $orig_args); + Warn("Warning: cannot parse argument list '$orig_args', fallback to split"); + } + } else { + @args = split(/\s*,\s*/, $orig_args); + for (@args) { + if ($process_inout and s/^(IN|IN_OUTLIST|OUTLIST|IN_OUT|OUT)\s+//) { + my $out_type = $1; + next if $out_type eq 'IN'; + $only_outlist{$_} = 1 if $out_type eq "OUTLIST"; + push @outlist, $name if $out_type =~ /OUTLIST$/; + $in_out{$_} = $out_type; + } + } + } if (defined($class)) { my $arg0 = ((defined($static) or $func_name eq 'new') ? "CLASS" : "THIS"); unshift(@args, $arg0); - ($orig_args = "$arg0, $orig_args") =~ s/^$arg0, $/$arg0/; + ($report_args = "$arg0, $report_args") =~ s/^\w+, $/$arg0/; } - $orig_args =~ s/"/\\"/g; - $min_args = $num_args = @args; - foreach $i (0..$num_args-1) { + my $extra_args = 0; + @args_num = (); + $num_args = 0; + my $report_args = ''; + foreach $i (0 .. $#args) { if ($args[$i] =~ s/\.\.\.//) { $elipsis = 1; - $min_args--; - if ($args[$i] eq '' && $i == $num_args - 1) { + if ($args[$i] eq '' && $i == $#args) { + $report_args .= ", ..."; pop(@args); last; } } + if ($only_outlist{$args[$i]}) { + push @args_num, undef; + } else { + push @args_num, ++$num_args; + $report_args .= ", $args[$i]"; + } if ($args[$i] =~ /^([^=]*[^\s=])\s*=\s*(.*)/s) { - $min_args--; + $extra_args++; $args[$i] = $1; $defaults{$args[$i]} = $2; $defaults{$args[$i]} =~ s/"/\\"/g; } $proto_arg[$i+1] = "\$" ; } - if (defined($class)) { - $func_args = join(", ", @args[1..$#args]); - } else { - $func_args = join(", ", @args); + $min_args = $num_args - $extra_args; + $report_args =~ s/"/\\"/g; + $report_args =~ s/^,\s+//; + my @func_args = @args; + shift @func_args if defined($class); + + for (@func_args) { + s/^/&/ if $in_out{$_}; } - @args_match{@args} = 1..@args; + $func_args = join(", ", @func_args); + @args_match{@args} = @args_num; $PPCODE = grep(/^\s*PPCODE\s*:/, @line); $CODE = grep(/^\s*CODE\s*:/, @line); @@ -992,8 +1174,11 @@ while (fetch_para()) { $ALIAS = grep(/^\s*ALIAS\s*:/, @line); $INTERFACE = grep(/^\s*INTERFACE\s*:/, @line); + $xsreturn = 1 if $EXPLICIT_RETURN; + # print function header print Q<<"EOF"; +#XS(XS_${Full_func_name}); /* prototype to pass -Wmissing-prototypes */ #XS(XS_${Full_func_name}) #[[ # dXSARGS; @@ -1022,12 +1207,21 @@ EOF if ($ALIAS) { print Q<<"EOF" if $cond } # if ($cond) -# croak("Usage: %s($orig_args)", GvNAME(CvGV(cv))); +# Perl_croak(aTHX_ "Usage: %s($report_args)", GvNAME(CvGV(cv))); EOF else { print Q<<"EOF" if $cond } # if ($cond) -# croak("Usage: $pname($orig_args)"); +# Perl_croak(aTHX_ "Usage: $pname($report_args)"); +EOF + + #gcc -Wall: if an xsub has no arguments and PPCODE is used + #it is likely none of ST, XSRETURN or XSprePUSH macros are used + #hence `ax' (setup by dXSARGS) is unused + #XXX: could breakup the dXSARGS; into dSP;dMARK;dITEMS + #but such a move could break third-party extensions + print Q<<"EOF" if $PPCODE and $num_args == 0; +# PERL_UNUSED_VAR(ax); /* -Wall */ EOF print Q<<"EOF" if $PPCODE; @@ -1056,7 +1250,7 @@ EOF $gotRETVAL = 0; INPUT_handler() ; - process_keyword("INPUT|PREINIT|INTERFACE_MACRO|C_ARGS|ALIAS|PROTOTYPE|SCOPE") ; + process_keyword("INPUT|PREINIT|INTERFACE_MACRO|C_ARGS|ALIAS|ATTRS|PROTOTYPE|SCOPE") ; print Q<<"EOF" if $ScopeThisXSUB; # ENTER; @@ -1078,19 +1272,27 @@ EOF # do code if (/^\s*NOT_IMPLEMENTED_YET/) { - print "\n\tcroak(\"$pname: not implemented yet\");\n"; + print "\n\tPerl_croak(aTHX_ \"$pname: not implemented yet\");\n"; $_ = '' ; } else { if ($ret_type ne "void") { - print "\t" . &map_type($ret_type) . "\tRETVAL;\n" + print "\t" . &map_type($ret_type, 'RETVAL') . ";\n" if !$retvaldone; $args_match{"RETVAL"} = 0; $var_types{"RETVAL"} = $ret_type; + print "\tdXSTARG;\n" + if $WantOptimize and $targetable{$type_kind{$ret_type}}; } + if (@arg_with_types) { + unshift @line, @arg_with_types, $_; + $_ = ""; + $processing_arg_with_types = 1; + INPUT_handler() ; + } print $deferred; - process_keyword("INIT|ALIAS|PROTOTYPE|INTERFACE_MACRO|INTERFACE|C_ARGS") ; + process_keyword("INIT|ALIAS|ATTRS|PROTOTYPE|INTERFACE_MACRO|INTERFACE|C_ARGS") ; if (check_keyword("PPCODE")) { print_section(); @@ -1129,21 +1331,60 @@ EOF } # do output variables - $gotRETVAL = 0; - undef $RETVAL_code ; + $gotRETVAL = 0; # 1 if RETVAL seen in OUTPUT section; + undef $RETVAL_code ; # code to set RETVAL (from OUTPUT section); + # $wantRETVAL set if 'RETVAL =' autogenerated + ($wantRETVAL, $ret_type) = (0, 'void') if $RETVAL_no_return; undef %outargs ; - process_keyword("OUTPUT|ALIAS|PROTOTYPE"); + process_keyword("POSTCALL|OUTPUT|ALIAS|ATTRS|PROTOTYPE"); + + &generate_output($var_types{$_}, $args_match{$_}, $_, $DoSetMagic) + for grep $in_out{$_} =~ /OUT$/, keys %in_out; # all OUTPUT done, so now push the return value on the stack if ($gotRETVAL && $RETVAL_code) { print "\t$RETVAL_code\n"; } elsif ($gotRETVAL || $wantRETVAL) { - # RETVAL almost never needs SvSETMAGIC() - &generate_output($ret_type, 0, 'RETVAL', 0); + my $t = $WantOptimize && $targetable{$type_kind{$ret_type}}; + my $var = 'RETVAL'; + my $type = $ret_type; + + # 0: type, 1: with_size, 2: how, 3: how_size + if ($t and not $t->[1] and $t->[0] eq 'p') { + # PUSHp corresponds to setpvn. Treate setpv directly + my $what = eval qq("$t->[2]"); + warn $@ if $@; + + print "\tsv_setpv(TARG, $what); XSprePUSH; PUSHTARG;\n"; + $prepush_done = 1; + } + elsif ($t) { + my $what = eval qq("$t->[2]"); + warn $@ if $@; + + my $size = $t->[3]; + $size = '' unless defined $size; + $size = eval qq("$size"); + warn $@ if $@; + print "\tXSprePUSH; PUSH$t->[0]($what$size);\n"; + $prepush_done = 1; + } + else { + # RETVAL almost never needs SvSETMAGIC() + &generate_output($ret_type, 0, 'RETVAL', 0); + } } + $xsreturn = 1 if $ret_type ne "void"; + my $num = $xsreturn; + my $c = @outlist; + print "\tXSprePUSH;" if $c and not $prepush_done; + print "\tEXTEND(SP,$c);\n" if $c; + $xsreturn += $c; + generate_output($var_types{$_}, $num++, $_, 0, 1) for @outlist; + # do cleanup - process_keyword("CLEANUP|ALIAS|PROTOTYPE") ; + process_keyword("CLEANUP|ALIAS|ATTRS|PROTOTYPE") ; print Q<<"EOF" if $ScopeThisXSUB; # ]] @@ -1174,12 +1415,12 @@ EOF print Q<= $num) {\\n$expr;\\n\\t}\\n"/; + } else { + $deferred .= eval qq/"\\n\\tif (items < $num)\\n\\t $var = $defaults{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/; + } + warn $@ if $@; } elsif ($ScopeThisXSUB or $expr !~ /^\t\$var =/) { - eval qq/print "\\t$var;\\n"/; + if ($name_printed) { + print ";\n"; + } else { + eval qq/print "\\t$var;\\n"/; + warn $@ if $@; + } $deferred .= eval qq/"\\n$expr;\\n"/; + warn $@ if $@; } else { + die "panic: do not know how to handle this branch for function pointers" + if $name_printed; eval qq/print "$expr;\\n"/; + warn $@ if $@; } } sub generate_output { - local($type, $num, $var, $do_setmagic) = @_; + local($type, $num, $var, $do_setmagic, $do_push) = @_; local($arg) = "ST(" . ($num - ($num != 0)) . ")"; local($argoff) = $num - 1; local($ntype); $type = TidyType($type) ; if ($type =~ /^array\(([^,]*),(.*)\)/) { - print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1)), XFree((char *)$var);\n"; + print "\t$arg = sv_newmortal();\n"; + print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1));\n"; print "\tSvSETMAGIC($arg);\n" if $do_setmagic; } else { blurt("Error: '$type' not in typemap"), return unless defined($type_kind{$type}); - blurt("Error: No OUTPUT definition for type '$type' found"), return + blurt("Error: No OUTPUT definition for type '$type', typekind '$type_kind{$type}' found"), return unless defined $output_expr{$type_kind{$type}} ; ($ntype = $type) =~ s/\s*\*/Ptr/g; $ntype =~ s/\(\)//g; @@ -1428,7 +1697,7 @@ sub generate_output { if ($expr =~ /DO_ARRAY_ELEM/) { blurt("Error: '$subtype' not in typemap"), return unless defined($type_kind{$subtype}); - blurt("Error: No OUTPUT definition for type '$subtype' found"), return + blurt("Error: No OUTPUT definition for type '$subtype', typekind '$type_kind{$subtype}' found"), return unless defined $output_expr{$type_kind{$subtype}} ; $subexpr = $output_expr{$type_kind{$subtype}}; $subexpr =~ s/ntype/subtype/g; @@ -1437,6 +1706,7 @@ sub generate_output { $subexpr =~ s/\n\t/\n\t\t/g; $expr =~ s/DO_ARRAY_ELEM\n/$subexpr/; eval "print qq\a$expr\a"; + warn $@ if $@; print "\t\tSvSETMAGIC(ST(ix_$var));\n" if $do_setmagic; } elsif ($var eq 'RETVAL') { @@ -1444,18 +1714,16 @@ sub generate_output { # We expect that $arg has refcnt 1, so we need to # mortalize it. eval "print qq\a$expr\a"; - print "\tsv_2mortal(ST(0));\n"; - print "\tSvSETMAGIC(ST(0));\n" if $do_setmagic; + warn $@ if $@; + print "\tsv_2mortal(ST($num));\n"; + print "\tSvSETMAGIC(ST($num));\n" if $do_setmagic; } elsif ($expr =~ /^\s*\$arg\s*=/) { # We expect that $arg has refcnt >=1, so we need - # to mortalize it. However, the extension may have - # returned the built-in perl value, which is - # read-only, thus not mortalizable. However, it is - # safe to leave it as it is, since it would be - # ignored by REFCNT_dec. Builtin values have REFCNT==0. + # to mortalize it! eval "print qq\a$expr\a"; - print "\tif (SvREFCNT(ST(0))) sv_2mortal(ST(0));\n"; + warn $@ if $@; + print "\tsv_2mortal(ST(0));\n"; print "\tSvSETMAGIC(ST(0));\n" if $do_setmagic; } else { @@ -1465,21 +1733,37 @@ sub generate_output { # works too. print "\tST(0) = sv_newmortal();\n"; eval "print qq\a$expr\a"; + warn $@ if $@; # new mortals don't have set magic } } + elsif ($do_push) { + print "\tPUSHs(sv_newmortal());\n"; + $arg = "ST($num)"; + eval "print qq\a$expr\a"; + warn $@ if $@; + print "\tSvSETMAGIC($arg);\n" if $do_setmagic; + } elsif ($arg =~ /^ST\(\d+\)$/) { eval "print qq\a$expr\a"; + warn $@ if $@; print "\tSvSETMAGIC($arg);\n" if $do_setmagic; } } } sub map_type { - my($type) = @_; + my($type, $varname) = @_; $type =~ tr/:/_/; $type =~ s/^array\(([^,]*),(.*)\).*/$1 */s; + if ($varname) { + if ($varname && $type =~ / \( \s* \* (?= \s* \) ) /xg) { + (substr $type, pos $type, 0) = " $varname "; + } else { + $type .= "\t$varname"; + } + } $type; }