#!./miniperl

=head1 NAME

xsubpp - compiler to convert Perl XS code into C code

=head1 SYNOPSIS

B<xsubpp> [B<-C++>] [B<-except>] [B<-typemap typemap>]... file.xs

=head1 DESCRIPTION

I<xsubpp> will compile XS code into C code by embedding the constructs
necessary to let C functions manipulate Perl values and creates the glue
necessary to let Perl access those functions.  The compiler uses typemaps to
determine how to map C function parameters and variables to Perl values.

The compiler will search for typemap files called I<typemap>.  It will use
the following search path to find default typemaps, with the rightmost
typemap taking precedence.

	../../../typemap:../../typemap:../typemap:typemap

=head1 OPTIONS

=over 5

=item B<-C++>

Adds ``extern "C"'' to the C code.


=item B<-except>

Adds exception handling stubs to the C code.

=item B<-typemap typemap>

Indicates that a user-supplied typemap should take precedence over the
default typemaps.  This option may be used multiple times, with the last
typemap having the highest precedence.

=back

=head1 ENVIRONMENT

No environment variables are used.

=head1 AUTHOR

Larry Wall

=head1 MODIFICATION HISTORY

=head2 1.0

I<xsubpp> as released with Perl 5.000

=head2 1.1

I<xsubpp> as released with Perl 5.001

=head2 1.2 

Changes by Paul Marquess <pmarquess@bfsec.bt.co.uk>, 22 May 1995.

=over 5

=item 1.

Added I<xsubpp> version number for the first time. As previous releases
of I<xsubpp> did not have a formal version number, a numbering scheme
has been applied retrospectively.

=item 2.

If OUTPUT: is being used to specify output parameters and RETVAL is
also to be returned, it is now no longer necessary for the user to
ensure that RETVAL is specified last.

=item 3.

The I<xsubpp> version number, the .xs filename and a time stamp are
written to the generated .c file as a comment.

=item 4.

When I<xsubpp> is parsing the definition of both the input parameters
and the OUTPUT parameters, any duplicate definitions will be noted and
ignored.

=item 5.

I<xsubpp> is slightly more forgiving with extra whitespace.

=back

=head2 1.3 

Changes by Paul Marquess <pmarquess@bfsec.bt.co.uk>, 23 May 1995.

=over 5

=item 1.

More whitespace restrictions have been relaxed. In particular some
cases where a tab character was used to delimit fields has been
removed. In these cases any whitespace will now suffice.

The specific places where changes have been made are in the TYPEMAP
section of a typemap file and the input and OUTPUT: parameter
declarations sections in a .xs file.

=item 2.

More error checking added.

Before processing each typemap file I<xsubpp> now checks that it is a
text file. If not an warning will be displayed. In addition, a warning
will be displayed if it is not possible to open the typemap file.

In the TYPEMAP section of a typemap file, an error will be raised if
the line does not have 2 columns.

When parsing input parameter declarations check that there is at least
a type and name pair.

=back

=head2 1.4 

When parsing the OUTPUT arguments check that they are all present in
the corresponding input argument definitions.

=head2 1.5 

Changes by Paul Marquess <pmarquess@bfsec.bt.co.uk>, 1 June 1995.

Started tidy up to allow clean run using C<-w> flag. 

Added some more error checking.

The CASE: functionality now works.

=head2 1.6 

Changes by Paul Marquess <pmarquess@bfsec.bt.co.uk>, 3 June 1995.

Added some more error checking.

=head2 1.7 

Changes by Paul Marquess <pmarquess@bfsec.bt.co.uk>, 5 June 1995.

When an error or warning message is printed C<xsubpp> will now attempt
to identify the exact line in the C<.xs> file where the fault occurs.
This can be achieved in the majority of cases.

=head2 1.8 

Changes by Hallvard B Furuseth <h.b.furuseth@usit.uio.no>, 6 June 1995.

Accept backslash-newline as in C.  Allow preprocessor directives
anywhere.  Ignore whitespace in front of comments and on blank lines.

=head2 1.9 

Changes by Paul Marquess <pmarquess@bfsec.bt.co.uk>, 21 June 1995.

=over 5

=item 1.

Changed duplicate function error to a warning.

=item 2.

Changed the comment placed at the top of the C<.c> file to be more like
the comment used by MakeMaker.

=item 3.

When parsing the type for an XSUB parameter I<xsubpp> can now accept
definitions like this:

    char *fred

i.e. the '*' is recognised as part of the type, rather than the first
character of the variable.

=item 4.

Fixed a problem with command line parsing - I<xsubpp> was not properly
detecting the case where there was no filename present on the command
line.

=back

=head1 SEE ALSO

perl(1), perlapi(1)

=cut

# Global Constants
$XSUBPP_version = "1.9" ;

$usage = "Usage: xsubpp [-C++] [-except] [-typemap typemap] file.xs\n";

SWITCH: while ($ARGV[0] =~ /^-/) {
    $flag = shift @ARGV;
    $flag =~ s/^-// ;
    $spat = shift,	next SWITCH	if $flag eq 's';
    $cplusplus = 1,	next SWITCH	if $flag eq 'C++';
    $except = 1,	next SWITCH	if $flag eq 'except';
    push(@tm,shift),	next SWITCH	if $flag eq 'typemap';
    die $usage;
}
@ARGV == 1 or die $usage;
chomp($pwd = `pwd`);
# Check for error message from VMS
if ($pwd =~ /unrecognized command verb/) { $Is_VMS = 1; $pwd = $ENV{DEFAULT} }
($dir, $filename) = $ARGV[0] =~ m#(.*)/(.*)#
	or ($dir, $filename) = $ARGV[0] =~ m#(.*[>\]])(.*)#
	or ($dir, $filename) = ('.', $ARGV[0]);
chdir($dir);

sub TrimWhitespace
{
    $_[0] =~ s/^\s+|\s+$//go ;
}

sub TidyType
{
    local ($_) = @_ ;

    # rationalise any '*' by joining them into bunches and removing whitespace
    s#\s*(\*+)\s*#$1#g;
    s#(\*+)# $1 #g ;

    # change multiple whitespace into a single space
    s/\s+/ /g ;
    
    # trim leading & trailing whitespace
    TrimWhitespace($_) ;

    $_ ;
}

$typemap = shift @ARGV;
foreach $typemap (@tm) {
    die "Can't find $typemap in $pwd\n" unless -r $typemap;
}
unshift @tm, qw(../../../../lib/ExtUtils/typemap ../../../lib/ExtUtils/typemap
                ../../lib/ExtUtils/typemap ../../../typemap ../../typemap
                ../typemap typemap);
foreach $typemap (@tm) {
    next unless -e $typemap ;
    # skip directories, binary files etc.
    warn("Warning: ignoring non-text typemap file '$typemap'\n"), next 
	unless -T $typemap ;
    open(TYPEMAP, $typemap) 
	or warn ("Warning: could not open typemap file '$typemap': $!\n"), next;
    $mode = 'Typemap';
    $junk = "" ;
    $current = \$junk;
    while (<TYPEMAP>) {
	next if /^\s*#/;
	if (/^INPUT\s*$/)   { $mode = 'Input';   next; }
	if (/^OUTPUT\s*$/)  { $mode = 'Output';  next; }
	if (/^TYPEMAP\s*$/) { $mode = 'Typemap'; next; }
	if ($mode eq 'Typemap') {
	    chomp;
	    my $line = $_ ;
            TrimWhitespace($_) ;
	    # skip blank lines and comment lines
	    next if /^$/ or /^#/ ;
	    my @words = split (' ') ;
	    warn("Warning: File '$typemap' Line $. '$line' TYPEMAP entry needs 2 columns\n"), next 
		unless @words >= 2 ;
	    my $kind = pop @words ;
            TrimWhitespace($kind) ;
	    $type_kind{TidyType("@words")} = $kind ;
	}
	elsif ($mode eq 'Input') {
	    if (/^\s/) {
		$$current .= $_;
	    }
	    else {
		s/\s*$//;
		$input_expr{$_} = '';
		$current = \$input_expr{$_};
	    }
	}
	else {
	    if (/^\s/) {
		$$current .= $_;
	    }
	    else {
		s/\s*$//;
		$output_expr{$_} = '';
		$current = \$output_expr{$_};
	    }
	}
    }
    close(TYPEMAP);
}

foreach $key (keys %input_expr) {
    $input_expr{$key} =~ s/\n+$//;
}

sub Q {
    my($text) = @_;
    $text =~ tr/#//d;
    $text =~ s/\[\[/{/g;
    $text =~ s/\]\]/}/g;
    $text;
}

open(F, $filename) or die "cannot open $filename: $!\n";

# Identify the version of xsubpp used
print <<EOM ;
/*
 * This file was generated automatically by xsubpp version $XSUBPP_version from the 
 * contents of $filename. Don't edit this file, edit $filename instead.
 *
 *	ANY CHANGES MADE HERE WILL BE LOST! 
 *
 */

EOM
 

while (<F>) {
    last if ($Module, $Package, $Prefix) =
	/^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/;
    print $_;
}
&Exit unless defined $_;

my $lastline	= $_;
my $lastline_no = $.;


# Read next xsub into @line from ($lastline, <F>).
sub fetch_para {
    # parse paragraph
    @line = ();
    @line_no = () ;
    return 0 unless defined $lastline;

    if ($lastline =~
	/^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/) {
	$Module = $1;
	$Package = $2;
	$Prefix = $3;
	($Module_cname = $Module) =~ s/\W/_/g;
	($Packid = $Package) =~ s/:/_/g;
	$Packprefix = $Package;
	$Packprefix .= "::" if defined $Packprefix && $Packprefix ne "";
	$lastline = "";
    }

    for(;;) {
	if ($lastline !~ /^\s*#/ ||
	    $lastline =~ /^#[ \t]*((if|ifn?def|else|elif|endif|define|undef|pragma)\b|include\s*["<].*[>"])/) {
	    last if $lastline =~ /^\S/ && @line && $line[-1] eq "";
	    push(@line, $lastline);
	    push(@line_no, $lastline_no) ;
	}

	# Read next line and continuation lines
	last unless defined($lastline = <F>);
	$lastline_no = $.;
	my $tmp_line;
	$lastline .= $tmp_line
	    while ($lastline =~ /\\\n$/ && defined($tmp_line = <F>));
	    
	# chomp $lastline;
	$lastline =~ s/^\s+$//;
    }
    pop(@line), pop(@line_no) while @line && $line[-1] eq "";
    $PPCODE = grep(/^\s*PPCODE\s*:/, @line);
    1;
}

PARAGRAPH:
while (&fetch_para) {
    # Print initial preprocessor statements and blank lines
    print shift(@line), "\n"
	while @line && $line[0] !~ /^[^\#]/;

    next PARAGRAPH unless @line;

    death ("Code is not inside a function")
	if $line[0] =~ /^\s/;

    # initialize info arrays
    # my(%args_match,%var_types,%var_addr);
    # my($class,$static,$elipsis,$wantRETVAL,%arg_list);
    undef(%args_match);
    undef(%var_types);
    undef(%var_addr);
    undef(%defaults);
    undef($class);
    undef($static);
    undef($elipsis);
    undef($wantRETVAL) ;
    undef(%arg_list) ;

    # extract return type, function name and arguments
    my($ret_type) = TidyType(shift(@line));

    if ($ret_type =~ /^BOOT\s*:/) {
        push (@BootCode, @line, "", "") ;
        next PARAGRAPH ;
    }

    # a function definition needs at least 2 lines
    blurt ("Error: Function definition too short '$ret_type'"), next PARAGRAPH
	unless @line ;

    if ($ret_type =~ /^static\s+(.*)$/) {
	    $static = 1;
	    $ret_type = $1;
    }
    $func_header = shift(@line);
    blurt ("Error: Cannot parse function definition from '$func_header'"), next PARAGRAPH
	unless $func_header =~ /^([\w:]+)\s*\((.*)\)$/;

    ($func_name, $orig_args) =  ($1, $2) ;
    if ($func_name =~ /(.*)::(.*)/) {
	    $class = $1;
	    $func_name = $2;
    }
    $Prefix = '' unless defined $Prefix ; # keep -w happy
    ($pname = $func_name) =~ s/^($Prefix)?/$Packprefix/;

    # Check for duplicate function definition
    Warn("Warning: duplicate function definition '$func_name' detected")
	if defined $Func_name{"${Packid}_$func_name"} ;
    $Func_name{"${Packid}_$func_name"} ++ ;

    push(@Func_name, "${Packid}_$func_name");
    push(@Func_pname, $pname);
    @args = split(/\s*,\s*/, $orig_args);
    if (defined($class)) {
	if (defined($static)) {
	    unshift(@args, "CLASS");
	    $orig_args = "CLASS, $orig_args";
	    $orig_args =~ s/^CLASS, $/CLASS/;
	}
	else {
	    unshift(@args, "THIS");
	    $orig_args = "THIS, $orig_args";
	    $orig_args =~ s/^THIS, $/THIS/;
	}
    }
    $orig_args =~ s/"/\\"/g;
    $min_args = $num_args = @args;
    foreach $i (0..$num_args-1) {
	    if ($args[$i] =~ s/\.\.\.//) {
		    $elipsis = 1;
		    $min_args--;
		    if ($args[$i] eq '' && $i == $num_args - 1) {
			pop(@args);
			last;
		    }
	    }
	    if ($args[$i] =~ /([^=]*\S)\s*=\s*(.*)/) {
		    $min_args--;
		    $args[$i] = $1;
		    $defaults{$args[$i]} = $2;
		    $defaults{$args[$i]} =~ s/"/\\"/g;
	    }
    }
    if (defined($class)) {
	    $func_args = join(", ", @args[1..$#args]);
    } else {
	    $func_args = join(", ", @args);
    }
    @args_match{@args} = 1..@args;

    # print function header
    print Q<<"EOF";
#XS(XS_${Packid}_$func_name)
#[[
#    dXSARGS;
EOF
    if ($elipsis) {
	$cond = qq(items < $min_args);
    }
    elsif ($min_args == $num_args) {
	$cond = qq(items != $min_args);
    }
    else {
	$cond = qq(items < $min_args || items > $num_args);
    }

    print Q<<"EOF" if $except;
#    char errbuf[1024];
#    *errbuf = '\0';
EOF

    print Q<<"EOF";
#    if ($cond) {
#	croak("Usage: $pname($orig_args)");
#    }
EOF

    print Q<<"EOF" if $PPCODE;
#    SP -= items;
EOF

    # Now do a block of some sort.

    $condnum = 0;
    $else_cond = 0 ;
    if (!@line) {
	@line = "CLEANUP:";
    }
    while (@line) {
	if ($line[0] =~ s/^\s*CASE\s*:\s*//) {
	    $cond = shift(@line);
            TrimWhitespace($cond) ;
	    if ($condnum == 0) {
		# Check $cond is not blank
		blurt("Error: First CASE: needs a condition") 
		    if $cond eq '' ;
		print "    if ($cond)\n"
	    }
	    elsif ($cond ne '') {
		print "    else if ($cond)\n";
	    }
	    else {
		blurt ("Error: Too many CASE: statements without a condition")
		    unless $else_cond ;
    	        ++ $else_cond  ;
		print "    else\n";
	    }
	    $condnum++;
            $_ = '' ;
	}

	if ($except) {
	    print Q<<"EOF";
#    TRY [[
EOF
	}
	else {
	    print Q<<"EOF";
#    [[
EOF
	}

	# do initialization of input variables
	$thisdone = 0;
	$retvaldone = 0;
	$deferred = "";
	%arg_list = () ;
        $gotRETVAL = 0;
	while (@line) {
		$_ = shift(@line);
		last if /^\s*NOT_IMPLEMENTED_YET/;
		last if /^\s*(PPCODE|CODE|OUTPUT|CLEANUP|CASE)\s*:/;

                TrimWhitespace($_) ;
                # skip blank lines 
                next if /^$/ ;
		my $line = $_ ;

                # remove trailing semicolon if no initialisation
                s/\s*;+\s*$//g unless /=/ ;

	  	# check for optional initialisation code
		my $var_init = '' ;
		$var_init = $1 if s/\s*(=.*)$// ;

                my @words = split (' ') ;
                blurt("Error: invalid argument declaration '$line'"), next
                    unless @words >= 2 ;
                my $var_name = pop @words ;

		# move any *'s from the variable name to the type
		push(@words, $1)
		    if $var_name =~ s/^(\*+)// ;

		# check that removing the *'s hasn't eaten the whole variable
		blurt("Error: invalid argument declaration '$line'"), next
		    if $var_name eq '' ;

		my $var_type = "@words" ;

		# catch many errors similar to: SV<tab>* name
		blurt("Error: invalid $pname argument name '$var_name' (type '$var_type')\n")
			unless ($var_name =~ m/^&?\w+$/);
		if ($var_name =~ /^&/) {
			$var_name =~ s/^&//;
			$var_addr{$var_name} = 1;
		}

	        # Check for duplicate definitions
	        blurt ("Error: duplicate definition of argument '$var_name' ignored"), next
		    if $arg_list{$var_name} ++  ;

		$thisdone |= $var_name eq "THIS";
		$retvaldone |= $var_name eq "RETVAL";
		$var_types{$var_name} = $var_type;
		print "\t" . &map_type($var_type);
		$var_num = $args_match{$var_name};
		if ($var_addr{$var_name}) {
			$func_args =~ s/\b($var_name)\b/&$1/;
		}
		if ($var_init !~ /^=\s*NO_INIT\s*$/) {
			if ($var_init !~ /^\s*$/) {
				&output_init($var_type, $var_num,
				    "$var_name $var_init");
			} elsif ($var_num) {
				# generate initialization code
				&generate_init($var_type, $var_num, $var_name);
			} else {
				print ";\n";
			}
		} else {
			print "\t$var_name;\n";
		}
	}
	if (!$thisdone && defined($class)) {
	    if (defined($static)) {
		print "\tchar *";
		$var_types{"CLASS"} = "char *";
		&generate_init("char *", 1, "CLASS");
	    }
	    else {
		print "\t$class *";
		$var_types{"THIS"} = "$class *";
		&generate_init("$class *", 1, "THIS");
	    }
	}

	# do code
	if (/^\s*NOT_IMPLEMENTED_YET/) {
		print "\ncroak(\"$pname: not implemented yet\");\n";
	} else {
		if ($ret_type ne "void") {
			print "\t" . &map_type($ret_type) . "\tRETVAL;\n"
				if !$retvaldone;
			$args_match{"RETVAL"} = 0;
			$var_types{"RETVAL"} = $ret_type;
		}
		if (/^\s*PPCODE\s*:/) {
			print $deferred;
			while (@line) {
				$_ = shift(@line);
				death ("PPCODE must be last thing")
				    if /^\s*(OUTPUT|CLEANUP|CASE)\s*:/;
				print "$_\n";
			}
			print "\tPUTBACK;\n\treturn;\n";
		} elsif (/^\s*CODE\s*:/) {
			print $deferred;
			while (@line) {
				$_ = shift(@line);
				last if /^\s*(OUTPUT|CLEANUP|CASE)\s*:/;
				print "$_\n";
			}
		} elsif ($func_name eq "DESTROY") {
			print $deferred;
			print "\n\t";
			print "delete THIS;\n"
		} else {
			print $deferred;
			print "\n\t";
			if ($ret_type ne "void") {
				print "RETVAL = ";
				$wantRETVAL = 1;
			}
			if (defined($static)) {
			    if ($func_name =~ /^new/) {
				$func_name = "$class";
			    }
			    else {
				print "$class::";
			    }
			} elsif (defined($class)) {
				print "THIS->";
			}
			$func_name =~ s/^($spat)//
			    if defined($spat);
			print "$func_name($func_args);\n";
		}
	}

	# do output variables
	if (/^\s*OUTPUT\s*:/) {
		$gotRETVAL = 0;
		my $RETVAL_code ;
		my %outargs ;
		while (@line) {
			$_ = shift(@line);
			last if /^\s*(CLEANUP|CASE)\s*:/;
			TrimWhitespace($_) ;
			next if /^$/ ;
			my ($outarg, $outcode) = /^(\S+)\s*(.*)/ ;
			if (!$gotRETVAL and $outarg eq 'RETVAL') {
			    # deal with RETVAL last
			    $RETVAL_code = $outcode ;
			    $gotRETVAL = 1 ;
			    next ;
			}
			blurt ("Error: duplicate OUTPUT argument '$outarg' ignored"), next
			    if $outargs{$outarg} ++ ;
			blurt ("Error: OUTPUT $outarg not an argument"), next
			    unless defined($args_match{$outarg});
			blurt("Error: No input definition for OUTPUT argument '$outarg' - ignored"), next
			    unless defined $var_types{$outarg} ;
			if ($outcode) {
			    print "\t$outcode\n";
			} else {
				$var_num = $args_match{$outarg};
				&generate_output($var_types{$outarg}, $var_num,
				    $outarg); 
			}
		}

		if ($gotRETVAL) {
			if ($RETVAL_code) 
                            { print "\t$RETVAL_code\n" }
			else 
			    { &generate_output($ret_type, 0, 'RETVAL') }
		}
	}

	# all OUTPUT done, so now push the return value on the stack
	&generate_output($ret_type, 0, "RETVAL")
	     if $wantRETVAL and ! $gotRETVAL ;

	# do cleanup
	if (/^\s*CLEANUP\s*:/) {
	    while (@line) {
		    $_ = shift(@line);
		    last if /^\s*CASE\s*:/;
		    print "$_\n";
	    }
	}
	# print function trailer
	if ($except) {
	    print Q<<EOF;
#    ]]
#    BEGHANDLERS
#    CATCHALL
#	sprintf(errbuf, "%s: %s\\tpropagated", Xname, Xreason);
#    ENDHANDLERS
EOF
	}
	else {
	    print Q<<EOF;
#    ]]
EOF
	}
	if (/^\s*CASE\s*:/) {
	    unshift(@line, $_);
	}
    }

    print Q<<EOF if $except;
#    if (errbuf[0])
#	croak(errbuf);
EOF

    print Q<<EOF unless $PPCODE;
#    XSRETURN(1);
EOF

    print Q<<EOF;
#]]
#
EOF
}

# print initialization routine
print qq/extern "C"\n/ if $cplusplus;
print Q<<"EOF";
#XS(boot_$Module_cname)
#[[
#    dXSARGS;
#    char* file = __FILE__;
#
EOF

for (@Func_name) {
    $pname = shift(@Func_pname);
    print "    newXS(\"$pname\", XS_$_, file);\n";
}

if (@BootCode)
{
    print "\n    /* Initialisation Section */\n\n" ;
    print grep (s/$/\n/, @BootCode) ;
    print "    /* End of Initialisation Section */\n\n" ;
}

print Q<<"EOF";;
#    ST(0) = &sv_yes;
#    XSRETURN(1);
#]]
EOF

&Exit;


sub output_init {
    local($type, $num, $init) = @_;
    local($arg) = "ST(" . ($num - 1) . ")";

    eval qq/print " $init\\\n"/;
}

sub Warn
{
    # work out the line number
    my $line_no = $line_no[@line_no - @line -1] ;
 
    print STDERR "@_ in $filename, line $line_no\n" ;
}

sub blurt 
{ 
    Warn @_ ;
    $errors ++ 
}

sub death
{
    Warn @_ ;
    exit 1 ;
}

sub generate_init {
    local($type, $num, $var) = @_;
    local($arg) = "ST(" . ($num - 1) . ")";
    local($argoff) = $num - 1;
    local($ntype);
    local($tk);

    $type = TidyType($type) ;
    blurt("Error: '$type' not in typemap"), return 
	unless defined($type_kind{$type});

    ($ntype = $type) =~ s/\s*\*/Ptr/g;
    $subtype = $ntype;
    $subtype =~ s/Ptr$//;
    $subtype =~ s/Array$//;
    $tk = $type_kind{$type};
    $tk =~ s/OBJ$/REF/ if $func_name =~ /DESTROY$/;
    $type =~ s/:/_/g;
    blurt("Error: No INPUT definition for type '$type' found"), return
        unless defined $input_expr{$tk} ;
    $expr = $input_expr{$tk};
    if ($expr =~ /DO_ARRAY_ELEM/) {
        blurt("Error: '$subtype' not in typemap"), return 
	    unless defined($type_kind{$subtype});
        blurt("Error: No INPUT definition for type '$subtype' found"), return
            unless defined $input_expr{$type_kind{$subtype}} ;
	$subexpr = $input_expr{$type_kind{$subtype}};
	$subexpr =~ s/ntype/subtype/g;
	$subexpr =~ s/\$arg/ST(ix_$var)/g;
	$subexpr =~ s/\n\t/\n\t\t/g;
	$subexpr =~ s/is not of (.*")/[arg %d] is not of $1, ix_$var + 1/g;
	$subexpr =~ s/\$var/${var}[ix_$var - $argoff]/;
	$expr =~ s/DO_ARRAY_ELEM/$subexpr/;
    }
    if (defined($defaults{$var})) {
	    $expr =~ s/(\t+)/$1    /g;
	    $expr =~ s/        /\t/g;
	    eval qq/print "\\t$var;\\n"/;
	    $deferred .= eval qq/"\\n\\tif (items < $num)\\n\\t    $var = $defaults{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/;
    } elsif ($expr !~ /^\t\$var =/) {
	    eval qq/print "\\t$var;\\n"/;
	    $deferred .= eval qq/"\\n$expr;\\n"/;
    } else {
	    eval qq/print "$expr;\\n"/;
    }
}

sub generate_output {
    local($type, $num, $var) = @_;
    local($arg) = "ST(" . ($num - ($num != 0)) . ")";
    local($argoff) = $num - 1;
    local($ntype);

    $type = TidyType($type) ;
    if ($type =~ /^array\(([^,]*),(.*)\)/) {
	    print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1)), XFree((char *)$var);\n";
    } else {
	    blurt("Error: '$type' not in typemap"), return
		unless defined($type_kind{$type});
            blurt("Error: No OUTPUT definition for type '$type' found"), return
                unless defined $output_expr{$type_kind{$type}} ;
	    ($ntype = $type) =~ s/\s*\*/Ptr/g;
	    $ntype =~ s/\(\)//g;
	    $subtype = $ntype;
	    $subtype =~ s/Ptr$//;
	    $subtype =~ s/Array$//;
	    $expr = $output_expr{$type_kind{$type}};
	    if ($expr =~ /DO_ARRAY_ELEM/) {
	        blurt("Error: '$subtype' not in typemap"), return
		    unless defined($type_kind{$subtype});
                blurt("Error: No OUTPUT definition for type '$subtype' found"), return
                    unless defined $output_expr{$type_kind{$subtype}} ;
		$subexpr = $output_expr{$type_kind{$subtype}};
		$subexpr =~ s/ntype/subtype/g;
		$subexpr =~ s/\$arg/ST(ix_$var)/g;
		$subexpr =~ s/\$var/${var}[ix_$var]/g;
		$subexpr =~ s/\n\t/\n\t\t/g;
		$expr =~ s/DO_ARRAY_ELEM\n/$subexpr/;
		eval "print qq\a$expr\a";
	    }
	    elsif ($var eq 'RETVAL') {
		if ($expr =~ /^\t\$arg = /) {
		    eval "print qq\a$expr\a";
		    print "\tsv_2mortal(ST(0));\n";
		}
		else {
		    print "\tST(0) = sv_newmortal();\n";
		    eval "print qq\a$expr\a";
		}
	    }
	    elsif ($arg =~ /^ST\(\d+\)$/) {
		eval "print qq\a$expr\a";
	    }
    }
}

sub map_type {
    my($type) = @_;

    $type =~ s/:/_/g;
    if ($type =~ /^array\(([^,]*),(.*)\)/) {
	    return "$1 *";
    } else {
	    return $type;
    }
}


sub Exit {
# If this is VMS, the exit status has meaning to the shell, so we
# use a predictable value (SS$_Abort) rather than an arbitrary
# number.
    exit ($Is_VMS ? 44 : $errors) ;
}