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 =head2 1.5
 136
 137 Changes by Paul Marquess <pmarquess@bfsec.bt.co.uk>, 1 June 1995.
 138
 139 Started tidy up to allow clean run using C<-w> flag.
 140
 141 Added some more error checking.
 142
 143 The CASE: functionality now works.
 144
 145 =head2 1.6
 146
 147 Changes by Paul Marquess <pmarquess@bfsec.bt.co.uk>, 3 June 1995.
 148
 149 Added some more error checking.
 150
 151 =head2 1.7
 152
 153 Changes by Paul Marquess <pmarquess@bfsec.bt.co.uk>, 5 June 1995.
 154
 155 When an error or warning message is printed C<xsubpp> will now attempt
 156 to identify the exact line in the C<.xs> file where the fault occurs.
 157 This can be achieved in the majority of cases.
 158
 159 =head1 SEE ALSO
 160
 161 perl(1)
 162
 163 =cut
 164
 165 use FileHandle ;
 166
 167 # Global Constants
 168 $XSUBPP_version = "1.7" ;
 169
 170 $usage = "Usage: xsubpp [-C++] [-except] [-typemap typemap] file.xs\n";
 171
 172 SWITCH: while ($ARGV[0] =~ s/^-//) {
 173     $flag = shift @ARGV;
 174     $spat = shift,      next SWITCH     if $flag eq 's';
 175     $cplusplus = 1,     next SWITCH     if $flag eq 'C++';
 176     $except = 1,        next SWITCH     if $flag eq 'except';
 177     push(@tm,shift),    next SWITCH     if $flag eq 'typemap';
 178     die $usage;
 179 }
 180 @ARGV == 1 or die $usage;
 181 chop($pwd = `pwd`);
 182 # Check for error message from VMS
 183 if ($pwd =~ /unrecognized command verb/) { $Is_VMS = 1; $pwd = $ENV{DEFAULT} }
 184 ($dir, $filename) = $ARGV[0] =~ m#(.*)/(.*)#
 185         or ($dir, $filename) = $ARGV[0] =~ m#(.*[>\]])(.*)#
 186         or ($dir, $filename) = ('.', $ARGV[0]);
 187 chdir($dir);
 188
 189 sub TrimWhitespace
 190 {
 191     $_[0] =~ s/^\s+|\s+$//go ;
 192 }
 193
 194 sub TidyType
 195 {
 196     local ($_) = @_ ;
 197
 198     # rationalise any '*' by joining them into bunches and removing whitespace
 199     s#\s*(\*+)\s*#$1#g;
 200
 201     # change multiple whitespace into a single space
 202     s/\s+/ /g ;
 203
 204     # trim leading & trailing whitespace
 205     TrimWhitespace($_) ;
 206
 207     $_ ;
 208 }
 209
 210 $typemap = shift @ARGV;
 211 foreach $typemap (@tm) {
 212     die "Can't find $typemap in $pwd\n" unless -r $typemap;
 213 }
 214 unshift @tm, qw(../../../../lib/ExtUtils/typemap ../../../lib/ExtUtils/typemap
 215                 ../../lib/ExtUtils/typemap ../../../typemap ../../typemap
 216                 ../typemap typemap);
 217 foreach $typemap (@tm) {
 218     next unless -e $typemap ;
 219     # skip directories, binary files etc.
 220     warn("Warning: ignoring non-text typemap file '$typemap'\n"), next
 221         unless -T $typemap ;
 222     open(TYPEMAP, $typemap)
 223         or warn ("Warning: could not open typemap file '$typemap': $!\n"), next;
 224     $mode = Typemap;
 225     $junk = "" ;
 226     $current = \$junk;
 227     while (<TYPEMAP>) {
 228         next if /^#/;
 229         if (/^INPUT\s*$/) { $mode = Input, next }
 230         if (/^OUTPUT\s*$/) { $mode = Output, next }
 231         if (/^TYPEMAP\s*$/) { $mode = Typemap, next }
 232         if ($mode eq Typemap) {
 233             chop;
 234             my $line = $_ ;
 235             TrimWhitespace($_) ;
 236             # skip blank lines and comment lines
 237             next if /^$/ or /^#/ ;
 238             my @words = split (' ') ;
 239             warn("Warning: File '$typemap' Line $. '$line' TYPEMAP entry needs 2 columns\n"), next
 240                 unless @words >= 2 ;
 241             my $kind = pop @words ;
 242             TrimWhitespace($kind) ;
 243             $type_kind{TidyType("@words")} = $kind ;
 244         }
 245         elsif ($mode eq Input) {
 246             if (/^\s/) {
 247                 $$current .= $_;
 248             }
 249             else {
 250                 s/\s*$//;
 251                 $input_expr{$_} = '';
 252                 $current = \$input_expr{$_};
 253             }
 254         }
 255         else {
 256             if (/^\s/) {
 257                 $$current .= $_;
 258             }
 259             else {
 260                 s/\s*$//;
 261                 $output_expr{$_} = '';
 262                 $current = \$output_expr{$_};
 263             }
 264         }
 265     }
 266     close(TYPEMAP);
 267 }
 268
 269 foreach $key (keys %input_expr) {
 270     $input_expr{$key} =~ s/\n+$//;
 271 }
 272
 273 sub Q {
 274     local $text = shift;
 275     $text =~ tr/#//d;
 276     $text =~ s/\[\[/{/g;
 277     $text =~ s/\]\]/}/g;
 278     $text;
 279 }
 280
 281 open(F, $filename) or die "cannot open $filename: $!\n";
 282
 283 # Identify the version of xsubpp used
 284 $TimeStamp = localtime ;
 285 print <<EOM ;
 286 /*
 287  * This file was generated automatically by xsubpp version $XSUBPP_version
 288  * from $filename on $TimeStamp
 289  *
 290  */
 291
 292 EOM
 293
 294
 295 while (<F>) {
 296     last if ($Module, $foo, $Package, $foo1, $Prefix) =
 297         /^MODULE\s*=\s*([\w:]+)(\s+PACKAGE\s*=\s*([\w:]+))?(\s+PREFIX\s*=\s*(\S+))?\s*$/;
 298     print $_;
 299 }
 300 exit 0 if $_ eq "";
 301 $lastline = $_;
 302
 303 sub fetch_para {
 304     # parse paragraph
 305     @line = ();
 306     @line_no = () ;
 307     if ($lastline ne "") {
 308         if ($lastline =~
 309     /^MODULE\s*=\s*([\w:]+)(\s+PACKAGE\s*=\s*([\w:]+))?(\s+PREFIX\s*=\s*(\S+))?\s*$/) {
 310             $Module = $1;
 311             $foo = $2;
 312             $Package = $3;
 313             $foo1 = $4;
 314             $Prefix = $5;
 315             ($Module_cname = $Module) =~ s/\W/_/g;
 316             ($Packid = $Package) =~ s/:/_/g;
 317             $Packprefix = $Package;
 318             $Packprefix .= "::" if defined $Packprefix && $Packprefix ne "";
 319             while (<F>) {
 320                 chop;
 321                 next if /^#/ &&
 322                     !/^#[ \t]*(if|ifdef|ifndef|else|elif|endif|define|undef)\b/;
 323                 last if /^\S/;
 324             }
 325             push(@line, $_), push(@line_no, input_line_number F) if $_ ne "";
 326         }
 327         else {
 328             push(@line, $lastline);
 329             push(@line_no, $lastline_no) ;
 330         }
 331         $lastline = "";
 332         while (<F>) {
 333             next if /^#/ &&
 334                 !/^#[ \t]*(if|ifdef|ifndef|else|elif|endif|define|undef)\b/;
 335             chop;
 336             if (/^\S/ && @line && $line[-1] eq "") {
 337                 $lastline = $_;
 338                 $lastline_no = input_line_number F ;
 339                 last;
 340             }
 341             else {
 342                 push(@line, $_);
 343                 push(@line_no, input_line_number F) ;
 344             }
 345         }
 346         pop(@line), pop(@line_no) while @line && $line[-1] =~ /^\s*$/;
 347     }
 348     $PPCODE = grep(/PPCODE:/, @line);
 349     scalar @line;
 350 }
 351
 352 PARAGRAPH:
 353 while (&fetch_para) {
 354     # initialize info arrays
 355     undef(%args_match);
 356     undef(%var_types);
 357     undef(%var_addr);
 358     undef(%defaults);
 359     undef($class);
 360     undef($static);
 361     undef($elipsis);
 362     undef($wantRETVAL) ;
 363     undef(%arg_list) ;
 364
 365     # extract return type, function name and arguments
 366     $ret_type = TidyType(shift(@line));
 367
 368     if ($ret_type =~ /^BOOT:/) {
 369         push (@BootCode, @line, "", "") ;
 370         next PARAGRAPH ;
 371     }
 372
 373     # a function definition needs at least 2 lines
 374     blurt ("Error: Function definition too short '$ret_type'"), next PARAGRAPH
 375         unless @line ;
 376
 377     if ($ret_type =~ /^static\s+(.*)$/) {
 378             $static = 1;
 379             $ret_type = $1;
 380     }
 381     $func_header = shift(@line);
 382     blurt ("Error: Cannot parse function definition from '$func_header'"), next PARAGRAPH
 383         unless $func_header =~ /^([\w:]+)\s*\((.*)\)$/;
 384
 385     ($func_name, $orig_args) =  ($1, $2) ;
 386     if ($func_name =~ /(.*)::(.*)/) {
 387             $class = $1;
 388             $func_name = $2;
 389     }
 390     $Prefix = '' unless defined $Prefix ; # keep -w happy
 391     ($pname = $func_name) =~ s/^($Prefix)?/$Packprefix/;
 392
 393     # Check for duplicate function definition
 394     blurt("Error: ignoring duplicate function definition '$func_name'"), next PARAGRAPH
 395         if defined $Func_name{"${Packid}_$func_name"} ;
 396     $Func_name{"${Packid}_$func_name"} ++ ;
 397
 398     push(@Func_name, "${Packid}_$func_name");
 399     push(@Func_pname, $pname);
 400     @args = split(/\s*,\s*/, $orig_args);
 401     if (defined($class)) {
 402         if (defined($static)) {
 403             unshift(@args, "CLASS");
 404             $orig_args = "CLASS, $orig_args";
 405             $orig_args =~ s/^CLASS, $/CLASS/;
 406         }
 407         else {
 408             unshift(@args, "THIS");
 409             $orig_args = "THIS, $orig_args";
 410             $orig_args =~ s/^THIS, $/THIS/;
 411         }
 412     }
 413     $orig_args =~ s/"/\\"/g;
 414     $min_args = $num_args = @args;
 415     foreach $i (0..$num_args-1) {
 416             if ($args[$i] =~ s/\.\.\.//) {
 417                     $elipsis = 1;
 418                     $min_args--;
 419                     if ($args[$i] eq '' && $i == $num_args - 1) {
 420                         pop(@args);
 421                         last;
 422                     }
 423             }
 424             if ($args[$i] =~ /([^=]*\S)\s*=\s*(.*)/) {
 425                     $min_args--;
 426                     $args[$i] = $1;
 427                     $defaults{$args[$i]} = $2;
 428                     $defaults{$args[$i]} =~ s/"/\\"/g;
 429             }
 430     }
 431     if (defined($class)) {
 432             $func_args = join(", ", @args[1..$#args]);
 433     } else {
 434             $func_args = join(", ", @args);
 435     }
 436     @args_match{@args} = 1..@args;
 437
 438     # print function header
 439     print Q<<"EOF";
 440 #XS(XS_${Packid}_$func_name)
 441 #[[
 442 #    dXSARGS;
 443 EOF
 444     if ($elipsis) {
 445         $cond = qq(items < $min_args);
 446     }
 447     elsif ($min_args == $num_args) {
 448         $cond = qq(items != $min_args);
 449     }
 450     else {
 451         $cond = qq(items < $min_args || items > $num_args);
 452     }
 453
 454     print Q<<"EOF" if $except;
 455 #    char errbuf[1024];
 456 #    *errbuf = '\0';
 457 EOF
 458
 459     print Q<<"EOF";
 460 #    if ($cond) {
 461 #       croak("Usage: $pname($orig_args)");
 462 #    }
 463 EOF
 464
 465     print Q<<"EOF" if $PPCODE;
 466 #    SP -= items;
 467 EOF
 468
 469     # Now do a block of some sort.
 470
 471     $condnum = 0;
 472     $else_cond = 0 ;
 473     if (!@line) {
 474         @line = "CLEANUP:";
 475     }
 476     while (@line) {
 477         if ($line[0] =~ s/^\s*CASE\s*:\s*//) {
 478             $cond = shift(@line);
 479             TrimWhitespace($cond) ;
 480             if ($condnum == 0) {
 481                 # Check $cond is not blank
 482                 blurt("Error: First CASE: needs a condition")
 483                     if $cond eq '' ;
 484                 print "    if ($cond)\n"
 485             }
 486             elsif ($cond ne '') {
 487                 print "    else if ($cond)\n";
 488             }
 489             else {
 490                 blurt ("Error: Too many CASE: statements without a condition")
 491                     unless $else_cond ;
 492                 ++ $else_cond  ;
 493                 print "    else\n";
 494             }
 495             $condnum++;
 496             $_ = '' ;
 497         }
 498
 499         if ($except) {
 500             print Q<<"EOF";
 501 #    TRY [[
 502 EOF
 503         }
 504         else {
 505             print Q<<"EOF";
 506 #    [[
 507 EOF
 508         }
 509
 510         # do initialization of input variables
 511         $thisdone = 0;
 512         $retvaldone = 0;
 513         $deferred = "";
 514         %arg_list = () ;
 515         $gotRETVAL = 0;
 516         while (@line) {
 517                 $_ = shift(@line);
 518                 last if /^\s*NOT_IMPLEMENTED_YET/;
 519                 last if /^\s*(PPCODE|CODE|OUTPUT|CLEANUP|CASE)\s*:/;
 520
 521                 TrimWhitespace($_) ;
 522                 # skip blank lines
 523                 next if /^$/ ;
 524                 my $line = $_ ;
 525
 526                 # remove trailing semicolon if no initialisation
 527                 s/\s*;+\s*$//g unless /=/ ;
 528
 529                 # check for optional initialisation code
 530                 my $var_init = '' ;
 531                 $var_init = $1 if s/\s*(=.*)$// ;
 532
 533                 my @words = split (' ') ;
 534                 blurt("Error: invalid argument declaration '$line'"), next
 535                     unless @words >= 2 ;
 536                 my $var_name = pop @words ;
 537                 my $var_type = "@words" ;
 538
 539                 # catch many errors similar to: SV<tab>* name
 540                 blurt("Error: invalid $pname argument name '$var_name' (type '$var_type')\n")
 541                         unless ($var_name =~ m/^&?\w+$/);
 542                 if ($var_name =~ /^&/) {
 543                         $var_name =~ s/^&//;
 544                         $var_addr{$var_name} = 1;
 545                 }
 546
 547                 # Check for duplicate definitions
 548                 blurt ("Error: duplicate definition of argument '$var_name' ignored"), next
 549                     if $arg_list{$var_name} ++  ;
 550
 551                 $thisdone |= $var_name eq "THIS";
 552                 $retvaldone |= $var_name eq "RETVAL";
 553                 $var_types{$var_name} = $var_type;
 554                 print "\t" . &map_type($var_type);
 555                 $var_num = $args_match{$var_name};
 556                 if ($var_addr{$var_name}) {
 557                         $func_args =~ s/\b($var_name)\b/&$1/;
 558                 }
 559                 if ($var_init !~ /^=\s*NO_INIT\s*$/) {
 560                         if ($var_init !~ /^\s*$/) {
 561                                 &output_init($var_type, $var_num,
 562                                     "$var_name $var_init");
 563                         } elsif ($var_num) {
 564                                 # generate initialization code
 565                                 &generate_init($var_type, $var_num, $var_name);
 566                         } else {
 567                                 print ";\n";
 568                         }
 569                 } else {
 570                         print "\t$var_name;\n";
 571                 }
 572         }
 573         if (!$thisdone && defined($class)) {
 574             if (defined($static)) {
 575                 print "\tchar *";
 576                 $var_types{"CLASS"} = "char *";
 577                 &generate_init("char *", 1, "CLASS");
 578             }
 579             else {
 580                 print "\t$class *";
 581                 $var_types{"THIS"} = "$class *";
 582                 &generate_init("$class *", 1, "THIS");
 583             }
 584         }
 585
 586         # do code
 587         if (/^\s*NOT_IMPLEMENTED_YET/) {
 588                 print "\ncroak(\"$pname: not implemented yet\");\n";
 589         } else {
 590                 if ($ret_type ne "void") {
 591                         print "\t" . &map_type($ret_type) . "\tRETVAL;\n"
 592                                 if !$retvaldone;
 593                         $args_match{"RETVAL"} = 0;
 594                         $var_types{"RETVAL"} = $ret_type;
 595                 }
 596                 if (/^\s*PPCODE:/) {
 597                         print $deferred;
 598                         while (@line) {
 599                                 $_ = shift(@line);
 600                                 death ("PPCODE must be last thing")
 601                                     if /^\s*(OUTPUT|CLEANUP|CASE)\s*:/;
 602                                 print "$_\n";
 603                         }
 604                         print "\tPUTBACK;\n\treturn;\n";
 605                 } elsif (/^\s*CODE:/) {
 606                         print $deferred;
 607                         while (@line) {
 608                                 $_ = shift(@line);
 609                                 last if /^\s*(OUTPUT|CLEANUP|CASE)\s*:/;
 610                                 print "$_\n";
 611                         }
 612                 } elsif ($func_name eq "DESTROY") {
 613                         print $deferred;
 614                         print "\n\t";
 615                         print "delete THIS;\n"
 616                 } else {
 617                         print $deferred;
 618                         print "\n\t";
 619                         if ($ret_type ne "void") {
 620                                 print "RETVAL = ";
 621                         }
 622                         if (defined($static)) {
 623                             if ($func_name =~ /^new/) {
 624                                 $func_name = "$class";
 625                             }
 626                             else {
 627                                 print "$class::";
 628                             }
 629                         } elsif (defined($class)) {
 630                                 print "THIS->";
 631                         }
 632                         if (defined($spat) && $func_name =~ /^($spat)(.*)$/) {
 633                                 $func_name = $2;
 634                         }
 635                         print "$func_name($func_args);\n";
 636                         $wantRETVAL = 1 unless $ret_type eq "void";
 637                 }
 638         }
 639
 640         # do output variables
 641         if (/^\s*OUTPUT\s*:/) {
 642                 $gotRETVAL = 0;
 643                 my $RETVAL_code ;
 644                 my %outargs ;
 645                 while (@line) {
 646                         $_ = shift(@line);
 647                         last if /^\s*CLEANUP|CASE\s*:/;
 648                         TrimWhitespace($_) ;
 649                         next if /^$/ ;
 650                         my ($outarg, $outcode) = /^(\S+)\s*(.*)/ ;
 651                         if (!$gotRETVAL and $outarg eq 'RETVAL') {
 652                             # deal with RETVAL last
 653                             $RETVAL_code = $outcode ;
 654                             $gotRETVAL = 1 ;
 655                             next ;
 656                         }
 657                         blurt ("Error: duplicate OUTPUT argument '$outarg' ignored"), next
 658                             if $outargs{$outarg} ++ ;
 659                         blurt ("Error: OUTPUT $outarg not an argument"), next
 660                             unless defined($args_match{$outarg});
 661                         blurt("Error: No input definition for OUTPUT argument '$outarg' - ignored"), next
 662                             unless defined $var_types{$outarg} ;
 663                         if ($outcode) {
 664                             print "\t$outcode\n";
 665                         } else {
 666                                 $var_num = $args_match{$outarg};
 667                                 &generate_output($var_types{$outarg}, $var_num,
 668                                     $outarg);
 669                         }
 670                 }
 671
 672                 if ($gotRETVAL) {
 673                         if ($RETVAL_code)
 674                             { print "\t$RETVAL_code\n" }
 675                         else
 676                             { &generate_output($ret_type, 0, 'RETVAL') }
 677                 }
 678         }
 679
 680         # all OUTPUT done, so now push the return value on the stack
 681         &generate_output($ret_type, 0, "RETVAL")
 682              if $wantRETVAL and ! $gotRETVAL ;
 683
 684         # do cleanup
 685         if (/^\s*CLEANUP\s*:/) {
 686             while (@line) {
 687                     $_ = shift(@line);
 688                     last if /^\s*CASE\s*:/;
 689                     print "$_\n";
 690             }
 691         }
 692         # print function trailer
 693         if ($except) {
 694             print Q<<EOF;
 695 #    ]]
 696 #    BEGHANDLERS
 697 #    CATCHALL
 698 #       sprintf(errbuf, "%s: %s\\tpropagated", Xname, Xreason);
 699 #    ENDHANDLERS
 700 EOF
 701         }
 702         else {
 703             print Q<<EOF;
 704 #    ]]
 705 EOF
 706         }
 707         if (/^\s*CASE\s*:/) {
 708             unshift(@line, $_);
 709         }
 710     }
 711
 712     print Q<<EOF if $except;
 713 #    if (errbuf[0])
 714 #       croak(errbuf);
 715 EOF
 716
 717     print Q<<EOF unless $PPCODE;
 718 #    XSRETURN(1);
 719 EOF
 720
 721     print Q<<EOF;
 722 #]]
 723 #
 724 EOF
 725 }
 726
 727 # print initialization routine
 728 print qq/extern "C"\n/ if $cplusplus;
 729 print Q<<"EOF";
 730 #XS(boot_$Module_cname)
 731 #[[
 732 #    dXSARGS;
 733 #    char* file = __FILE__;
 734 #
 735 EOF
 736
 737 for (@Func_name) {
 738     $pname = shift(@Func_pname);
 739     print "    newXS(\"$pname\", XS_$_, file);\n";
 740 }
 741
 742 if (@BootCode)
 743 {
 744     print "\n    /* Initialisation Section */\n\n" ;
 745     print grep (s/$/\n/, @BootCode) ;
 746     print "    /* End of Initialisation Section */\n\n" ;
 747 }
 748
 749 print "    ST(0) = &sv_yes;\n";
 750 print "    XSRETURN(1);\n";
 751 print "}\n";
 752
 753 sub output_init {
 754     local($type, $num, $init) = @_;
 755     local($arg) = "ST(" . ($num - 1) . ")";
 756
 757     eval qq/print " $init\\\n"/;
 758 }
 759
 760 sub Warn
 761 {
 762     # work out the line number
 763     my $line_no = $line_no[@line_no - @line -1] ;
 764
 765     print STDERR "@_ in $filename, line $line_no\n" ;
 766 }
 767
 768 sub blurt
 769 {
 770     Warn @_ ;
 771     $errors ++
 772 }
 773
 774 sub death
 775 {
 776     Warn @_ ;
 777     exit 1 ;
 778 }
 779
 780 sub generate_init {
 781     local($type, $num, $var) = @_;
 782     local($arg) = "ST(" . ($num - 1) . ")";
 783     local($argoff) = $num - 1;
 784     local($ntype);
 785     local($tk);
 786
 787     $type = TidyType($type) ;
 788     blurt("Error: '$type' not in typemap"), return
 789         unless defined($type_kind{$type});
 790
 791     ($ntype = $type) =~ s/\s*\*/Ptr/g;
 792     $subtype = $ntype;
 793     $subtype =~ s/Ptr$//;
 794     $subtype =~ s/Array$//;
 795     $tk = $type_kind{$type};
 796     $tk =~ s/OBJ$/REF/ if $func_name =~ /DESTROY$/;
 797     $type =~ s/:/_/g;
 798     blurt("Error: No INPUT definition for type '$type' found"), return
 799         unless defined $input_expr{$tk} ;
 800     $expr = $input_expr{$tk};
 801     if ($expr =~ /DO_ARRAY_ELEM/) {
 802         blurt("Error: '$subtype' not in typemap"), return
 803             unless defined($type_kind{$subtype});
 804         blurt("Error: No INPUT definition for type '$subtype' found"), return
 805             unless defined $input_expr{$type_kind{$subtype}} ;
 806         $subexpr = $input_expr{$type_kind{$subtype}};
 807         $subexpr =~ s/ntype/subtype/g;
 808         $subexpr =~ s/\$arg/ST(ix_$var)/g;
 809         $subexpr =~ s/\n\t/\n\t\t/g;
 810         $subexpr =~ s/is not of (.*")/[arg %d] is not of $1, ix_$var + 1/g;
 811         $subexpr =~ s/\$var/${var}[ix_$var - $argoff]/;
 812         $expr =~ s/DO_ARRAY_ELEM/$subexpr/;
 813     }
 814     if (defined($defaults{$var})) {
 815             $expr =~ s/(\t+)/$1    /g;
 816             $expr =~ s/        /\t/g;
 817             eval qq/print "\\t$var;\\n"/;
 818             $deferred .= eval qq/"\\n\\tif (items < $num)\\n\\t    $var = $defaults{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/;
 819     } elsif ($expr !~ /^\t\$var =/) {
 820             eval qq/print "\\t$var;\\n"/;
 821             $deferred .= eval qq/"\\n$expr;\\n"/;
 822     } else {
 823             eval qq/print "$expr;\\n"/;
 824     }
 825 }
 826
 827 sub generate_output {
 828     local($type, $num, $var) = @_;
 829     local($arg) = "ST(" . ($num - ($num != 0)) . ")";
 830     local($argoff) = $num - 1;
 831     local($ntype);
 832
 833     $type = TidyType($type) ;
 834     if ($type =~ /^array\(([^,]*),(.*)\)/) {
 835             print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1)), XFree((char *)$var);\n";
 836     } else {
 837             blurt("Error: '$type' not in typemap"), return
 838                 unless defined($type_kind{$type});
 839             blurt("Error: No OUTPUT definition for type '$type' found"), return
 840                 unless defined $output_expr{$type_kind{$type}} ;
 841             ($ntype = $type) =~ s/\s*\*/Ptr/g;
 842             $ntype =~ s/\(\)//g;
 843             $subtype = $ntype;
 844             $subtype =~ s/Ptr$//;
 845             $subtype =~ s/Array$//;
 846             $expr = $output_expr{$type_kind{$type}};
 847             if ($expr =~ /DO_ARRAY_ELEM/) {
 848                 blurt("Error: '$subtype' not in typemap"), return
 849                     unless defined($type_kind{$subtype});
 850                 blurt("Error: No OUTPUT definition for type '$subtype' found"), return
 851                     unless defined $output_expr{$type_kind{$subtype}} ;
 852                 $subexpr = $output_expr{$type_kind{$subtype}};
 853                 $subexpr =~ s/ntype/subtype/g;
 854                 $subexpr =~ s/\$arg/ST(ix_$var)/g;
 855                 $subexpr =~ s/\$var/${var}[ix_$var]/g;
 856                 $subexpr =~ s/\n\t/\n\t\t/g;
 857                 $expr =~ s/DO_ARRAY_ELEM\n/$subexpr/;
 858                 eval "print qq\a$expr\a";
 859             }
 860             elsif ($var eq 'RETVAL') {
 861                 if ($expr =~ /^\t\$arg = /) {
 862                     eval "print qq\a$expr\a";
 863                     print "\tsv_2mortal(ST(0));\n";
 864                 }
 865                 else {
 866                     print "\tST(0) = sv_newmortal();\n";
 867                     eval "print qq\a$expr\a";
 868                 }
 869             }
 870             elsif ($arg =~ /^ST\(\d+\)$/) {
 871                 eval "print qq\a$expr\a";
 872             }
 873     }
 874 }
 875
 876 sub map_type {
 877     local($type) = @_;
 878
 879     $type =~ s/:/_/g;
 880     if ($type =~ /^array\(([^,]*),(.*)\)/) {
 881             return "$1 *";
 882     } else {
 883             return $type;
 884     }
 885 }
 886
 887 # If this is VMS, the exit status has meaning to the shell, so we
 888 # use a predictable value (SS$_Abort) rather than an arbitrary
 889 # number.
 890 exit ($Is_VMS ? 44 : $errors) ;