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<-noprototypes>] [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<-noprototypes>
  48
  49
  50 =back
  51
  52 =head1 ENVIRONMENT
  53
  54 No environment variables are used.
  55
  56 =head1 AUTHOR
  57
  58 Larry Wall
  59
  60 =head1 MODIFICATION HISTORY
  61
  62 See the file F<changes.pod>.
  63
  64 =head1 SEE ALSO
  65
  66 perl(1), perlapi(1)
  67
  68 =cut
  69
  70 # Global Constants
  71 $XSUBPP_version = "1.924";
  72 require 5.002;
  73
  74 $usage = "Usage: xsubpp [-v] [-C++] [-except] [-noprototypes] [-s pattern] [-typemap typemap]... file.xs\n";
  75
  76 $proto_re = "[" . quotemeta('\$%&*@;') . "]" ;
  77
  78 $except = "";
  79 $WantPrototypes = 1 ;
  80 SWITCH: while (@ARGV and $ARGV[0] =~ /^-./) {
  81     $flag = shift @ARGV;
  82     $flag =~ s/^-// ;
  83     $spat = shift,      next SWITCH     if $flag eq 's';
  84     $cplusplus = 1,     next SWITCH     if $flag eq 'C++';
  85     $WantPrototypes = 0, next SWITCH    if $flag eq 'noprototypes';
  86     $WantPrototypes = 1, next SWITCH    if $flag eq 'prototypes';
  87     $except = " TRY",   next SWITCH     if $flag eq 'except';
  88     push(@tm,shift),    next SWITCH     if $flag eq 'typemap';
  89     (print "xsubpp version $XSUBPP_version\n"), exit
  90         if $flag eq 'v';
  91     die $usage;
  92 }
  93 @ARGV == 1 or die $usage;
  94 chomp($pwd = `pwd`);
  95 # Check for error message from VMS
  96 if ($pwd =~ /unrecognized command verb/) { $Is_VMS = 1; $pwd = $ENV{DEFAULT} }
  97 ($dir, $filename) = $ARGV[0] =~ m#(.*)/(.*)#
  98         or ($dir, $filename) = $ARGV[0] =~ m#(.*[>\]])(.*)#
  99         or ($dir, $filename) = ('.', $ARGV[0]);
 100 chdir($dir);
 101
 102 sub TrimWhitespace
 103 {
 104     $_[0] =~ s/^\s+|\s+$//go ;
 105 }
 106
 107 sub TidyType
 108 {
 109     local ($_) = @_ ;
 110
 111     # rationalise any '*' by joining them into bunches and removing whitespace
 112     s#\s*(\*+)\s*#$1#g;
 113     s#(\*+)# $1 #g ;
 114
 115     # change multiple whitespace into a single space
 116     s/\s+/ /g ;
 117
 118     # trim leading & trailing whitespace
 119     TrimWhitespace($_) ;
 120
 121     $_ ;
 122 }
 123
 124 $typemap = shift @ARGV;
 125 foreach $typemap (@tm) {
 126     die "Can't find $typemap in $pwd\n" unless -r $typemap;
 127 }
 128 unshift @tm, qw(../../../../lib/ExtUtils/typemap ../../../lib/ExtUtils/typemap
 129                 ../../lib/ExtUtils/typemap ../../../typemap ../../typemap
 130                 ../typemap typemap);
 131 foreach $typemap (@tm) {
 132     next unless -e $typemap ;
 133     # skip directories, binary files etc.
 134     warn("Warning: ignoring non-text typemap file '$typemap'\n"), next
 135         unless -T $typemap ;
 136     open(TYPEMAP, $typemap)
 137         or warn ("Warning: could not open typemap file '$typemap': $!\n"), next;
 138     $mode = 'Typemap';
 139     $junk = "" ;
 140     $current = \$junk;
 141     while (<TYPEMAP>) {
 142         next if /^\s*#/;
 143         if (/^INPUT\s*$/)   { $mode = 'Input';   $current = \$junk;  next; }
 144         if (/^OUTPUT\s*$/)  { $mode = 'Output';  $current = \$junk;  next; }
 145         if (/^TYPEMAP\s*$/) { $mode = 'Typemap'; $current = \$junk;  next; }
 146         if ($mode eq 'Typemap') {
 147             chomp;
 148             my $line = $_ ;
 149             TrimWhitespace($_) ;
 150             # skip blank lines and comment lines
 151             next if /^$/ or /^#/ ;
 152             my($type,$kind, $proto) = /^\s*(.*?\S)\s+(\S+)\s*($proto_re*)\s*$/ or
 153                 warn("Warning: File '$typemap' Line $. '$line' TYPEMAP entry needs 2 or 3 columns\n"), next;
 154             $type = TidyType($type) ;
 155             $type_kind{$type} = $kind ;
 156             # prototype defaults to '$'
 157             $proto = '$' unless $proto ;
 158             warn("Warning: File '$typemap' Line $. '$line' Invalid prototype '$proto'\n")
 159                 unless ValidProtoString($proto) ;
 160             $proto_letter{$type} = C_string($proto) ;
 161         }
 162         elsif (/^\s/) {
 163             $$current .= $_;
 164         }
 165         elsif ($mode eq 'Input') {
 166             s/\s+$//;
 167             $input_expr{$_} = '';
 168             $current = \$input_expr{$_};
 169         }
 170         else {
 171             s/\s+$//;
 172             $output_expr{$_} = '';
 173             $current = \$output_expr{$_};
 174         }
 175     }
 176     close(TYPEMAP);
 177 }
 178
 179 foreach $key (keys %input_expr) {
 180     $input_expr{$key} =~ s/\n+$//;
 181 }
 182
 183 $END = "!End!\n\n";             # "impossible" keyword (multiple newline)
 184
 185 # Match an XS keyword
 186 $BLOCK_re= '\s*(' . join('|', qw(
 187         REQUIRE BOOT CASE PREINIT INPUT INIT CODE PPCODE OUTPUT
 188         CLEANUP ALIAS PROTOTYPES PROTOTYPE
 189         )) . "|$END)\\s*:";
 190
 191 # Input:  ($_, @line) == unparsed input.
 192 # Output: ($_, @line) == (rest of line, following lines).
 193 # Return: the matched keyword if found, otherwise 0
 194 sub check_keyword {
 195         $_ = shift(@line) while !/\S/ && @line;
 196         s/^(\s*)($_[0])\s*:\s*(?:#.*)?/$1/s && $2;
 197 }
 198
 199
 200 sub print_section {
 201     $_ = shift(@line) while !/\S/ && @line;
 202     for (;  defined($_) && !/^$BLOCK_re/o;  $_ = shift(@line)) {
 203         print "$_\n";
 204     }
 205 }
 206
 207 sub CASE_handler {
 208     blurt ("Error: `CASE:' after unconditional `CASE:'")
 209         if $condnum && $cond eq '';
 210     $cond = $_;
 211     TrimWhitespace($cond);
 212     print "   ", ($condnum++ ? " else" : ""), ($cond ? " if ($cond)\n" : "\n");
 213     $_ = '' ;
 214 }
 215
 216 sub INPUT_handler {
 217     for (;  !/^$BLOCK_re/o;  $_ = shift(@line)) {
 218         last if /^\s*NOT_IMPLEMENTED_YET/;
 219         next unless /\S/;       # skip blank lines
 220
 221         TrimWhitespace($_) ;
 222         my $line = $_ ;
 223
 224         # remove trailing semicolon if no initialisation
 225         s/\s*;$//g unless /=/ ;
 226
 227         # check for optional initialisation code
 228         my $var_init = '' ;
 229         $var_init = $1 if s/\s*(=.*)$//s ;
 230         $var_init =~ s/"/\\"/g;
 231
 232         s/\s+/ /g;
 233         my ($var_type, $var_addr, $var_name) = /^(.*?[^& ]) *(\&?) *\b(\w+)$/s
 234             or blurt("Error: invalid argument declaration '$line'"), next;
 235
 236         # Check for duplicate definitions
 237         blurt ("Error: duplicate definition of argument '$var_name' ignored"), next
 238             if $arg_list{$var_name} ++  ;
 239
 240         $thisdone |= $var_name eq "THIS";
 241         $retvaldone |= $var_name eq "RETVAL";
 242         $var_types{$var_name} = $var_type;
 243         print "\t" . &map_type($var_type);
 244         $var_num = $args_match{$var_name};
 245
 246         $proto_arg[$var_num] = ProtoString($var_type) ;
 247         if ($var_addr) {
 248             $var_addr{$var_name} = 1;
 249             $func_args =~ s/\b($var_name)\b/&$1/;
 250         }
 251         if ($var_init =~ /^=\s*NO_INIT\s*;?\s*$/) {
 252             print "\t$var_name;\n";
 253         } elsif ($var_init =~ /\S/) {
 254             &output_init($var_type, $var_num, "$var_name $var_init");
 255         } elsif ($var_num) {
 256             # generate initialization code
 257             &generate_init($var_type, $var_num, $var_name);
 258         } else {
 259             print ";\n";
 260         }
 261     }
 262 }
 263
 264 sub OUTPUT_handler {
 265     for (;  !/^$BLOCK_re/o;  $_ = shift(@line)) {
 266         next unless /\S/;
 267         my ($outarg, $outcode) = /^\s*(\S+)\s*(.*?)\s*$/s ;
 268         blurt ("Error: duplicate OUTPUT argument '$outarg' ignored"), next
 269             if $outargs{$outarg} ++ ;
 270         if (!$gotRETVAL and $outarg eq 'RETVAL') {
 271             # deal with RETVAL last
 272             $RETVAL_code = $outcode ;
 273             $gotRETVAL = 1 ;
 274             next ;
 275         }
 276         blurt ("Error: OUTPUT $outarg not an argument"), next
 277             unless defined($args_match{$outarg});
 278         blurt("Error: No input definition for OUTPUT argument '$outarg' - ignored"), next
 279             unless defined $var_types{$outarg} ;
 280         if ($outcode) {
 281             print "\t$outcode\n";
 282         } else {
 283             $var_num = $args_match{$outarg};
 284             &generate_output($var_types{$outarg}, $var_num, $outarg);
 285         }
 286     }
 287 }
 288
 289 sub GetAliases
 290 {
 291     my ($line) = @_ ;
 292     my ($orig) = $line ;
 293     my ($alias) ;
 294     my ($value) ;
 295
 296     # Parse alias definitions
 297     # format is
 298     #    alias = value alias = value ...
 299
 300     while ($line =~ s/^\s*([\w:]+)\s*=\s*(\w+)\s*//) {
 301         $alias = $1 ;
 302         $orig_alias = $alias ;
 303         $value = $2 ;
 304
 305         # check for optional package definition in the alias
 306         $alias = $Packprefix . $alias if $alias !~ /::/ ;
 307
 308         # check for duplicate alias name & duplicate value
 309         Warn("Warning: Ignoring duplicate alias '$orig_alias'")
 310             if defined $XsubAliases{$pname}{$alias} ;
 311
 312         Warn("Warning: Aliases '$orig_alias' and '$XsubAliasValues{$pname}{$value}' have identical values")
 313             if $XsubAliasValues{$pname}{$value} ;
 314
 315         $XsubAliases{$pname}{$alias} = $value ;
 316         $XsubAliasValues{$pname}{$value} = $orig_alias ;
 317     }
 318
 319     blurt("Error: Cannot parse ALIAS definitions from '$orig'")
 320         if $line ;
 321 }
 322
 323 sub ALIAS_handler ()
 324 {
 325     for (;  !/^$BLOCK_re/o;  $_ = shift(@line)) {
 326         next unless /\S/;
 327         TrimWhitespace($_) ;
 328         GetAliases($_) if $_ ;
 329     }
 330 }
 331
 332 sub REQUIRE_handler ()
 333 {
 334     # the rest of the current line should contain a version number
 335     my ($Ver) = $_ ;
 336
 337     TrimWhitespace($Ver) ;
 338
 339     death ("Error: REQUIRE expects a version number")
 340         unless $Ver ;
 341
 342     # check that the version number is of the form n.n
 343     death ("Error: REQUIRE: expected a number, got '$Ver'")
 344         unless $Ver =~ /^\d+(\.\d*)?/ ;
 345
 346     death ("Error: xsubpp $Ver (or better) required--this is only $XSUBPP_version.")
 347         unless $XSUBPP_version >= $Ver ;
 348 }
 349
 350 sub PROTOTYPE_handler ()
 351 {
 352     for (;  !/^$BLOCK_re/o;  $_ = shift(@line)) {
 353         next unless /\S/;
 354         TrimWhitespace($_) ;
 355         if ($_ eq 'DISABLE') {
 356            $ProtoThisXSUB = 0
 357         }
 358         elsif ($_ eq 'ENABLE') {
 359            $ProtoThisXSUB = 1
 360         }
 361         else {
 362             # remove any whitespace
 363             s/\s+//g ;
 364             death("Error: Invalid prototype '$_'")
 365                 unless ValidProtoString($_) ;
 366             $ProtoThisXSUB = C_string($_) ;
 367         }
 368     }
 369 }
 370
 371 sub PROTOTYPES_handler ()
 372 {
 373     # the rest of the current line should contain either ENABLE or
 374     # DISABLE
 375
 376     TrimWhitespace($_) ;
 377
 378     # check for ENABLE/DISABLE
 379     death ("Error: PROTOTYPES: ENABLE/DISABLE")
 380         unless /^(ENABLE|DISABLE)/i ;
 381
 382     $WantPrototypes = 1 if $1 eq 'ENABLE' ;
 383     $WantPrototypes = 0 if $1 eq 'DISABLE' ;
 384
 385 }
 386
 387 sub ValidProtoString ($)
 388 {
 389     my($string) = @_ ;
 390
 391     if ( $string =~ /^$proto_re+$/ ) {
 392         return $string ;
 393     }
 394
 395     return 0 ;
 396 }
 397
 398 sub C_string ($)
 399 {
 400     my($string) = @_ ;
 401
 402     $string =~ s[\\][\\\\]g ;
 403     $string ;
 404 }
 405
 406 sub ProtoString ($)
 407 {
 408     my ($type) = @_ ;
 409
 410     $proto_letter{$type} or '$' ;
 411 }
 412
 413 sub check_cpp {
 414     my @cpp = grep(/^\#\s*(?:if|e\w+)/, @line);
 415     if (@cpp) {
 416         my ($cpp, $cpplevel);
 417         for $cpp (@cpp) {
 418             if ($cpp =~ /^\#\s*if/) {
 419                 $cpplevel++;
 420             } elsif (!$cpplevel) {
 421                 Warn("Warning: #else/elif/endif without #if in this function");
 422                 return;
 423             } elsif ($cpp =~ /^\#\s*endif/) {
 424                 $cpplevel--;
 425             }
 426         }
 427         Warn("Warning: #if without #endif in this function") if $cpplevel;
 428     }
 429 }
 430
 431
 432 sub Q {
 433     my($text) = @_;
 434     $text =~ s/^#//gm;
 435     $text =~ s/\[\[/{/g;
 436     $text =~ s/\]\]/}/g;
 437     $text;
 438 }
 439
 440 open(F, $filename) or die "cannot open $filename: $!\n";
 441
 442 # Identify the version of xsubpp used
 443 print <<EOM ;
 444 /*
 445  * This file was generated automatically by xsubpp version $XSUBPP_version from the
 446  * contents of $filename. Don't edit this file, edit $filename instead.
 447  *
 448  *      ANY CHANGES MADE HERE WILL BE LOST!
 449  *
 450  */
 451
 452 EOM
 453
 454
 455 while (<F>) {
 456     last if ($Module, $Package, $Prefix) =
 457         /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/;
 458     print $_;
 459 }
 460 &Exit unless defined $_;
 461
 462 my $lastline    = $_;
 463 my $lastline_no = $.;
 464
 465
 466 # Read next xsub into @line from ($lastline, <F>).
 467 sub fetch_para {
 468     # parse paragraph
 469     @line = ();
 470     @line_no = () ;
 471     return 0 unless defined $lastline;
 472
 473     if ($lastline =~
 474         /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/) {
 475         $Module = $1;
 476         $Package = defined($2) ? $2 : '';       # keep -w happy
 477         $Prefix  = defined($3) ? $3 : '';       # keep -w happy
 478         ($Module_cname = $Module) =~ s/\W/_/g;
 479         ($Packid = $Package) =~ tr/:/_/;
 480         $Packprefix = $Package;
 481         $Packprefix .= "::" if $Packprefix ne "";
 482         $lastline = "";
 483     }
 484
 485     for(;;) {
 486         if ($lastline !~ /^\s*#/ ||
 487             $lastline =~ /^#[ \t]*(?:(?:if|ifn?def|else|elif|endif|define|undef|pragma)\b|include\s*["<].*[>"])/) {
 488             last if $lastline =~ /^\S/ && @line && $line[-1] eq "";
 489             push(@line, $lastline);
 490             push(@line_no, $lastline_no) ;
 491         }
 492
 493         # Read next line and continuation lines
 494         last unless defined($lastline = <F>);
 495         $lastline_no = $.;
 496         my $tmp_line;
 497         $lastline .= $tmp_line
 498             while ($lastline =~ /\\$/ && defined($tmp_line = <F>));
 499
 500         chomp $lastline;
 501         $lastline =~ s/^\s+$//;
 502     }
 503     pop(@line), pop(@line_no) while @line && $line[-1] eq "";
 504     1;
 505 }
 506
 507 PARAGRAPH:
 508 while (fetch_para()) {
 509     # Print initial preprocessor statements and blank lines
 510     print shift(@line), "\n"
 511         while @line && $line[0] !~ /^[^\#]/;
 512
 513     next PARAGRAPH unless @line;
 514
 515     death ("Code is not inside a function")
 516         if $line[0] =~ /^\s/;
 517
 518     # initialize info arrays
 519     undef(%args_match);
 520     undef(%var_types);
 521     undef(%var_addr);
 522     undef(%defaults);
 523     undef($class);
 524     undef($static);
 525     undef($elipsis);
 526     undef($wantRETVAL) ;
 527     undef(%arg_list) ;
 528     undef(@proto_arg) ;
 529     $ProtoThisXSUB = $WantPrototypes ;
 530
 531     $_ = shift(@line);
 532     while ($kwd = check_keyword("REQUIRE|PROTOTYPES")) {
 533         if ($kwd eq 'REQUIRE')
 534           { REQUIRE_handler() }
 535         else
 536           { PROTOTYPES_handler() }
 537         next PARAGRAPH unless @line ;
 538         $_ = shift(@line);
 539     }
 540
 541     if (check_keyword("BOOT")) {
 542         &check_cpp;
 543         push (@BootCode, $_, @line, "") ;
 544         next PARAGRAPH ;
 545     }
 546
 547
 548     # extract return type, function name and arguments
 549     my($ret_type) = TidyType($_);
 550
 551     # a function definition needs at least 2 lines
 552     blurt ("Error: Function definition too short '$ret_type'"), next PARAGRAPH
 553         unless @line ;
 554
 555     $static = 1 if $ret_type =~ s/^static\s+//;
 556
 557     $func_header = shift(@line);
 558     blurt ("Error: Cannot parse function definition from '$func_header'"), next PARAGRAPH
 559         unless $func_header =~ /^(?:([\w:]*)::)?(\w+)\s*\(\s*(.*?)\s*\)\s*$/s;
 560
 561     ($class, $func_name, $orig_args) =  ($1, $2, $3) ;
 562     ($pname = $func_name) =~ s/^($Prefix)?/$Packprefix/;
 563
 564     # Check for duplicate function definition
 565     if (defined $Func_name{"${Packid}_$func_name"} ) {
 566        Warn("Warning: duplicate function definition '$func_name' detected")
 567     }
 568     else {
 569         push(@Func_name, "${Packid}_$func_name");
 570         push(@Func_pname, $pname);
 571     }
 572     $Func_name{"${Packid}_$func_name"} ++ ;
 573
 574     @args = split(/\s*,\s*/, $orig_args);
 575     if (defined($class)) {
 576         my $arg0 = (defined($static) ? "CLASS" : "THIS");
 577         unshift(@args, $arg0);
 578         ($orig_args = "$arg0, $orig_args") =~ s/^$arg0, $/$arg0/;
 579     }
 580     $orig_args =~ s/"/\\"/g;
 581     $min_args = $num_args = @args;
 582     foreach $i (0..$num_args-1) {
 583             if ($args[$i] =~ s/\.\.\.//) {
 584                     $elipsis = 1;
 585                     $min_args--;
 586                     if ($args[$i] eq '' && $i == $num_args - 1) {
 587                         pop(@args);
 588                         last;
 589                     }
 590             }
 591             if ($args[$i] =~ /^([^=]*[^\s=])\s*=\s*(.*)/s) {
 592                     $min_args--;
 593                     $args[$i] = $1;
 594                     $defaults{$args[$i]} = $2;
 595                     $defaults{$args[$i]} =~ s/"/\\"/g;
 596             }
 597             $proto_arg[$i+1] = '$' ;
 598     }
 599     if (defined($class)) {
 600             $func_args = join(", ", @args[1..$#args]);
 601     } else {
 602             $func_args = join(", ", @args);
 603     }
 604     @args_match{@args} = 1..@args;
 605
 606     $PPCODE = grep(/^\s*PPCODE\s*:/, @line);
 607     $ALIAS  = grep(/^\s*ALIAS\s*:/,  @line);
 608
 609     # print function header
 610     print Q<<"EOF";
 611 #XS(XS_${Packid}_$func_name)
 612 #[[
 613 #    dXSARGS;
 614 EOF
 615     print Q<<"EOF" if $ALIAS ;
 616 #    dXSI32;
 617 EOF
 618     if ($elipsis) {
 619         $cond = ($min_args ? qq(items < $min_args) : 0);
 620     }
 621     elsif ($min_args == $num_args) {
 622         $cond = qq(items != $min_args);
 623     }
 624     else {
 625         $cond = qq(items < $min_args || items > $num_args);
 626     }
 627
 628     print Q<<"EOF" if $except;
 629 #    char errbuf[1024];
 630 #    *errbuf = '\0';
 631 EOF
 632
 633     if ($ALIAS)
 634       { print Q<<"EOF" if $cond }
 635 #    if ($cond)
 636 #       croak("Usage: %s($orig_args)", GvNAME(CvGV(cv)));
 637 EOF
 638     else
 639       { print Q<<"EOF" if $cond }
 640 #    if ($cond)
 641 #       croak("Usage: $pname($orig_args)");
 642 EOF
 643
 644     print Q<<"EOF" if $PPCODE;
 645 #    SP -= items;
 646 EOF
 647
 648     # Now do a block of some sort.
 649
 650     $condnum = 0;
 651     $cond = '';                 # last CASE: condidional
 652     push(@line, "$END:");
 653     push(@line_no, $line_no[-1]);
 654     $_ = '';
 655     &check_cpp;
 656     while (@line) {
 657         &CASE_handler if check_keyword("CASE");
 658         print Q<<"EOF";
 659 #   $except [[
 660 EOF
 661
 662         # do initialization of input variables
 663         $thisdone = 0;
 664         $retvaldone = 0;
 665         $deferred = "";
 666         %arg_list = () ;
 667         $gotRETVAL = 0;
 668
 669         &INPUT_handler;
 670         my $kwd;
 671         while ($kwd = check_keyword("INPUT|PREINIT")) {
 672             if ($kwd eq 'PREINIT') { &print_section; } else { &INPUT_handler; }
 673         }
 674         if (!$thisdone && defined($class)) {
 675             if (defined($static)) {
 676                 print "\tchar *";
 677                 $var_types{"CLASS"} = "char *";
 678                 &generate_init("char *", 1, "CLASS");
 679             }
 680             else {
 681                 print "\t$class *";
 682                 $var_types{"THIS"} = "$class *";
 683                 &generate_init("$class *", 1, "THIS");
 684             }
 685         }
 686
 687         # do code
 688         if (/^\s*NOT_IMPLEMENTED_YET/) {
 689                 print "\n\tcroak(\"$pname: not implemented yet\");\n";
 690                 $_ = '' ;
 691         } else {
 692                 if ($ret_type ne "void") {
 693                         print "\t" . &map_type($ret_type) . "\tRETVAL;\n"
 694                                 if !$retvaldone;
 695                         $args_match{"RETVAL"} = 0;
 696                         $var_types{"RETVAL"} = $ret_type;
 697                 }
 698                 print $deferred;
 699                 while ($kwd = check_keyword("INIT|ALIAS|PROTOTYPE")) {
 700                     if ($kwd eq 'INIT') {
 701                         &print_section
 702                     }
 703                     elsif ($kwd eq 'PROTOTYPE')
 704                       {  PROTOTYPE_handler() }
 705                     else
 706                       {  ALIAS_handler() }
 707                 }
 708
 709                 if (check_keyword("PPCODE")) {
 710                         &print_section;
 711                         death ("PPCODE must be last thing") if @line;
 712                         print "\tPUTBACK;\n\treturn;\n";
 713                 } elsif (check_keyword("CODE")) {
 714                         &print_section;
 715                 } elsif ($func_name eq "DESTROY") {
 716                         print "\n\t";
 717                         print "delete THIS;\n";
 718                 } else {
 719                         print "\n\t";
 720                         if ($ret_type ne "void") {
 721                                 print "RETVAL = ";
 722                                 $wantRETVAL = 1;
 723                         }
 724                         if (defined($static)) {
 725                             if ($func_name =~ /^new/) {
 726                                 $func_name .= " $class";
 727                             } else {
 728                                 print "${class}::";
 729                             }
 730                         } elsif (defined($class)) {
 731                                 print "THIS->";
 732                         }
 733                         $func_name =~ s/^($spat)//
 734                             if defined($spat);
 735                         print "$func_name($func_args);\n";
 736                 }
 737         }
 738
 739         # do output variables
 740         $gotRETVAL = 0;
 741         undef $RETVAL_code ;
 742         undef %outargs ;
 743         &OUTPUT_handler while check_keyword("OUTPUT");
 744
 745         # all OUTPUT done, so now push the return value on the stack
 746         if ($gotRETVAL && $RETVAL_code) {
 747             print "\t$RETVAL_code\n";
 748         } elsif ($gotRETVAL || $wantRETVAL) {
 749             &generate_output($ret_type, 0, 'RETVAL');
 750         }
 751
 752         # do cleanup
 753         &print_section while check_keyword("CLEANUP");
 754
 755         # print function trailer
 756         print Q<<EOF;
 757 #    ]]
 758 EOF
 759         print Q<<EOF if $except;
 760 #    BEGHANDLERS
 761 #    CATCHALL
 762 #       sprintf(errbuf, "%s: %s\\tpropagated", Xname, Xreason);
 763 #    ENDHANDLERS
 764 EOF
 765         if (check_keyword("CASE")) {
 766             blurt ("Error: No `CASE:' at top of function")
 767                 unless $condnum;
 768             $_ = "CASE: $_";    # Restore CASE: label
 769             next;
 770         }
 771         last if $_ eq "$END:";
 772         death(/^$BLOCK_re/o ? "Misplaced `$1:'" : "Junk at end of function");
 773     }
 774
 775     print Q<<EOF if $except;
 776 #    if (errbuf[0])
 777 #       croak(errbuf);
 778 EOF
 779
 780     print Q<<EOF unless $PPCODE;
 781 #    XSRETURN(1);
 782 EOF
 783
 784     print Q<<EOF;
 785 #]]
 786 #
 787 EOF
 788
 789     # Build the prototype string for the xsub
 790     if ($ProtoThisXSUB) {
 791         if ($ProtoThisXSUB != 1) {
 792             $ProtoXSUB{$pname} = '"' . $ProtoThisXSUB . '"'
 793         }
 794         else {
 795             my $s = ';';
 796             if ($min_args < $num_args)  {
 797                 $s = '';
 798                 $proto_arg[$min_args] .= ";" ;
 799             }
 800             push @proto_arg, "${s}@"
 801                 if $elipsis ;
 802
 803             $ProtoXSUB{$pname} = '"' . join ("", @proto_arg) . '"'
 804         }
 805     }
 806
 807 }
 808
 809 # print initialization routine
 810 print Q<<"EOF";
 811 ##ifdef __cplusplus
 812 #extern "C"
 813 ##endif
 814 #XS(boot_$Module_cname)
 815 #[[
 816 #    dXSARGS;
 817 #    char* file = __FILE__;
 818 #
 819 EOF
 820
 821 print Q<<"EOF" if defined %XsubAliases ;
 822 #    {
 823 #        CV * cv ;
 824 #
 825 EOF
 826
 827 for (@Func_name) {
 828     $pname = shift(@Func_pname);
 829     my $newXS = "newXS" ;
 830     my $proto = "" ;
 831
 832     if ($ProtoXSUB{$pname}) {
 833         $newXS = "newXSproto" ;
 834         $proto = ", $ProtoXSUB{$pname}" ;
 835     }
 836
 837     if ($XsubAliases{$pname}) {
 838         $XsubAliases{$pname}{$pname} = 0
 839                 unless defined $XsubAliases{$pname}{$pname} ;
 840         while ( ($name, $value) = each %{$XsubAliases{$pname}}) {
 841             print Q<<"EOF" ;
 842 #        cv = newXS(\"$name\", XS_$_, file);
 843 #        XSANY.any_i32 = $value ;
 844 EOF
 845             print Q<<"EOF" if $proto ;
 846 #        sv_setpv(cv, $ProtoXSUB{$pname}) ;
 847 EOF
 848         }
 849     }
 850     else {
 851         print "        ${newXS}(\"$pname\", XS_$_, file$proto);\n";
 852     }
 853 }
 854
 855 print Q<<"EOF" if defined %XsubAliases ;
 856 #    }
 857 EOF
 858
 859 if (@BootCode)
 860 {
 861     print "\n    /* Initialisation Section */\n" ;
 862     print grep (s/$/\n/, @BootCode) ;
 863     print "\n    /* End of Initialisation Section */\n\n" ;
 864 }
 865
 866 print Q<<"EOF";;
 867 #    ST(0) = &sv_yes;
 868 #    XSRETURN(1);
 869 #]]
 870 EOF
 871
 872 &Exit;
 873
 874
 875 sub output_init {
 876     local($type, $num, $init) = @_;
 877     local($arg) = "ST(" . ($num - 1) . ")";
 878
 879     eval qq/print " $init\\\n"/;
 880 }
 881
 882 sub Warn
 883 {
 884     # work out the line number
 885     my $line_no = $line_no[@line_no - @line -1] ;
 886
 887     print STDERR "@_ in $filename, line $line_no\n" ;
 888 }
 889
 890 sub blurt
 891 {
 892     Warn @_ ;
 893     $errors ++
 894 }
 895
 896 sub death
 897 {
 898     Warn @_ ;
 899     exit 1 ;
 900 }
 901
 902 sub generate_init {
 903     local($type, $num, $var) = @_;
 904     local($arg) = "ST(" . ($num - 1) . ")";
 905     local($argoff) = $num - 1;
 906     local($ntype);
 907     local($tk);
 908
 909     $type = TidyType($type) ;
 910     blurt("Error: '$type' not in typemap"), return
 911         unless defined($type_kind{$type});
 912
 913     ($ntype = $type) =~ s/\s*\*/Ptr/g;
 914     ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;
 915     $tk = $type_kind{$type};
 916     $tk =~ s/OBJ$/REF/ if $func_name =~ /DESTROY$/;
 917     $type =~ tr/:/_/;
 918     blurt("Error: No INPUT definition for type '$type' found"), return
 919         unless defined $input_expr{$tk} ;
 920     $expr = $input_expr{$tk};
 921     if ($expr =~ /DO_ARRAY_ELEM/) {
 922         blurt("Error: '$subtype' not in typemap"), return
 923             unless defined($type_kind{$subtype});
 924         blurt("Error: No INPUT definition for type '$subtype' found"), return
 925             unless defined $input_expr{$type_kind{$subtype}} ;
 926         $subexpr = $input_expr{$type_kind{$subtype}};
 927         $subexpr =~ s/ntype/subtype/g;
 928         $subexpr =~ s/\$arg/ST(ix_$var)/g;
 929         $subexpr =~ s/\n\t/\n\t\t/g;
 930         $subexpr =~ s/is not of (.*")/[arg %d] is not of $1, ix_$var + 1/g;
 931         $subexpr =~ s/\$var/${var}[ix_$var - $argoff]/;
 932         $expr =~ s/DO_ARRAY_ELEM/$subexpr/;
 933     }
 934     if (defined($defaults{$var})) {
 935             $expr =~ s/(\t+)/$1    /g;
 936             $expr =~ s/        /\t/g;
 937             eval qq/print "\\t$var;\\n"/;
 938             $deferred .= eval qq/"\\n\\tif (items < $num)\\n\\t    $var = $defaults{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/;
 939     } elsif ($expr !~ /^\t\$var =/) {
 940             eval qq/print "\\t$var;\\n"/;
 941             $deferred .= eval qq/"\\n$expr;\\n"/;
 942     } else {
 943             eval qq/print "$expr;\\n"/;
 944     }
 945 }
 946
 947 sub generate_output {
 948     local($type, $num, $var) = @_;
 949     local($arg) = "ST(" . ($num - ($num != 0)) . ")";
 950     local($argoff) = $num - 1;
 951     local($ntype);
 952
 953     $type = TidyType($type) ;
 954     if ($type =~ /^array\(([^,]*),(.*)\)/) {
 955             print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1)), XFree((char *)$var);\n";
 956     } else {
 957             blurt("Error: '$type' not in typemap"), return
 958                 unless defined($type_kind{$type});
 959             blurt("Error: No OUTPUT definition for type '$type' found"), return
 960                 unless defined $output_expr{$type_kind{$type}} ;
 961             ($ntype = $type) =~ s/\s*\*/Ptr/g;
 962             $ntype =~ s/\(\)//g;
 963             ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;
 964             $expr = $output_expr{$type_kind{$type}};
 965             if ($expr =~ /DO_ARRAY_ELEM/) {
 966                 blurt("Error: '$subtype' not in typemap"), return
 967                     unless defined($type_kind{$subtype});
 968                 blurt("Error: No OUTPUT definition for type '$subtype' found"), return
 969                     unless defined $output_expr{$type_kind{$subtype}} ;
 970                 $subexpr = $output_expr{$type_kind{$subtype}};
 971                 $subexpr =~ s/ntype/subtype/g;
 972                 $subexpr =~ s/\$arg/ST(ix_$var)/g;
 973                 $subexpr =~ s/\$var/${var}[ix_$var]/g;
 974                 $subexpr =~ s/\n\t/\n\t\t/g;
 975                 $expr =~ s/DO_ARRAY_ELEM\n/$subexpr/;
 976                 eval "print qq\a$expr\a";
 977             }
 978             elsif ($var eq 'RETVAL') {
 979                 if ($expr =~ /^\t\$arg = /) {
 980                     eval "print qq\a$expr\a";
 981                     print "\tsv_2mortal(ST(0));\n";
 982                 }
 983                 else {
 984                     print "\tST(0) = sv_newmortal();\n";
 985                     eval "print qq\a$expr\a";
 986                 }
 987             }
 988             elsif ($arg =~ /^ST\(\d+\)$/) {
 989                 eval "print qq\a$expr\a";
 990             }
 991     }
 992 }
 993
 994 sub map_type {
 995     my($type) = @_;
 996
 997     $type =~ tr/:/_/;
 998     $type =~ s/^array\(([^,]*),(.*)\).*/$1 */s;
 999     $type;
1000 }
1001
1002
1003 sub Exit {
1004 # If this is VMS, the exit status has meaning to the shell, so we
1005 # use a predictable value (SS$_Abort) rather than an arbitrary
1006 # number.
1007     exit ($Is_VMS ? 44 : $errors) ;
1008 }