[p5sagit/p5-mst-13.2.git] / ext / xsubpp

#!/usr/bin/perl
# $Header$ 

$usage = "Usage: xsubpp [-a] [-s] [-c] typemap file.xs\n";
die $usage unless (@ARGV >= 2 && @ARGV <= 6);

SWITCH: while ($ARGV[0] =~ /^-/) {
    $flag = shift @ARGV;
    $aflag = 1, next SWITCH if $flag =~ /^-a$/;
    $spat = $1, next SWITCH if $flag =~ /^-s(.*)$/;
    $cflag = 1, next SWITCH if $flag =~ /^-c$/;
    $eflag = 1, next SWITCH if $flag =~ /^-e$/;
    die $usage;
}

$typemap = shift @ARGV;
open(TYPEMAP, $typemap) || die "cannot open $typemap\n";
while (<TYPEMAP>) {
	next if /^\s*$/ || /^#/;
	chop;
	($typename, $kind) = split(/\t+/, $_, 2);
	$type_kind{$typename} = $kind;
}
close(TYPEMAP);

%input_expr = (JUNK, split(/\n(T_\w*)\s*\n/, <<'T_END'));

T_INT
	$var = (int)SvIV($arg)
T_ENUM
	$var = ($type)SvIV($arg)
T_U_INT
	$var = (unsigned int)SvIV($arg)
T_SHORT
	$var = (short)SvIV($arg)
T_U_SHORT
	$var = (unsigned short)SvIV($arg)
T_LONG
	$var = (long)SvIV($arg)
T_U_LONG
	$var = (unsigned long)SvIV($arg)
T_CHAR
	$var = (char)*SvPV($arg,na)
T_U_CHAR
	$var = (unsigned char)SvIV($arg)
T_FLOAT
	$var = (float)SvNV($arg)
T_DOUBLE
	$var = SvNV($arg)
T_STRING
	$var = SvPV($arg,na)
T_PTR
	$var = ($type)(unsigned long)SvNV($arg)
T_PTRREF
	if (SvTYPE($arg) == SVt_REF)
	    $var = ($type)(unsigned long)SvNV((SV*)SvANY($arg));
	else
	    croak(\"$var is not a reference\")
T_PTROBJ
	if (sv_isa($arg, \"${ntype}\"))
	    $var = ($type)(unsigned long)SvNV((SV*)SvANY($arg));
	else
	    croak(\"$var is not of type ${ntype}\")
T_PTRDESC
	if (sv_isa($arg, \"${ntype}\")) {
	    ${type}_desc = (\U${type}_DESC\E*)(unsigned long)SvNV((SV*)SvANY($arg));
	    $var = ${type}_desc->ptr;
	}
	else
	    croak(\"$var is not of type ${ntype}\")
T_REFREF
	if (SvTYPE($arg) == SVt_REF)
	    $var = *($type)(unsigned long)SvNV((SV*)SvANY($arg));
	else
	    croak(\"$var is not a reference\")
T_REFOBJ
	if (sv_isa($arg, \"${ntype}\"))
	    $var = *($type)(unsigned long)SvNV((SV*)SvANY($arg));
	else
	    croak(\"$var is not of type ${ntype}\")
T_OPAQUE
	$var NOT IMPLEMENTED
T_OPAQUEPTR
	$var = ($type)SvPV($arg,na)
T_PACKED
	$var = XS_unpack_$ntype($arg)
T_PACKEDARRAY
	$var = XS_unpack_$ntype($arg)
T_CALLBACK
	$var = make_perl_cb_$type($arg)
T_ARRAY
	$var = $ntype(items -= $argoff);
	U32 ix_$var = $argoff;
	while (items--) {
	    DO_ARRAY_ELEM;
	}
T_DATUM
	$var.dptr = SvPV($arg, $var.dsize);
T_GDATUM
	UNIMPLEMENTED
T_PLACEHOLDER
T_END

$* = 1; %output_expr = (JUNK, split(/^(T_\w*)\s*\n/, <<'T_END')); $* = 0;
T_INT
	sv_setiv($arg, (I32)$var);
T_ENUM
	sv_setiv($arg, (I32)$var);
T_U_INT
	sv_setiv($arg, (I32)$var);
T_SHORT
	sv_setiv($arg, (I32)$var);
T_U_SHORT
	sv_setiv($arg, (I32)$var);
T_LONG
	sv_setiv($arg, (I32)$var);
T_U_LONG
	sv_setiv($arg, (I32)$var);
T_CHAR
	sv_setpvn($arg, (char *)&$var, 1);
T_U_CHAR
	sv_setiv($arg, (I32)$var);
T_FLOAT
	sv_setnv($arg, (double)$var);
T_DOUBLE
	sv_setnv($arg, $var);
T_STRING
	sv_setpv($arg, $var);
T_PTR
	sv_setnv($arg, (double)(unsigned long)$var);
T_PTRREF
	sv_setptrref($arg, $var);
T_PTROBJ
	sv_setptrobj($arg, $var, \"${ntype}\");
T_PTRDESC
	sv_setptrobj($arg, (void*)new\U${type}_DESC\E($var), \"${ntype}\");
T_REFREF
	sv_setrefref($arg, \"${ntype}\", XS_service_$ntype,
		    ($var ? (void*)new $ntype($var) : 0));
T_REFOBJ
	NOT IMPLEMENTED
T_OPAQUE
	sv_setpvn($arg, (char *)&$var, sizeof($var));
T_OPAQUEPTR
	sv_setpvn($arg, (char *)$var, sizeof(*$var)), XFree((char *)$var);
T_PACKED
	XS_pack_$ntype($arg, $var);
T_PACKEDARRAY
	XS_pack_$ntype($arg, $var, count_$ntype);
T_DATAUNIT	
	sv_setpvn($arg, $var.chp(), $var.size());
T_CALLBACK
	sv_setpvn($arg, $var.context.value().chp(),
		$var.context.value().size());
T_ARRAY
	ST_EXTEND($var.size);
	for (U32 ix_$var = 0; ix_$var < $var.size; ix_$var++) {
		ST(ix_$var) = sv_mortalcopy(&sv_undef);
	DO_ARRAY_ELEM
	}
	sp += $var.size - 1;
T_DATUM
	sv_setpvn($arg, $var.dptr, $var.dsize);
T_GDATUM
	sv_usepvn($arg, $var.dptr, $var.dsize);
T_END

$uvfile = shift @ARGV;
open(F, $uvfile) || die "cannot open $uvfile\n";

if ($eflag) {
	print qq|#include "cfm/basic.h"\n|;
}

while (<F>) {
	last if ($Module, $foo, $Package, $foo1, $Prefix) =
		/^MODULE\s*=\s*(\w+)(\s+PACKAGE\s*=\s*(\w+))?(\s+PREFIX\s*=\s*(.+))?$/;
	print $_;
}
$Pack = $Package;
$Package .= "::" if defined $Package && $Package ne "";
$/ = "";

while (<F>) {
	# parse paragraph
	chop;
	next if /^\s*$/;
	next if /^(#.*\n?)+$/;
	if (/^MODULE\s*=\s*(\w+)(\s+PACKAGE\s*=\s*(\w+))?(\s+PREFIX\s*=\s*(.+))?$/) {
		$Module = $1;
		$foo = $2;
		$Package = $3;
		$Pack = $Package;
		$foo1 = $4;
		$Prefix = $5;
		$Package .= "::" if defined $Package && $Package ne "";
		next;
	}
	split(/[\t ]*\n/);

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

	# extract return type, function name and arguments
	$ret_type = shift(@_);
	if ($ret_type =~ /^static\s+(.*)$/) {
		$static = 1;
		$ret_type = $1;
	}
	$func_header = shift(@_);
	($func_name, $orig_args) =  $func_header =~ /^([\w:]+)\s*\((.*)\)$/;
	if ($func_name =~ /(.*)::(.*)/) {
		$class = $1;
		$func_name = $2;
	}
	($pname = $func_name) =~ s/^($Prefix)?/$Package/;
	push(@Func_name, "${Pack}_$func_name");
	push(@Func_pname, $pname);
	@args = split(/\s*,\s*/, $orig_args);
	if (defined($class) && !defined($static)) {
		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) && !defined($static)) {
		$func_args = join(", ", @args[1..$#args]);
	} else {
		$func_args = join(", ", @args);
	}
	@args_match{@args} = 1..@args;

	# print function header
	print <<"EOF" if $aflag;
static int
XS_${Pack}_$func_name(int, int sp, int items)
EOF
	print <<"EOF" if !$aflag;
static int
XS_${Pack}_$func_name(ix, sp, items)
register int ix;
register int sp;
register int items;
EOF
	print <<"EOF" if $elipsis;
{
    if (items < $min_args) {
	croak("Usage: $pname($orig_args)");
    }
EOF
	print <<"EOF" if !$elipsis;
{
    if (items < $min_args || items > $num_args) {
	croak("Usage: $pname($orig_args)");
    }
EOF

# Now do a block of some sort.

$condnum = 0;
if (!@_) {
    @_ = "CLEANUP:";
}
while (@_) {
	if ($_[0] =~ s/^\s*CASE\s*:\s*//) {
		$cond = shift(@_);
		if ($condnum == 0) {
		    print "    if ($cond)\n";
		}
		elsif ($cond ne '') {
		    print "    else if ($cond)\n";
		}
		else {
		    print "    else\n";
		}
		$condnum++;
	}

	print 		<<"EOF" if $eflag;
    TRY {
EOF
	print 		<<"EOF" if !$eflag;
    {
EOF

	# do initialization of input variables
	$thisdone = 0;
	$retvaldone = 0;
	$deferred = "";
	while ($_ = shift(@_)) {
		last if /^\s*NOT_IMPLEMENTED_YET/;
		last if /^\s*(CODE|OUTPUT|CLEANUP|CASE)\s*:/;
		($var_type, $var_name, $var_init) =
		    /\s*([^\t]+)\s*([^\s=]+)\s*(=.*)?/;
		if ($var_name =~ /^&/) {
			$var_name =~ s/^&//;
			$var_addr{$var_name} = 1;
		}
		$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) && !defined($static)) {
		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;
		}
		print $deferred;
		if (/^\s*CODE:/) {
			while ($_ = shift(@_)) {
				last if /^\s*(OUTPUT|CLEANUP|CASE)\s*:/;
				print "$_\n";
			}
		} else {
			print "\n\t";
			if ($ret_type ne "void") {
				print "RETVAL = ";
			}
			if (defined($static)) {
				print "$class::";
			} elsif (defined($class)) {
				print "THIS->";
			}
			if (defined($spat) && $func_name =~ /^($spat)(.*)$/) {
				$func_name = $2;
			}
			print "$func_name($func_args);\n";
			&generate_output($ret_type, 0, "RETVAL")
			    unless $ret_type eq "void";
		}
	}

	# do output variables
	if (/^\s*OUTPUT\s*:/) {
		while ($_ = shift(@_)) {
			last if /^\s*CLEANUP\s*:/;
			s/^\s+//;
			($outarg, $outcode) = split(/\t+/);
			if ($outcode) {
			print "\t$outcode\n";
			} else {
				die "$outarg not an argument"
				    unless defined($args_match{$outarg});
				$var_num = $args_match{$outarg};
				&generate_output($var_types{$outarg}, $var_num,
				    $outarg); 
			}
		}
	}
	# do cleanup
	if (/^\s*CLEANUP\s*:/) {
	    while ($_ = shift(@_)) {
		    last if /^\s*CASE\s*:/;
		    print "$_\n";
	    }
	}
	# print function trailer
	print <<EOF if $eflag;
    }
    BEGHANDLERS
    CATCHALL
	croak("%s: %s\\tpropagated", Xname, Xreason);
    ENDHANDLERS
EOF
	print <<EOF if !$eflag;
    }
EOF
	if (/^\s*CASE\s*:/) {
	    unshift(@_, $_);
	}
}
	print <<EOF;
    return sp;
}

EOF
}

# print initialization routine
print qq/extern "C"\n/ if $cflag;
print <<"EOF";
int init_$Module(ix,sp,items)
int ix;
int sp;
int items;
{
    char* file = __FILE__;

EOF

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

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

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

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

	die "$type not in typemap" if !defined($type_kind{$type});
	($ntype = $type) =~ s/\s*\*/Ptr/g;
	$subtype = $ntype;
	$subtype =~ s/Ptr$//;
	$subtype =~ s/Array$//;
	$expr = $input_expr{$type_kind{$type}};
	if ($expr =~ /DO_ARRAY_ELEM/) {
	    $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)";
	local($argoff) = $num - 1;
	local($ntype);

	if ($type =~ /^array\(([^,]*),(.*)\)/) {
		print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1)), XFree((char *)$var);\n";
	} else {
		die "$type not in typemap" if !defined($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/) {
		    $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/;
		}
		elsif ($arg eq 'ST(0)') {
		    print "\tST(0) = sv_mortalcopy(&sv_undef);\n";
		}
		eval "print qq\f$expr\f";
	}
}

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

	if ($type =~ /^array\(([^,]*),(.*)\)/) {
		return "$1 *";
	} else {
		return $type;
	}
}
Commit	Line	Data
93a17b20	1	#!/usr/bin/perl
	2	# $Header$
	3
463ee0b2	4	$usage = "Usage: xsubpp [-a] [-s] [-c] typemap file.xs\n";
93a17b20	5	die $usage unless (@ARGV >= 2 && @ARGV <= 6);
	6
	7	SWITCH: while ($ARGV[0] =~ /^-/) {
	8	$flag = shift @ARGV;
	9	$aflag = 1, next SWITCH if $flag =~ /^-a$/;
	10	$spat = $1, next SWITCH if $flag =~ /^-s(.*)$/;
	11	$cflag = 1, next SWITCH if $flag =~ /^-c$/;
	12	$eflag = 1, next SWITCH if $flag =~ /^-e$/;
	13	die $usage;
	14	}
	15
	16	$typemap = shift @ARGV;
	17	open(TYPEMAP, $typemap) \|\| die "cannot open $typemap\n";
	18	while (<TYPEMAP>) {
	19	next if /^\s*$/ \|\| /^#/;
	20	chop;
	21	($typename, $kind) = split(/\t+/, $_, 2);
	22	$type_kind{$typename} = $kind;
	23	}
	24	close(TYPEMAP);
	25
	26	%input_expr = (JUNK, split(/\n(T_\w)\s\n/, <<'T_END'));
	27
	28	T_INT
463ee0b2	29	$var = (int)SvIV($arg)
93a17b20	30	T_ENUM
463ee0b2	31	$var = ($type)SvIV($arg)
93a17b20	32	T_U_INT
463ee0b2	33	$var = (unsigned int)SvIV($arg)
93a17b20	34	T_SHORT
463ee0b2	35	$var = (short)SvIV($arg)
93a17b20	36	T_U_SHORT
463ee0b2	37	$var = (unsigned short)SvIV($arg)
93a17b20	38	T_LONG
463ee0b2	39	$var = (long)SvIV($arg)
93a17b20	40	T_U_LONG
463ee0b2	41	$var = (unsigned long)SvIV($arg)
93a17b20	42	T_CHAR
463ee0b2	43	$var = (char)*SvPV($arg,na)
93a17b20	44	T_U_CHAR
463ee0b2	45	$var = (unsigned char)SvIV($arg)
93a17b20	46	T_FLOAT
463ee0b2	47	$var = (float)SvNV($arg)
93a17b20	48	T_DOUBLE
463ee0b2	49	$var = SvNV($arg)
93a17b20	50	T_STRING
463ee0b2	51	$var = SvPV($arg,na)
93a17b20	52	T_PTR
463ee0b2	53	$var = ($type)(unsigned long)SvNV($arg)
	54	T_PTRREF
	55	if (SvTYPE($arg) == SVt_REF)
	56	$var = ($type)(unsigned long)SvNV((SV*)SvANY($arg));
	57	else
	58	croak(\"$var is not a reference\")
	59	T_PTROBJ
	60	if (sv_isa($arg, \"${ntype}\"))
	61	$var = ($type)(unsigned long)SvNV((SV*)SvANY($arg));
	62	else
	63	croak(\"$var is not of type ${ntype}\")
	64	T_PTRDESC
	65	if (sv_isa($arg, \"${ntype}\")) {
	66	${type}_desc = (\U${type}_DESC\E)(unsigned long)SvNV((SV)SvANY($arg));
	67	$var = ${type}_desc->ptr;
	68	}
	69	else
	70	croak(\"$var is not of type ${ntype}\")
	71	T_REFREF
	72	if (SvTYPE($arg) == SVt_REF)
	73	$var = ($type)(unsigned long)SvNV((SV)SvANY($arg));
	74	else
	75	croak(\"$var is not a reference\")
	76	T_REFOBJ
	77	if (sv_isa($arg, \"${ntype}\"))
	78	$var = ($type)(unsigned long)SvNV((SV)SvANY($arg));
	79	else
	80	croak(\"$var is not of type ${ntype}\")
93a17b20	81	T_OPAQUE
	82	$var NOT IMPLEMENTED
	83	T_OPAQUEPTR
463ee0b2	84	$var = ($type)SvPV($arg,na)
93a17b20	85	T_PACKED
463ee0b2	86	$var = XS_unpack_$ntype($arg)
93a17b20	87	T_PACKEDARRAY
463ee0b2	88	$var = XS_unpack_$ntype($arg)
93a17b20	89	T_CALLBACK
	90	$var = make_perl_cb_$type($arg)
	91	T_ARRAY
	92	$var = $ntype(items -= $argoff);
	93	U32 ix_$var = $argoff;
	94	while (items--) {
	95	DO_ARRAY_ELEM;
	96	}
463ee0b2	97	T_DATUM
	98	$var.dptr = SvPV($arg, $var.dsize);
	99	T_GDATUM
	100	UNIMPLEMENTED
93a17b20	101	T_PLACEHOLDER
	102	T_END
	103
	104	$* = 1; %output_expr = (JUNK, split(/^(T_\w)\s\n/, <<'T_END')); $* = 0;
	105	T_INT
463ee0b2	106	sv_setiv($arg, (I32)$var);
93a17b20	107	T_ENUM
463ee0b2	108	sv_setiv($arg, (I32)$var);
93a17b20	109	T_U_INT
463ee0b2	110	sv_setiv($arg, (I32)$var);
93a17b20	111	T_SHORT
463ee0b2	112	sv_setiv($arg, (I32)$var);
93a17b20	113	T_U_SHORT
463ee0b2	114	sv_setiv($arg, (I32)$var);
93a17b20	115	T_LONG
463ee0b2	116	sv_setiv($arg, (I32)$var);
93a17b20	117	T_U_LONG
463ee0b2	118	sv_setiv($arg, (I32)$var);
93a17b20	119	T_CHAR
463ee0b2	120	sv_setpvn($arg, (char *)&$var, 1);
93a17b20	121	T_U_CHAR
463ee0b2	122	sv_setiv($arg, (I32)$var);
93a17b20	123	T_FLOAT
463ee0b2	124	sv_setnv($arg, (double)$var);
93a17b20	125	T_DOUBLE
463ee0b2	126	sv_setnv($arg, $var);
93a17b20	127	T_STRING
463ee0b2	128	sv_setpv($arg, $var);
93a17b20	129	T_PTR
463ee0b2	130	sv_setnv($arg, (double)(unsigned long)$var);
	131	T_PTRREF
	132	sv_setptrref($arg, $var);
	133	T_PTROBJ
	134	sv_setptrobj($arg, $var, \"${ntype}\");
	135	T_PTRDESC
	136	sv_setptrobj($arg, (void*)new\U${type}_DESC\E($var), \"${ntype}\");
	137	T_REFREF
	138	sv_setrefref($arg, \"${ntype}\", XS_service_$ntype,
	139	($var ? (void*)new $ntype($var) : 0));
	140	T_REFOBJ
	141	NOT IMPLEMENTED
93a17b20	142	T_OPAQUE
463ee0b2	143	sv_setpvn($arg, (char *)&$var, sizeof($var));
93a17b20	144	T_OPAQUEPTR
463ee0b2	145	sv_setpvn($arg, (char )$var, sizeof($var)), XFree((char *)$var);
93a17b20	146	T_PACKED
463ee0b2	147	XS_pack_$ntype($arg, $var);
93a17b20	148	T_PACKEDARRAY
463ee0b2	149	XS_pack_$ntype($arg, $var, count_$ntype);
93a17b20	150	T_DATAUNIT
463ee0b2	151	sv_setpvn($arg, $var.chp(), $var.size());
93a17b20	152	T_CALLBACK
463ee0b2	153	sv_setpvn($arg, $var.context.value().chp(),
93a17b20	154	$var.context.value().size());
	155	T_ARRAY
	156	ST_EXTEND($var.size);
	157	for (U32 ix_$var = 0; ix_$var < $var.size; ix_$var++) {
463ee0b2	158	ST(ix_$var) = sv_mortalcopy(&sv_undef);
93a17b20	159	DO_ARRAY_ELEM
	160	}
	161	sp += $var.size - 1;
463ee0b2	162	T_DATUM
	163	sv_setpvn($arg, $var.dptr, $var.dsize);
	164	T_GDATUM
	165	sv_usepvn($arg, $var.dptr, $var.dsize);
93a17b20	166	T_END
	167
	168	$uvfile = shift @ARGV;
	169	open(F, $uvfile) \|\| die "cannot open $uvfile\n";
	170
	171	if ($eflag) {
	172	print qq\|#include "cfm/basic.h"\n\|;
	173	}
	174
	175	while (<F>) {
	176	last if ($Module, $foo, $Package, $foo1, $Prefix) =
	177	/^MODULE\s=\s(\w+)(\s+PACKAGE\s=\s(\w+))?(\s+PREFIX\s=\s(.+))?$/;
	178	print $_;
	179	}
	180	$Pack = $Package;
463ee0b2	181	$Package .= "::" if defined $Package && $Package ne "";
93a17b20	182	$/ = "";
	183
	184	while (<F>) {
	185	# parse paragraph
	186	chop;
	187	next if /^\s*$/;
	188	next if /^(#.*\n?)+$/;
	189	if (/^MODULE\s=\s(\w+)(\s+PACKAGE\s=\s(\w+))?(\s+PREFIX\s=\s(.+))?$/) {
	190	$Module = $1;
	191	$foo = $2;
	192	$Package = $3;
	193	$Pack = $Package;
	194	$foo1 = $4;
	195	$Prefix = $5;
463ee0b2	196	$Package .= "::" if defined $Package && $Package ne "";
93a17b20	197	next;
	198	}
	199	split(/[\t ]*\n/);
	200
	201	# initialize info arrays
	202	undef(%args_match);
	203	undef(%var_types);
	204	undef(%var_addr);
	205	undef(%defaults);
	206	undef($class);
	207	undef($static);
	208	undef($elipsis);
	209
	210	# extract return type, function name and arguments
	211	$ret_type = shift(@_);
	212	if ($ret_type =~ /^static\s+(.*)$/) {
	213	$static = 1;
	214	$ret_type = $1;
	215	}
	216	$func_header = shift(@_);
	217	($func_name, $orig_args) = $func_header =~ /^([\w:]+)\s\((.)\)$/;
	218	if ($func_name =~ /(.)::(.)/) {
	219	$class = $1;
	220	$func_name = $2;
	221	}
	222	($pname = $func_name) =~ s/^($Prefix)?/$Package/;
	223	push(@Func_name, "${Pack}_$func_name");
	224	push(@Func_pname, $pname);
	225	@args = split(/\s,\s/, $orig_args);
	226	if (defined($class) && !defined($static)) {
	227	unshift(@args, "THIS");
	228	$orig_args = "THIS, $orig_args";
	229	$orig_args =~ s/^THIS, $/THIS/;
	230	}
	231	$orig_args =~ s/"/\\"/g;
	232	$min_args = $num_args = @args;
	233	foreach $i (0..$num_args-1) {
	234	if ($args[$i] =~ s/\.\.\.//) {
	235	$elipsis = 1;
	236	$min_args--;
	237	if ($args[i] eq '' && $i == $num_args - 1) {
	238	pop(@args);
	239	last;
	240	}
	241	}
	242	if ($args[$i] =~ /([^=]\S)\s=\s(.)/) {
	243	$min_args--;
	244	$args[$i] = $1;
	245	$defaults{$args[$i]} = $2;
	246	$defaults{$args[$i]} =~ s/"/\\"/g;
	247	}
	248	}
	249	if (defined($class) && !defined($static)) {
	250	$func_args = join(", ", @args[1..$#args]);
	251	} else {
	252	$func_args = join(", ", @args);
	253	}
	254	@args_match{@args} = 1..@args;
	255
	256	# print function header
	257	print <<"EOF" if $aflag;
	258	static int
463ee0b2	259	XS_${Pack}_$func_name(int, int sp, int items)
93a17b20	260	EOF
	261	print <<"EOF" if !$aflag;
	262	static int
463ee0b2	263	XS_${Pack}_$func_name(ix, sp, items)
93a17b20	264	register int ix;
	265	register int sp;
	266	register int items;
	267	EOF
	268	print <<"EOF" if $elipsis;
	269	{
	270	if (items < $min_args) {
463ee0b2	271	croak("Usage: $pname($orig_args)");
93a17b20	272	}
	273	EOF
	274	print <<"EOF" if !$elipsis;
	275	{
	276	if (items < $min_args \|\| items > $num_args) {
463ee0b2	277	croak("Usage: $pname($orig_args)");
93a17b20	278	}
	279	EOF
	280
	281	# Now do a block of some sort.
	282
	283	$condnum = 0;
	284	if (!@_) {
	285	@_ = "CLEANUP:";
	286	}
	287	while (@_) {
	288	if ($_[0] =~ s/^\sCASE\s:\s*//) {
	289	$cond = shift(@_);
	290	if ($condnum == 0) {
	291	print " if ($cond)\n";
	292	}
	293	elsif ($cond ne '') {
	294	print " else if ($cond)\n";
	295	}
	296	else {
	297	print " else\n";
	298	}
	299	$condnum++;
	300	}
	301
	302	print <<"EOF" if $eflag;
	303	TRY {
	304	EOF
	305	print <<"EOF" if !$eflag;
	306	{
	307	EOF
	308
	309	# do initialization of input variables
	310	$thisdone = 0;
	311	$retvaldone = 0;
463ee0b2	312	$deferred = "";
93a17b20	313	while ($_ = shift(@_)) {
	314	last if /^\s*NOT_IMPLEMENTED_YET/;
	315	last if /^\s(CODE\|OUTPUT\|CLEANUP\|CASE)\s:/;
	316	($var_type, $var_name, $var_init) =
	317	/\s([^\t]+)\s([^\s=]+)\s(=.)?/;
	318	if ($var_name =~ /^&/) {
	319	$var_name =~ s/^&//;
	320	$var_addr{$var_name} = 1;
	321	}
	322	$thisdone \|= $var_name eq "THIS";
	323	$retvaldone \|= $var_name eq "RETVAL";
	324	$var_types{$var_name} = $var_type;
	325	print "\t" . &map_type($var_type);
	326	$var_num = $args_match{$var_name};
	327	if ($var_addr{$var_name}) {
	328	$func_args =~ s/\b($var_name)\b/&\1/;
	329	}
	330	if ($var_init !~ /^=\sNO_INIT\s$/) {
	331	if ($var_init !~ /^\s*$/) {
	332	&output_init($var_type, $var_num,
	333	"$var_name $var_init");
	334	} elsif ($var_num) {
	335	# generate initialization code
	336	&generate_init($var_type, $var_num, $var_name);
	337	} else {
	338	print ";\n";
	339	}
	340	} else {
	341	print "\t$var_name;\n";
	342	}
	343	}
	344	if (!$thisdone && defined($class) && !defined($static)) {
	345	print "\t$class *";
	346	$var_types{"THIS"} = "$class *";
	347	&generate_init("$class *", 1, "THIS");
	348	}
	349
	350	# do code
	351	if (/^\s*NOT_IMPLEMENTED_YET/) {
463ee0b2	352	print "\ncroak(\"$pname: not implemented yet\");\n";
93a17b20	353	} else {
	354	if ($ret_type ne "void") {
	355	print "\t" . &map_type($ret_type) . "\tRETVAL;\n"
	356	if !$retvaldone;
	357	$args_match{"RETVAL"} = 0;
	358	$var_types{"RETVAL"} = $ret_type;
	359	}
463ee0b2	360	print $deferred;
93a17b20	361	if (/^\s*CODE:/) {
	362	while ($_ = shift(@_)) {
	363	last if /^\s(OUTPUT\|CLEANUP\|CASE)\s:/;
	364	print "$_\n";
	365	}
	366	} else {
	367	print "\n\t";
	368	if ($ret_type ne "void") {
463ee0b2	369	print "RETVAL = ";
93a17b20	370	}
	371	if (defined($static)) {
	372	print "$class::";
	373	} elsif (defined($class)) {
	374	print "THIS->";
	375	}
	376	if (defined($spat) && $func_name =~ /^($spat)(.*)$/) {
	377	$func_name = $2;
	378	}
	379	print "$func_name($func_args);\n";
	380	&generate_output($ret_type, 0, "RETVAL")
	381	unless $ret_type eq "void";
	382	}
	383	}
	384
	385	# do output variables
	386	if (/^\sOUTPUT\s:/) {
	387	while ($_ = shift(@_)) {
	388	last if /^\sCLEANUP\s:/;
	389	s/^\s+//;
	390	($outarg, $outcode) = split(/\t+/);
	391	if ($outcode) {
	392	print "\t$outcode\n";
	393	} else {
	394	die "$outarg not an argument"
	395	unless defined($args_match{$outarg});
	396	$var_num = $args_match{$outarg};
	397	&generate_output($var_types{$outarg}, $var_num,
	398	$outarg);
	399	}
	400	}
	401	}
	402	# do cleanup
	403	if (/^\sCLEANUP\s:/) {
	404	while ($_ = shift(@_)) {
	405	last if /^\sCASE\s:/;
	406	print "$_\n";
	407	}
	408	}
	409	# print function trailer
	410	print <<EOF if $eflag;
	411	}
	412	BEGHANDLERS
	413	CATCHALL
463ee0b2	414	croak("%s: %s\\tpropagated", Xname, Xreason);
93a17b20	415	ENDHANDLERS
	416	EOF
	417	print <<EOF if !$eflag;
	418	}
	419	EOF
	420	if (/^\sCASE\s:/) {
	421	unshift(@_, $_);
	422	}
	423	}
	424	print <<EOF;
	425	return sp;
	426	}
	427
	428	EOF
	429	}
	430
	431	# print initialization routine
	432	print qq/extern "C"\n/ if $cflag;
	433	print <<"EOF";
463ee0b2	434	int init_$Module(ix,sp,items)
	435	int ix;
	436	int sp;
	437	int items;
93a17b20	438	{
463ee0b2	439	char* file = __FILE__;
463ee0b2	440
93a17b20	441	EOF
	442
	443	for (@Func_name) {
	444	$pname = shift(@Func_pname);
463ee0b2	445	print " newXSUB(\"$pname\", 0, XS_$_, file);\n";
93a17b20	446	}
	447	print "}\n";
	448
	449	sub output_init {
	450	local($type, $num, $init) = @_;
	451	local($arg) = "ST($num)";
	452
463ee0b2	453	eval qq/print " $init\\\n"/;
93a17b20	454	}
	455
	456	sub generate_init {
	457	local($type, $num, $var) = @_;
	458	local($arg) = "ST($num)";
	459	local($argoff) = $num - 1;
	460	local($ntype);
	461
	462	die "$type not in typemap" if !defined($type_kind{$type});
	463	($ntype = $type) =~ s/\s\/Ptr/g;
	464	$subtype = $ntype;
	465	$subtype =~ s/Ptr$//;
	466	$subtype =~ s/Array$//;
	467	$expr = $input_expr{$type_kind{$type}};
	468	if ($expr =~ /DO_ARRAY_ELEM/) {
	469	$subexpr = $input_expr{$type_kind{$subtype}};
	470	$subexpr =~ s/ntype/subtype/g;
	471	$subexpr =~ s/\$arg/ST(ix_$var)/g;
	472	$subexpr =~ s/\n\t/\n\t\t/g;
	473	$subexpr =~ s/is not of (.*")/[arg %d] is not of $1, ix_$var + 1/g;
	474	$subexpr =~ s/\$var/$var[ix_$var - $argoff]/;
	475	$expr =~ s/DO_ARRAY_ELEM/$subexpr/;
	476	}
	477	if (defined($defaults{$var})) {
	478	$expr =~ s/(\t+)/$1 /g;
	479	$expr =~ s/ /\t/g;
463ee0b2	480	eval qq/print "\\t$var;\\n"/;
463ee0b2	481	$deferred .= eval qq/"\\n\\tif (items < $num)\\n\\t $var = $defaults{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/;
93a17b20	482	} elsif ($expr !~ /^\t\$var =/) {
463ee0b2	483	eval qq/print "\\t$var;\\n"/;
463ee0b2	484	$deferred .= eval qq/"\\n$expr;\\n"/;
93a17b20	485	} else {
463ee0b2	486	eval qq/print "$expr;\\n"/;
93a17b20	487	}
	488	}
	489
	490	sub generate_output {
	491	local($type, $num, $var) = @_;
	492	local($arg) = "ST($num)";
	493	local($argoff) = $num - 1;
	494	local($ntype);
	495
	496	if ($type =~ /^array\(([^,]),(.)\)/) {
463ee0b2	497	print "\tsv_setpvn($arg, (char )$var, $2 sizeof($1)), XFree((char *)$var);\n";
93a17b20	498	} else {
	499	die "$type not in typemap" if !defined($type_kind{$type});
	500	($ntype = $type) =~ s/\s\/Ptr/g;
	501	$ntype =~ s/\(\)//g;
	502	$subtype = $ntype;
	503	$subtype =~ s/Ptr$//;
	504	$subtype =~ s/Array$//;
	505	$expr = $output_expr{$type_kind{$type}};
	506	if ($expr =~ /DO_ARRAY_ELEM/) {
	507	$subexpr = $output_expr{$type_kind{$subtype}};
	508	$subexpr =~ s/ntype/subtype/g;
	509	$subexpr =~ s/\$arg/ST(ix_$var)/g;
	510	$subexpr =~ s/\$var/${var}[ix_$var]/g;
	511	$subexpr =~ s/\n\t/\n\t\t/g;
	512	$expr =~ s/DO_ARRAY_ELEM\n/$subexpr/;
	513	}
463ee0b2	514	elsif ($arg eq 'ST(0)') {
	515	print "\tST(0) = sv_mortalcopy(&sv_undef);\n";
	516	}
93a17b20	517	eval "print qq\f$expr\f";
	518	}
	519	}
	520
	521	sub map_type {
	522	local($type) = @_;
	523
	524	if ($type =~ /^array\(([^,]),(.)\)/) {
	525	return "$1 *";
	526	} else {
	527	return $type;
	528	}
	529	}