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<-C++>] [B<-except>] [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 =back
  44
  45 =head1 ENVIRONMENT
  46
  47 No environment variables are used.
  48
  49 =head1 AUTHOR
  50
  51 Larry Wall
  52
  53 =head1 MODIFICATION HISTORY
  54
  55 =head2 1.0
  56
  57 I<xsubpp> as released with Perl 5.000
  58
  59 =head2 1.1
  60
  61 I<xsubpp> as released with Perl 5.001
  62
  63 =head2 1.2
  64
  65 Changes by Paul Marquess <pmarquess@bfsec.bt.co.uk>, 22 May 1995.
  66
  67 =over 5
  68
  69 =item 1.
  70
  71 Added I<xsubpp> version number for the first time. As previous releases
  72 of I<xsubpp> did not have a formal version number, a numbering scheme
  73 has been applied retrospectively.
  74
  75 =item 2.
  76
  77 If OUTPUT: is being used to specify output parameters and RETVAL is
  78 also to be returned, it is now no longer necessary for the user to
  79 ensure that RETVAL is specified last.
  80
  81 =item 3.
  82
  83 The I<xsubpp> version number, the .xs filename and a time stamp are
  84 written to the generated .c file as a comment.
  85
  86 =item 4.
  87
  88 When I<xsubpp> is parsing the definition of both the input parameters
  89 and the OUTPUT parameters, any duplicate definitions will be noted and
  90 ignored.
  91
  92 =item 5.
  93
  94 I<xsubpp> is slightly more forgiving with extra whitespace.
  95
  96 =back
  97
  98 =head2 1.3
  99
 100 Changes by Paul Marquess <pmarquess@bfsec.bt.co.uk>, 23 May 1995.
 101
 102 =over 5
 103
 104 =item 1.
 105
 106 More whitespace restrictions have been relaxed. In particular some
 107 cases where a tab character was used to delimit fields has been
 108 removed. In these cases any whitespace will now suffice.
 109
 110 The specific places where changes have been made are in the TYPEMAP
 111 section of a typemap file and the input and OUTPUT: parameter
 112 declarations sections in a .xs file.
 113
 114 =item 2.
 115
 116 More error checking added.
 117
 118 Before processing each typemap file I<xsubpp> now checks that it is a
 119 text file. If not an warning will be displayed. In addition, a warning
 120 will be displayed if it is not possible to open the typemap file.
 121
 122 In the TYPEMAP section of a typemap file, an error will be raised if
 123 the line does not have 2 columns.
 124
 125 When parsing input parameter declarations check that there is at least
 126 a type and name pair.
 127
 128 =back
 129
 130 =head2 1.4
 131
 132 When parsing the OUTPUT arguments check that they are all present in
 133 the corresponding input argument definitions.
 134
 135 =head1 SEE ALSO
 136
 137 perl(1)
 138
 139 =cut
 140
 141 # Global Constants
 142 $XSUBPP_version = "1.4" ;
 143
 144 $usage = "Usage: xsubpp [-C++] [-except] [-typemap typemap] file.xs\n";
 145
 146 SWITCH: while ($ARGV[0] =~ s/^-//) {
 147     $flag = shift @ARGV;
 148     $spat = shift,      next SWITCH     if $flag eq 's';
 149     $cplusplus = 1,     next SWITCH     if $flag eq 'C++';
 150     $except = 1,        next SWITCH     if $flag eq 'except';
 151     push(@tm,shift),    next SWITCH     if $flag eq 'typemap';
 152     die $usage;
 153 }
 154 @ARGV == 1 or die $usage;
 155 chop($pwd = `pwd`);
 156 # Check for error message from VMS
 157 if ($pwd =~ /unrecognized command verb/) { $Is_VMS = 1; $pwd = $ENV{DEFAULT} }
 158 ($dir, $filename) = @ARGV[0] =~ m#(.*)/(.*)#
 159         or ($dir, $filename) = @ARGV[0] =~ m#(.*[>\]])(.*)#
 160         or ($dir, $filename) = ('.', $ARGV[0]);
 161 chdir($dir);
 162
 163 sub TrimWhitespace
 164 {
 165     $_[0] =~ s/^\s+|\s+$//go ;
 166 }
 167
 168 sub TidyType
 169 {
 170     local ($_) = @_ ;
 171
 172     # rationalise any '*' by joining them into bunches and removing whitespace
 173     s#\s*(\*+)\s*#$1#g;
 174
 175     # change multiple whitespace into a single space
 176     s/\s+/ /g ;
 177
 178     # trim leading & trailing whitespace
 179     TrimWhitespace($_) ;
 180
 181     $_ ;
 182 }
 183
 184 $typemap = shift @ARGV;
 185 foreach $typemap (@tm) {
 186     die "Can't find $typemap in $pwd\n" unless -r $typemap;
 187 }
 188 unshift @tm, qw(../../../../lib/ExtUtils/typemap ../../../lib/ExtUtils/typemap
 189                 ../../lib/ExtUtils/typemap ../../../typemap ../../typemap
 190                 ../typemap typemap);
 191 foreach $typemap (@tm) {
 192     next unless -e $typemap ;
 193     # skip directories, binary files etc.
 194     warn("Warning: ignoring non-text typemap file '$typemap'\n"), next
 195         unless -T $typemap ;
 196     open(TYPEMAP, $typemap)
 197         or warn ("Warning: could not open typemap file '$typemap': $!\n"), next;
 198     $mode = Typemap;
 199     $current = \$junk;
 200     while (<TYPEMAP>) {
 201         next if /^#/;
 202         if (/^INPUT\s*$/) { $mode = Input, next }
 203         if (/^OUTPUT\s*$/) { $mode = Output, next }
 204         if (/^TYPEMAP\s*$/) { $mode = Typemap, next }
 205         if ($mode eq Typemap) {
 206             chop;
 207             my $line = $_ ;
 208             TrimWhitespace($_) ;
 209             # skip blank lines and comment lines
 210             next if /^$/ or /^#/ ;
 211             my @words = split (' ') ;
 212             blurt("Error: File '$typemap' Line $. '$line' TYPEMAP entry needs 2 columns\n"), next
 213                 unless @words >= 2 ;
 214             my $kind = pop @words ;
 215             TrimWhitespace($kind) ;
 216             $type_kind{TidyType("@words")} = $kind ;
 217         }
 218         elsif ($mode eq Input) {
 219             if (/^\s/) {
 220                 $$current .= $_;
 221             }
 222             else {
 223                 s/\s*$//;
 224                 $input_expr{$_} = '';
 225                 $current = \$input_expr{$_};
 226             }
 227         }
 228         else {
 229             if (/^\s/) {
 230                 $$current .= $_;
 231             }
 232             else {
 233                 s/\s*$//;
 234                 $output_expr{$_} = '';
 235                 $current = \$output_expr{$_};
 236             }
 237         }
 238     }
 239     close(TYPEMAP);
 240 }
 241
 242 foreach $key (keys %input_expr) {
 243     $input_expr{$key} =~ s/\n+$//;
 244 }
 245
 246 sub Q {
 247     local $text = shift;
 248     $text =~ tr/#//d;
 249     $text =~ s/\[\[/{/g;
 250     $text =~ s/\]\]/}/g;
 251     $text;
 252 }
 253
 254 # Identify the version of xsubpp used
 255 $TimeStamp = localtime ;
 256 print <<EOM ;
 257 /*
 258  * This file was generated automatically by xsubpp version $XSUBPP_version
 259  * from $filename on $TimeStamp
 260  *
 261  */
 262
 263 EOM
 264
 265
 266 open(F, $filename) or die "cannot open $filename: $!\n";
 267
 268 while (<F>) {
 269     last if ($Module, $foo, $Package, $foo1, $Prefix) =
 270         /^MODULE\s*=\s*([\w:]+)(\s+PACKAGE\s*=\s*([\w:]+))?(\s+PREFIX\s*=\s*(\S+))?\s*$/;
 271     print $_;
 272 }
 273 exit 0 if $_ eq "";
 274 $lastline = $_;
 275
 276 sub fetch_para {
 277     # parse paragraph
 278     @line = ();
 279     if ($lastline ne "") {
 280         if ($lastline =~
 281     /^MODULE\s*=\s*([\w:]+)(\s+PACKAGE\s*=\s*([\w:]+))?(\s+PREFIX\s*=\s*(\S+))?\s*$/) {
 282             $Module = $1;
 283             $foo = $2;
 284             $Package = $3;
 285             $foo1 = $4;
 286             $Prefix = $5;
 287             ($Module_cname = $Module) =~ s/\W/_/g;
 288             ($Packid = $Package) =~ s/:/_/g;
 289             $Packprefix = $Package;
 290             $Packprefix .= "::" if defined $Packprefix && $Packprefix ne "";
 291             while (<F>) {
 292                 chop;
 293                 next if /^#/ &&
 294                     !/^#[ \t]*(if|ifdef|ifndef|else|elif|endif|define|undef)\b/;
 295                 last if /^\S/;
 296             }
 297             push(@line, $_) if $_ ne "";
 298         }
 299         else {
 300             push(@line, $lastline);
 301         }
 302         $lastline = "";
 303         while (<F>) {
 304             next if /^#/ &&
 305                 !/^#[ \t]*(if|ifdef|ifndef|else|elif|endif|define|undef)\b/;
 306             chop;
 307             if (/^\S/ && @line && $line[-1] eq "") {
 308                 $lastline = $_;
 309                 last;
 310             }
 311             else {
 312                 push(@line, $_);
 313             }
 314         }
 315         pop(@line) while @line && $line[-1] =~ /^\s*$/;
 316     }
 317     $PPCODE = grep(/PPCODE:/, @line);
 318     scalar @line;
 319 }
 320
 321 while (&fetch_para) {
 322     # initialize info arrays
 323     undef(%args_match);
 324     undef(%var_types);
 325     undef(%var_addr);
 326     undef(%defaults);
 327     undef($class);
 328     undef($static);
 329     undef($elipsis);
 330     undef($wantRETVAL) ;
 331     undef(%arg_list) ;
 332
 333     # extract return type, function name and arguments
 334     $ret_type = TidyType(shift(@line));
 335     if ($ret_type =~ /^BOOT:/) {
 336         push (@BootCode, @line, "", "") ;
 337         next ;
 338     }
 339     if ($ret_type =~ /^static\s+(.*)$/) {
 340             $static = 1;
 341             $ret_type = $1;
 342     }
 343     $func_header = shift(@line);
 344     ($func_name, $orig_args) =  $func_header =~ /^([\w:]+)\s*\((.*)\)$/;
 345     if ($func_name =~ /(.*)::(.*)/) {
 346             $class = $1;
 347             $func_name = $2;
 348     }
 349     ($pname = $func_name) =~ s/^($Prefix)?/$Packprefix/;
 350     push(@Func_name, "${Packid}_$func_name");
 351     push(@Func_pname, $pname);
 352     @args = split(/\s*,\s*/, $orig_args);
 353     if (defined($class)) {
 354         if (defined($static)) {
 355             unshift(@args, "CLASS");
 356             $orig_args = "CLASS, $orig_args";
 357             $orig_args =~ s/^CLASS, $/CLASS/;
 358         }
 359         else {
 360             unshift(@args, "THIS");
 361             $orig_args = "THIS, $orig_args";
 362             $orig_args =~ s/^THIS, $/THIS/;
 363         }
 364     }
 365     $orig_args =~ s/"/\\"/g;
 366     $min_args = $num_args = @args;
 367     foreach $i (0..$num_args-1) {
 368             if ($args[$i] =~ s/\.\.\.//) {
 369                     $elipsis = 1;
 370                     $min_args--;
 371                     if ($args[i] eq '' && $i == $num_args - 1) {
 372                         pop(@args);
 373                         last;
 374                     }
 375             }
 376             if ($args[$i] =~ /([^=]*\S)\s*=\s*(.*)/) {
 377                     $min_args--;
 378                     $args[$i] = $1;
 379                     $defaults{$args[$i]} = $2;
 380                     $defaults{$args[$i]} =~ s/"/\\"/g;
 381             }
 382     }
 383     if (defined($class)) {
 384             $func_args = join(", ", @args[1..$#args]);
 385     } else {
 386             $func_args = join(", ", @args);
 387     }
 388     @args_match{@args} = 1..@args;
 389
 390     # print function header
 391     print Q<<"EOF";
 392 #XS(XS_${Packid}_$func_name)
 393 #[[
 394 #    dXSARGS;
 395 EOF
 396     if ($elipsis) {
 397         $cond = qq(items < $min_args);
 398     }
 399     elsif ($min_args == $num_args) {
 400         $cond = qq(items != $min_args);
 401     }
 402     else {
 403         $cond = qq(items < $min_args || items > $num_args);
 404     }
 405
 406     print Q<<"EOF" if $except;
 407 #    char errbuf[1024];
 408 #    *errbuf = '\0';
 409 EOF
 410
 411     print Q<<"EOF";
 412 #    if ($cond) {
 413 #       croak("Usage: $pname($orig_args)");
 414 #    }
 415 EOF
 416
 417     print Q<<"EOF" if $PPCODE;
 418 #    SP -= items;
 419 EOF
 420
 421     # Now do a block of some sort.
 422
 423     $condnum = 0;
 424     if (!@line) {
 425         @line = "CLEANUP:";
 426     }
 427     while (@line) {
 428         if ($_[0] =~ s/^\s*CASE\s*:\s*//) {
 429             $cond = shift(@line);
 430             if ($condnum == 0) {
 431                 print "    if ($cond)\n";
 432             }
 433             elsif ($cond ne '') {
 434                 print "    else if ($cond)\n";
 435             }
 436             else {
 437                 print "    else\n";
 438             }
 439             $condnum++;
 440         }
 441
 442         if ($except) {
 443             print Q<<"EOF";
 444 #    TRY [[
 445 EOF
 446         }
 447         else {
 448             print Q<<"EOF";
 449 #    [[
 450 EOF
 451         }
 452
 453         # do initialization of input variables
 454         $thisdone = 0;
 455         $retvaldone = 0;
 456         $deferred = "";
 457         while (@line) {
 458                 $_ = shift(@line);
 459                 last if /^\s*NOT_IMPLEMENTED_YET/;
 460                 last if /^\s*(PPCODE|CODE|OUTPUT|CLEANUP|CASE)\s*:/;
 461
 462                 TrimWhitespace($_) ;
 463                 # skip blank lines
 464                 next if /^$/ ;
 465                 my $line = $_ ;
 466                 # check for optional initialisation code
 467                 my $var_init = $1 if s/\s*(=.*)$// ;
 468
 469                 my @words = split (' ') ;
 470                 blurt("Error: invalid argument declaration '$line'"), next
 471                     unless @words >= 2 ;
 472                 my $var_name = pop @words ;
 473                 my $var_type = "@words" ;
 474
 475                 # catch C style argument declaration (this could be made alowable syntax)
 476                 warn("Warning: ignored semicolon in $pname argument declaration '$_'\n")
 477                         if ($var_name =~ s/;//g); # eg SV *<tab>name;
 478                 # catch many errors similar to: SV<tab>* name
 479                 blurt("Error: invalid $pname argument name '$var_name' (type '$var_type')\n")
 480                         unless ($var_name =~ m/^&?\w+$/);
 481                 if ($var_name =~ /^&/) {
 482                         $var_name =~ s/^&//;
 483                         $var_addr{$var_name} = 1;
 484                 }
 485
 486                 # Check for duplicate definitions
 487                 blurt ("Error: duplicate definition of argument '$var_name' ignored"), next
 488                     if $arg_list{$var_name} ++  ;
 489
 490                 $thisdone |= $var_name eq "THIS";
 491                 $retvaldone |= $var_name eq "RETVAL";
 492                 $var_types{$var_name} = $var_type;
 493                 print "\t" . &map_type($var_type);
 494                 $var_num = $args_match{$var_name};
 495                 if ($var_addr{$var_name}) {
 496                         $func_args =~ s/\b($var_name)\b/&\1/;
 497                 }
 498                 if ($var_init !~ /^=\s*NO_INIT\s*$/) {
 499                         if ($var_init !~ /^\s*$/) {
 500                                 &output_init($var_type, $var_num,
 501                                     "$var_name $var_init");
 502                         } elsif ($var_num) {
 503                                 # generate initialization code
 504                                 &generate_init($var_type, $var_num, $var_name);
 505                         } else {
 506                                 print ";\n";
 507                         }
 508                 } else {
 509                         print "\t$var_name;\n";
 510                 }
 511         }
 512         if (!$thisdone && defined($class)) {
 513             if (defined($static)) {
 514                 print "\tchar *";
 515                 $var_types{"CLASS"} = "char *";
 516                 &generate_init("char *", 1, "CLASS");
 517             }
 518             else {
 519                 print "\t$class *";
 520                 $var_types{"THIS"} = "$class *";
 521                 &generate_init("$class *", 1, "THIS");
 522             }
 523         }
 524
 525         # do code
 526         if (/^\s*NOT_IMPLEMENTED_YET/) {
 527                 print "\ncroak(\"$pname: not implemented yet\");\n";
 528         } else {
 529                 if ($ret_type ne "void") {
 530                         print "\t" . &map_type($ret_type) . "\tRETVAL;\n"
 531                                 if !$retvaldone;
 532                         $args_match{"RETVAL"} = 0;
 533                         $var_types{"RETVAL"} = $ret_type;
 534                 }
 535                 if (/^\s*PPCODE:/) {
 536                         print $deferred;
 537                         while (@line) {
 538                                 $_ = shift(@line);
 539                                 die "PPCODE must be last thing"
 540                                     if /^\s*(OUTPUT|CLEANUP|CASE)\s*:/;
 541                                 print "$_\n";
 542                         }
 543                         print "\tPUTBACK;\n\treturn;\n";
 544                 } elsif (/^\s*CODE:/) {
 545                         print $deferred;
 546                         while (@line) {
 547                                 $_ = shift(@line);
 548                                 last if /^\s*(OUTPUT|CLEANUP|CASE)\s*:/;
 549                                 print "$_\n";
 550                         }
 551                 } elsif ($func_name eq "DESTROY") {
 552                         print $deferred;
 553                         print "\n\t";
 554                         print "delete THIS;\n"
 555                 } else {
 556                         print $deferred;
 557                         print "\n\t";
 558                         if ($ret_type ne "void") {
 559                                 print "RETVAL = ";
 560                         }
 561                         if (defined($static)) {
 562                             if ($func_name =~ /^new/) {
 563                                 $func_name = "$class";
 564                             }
 565                             else {
 566                                 print "$class::";
 567                             }
 568                         } elsif (defined($class)) {
 569                                 print "THIS->";
 570                         }
 571                         if (defined($spat) && $func_name =~ /^($spat)(.*)$/) {
 572                                 $func_name = $2;
 573                         }
 574                         print "$func_name($func_args);\n";
 575                         $wantRETVAL = 1
 576                             unless $ret_type eq "void";
 577                 }
 578         }
 579
 580         # do output variables
 581         if (/^\s*OUTPUT\s*:/) {
 582                 my $gotRETVAL ;
 583                 my %outargs ;
 584                 while (@line) {
 585                         $_ = shift(@line);
 586                         last if /^\s*CLEANUP\s*:/;
 587                         TrimWhitespace($_) ;
 588                         next if /^$/ ;
 589                         my ($outarg, $outcode) = /^(\S+)\s*(.*)/ ;
 590                         if (!$gotRETVAL and $outarg eq 'RETVAL') {
 591                             # deal with RETVAL last
 592                             push(@line, $_) ;
 593                             $gotRETVAL = 1 ;
 594                             undef ($wantRETVAL) ;
 595                             next ;
 596                         }
 597                         blurt ("Error: duplicate OUTPUT argument '$outarg' ignored"), next
 598                             if $outargs{$outarg} ++ ;
 599                         blurt ("Error: OUTPUT $outarg not an argument"), next
 600                             unless defined($args_match{$outarg});
 601                         blurt("Error: No input definition for OUTPUT argument '$outarg' - ignored"), next
 602                             unless defined $var_types{$outarg} ;
 603                         if ($outcode) {
 604                             print "\t$outcode\n";
 605                         } else {
 606                                 $var_num = $args_match{$outarg};
 607                                 &generate_output($var_types{$outarg}, $var_num,
 608                                     $outarg);
 609                         }
 610                 }
 611         }
 612
 613         # all OUTPUT done, so now push the return value on the stack
 614         &generate_output($ret_type, 0, "RETVAL")
 615              if $wantRETVAL ;
 616
 617         # do cleanup
 618         if (/^\s*CLEANUP\s*:/) {
 619             while (@line) {
 620                     $_ = shift(@line);
 621                     last if /^\s*CASE\s*:/;
 622                     print "$_\n";
 623             }
 624         }
 625         # print function trailer
 626         if ($except) {
 627             print Q<<EOF;
 628 #    ]]
 629 #    BEGHANDLERS
 630 #    CATCHALL
 631 #       sprintf(errbuf, "%s: %s\\tpropagated", Xname, Xreason);
 632 #    ENDHANDLERS
 633 EOF
 634         }
 635         else {
 636             print Q<<EOF;
 637 #    ]]
 638 EOF
 639         }
 640         if (/^\s*CASE\s*:/) {
 641             unshift(@line, $_);
 642         }
 643     }
 644
 645     print Q<<EOF if $except;
 646 #    if (errbuf[0])
 647 #       croak(errbuf);
 648 EOF
 649
 650     print Q<<EOF unless $PPCODE;
 651 #    XSRETURN(1);
 652 EOF
 653
 654     print Q<<EOF;
 655 #]]
 656 #
 657 EOF
 658 }
 659
 660 # print initialization routine
 661 print qq/extern "C"\n/ if $cplusplus;
 662 print Q<<"EOF";
 663 #XS(boot_$Module_cname)
 664 #[[
 665 #    dXSARGS;
 666 #    char* file = __FILE__;
 667 #
 668 EOF
 669
 670 for (@Func_name) {
 671     $pname = shift(@Func_pname);
 672     print "    newXS(\"$pname\", XS_$_, file);\n";
 673 }
 674
 675 if (@BootCode)
 676 {
 677     print "\n    /* Initialisation Section */\n\n" ;
 678     print grep (s/$/\n/, @BootCode) ;
 679     print "    /* End of Initialisation Section */\n\n" ;
 680 }
 681
 682 print "    ST(0) = &sv_yes;\n";
 683 print "    XSRETURN(1);\n";
 684 print "}\n";
 685
 686 sub output_init {
 687     local($type, $num, $init) = @_;
 688     local($arg) = "ST(" . ($num - 1) . ")";
 689
 690     eval qq/print " $init\\\n"/;
 691 }
 692
 693 sub blurt { warn @_; $errors++ }
 694
 695 sub generate_init {
 696     local($type, $num, $var) = @_;
 697     local($arg) = "ST(" . ($num - 1) . ")";
 698     local($argoff) = $num - 1;
 699     local($ntype);
 700     local($tk);
 701
 702     $type = TidyType($type) ;
 703     blurt("Error: '$type' not in typemap"), return unless defined($type_kind{$type});
 704     ($ntype = $type) =~ s/\s*\*/Ptr/g;
 705     $subtype = $ntype;
 706     $subtype =~ s/Ptr$//;
 707     $subtype =~ s/Array$//;
 708     $tk = $type_kind{$type};
 709     $tk =~ s/OBJ$/REF/ if $func_name =~ /DESTROY$/;
 710     $type =~ s/:/_/g;
 711     $expr = $input_expr{$tk};
 712     if ($expr =~ /DO_ARRAY_ELEM/) {
 713         $subexpr = $input_expr{$type_kind{$subtype}};
 714         $subexpr =~ s/ntype/subtype/g;
 715         $subexpr =~ s/\$arg/ST(ix_$var)/g;
 716         $subexpr =~ s/\n\t/\n\t\t/g;
 717         $subexpr =~ s/is not of (.*")/[arg %d] is not of $1, ix_$var + 1/g;
 718         $subexpr =~ s/\$var/${var}[ix_$var - $argoff]/;
 719         $expr =~ s/DO_ARRAY_ELEM/$subexpr/;
 720     }
 721     if (defined($defaults{$var})) {
 722             $expr =~ s/(\t+)/$1    /g;
 723             $expr =~ s/        /\t/g;
 724             eval qq/print "\\t$var;\\n"/;
 725             $deferred .= eval qq/"\\n\\tif (items < $num)\\n\\t    $var = $defaults{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/;
 726     } elsif ($expr !~ /^\t\$var =/) {
 727             eval qq/print "\\t$var;\\n"/;
 728             $deferred .= eval qq/"\\n$expr;\\n"/;
 729     } else {
 730             eval qq/print "$expr;\\n"/;
 731     }
 732 }
 733
 734 sub generate_output {
 735     local($type, $num, $var) = @_;
 736     local($arg) = "ST(" . ($num - ($num != 0)) . ")";
 737     local($argoff) = $num - 1;
 738     local($ntype);
 739
 740     $type = TidyType($type) ;
 741     if ($type =~ /^array\(([^,]*),(.*)\)/) {
 742             print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1)), XFree((char *)$var);\n";
 743     } else {
 744             blurt("Error: '$type' not in typemap"), return
 745                 unless defined($type_kind{$type});
 746             ($ntype = $type) =~ s/\s*\*/Ptr/g;
 747             $ntype =~ s/\(\)//g;
 748             $subtype = $ntype;
 749             $subtype =~ s/Ptr$//;
 750             $subtype =~ s/Array$//;
 751             $expr = $output_expr{$type_kind{$type}};
 752             if ($expr =~ /DO_ARRAY_ELEM/) {
 753                 $subexpr = $output_expr{$type_kind{$subtype}};
 754                 $subexpr =~ s/ntype/subtype/g;
 755                 $subexpr =~ s/\$arg/ST(ix_$var)/g;
 756                 $subexpr =~ s/\$var/${var}[ix_$var]/g;
 757                 $subexpr =~ s/\n\t/\n\t\t/g;
 758                 $expr =~ s/DO_ARRAY_ELEM\n/$subexpr/;
 759                 eval "print qq\a$expr\a";
 760             }
 761             elsif ($var eq 'RETVAL') {
 762                 if ($expr =~ /^\t\$arg = /) {
 763                     eval "print qq\a$expr\a";
 764                     print "\tsv_2mortal(ST(0));\n";
 765                 }
 766                 else {
 767                     print "\tST(0) = sv_newmortal();\n";
 768                     eval "print qq\a$expr\a";
 769                 }
 770             }
 771             elsif ($arg =~ /^ST\(\d+\)$/) {
 772                 eval "print qq\a$expr\a";
 773             }
 774             elsif ($arg =~ /^ST\(\d+\)$/) {
 775                 eval "print qq\a$expr\a";
 776             }
 777             elsif ($arg =~ /^ST\(\d+\)$/) {
 778                 eval "print qq\a$expr\a";
 779             }
 780     }
 781 }
 782
 783 sub map_type {
 784     local($type) = @_;
 785
 786     $type =~ s/:/_/g;
 787     if ($type =~ /^array\(([^,]*),(.*)\)/) {
 788             return "$1 *";
 789     } else {
 790             return $type;
 791     }
 792 }
 793
 794 # If this is VMS, the exit status has meaning to the shell, so we
 795 # use a predictable value (SS$_Abort) rather than an arbitrary
 796 # number.
 797 exit $Is_VMS ? 44 : $errors;