Clean up format of dlopen() debug info
[p5sagit/p5-mst-13.2.git] / lib / ExtUtils / xsubpp
index 3113c62..0cc8d78 100755 (executable)
@@ -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);
 }