lib/ExtUtils/xsubpp

   1 #!./miniperl
   2
   3 =head1 NAME
   4
   5 xsubpp - compiler to convert Perl XS code into C code
   6
   7 =head1 SYNOPSIS
   8
   9 B<xsubpp> [B<-C++>] [B<-except>] [B<-typemap typemap>]... file.xs
  10
  11 =head1 DESCRIPTION
  12
  13 I<xsubpp> will compile XS code into C code by embedding the constructs
  14 necessary to let C functions manipulate Perl values and creates the glue
  15 necessary to let Perl access those functions.  The compiler uses typemaps to
  16 determine how to map C function parameters and variables to Perl values.
  17
  18 The compiler will search for typemap files called I<typemap>.  It will use
  19 the following search path to find default typemaps, with the rightmost
  20 typemap taking precedence.
  21
  22         ../../../typemap:../../typemap:../typemap:typemap
  23
  24 =head1 OPTIONS
  25
  26 =over 5
  27
  28 =item B<-C++>
  29
  30 Adds ``extern "C"'' to the C code.
  31
  32
  33 =item B<-except>
  34
  35 Adds exception handling stubs to the C code.
  36
  37 =item B<-typemap typemap>
  38
  39 Indicates that a user-supplied typemap should take precedence over the
  40 default typemaps.  This option may be used multiple times, with the last
  41 typemap having the highest precedence.
  42
  43 =back
  44
  45 =head1 ENVIRONMENT
  46
  47 No environment variables are used.
  48
  49 =head1 AUTHOR
  50
  51 Larry Wall
  52
  53 =head1 MODIFICATION HISTORY
  54
  55 =head2 1.0
  56
  57 I<xsubpp> as released with Perl 5.000
  58
  59 =head2 1.1
  60
  61 I<xsubpp> as released with Perl 5.001
  62
  63 =head2 1.2
  64
  65 Changes by Paul Marquess <pmarquess@bfsec.bt.co.uk>, 22 May 1995.
  66
  67 =over 5
  68
  69 =item 1.
  70
  71 Added I<xsubpp> version number for the first time. As previous releases
  72 of I<xsubpp> did not have a formal version number, a numbering scheme
  73 has been applied retrospectively.
  74
  75 =item 2.
  76
  77 If OUTPUT: is being used to specify output parameters and RETVAL is
  78 also to be returned, it is now no longer necessary for the user to
  79 ensure that RETVAL is specified last.
  80
  81 =item 3.
  82
  83 The I<xsubpp> version number, the .xs filename and a time stamp are
  84 written to the generated .c file as a comment.
  85
  86 =item 4.
  87
  88 When I<xsubpp> is parsing the definition of both the input parameters
  89 and the OUTPUT parameters, any duplicate definitions will be noted and
  90 ignored.
  91
  92 =item 5.
  93
  94 I<xsubpp> is slightly more forgiving with extra whitespace.
  95
  96 =back
  97
  98 =head2 1.3
  99
 100 Changes by Paul Marquess <pmarquess@bfsec.bt.co.uk>, 23 May 1995.
 101
 102 =over 5
 103
 104 =item 1.
 105
 106 More whitespace restrictions have been relaxed. In particular some
 107 cases where a tab character was used to delimit fields has been
 108 removed. In these cases any whitespace will now suffice.
 109
 110 The specific places where changes have been made are in the TYPEMAP
 111 section of a typemap file and the input and OUTPUT: parameter
 112 declarations sections in a .xs file.
 113
 114 =item 2.
 115
 116 More error checking added.
 117
 118 Before processing each typemap file I<xsubpp> now checks that it is a
 119 text file. If not an warning will be displayed. In addition, a warning
 120 will be displayed if it is not possible to open the typemap file.
 121
 122 In the TYPEMAP section of a typemap file, an error will be raised if
 123 the line does not have 2 columns.
 124
 125 When parsing input parameter declarations check that there is at least
 126 a type and name pair.
 127
 128 =back
 129
 130 =head2 1.4
 131
 132 When parsing the OUTPUT arguments check that they are all present in
 133 the corresponding input argument definitions.
 134
 135 =head2 1.5
 136
 137 Changes by Paul Marquess <pmarquess@bfsec.bt.co.uk>, 1 June 1995.
 138
 139 Started tidy up to allow clean run using C<-w> flag.
 140
 141 Added some more error checking.
 142
 143 The CASE: functionality now works.
 144
 145 =head2 1.6
 146
 147 Changes by Paul Marquess <pmarquess@bfsec.bt.co.uk>, 3 June 1995.
 148
 149 Added some more error checking.
 150
 151 =head2 1.7
 152
 153 Changes by Paul Marquess <pmarquess@bfsec.bt.co.uk>, 5 June 1995.
 154
 155 When an error or warning message is printed C<xsubpp> will now attempt
 156 to identify the exact line in the C<.xs> file where the fault occurs.
 157 This can be achieved in the majority of cases.
 158
 159 =head2 1.8
 160
 161 Changes by Hallvard B Furuseth <h.b.furuseth@usit.uio.no>, 6 June 1995.
 162
 163 Accept backslash-newline as in C.  Allow preprocessor directives
 164 anywhere.  Ignore whitespace in front of comments and on blank lines.
 165
 166 =head2 1.9
 167
 168 Changes by Paul Marquess <pmarquess@bfsec.bt.co.uk>, 21 June 1995.
 169
 170 =over 5
 171
 172 =item 1.
 173
 174 Changed duplicate function error to a warning.
 175
 176 =item 2.
 177
 178 Changed the comment placed at the top of the C<.c> file to be more like
 179 the comment used by MakeMaker.
 180
 181 =item 3.
 182
 183 When parsing the type for an XSUB parameter I<xsubpp> can now accept
 184 definitions like this:
 185
 186     char *fred
 187
 188 i.e. the '*' is recognised as part of the type, rather than the first
 189 character of the variable.
 190
 191 =item 4.
 192
 193 Fixed a problem with command line parsing - I<xsubpp> was not properly
 194 detecting the case where there was no filename present on the command
 195 line.
 196
 197 =back
 198
 199 =head1 SEE ALSO
 200
 201 perl(1), perlapi(1)
 202
 203 =cut
 204
 205 # Global Constants
 206 $XSUBPP_version = "1.9" ;
 207
 208 $usage = "Usage: xsubpp [-C++] [-except] [-typemap typemap] file.xs\n";
 209
 210 SWITCH: while ($ARGV[0] =~ /^-/) {
 211     $flag = shift @ARGV;
 212     $flag =~ s/^-// ;
 213     $spat = shift,      next SWITCH     if $flag eq 's';
 214     $cplusplus = 1,     next SWITCH     if $flag eq 'C++';
 215     $except = 1,        next SWITCH     if $flag eq 'except';
 216     push(@tm,shift),    next SWITCH     if $flag eq 'typemap';
 217     die $usage;
 218 }
 219 @ARGV == 1 or die $usage;
 220 chomp($pwd = `pwd`);
 221 # Check for error message from VMS
 222 if ($pwd =~ /unrecognized command verb/) { $Is_VMS = 1; $pwd = $ENV{DEFAULT} }
 223 ($dir, $filename) = $ARGV[0] =~ m#(.*)/(.*)#
 224         or ($dir, $filename) = $ARGV[0] =~ m#(.*[>\]])(.*)#
 225         or ($dir, $filename) = ('.', $ARGV[0]);
 226 chdir($dir);
 227
 228 sub TrimWhitespace
 229 {
 230     $_[0] =~ s/^\s+|\s+$//go ;
 231 }
 232
 233 sub TidyType
 234 {
 235     local ($_) = @_ ;
 236
 237     # rationalise any '*' by joining them into bunches and removing whitespace
 238     s#\s*(\*+)\s*#$1#g;
 239     s#(\*+)# $1 #g ;
 240
 241     # change multiple whitespace into a single space
 242     s/\s+/ /g ;
 243
 244     # trim leading & trailing whitespace
 245     TrimWhitespace($_) ;
 246
 247     $_ ;
 248 }
 249
 250 $typemap = shift @ARGV;
 251 foreach $typemap (@tm) {
 252     die "Can't find $typemap in $pwd\n" unless -r $typemap;
 253 }
 254 unshift @tm, qw(../../../../lib/ExtUtils/typemap ../../../lib/ExtUtils/typemap
 255                 ../../lib/ExtUtils/typemap ../../../typemap ../../typemap
 256                 ../typemap typemap);
 257 foreach $typemap (@tm) {
 258     next unless -e $typemap ;
 259     # skip directories, binary files etc.
 260     warn("Warning: ignoring non-text typemap file '$typemap'\n"), next
 261         unless -T $typemap ;
 262     open(TYPEMAP, $typemap)
 263         or warn ("Warning: could not open typemap file '$typemap': $!\n"), next;
 264     $mode = 'Typemap';
 265     $junk = "" ;
 266     $current = \$junk;
 267     while (<TYPEMAP>) {
 268         next if /^\s*#/;
 269         if (/^INPUT\s*$/)   { $mode = 'Input';   next; }
 270         if (/^OUTPUT\s*$/)  { $mode = 'Output';  next; }
 271         if (/^TYPEMAP\s*$/) { $mode = 'Typemap'; next; }
 272         if ($mode eq 'Typemap') {
 273             chomp;
 274             my $line = $_ ;
 275             TrimWhitespace($_) ;
 276             # skip blank lines and comment lines
 277             next if /^$/ or /^#/ ;
 278             my @words = split (' ') ;
 279             warn("Warning: File '$typemap' Line $. '$line' TYPEMAP entry needs 2 columns\n"), next
 280                 unless @words >= 2 ;
 281             my $kind = pop @words ;
 282             TrimWhitespace($kind) ;
 283             $type_kind{TidyType("@words")} = $kind ;
 284         }
 285         elsif ($mode eq 'Input') {
 286             if (/^\s/) {
 287                 $$current .= $_;
 288             }
 289             else {
 290                 s/\s*$//;
 291                 $input_expr{$_} = '';
 292                 $current = \$input_expr{$_};
 293             }
 294         }
 295         else {
 296             if (/^\s/) {
 297                 $$current .= $_;
 298             }
 299             else {
 300                 s/\s*$//;
 301                 $output_expr{$_} = '';
 302                 $current = \$output_expr{$_};
 303             }
 304         }
 305     }
 306     close(TYPEMAP);
 307 }
 308
 309 foreach $key (keys %input_expr) {
 310     $input_expr{$key} =~ s/\n+$//;
 311 }
 312
 313 sub Q {
 314     my($text) = @_;
 315     $text =~ tr/#//d;
 316     $text =~ s/\[\[/{/g;
 317     $text =~ s/\]\]/}/g;
 318     $text;
 319 }
 320
 321 open(F, $filename) or die "cannot open $filename: $!\n";
 322
 323 # Identify the version of xsubpp used
 324 print <<EOM ;
 325 /*
 326  * This file was generated automatically by xsubpp version $XSUBPP_version from the
 327  * contents of $filename. Don't edit this file, edit $filename instead.
 328  *
 329  *      ANY CHANGES MADE HERE WILL BE LOST!
 330  *
 331  */
 332
 333 EOM
 334
 335
 336 while (<F>) {
 337     last if ($Module, $Package, $Prefix) =
 338         /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/;
 339     print $_;
 340 }
 341 &Exit unless defined $_;
 342
 343 my $lastline    = $_;
 344 my $lastline_no = $.;
 345
 346
 347 # Read next xsub into @line from ($lastline, <F>).
 348 sub fetch_para {
 349     # parse paragraph
 350     @line = ();
 351     @line_no = () ;
 352     return 0 unless defined $lastline;
 353
 354     if ($lastline =~
 355         /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/) {
 356         $Module = $1;
 357         $Package = $2;
 358         $Prefix = $3;
 359         ($Module_cname = $Module) =~ s/\W/_/g;
 360         ($Packid = $Package) =~ s/:/_/g;
 361         $Packprefix = $Package;
 362         $Packprefix .= "::" if defined $Packprefix && $Packprefix ne "";
 363         $lastline = "";
 364     }
 365
 366     for(;;) {
 367         if ($lastline !~ /^\s*#/ ||
 368             $lastline =~ /^#[ \t]*((if|ifn?def|else|elif|endif|define|undef|pragma)\b|include\s*["<].*[>"])/) {
 369             last if $lastline =~ /^\S/ && @line && $line[-1] eq "";
 370             push(@line, $lastline);
 371             push(@line_no, $lastline_no) ;
 372         }
 373
 374         # Read next line and continuation lines
 375         last unless defined($lastline = <F>);
 376         $lastline_no = $.;
 377         my $tmp_line;
 378         $lastline .= $tmp_line
 379             while ($lastline =~ /\\\n$/ && defined($tmp_line = <F>));
 380
 381         # chomp $lastline;
 382         $lastline =~ s/^\s+$//;
 383     }
 384     pop(@line), pop(@line_no) while @line && $line[-1] eq "";
 385     $PPCODE = grep(/^\s*PPCODE\s*:/, @line);
 386     1;
 387 }
 388
 389 PARAGRAPH:
 390 while (&fetch_para) {
 391     # Print initial preprocessor statements and blank lines
 392     print shift(@line), "\n"
 393         while @line && $line[0] !~ /^[^\#]/;
 394
 395     next PARAGRAPH unless @line;
 396
 397     death ("Code is not inside a function")
 398         if $line[0] =~ /^\s/;
 399
 400     # initialize info arrays
 401     # my(%args_match,%var_types,%var_addr);
 402     # my($class,$static,$elipsis,$wantRETVAL,%arg_list);
 403     undef(%args_match);
 404     undef(%var_types);
 405     undef(%var_addr);
 406     undef(%defaults);
 407     undef($class);
 408     undef($static);
 409     undef($elipsis);
 410     undef($wantRETVAL) ;
 411     undef(%arg_list) ;
 412
 413     # extract return type, function name and arguments
 414     my($ret_type) = TidyType(shift(@line));
 415
 416     if ($ret_type =~ /^BOOT\s*:/) {
 417         push (@BootCode, @line, "", "") ;
 418         next PARAGRAPH ;
 419     }
 420
 421     # a function definition needs at least 2 lines
 422     blurt ("Error: Function definition too short '$ret_type'"), next PARAGRAPH
 423         unless @line ;
 424
 425     if ($ret_type =~ /^static\s+(.*)$/) {
 426             $static = 1;
 427             $ret_type = $1;
 428     }
 429     $func_header = shift(@line);
 430     blurt ("Error: Cannot parse function definition from '$func_header'"), next PARAGRAPH
 431         unless $func_header =~ /^([\w:]+)\s*\((.*)\)$/;
 432
 433     ($func_name, $orig_args) =  ($1, $2) ;
 434     if ($func_name =~ /(.*)::(.*)/) {
 435             $class = $1;
 436             $func_name = $2;
 437     }
 438     $Prefix = '' unless defined $Prefix ; # keep -w happy
 439     ($pname = $func_name) =~ s/^($Prefix)?/$Packprefix/;
 440
 441     # Check for duplicate function definition
 442     Warn("Warning: duplicate function definition '$func_name' detected")
 443         if defined $Func_name{"${Packid}_$func_name"} ;
 444     $Func_name{"${Packid}_$func_name"} ++ ;
 445
 446     push(@Func_name, "${Packid}_$func_name");
 447     push(@Func_pname, $pname);
 448     @args = split(/\s*,\s*/, $orig_args);
 449     if (defined($class)) {
 450         if (defined($static)) {
 451             unshift(@args, "CLASS");
 452             $orig_args = "CLASS, $orig_args";
 453             $orig_args =~ s/^CLASS, $/CLASS/;
 454         }
 455         else {
 456             unshift(@args, "THIS");
 457             $orig_args = "THIS, $orig_args";
 458             $orig_args =~ s/^THIS, $/THIS/;
 459         }
 460     }
 461     $orig_args =~ s/"/\\"/g;
 462     $min_args = $num_args = @args;
 463     foreach $i (0..$num_args-1) {
 464             if ($args[$i] =~ s/\.\.\.//) {
 465                     $elipsis = 1;
 466                     $min_args--;
 467                     if ($args[$i] eq '' && $i == $num_args - 1) {
 468                         pop(@args);
 469                         last;
 470                     }
 471             }
 472             if ($args[$i] =~ /([^=]*\S)\s*=\s*(.*)/) {
 473                     $min_args--;
 474                     $args[$i] = $1;
 475                     $defaults{$args[$i]} = $2;
 476                     $defaults{$args[$i]} =~ s/"/\\"/g;
 477             }
 478     }
 479     if (defined($class)) {
 480             $func_args = join(", ", @args[1..$#args]);
 481     } else {
 482             $func_args = join(", ", @args);
 483     }
 484     @args_match{@args} = 1..@args;
 485
 486     # print function header
 487     print Q<<"EOF";
 488 #XS(XS_${Packid}_$func_name)
 489 #[[
 490 #    dXSARGS;
 491 EOF
 492     if ($elipsis) {
 493         $cond = qq(items < $min_args);
 494     }
 495     elsif ($min_args == $num_args) {
 496         $cond = qq(items != $min_args);
 497     }
 498     else {
 499         $cond = qq(items < $min_args || items > $num_args);
 500     }
 501
 502     print Q<<"EOF" if $except;
 503 #    char errbuf[1024];
 504 #    *errbuf = '\0';
 505 EOF
 506
 507     print Q<<"EOF";
 508 #    if ($cond) {
 509 #       croak("Usage: $pname($orig_args)");
 510 #    }
 511 EOF
 512
 513     print Q<<"EOF" if $PPCODE;
 514 #    SP -= items;
 515 EOF
 516
 517     # Now do a block of some sort.
 518
 519     $condnum = 0;
 520     $else_cond = 0 ;
 521     if (!@line) {
 522         @line = "CLEANUP:";
 523     }
 524     while (@line) {
 525         if ($line[0] =~ s/^\s*CASE\s*:\s*//) {
 526             $cond = shift(@line);
 527             TrimWhitespace($cond) ;
 528             if ($condnum == 0) {
 529                 # Check $cond is not blank
 530                 blurt("Error: First CASE: needs a condition")
 531                     if $cond eq '' ;
 532                 print "    if ($cond)\n"
 533             }
 534             elsif ($cond ne '') {
 535                 print "    else if ($cond)\n";
 536             }
 537             else {
 538                 blurt ("Error: Too many CASE: statements without a condition")
 539                     unless $else_cond ;
 540                 ++ $else_cond  ;
 541                 print "    else\n";
 542             }
 543             $condnum++;
 544             $_ = '' ;
 545         }
 546
 547         if ($except) {
 548             print Q<<"EOF";
 549 #    TRY [[
 550 EOF
 551         }
 552         else {
 553             print Q<<"EOF";
 554 #    [[
 555 EOF
 556         }
 557
 558         # do initialization of input variables
 559         $thisdone = 0;
 560         $retvaldone = 0;
 561         $deferred = "";
 562         %arg_list = () ;
 563         $gotRETVAL = 0;
 564         while (@line) {
 565                 $_ = shift(@line);
 566                 last if /^\s*NOT_IMPLEMENTED_YET/;
 567                 last if /^\s*(PPCODE|CODE|OUTPUT|CLEANUP|CASE)\s*:/;
 568
 569                 TrimWhitespace($_) ;
 570                 # skip blank lines
 571                 next if /^$/ ;
 572                 my $line = $_ ;
 573
 574                 # remove trailing semicolon if no initialisation
 575                 s/\s*;+\s*$//g unless /=/ ;
 576
 577                 # check for optional initialisation code
 578                 my $var_init = '' ;
 579                 $var_init = $1 if s/\s*(=.*)$// ;
 580
 581                 my @words = split (' ') ;
 582                 blurt("Error: invalid argument declaration '$line'"), next
 583                     unless @words >= 2 ;
 584                 my $var_name = pop @words ;
 585
 586                 # move any *'s from the variable name to the type
 587                 push(@words, $1)
 588                     if $var_name =~ s/^(\*+)// ;
 589
 590                 # check that removing the *'s hasn't eaten the whole variable
 591                 blurt("Error: invalid argument declaration '$line'"), next
 592                     if $var_name eq '' ;
 593
 594                 my $var_type = "@words" ;
 595
 596                 # catch many errors similar to: SV<tab>* name
 597                 blurt("Error: invalid $pname argument name '$var_name' (type '$var_type')\n")
 598                         unless ($var_name =~ m/^&?\w+$/);
 599                 if ($var_name =~ /^&/) {
 600                         $var_name =~ s/^&//;
 601                         $var_addr{$var_name} = 1;
 602                 }
 603
 604                 # Check for duplicate definitions
 605                 blurt ("Error: duplicate definition of argument '$var_name' ignored"), next
 606                     if $arg_list{$var_name} ++  ;
 607
 608                 $thisdone |= $var_name eq "THIS";
 609                 $retvaldone |= $var_name eq "RETVAL";
 610                 $var_types{$var_name} = $var_type;
 611                 print "\t" . &map_type($var_type);
 612                 $var_num = $args_match{$var_name};
 613                 if ($var_addr{$var_name}) {
 614                         $func_args =~ s/\b($var_name)\b/&$1/;
 615                 }
 616                 if ($var_init !~ /^=\s*NO_INIT\s*$/) {
 617                         if ($var_init !~ /^\s*$/) {
 618                                 &output_init($var_type, $var_num,
 619                                     "$var_name $var_init");
 620                         } elsif ($var_num) {
 621                                 # generate initialization code
 622                                 &generate_init($var_type, $var_num, $var_name);
 623                         } else {
 624                                 print ";\n";
 625                         }
 626                 } else {
 627                         print "\t$var_name;\n";
 628                 }
 629         }
 630         if (!$thisdone && defined($class)) {
 631             if (defined($static)) {
 632                 print "\tchar *";
 633                 $var_types{"CLASS"} = "char *";
 634                 &generate_init("char *", 1, "CLASS");
 635             }
 636             else {
 637                 print "\t$class *";
 638                 $var_types{"THIS"} = "$class *";
 639                 &generate_init("$class *", 1, "THIS");
 640             }
 641         }
 642
 643         # do code
 644         if (/^\s*NOT_IMPLEMENTED_YET/) {
 645                 print "\ncroak(\"$pname: not implemented yet\");\n";
 646         } else {
 647                 if ($ret_type ne "void") {
 648                         print "\t" . &map_type($ret_type) . "\tRETVAL;\n"
 649                                 if !$retvaldone;
 650                         $args_match{"RETVAL"} = 0;
 651                         $var_types{"RETVAL"} = $ret_type;
 652                 }
 653                 if (/^\s*PPCODE\s*:/) {
 654                         print $deferred;
 655                         while (@line) {
 656                                 $_ = shift(@line);
 657                                 death ("PPCODE must be last thing")
 658                                     if /^\s*(OUTPUT|CLEANUP|CASE)\s*:/;
 659                                 print "$_\n";
 660                         }
 661                         print "\tPUTBACK;\n\treturn;\n";
 662                 } elsif (/^\s*CODE\s*:/) {
 663                         print $deferred;
 664                         while (@line) {
 665                                 $_ = shift(@line);
 666                                 last if /^\s*(OUTPUT|CLEANUP|CASE)\s*:/;
 667                                 print "$_\n";
 668                         }
 669                 } elsif ($func_name eq "DESTROY") {
 670                         print $deferred;
 671                         print "\n\t";
 672                         print "delete THIS;\n"
 673                 } else {
 674                         print $deferred;
 675                         print "\n\t";
 676                         if ($ret_type ne "void") {
 677                                 print "RETVAL = ";
 678                                 $wantRETVAL = 1;
 679                         }
 680                         if (defined($static)) {
 681                             if ($func_name =~ /^new/) {
 682                                 $func_name = "$class";
 683                             }
 684                             else {
 685                                 print "$class::";
 686                             }
 687                         } elsif (defined($class)) {
 688                                 print "THIS->";
 689                         }
 690                         $func_name =~ s/^($spat)//
 691                             if defined($spat);
 692                         print "$func_name($func_args);\n";
 693                 }
 694         }
 695
 696         # do output variables
 697         if (/^\s*OUTPUT\s*:/) {
 698                 $gotRETVAL = 0;
 699                 my $RETVAL_code ;
 700                 my %outargs ;
 701                 while (@line) {
 702                         $_ = shift(@line);
 703                         last if /^\s*(CLEANUP|CASE)\s*:/;
 704                         TrimWhitespace($_) ;
 705                         next if /^$/ ;
 706                         my ($outarg, $outcode) = /^(\S+)\s*(.*)/ ;
 707                         if (!$gotRETVAL and $outarg eq 'RETVAL') {
 708                             # deal with RETVAL last
 709                             $RETVAL_code = $outcode ;
 710                             $gotRETVAL = 1 ;
 711                             next ;
 712                         }
 713                         blurt ("Error: duplicate OUTPUT argument '$outarg' ignored"), next
 714                             if $outargs{$outarg} ++ ;
 715                         blurt ("Error: OUTPUT $outarg not an argument"), next
 716                             unless defined($args_match{$outarg});
 717                         blurt("Error: No input definition for OUTPUT argument '$outarg' - ignored"), next
 718                             unless defined $var_types{$outarg} ;
 719                         if ($outcode) {
 720                             print "\t$outcode\n";
 721                         } else {
 722                                 $var_num = $args_match{$outarg};
 723                                 &generate_output($var_types{$outarg}, $var_num,
 724                                     $outarg);
 725                         }
 726                 }
 727
 728                 if ($gotRETVAL) {
 729                         if ($RETVAL_code)
 730                             { print "\t$RETVAL_code\n" }
 731                         else
 732                             { &generate_output($ret_type, 0, 'RETVAL') }
 733                 }
 734         }
 735
 736         # all OUTPUT done, so now push the return value on the stack
 737         &generate_output($ret_type, 0, "RETVAL")
 738              if $wantRETVAL and ! $gotRETVAL ;
 739
 740         # do cleanup
 741         if (/^\s*CLEANUP\s*:/) {
 742             while (@line) {
 743                     $_ = shift(@line);
 744                     last if /^\s*CASE\s*:/;
 745                     print "$_\n";
 746             }
 747         }
 748         # print function trailer
 749         if ($except) {
 750             print Q<<EOF;
 751 #    ]]
 752 #    BEGHANDLERS
 753 #    CATCHALL
 754 #       sprintf(errbuf, "%s: %s\\tpropagated", Xname, Xreason);
 755 #    ENDHANDLERS
 756 EOF
 757         }
 758         else {
 759             print Q<<EOF;
 760 #    ]]
 761 EOF
 762         }
 763         if (/^\s*CASE\s*:/) {
 764             unshift(@line, $_);
 765         }
 766     }
 767
 768     print Q<<EOF if $except;
 769 #    if (errbuf[0])
 770 #       croak(errbuf);
 771 EOF
 772
 773     print Q<<EOF unless $PPCODE;
 774 #    XSRETURN(1);
 775 EOF
 776
 777     print Q<<EOF;
 778 #]]
 779 #
 780 EOF
 781 }
 782
 783 # print initialization routine
 784 print qq/extern "C"\n/ if $cplusplus;
 785 print Q<<"EOF";
 786 #XS(boot_$Module_cname)
 787 #[[
 788 #    dXSARGS;
 789 #    char* file = __FILE__;
 790 #
 791 EOF
 792
 793 for (@Func_name) {
 794     $pname = shift(@Func_pname);
 795     print "    newXS(\"$pname\", XS_$_, file);\n";
 796 }
 797
 798 if (@BootCode)
 799 {
 800     print "\n    /* Initialisation Section */\n\n" ;
 801     print grep (s/$/\n/, @BootCode) ;
 802     print "    /* End of Initialisation Section */\n\n" ;
 803 }
 804
 805 print Q<<"EOF";;
 806 #    ST(0) = &sv_yes;
 807 #    XSRETURN(1);
 808 #]]
 809 EOF
 810
 811 &Exit;
 812
 813
 814 sub output_init {
 815     local($type, $num, $init) = @_;
 816     local($arg) = "ST(" . ($num - 1) . ")";
 817
 818     eval qq/print " $init\\\n"/;
 819 }
 820
 821 sub Warn
 822 {
 823     # work out the line number
 824     my $line_no = $line_no[@line_no - @line -1] ;
 825
 826     print STDERR "@_ in $filename, line $line_no\n" ;
 827 }
 828
 829 sub blurt
 830 {
 831     Warn @_ ;
 832     $errors ++
 833 }
 834
 835 sub death
 836 {
 837     Warn @_ ;
 838     exit 1 ;
 839 }
 840
 841 sub generate_init {
 842     local($type, $num, $var) = @_;
 843     local($arg) = "ST(" . ($num - 1) . ")";
 844     local($argoff) = $num - 1;
 845     local($ntype);
 846     local($tk);
 847
 848     $type = TidyType($type) ;
 849     blurt("Error: '$type' not in typemap"), return
 850         unless defined($type_kind{$type});
 851
 852     ($ntype = $type) =~ s/\s*\*/Ptr/g;
 853     $subtype = $ntype;
 854     $subtype =~ s/Ptr$//;
 855     $subtype =~ s/Array$//;
 856     $tk = $type_kind{$type};
 857     $tk =~ s/OBJ$/REF/ if $func_name =~ /DESTROY$/;
 858     $type =~ s/:/_/g;
 859     blurt("Error: No INPUT definition for type '$type' found"), return
 860         unless defined $input_expr{$tk} ;
 861     $expr = $input_expr{$tk};
 862     if ($expr =~ /DO_ARRAY_ELEM/) {
 863         blurt("Error: '$subtype' not in typemap"), return
 864             unless defined($type_kind{$subtype});
 865         blurt("Error: No INPUT definition for type '$subtype' found"), return
 866             unless defined $input_expr{$type_kind{$subtype}} ;
 867         $subexpr = $input_expr{$type_kind{$subtype}};
 868         $subexpr =~ s/ntype/subtype/g;
 869         $subexpr =~ s/\$arg/ST(ix_$var)/g;
 870         $subexpr =~ s/\n\t/\n\t\t/g;
 871         $subexpr =~ s/is not of (.*")/[arg %d] is not of $1, ix_$var + 1/g;
 872         $subexpr =~ s/\$var/${var}[ix_$var - $argoff]/;
 873         $expr =~ s/DO_ARRAY_ELEM/$subexpr/;
 874     }
 875     if (defined($defaults{$var})) {
 876             $expr =~ s/(\t+)/$1    /g;
 877             $expr =~ s/        /\t/g;
 878             eval qq/print "\\t$var;\\n"/;
 879             $deferred .= eval qq/"\\n\\tif (items < $num)\\n\\t    $var = $defaults{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/;
 880     } elsif ($expr !~ /^\t\$var =/) {
 881             eval qq/print "\\t$var;\\n"/;
 882             $deferred .= eval qq/"\\n$expr;\\n"/;
 883     } else {
 884             eval qq/print "$expr;\\n"/;
 885     }
 886 }
 887
 888 sub generate_output {
 889     local($type, $num, $var) = @_;
 890     local($arg) = "ST(" . ($num - ($num != 0)) . ")";
 891     local($argoff) = $num - 1;
 892     local($ntype);
 893
 894     $type = TidyType($type) ;
 895     if ($type =~ /^array\(([^,]*),(.*)\)/) {
 896             print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1)), XFree((char *)$var);\n";
 897     } else {
 898             blurt("Error: '$type' not in typemap"), return
 899                 unless defined($type_kind{$type});
 900             blurt("Error: No OUTPUT definition for type '$type' found"), return
 901                 unless defined $output_expr{$type_kind{$type}} ;
 902             ($ntype = $type) =~ s/\s*\*/Ptr/g;
 903             $ntype =~ s/\(\)//g;
 904             $subtype = $ntype;
 905             $subtype =~ s/Ptr$//;
 906             $subtype =~ s/Array$//;
 907             $expr = $output_expr{$type_kind{$type}};
 908             if ($expr =~ /DO_ARRAY_ELEM/) {
 909                 blurt("Error: '$subtype' not in typemap"), return
 910                     unless defined($type_kind{$subtype});
 911                 blurt("Error: No OUTPUT definition for type '$subtype' found"), return
 912                     unless defined $output_expr{$type_kind{$subtype}} ;
 913                 $subexpr = $output_expr{$type_kind{$subtype}};
 914                 $subexpr =~ s/ntype/subtype/g;
 915                 $subexpr =~ s/\$arg/ST(ix_$var)/g;
 916                 $subexpr =~ s/\$var/${var}[ix_$var]/g;
 917                 $subexpr =~ s/\n\t/\n\t\t/g;
 918                 $expr =~ s/DO_ARRAY_ELEM\n/$subexpr/;
 919                 eval "print qq\a$expr\a";
 920             }
 921             elsif ($var eq 'RETVAL') {
 922                 if ($expr =~ /^\t\$arg = /) {
 923                     eval "print qq\a$expr\a";
 924                     print "\tsv_2mortal(ST(0));\n";
 925                 }
 926                 else {
 927                     print "\tST(0) = sv_newmortal();\n";
 928                     eval "print qq\a$expr\a";
 929                 }
 930             }
 931             elsif ($arg =~ /^ST\(\d+\)$/) {
 932                 eval "print qq\a$expr\a";
 933             }
 934     }
 935 }
 936
 937 sub map_type {
 938     my($type) = @_;
 939
 940     $type =~ s/:/_/g;
 941     if ($type =~ /^array\(([^,]*),(.*)\)/) {
 942             return "$1 *";
 943     } else {
 944             return $type;
 945     }
 946 }
 947
 948
 949 sub Exit {
 950 # If this is VMS, the exit status has meaning to the shell, so we
 951 # use a predictable value (SS$_Abort) rather than an arbitrary
 952 # number.
 953     exit ($Is_VMS ? 44 : $errors) ;
 954 }