home *** CD-ROM | disk | FTP | other *** search
/ OpenStep 4.2 / Openstep-4.2-Intel-User.iso / usr / lib / perl5 / ExtUtils / xsubpp < prev   
Text File  |  1997-03-29  |  23KB  |  955 lines
  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. }
  955.