lib/ExtUtils/xsubpp

   1 #!./miniperl
   2
   3 =head1 NAME
   4
   5 xsubpp - compiler to convert Perl XS code into C code
   6
   7 =head1 SYNOPSIS
   8
   9 B<xsubpp> [B<-v>] [B<-C++>] [B<-except>] [B<-s pattern>] [B<-prototypes>] [B<-noversioncheck>] [B<-nolinenumbers>] [B<-typemap typemap>]... file.xs
  10
  11 =head1 DESCRIPTION
  12
  13 I<xsubpp> will compile XS code into C code by embedding the constructs
  14 necessary to let C functions manipulate Perl values and creates the glue
  15 necessary to let Perl access those functions.  The compiler uses typemaps to
  16 determine how to map C function parameters and variables to Perl values.
  17
  18 The compiler will search for typemap files called I<typemap>.  It will use
  19 the following search path to find default typemaps, with the rightmost
  20 typemap taking precedence.
  21
  22         ../../../typemap:../../typemap:../typemap:typemap
  23
  24 =head1 OPTIONS
  25
  26 =over 5
  27
  28 =item B<-C++>
  29
  30 Adds ``extern "C"'' to the C code.
  31
  32
  33 =item B<-except>
  34
  35 Adds exception handling stubs to the C code.
  36
  37 =item B<-typemap typemap>
  38
  39 Indicates that a user-supplied typemap should take precedence over the
  40 default typemaps.  This option may be used multiple times, with the last
  41 typemap having the highest precedence.
  42
  43 =item B<-v>
  44
  45 Prints the I<xsubpp> version number to standard output, then exits.
  46
  47 =item B<-prototypes>
  48
  49 By default I<xsubpp> will not automatically generate prototype code for
  50 all xsubs. This flag will enable prototypes.
  51
  52 =item B<-noversioncheck>
  53
  54 Disables the run time test that determines if the object file (derived
  55 from the C<.xs> file) and the C<.pm> files have the same version
  56 number.
  57
  58 =item B<-nolinenumbers>
  59
  60 Prevents the inclusion of `#line' directives in the output.
  61
  62 =back
  63
  64 =head1 ENVIRONMENT
  65
  66 No environment variables are used.
  67
  68 =head1 AUTHOR
  69
  70 Larry Wall
  71
  72 =head1 MODIFICATION HISTORY
  73
  74 See the file F<changes.pod>.
  75
  76 =head1 SEE ALSO
  77
  78 perl(1), perlxs(1), perlxstut(1)
  79
  80 =cut
  81
  82 require 5.002;
  83 use Cwd;
  84 use vars '$cplusplus';
  85
  86 sub Q ;
  87
  88 # Global Constants
  89
  90 $XSUBPP_version = "1.9506";
  91
  92 my ($Is_VMS, $SymSet);
  93 if ($^O eq 'VMS') {
  94     $Is_VMS = 1;
  95     # Establish set of global symbols with max length 28, since xsubpp
  96     # will later add the 'XS_' prefix.
  97     require ExtUtils::XSSymSet;
  98     $SymSet = new ExtUtils::XSSymSet 28;
  99 }
 100
 101 $FH = 'File0000' ;
 102
 103 $usage = "Usage: xsubpp [-v] [-C++] [-except] [-prototypes] [-noversioncheck] [-nolinenumbers] [-s pattern] [-typemap typemap]... file.xs\n";
 104
 105 $proto_re = "[" . quotemeta('\$%&*@;') . "]" ;
 106
 107 $except = "";
 108 $WantPrototypes = -1 ;
 109 $WantVersionChk = 1 ;
 110 $ProtoUsed = 0 ;
 111 $WantLineNumbers = 1 ;
 112 SWITCH: while (@ARGV and $ARGV[0] =~ /^-./) {
 113     $flag = shift @ARGV;
 114     $flag =~ s/^-// ;
 115     $spat = quotemeta shift,    next SWITCH     if $flag eq 's';
 116     $cplusplus = 1,     next SWITCH     if $flag eq 'C++';
 117     $WantPrototypes = 0, next SWITCH    if $flag eq 'noprototypes';
 118     $WantPrototypes = 1, next SWITCH    if $flag eq 'prototypes';
 119     $WantVersionChk = 0, next SWITCH    if $flag eq 'noversioncheck';
 120     $WantVersionChk = 1, next SWITCH    if $flag eq 'versioncheck';
 121     $except = " TRY",   next SWITCH     if $flag eq 'except';
 122     push(@tm,shift),    next SWITCH     if $flag eq 'typemap';
 123     $WantLineNumbers = 0, next SWITCH   if $flag eq 'nolinenumbers';
 124     $WantLineNumbers = 1, next SWITCH   if $flag eq 'linenumbers';
 125     (print "xsubpp version $XSUBPP_version\n"), exit
 126         if $flag eq 'v';
 127     die $usage;
 128 }
 129 if ($WantPrototypes == -1)
 130   { $WantPrototypes = 0}
 131 else
 132   { $ProtoUsed = 1 }
 133
 134
 135 @ARGV == 1 or die $usage;
 136 ($dir, $filename) = $ARGV[0] =~ m#(.*)/(.*)#
 137         or ($dir, $filename) = $ARGV[0] =~ m#(.*)\\(.*)#
 138         or ($dir, $filename) = $ARGV[0] =~ m#(.*[>\]])(.*)#
 139         or ($dir, $filename) = ('.', $ARGV[0]);
 140 chdir($dir);
 141 $pwd = cwd();
 142
 143 ++ $IncludedFiles{$ARGV[0]} ;
 144
 145 my(@XSStack) = ({type => 'none'});      # Stack of conditionals and INCLUDEs
 146 my($XSS_work_idx, $cpp_next_tmp) = (0, "XSubPPtmpAAAA");
 147
 148
 149 sub TrimWhitespace
 150 {
 151     $_[0] =~ s/^\s+|\s+$//go ;
 152 }
 153
 154 sub TidyType
 155 {
 156     local ($_) = @_ ;
 157
 158     # rationalise any '*' by joining them into bunches and removing whitespace
 159     s#\s*(\*+)\s*#$1#g;
 160     s#(\*+)# $1 #g ;
 161
 162     # change multiple whitespace into a single space
 163     s/\s+/ /g ;
 164
 165     # trim leading & trailing whitespace
 166     TrimWhitespace($_) ;
 167
 168     $_ ;
 169 }
 170
 171 $typemap = shift @ARGV;
 172 foreach $typemap (@tm) {
 173     die "Can't find $typemap in $pwd\n" unless -r $typemap;
 174 }
 175 unshift @tm, qw(../../../../lib/ExtUtils/typemap ../../../lib/ExtUtils/typemap
 176                 ../../lib/ExtUtils/typemap ../../../typemap ../../typemap
 177                 ../typemap typemap);
 178 foreach $typemap (@tm) {
 179     next unless -e $typemap ;
 180     # skip directories, binary files etc.
 181     warn("Warning: ignoring non-text typemap file '$typemap'\n"), next
 182         unless -T $typemap ;
 183     open(TYPEMAP, $typemap)
 184         or warn ("Warning: could not open typemap file '$typemap': $!\n"), next;
 185     $mode = 'Typemap';
 186     $junk = "" ;
 187     $current = \$junk;
 188     while (<TYPEMAP>) {
 189         next if /^\s*#/;
 190         my $line_no = $. + 1;
 191         if (/^INPUT\s*$/)   { $mode = 'Input';   $current = \$junk;  next; }
 192         if (/^OUTPUT\s*$/)  { $mode = 'Output';  $current = \$junk;  next; }
 193         if (/^TYPEMAP\s*$/) { $mode = 'Typemap'; $current = \$junk;  next; }
 194         if ($mode eq 'Typemap') {
 195             chomp;
 196             my $line = $_ ;
 197             TrimWhitespace($_) ;
 198             # skip blank lines and comment lines
 199             next if /^$/ or /^#/ ;
 200             my($type,$kind, $proto) = /^\s*(.*?\S)\s+(\S+)\s*($proto_re*)\s*$/ or
 201                 warn("Warning: File '$typemap' Line $. '$line' TYPEMAP entry needs 2 or 3 columns\n"), next;
 202             $type = TidyType($type) ;
 203             $type_kind{$type} = $kind ;
 204             # prototype defaults to '$'
 205             $proto = "\$" unless $proto ;
 206             warn("Warning: File '$typemap' Line $. '$line' Invalid prototype '$proto'\n")
 207                 unless ValidProtoString($proto) ;
 208             $proto_letter{$type} = C_string($proto) ;
 209         }
 210         elsif (/^\s/) {
 211             $$current .= $_;
 212         }
 213         elsif ($mode eq 'Input') {
 214             s/\s+$//;
 215             $input_expr{$_} = '';
 216             $current = \$input_expr{$_};
 217         }
 218         else {
 219             s/\s+$//;
 220             $output_expr{$_} = '';
 221             $current = \$output_expr{$_};
 222         }
 223     }
 224     close(TYPEMAP);
 225 }
 226
 227 foreach $key (keys %input_expr) {
 228     $input_expr{$key} =~ s/\n+$//;
 229 }
 230
 231 $END = "!End!\n\n";             # "impossible" keyword (multiple newline)
 232
 233 # Match an XS keyword
 234 $BLOCK_re= '\s*(' . join('|', qw(
 235         REQUIRE BOOT CASE PREINIT INPUT INIT CODE PPCODE OUTPUT
 236         CLEANUP ALIAS PROTOTYPES PROTOTYPE VERSIONCHECK INCLUDE
 237         SCOPE
 238         )) . "|$END)\\s*:";
 239
 240 # Input:  ($_, @line) == unparsed input.
 241 # Output: ($_, @line) == (rest of line, following lines).
 242 # Return: the matched keyword if found, otherwise 0
 243 sub check_keyword {
 244         $_ = shift(@line) while !/\S/ && @line;
 245         s/^(\s*)($_[0])\s*:\s*(?:#.*)?/$1/s && $2;
 246 }
 247
 248
 249 if ($WantLineNumbers) {
 250     {
 251         package xsubpp::counter;
 252         sub TIEHANDLE {
 253             my ($class, $cfile) = @_;
 254             my $buf = "";
 255             $SECTION_END_MARKER = "#line --- \"$cfile\"";
 256             $line_no = 1;
 257             bless \$buf;
 258         }
 259
 260         sub PRINT {
 261             my $self = shift;
 262             for (@_) {
 263                 $$self .= $_;
 264                 while ($$self =~ s/^([^\n]*\n)//) {
 265                     my $line = $1;
 266                     ++ $line_no;
 267                     $line =~ s|^\#line\s+---(?=\s)|#line $line_no|;
 268                     print STDOUT $line;
 269                 }
 270             }
 271         }
 272
 273         sub PRINTF {
 274             my $self = shift;
 275             my $fmt = shift;
 276             $self->PRINT(sprintf($fmt, @_));
 277         }
 278
 279         sub DESTROY {
 280             # Not necessary if we're careful to end with a "\n"
 281             my $self = shift;
 282             print STDOUT $$self;
 283         }
 284     }
 285
 286     my $cfile = $filename;
 287     $cfile =~ s/\.xs$/.c/i or $cfile .= ".c";
 288     tie(*PSEUDO_STDOUT, 'xsubpp::counter', $cfile);
 289     select PSEUDO_STDOUT;
 290 }
 291
 292 sub print_section {
 293     # the "do" is required for right semantics
 294     do { $_ = shift(@line) } while !/\S/ && @line;
 295
 296     print("#line ", $line_no[@line_no - @line -1], " \"$filename\"\n")
 297         if $WantLineNumbers && !/^\s*#\s*line\b/ && !/^#if XSubPPtmp/;
 298     for (;  defined($_) && !/^$BLOCK_re/o;  $_ = shift(@line)) {
 299         print "$_\n";
 300     }
 301     print "$xsubpp::counter::SECTION_END_MARKER\n" if $WantLineNumbers;
 302 }
 303
 304 sub process_keyword($)
 305 {
 306     my($pattern) = @_ ;
 307     my $kwd ;
 308
 309     &{"${kwd}_handler"}()
 310         while $kwd = check_keyword($pattern) ;
 311 }
 312
 313 sub CASE_handler {
 314     blurt ("Error: `CASE:' after unconditional `CASE:'")
 315         if $condnum && $cond eq '';
 316     $cond = $_;
 317     TrimWhitespace($cond);
 318     print "   ", ($condnum++ ? " else" : ""), ($cond ? " if ($cond)\n" : "\n");
 319     $_ = '' ;
 320 }
 321
 322 sub INPUT_handler {
 323     for (;  !/^$BLOCK_re/o;  $_ = shift(@line)) {
 324         last if /^\s*NOT_IMPLEMENTED_YET/;
 325         next unless /\S/;       # skip blank lines
 326
 327         TrimWhitespace($_) ;
 328         my $line = $_ ;
 329
 330         # remove trailing semicolon if no initialisation
 331         s/\s*;$//g unless /=/ ;
 332
 333         # check for optional initialisation code
 334         my $var_init = '' ;
 335         $var_init = $1 if s/\s*(=.*)$//s ;
 336         $var_init =~ s/"/\\"/g;
 337
 338         s/\s+/ /g;
 339         my ($var_type, $var_addr, $var_name) = /^(.*?[^& ]) *(\&?) *\b(\w+)$/s
 340             or blurt("Error: invalid argument declaration '$line'"), next;
 341
 342         # Check for duplicate definitions
 343         blurt ("Error: duplicate definition of argument '$var_name' ignored"), next
 344             if $arg_list{$var_name} ++  ;
 345
 346         $thisdone |= $var_name eq "THIS";
 347         $retvaldone |= $var_name eq "RETVAL";
 348         $var_types{$var_name} = $var_type;
 349         print "\t" . &map_type($var_type);
 350         $var_num = $args_match{$var_name};
 351
 352         $proto_arg[$var_num] = ProtoString($var_type)
 353             if $var_num ;
 354         if ($var_addr) {
 355             $var_addr{$var_name} = 1;
 356             $func_args =~ s/\b($var_name)\b/&$1/;
 357         }
 358         if ($var_init =~ /^=\s*NO_INIT\s*;?\s*$/) {
 359             print "\t$var_name;\n";
 360         } elsif ($var_init =~ /\S/) {
 361             &output_init($var_type, $var_num, "$var_name $var_init");
 362         } elsif ($var_num) {
 363             # generate initialization code
 364             &generate_init($var_type, $var_num, $var_name);
 365         } else {
 366             print ";\n";
 367         }
 368     }
 369 }
 370
 371 sub OUTPUT_handler {
 372     for (;  !/^$BLOCK_re/o;  $_ = shift(@line)) {
 373         next unless /\S/;
 374         if (/^\s*SETMAGIC\s*:\s*(ENABLE|DISABLE)\s*/) {
 375             $DoSetMagic = ($1 eq "ENABLE" ? 1 : 0);
 376             next;
 377         }
 378         my ($outarg, $outcode) = /^\s*(\S+)\s*(.*?)\s*$/s ;
 379         blurt ("Error: duplicate OUTPUT argument '$outarg' ignored"), next
 380             if $outargs{$outarg} ++ ;
 381         if (!$gotRETVAL and $outarg eq 'RETVAL') {
 382             # deal with RETVAL last
 383             $RETVAL_code = $outcode ;
 384             $gotRETVAL = 1 ;
 385             next ;
 386         }
 387         blurt ("Error: OUTPUT $outarg not an argument"), next
 388             unless defined($args_match{$outarg});
 389         blurt("Error: No input definition for OUTPUT argument '$outarg' - ignored"), next
 390             unless defined $var_types{$outarg} ;
 391         if ($outcode) {
 392             print "\t$outcode\n";
 393             print "\tSvSETMAGIC(ST(" . $var_num-1 . "));\n" if $DoSetMagic;
 394         } else {
 395             $var_num = $args_match{$outarg};
 396             &generate_output($var_types{$outarg}, $var_num, $outarg, $DoSetMagic);
 397         }
 398     }
 399 }
 400
 401 sub CLEANUP_handler() { print_section() }
 402 sub PREINIT_handler() { print_section() }
 403 sub INIT_handler()    { print_section() }
 404
 405 sub GetAliases
 406 {
 407     my ($line) = @_ ;
 408     my ($orig) = $line ;
 409     my ($alias) ;
 410     my ($value) ;
 411
 412     # Parse alias definitions
 413     # format is
 414     #    alias = value alias = value ...
 415
 416     while ($line =~ s/^\s*([\w:]+)\s*=\s*(\w+)\s*//) {
 417         $alias = $1 ;
 418         $orig_alias = $alias ;
 419         $value = $2 ;
 420
 421         # check for optional package definition in the alias
 422         $alias = $Packprefix . $alias if $alias !~ /::/ ;
 423
 424         # check for duplicate alias name & duplicate value
 425         Warn("Warning: Ignoring duplicate alias '$orig_alias'")
 426             if defined $XsubAliases{$alias} ;
 427
 428         Warn("Warning: Aliases '$orig_alias' and '$XsubAliasValues{$value}' have identical values")
 429             if $XsubAliasValues{$value} ;
 430
 431         $XsubAliases = 1;
 432         $XsubAliases{$alias} = $value ;
 433         $XsubAliasValues{$value} = $orig_alias ;
 434     }
 435
 436     blurt("Error: Cannot parse ALIAS definitions from '$orig'")
 437         if $line ;
 438 }
 439
 440 sub ALIAS_handler ()
 441 {
 442     for (;  !/^$BLOCK_re/o;  $_ = shift(@line)) {
 443         next unless /\S/;
 444         TrimWhitespace($_) ;
 445         GetAliases($_) if $_ ;
 446     }
 447 }
 448
 449 sub REQUIRE_handler ()
 450 {
 451     # the rest of the current line should contain a version number
 452     my ($Ver) = $_ ;
 453
 454     TrimWhitespace($Ver) ;
 455
 456     death ("Error: REQUIRE expects a version number")
 457         unless $Ver ;
 458
 459     # check that the version number is of the form n.n
 460     death ("Error: REQUIRE: expected a number, got '$Ver'")
 461         unless $Ver =~ /^\d+(\.\d*)?/ ;
 462
 463     death ("Error: xsubpp $Ver (or better) required--this is only $XSUBPP_version.")
 464         unless $XSUBPP_version >= $Ver ;
 465 }
 466
 467 sub VERSIONCHECK_handler ()
 468 {
 469     # the rest of the current line should contain either ENABLE or
 470     # DISABLE
 471
 472     TrimWhitespace($_) ;
 473
 474     # check for ENABLE/DISABLE
 475     death ("Error: VERSIONCHECK: ENABLE/DISABLE")
 476         unless /^(ENABLE|DISABLE)/i ;
 477
 478     $WantVersionChk = 1 if $1 eq 'ENABLE' ;
 479     $WantVersionChk = 0 if $1 eq 'DISABLE' ;
 480
 481 }
 482
 483 sub PROTOTYPE_handler ()
 484 {
 485     my $specified ;
 486
 487     death("Error: Only 1 PROTOTYPE definition allowed per xsub")
 488         if $proto_in_this_xsub ++ ;
 489
 490     for (;  !/^$BLOCK_re/o;  $_ = shift(@line)) {
 491         next unless /\S/;
 492         $specified = 1 ;
 493         TrimWhitespace($_) ;
 494         if ($_ eq 'DISABLE') {
 495            $ProtoThisXSUB = 0
 496         }
 497         elsif ($_ eq 'ENABLE') {
 498            $ProtoThisXSUB = 1
 499         }
 500         else {
 501             # remove any whitespace
 502             s/\s+//g ;
 503             death("Error: Invalid prototype '$_'")
 504                 unless ValidProtoString($_) ;
 505             $ProtoThisXSUB = C_string($_) ;
 506         }
 507     }
 508
 509     # If no prototype specified, then assume empty prototype ""
 510     $ProtoThisXSUB = 2 unless $specified ;
 511
 512     $ProtoUsed = 1 ;
 513
 514 }
 515
 516 sub SCOPE_handler ()
 517 {
 518     death("Error: Only 1 SCOPE declaration allowed per xsub")
 519         if $scope_in_this_xsub ++ ;
 520
 521     for (;  !/^$BLOCK_re/o;  $_ = shift(@line)) {
 522                 next unless /\S/;
 523                 TrimWhitespace($_) ;
 524         if ($_ =~ /^DISABLE/i) {
 525                    $ScopeThisXSUB = 0
 526         }
 527         elsif ($_ =~ /^ENABLE/i) {
 528                    $ScopeThisXSUB = 1
 529         }
 530     }
 531
 532 }
 533
 534 sub PROTOTYPES_handler ()
 535 {
 536     # the rest of the current line should contain either ENABLE or
 537     # DISABLE
 538
 539     TrimWhitespace($_) ;
 540
 541     # check for ENABLE/DISABLE
 542     death ("Error: PROTOTYPES: ENABLE/DISABLE")
 543         unless /^(ENABLE|DISABLE)/i ;
 544
 545     $WantPrototypes = 1 if $1 eq 'ENABLE' ;
 546     $WantPrototypes = 0 if $1 eq 'DISABLE' ;
 547     $ProtoUsed = 1 ;
 548
 549 }
 550
 551 sub INCLUDE_handler ()
 552 {
 553     # the rest of the current line should contain a valid filename
 554
 555     TrimWhitespace($_) ;
 556
 557     death("INCLUDE: filename missing")
 558         unless $_ ;
 559
 560     death("INCLUDE: output pipe is illegal")
 561         if /^\s*\|/ ;
 562
 563     # simple minded recursion detector
 564     death("INCLUDE loop detected")
 565         if $IncludedFiles{$_} ;
 566
 567     ++ $IncludedFiles{$_} unless /\|\s*$/ ;
 568
 569     # Save the current file context.
 570     push(@XSStack, {
 571         type            => 'file',
 572         LastLine        => $lastline,
 573         LastLineNo      => $lastline_no,
 574         Line            => \@line,
 575         LineNo          => \@line_no,
 576         Filename        => $filename,
 577         Handle          => $FH,
 578         }) ;
 579
 580     ++ $FH ;
 581
 582     # open the new file
 583     open ($FH, "$_") or death("Cannot open '$_': $!") ;
 584
 585     print Q<<"EOF" ;
 586 #
 587 #/* INCLUDE:  Including '$_' from '$filename' */
 588 #
 589 EOF
 590
 591     $filename = $_ ;
 592
 593     # Prime the pump by reading the first
 594     # non-blank line
 595
 596     # skip leading blank lines
 597     while (<$FH>) {
 598         last unless /^\s*$/ ;
 599     }
 600
 601     $lastline = $_ ;
 602     $lastline_no = $. ;
 603
 604 }
 605
 606 sub PopFile()
 607 {
 608     return 0 unless $XSStack[-1]{type} eq 'file' ;
 609
 610     my $data     = pop @XSStack ;
 611     my $ThisFile = $filename ;
 612     my $isPipe   = ($filename =~ /\|\s*$/) ;
 613
 614     -- $IncludedFiles{$filename}
 615         unless $isPipe ;
 616
 617     close $FH ;
 618
 619     $FH         = $data->{Handle} ;
 620     $filename   = $data->{Filename} ;
 621     $lastline   = $data->{LastLine} ;
 622     $lastline_no = $data->{LastLineNo} ;
 623     @line       = @{ $data->{Line} } ;
 624     @line_no    = @{ $data->{LineNo} } ;
 625
 626     if ($isPipe and $? ) {
 627         -- $lastline_no ;
 628         print STDERR "Error reading from pipe '$ThisFile': $! in $filename, line $lastline_no\n"  ;
 629         exit 1 ;
 630     }
 631
 632     print Q<<"EOF" ;
 633 #
 634 #/* INCLUDE: Returning to '$filename' from '$ThisFile' */
 635 #
 636 EOF
 637
 638     return 1 ;
 639 }
 640
 641 sub ValidProtoString ($)
 642 {
 643     my($string) = @_ ;
 644
 645     if ( $string =~ /^$proto_re+$/ ) {
 646         return $string ;
 647     }
 648
 649     return 0 ;
 650 }
 651
 652 sub C_string ($)
 653 {
 654     my($string) = @_ ;
 655
 656     $string =~ s[\\][\\\\]g ;
 657     $string ;
 658 }
 659
 660 sub ProtoString ($)
 661 {
 662     my ($type) = @_ ;
 663
 664     $proto_letter{$type} or "\$" ;
 665 }
 666
 667 sub check_cpp {
 668     my @cpp = grep(/^\#\s*(?:if|e\w+)/, @line);
 669     if (@cpp) {
 670         my ($cpp, $cpplevel);
 671         for $cpp (@cpp) {
 672             if ($cpp =~ /^\#\s*if/) {
 673                 $cpplevel++;
 674             } elsif (!$cpplevel) {
 675                 Warn("Warning: #else/elif/endif without #if in this function");
 676                 print STDERR "    (precede it with a blank line if the matching #if is outside the function)\n"
 677                     if $XSStack[-1]{type} eq 'if';
 678                 return;
 679             } elsif ($cpp =~ /^\#\s*endif/) {
 680                 $cpplevel--;
 681             }
 682         }
 683         Warn("Warning: #if without #endif in this function") if $cpplevel;
 684     }
 685 }
 686
 687
 688 sub Q {
 689     my($text) = @_;
 690     $text =~ s/^#//gm;
 691     $text =~ s/\[\[/{/g;
 692     $text =~ s/\]\]/}/g;
 693     $text;
 694 }
 695
 696 open($FH, $filename) or die "cannot open $filename: $!\n";
 697
 698 # Identify the version of xsubpp used
 699 print <<EOM ;
 700 /*
 701  * This file was generated automatically by xsubpp version $XSUBPP_version from the
 702  * contents of $filename. Do not edit this file, edit $filename instead.
 703  *
 704  *      ANY CHANGES MADE HERE WILL BE LOST!
 705  *
 706  */
 707
 708 EOM
 709
 710
 711 print("#line 1 \"$filename\"\n")
 712     if $WantLineNumbers;
 713
 714 while (<$FH>) {
 715     last if ($Module, $Package, $Prefix) =
 716         /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/;
 717     print $_;
 718 }
 719 &Exit unless defined $_;
 720
 721 $lastline    = $_;
 722 $lastline_no = $.;
 723
 724 # Read next xsub into @line from ($lastline, <$FH>).
 725 sub fetch_para {
 726     # parse paragraph
 727     death ("Error: Unterminated `#if/#ifdef/#ifndef'")
 728         if !defined $lastline && $XSStack[-1]{type} eq 'if';
 729     @line = ();
 730     @line_no = () ;
 731     return PopFile() if !defined $lastline;
 732
 733     if ($lastline =~
 734         /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/) {
 735         $Module = $1;
 736         $Package = defined($2) ? $2 : '';       # keep -w happy
 737         $Prefix  = defined($3) ? $3 : '';       # keep -w happy
 738         $Prefix = quotemeta $Prefix ;
 739         ($Module_cname = $Module) =~ s/\W/_/g;
 740         ($Packid = $Package) =~ tr/:/_/;
 741         $Packprefix = $Package;
 742         $Packprefix .= "::" if $Packprefix ne "";
 743         $lastline = "";
 744     }
 745
 746     for(;;) {
 747         if ($lastline !~ /^\s*#/ ||
 748             # CPP directives:
 749             #   ANSI:   if ifdef ifndef elif else endif define undef
 750             #           line error pragma
 751             #   gcc:    warning include_next
 752             #   obj-c:  import
 753             #   others: ident (gcc notes that some cpps have this one)
 754             $lastline =~ /^#[ \t]*(?:(?:if|ifn?def|elif|else|endif|define|undef|pragma|error|warning|line\s+\d+|ident)\b|(?:include(?:_next)?|import)\s*["<].*[>"])/) {
 755             last if $lastline =~ /^\S/ && @line && $line[-1] eq "";
 756             push(@line, $lastline);
 757             push(@line_no, $lastline_no) ;
 758         }
 759
 760         # Read next line and continuation lines
 761         last unless defined($lastline = <$FH>);
 762         $lastline_no = $.;
 763         my $tmp_line;
 764         $lastline .= $tmp_line
 765             while ($lastline =~ /\\$/ && defined($tmp_line = <$FH>));
 766
 767         chomp $lastline;
 768         $lastline =~ s/^\s+$//;
 769     }
 770     pop(@line), pop(@line_no) while @line && $line[-1] eq "";
 771     1;
 772 }
 773
 774 PARAGRAPH:
 775 while (fetch_para()) {
 776     # Print initial preprocessor statements and blank lines
 777     while (@line && $line[0] !~ /^[^\#]/) {
 778         my $line = shift(@line);
 779         print $line, "\n";
 780         next unless $line =~ /^\#\s*((if)(?:n?def)?|elsif|else|endif)\b/;
 781         my $statement = $+;
 782         if ($statement eq 'if') {
 783             $XSS_work_idx = @XSStack;
 784             push(@XSStack, {type => 'if'});
 785         } else {
 786             death ("Error: `$statement' with no matching `if'")
 787                 if $XSStack[-1]{type} ne 'if';
 788             if ($XSStack[-1]{varname}) {
 789                 push(@InitFileCode, "#endif\n");
 790                 push(@BootCode,     "#endif");
 791             }
 792
 793             my(@fns) = keys %{$XSStack[-1]{functions}};
 794             if ($statement ne 'endif') {
 795                 # Hide the functions defined in other #if branches, and reset.
 796                 @{$XSStack[-1]{other_functions}}{@fns} = (1) x @fns;
 797                 @{$XSStack[-1]}{qw(varname functions)} = ('', {});
 798             } else {
 799                 my($tmp) = pop(@XSStack);
 800                 0 while (--$XSS_work_idx
 801                          && $XSStack[$XSS_work_idx]{type} ne 'if');
 802                 # Keep all new defined functions
 803                 push(@fns, keys %{$tmp->{other_functions}});
 804                 @{$XSStack[$XSS_work_idx]{functions}}{@fns} = (1) x @fns;
 805             }
 806         }
 807     }
 808
 809     next PARAGRAPH unless @line;
 810
 811     if ($XSS_work_idx && !$XSStack[$XSS_work_idx]{varname}) {
 812         # We are inside an #if, but have not yet #defined its xsubpp variable.
 813         print "#define $cpp_next_tmp 1\n\n";
 814         push(@InitFileCode, "#if $cpp_next_tmp\n");
 815         push(@BootCode,     "#if $cpp_next_tmp");
 816         $XSStack[$XSS_work_idx]{varname} = $cpp_next_tmp++;
 817     }
 818
 819     death ("Code is not inside a function"
 820            ." (maybe last function was ended by a blank line "
 821            ." followed by a a statement on column one?)")
 822         if $line[0] =~ /^\s/;
 823
 824     # initialize info arrays
 825     undef(%args_match);
 826     undef(%var_types);
 827     undef(%var_addr);
 828     undef(%defaults);
 829     undef($class);
 830     undef($static);
 831     undef($elipsis);
 832     undef($wantRETVAL) ;
 833     undef(%arg_list) ;
 834     undef(@proto_arg) ;
 835     undef($proto_in_this_xsub) ;
 836     undef($scope_in_this_xsub) ;
 837     $ProtoThisXSUB = $WantPrototypes ;
 838     $ScopeThisXSUB = 0;
 839
 840     $_ = shift(@line);
 841     while ($kwd = check_keyword("REQUIRE|PROTOTYPES|VERSIONCHECK|INCLUDE")) {
 842         &{"${kwd}_handler"}() ;
 843         next PARAGRAPH unless @line ;
 844         $_ = shift(@line);
 845     }
 846
 847     if (check_keyword("BOOT")) {
 848         &check_cpp;
 849         push (@BootCode, "#line $line_no[@line_no - @line] \"$filename\"")
 850           if $WantLineNumbers && $line[0] !~ /^\s*#\s*line\b/;
 851         push (@BootCode, @line, "") ;
 852         next PARAGRAPH ;
 853     }
 854
 855
 856     # extract return type, function name and arguments
 857     my($ret_type) = TidyType($_);
 858
 859     # a function definition needs at least 2 lines
 860     blurt ("Error: Function definition too short '$ret_type'"), next PARAGRAPH
 861         unless @line ;
 862
 863     $static = 1 if $ret_type =~ s/^static\s+//;
 864
 865     $func_header = shift(@line);
 866     blurt ("Error: Cannot parse function definition from '$func_header'"), next PARAGRAPH
 867         unless $func_header =~ /^(?:([\w:]*)::)?(\w+)\s*\(\s*(.*?)\s*\)\s*$/s;
 868
 869     ($class, $func_name, $orig_args) =  ($1, $2, $3) ;
 870     ($pname = $func_name) =~ s/^($Prefix)?/$Packprefix/;
 871     ($clean_func_name = $func_name) =~ s/^$Prefix//;
 872     $Full_func_name = "${Packid}_$clean_func_name";
 873     if ($Is_VMS) { $Full_func_name = $SymSet->addsym($Full_func_name); }
 874
 875     # Check for duplicate function definition
 876     for $tmp (@XSStack) {
 877         next unless defined $tmp->{functions}{$Full_func_name};
 878         Warn("Warning: duplicate function definition '$clean_func_name' detected");
 879         last;
 880     }
 881     $XSStack[$XSS_work_idx]{functions}{$Full_func_name} ++ ;
 882     %XsubAliases = %XsubAliasValues = ();
 883     $DoSetMagic = 1;
 884
 885     @args = split(/\s*,\s*/, $orig_args);
 886     if (defined($class)) {
 887         my $arg0 = ((defined($static) or $func_name eq 'new')
 888                     ? "CLASS" : "THIS");
 889         unshift(@args, $arg0);
 890         ($orig_args = "$arg0, $orig_args") =~ s/^$arg0, $/$arg0/;
 891     }
 892     $orig_args =~ s/"/\\"/g;
 893     $min_args = $num_args = @args;
 894     foreach $i (0..$num_args-1) {
 895             if ($args[$i] =~ s/\.\.\.//) {
 896                     $elipsis = 1;
 897                     $min_args--;
 898                     if ($args[$i] eq '' && $i == $num_args - 1) {
 899                         pop(@args);
 900                         last;
 901                     }
 902             }
 903             if ($args[$i] =~ /^([^=]*[^\s=])\s*=\s*(.*)/s) {
 904                     $min_args--;
 905                     $args[$i] = $1;
 906                     $defaults{$args[$i]} = $2;
 907                     $defaults{$args[$i]} =~ s/"/\\"/g;
 908             }
 909             $proto_arg[$i+1] = "\$" ;
 910     }
 911     if (defined($class)) {
 912             $func_args = join(", ", @args[1..$#args]);
 913     } else {
 914             $func_args = join(", ", @args);
 915     }
 916     @args_match{@args} = 1..@args;
 917
 918     $PPCODE = grep(/^\s*PPCODE\s*:/, @line);
 919     $CODE = grep(/^\s*CODE\s*:/, @line);
 920     # Detect CODE: blocks which use ST(n)= or XST_m*(n,v)
 921     #   to set explicit return values.
 922     $EXPLICIT_RETURN = ($CODE &&
 923                 ("@line" =~ /(\bST\s*\([^;]*=) | (\bXST_m\w+\s*\()/x ));
 924     $ALIAS  = grep(/^\s*ALIAS\s*:/,  @line);
 925
 926     # print function header
 927     print Q<<"EOF";
 928 #XS(XS_${Full_func_name})
 929 #[[
 930 #    dXSARGS;
 931 EOF
 932     print Q<<"EOF" if $ALIAS ;
 933 #    dXSI32;
 934 EOF
 935     if ($elipsis) {
 936         $cond = ($min_args ? qq(items < $min_args) : 0);
 937     }
 938     elsif ($min_args == $num_args) {
 939         $cond = qq(items != $min_args);
 940     }
 941     else {
 942         $cond = qq(items < $min_args || items > $num_args);
 943     }
 944
 945     print Q<<"EOF" if $except;
 946 #    char errbuf[1024];
 947 #    *errbuf = '\0';
 948 EOF
 949
 950     if ($ALIAS)
 951       { print Q<<"EOF" if $cond }
 952 #    if ($cond)
 953 #       croak("Usage: %s($orig_args)", GvNAME(CvGV(cv)));
 954 EOF
 955     else
 956       { print Q<<"EOF" if $cond }
 957 #    if ($cond)
 958 #       croak("Usage: $pname($orig_args)");
 959 EOF
 960
 961     print Q<<"EOF" if $PPCODE;
 962 #    SP -= items;
 963 EOF
 964
 965     # Now do a block of some sort.
 966
 967     $condnum = 0;
 968     $cond = '';                 # last CASE: condidional
 969     push(@line, "$END:");
 970     push(@line_no, $line_no[-1]);
 971     $_ = '';
 972     &check_cpp;
 973     while (@line) {
 974         &CASE_handler if check_keyword("CASE");
 975         print Q<<"EOF";
 976 #   $except [[
 977 EOF
 978
 979         # do initialization of input variables
 980         $thisdone = 0;
 981         $retvaldone = 0;
 982         $deferred = "";
 983         %arg_list = () ;
 984         $gotRETVAL = 0;
 985
 986         INPUT_handler() ;
 987         process_keyword("INPUT|PREINIT|ALIAS|PROTOTYPE|SCOPE") ;
 988
 989         print Q<<"EOF" if $ScopeThisXSUB;
 990 #   ENTER;
 991 #   [[
 992 EOF
 993
 994         if (!$thisdone && defined($class)) {
 995             if (defined($static) or $func_name eq 'new') {
 996                 print "\tchar *";
 997                 $var_types{"CLASS"} = "char *";
 998                 &generate_init("char *", 1, "CLASS");
 999             }
1000             else {
1001                 print "\t$class *";
1002                 $var_types{"THIS"} = "$class *";
1003                 &generate_init("$class *", 1, "THIS");
1004             }
1005         }
1006
1007         # do code
1008         if (/^\s*NOT_IMPLEMENTED_YET/) {
1009                 print "\n\tcroak(\"$pname: not implemented yet\");\n";
1010                 $_ = '' ;
1011         } else {
1012                 if ($ret_type ne "void") {
1013                         print "\t" . &map_type($ret_type) . "\tRETVAL;\n"
1014                                 if !$retvaldone;
1015                         $args_match{"RETVAL"} = 0;
1016                         $var_types{"RETVAL"} = $ret_type;
1017                 }
1018
1019                 print $deferred;
1020
1021         process_keyword("INIT|ALIAS|PROTOTYPE") ;
1022
1023                 if (check_keyword("PPCODE")) {
1024                         print_section();
1025                         death ("PPCODE must be last thing") if @line;
1026                         print "\tLEAVE;\n" if $ScopeThisXSUB;
1027                         print "\tPUTBACK;\n\treturn;\n";
1028                 } elsif (check_keyword("CODE")) {
1029                         print_section() ;
1030                 } elsif (defined($class) and $func_name eq "DESTROY") {
1031                         print "\n\t";
1032                         print "delete THIS;\n";
1033                 } else {
1034                         print "\n\t";
1035                         if ($ret_type ne "void") {
1036                                 print "RETVAL = ";
1037                                 $wantRETVAL = 1;
1038                         }
1039                         if (defined($static)) {
1040                             if ($func_name eq 'new') {
1041                                 $func_name = "$class";
1042                             } else {
1043                                 print "${class}::";
1044                             }
1045                         } elsif (defined($class)) {
1046                             if ($func_name eq 'new') {
1047                                 $func_name .= " $class";
1048                             } else {
1049                                 print "THIS->";
1050                             }
1051                         }
1052                         $func_name =~ s/^($spat)//
1053                             if defined($spat);
1054                         print "$func_name($func_args);\n";
1055                 }
1056         }
1057
1058         # do output variables
1059         $gotRETVAL = 0;
1060         undef $RETVAL_code ;
1061         undef %outargs ;
1062         process_keyword("OUTPUT|ALIAS|PROTOTYPE");
1063
1064         # all OUTPUT done, so now push the return value on the stack
1065         if ($gotRETVAL && $RETVAL_code) {
1066             print "\t$RETVAL_code\n";
1067         } elsif ($gotRETVAL || $wantRETVAL) {
1068             # RETVAL almost never needs SvSETMAGIC()
1069             &generate_output($ret_type, 0, 'RETVAL', 0);
1070         }
1071
1072         # do cleanup
1073         process_keyword("CLEANUP|ALIAS|PROTOTYPE") ;
1074
1075         print Q<<"EOF" if $ScopeThisXSUB;
1076 #   ]]
1077 EOF
1078         print Q<<"EOF" if $ScopeThisXSUB and not $PPCODE;
1079 #   LEAVE;
1080 EOF
1081
1082         # print function trailer
1083         print Q<<EOF;
1084 #    ]]
1085 EOF
1086         print Q<<EOF if $except;
1087 #    BEGHANDLERS
1088 #    CATCHALL
1089 #       sprintf(errbuf, "%s: %s\\tpropagated", Xname, Xreason);
1090 #    ENDHANDLERS
1091 EOF
1092         if (check_keyword("CASE")) {
1093             blurt ("Error: No `CASE:' at top of function")
1094                 unless $condnum;
1095             $_ = "CASE: $_";    # Restore CASE: label
1096             next;
1097         }
1098         last if $_ eq "$END:";
1099         death(/^$BLOCK_re/o ? "Misplaced `$1:'" : "Junk at end of function");
1100     }
1101
1102     print Q<<EOF if $except;
1103 #    if (errbuf[0])
1104 #       croak(errbuf);
1105 EOF
1106
1107     if ($ret_type ne "void" or $EXPLICIT_RETURN) {
1108         print Q<<EOF unless $PPCODE;
1109 #    XSRETURN(1);
1110 EOF
1111     } else {
1112         print Q<<EOF unless $PPCODE;
1113 #    XSRETURN_EMPTY;
1114 EOF
1115     }
1116
1117     print Q<<EOF;
1118 #]]
1119 #
1120 EOF
1121
1122     my $newXS = "newXS" ;
1123     my $proto = "" ;
1124
1125     # Build the prototype string for the xsub
1126     if ($ProtoThisXSUB) {
1127         $newXS = "newXSproto";
1128
1129         if ($ProtoThisXSUB eq 2) {
1130             # User has specified empty prototype
1131             $proto = ', ""' ;
1132         }
1133         elsif ($ProtoThisXSUB ne 1) {
1134             # User has specified a prototype
1135             $proto = ', "' . $ProtoThisXSUB . '"';
1136         }
1137         else {
1138             my $s = ';';
1139             if ($min_args < $num_args)  {
1140                 $s = '';
1141                 $proto_arg[$min_args] .= ";" ;
1142             }
1143             push @proto_arg, "$s\@"
1144                 if $elipsis ;
1145
1146             $proto = ', "' . join ("", @proto_arg) . '"';
1147         }
1148     }
1149
1150     if (%XsubAliases) {
1151         $XsubAliases{$pname} = 0
1152             unless defined $XsubAliases{$pname} ;
1153         while ( ($name, $value) = each %XsubAliases) {
1154             push(@InitFileCode, Q<<"EOF");
1155 #        cv = newXS(\"$name\", XS_$Full_func_name, file);
1156 #        XSANY.any_i32 = $value ;
1157 EOF
1158         push(@InitFileCode, Q<<"EOF") if $proto;
1159 #        sv_setpv((SV*)cv$proto) ;
1160 EOF
1161         }
1162     }
1163     else {
1164         push(@InitFileCode,
1165              "        ${newXS}(\"$pname\", XS_$Full_func_name, file$proto);\n");
1166     }
1167 }
1168
1169 # print initialization routine
1170 print Q<<"EOF";
1171 ##ifdef __cplusplus
1172 #extern "C"
1173 ##endif
1174 #XS(boot_$Module_cname)
1175 #[[
1176 #    dXSARGS;
1177 #    char* file = __FILE__;
1178 #
1179 EOF
1180
1181 print Q<<"EOF" if $WantVersionChk ;
1182 #    XS_VERSION_BOOTCHECK ;
1183 #
1184 EOF
1185
1186 print Q<<"EOF" if defined $XsubAliases ;
1187 #    {
1188 #        CV * cv ;
1189 #
1190 EOF
1191
1192 print @InitFileCode;
1193
1194 print Q<<"EOF" if defined $XsubAliases ;
1195 #    }
1196 EOF
1197
1198 if (@BootCode)
1199 {
1200     print "\n    /* Initialisation Section */\n\n" ;
1201     @line = @BootCode;
1202     print_section();
1203     print "\n    /* End of Initialisation Section */\n\n" ;
1204 }
1205
1206 print Q<<"EOF";;
1207 #    ST(0) = &sv_yes;
1208 #    XSRETURN(1);
1209 #]]
1210 EOF
1211
1212 warn("Please specify prototyping behavior for $filename (see perlxs manual)\n")
1213     unless $ProtoUsed ;
1214 &Exit;
1215
1216
1217 sub output_init {
1218     local($type, $num, $init) = @_;
1219     local($arg) = "ST(" . ($num - 1) . ")";
1220
1221     eval qq/print " $init\\\n"/;
1222 }
1223
1224 sub Warn
1225 {
1226     # work out the line number
1227     my $line_no = $line_no[@line_no - @line -1] ;
1228
1229     print STDERR "@_ in $filename, line $line_no\n" ;
1230 }
1231
1232 sub blurt
1233 {
1234     Warn @_ ;
1235     $errors ++
1236 }
1237
1238 sub death
1239 {
1240     Warn @_ ;
1241     exit 1 ;
1242 }
1243
1244 sub generate_init {
1245     local($type, $num, $var) = @_;
1246     local($arg) = "ST(" . ($num - 1) . ")";
1247     local($argoff) = $num - 1;
1248     local($ntype);
1249     local($tk);
1250
1251     $type = TidyType($type) ;
1252     blurt("Error: '$type' not in typemap"), return
1253         unless defined($type_kind{$type});
1254
1255     ($ntype = $type) =~ s/\s*\*/Ptr/g;
1256     ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;
1257     $tk = $type_kind{$type};
1258     $tk =~ s/OBJ$/REF/ if $func_name =~ /DESTROY$/;
1259     $type =~ tr/:/_/;
1260     blurt("Error: No INPUT definition for type '$type' found"), return
1261         unless defined $input_expr{$tk} ;
1262     $expr = $input_expr{$tk};
1263     if ($expr =~ /DO_ARRAY_ELEM/) {
1264         blurt("Error: '$subtype' not in typemap"), return
1265             unless defined($type_kind{$subtype});
1266         blurt("Error: No INPUT definition for type '$subtype' found"), return
1267             unless defined $input_expr{$type_kind{$subtype}} ;
1268         $subexpr = $input_expr{$type_kind{$subtype}};
1269         $subexpr =~ s/ntype/subtype/g;
1270         $subexpr =~ s/\$arg/ST(ix_$var)/g;
1271         $subexpr =~ s/\n\t/\n\t\t/g;
1272         $subexpr =~ s/is not of (.*\")/[arg %d] is not of $1, ix_$var + 1/g;
1273         $subexpr =~ s/\$var/${var}[ix_$var - $argoff]/;
1274         $expr =~ s/DO_ARRAY_ELEM/$subexpr/;
1275     }
1276     if ($expr =~ m#/\*.*scope.*\*/#i) { # "scope" in C comments
1277         $ScopeThisXSUB = 1;
1278     }
1279     if (defined($defaults{$var})) {
1280             $expr =~ s/(\t+)/$1    /g;
1281             $expr =~ s/        /\t/g;
1282             eval qq/print "\\t$var;\\n"/;
1283             $deferred .= eval qq/"\\n\\tif (items < $num)\\n\\t    $var = $defaults{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/;
1284     } elsif ($ScopeThisXSUB or $expr !~ /^\t\$var =/) {
1285             eval qq/print "\\t$var;\\n"/;
1286             $deferred .= eval qq/"\\n$expr;\\n"/;
1287     } else {
1288             eval qq/print "$expr;\\n"/;
1289     }
1290 }
1291
1292 sub generate_output {
1293     local($type, $num, $var, $do_setmagic) = @_;
1294     local($arg) = "ST(" . ($num - ($num != 0)) . ")";
1295     local($argoff) = $num - 1;
1296     local($ntype);
1297
1298     $type = TidyType($type) ;
1299     if ($type =~ /^array\(([^,]*),(.*)\)/) {
1300             print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1)), XFree((char *)$var);\n";
1301             print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
1302     } else {
1303             blurt("Error: '$type' not in typemap"), return
1304                 unless defined($type_kind{$type});
1305             blurt("Error: No OUTPUT definition for type '$type' found"), return
1306                 unless defined $output_expr{$type_kind{$type}} ;
1307             ($ntype = $type) =~ s/\s*\*/Ptr/g;
1308             $ntype =~ s/\(\)//g;
1309             ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;
1310             $expr = $output_expr{$type_kind{$type}};
1311             if ($expr =~ /DO_ARRAY_ELEM/) {
1312                 blurt("Error: '$subtype' not in typemap"), return
1313                     unless defined($type_kind{$subtype});
1314                 blurt("Error: No OUTPUT definition for type '$subtype' found"), return
1315                     unless defined $output_expr{$type_kind{$subtype}} ;
1316                 $subexpr = $output_expr{$type_kind{$subtype}};
1317                 $subexpr =~ s/ntype/subtype/g;
1318                 $subexpr =~ s/\$arg/ST(ix_$var)/g;
1319                 $subexpr =~ s/\$var/${var}[ix_$var]/g;
1320                 $subexpr =~ s/\n\t/\n\t\t/g;
1321                 $expr =~ s/DO_ARRAY_ELEM\n/$subexpr/;
1322                 eval "print qq\a$expr\a";
1323                 print "\t\tSvSETMAGIC(ST(ix_$var));\n" if $do_setmagic;
1324             }
1325             elsif ($var eq 'RETVAL') {
1326                 if ($expr =~ /^\t\$arg = new/) {
1327                     # We expect that $arg has refcnt 1, so we need to
1328                     # mortalize it.
1329                     eval "print qq\a$expr\a";
1330                     print "\tsv_2mortal(ST(0));\n";
1331                     print "\tSvSETMAGIC(ST(0));\n" if $do_setmagic;
1332                 }
1333                 elsif ($expr =~ /^\s*\$arg\s*=/) {
1334                     # We expect that $arg has refcnt >=1, so we need
1335                     # to mortalize it. However, the extension may have
1336                     # returned the built-in perl value, which is
1337                     # read-only, thus not mortalizable. However, it is
1338                     # safe to leave it as it is, since it would be
1339                     # ignored by REFCNT_dec. Builtin values have REFCNT==0.
1340                     eval "print qq\a$expr\a";
1341                     print "\tif (SvREFCNT(ST(0))) sv_2mortal(ST(0));\n";
1342                     print "\tSvSETMAGIC(ST(0));\n" if $do_setmagic;
1343                 }
1344                 else {
1345                     # Just hope that the entry would safely write it
1346                     # over an already mortalized value. By
1347                     # coincidence, something like $arg = &sv_undef
1348                     # works too.
1349                     print "\tST(0) = sv_newmortal();\n";
1350                     eval "print qq\a$expr\a";
1351                     # new mortals don't have set magic
1352                 }
1353             }
1354             elsif ($arg =~ /^ST\(\d+\)$/) {
1355                 eval "print qq\a$expr\a";
1356                 print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
1357             }
1358     }
1359 }
1360
1361 sub map_type {
1362     my($type) = @_;
1363
1364     $type =~ tr/:/_/;
1365     $type =~ s/^array\(([^,]*),(.*)\).*/$1 */s;
1366     $type;
1367 }
1368
1369
1370 sub Exit {
1371 # If this is VMS, the exit status has meaning to the shell, so we
1372 # use a predictable value (SS$_Normal or SS$_Abort) rather than an
1373 # arbitrary number.
1374 #    exit ($Is_VMS ? ($errors ? 44 : 1) : $errors) ;
1375     exit ($errors ? 1 : 0);
1376 }