unshift @ARGV, 'Pari.xs' if @ARGV < 2 and -r 'Pari.xs';
unshift @ARGV, 'libPARI/anal.c' if @ARGV < 2 and -r 'libPARI/anal.c';
(@ARGV == 2) || &usage;
@known = split /,\s*/, 'label, while, goto, until, read, pprint, print, texprint, pprint1, print1, O, if, o';
@known{@known} = (1) x @known;
open(XSUB,$ARGV[1]) || die "Cannot open $ARGV[1]: $!";
while (<XSUB>) {
$supported{$1}++ if /^\s*CASE_INTERFACE\s*\(\s*(\d+)\s*\)/;
}
close(XSUB) || die "Cannot close $ARGV[1]: $!";
open(ANAL,$ARGV[0]) || die "Cannot open $ARGV[0]: $!";
while (<ANAL>) {
if (/^entree\s+fonctions\[/ ... /^\s*\}\s*;\s*$/) {
next unless $i++; # Skip first line
last if /^\s*\}\s*;\s*$/;
&warnl() unless /
^ \s* \{ \s* "
(
[^""]+ # 1 Name
)
" \s* , \s*
(
\d+ # 2 Interface
)
\s* , \s*
(
[^,]+ # 3 C function pointer
)
\s* , \s*
(
\d+ # 4 Group
)
\s* , \s*
(
\d+ # 5
)
( \s* , \s* ((" [^"]* ") | NULL) \s* , \s* NULL )? # New fields
\s* \} \s* ,? \s* $
/x; # ";
($pari, $interface, $gp, $group, $code) = ($1, $2, $3, $4, $8);
if ($gp eq "0") {
if ($known{$pari}) {
$builtin_known{$pari}++;
} else {
$builtin{$pari}++;
}
} else {
$interface{$pari} = $interface;
$code{$interface} ||= ($code || '');
push @{$group{$group}}, $pari unless exists $supported{$interface};
$interfaces{$interface}++;
}
# print "'$pari' <= '$gp' via $interface\n";
# &warnl() unless $gp =~ /\b$pari\b/;
}
}
close(ANAL) || die "Cannot close $ARGV[0]: $!";
print "Builtins, unsupported as functions (but available in Perl):\n\t", join(", ", keys %builtin_known), "\n\n"
if %builtin_known;
print "Builtins, completely unsupported:\n\t", join(", ", keys %builtin), "\n\n"
if %builtin;
for (keys %interfaces) {
$unsupported{$_}++ unless $supported{$_};
}
@unsupported = sort {$interfaces{$a} <=> $interfaces{$b}} keys %unsupported;
print "\tTotal number of unsupported interfaces: ",scalar @unsupported,":\n";
for $i (sort {$a <=> $b} @unsupported) {
print "Interface $i=$code{$i} used in $interfaces{$i} function(s): ",
join(", ", @f=grep($interface{$_}==$i, keys %interface)), ".\n";
if ($code{$i}) {
$write = write_interface($i,$code{$i});
$suggest{$i} = $write if defined $write;
}
$total += $interfaces{$i};
push(@ff,@f);
}
print "\n\tTotal number of unsupported functions: $total:\n";
#join(", ", sort @ff), "\n";
for $g (sort {$a <=> $b} keys %group) {
print "group $g:\t", join(', ', sort @{$group{$g}}), "\n";
}
if (%suggest) {
print "Suggested code for interfaces:\n\n";
for $i (sort keys %suggest) {
print $suggest{$i};
}
for $i (sort keys %suggest) {
print <<EOI;
CASE_INTERFACE($i);
EOI
}
print "\n";
for $i (sort keys %suggest) {
print <<EOI;
case $i:
EOI
}
}
sub usage {die "Usage: $0 [path/to/anal.c] [path/to/Pari.xs]\n"}
sub warnl {warn "Unrecognized line:\n$_"}
sub write_interface {
my ($num, $interface) = @_;
my ($int) = $interface =~ /^"(.*)"$/ or return;
my @types;
my @c_arg_names;
my $ret_type = 'GEN';
while (length $int) {
if ($int =~ s/^s//) {
push @types, 'char *';
push @c_arg_names, 'arg' . scalar @types;
} elsif ($int =~ s/^l//) {
$ret_type = 'long';
} elsif ($int =~ s/^L//) {
push @types, 'long';
push @c_arg_names, 'arg' . scalar @types;
} elsif ($int =~ s/^V=//) {
push @types, 'PariVar';
push @c_arg_names, 'arg' . scalar @types;
} elsif ($int =~ s/^I//) {
push @types, 'PariExpr';
push @c_arg_names, 'arg' . scalar @types;
} elsif ($int =~ s/^G//) {
push @types, 'GEN';
push @c_arg_names, 'arg' . scalar @types;
} elsif ($int =~ s/^p//) {
push @c_arg_names, 'prec';
} else {
print "tail `$int' of interface$num unsupported\n";
return;
}
}
my @args = map {"arg$_"} 1 .. @types;
my $args = join ', ', @args;
my $c_args = join ', ', @c_arg_names;
my $i = 0;
$argdecl = join '', map {$i++; " $_ arg$i\n"} @types;
my $out = <<EOA;
$ret_type
interface$num($args)
long oldavma=avma;
EOA
$out .= $argdecl;
$out .= <<EOA;
CODE:
{
dFUNCTION($ret_type);
if (!FUNCTION) {
croak("XSUB call through interface did not provide *function");
}
RETVAL=FUNCTION($c_args);
}
OUTPUT:
RETVAL
EOA
if ($ret_type ne 'GEN') {
$out .= <<EOA;
CLEANUP:
avma=oldavma;
EOA
}
$out .= "\n";
$out;
}