X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FExtUtils%2Fxsubpp;h=0cc8d785a7b4d7ad58aafa0704553f2f636e74e7;hb=248e2feabe92562dd8355cfd55ca72d937481761;hp=3113c62ed995c8c23afbb5c299b9ab0805ca7cf1;hpb=8fc38fdaa1848793e9b9d4a3642e644f9d791ae0;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/lib/ExtUtils/xsubpp b/lib/ExtUtils/xsubpp
index 3113c62..0cc8d78 100755
--- a/lib/ExtUtils/xsubpp
+++ b/lib/ExtUtils/xsubpp
@@ -71,18 +71,30 @@ See the file F<changes.pod>.
 
 =head1 SEE ALSO
 
-perl(1), perlxs(1), perlxstut(1), perlapi(1)
+perl(1), perlxs(1), perlxstut(1), perlxs(1)
 
 =cut
 
-# Global Constants
-$XSUBPP_version = "1.929";
 require 5.002;
+use Cwd;
+use vars '$cplusplus';
 
 sub Q ;
 
-$FH_string = 'File0000' ;
-*FH = $FH_string ;
+# Global Constants
+
+$XSUBPP_version = "1.9402";
+
+my ($Is_VMS, $SymSet);
+if ($^O eq 'VMS') {
+    $Is_VMS = 1;
+    # Establish set of global symbols with max length 28, since xsubpp
+    # will later add the 'XS_' prefix.
+    require ExtUtils::XSSymSet;
+    $SymSet = new ExtUtils::XSSymSet 28;
+}
+
+$FH = 'File0000' ;
 
 $usage = "Usage: xsubpp [-v] [-C++] [-except] [-prototypes] [-noversioncheck] [-s pattern] [-typemap typemap]... file.xs\n";
 
@@ -95,7 +107,7 @@ $ProtoUsed = 0 ;
 SWITCH: while (@ARGV and $ARGV[0] =~ /^-./) {
     $flag = shift @ARGV;
     $flag =~ s/^-// ;
-    $spat = shift,	next SWITCH	if $flag eq 's';
+    $spat = quotemeta shift,	next SWITCH	if $flag eq 's';
     $cplusplus = 1,	next SWITCH	if $flag eq 'C++';
     $WantPrototypes = 0, next SWITCH	if $flag eq 'noprototypes';
     $WantPrototypes = 1, next SWITCH	if $flag eq 'prototypes';
@@ -118,13 +130,14 @@ else
 	or ($dir, $filename) = $ARGV[0] =~ m#(.*[>\]])(.*)#
 	or ($dir, $filename) = ('.', $ARGV[0]);
 chdir($dir);
-# Check for VMS; Config.pm may not be installed yet, but this routine
-# is built into VMS perl
-if (defined(&VMS::Filespec::vmsify)) { $Is_VMS = 1; $pwd = $ENV{DEFAULT}; }
-else                                 { $Is_VMS = 0; chomp($pwd = `pwd`);   }
+$pwd = cwd();
 
 ++ $IncludedFiles{$ARGV[0]} ;
 
+my(@XSStack) = ({type => 'none'});	# Stack of conditionals and INCLUDEs
+my($XSS_work_idx, $cpp_next_tmp) = (0, "XSubPPtmpAAAA");
+
+
 sub TrimWhitespace
 {
     $_[0] =~ s/^\s+|\s+$//go ;
@@ -166,6 +179,7 @@ foreach $typemap (@tm) {
     $current = \$junk;
     while (<TYPEMAP>) {
 	next if /^\s*#/;
+        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; }
@@ -180,7 +194,7 @@ foreach $typemap (@tm) {
             $type = TidyType($type) ;
 	    $type_kind{$type} = $kind ;
             # prototype defaults to '$'
-            $proto = '$' unless $proto ;
+            $proto = "\$" unless $proto ;
             warn("Warning: File '$typemap' Line $. '$line' Invalid prototype '$proto'\n") 
                 unless ValidProtoString($proto) ;
             $proto_letter{$type} = C_string($proto) ;
@@ -212,6 +226,7 @@ $END = "!End!\n\n";		# "impossible" keyword (multiple newline)
 $BLOCK_re= '\s*(' . join('|', qw(
 	REQUIRE BOOT CASE PREINIT INPUT INIT CODE PPCODE OUTPUT 
 	CLEANUP ALIAS PROTOTYPES PROTOTYPE VERSIONCHECK INCLUDE
+	SCOPE
 	)) . "|$END)\\s*:";
 
 # Input:  ($_, @line) == unparsed input.
@@ -224,8 +239,10 @@ sub check_keyword {
 
 
 sub print_section {
+    my $count = 0;
     $_ = shift(@line) while !/\S/ && @line;
     for (;  defined($_) && !/^$BLOCK_re/o;  $_ = shift(@line)) {
+        print line_directive() unless ($count++);
 	print "$_\n";
     }
 }
@@ -237,6 +254,7 @@ sub process_keyword($)
 
     &{"${kwd}_handler"}() 
         while $kwd = check_keyword($pattern) ;
+    print line_directive();
 }
 
 sub CASE_handler {
@@ -313,6 +331,7 @@ sub OUTPUT_handler {
 	    unless defined($args_match{$outarg});
 	blurt("Error: No input definition for OUTPUT argument '$outarg' - ignored"), next
 	    unless defined $var_types{$outarg} ;
+	print line_directive();
 	if ($outcode) {
 	    print "\t$outcode\n";
 	} else {
@@ -347,13 +366,14 @@ sub GetAliases
         
         # check for duplicate alias name & duplicate value
 	Warn("Warning: Ignoring duplicate alias '$orig_alias'")
-	    if defined $XsubAliases{$pname}{$alias} ;
+	    if defined $XsubAliases{$alias} ;
 
-        Warn("Warning: Aliases '$orig_alias' and '$XsubAliasValues{$pname}{$value}' have identical values")
-	    if $XsubAliasValues{$pname}{$value} ;
+	Warn("Warning: Aliases '$orig_alias' and '$XsubAliasValues{$value}' have identical values")
+	    if $XsubAliasValues{$value} ;
 
-        $XsubAliases{$pname}{$alias} = $value ;
-        $XsubAliasValues{$pname}{$value} = $orig_alias ;
+	$XsubAliases = 1;
+	$XsubAliases{$alias} = $value ;
+	$XsubAliasValues{$value} = $orig_alias ;
     }
 
     blurt("Error: Cannot parse ALIAS definitions from '$orig'")
@@ -405,8 +425,14 @@ sub VERSIONCHECK_handler ()
 
 sub PROTOTYPE_handler ()
 {
+    my $specified ;
+
+    death("Error: Only 1 PROTOTYPE definition allowed per xsub") 
+        if $proto_in_this_xsub ++ ;
+
     for (;  !/^$BLOCK_re/o;  $_ = shift(@line)) {
 	next unless /\S/;
+	$specified = 1 ;
 	TrimWhitespace($_) ;
         if ($_ eq 'DISABLE') {
 	   $ProtoThisXSUB = 0 
@@ -422,7 +448,30 @@ sub PROTOTYPE_handler ()
             $ProtoThisXSUB = C_string($_) ;
         }
     }
+
+    # If no prototype specified, then assume empty prototype ""
+    $ProtoThisXSUB = 2 unless $specified ;
+
     $ProtoUsed = 1 ;
+
+}
+
+sub SCOPE_handler ()
+{
+    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 
+        }
+        elsif ($_ =~ /^ENABLE/i) {
+		   $ScopeThisXSUB = 1 
+        }
+    }
+
 }
 
 sub PROTOTYPES_handler ()
@@ -448,9 +497,6 @@ sub INCLUDE_handler ()
  
     TrimWhitespace($_) ;
  
-    # If the filename is enclosed in quotes, remove them.
-    s/^'([^']*)'$/$1/ or s/^"([^"]*)"$/$1/ ;
-
     death("INCLUDE: filename missing")
         unless $_ ;
 
@@ -464,19 +510,20 @@ sub INCLUDE_handler ()
     ++ $IncludedFiles{$_} unless /\|\s*$/ ;
 
     # Save the current file context.
-    push(@FileStack, {
+    push(@XSStack, {
+	type		=> 'file',
         LastLine        => $lastline,
         LastLineNo      => $lastline_no,
         Line            => \@line,
         LineNo          => \@line_no,
         Filename        => $filename,
-        Handle          => $FH_string,
+        Handle          => $FH,
         }) ;
  
-    ++ $FH_string ;
+    ++ $FH ;
 
     # open the new file
-    open ($FH_string, "$_") or death("Cannot open '$_': $!") ;
+    open ($FH, "$_") or death("Cannot open '$_': $!") ;
  
     print Q<<"EOF" ;
 #
@@ -484,35 +531,41 @@ sub INCLUDE_handler ()
 #
 EOF
 
-    *FH = $FH_string ;
     $filename = $_ ;
 
-    # Prime the pump by reading the first line
-    $lastline = <FH> ;
+    # Prime the pump by reading the first 
+    # non-blank line
+
+    # skip leading blank lines
+    while (<$FH>) {
+        last unless /^\s*$/ ;
+    }
+
+    $lastline = $_ ;
     $lastline_no = $. ;
  
 }
  
 sub PopFile()
 {
-    return 0 unless @FileStack ;
- 
-    my $data     = pop @FileStack ;
+    return 0 unless $XSStack[-1]{type} eq 'file' ;
+
+    my $data     = pop @XSStack ;
     my $ThisFile = $filename ;
     my $isPipe   = ($filename =~ /\|\s*$/) ;
  
     -- $IncludedFiles{$filename}
         unless $isPipe ;
 
-    close FH ;
+    close $FH ;
 
-    *FH         = $data->{Handle} ;
+    $FH         = $data->{Handle} ;
     $filename   = $data->{Filename} ;
     $lastline   = $data->{LastLine} ;
     $lastline_no = $data->{LastLineNo} ;
     @line       = @{ $data->{Line} } ;
     @line_no    = @{ $data->{LineNo} } ;
- 
+
     if ($isPipe and $? ) {
         -- $lastline_no ;
         print STDERR "Error reading from pipe '$ThisFile': $! in $filename, line $lastline_no\n"  ;
@@ -551,7 +604,7 @@ sub ProtoString ($)
 {
     my ($type) = @_ ;
 
-    $proto_letter{$type} or '$' ;
+    $proto_letter{$type} or "\$" ;
 }
 
 sub check_cpp {
@@ -563,6 +616,8 @@ sub check_cpp {
 		$cpplevel++;
 	    } elsif (!$cpplevel) {
 		Warn("Warning: #else/elif/endif without #if in this function");
+		print STDERR "    (precede it with a blank line if the matching #if is outside the function)\n"
+		    if $XSStack[-1]{type} eq 'if';
 		return;
 	    } elsif ($cpp =~ /^\#\s*endif/) {
 		$cpplevel--;
@@ -581,22 +636,22 @@ sub Q {
     $text;
 }
 
-open(FH, $filename) or die "cannot open $filename: $!\n";
+open($FH, $filename) or die "cannot open $filename: $!\n";
 
 # Identify the version of xsubpp used
 print <<EOM ;
 /*
  * This file was generated automatically by xsubpp version $XSUBPP_version from the 
- * contents of $filename. Don't edit this file, edit $filename instead.
+ * contents of $filename. Do not edit this file, edit $filename instead.
  *
  *	ANY CHANGES MADE HERE WILL BE LOST! 
  *
  */
 
 EOM
- 
+print "#line 1 \"$filename\"\n"; 
 
-while (<FH>) {
+while (<$FH>) {
     last if ($Module, $Package, $Prefix) =
 	/^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/;
     print $_;
@@ -606,22 +661,21 @@ while (<FH>) {
 $lastline    = $_;
 $lastline_no = $.;
 
-
-# Read next xsub into @line from ($lastline, <FH>).
+# Read next xsub into @line from ($lastline, <$FH>).
 sub fetch_para {
     # parse paragraph
+    death ("Error: Unterminated `#if/#ifdef/#ifndef'")
+	if !defined $lastline && $XSStack[-1]{type} eq 'if';
     @line = ();
     @line_no = () ;
-    if (! defined $lastline) {
-        return 1 if PopFile() ;
-        return 0 ; 
-    }
+    return PopFile() if !defined $lastline;
 
     if ($lastline =~
 	/^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/) {
 	$Module = $1;
 	$Package = defined($2) ? $2 : '';	# keep -w happy
 	$Prefix  = defined($3) ? $3 : '';	# keep -w happy
+	$Prefix = quotemeta $Prefix ;
 	($Module_cname = $Module) =~ s/\W/_/g;
 	($Packid = $Package) =~ tr/:/_/;
 	$Packprefix = $Package;
@@ -631,18 +685,24 @@ sub fetch_para {
 
     for(;;) {
 	if ($lastline !~ /^\s*#/ ||
-	    $lastline =~ /^#[ \t]*(?:(?:if|ifn?def|else|elif|endif|define|undef|pragma)\b|include\s*["<].*[>"])/) {
+	    # CPP directives:
+	    #	ANSI:	if ifdef ifndef elif else endif define undef
+	    #		line error pragma
+	    #	gcc:	warning include_next
+	    #   obj-c:	import
+	    #   others:	ident (gcc notes that some cpps have this one)
+	    $lastline =~ /^#[ \t]*(?:(?:if|ifn?def|elif|else|endif|define|undef|pragma|error|warning|line\s+\d+|ident)\b|(?:include(?:_next)?|import)\s*["<].*[>"])/) {
 	    last if $lastline =~ /^\S/ && @line && $line[-1] eq "";
 	    push(@line, $lastline);
 	    push(@line_no, $lastline_no) ;
 	}
 
 	# Read next line and continuation lines
-	last unless defined($lastline = <FH>);
+	last unless defined($lastline = <$FH>);
 	$lastline_no = $.;
 	my $tmp_line;
 	$lastline .= $tmp_line
-	    while ($lastline =~ /\\$/ && defined($tmp_line = <FH>));
+	    while ($lastline =~ /\\$/ && defined($tmp_line = <$FH>));
 	    
 	chomp $lastline;
 	$lastline =~ s/^\s+$//;
@@ -654,12 +714,51 @@ sub fetch_para {
 PARAGRAPH:
 while (fetch_para()) {
     # Print initial preprocessor statements and blank lines
-    print shift(@line), "\n"
-	while @line && $line[0] !~ /^[^\#]/;
+    while (@line && $line[0] !~ /^[^\#]/) {
+	my $line = shift(@line);
+	print $line, "\n";
+	next unless $line =~ /^\#\s*((if)(?:n?def)?|elsif|else|endif)\b/;
+	my $statement = $+;
+	if ($statement eq 'if') {
+	    $XSS_work_idx = @XSStack;
+	    push(@XSStack, {type => 'if'});
+	} else {
+	    death ("Error: `$statement' with no matching `if'")
+		if $XSStack[-1]{type} ne 'if';
+	    if ($XSStack[-1]{varname}) {
+		push(@InitFileCode, "#endif\n");
+		push(@BootCode,     "#endif");
+	    }
+
+	    my(@fns) = keys %{$XSStack[-1]{functions}};
+	    if ($statement ne 'endif') {
+		# Hide the functions defined in other #if branches, and reset.
+		@{$XSStack[-1]{other_functions}}{@fns} = (1) x @fns;
+		@{$XSStack[-1]}{qw(varname functions)} = ('', {});
+	    } else {
+		my($tmp) = pop(@XSStack);
+		0 while (--$XSS_work_idx
+			 && $XSStack[$XSS_work_idx]{type} ne 'if');
+		# Keep all new defined functions
+		push(@fns, keys %{$tmp->{other_functions}});
+		@{$XSStack[$XSS_work_idx]{functions}}{@fns} = (1) x @fns;
+	    }
+	}
+    }
 
     next PARAGRAPH unless @line;
 
-    death ("Code is not inside a function")
+    if ($XSS_work_idx && !$XSStack[$XSS_work_idx]{varname}) {
+	# We are inside an #if, but have not yet #defined its xsubpp variable.
+	print "#define $cpp_next_tmp 1\n\n";
+	push(@InitFileCode, "#if $cpp_next_tmp\n");
+	push(@BootCode,     "#if $cpp_next_tmp");
+	$XSStack[$XSS_work_idx]{varname} = $cpp_next_tmp++;
+    }
+
+    death ("Code is not inside a function"
+	   ." (maybe last function was ended by a blank line "
+	   ." followed by a a statement on column one?)")
 	if $line[0] =~ /^\s/;
 
     # initialize info arrays
@@ -673,7 +772,10 @@ while (fetch_para()) {
     undef($wantRETVAL) ;
     undef(%arg_list) ;
     undef(@proto_arg) ;
+    undef($proto_in_this_xsub) ;
+    undef($scope_in_this_xsub) ;
     $ProtoThisXSUB = $WantPrototypes ;
+    $ScopeThisXSUB = 0;
 
     $_ = shift(@line);
     while ($kwd = check_keyword("REQUIRE|PROTOTYPES|VERSIONCHECK|INCLUDE")) {
@@ -684,7 +786,7 @@ while (fetch_para()) {
 
     if (check_keyword("BOOT")) {
 	&check_cpp;
-        push (@BootCode, $_, @line, "") ;
+        push (@BootCode, $_, line_directive(), @line, "") ;
         next PARAGRAPH ;
     }
 
@@ -704,16 +806,18 @@ while (fetch_para()) {
 
     ($class, $func_name, $orig_args) =  ($1, $2, $3) ;
     ($pname = $func_name) =~ s/^($Prefix)?/$Packprefix/;
+    ($clean_func_name = $func_name) =~ s/^$Prefix//;
+    $Full_func_name = "${Packid}_$clean_func_name";
+    if ($Is_VMS) { $Full_func_name = $SymSet->addsym($Full_func_name); }
 
     # Check for duplicate function definition
-    if (defined $Func_name{"${Packid}_$func_name"} ) {
-       Warn("Warning: duplicate function definition '$func_name' detected") 
+    for $tmp (@XSStack) {
+	next unless defined $tmp->{functions}{$Full_func_name};
+	Warn("Warning: duplicate function definition '$clean_func_name' detected");
+	last;
     }
-    else {
-        push(@Func_name, "${Packid}_$func_name");
-        push(@Func_pname, $pname);
-    }
-    $Func_name{"${Packid}_$func_name"} ++ ;
+    $XSStack[$XSS_work_idx]{functions}{$Full_func_name} ++ ;
+    %XsubAliases = %XsubAliasValues = ();
 
     @args = split(/\s*,\s*/, $orig_args);
     if (defined($class)) {
@@ -738,7 +842,7 @@ while (fetch_para()) {
 		    $defaults{$args[$i]} = $2;
 		    $defaults{$args[$i]} =~ s/"/\\"/g;
 	    }
-	    $proto_arg[$i+1] = '$' ;
+	    $proto_arg[$i+1] = "\$" ;
     }
     if (defined($class)) {
 	    $func_args = join(", ", @args[1..$#args]);
@@ -748,11 +852,16 @@ while (fetch_para()) {
     @args_match{@args} = 1..@args;
 
     $PPCODE = grep(/^\s*PPCODE\s*:/, @line);
+    $CODE = grep(/^\s*CODE\s*:/, @line);
+    # Detect CODE: blocks which use ST(n)= or XST_m*(n,v)
+    #   to set explicit return values.
+    $EXPLICIT_RETURN = ($CODE &&
+		("@line" =~ /(\bST\s*\([^;]*=) | (\bXST_m\w+\s*\()/x ));
     $ALIAS  = grep(/^\s*ALIAS\s*:/,  @line);
 
     # print function header
     print Q<<"EOF";
-#XS(XS_${Packid}_$func_name)
+#XS(XS_${Full_func_name})
 #[[
 #    dXSARGS;
 EOF
@@ -811,8 +920,13 @@ EOF
         $gotRETVAL = 0;
 
 	INPUT_handler() ;
-	process_keyword("INPUT|PREINIT|ALIAS|PROTOTYPE") ;
+	process_keyword("INPUT|PREINIT|ALIAS|PROTOTYPE|SCOPE") ;
 
+	print Q<<"EOF" if $ScopeThisXSUB;
+#   ENTER;
+#   [[
+EOF
+	
 	if (!$thisdone && defined($class)) {
 	    if (defined($static) or $func_name =~ /^new/) {
 		print "\tchar *";
@@ -837,12 +951,15 @@ EOF
 			$args_match{"RETVAL"} = 0;
 			$var_types{"RETVAL"} = $ret_type;
 		}
+
 		print $deferred;
-                process_keyword("INIT|ALIAS|PROTOTYPE") ;
+
+        process_keyword("INIT|ALIAS|PROTOTYPE") ;
 
 		if (check_keyword("PPCODE")) {
 			print_section();
 			death ("PPCODE must be last thing") if @line;
+			print "\tLEAVE;\n" if $ScopeThisXSUB;
 			print "\tPUTBACK;\n\treturn;\n";
 		} elsif (check_keyword("CODE")) {
 			print_section() ;
@@ -886,10 +1003,18 @@ EOF
 	} elsif ($gotRETVAL || $wantRETVAL) {
 	    &generate_output($ret_type, 0, 'RETVAL');
 	}
+	print line_directive();
 
 	# do cleanup
 	process_keyword("CLEANUP|ALIAS|PROTOTYPE") ;
 
+	print Q<<"EOF" if $ScopeThisXSUB;
+#   ]]
+EOF
+	print Q<<"EOF" if $ScopeThisXSUB and not $PPCODE;
+#   LEAVE;
+EOF
+
 	# print function trailer
 	print Q<<EOF;
 #    ]]
@@ -915,19 +1040,35 @@ EOF
 #	croak(errbuf);
 EOF
 
-    print Q<<EOF unless $PPCODE;
+    if ($ret_type ne "void" or $EXPLICIT_RETURN) {
+        print Q<<EOF unless $PPCODE;
 #    XSRETURN(1);
 EOF
+    } else {
+        print Q<<EOF unless $PPCODE;
+#    XSRETURN_EMPTY;
+EOF
+    }
 
     print Q<<EOF;
 #]]
 #
 EOF
 
+    my $newXS = "newXS" ;
+    my $proto = "" ;
+
     # Build the prototype string for the xsub
     if ($ProtoThisXSUB) {
-        if ($ProtoThisXSUB != 1) {
-            $ProtoXSUB{$pname} = '"' . $ProtoThisXSUB . '"'
+	$newXS = "newXSproto";
+
+	if ($ProtoThisXSUB == 2) {
+	    # User has specified empty prototype
+	    $proto = ', ""' ;
+	}
+        elsif ($ProtoThisXSUB != 1) {
+            # User has specified a prototype
+            $proto = ', "' . $ProtoThisXSUB . '"';
         }
         else {
 	    my $s = ';';
@@ -935,13 +1076,30 @@ EOF
                 $s = ''; 
 		$proto_arg[$min_args] .= ";" ;
 	    }
-            push @proto_arg, "${s}@" 
+            push @proto_arg, "$s\@" 
                 if $elipsis ;
     
-            $ProtoXSUB{$pname} = '"' . join ("", @proto_arg) . '"' 
+            $proto = ', "' . join ("", @proto_arg) . '"';
         }
     }
 
+    if (%XsubAliases) {
+	$XsubAliases{$pname} = 0 
+	    unless defined $XsubAliases{$pname} ;
+	while ( ($name, $value) = each %XsubAliases) {
+	    push(@InitFileCode, Q<<"EOF");
+#        cv = newXS(\"$name\", XS_$Full_func_name, file);
+#        XSANY.any_i32 = $value ;
+EOF
+	push(@InitFileCode, Q<<"EOF") if $proto;
+#        sv_setpv((SV*)cv$proto) ;
+EOF
+        }
+    }
+    else {
+	push(@InitFileCode,
+	     "        ${newXS}(\"$pname\", XS_$Full_func_name, file$proto);\n");
+    }
 }
 
 # print initialization routine
@@ -961,41 +1119,15 @@ print Q<<"EOF" if $WantVersionChk ;
 #
 EOF
 
-print Q<<"EOF" if defined %XsubAliases ;
+print Q<<"EOF" if defined $XsubAliases ;
 #    {
 #        CV * cv ;
 #
 EOF
 
-for (@Func_name) {
-    $pname = shift(@Func_pname);
-    my $newXS = "newXS" ;
-    my $proto = "" ;
+print @InitFileCode;
 
-    if ($ProtoXSUB{$pname}) {
-        $newXS = "newXSproto" ;
-        $proto = ", $ProtoXSUB{$pname}" ;
-    }
-
-    if ($XsubAliases{$pname}) {
-        $XsubAliases{$pname}{$pname} = 0 
-		unless defined $XsubAliases{$pname}{$pname} ;
-        while ( ($name, $value) = each %{$XsubAliases{$pname}}) {
-            print Q<<"EOF" ;
-#        cv = newXS(\"$name\", XS_$_, file);
-#        XSANY.any_i32 = $value ;
-EOF
-            print Q<<"EOF" if $proto ;
-#        sv_setpv(cv, $ProtoXSUB{$pname}) ;
-EOF
-        }
-    }
-    else {
-        print "        ${newXS}(\"$pname\", XS_$_, file$proto);\n";
-    }
-}
-
-print Q<<"EOF" if defined %XsubAliases ;
+print Q<<"EOF" if defined $XsubAliases ;
 #    }
 EOF
 
@@ -1024,6 +1156,15 @@ sub output_init {
     eval qq/print " $init\\\n"/;
 }
 
+sub line_directive
+{
+    # work out the line number
+    my $line_no = $line_no[@line_no - @line -1] ;
+ 
+    return "#line $line_no \"$filename\"\n" ;
+
+}
+
 sub Warn
 {
     # work out the line number
@@ -1072,16 +1213,19 @@ sub generate_init {
 	$subexpr =~ s/ntype/subtype/g;
 	$subexpr =~ s/\$arg/ST(ix_$var)/g;
 	$subexpr =~ s/\n\t/\n\t\t/g;
-	$subexpr =~ s/is not of (.*")/[arg %d] is not of $1, ix_$var + 1/g;
+	$subexpr =~ s/is not of (.*\")/[arg %d] is not of $1, ix_$var + 1/g;
 	$subexpr =~ s/\$var/${var}[ix_$var - $argoff]/;
 	$expr =~ s/DO_ARRAY_ELEM/$subexpr/;
     }
+    if ($expr =~ m#/\*.*scope.*\*/#i) { # "scope" in C comments
+    	$ScopeThisXSUB = 1;
+    }
     if (defined($defaults{$var})) {
 	    $expr =~ s/(\t+)/$1    /g;
 	    $expr =~ s/        /\t/g;
 	    eval qq/print "\\t$var;\\n"/;
 	    $deferred .= eval qq/"\\n\\tif (items < $num)\\n\\t    $var = $defaults{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/;
-    } elsif ($expr !~ /^\t\$var =/) {
+    } elsif ($ScopeThisXSUB or $expr !~ /^\t\$var =/) {
 	    eval qq/print "\\t$var;\\n"/;
 	    $deferred .= eval qq/"\\n$expr;\\n"/;
     } else {
@@ -1121,11 +1265,27 @@ sub generate_output {
 		eval "print qq\a$expr\a";
 	    }
 	    elsif ($var eq 'RETVAL') {
-		if ($expr =~ /^\t\$arg = /) {
+		if ($expr =~ /^\t\$arg = new/) {
+		    # 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";
 		}
+		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.
+		    eval "print qq\a$expr\a";
+		    print "\tif (SvREFCNT(ST(0))) sv_2mortal(ST(0));\n";
+		}
 		else {
+		    # Just hope that the entry would safely write it
+		    # over an already mortalized value. By
+		    # coincidence, something like $arg = &sv_undef
+		    # works too.
 		    print "\tST(0) = sv_newmortal();\n";
 		    eval "print qq\a$expr\a";
 		}
@@ -1149,5 +1309,6 @@ sub Exit {
 # If this is VMS, the exit status has meaning to the shell, so we
 # use a predictable value (SS$_Normal or SS$_Abort) rather than an
 # arbitrary number.
-    exit ($Is_VMS ? ($errors ? 44 : 1) : $errors) ;
+#    exit ($Is_VMS ? ($errors ? 44 : 1) : $errors) ;
+    exit ($errors ? 1 : 0);
 }