X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FExtUtils%2Fxsubpp;h=b5dfa610c02097eda4d8c52ab683013ca56bd13d;hb=80a5d8e74b5512d4ab704d0e83466ae41247ce55;hp=ff9b452caf420aa68793de81fc729083dad74c42;hpb=146174a91a192983720a158796dc066226ad0e55;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/ExtUtils/xsubpp b/lib/ExtUtils/xsubpp index ff9b452..b5dfa61 100755 --- a/lib/ExtUtils/xsubpp +++ b/lib/ExtUtils/xsubpp @@ -34,6 +34,10 @@ any makefiles generated by MakeMaker. Adds ``extern "C"'' to the C code. +=item B<-hiertype> + +Retains '::' in type names so that C++ hierachical types can be mapped. + =item B<-except> Adds exception handling stubs to the C code. @@ -70,6 +74,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 @@ -92,7 +104,7 @@ perl(1), perlxs(1), perlxstut(1) require 5.002; use Cwd; -use vars '$cplusplus'; +use vars qw($cplusplus $hiertype); use vars '%v'; use Config; @@ -101,7 +113,7 @@ sub Q ; # Global Constants -$XSUBPP_version = "1.9507"; +$XSUBPP_version = "1.9508"; my ($Is_VMS, $SymSet); if ($^O eq 'VMS') { @@ -114,11 +126,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,23 +136,33 @@ $WantVersionChk = 1 ; $ProtoUsed = 0 ; $WantLineNumbers = 1 ; $WantOptimize = 1 ; +$Overload = 0; + +my $process_inout = 1; +my $process_argtypes = 1; + SWITCH: while (@ARGV and $ARGV[0] =~ /^-./) { $flag = shift @ARGV; $flag =~ s/^-// ; $spat = quotemeta shift, next SWITCH if $flag eq 's'; $cplusplus = 1, next SWITCH if $flag eq 'C++'; + $hiertype = 1, next SWITCH if $flag eq 'hiertype'; $WantPrototypes = 0, next SWITCH if $flag eq 'noprototypes'; $WantPrototypes = 1, next SWITCH if $flag eq 'prototypes'; $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; @@ -182,7 +202,7 @@ sub TidyType # change multiple whitespace into a single space s/\s+/ /g ; - + # trim leading & trailing whitespace TrimWhitespace($_) ; @@ -197,18 +217,18 @@ 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 + warn("Warning: ignoring non-text typemap file '$typemap'\n"), next unless -T $typemap ; - open(TYPEMAP, $typemap) + open(TYPEMAP, $typemap) or warn ("Warning: could not open typemap file '$typemap': $!\n"), next; $mode = 'Typemap'; $junk = "" ; $current = \$junk; while () { next if /^\s*#/; - my $line_no = $. + 1; + my $line_no = $. + 1; if (/^INPUT\s*$/) { $mode = 'Input'; $current = \$junk; next; } if (/^OUTPUT\s*$/) { $mode = 'Output'; $current = \$junk; next; } if (/^TYPEMAP\s*$/) { $mode = 'Typemap'; $current = \$junk; next; } @@ -224,7 +244,7 @@ foreach $typemap (@tm) { $type_kind{$type} = $kind ; # prototype defaults to '$' $proto = "\$" unless $proto ; - warn("Warning: File '$typemap' Line $. '$line' Invalid prototype '$proto'\n") + warn("Warning: File '$typemap' Line $. '$line' Invalid prototype '$proto'\n") unless ValidProtoString($proto) ; $proto_letter{$type} = C_string($proto) ; } @@ -246,12 +266,12 @@ foreach $typemap (@tm) { } foreach $key (keys %input_expr) { - $input_expr{$key} =~ s/\n+$//; + $input_expr{$key} =~ s/;*\s+\z//; } -$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 +280,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; @@ -271,9 +291,9 @@ $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 + REQUIRE BOOT CASE PREINIT INPUT INIT CODE PPCODE OUTPUT + CLEANUP ALIAS ATTRS PROTOTYPES PROTOTYPE VERSIONCHECK INCLUDE + SCOPE INTERFACE INTERFACE_MACRO C_ARGS POSTCALL OVERLOAD )) . "|$END)\\s*:"; # Input: ($_, @line) == unparsed input. @@ -284,6 +304,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) { { @@ -331,7 +364,7 @@ if ($WantLineNumbers) { sub print_section { # the "do" is required for right semantics do { $_ = shift(@line) } while !/\S/ && @line; - + print("#line ", $line_no[@line_no - @line -1], " \"$filename\"\n") if $WantLineNumbers && !/^\s*#\s*line\b/ && !/^#if XSubPPtmp/; for (; defined($_) && !/^$BLOCK_re/o; $_ = shift(@line)) { @@ -342,11 +375,11 @@ sub print_section { sub merge_section { my $in = ''; - + while (!/\S/ && @line) { $_ = shift(@line); } - + for (; defined($_) && !/^$BLOCK_re/o; $_ = shift(@line)) { $in .= "$_\n"; } @@ -359,7 +392,7 @@ sub process_keyword($) my($pattern) = @_ ; my $kwd ; - &{"${kwd}_handler"}() + &{"${kwd}_handler"}() while $kwd = check_keyword($pattern) ; } @@ -375,7 +408,7 @@ sub CASE_handler { sub INPUT_handler { for (; !/^$BLOCK_re/o; $_ = shift(@line)) { last if /^\s*NOT_IMPLEMENTED_YET/; - next unless /\S/; # skip blank lines + next unless /\S/; # skip blank lines TrimWhitespace($_) ; my $line = $_ ; @@ -383,18 +416,27 @@ sub INPUT_handler { # remove trailing semicolon if no initialisation s/\s*;$//g unless /[=;+].*\S/ ; + # Process the length(foo) declarations + if (s/^([^=]*)\blength\(\s*(\w+)\s*\)\s*$/$1 XSauto_length_of_$2=NO_INIT/x) { + print "\tSTRLEN\tSTRLEN_length_of_$2;\n"; + $lengthof{$2} = $name; + # $islengthof{$name} = $1; + $deferred .= "\n\tXSauto_length_of_$2 = STRLEN_length_of_$2;"; + } + # check for optional initialisation code my $var_init = '' ; $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 $argtype_seen{$var_name} and not $processing_arg_with_types; $thisdone |= $var_name eq "THIS"; $retvaldone |= $var_name eq "RETVAL"; @@ -412,13 +454,12 @@ sub INPUT_handler { } $var_num = $args_match{$var_name}; - $proto_arg[$var_num] = ProtoString($var_type) + $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,19 +503,21 @@ 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$/; } } sub C_ARGS_handler() { my $in = merge_section(); - + TrimWhitespace($in); $func_args = $in; -} +} sub INTERFACE_MACRO_handler() { my $in = merge_section(); - + TrimWhitespace($in); if ($in =~ /\s/) { # two ($interface_macro, $interface_macro_set) = split ' ', $in; @@ -488,9 +531,9 @@ sub INTERFACE_MACRO_handler() { sub INTERFACE_handler() { my $in = merge_section(); - + TrimWhitespace($in); - + foreach (split /[\s,]+/, $in) { $Interfaces{$_} = $_; } @@ -501,9 +544,10 @@ EOF $Interfaces = 1; # global } -sub CLEANUP_handler() { print_section() } -sub PREINIT_handler() { print_section() } -sub INIT_handler() { print_section() } +sub CLEANUP_handler() { print_section() } +sub PREINIT_handler() { print_section() } +sub POSTCALL_handler() { print_section() } +sub INIT_handler() { print_section() } sub GetAliases { @@ -523,7 +567,7 @@ sub GetAliases # check for optional package definition in the alias $alias = $Packprefix . $alias if $alias !~ /::/ ; - + # check for duplicate alias name & duplicate value Warn("Warning: Ignoring duplicate alias '$orig_alias'") if defined $XsubAliases{$alias} ; @@ -540,6 +584,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)) { @@ -549,6 +602,21 @@ sub ALIAS_handler () } } +sub OVERLOAD_handler() +{ + for (; !/^$BLOCK_re/o; $_ = shift(@line)) { + next unless /\S/; + TrimWhitespace($_) ; + while ( s/^\s*([\w:"\\)\+\-\*\/\%\<\>\.\&\|\^\!\~\{\}\=]+)\s*//) { + $Overload = 1 unless $Overload; + my $overload = "$Package\::(".$1 ; + push(@InitFileCode, + " newXS(\"$overload\", XS_$Full_func_name, file$proto);\n"); + } + } + +} + sub REQUIRE_handler () { # the rest of the current line should contain a version number @@ -564,30 +632,30 @@ sub REQUIRE_handler () unless $Ver =~ /^\d+(\.\d*)?/ ; death ("Error: xsubpp $Ver (or better) required--this is only $XSUBPP_version.") - unless $XSUBPP_version >= $Ver ; + unless $XSUBPP_version >= $Ver ; } sub VERSIONCHECK_handler () { # the rest of the current line should contain either ENABLE or # DISABLE - + TrimWhitespace($_) ; - + # check for ENABLE/DISABLE death ("Error: VERSIONCHECK: ENABLE/DISABLE") unless /^(ENABLE|DISABLE)/i ; - + $WantVersionChk = 1 if $1 eq 'ENABLE' ; $WantVersionChk = 0 if $1 eq 'DISABLE' ; - + } sub PROTOTYPE_handler () { my $specified ; - death("Error: Only 1 PROTOTYPE definition allowed per xsub") + death("Error: Only 1 PROTOTYPE definition allowed per xsub") if $proto_in_this_xsub ++ ; for (; !/^$BLOCK_re/o; $_ = shift(@line)) { @@ -595,10 +663,10 @@ sub PROTOTYPE_handler () $specified = 1 ; TrimWhitespace($_) ; if ($_ eq 'DISABLE') { - $ProtoThisXSUB = 0 + $ProtoThisXSUB = 0 } elsif ($_ eq 'ENABLE') { - $ProtoThisXSUB = 1 + $ProtoThisXSUB = 1 } else { # remove any whitespace @@ -618,17 +686,17 @@ sub PROTOTYPE_handler () sub SCOPE_handler () { - death("Error: Only 1 SCOPE declaration allowed per xsub") + death("Error: Only 1 SCOPE declaration allowed per xsub") if $scope_in_this_xsub ++ ; for (; !/^$BLOCK_re/o; $_ = shift(@line)) { next unless /\S/; TrimWhitespace($_) ; if ($_ =~ /^DISABLE/i) { - $ScopeThisXSUB = 0 + $ScopeThisXSUB = 0 } elsif ($_ =~ /^ENABLE/i) { - $ScopeThisXSUB = 1 + $ScopeThisXSUB = 1 } } @@ -637,7 +705,7 @@ sub SCOPE_handler () sub PROTOTYPES_handler () { # the rest of the current line should contain either ENABLE or - # DISABLE + # DISABLE TrimWhitespace($_) ; @@ -654,9 +722,9 @@ sub PROTOTYPES_handler () sub INCLUDE_handler () { # the rest of the current line should contain a valid filename - + TrimWhitespace($_) ; - + death("INCLUDE: filename missing") unless $_ ; @@ -679,12 +747,12 @@ sub INCLUDE_handler () Filename => $filename, Handle => $FH, }) ; - + ++ $FH ; # open the new file open ($FH, "$_") or death("Cannot open '$_': $!") ; - + print Q<<"EOF" ; # #/* INCLUDE: Including '$_' from '$filename' */ @@ -693,7 +761,7 @@ EOF $filename = $_ ; - # Prime the pump by reading the first + # Prime the pump by reading the first # non-blank line # skip leading blank lines @@ -703,9 +771,9 @@ EOF $lastline = $_ ; $lastline_no = $. ; - + } - + sub PopFile() { return 0 unless $XSStack[-1]{type} eq 'file' ; @@ -713,7 +781,7 @@ sub PopFile() my $data = pop @XSStack ; my $ThisFile = $filename ; my $isPipe = ($filename =~ /\|\s*$/) ; - + -- $IncludedFiles{$filename} unless $isPipe ; @@ -801,26 +869,41 @@ open($FH, $filename) or die "cannot open $filename: $!\n"; # Identify the version of xsubpp used print <) { + 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 +936,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 +965,7 @@ sub fetch_para { my $tmp_line; $lastline .= $tmp_line while ($lastline =~ /\\$/ && defined($tmp_line = <$FH>)); - + chomp $lastline; $lastline =~ s/^\s+$//; } @@ -927,27 +1020,37 @@ 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(@fake_INPUT_pre) ; # For length(s) generated variables + undef(@fake_INPUT) ; + undef($processing_arg_with_types) ; + undef(%argtype_seen) ; + undef(@outlist) ; + undef(%in_out) ; + undef(%lengthof) ; + # undef(%islengthof) ; 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 +1070,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 +1085,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,41 +1101,113 @@ 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_C_inlist; # Not in the signature of Perl function + 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, $default) = / ( [^=]* ) ( (?: = .* )? ) /x; + my ($pre, $name) = ($arg =~ /(.*?) \s* + \b ( \w+ | length\( \s*\w+\s* \) ) + \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+//; + $pre =~ s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\s+//; + } + my $islength; + if ($name =~ /^length\( \s* (\w+) \s* \)\z/x) { + $name = "XSauto_length_of_$1"; + $islength = 1; + die "Default value on length() argument: `$_'" + if length $default; + } + if (length $pre or $islength) { # Has a type + if ($islength) { + push @fake_INPUT_pre, $arg; + } else { + push @fake_INPUT, $arg; + } + # warn "pushing '$arg'\n"; + $argtype_seen{$name}++; + $_ = "$name$default"; # Assigns to @args + } + $only_C_inlist{$_} = 1 if $out_type eq "OUTLIST" or $islength; + 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_C_inlist{$_} = 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_C_inlist{$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); @@ -1037,8 +1218,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; @@ -1064,15 +1248,24 @@ EOF # *errbuf = '\0'; EOF - if ($ALIAS) + 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 + 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; @@ -1101,7 +1294,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|OVERLOAD") ; print Q<<"EOF" if $ScopeThisXSUB; # ENTER; @@ -1135,9 +1328,15 @@ EOF if $WantOptimize and $targetable{$type_kind{$ret_type}}; } + if (@fake_INPUT or @fake_INPUT_pre) { + unshift @line, @fake_INPUT_pre, @fake_INPUT, $_; + $_ = ""; + $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|OVERLOAD") ; if (check_keyword("PPCODE")) { print_section(); @@ -1176,10 +1375,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|OVERLOAD"); + + &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) { @@ -1196,6 +1400,7 @@ EOF warn $@ if $@; print "\tsv_setpv(TARG, $what); XSprePUSH; PUSHTARG;\n"; + $prepush_done = 1; } elsif ($t) { my $what = eval qq("$t->[2]"); @@ -1206,6 +1411,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() @@ -1213,8 +1419,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|OVERLOAD") ; print Q<<"EOF" if $ScopeThisXSUB; # ]] @@ -1248,9 +1462,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 =/) { + } elsif ($ScopeThisXSUB or $expr !~ /^\s*\$var =/) { if ($name_printed) { print ";\n"; } else { @@ -1487,19 +1738,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; @@ -1508,7 +1760,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; @@ -1526,8 +1778,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 @@ -1548,6 +1800,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 $@; @@ -1559,7 +1818,8 @@ sub generate_output { sub map_type { my($type, $varname) = @_; - $type =~ tr/:/_/; + # C++ has :: in types too so skip this + $type =~ tr/:/_/ unless $hiertype; $type =~ s/^array\(([^,]*),(.*)\).*/$1 */s; if ($varname) { if ($varname && $type =~ / \( \s* \* (?= \s* \) ) /xg) {