X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FExtUtils%2Fxsubpp;h=98bb7397f66f4150a129f24e025f3ef9ee6840f0;hb=8c7f0036c6170bb0e341d84874bdb51f472a6afb;hp=4fedd3bb416c7a69acf57990837e7fb1d3d6b416;hpb=b7e88d4403a3f62fd94b9397a3275f2e7d3f7928;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/ExtUtils/xsubpp b/lib/ExtUtils/xsubpp index 4fedd3b..98bb739 100755 --- a/lib/ExtUtils/xsubpp +++ b/lib/ExtUtils/xsubpp @@ -70,6 +70,14 @@ 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> + +Disable recognition of ANSI-like descriptions of function signature. + =back =head1 ENVIRONMENT @@ -101,7 +109,7 @@ sub Q ; # Global Constants -$XSUBPP_version = "1.9507"; +$XSUBPP_version = "1.9508"; my ($Is_VMS, $SymSet); if ($^O eq 'VMS') { @@ -114,11 +122,9 @@ if ($^O eq 'VMS') { $FH = 'File0000' ; -$usage = "Usage: xsubpp [-v] [-C++] [-except] [-prototypes] [-noversioncheck] [-nolinenumbers] [-nooptimize] [-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 ; @@ -126,6 +132,10 @@ $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/^-// ; @@ -136,13 +146,17 @@ SWITCH: while (@ARGV and $ARGV[0] =~ /^-./) { $WantVersionChk = 0, next SWITCH if $flag eq 'noversioncheck'; $WantVersionChk = 1, next SWITCH if $flag eq 'versioncheck'; # XXX left this in for compat - $WantCAPI = 1, next SWITCH if $flag eq 'object_capi'; + 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'; $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; @@ -197,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 ; @@ -249,9 +263,9 @@ foreach $key (keys %input_expr) { $input_expr{$key} =~ s/\n+$//; } -$bal = qr[(?:(?>[^()]+)|\((?p{ $bal })\))*]; # ()-balanced +$bal = qr[(?:(?>[^()]+)|\((??{ $bal })\))*]; # ()-balanced $cast = qr[(?:\(\s*SV\s*\*\s*\)\s*)?]; # Optional (SV*) cast -$size = qr[,\s* (?p{ $bal }) ]x; # Third arg (to setpvn) +$size = qr[,\s* (??{ $bal }) ]x; # Third arg (to setpvn) foreach $key (keys %output_expr) { use re 'eval'; @@ -260,8 +274,8 @@ foreach $key (keys %output_expr) { ($output_expr{$key} =~ m[^ \s+ sv_set ( [iunp] ) v (n)? # Type, is_setpvn \s* \( \s* $cast \$arg \s* , - \s* ( (?p{ $bal }) ) # Set from - ( (?p{ $size }) )? # Possible sizeof set-from + \s* ( (??{ $bal }) ) # Set from + ( (??{ $size }) )? # Possible sizeof set-from \) \s* ; \s* $ ]x); $targetable{$key} = [$t, $with_size, $arg, $sarg] if $t; @@ -272,8 +286,8 @@ $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. @@ -284,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) { { @@ -389,12 +416,13 @@ sub INPUT_handler { $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"; @@ -414,11 +442,10 @@ sub INPUT_handler { $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 { @@ -462,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$/; } } @@ -503,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 @@ -540,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)) { @@ -814,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|\s+defined)\s*(\(__cplusplus\)|__cplusplus)/#if defined(__cplusplus) && !defined(PERL_OBJECT)/; - } print $_; } &Exit unless defined $_; @@ -853,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 @@ -872,7 +936,7 @@ sub fetch_para { my $tmp_line; $lastline .= $tmp_line while ($lastline =~ /\\$/ && defined($tmp_line = <$FH>)); - + chomp $lastline; $lastline =~ s/^\s+$//; } @@ -927,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")) { @@ -967,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 @@ -976,7 +1053,7 @@ 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*(const)?\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; @@ -992,43 +1069,101 @@ while (fetch_para()) { last; } $XSStack[$XSS_work_idx]{functions}{$Full_func_name} ++ ; - %XsubAliases = %XsubAliasValues = %Interfaces = (); + %XsubAliases = %XsubAliasValues = %Interfaces = @Attributes = (); $DoSetMagic = 1; - my $temp_args = $orig_args; - $temp_args =~ s/\\\s*//g; - @args = split(/\s*,\s*/, $temp_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); @@ -1039,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; @@ -1069,12 +1207,21 @@ EOF if ($ALIAS) { print Q<<"EOF" if $cond } # if ($cond) -# Perl_croak(aTHX_ "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) -# Perl_croak(aTHX_ "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; @@ -1103,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; @@ -1137,9 +1284,15 @@ EOF 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(); @@ -1178,10 +1331,15 @@ 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) { @@ -1198,6 +1356,7 @@ EOF warn $@ if $@; print "\tsv_setpv(TARG, $what); XSprePUSH; PUSHTARG;\n"; + $prepush_done = 1; } elsif ($t) { my $what = eval qq("$t->[2]"); @@ -1208,6 +1367,7 @@ EOF $size = eval qq("$size"); warn $@ if $@; print "\tXSprePUSH; PUSH$t->[0]($what$size);\n"; + $prepush_done = 1; } else { # RETVAL almost never needs SvSETMAGIC() @@ -1215,8 +1375,16 @@ EOF } } + $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; # ]] @@ -1250,9 +1418,9 @@ EOF # Perl_croak(aTHX_ errbuf); EOF - if ($ret_type ne "void" or $EXPLICIT_RETURN) { + if ($xsreturn) { 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 =/) { if ($name_printed) { @@ -1489,19 +1675,20 @@ sub generate_init { } 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 "\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; @@ -1510,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; @@ -1528,8 +1715,8 @@ sub generate_output { # mortalize it. eval "print qq\a$expr\a"; warn $@ if $@; - print "\tsv_2mortal(ST(0));\n"; - print "\tSvSETMAGIC(ST(0));\n" if $do_setmagic; + 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 @@ -1550,6 +1737,13 @@ sub generate_output { # 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 $@;