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