package Math::PariBuild;
$VERSION = '2.01080604';
require Exporter;
@ISA = 'Exporter';
@EXPORT = qw(get_pari_version
pari_formatted_version
find_pari_dir
download_pari
patch_pari
download_and_patch_pari
make_pod
build_tests
find_paricfg
find_or_Configure_paricfg
write_paricfg
build_paricfg
find_machine_architecture
known_asmarch
inline_headers
inline_headers2
not_gnu_as
choose_and_report_assembler
kernel_files
kernel_fill_data
assembler_flags
assembler_flags_via
extra_includes
ep_codes_from_file
ep_hash_report
ep_in_version
code_C_translator
build_funclists
);
use strict;
use Config;
use File::Copy 'copy';
use File::Basename 'basename';
=head1 NAME
Math::PariBuild - utility functions used during configuration of C<Math::Pari>.
=head1 SYNOPSIS
use Math::PariBuild;
=head1 DESCRIPTION
=over
=item C<get_pari_version($dir)>
extracts the version of GP/PARI given the build directory $dir;
version is read from $F<$dir/config/version> and has the form as in
C<"2.3.1">. Returns undef on failure.
=cut
sub get_pari_version {
my $dir = shift;
my $v = "";
open(IN, "$dir/config/version") or return;
/(?:version|VersionMajor|VersionMinor|patch)='?(\d+(\.\d+)?)'?/
and $v .= "$1." while <IN>;
close(IN) or die "error closing '$dir/config/version'";
$v =~ s/\.$// or return;
return $v;
}
=item C<pari_formatted_version($dir)>
extracts the version of GP/PARI given the build directory $dir;
version has the form as in C<"2003001"> for version 2.3.1. Returns
the directory name on failure.
=cut
sub pari_formatted_version {
my $dir = shift;
my $v;
$v = get_pari_version $dir;
if (defined $v) {
$dir = $v;
} else {
warn(<<EOW);
Could not extract version from '$dir/config/version';
Do you remember that paridir should be location of PARI/GP source tree,
not the location of compiled+installed files?
Trying extract from the directory name...
EOW
}
return sprintf '%d%03d%03d',$1, $2, $3
if $dir =~ /(\d+)\.(\d+).(\d+)(\.(alpha|beta))?$/;
warn(<<EOW);
Directory `$dir' has unknown syntax...
EOW
return $dir;
}
=item find_pari_dir()
Returns the GP/PARI build directory, looking for it as a kid, sibling,
or parent of the current directory. [Currently skips versions 2.3.* if
possible.]
=cut
my $latmus = 'src/test/in/nfields';
sub filter_versions_too_new {
my $force = shift;
my @dirs = grep !m((?:^|[\\/])pari-(?:$common::skip_versions)), @_;
print "Filtered out versions too new...\n" if @dirs != @_;
return @dirs if $force or @dirs;
return @_; # Not found, not forced
}
sub find_pari_dir {
my ($dir, @dirs, @gooddirs);
# Try to find alongside
for $dir ('.', '..', '../..', '../../..') {
@dirs = filter_versions_too_new 0, <$dir/pari-[234].*>;
@dirs = "$dir/pari" if not @dirs and -d "$dir/pari";
@dirs = grep -e "$_/$latmus", @dirs;
last if @dirs;
}
@gooddirs = grep !/alpha|beta/, @dirs;
@gooddirs = grep !/alpha/, @dirs unless @gooddirs;
@gooddirs = @dirs unless @gooddirs;
@gooddirs = sort {pari_formatted_version($a) cmp pari_formatted_version($b)}
@gooddirs;
return $gooddirs[-1];
}
=item download_pari()
Using FTP connection, downloads the latest version of GP/PARI, and
extracts it. Returns the GP/PARI build directory and the version in
the format C<"2.3.1">. [Currently skips versions 2.3.*]
Optional arguments: name of the tar file with GP/PARI source (undef
OK), force download.
=cut
sub manual_download_instructions {
<<EOP;
One can rerun Makefile.PL after fetching GP/PARI archive (e.g., pari-2.1.7.tgz,
or pari-2.3.4.tar.gz) manually to the current directory, or a (grand)parent
directory of the current directory.
[Keep in mind that the numbers "inside version" of Math::Pari module
correspond to the last versions of GP/PARI it was tested with (additionally,
2.0108* works best with the last 2.1.* version, 2.1.7).
As an alternative to having archive in CWD or its (grand)parent, specify
pari_tgz=PATH_TO_TAR_GZ
option to Makefile.PL.
There is no need to extract the archive, or build GP/PARI; but if you
have it extracted [and patched, if needed], you may specify
paridir=PATH_TO_DIST_DIR
option to Makefile.PL instead of `pari_tgz'. However, in this case
the files WON'T be auto-patched.
As a last-resort solution, there is also a possibility to use an already
compiled PARI library. See the documentation in README and INSTALL files.]
EOP
}
sub debug_no_response ($) {
return '' unless $ENV{AUTOMATED_TESTING};
my $r = shift;
my $c = $r->content;
my $t = $r->content_type;
$c = '<<undef>>' unless defined $c;
$c =~ s/\s+\Z/\n/;
my $b = '=====================';
return "\n$b Response content (type=$t)\n$c\n$b\n\n";
}
sub ll_ftp () { # All Perl download failures I saw are on Linux and BSD.
# this (not very portable) solution should work there?
open OF, '> ftp-cmd' or die "Can't open `ftp-cmd' for write: $!";
print OF <<'EOF'; # XXXX Hardwired version!
user anonymous auto-download-Math-Pari@cpan.org
cd /pub/pari/unix/
dir
cd OLD
dir
binary
get pari-2.1.7.tgz
quit
EOF
close OF or die "Can't close `ftp-cmd' for write: $!";
print <<EOP;
==============================================
ftp -pinegv megrez.math.u-bordeaux.fr < ftp-cmd
EOP
my $rc = system "ftp -pinegv megrez.math.u-bordeaux.fr < ftp-cmd";
print <<EOP;
==============================================
EOP
return if $rc;
# XXXX Temporarily disable continuing build (to see smoke testing reports)
warn <<EOW;
==========================================================================
===
=== If the output from FTP session above successfully lists
=== directories, your installs of Net::FTP and, possibly, LWP
=== is completely broken. How comes???
===
==========================================================================
EOW
warn(<<'EOW'), return unless $ENV{MATHPARI_USEFTP};
FTP session is for debugging only; I'm ignoring the downloaded file.
(Set $ENV{MATHPARI_USEFTP} to TRUE to actually use the downloaded file.)
EOW
return 'pari-2.1.7.tgz';
}
sub download_pari {
my ($srcfile, $force) = (shift, shift);
my $host = 'megrez.math.u-bordeaux.fr';
my $dir = '/pub/pari/unix/';
my($ftp, $ua, $base_url);
print "Did not find GP/PARI build directory around.\n" unless defined $srcfile;
my @match = ( '((?:.*\/)?pari\W*', '(\d+\.\d+\.\d+).*\.t(?:ar\.)?gz)$' );
my $match1 = "$match[0]$match[1]";
my $match = "$match[0](?!$common::skip_versions)$match[1]";
my %archive;
my $match_pari_archive = sub {
my ($file, $ok23) = (shift, shift);
return unless $ok23 ? $file =~ /$match1/o : $file =~ /$match/o;
$file = $1;
my $version = $2;
if ($file =~ /alpha/) {
$archive{alpha}{$version} = $file;
} elsif ($file =~ /beta/) {
$archive{beta}{$version} = $file;
} else {
$archive{golden}{$version} = $file;
}
};
if ($srcfile and -s $srcfile) {
die "The FILE supplied via the pari_tgz=$srcfile option did not match /$match/"
unless $match_pari_archive->($srcfile, 'ok2.3');
} else {
if ($force) {
print "Forced autofetching...\n\n"
} elsif (not $ENV{AUTOMATED_TESTING} and not $ENV{PERL_MM_USE_DEFAULT}
and -t STDIN and (-t STDOUT or -p STDOUT)) { # Interactive
$| = 1; # Usually, we run under MakeMaker, so test PERL_MM_USE_DEFAULT
my $mess = <<EOP;
Do you want to me to fetch GP/PARI automatically?
(If you do not, you will need to fetch it manually, and/or direct me to
the directory with GP/PARI source via the command-line option paridir=/dir)
Make sure you have a large scrollback buffer to see the messages, or `tee'
the STDOUT/STDERR to a file.
Fetch? (y/n, press Enter)
EOP
chomp $mess;
print "$mess ";
my $ans = <STDIN>;
if ($ans !~ /y/i) {
my ($eA, $eM, $tI, $tO, $tE, $pO, $pE)
= (@ENV{ qw(AUTOMATED_TESTING PERL_MM_USE_DEFAULT) },
-t STDIN, -t STDOUT, -t STDERR, -p STDERR, -p STDOUT);
defined() ? $_ = "'$_'" : $_ = '<undef>' for $eA, $eM;
print <<EOP; # Is AUTOMATED_TESTING ALWAYS defined on smoke???
Well, as you wish...
[ to debug Smoke Tests: AUTOMATED_TESTING=$eA PERL_MM_USE_DEFAULT=$eM
-t STDIN/STDOUT/ERR = $tI/$tO/$tE -p STDOUT/ERR = $pO/$pE ]
EOP
print manual_download_instructions();
return;
}
} else {
print "Non-interactive session, autofetching...\n\n"
}
$base_url = "ftp://$host$dir";
my @extra_chdir = qw(OLD);
print "Getting GP/PARI from $base_url\n";
eval {
require Net::FTP;
$ftp = Net::FTP->new($host) or die "Cannot create FTP object: $!";
$ftp->login("anonymous","Math::Pari@")
or die "Cannot login anonymously (",$ftp->message(),"): $!";
my $c = 0;
my @Extra = @extra_chdir;
while (not $c) {
$ftp->cwd($dir) or die "Cannot cwd (",$ftp->message(),"): $!";
$ftp->binary() or die "Cannot switch to binary (",$ftp->message(),"): $!";
my @lst = $ftp->ls();
@lst or ($ftp->pasv() and @lst = $ftp->ls()) or die "Cannot list (",$ftp->message(),"): $!";
#print "list = `@lst'\n";
%archive = ();
for my $file (@lst) {
$c++ if $match_pari_archive->($file);
}
unless ($c) {
die "Did not find any file matching /$match/ via FTP\n\n"
. manual_download_instructions() unless @Extra;
$dir = shift @Extra;
print "Not in this directory, now chdir('$dir')...\n";
}
}
};
if ($@) {
undef $ftp;
warn "$@\nCan't fetch file with Net::FTP, now trying with LWP::UserAgent...\n";
# second try with LWP::UserAgent
eval { require LWP::UserAgent; require HTML::LinkExtor }
or die "You do not have LWP::UserAgent and/or HTML::LinkExtor installed, cannot download, exiting...\n\n" . manual_download_instructions();
my $c = 0;
my @Extra = @extra_chdir;
while (not $c) {
$ua = LWP::UserAgent->new;
$ua->env_proxy;
my $req = HTTP::Request->new(GET => $base_url);
my $resp = $ua->request($req);
$resp->is_success
or die "Can't fetch directory listing from $base_url: " . $resp->as_string;
%archive = ();
if ($resp->content_type eq 'text/html') {
my $p = HTML::LinkExtor->new;
$p->parse($resp->content);
for my $link ($p->links) {
my($tag, %attr) = @$link;
next if $tag ne 'a';
$c++ if $match_pari_archive->($attr{href});
}
} else {
foreach my $file (split /\n/, $resp->content) {
$c++ if $match_pari_archive->($file);
}
}
unless ($c) {
unless (@Extra) {
warn debug_no_response($resp)
. "Did not find any file matching /$match/ via FTP.\n\n";
my $f = ll_ftp or die manual_download_instructions();
return download_pari($f);
}
my $dir = shift @Extra;
$base_url .= "$dir/";
print "Not in this directory, trying `$base_url'...\n";
}
}
}
}
sub fmt_version {sprintf "%03d%03d%03d", split /\./, shift}
my ($type, %have, %types, $best, %latest_version, %latest_file);
for $type (qw(alpha beta golden)) {
if ($archive{$type}) {
$have{$type}++;
$best = $type;
my @files = keys %{$archive{$type}};
print "Available $type versions: `@files'\n";
$latest_version{$type} = (sort {fmt_version($a) cmp fmt_version($b)}
keys %{$archive{$type}})[-1];
$latest_file{$type} = $archive{$type}{$latest_version{$type}};
print qq(Latest supported $type is `$latest_file{$type}'\n);
}
}
# Special-case v2.0.14
if (!$archive{golden} and $latest_version{beta} eq '2.0.11'
and $latest_version{alpha} eq '2.0.14') {
$best = 'alpha'; # It is tested!
}
undef $dir;
my $version;
if ($best) {
my $file = $latest_file{$best};
$version = $latest_version{$best};
print qq(Picking $best version $version, file $file\n);
if (-f $file) {
print qq(Well, I already have it, using the disk copy...\n);
} else {
print qq(Downloading `$base_url$file'...\n);
if ($ftp) {
$ftp->get($file) or die "Cannot get via FTP (",$ftp->message(),"): $!";
$ftp->quit or warn "Warning: cannot quit FTP: ", $ftp->message();
} else {
my $req = HTTP::Request->new(GET => "$base_url$file");
my $resp = $ua->request($req);
$resp->is_success
or die "Can't fetch $base_url/$file: " . $resp->as_string;
my $base = basename($file);
open(F, ">$base") or die "Can't write to $base: $!";
binmode F or die "Can't binmode(): $!";
print F $resp->content;
close F;
}
print qq(Downloaded...\n);
}
print qq(Extracting...\n);
my $zcat = "gzip -dc"; # zcat may be the old .Z-extractor
print "$zcat $file | tar -xvf -\n";
system "$zcat $file | tar -xvf -"
and do {
print "Can't un-targz PARI: \$!=$!, exitcode=$?.\n";
my @cmd = ($^X, qw(-MArchive::Tar -wle),
'Archive::Tar->new(shift)->extract()', $file);
print ' Now retry with "', join('" "', @cmd), "\"\n";
system @cmd and die "Can't un-targz PARI: \$!=$!, exitcode=$?.\n"
};
($dir = $file) =~ s,(?:.*[\\/])?(.*)\.t(ar\.)?gz$,$1,
or die "malformed name `$file'";
-d $dir or die "Did not find directory $dir!";
}
return ($dir, $version);
}
=item C<patches_for($version)>
Returns patches appropriate for GP/PARI version $version (formatted as in C<2.2.2>).
=cut
sub patches_for ($) {
my ($v) = (shift);
my %patches = ('2.0.11'
=> [qw(
patch11/diff_pari_gnuplot_aa
patch11/patch_pari_round0
patch11/patches_round1_short
patch11/diff_pari_fixed_interfaces_011
patch11/diff_pari_highlevel_hash_011a
patch11/diff_pari_ret_proto_2011)],
'2.0.12' => ['patch12/diff_for_perl_2012'],
'2.0.13' => ['patch13/diff_for_perl_2013',
'patch13/diff_for_gnuplot_2013'],
'2.0.14' => ['patch14/diff_for_perl_2014',
'patch14/diff_extra_2014',
'patch14/diff_last_2014',
'patch14/diff_plot_2014'],
'2.0.15' => ['patch15/diff_cast_2015',
'patch15/diff_errout_2015',
'patch15/diff_gnuplot_2015',
'patch15/diff_proto_2015',
'patch15/diff_errpari_2015',
'patch15/diff_pari_gnuplot_2015'],
'2.0.16' => ['patch16/diff_gnuplot_2016'],
'2.1.2' => ['patches/diff_2.1.2_gccism'],
'2.1.3' => ['patches/diff_2.1.3_interface'],
'2.1.4' => ['patches/diff_2.1.4_interface'],
'2.1.5' => ['patches/diff_2.1.4_interface'],
'2.2.2' => ['patches/diff_2.2.2_interface'],
'2.1.6' => ['patches/diff_2.1.6_ploth64',
'patches/diff_2.1.6_align_power_of_2',
'patches/diff_2.1.6_no-common'],
'2.1.7' => [
($^O =~ /darwin/i ? 'patches/diff_2.1.6_no-common' : ()),
($^O eq 'MSWin32' ? 'patches/diff_2.1.7_mingw-w64' : ()),
'patches/patch-pari-unnormalized-float',
'patches/diff_2.1.7_-O',
'patches/diff_2.1.7_div',
'patches/diff_2.1.6_align_power_of_2',
'patches/diff_2.1.7_restart'],
'2.3.5' => [
($^O eq 'MSWin32' ? 'patches/diff_2.3.5_mingw-w64' : ())],
);
print "Looking for patches for $v...\n";
my @p = $patches{$v} ? @{$patches{$v}} : ();
push @p, 'patches/diff_pari-2.1.3-ix86-divl'
if $v le '2.1.3' or $v ge '2.2' and $v le '2.2.2';
@p;
}
=item C<patch_pari($dir [, $version])>
Applies known necessary fixes to GP/PARI build directory $dir if needed.
Returns empty if no patching is needed, otherwise the string encoding
return values of patch commands.
=cut
sub patch_args ($) {
return '/' unless $^O =~ /win32/i;
my($patch, $p) = (shift, 'utils/inc_h.diff');
$p =~ s,/,\\,g;
system "$patch -p1 --binary < $p"
or warn("... Apparently, your patch takes flag --binary...\n"),
return ('\\', '--binary');
return '\\';
}
sub patch_pari {
my ($dir, $version) = (shift, shift);
$version = get_pari_version($dir) unless defined $version;
my @patches = patches_for($version) or return;
print "Patching...\n";
my $patch = $Config{gnupatch} || 'patch';
my ($dir_sep, @args) = patch_args $patch;
my ($rc, $p) = join '; ', $dir_sep, @args, '';
foreach $p (@patches) {
(my $pp = "../$p") =~ s,/,$dir_sep,g;
my $cmd = "cd $dir && $patch -p1 @args < $pp";
print "$cmd\n";
system "$cmd"
and warn "...Could not patch: \$?=$?, $!; continuing anyway...\n";
$rc .= "'$pp' => $?, "
}
print "Finished patching...\n";
$rc =~ s/,?\s+$//;
$rc
}
=item download_and_patch_pari()
Using FTP connection, downloads the latest version of GP/PARI,
extracts it, and applies known necessary fixes if needed. Returns the
GP/PARI build directory (in scalar context), otherwise the directory
and the result of patching.
Same optional arguments as for download_pari().
=cut
sub download_and_patch_pari {
my ($file, $force, @rc) = (shift, shift);
my ($dir, $version) = download_pari($file, $force);
@rc = patch_pari($dir, $version) if defined $dir;
return $dir unless wantarray;
($dir, @rc);
}
=item C<make_pod($podfile, $gphelp_opt, $dir)>
Makes POD documentation for functions in the PARI library. Converts
the TeX file found in GP/PARI build directory $dir to POD using the
given options for F<gphelp>.
=cut
# We can't do what the commented chunk does: $paridir/doc/gphelp is
# auto-generated, so its date is not relevant to anything.
# $targ = 'libPARI/gphelp';
# if (not -e $targ
# or -M $targ > -M "$paridir/doc/gphelp") {
# if (-f $targ) {
# chmod 0666, $targ;
# unlink $targ;
# }
# copy "$paridir/doc/gphelp", $targ;
# }
sub make_pod {
my ($targ, $how, $paridir) = @_;
if (not -e $targ
or -M $targ > -M "$paridir/doc/usersch3.tex"
or -M $targ > -M "libPARI/gphelp") {
if (-f $targ) {
chmod 0666, $targ;
unlink $targ;
}
(system "$^X libPARI/gphelp $how $paridir/doc/usersch3.tex > tmp_pod "
and (warn("Errors when converting documentation: $?"), 0))
or rename 'tmp_pod', $targ;
}
}
sub scan_headers {
my $opts = shift;
warn "Scanning header files...\n";
my $cmd = "$Config{cpprun} $Config{cppflags} utils/inc.h 2>&1";
open INC, "$cmd |" or warn("Error $! from: $cmd\n"), return;
$opts->{clk_tck_def} = 1;
while (<INC>) {
$opts->{have_ulong} = 1, warn "...ulong\n" if /\btypedef\b.*\bulong\s*;/;
$opts->{clk_tck_def} = 0, warn "...CLK_TCK not defined\n"
if /y\s*=\s*CLK_TCK\b/;
$opts->{have_getrusage} = 1, warn "...getrusage\n" if /\bgetrusage\s*\(/;
$opts->{have_ladd} = 1, warn "...ladd\n" if /\bladd\b/;
}
close INC or warn "Note (probably harmless): Errors reading from pipe: '$!', exit=$?: $cmd\n"
}
=item C<build_tests($dir)>
Converts GP/PARI test files in GP/PARI build directory $dir to Perl test suite.
=cut
sub build_tests {
my $dir = shift;
my $paritests = "$dir/src/test/in";
opendir TESTS, $paritests
or die "Cannot find tests in $paritests: $!";
my @tests = readdir TESTS;
closedir TESTS or die "Cannot find tests (close): $!";
my $sou = 'test_eng/ex.t';
my $targ = "$sou-";
unless (-e $targ and -M $targ <= -M $sou) {
$dir =~ s/\\/\\\\\\\\/g;
my $quote = ($^O =~ /win32/i) ? '"' : "'";
system "$^X -pe $quote s,CHANGE_ME,$dir, $quote $sou > $targ"
and die "Could not run test converter: $! $?";
}
$sou = $targ;
my $test;
for $test (@tests) {
next if $test =~ /^\.\.?$/;
next if $test =~ /compat/;
next if -d "$paritests/$test" and $test eq 'CVS';
next if $test =~ /(~|\.(bak|orig|rej))$/;
$targ = "t/55_$test.t";
if (-f $targ) {
chmod 0666, $targ;
unlink $targ;
}
copy $sou, $targ or die "Cannot create test $test.t: $1";
}
}
=item C<find_paricfg($dir)>
Finds suitable (?) files F<paricfg.h> in GP/PARI build directory $dir.
=cut
sub find_paricfg {
my $paridir = shift;
my @paricfg = <$paridir/o.*/paricfg.h>;
push @paricfg, <$paridir/O*/paricfg.h>;
# Reported to work with Win32 too
@paricfg = grep !/Odos/, @paricfg unless $^O =~ /dos|djgcc|MSWin32/i;
# Probably not present in newer versions anymore...
unshift @paricfg, "$paridir/win32/paricfg.h"
if $^O eq 'MSWin32' and -f "$paridir/win32/paricfg.h";
@paricfg;
}
=item C<find_paricfg($dir, $do_configure)>
Finds suitable (?) files F<paricfg.h> in GP/PARI build directory $dir.
If $do_configure is true, runs GP/PARI's Configure script to build
one. Returns FALSE if F<paricfg.h> needs to be build by Perl.
=cut
sub find_or_Configure_paricfg {
my ($paridir, $do_configure) = (shift, shift);
my @paricfg = find_paricfg $paridir;
return 0 unless $do_configure;
if (@paricfg == 0) {
print "No existing paricfg.h found, running Configure...\n";
print "cd $paridir ; sh ./Configure\n";
system "cd $paridir ; sh ./Configure"
and die "Cannot configure: $!, exitcode=$?.\n";
print "Configuration of GP/PARI successful.\n";
@paricfg = find_paricfg $paridir;
}
if (@paricfg == 0) {
warn <<EOW;
Did not find paricfg.h. You may need to manually copy it to libPARI
directory from the GP/PARI build directory.
...Now switching to creation of paricfg.h by Perl code.
EOW
return 0;
}
my $found = $paricfg[0];
if (@paricfg > 1) {
warn "Found multiple paricfg.h: @paricfg.\n";
@paricfg = sort { -M $a <=> -M $b} @paricfg;
$found = $paricfg[0];
warn "Choosing newest paricfg.h: $found.\n";
}
if (-e 'libPARI/paricfg.h' and -M $found >= -M 'libPARI/paricfg.h') {
print <<EOP; # Duplication with build_paricfg()...
Existing libPARI/paricfg.h not older than $found.
...Will not overwrite libPARI/paricfg.h... (remove it manually if needed);
You may also want to remove libPARI/paricfg.h if you configuration changed
from the time of the first build in this directory...
EOP
} else {
print "Found $found, copying it to libPARI...\n";
copy $found, 'libPARI/paricfg.h'
or die "Could not copy $found to paricfg.h: $!"
if not -e 'libPARI/paricfg.h' or -M $found < -M 'libPARI/paricfg.h';
}
return 1;
}
=item write_paricfg($formatted_version)
Writes PARI configuration file F<libPARI/paricfg.h>. Returns hash
with options found during the scan of the header files.
=cut
sub write_paricfg {
my $version = shift;
my %opts;
scan_headers(\%opts) or $opts{clk_tck_def} = 0;
warn "Creating libPARI/paricfg.h...\n";
open F, '> libPARI/paricfg.h' or die "open 'libPARI/paricfg.h' for write: $!";
print F <<EOP unless $^O =~ /win32/i; # Should not we check for CygWin?
#define UNIX
EOP
my $shellq = ($^O eq 'os2' or $^O =~ /win32/i or $^O eq 'dos') ? q(") : q(');
my $datadir = '/usr/local/lib/pari/';
{ local %ENV;
delete $ENV{GP_DATA_DIR};
(my $o = `$^X -wle "print shift" "print(default(datadir))" | gp -q` || '')
=~ s,/?\n*$,,;
$datadir = "$o/" if length $o and -d $o;
}
# with 2.1.7, it is either in one of $miscdir/galdata $share_prefix/pari/galdata
my $miscdir = $datadir; # Not needed with 2.3.4
$datadir .= "galdata/" if $version < 2003000;
print F <<EOP;
#define SHELL_Q '\\$shellq'
EOP
print F <<EOP;
#define GPDATADIR "$datadir"
#define GPMISCDIR "$miscdir"
#define PARI_BYTE_ORDER $Config{byteorder}
#define NOEXP2 /* Otherwise elliptic.t:11 rounds differetly, and fails */
EOP
if ($opts{have_getrusage}) {
print F <<EOP if $Config{d_times};
#define USE_GETRUSAGE 1
EOP
} else {
print F <<EOP if $Config{d_times} and $^O !~ /win32/i; # times() missing there...
#define USE_TIMES 1
EOP
print F <<EOP if $Config{d_times} and $Config{i_time} and !$opts{clk_tck_def};
/* Reported to be needed on some Linuxes: */
#include <time.h>
EOP
print F <<EOP if not $Config{d_times} and $Config{d_ftime};
#define USE_FTIME 1
EOP
}
print F <<EOP if $Config{dlsrc} eq 'dl_dlopen.xs';
#define HAS_DLOPEN
EOP
print F <<EOP unless $opts{have_ulong};
#define ULONG_NOT_DEFINED
EOP
my $arch = find_machine_architecture();
my $bits64 = ($arch =~ /alpha|64/ # ppc is 32bit
or defined($Config{longsize}) and $Config{longsize} == 8);
print F <<EOP if $bits64;
#define LONG_IS_64BIT 1
EOP
if (!$bits64) {
# Order of words in a double
my @w = unpack 'LL', pack 'd', 2;
my $f = $w[1] ? 1 : 0;
die "Unknown double format" unless $w[$f] == (1<<30) and $w[1-$f] == 0;
print F <<EOP;
#define PARI_DOUBLE_FORMAT $f
EOP
}
print F <<EOP;
#define DL_DFLT_NAME NULL
EOP
print F <<EOP if $arch eq 'port';
#define __HAS_NO_ASM__
EOP
my @v = ($version =~ /^(\d+)(\d{3})(\d{3})$/)
or die "write_paricfg() needs a formatted version argument, got `$version'";
my $vvv = ((($v[0]) << 16) + (($v[1]) << 8) + ($v[2]));
print F <<EOP; # <=2.3.0 it was used only in gp.c, which we don't compile
#define PARI_VERSION_CODE $vvv
#define PARI_VERSION(a,b,c) (((a) << 16) + ((b) << 8) + (c))
#define PARI_VERSION_SHIFT 8
EOP
close F or die "close 'libPARI/paricfg.h' for write: $!";
%opts;
}
=item C<build_paricfg($dir, $do_configure)>
Builds F<libPARI/paricfg.h> either ourselves, or by looking for it in
GP/PARI build directory $dir - and running GP/PARI's Configure script
if needed. Returns hash with options found during the scan of the
header files.
=cut
sub build_paricfg { # $version as in 2003005 for 2.3.5
my ($paridir, $do_configure, $version) = (shift, shift, shift);
my %opts;
unless (find_or_Configure_paricfg($paridir, $do_configure)) {
# Not generated by Configure
if (-r 'libPARI/paricfg.h') {
print <<EOP unless $do_configure; # Duplication with find_or_Configure_paricfg()
...Will not overwrite libPARI/paricfg.h... (remove it manually if needed)
You may also want to remove libPARI/paricfg.h if your configuration changed
from the time of the first build in this directory...
EOP
} else {
print "...Generating libPARI/paricfg.h ...\n";
%opts = write_paricfg($version);
}
}
%opts;
}
# The following two functions are based on the logic in the PARI
# Configure script (updated to 2.3.0's config/arch-osname):
sub process_sparc {
my $info = shift;
# *SuperSparc*) arch=sparcv8_super;;
# *TMS390Z5[05]*) arch=sparcv8_super;; # SuperSparc I or II
# *MB86934*) arch=sparcv8_super;; # SparcLite
# *RT625*) arch=sparcv8_super;; # HyperSparc
# *CY605*) arch=sparcv8_super;;
return 'sparcv8_super' if $info =~ /SuperSparc|TMS390Z5[05]|CY605|MB86934|RT625/;
# *TMS390S1[05]*) arch=sparcv8_micro;; # MicroSparc I
# *MB86904*) arch=sparcv8_micro;; # MicroSparc II
# *MB86907*) arch=sparcv8_micro;; # TurboSparc
return 'sparcv8_micro' if $info =~ /TMS390S1[05]|MB8690[47]/;
return shift;
}
=item find_machine_architecture()
Returns the type of the processor of the current machine.
=cut
sub find_machine_architecture () {
my $os = (split ' ', $Config{myuname})[0];
my $machine = $os; # Handles fx2800
if ($os =~ /^irix/) {
$machine = 'irix';
} elsif ($os =~ /^hp/) {
$machine = `uname -m` || 'hppa';
if ($machine =~ m(^9000/[34])) {
$machine = 'm68k';
} elsif ($machine ne 'ia64') {
$machine = 'hppa';
}
} elsif ($os eq 'os2' or $os eq 'netbsd'
or $os eq 'freebsd' or $os =~ /^cygwin/) {
chomp($machine = `uname -m`);
$machine ||= 'ix86';
} elsif (($Config{archname} eq 'MSWin32-x86-multi-thread') && ($Config{cc} =~ /gcc/)) {
$machine = 'ix86';
} elsif (0 and $os =~ /win32/i and not $Config{gccversion}) {
# Not needed with rename of kernel1.s to kernel1.c?
$machine = 'port'; # Win32 compilers would not understand the assmebler anyway
} elsif ($os eq 'ultrix') {
$machine = 'mips';
} elsif ($os eq 'nextstep' or -d '/NextApps') {
chomp($machine = `file /bin/sh | sed 's/.*(for architecture \(.*\))/\1/'`);
} elsif ($os eq 'darwin') {
chomp($machine = `uname -p`);
$machine = 'ppc' if $machine eq 'powerpc';
} elsif ($os eq 'osf1') {
$machine = 'alpha' if (split ' ', $Config{myuname})[4] eq 'alpha';
} elsif ($os =~ /^cygwin/) {
$machine = $ENV{HOSTTYPE};
} elsif ($os eq 'linux') {
chomp($machine = `uname -m`);
$machine = 'sparcv9' if $machine eq 'sparc64';
$machine = 'hppa' if $machine =~ /^parisc/;
if ($machine eq 'sparc' and -e '/proc/cpuinfo' && -R '/proc/cpuinfo') {
open IN, '/proc/cpuinfo' or die "open /proc/cpuinfo: $!";
local $/ = undef; # Needed?
my $info = <IN>;
close IN or die "close /proc/cpuinfo: $!";
$machine = process_sparc $info, $machine;
}
} elsif ($os eq 'sunos') {
my $type = (split ' ', $Config{myuname})[4];
# format: SunOS name 5.9 Generic_118558-26 sun4u sparc SUNW,Ultra-5_10
# But Generic* part can be skipped???
$type = (split ' ', $Config{myuname})[3] if $type eq 'sparc';
my $redo;
find_machine: {
if ($type =~ /^sun3/) {
$machine = 'm68k';
} elsif ($type =~ /^sun4[dm]/) {
local $ENV{PATH} = "$ENV{PATH}:/dev/sbin";
my $info = `(prtconf||devinfo)2>&-`;
$info = join ' ', grep /(TI|FMI|Cypress|Ross),/, split "\n", $info;
$machine = process_sparc $info, 'sparcv8';
} elsif ($type eq 'sun4u') {
$machine = 'sparcv9';
} elsif ($type =~ /^sun4[ce]?$/) {
# $machine = 'sparcv7';
$machine = 'none'; # sparcv7 not available with 2.3.0
} elsif ($type =~ /^i.*pc$/) {
$machine = 'ix86';
} elsif ((split ' ', $Config{myuname})[3] eq 'sun') {
$machine = 'm86k';
} elsif ($redo++ == 0) {
$type = `uname -m`;
redo find_machine;
}
}
} elsif ($os eq 'gnu') {# Cover GNU/Hurd, GNU/kFreeBSD and other GNU userland
chomp($machine = `uname -m`);
$machine = 'ix86' if $machine =~ /^i\d86-/;
}
$machine = 'port' # No assembler for 64bit - unless alpha/ia64
if $machine !~ m(alpha|64) and ($Config{longsize} || 0) == 8;
print("I detect multi-arch build; assembler not supported on such builds.\n\n"),
$machine = 'port' # No assembler for repeated -arch (multi-arch build)
if $Config{ccflags} =~ /(^|\s)-arch\s.*\S\s+-arch\s/;
# For older PARI:
### $machine = 'sparcv8super'
### if $machine eq 'sparcv9' or $machine eq 'sparcv8_hyper'
### or $machine eq 'sparcv8_super';
### $machine = 'sparcv8micro' if $machine eq 'sparcv8_micro';
# This part is probably not needed and never entered
if (not defined $machine
and $Config{myuname}
=~ /\b(sun3|sparcv7|sparcv8_micro|sparcv8_super|alpha|hppa|[ix]\d86)\b/) {
$machine = $1;
} elsif (not defined $machine) {
chomp($machine = `uname -m`);
}
$machine =~ s/[ix]\d86(-\w+)?/ix86/ if defined $machine; # i686-pc
print "...Processor of family `$machine' detected\n";
return $machine;
}
sub not_gnu_as {
local $/;
my $ass = $ENV{AS} || 'as';
my $devnul = -e '/dev/null' ? '< /dev/null' : '';
open ASS, "$ass --version 2>&1 $devnul |";
my $assout;
eval {
local $SIG{ALRM} = sub {die};
eval {alarm 10}; # Be extra safe...
$assout = <ASS>;
close ASS;
unless ($assout) {
eval {alarm 10}; # Be extra safe...
open ASS, "$ass -v 2>&1 $devnul |";
$assout = <ASS>;
close ASS;
}
eval {alarm 0};
};
($assout and $assout =~ /GNU/) and return; # GNU
$assout or 1;
}
# Which files to catenate to produce pariinl.h. Apparently, the only
# need to go to asm0.h in pre-2.3 is to undo the effect of ASMINLINE in
# paricfg.h. Note that we do ASMINLINE from the command line.
# 2.3.0 does something like this:
# ../config/genkernel ../src/kernel/ix86/asm0.h > parilvl0.h
# cat ../src/kernel/none/tune.h ../src/kernel/none/int.h ../src/kernel/none/level1.h > parilvl1.h
# cat parilvl0.h parilvl1.h > pariinl.h
# This logic works with up to 2.2.13
sub sparcv8_inl {
my ($asmarch, $pari_version) = (shift, shift);
return ['none/asm0.h','none/level1.h']
if $Config{osname} =~ /^(linux|nextstep)$/;
return ['sparcv8/level0.h','none/level1.h'] if $pari_version < 2002006;
return ['sparcv8_micro/level0_common.h','sparcv8_micro/level0.h',
'none/level1.h'] if $asmarch eq 'sparcv8_micro';
return ['sparcv8_micro/level0_common.h','none/divll.h',
'none/level1.h'] if $asmarch eq 'sparcv8_super';
# No for sparcv8...
}
sub inline_headers_arr { # These files are cat()ed to pariinl.h
my ($asmarch, $pari_version) = (shift, shift);
return sparcv8_inl($asmarch, $pari_version) if $asmarch =~ /^sparcv8/;
my %h = (
alpha => ['none/asm0.h','none/level1.h'],
hppa => ['none/asm0.h','none/level1.h'],
ix86 => ['ix86/level0.h','none/level1.h'],
m86k => ['none/level0.h','none/level1.h'],
none => ['none/level0.h','none/level1.h'],
# ppc is not done yet (2.0.15)
($pari_version > 2002007
? (ppc => ['ppc/asm0.h', 'none/divll.h'],
x86_64 => ['x86_64/asm0.h','none/level1.h'],
ia64 => ['ia64/asm0.h','ia64/asm1.h'])
: ()),
sparcv7 => ['none/asm0.h','none/level1.h'],
# sparcv8 => $sparcv8_inl,
# sparcv8_micro => $sparcv8_inl,
# sparcv8_super => $sparcv8_inl,
# sparcv9 is not done yet (2.0.15)
);
$h{$asmarch};
}
sub inline_headers {
my ($asmarch, $pari_version) = (shift, shift);
my $inlines = inline_headers_arr($asmarch, $pari_version)
or die "Unknown inlines for '$asmarch'";
my @inlines = @$inlines;
if ($pari_version < 2003000) { # Old, explicit logic
unshift @inlines, 'none/int.h' if $pari_version >= 2002005;
unshift @inlines, 'none/tune.h' if $pari_version >= 2002008;
}
map "\$(PARI_DIR)/src/kernel/$_", @inlines;
}
sub generic_build_method {
my ($asmarch, $pari_version, $paridir) = (shift, shift, shift);
$pari_version >= 2003000
and (not -f "$paridir/src/kernel/$asmarch/MakeLVL1.SH"
or $asmarch eq 'none');
}
sub inline_headers_by_file { # logic of 2.3.0
my($dir,$f) = (shift, shift);
die "I expect to have $f present" unless -f $f;
#local $/ = "\n";
open F, "< $f" or die "Error opening `$f' for read: $!";
my @I = ([], [$f]); # INL, NOINL
while (<F>) {
next unless /^(NO)?ASM\s+(\S.*?)\s*$/;
# print "Found <$_>\n";
my $arr = $I[ $1 ? 1 : 0 ];
push @$arr, map "$dir/none/$_.h", split ' ', $2;
}
close F or die "Error closing `$f' for read: $!";
return @I;
}
sub inline_headers_by_dir { # logic of 2.3.0
my ($asmarch, $pari_version, $paridir) = (shift, shift, shift);
my $dir = "$paridir/src/kernel";
#$asmarch ='none' if $asmarch eq 'port';
unless (generic_build_method($asmarch, $pari_version, $paridir)) {
# die "Do not know how to process MakeLVL1.SH";
}
my @I = ([],[]);
@I = inline_headers_by_file $dir, "$dir/sparcv8_micro/asm0-common.h"
if $asmarch =~ /^sparcv8_/;
my @I1 = inline_headers_by_file $dir, "$dir/$asmarch/asm0.h";
for (0,1) {
push @{$I[$_]}, @{$I1[$_]};
}
push @{$I[1]}, map "$dir/none/$_.h", qw(tune int level1);
return @I;
}
sub inline_headers_pre {
my ($asmarch, $pari_version, $paridir) = (shift, shift, shift);
return if $pari_version < 2003000;
my $script = "$paridir/src/kernel/$asmarch/";
return;
}
sub inline_headers2 {
my ($asmarch, $pari_version, $paridir) = (@_);
return ([inline_headers_pre(@_)], [inline_headers(@_)])
if $pari_version < 2003000;
return inline_headers_by_dir(@_);
}
sub known_asmarch {
defined inline_headers_arr(@_);
}
sub choose_and_report_assembler {
my($machine, $pari_version) = (shift, shift);
my %asmarch = (
sun3 => 'm86k',
sparc => 'sparcv8_micro',
sparcv9 => 'sparcv8_micro',
port => 'none',
mips => 'none',
fx2800 => 'none',
ia64 => (($Config{longsize}||4) == 8 ? 'ia64' : 'none'),
hppa => ($Config{osvers} =~ /^.\.10\./
? 'hppa' : 'none'),
);
my $asmarch = $asmarch{$machine} || $machine; # Temporary only
my %skip64 = (alpha => 1, none => 1);
if (not ( $skip64{$asmarch} or $asmarch =~ /\D64$/ )
and ($Config{longsize} || 0) == 8) {
$asmarch .= '_64';
$asmarch = 'hppa64' if $asmarch eq 'hppa_64';
$asmarch = 'x86_64' if $asmarch eq 'ix86_64';
}
unless (known_asmarch $asmarch, $pari_version) {
warn <<EOW;
#### Do not know how to build for assembler `$asmarch'. ####
#### Reversing to assembler-less type `port'. ####
#### ####
#### If you think your processor's assembler is supported ####
#### by PARI, edit libPARI/Makefile.PL and report. ####
#### ####
#### Alternatively, specify machine=YOURTYPE or machine=none ####
#### on the ####
#### perl Makefile.PL ####
#### command line. ####
#### Recognized types: ####
#### alpha hppa m86k none sparcv7 sparcv8 sparcv8_micro ####
#### sparcv8_super ix86 (ppc ia64 after 2.2.7) ####
EOW
$machine = 'port';
$asmarch = 'none';
}
if ($asmarch eq 'none') {
print "...I will use portable assembler-less build\n";
} else {
print "...I will use assembler build of type '$asmarch'.\n";
}
print <<EOP if $asmarch =~ /^hppa/;
###
### Some time ago HPPA assembler files were not relocatable,
### if this is still true, they are probably unsuitable for dynamic linking.
### It is advisable to restart Makefile.PL with an extra argument
### machine=port
### if you are planning for dynamic linking of Math::Pari.
###
### NOTE: machine=port results in a significant drop in performance.
### For a static build (which makes a new perl executable with the library
### compiled in [and arranges for it to be compiled in when
### other extensions are statically built later]):
### perl Makefile.PL LINKTYPE=static
### make static
### make perl
### make test
### make install
###
EOP
return $asmarch;
}
# Output (last two optional):
# [Which file to compile, whether you need to preprocess it to ./kernel1.s,
# Additional file to compile, need? to preprocess it to ./kernel2.s,]
sub sparcv8_kernel_files_old {
my ($asmarch, $pari_version, $Using_gnu_as) = (shift, shift, shift);
my $_ext = (($pari_version < 2000015) ? 's' : 'S');
my $cvt = $Using_gnu_as || $Config{osname} =~ /^(linux|nextstep)$/;
my $sparcv8_kernel = ($cvt
? ["sparcv8/level0.$_ext", 1,
"sparcv8/level0_$asmarch.$_ext", 1]
: ["sparcv8/level0.$_ext", 0,
"sparcv8/level0_$asmarch.$_ext", 0]);
# kernel2.o is not needed if the compiler can inline assembler:
my $sparcv8_need_kernel2 =
!$Config{gccversion} || $Config{osname} =~ /^(linux|nextstep)$/;
$sparcv8_kernel = [$sparcv8_kernel->[2], $sparcv8_kernel->[3]]
unless $sparcv8_need_kernel2;
return $sparcv8_kernel;
}
sub sparcv7_kernel_files {
my ($asmarch, $pari_version, $Using_gnu_as) = (shift, shift, shift);
my $_ext = (($pari_version < 2000015) ? 's' : 'S');
my $cvt = $Using_gnu_as || $Config{osname} =~ /^(linux|nextstep|netbsd)$/;
return ["sparcv7/level0.$_ext", $cvt];
}
sub kernel_files {
my ($asmarch, $pari_version, $Using_gnu_as, $paridir) = (@_);
return [] if $pari_version >= 2003000;
return sparcv8_kernel_files_old($asmarch, $pari_version, $Using_gnu_as)
if $asmarch =~ /^sparcv8/ and $pari_version < 2002006;
return sparcv7_kernel_files($asmarch, $pari_version, $Using_gnu_as)
if $asmarch eq 'sparcv7';
my $sparcv8_kernel = ["sparcv8_micro/level0_common.S", 1,
"$asmarch/level0.S", 1]; # 2.2.* only
# Default ["$asmarch/level0.s", 0]
my %level0 = (
alpha => '',
hppa => '', # was ['none/level0.c', 0] before 2.0015
($pari_version > 2002007
? (ppc => ["none/level0.c", 0],
ia64 => ["ia64/level0.s", 0])
: ()),
ix86 => ['ix86/l0asm.c', 1],
m86k => ["none/level0.c", 0],
none => ["none/level0.c", 0],
# ppc is not done yet (2.0.15)
sun3 => '',
# sparcv7 => '',
# sparcv8 => $sparcv8_kernel,
sparcv8_micro => $sparcv8_kernel,
sparcv8_super => $sparcv8_kernel,
# sparcv9 is not done yet (2.0.15)
);
return $level0{$asmarch} || ["$asmarch/level0.s", 0];
}
sub kernel_fill_data {
my ($kernels, $hash) = (shift, shift);
# The original file
return unless @$kernels;
$hash->{file1} = "\$(PARI_DIR)/src/kernel/$kernels->[0]";
$hash->{convert1} = $kernels->[1];
# The (possibly) preprocessed file
$hash->{converted1} = $hash->{convert1} ? 'kernel1.s' : $hash->{file1};
# Extra bookkeeping
($hash->{header1} = $hash->{file1}) =~ s/\.c$/.h/;
$hash->{header1} = '' unless -r $hash->{header1}; # Put as a dependence
($hash->{dir1} = $hash->{file1}) =~ s/[^\/]*\.[csS]$//; # Include with -I
# Additional file to compile (original and converted)
$hash->{file2} = $hash->{converted2} = "\$(PARI_DIR)/src/kernel/$kernels->[2]" if $kernels->[2];
$hash->{file2} = $hash->{converted2} = '' unless $kernels->[2];
$hash->{converted2} = 'kernel2.s' if $kernels->[3];
$hash->{convert} = ($hash->{converted2} eq 'kernel2.s'
or $hash->{converted1} eq 'kernel1.s');
if ( $^O =~ /win32/i
and $Config{cc} =~ /\bcl/ # M$ VC doesn't understand .s
and $hash->{converted1} eq 'kernel1.s' ) {
$hash->{converted1} = 'kernel1.c';
}
}
sub assembler_flags_via {
my ($machine, $not_gnu_as) = (shift, shift);
my %assf = (
# alpha => "-O1", # Not supported any more
sparc => ($Config{osname} eq 'solaris'
? "-P -T -I."
: "-P -I."),
hppa => "+DA1.1",
);
my $assflags = $assf{$machine =~ /sun3|sparc/ ? 'sparc' : $machine} || '';
$assflags .= ' -D__GNUC__' # hiremainder problem with gcc on Solaris
if $not_gnu_as and $Config{gccversion};
# Tested with Sun WorkShop 6 update 2 Compiler Common 6.2 Solaris_9_CBE 2001/04/02:
$assflags .= ' -K PIC' # check assembler message for hints
# disable: leads to segfaults on Solaris
if 0 and $not_gnu_as and $Config{cccdlflags} =~ /(^|\s)-K\s*(pic|PIC)\b/
and $not_gnu_as =~ /(^|\W)-K\s+\{?(\w+,)PIC\b/; # in GNU as, default???
return $assflags;
}
sub assembler_flags { # Backward compatibility
my ($machine, $is_gnu_as) = (shift, shift);
assembler_flags_via($machine, not $is_gnu_as);
}
sub extra_includes {
my $pari_dir = shift;
# Some #include directives assume us inside $pari_dir/OARCH; replace by src
return join ' -I ', '', grep -d, "$pari_dir/src/systems/$^O", "$pari_dir/src";
}
sub build_funclists_ourselves ($) {
my $pari_dir = shift;
chdir "$pari_dir/src/desc"
or die "Can't chdir to `$pari_dir/src/desc'";
unless (-f 'pari.desc') {
my $t = 'tmp-pari.desc';
#warn "Running `$^X merge_822 ../functions/*/* > $t'...\n";
system "$^X merge_822 ../functions/*/* > $t"
and die "Can't run `$^X merge_822 ../functions/*/* > $t'";
rename $t, 'pari.desc' or die "rename failed: $t => 'pari.desc'";
}
my %recipies;
if (-f 'gen_help') { # pre-2.2.13
%recipies = ( 'language/members.h' => [[qw(gen_member)]],
'language/init.h' => [[qw(gen_proto basic)],
[qw(gen_help basic)]],
'gp/highlvl.h' => [[qw(gen_proto highlevel)],
[qw(gen_help highlevel)]],
'gp/gp_init.h' => [[qw(gen_proto gp)],
[qw(gen_help gp)]],
);
} else {
%recipies = ( 'language/members.h' => [[qw(gen_member)]],
'language/init.h' => [[qw(gen_proto basic)]],
'gp/highlvl.h' => [[qw(gen_proto highlevel)]],
'gp/gp_init.h' => [[qw(gen_proto gp)]],
);
}
for my $outfile (keys %recipies) {
next if -r "../$outfile";
my $append = '>';
for my $step (@{$recipies{$outfile}}) {
#warn "Running `$^X @$step pari.desc $append ../$outfile-tmp'...\n";
system "$^X @$step pari.desc $append ../$outfile-tmp"
and die "Can't run `$^X @$step pari.desc $append ../$outfile-tmp'";
$append = '>>';
}
rename "../$outfile-tmp", "../$outfile"
or die "rename failed: ../$outfile-tmp => ../$outfile";
}
1;
}
sub build_funclists {
my $pari_dir = shift;
return unless -d "$pari_dir/src/desc"; # Old version, no autogeneration
return if -f "$pari_dir/src/language/init.h"
and -f "$pari_dir/src/desc/pari.desc";
if (-f "$pari_dir/src/desc/Makefile") { # Old development version
# Keeps checksum to update when needed; fake it
open FL, "> $pari_dir/src/funclist" and close FL # Ignore errors
unless -f "$pari_dir/src/funclist";
(system("cd $pari_dir/src/desc && make")
and system("cd $pari_dir/src/desc && make SHELL=cmd")
or not -s "$pari_dir/src/desc/pari.desc") and
(unlink("$pari_dir/src/desc/pari.desc"),
die <<EOW);
###
### Apparently, we failed to build function descriptions of GP/PARI.
### Try editing $pari_dir/src/desc/Makefile - a typical reason
### is a wrong value of SHELL for your system. You can run make in
### $pari_dir/src/desc manually too...
EOW
} else {
require Cwd;
my $cwd = Cwd::cwd();
my $res = eval { build_funclists_ourselves $pari_dir };
chdir $cwd;
die <<EOD unless $res;
$@
###
### We do not know how to build function descriptions of GP/PARI.
### Please build them manually (e.g., by building GP/PARI).
###
EOD
}
}
=item ep_codes_from_file($filename,%hash,%names)
Adds to the %hash the string interface descriptions corresponding to
the numeric codes use in the file's entree array. %hash is indexed by
by the numeric codes; the value are references to arrays with the corresponding
string interface descriptions.
Adds to %names the list of name => code values.
=cut
sub ep_codes_from_file ($\%\%) {
my ($file, $descrh, $names) = (shift, shift, shift);
local $_;
open IN, "< $file" or warn "Cannot open `$file': $!" and return;
while (<IN>) {
next unless /^\s*{\s*\"/;
chomp;
warn("Unrecognized line: `$_'\n"), next
unless /^\s*\{\s*"(\w+)"\s*,\s*(\d+)\s*,[^,]*,\s*\d+\s*,(?:\s*\d+\s*,)?\s*("((?:\\.|[^"])*)"|NULL)\s*(,|\})/;
next unless defined $4;
#print;
my ($name, $code, $descr) = ($1, $2, $4);
$descrh->{$code} = [] unless exists $descrh->{$code};
push @{$descrh->{$code}}, $descr
unless grep $descr eq $_, @{$descrh->{$code}};
warn "! Duplicate code $code for function '$name' (was $names->{$name})\n"
if defined $names->{$name};
$names->{$name} = [$code, $descr];
}
close IN or warn "Cannot close `$file': $!";
}
=item ep_hash_report(%hash, %names, $fh)
Writes to $fh the diagnostic about problemes with the string interface
descriptions corresponding to the numeric codes. If $fh is false,
returns TRUE if no problem were found.
=cut
my $expected_codes_as_in = '2.1.3';
# Not in 2.1.3
my ($dummy1, %old_expected_codes) = split /\s+/, qq(
13 GD0,L,D0,G,
34 vLLL
);
my ($dummy2, %expected_codes) = split /\s+/, qq(
1 Gp
2 GG
3 GGG
4 GGGG
10 lG
11 L
12 GnP
14 GDn
16 ls
18 G
19 vLL
20 lGG
21 GL
22 GVI
23 GL
24 LG
25 GGD0,L,
26 GnG
27 V=GIp
28 GDVDI
29 GGp
30 lGGG
31 GDGDGD&
32 GGL
33 GGGD0,L,p
35 vLGG
37 V=GGIp
45 LGD0,L,
47 V=GGIDG
48 V=GGIDG
49 GGDVDVDI
57 vLs
59 vLGGGG
62 GD0,G,D0,G,D0,L,p
73 LV=GGIpD0,L,D0,L,
83 vV=GGI
84 vGVI
85 vS
86 vV=GGGI
87 vV=GID0,L,
91 GD0,L,DGp
96 GD0,L,DGp
);
# Some historic changes in interfaces we do not care about (E vs I)
my $t;
my %variations = map {($t = $expected_codes{$_}) =~ s/I/E/ ? ($_, $t) : ()}
keys %expected_codes;
my %known_unimplemented = (57 => 1, 62 => 1);
sub ep_hash_report (\%;\%$) {
my ($h, $names, $fh) = (shift, shift, shift);
my ($c, @list);
$names = {} unless defined $names;
my @keys = grep {$_ ne 0 and $_ ne 99} keys %$h;
if (@list = grep {not exists $h->{$_}} keys %expected_codes) {
return unless $fh;
print $fh <<EOP;
Cosmetic only: the following numeric interfaces are not used any more:
EOP
for $c (sort @list) {
print $fh <<EOP;
$c (was meaning "$expected_codes{$c}" in $expected_codes_as_in)
EOP
}
}
if (@list = grep {not exists $expected_codes{$_}} @keys) {
return unless $fh;
print $fh <<EOP;
Harmless: the following numeric interfaces are new:
EOP
for $c (sort @list) {
print $fh <<EOP;
$c meaning "@{$h->{$c}}"
EOP
my $list = join ", ", grep $names->{$_}[0] == $c, sort keys %$names;
print $fh <<EOP;
(appears for $list)
EOP
}
}
if (@list = grep @{$h->{$_}} != 1, @keys) {
return unless $fh;
print $fh <<EOP;
May be harmless: non-unique string interfaces for numeric interfaces:
EOP
for $c (sort @list) {
print $fh <<EOP;
$c meaning "@{$h->{$c}}"
EOP
my $list = join ", ", grep $names->{$_}[0] == $c, sort keys %$names;
print $fh <<EOP;
(appears for $list)
EOP
}
}
if (@list = grep {exists $expected_codes{$_}
and "@{$h->{$_}}" ne $expected_codes{$_}
and "@{$h->{$_}}" ne $variations{$_}
and not $known_unimplemented{$_}} @keys) {
return unless $fh;
print $fh <<EOP;
Possible problems with Math::Pari interface to GP/PARI:
unexpected value of string interfaces for numeric interfaces:
EOP
for $c (sort @list) {
print $fh <<EOP;
$c meaning "@{$h->{$c}}" (was meaning "$expected_codes{$c}" in $expected_codes_as_in)
EOP
my $list = join ", ",
grep {$names->{$_}[0] == $c and $names->{$_}[1] ne $expected_codes{$c}}
sort keys %$names;
print $fh <<EOP;
(may affect functions $list)
EOP
}
}
return 1;
}
=item ep_in_version($version)
Updates the list of codes for the given version of GP/PARI (formatted as in
2002002).
=cut
sub ep_in_version ($) {
my $v = shift;
if ($v >= 2002002) {
my $c;
for $c (qw(26 62)) {
delete $expected_codes{$c};
}
}
}
=item code_C_translator()
Returns string for C code to translate code string to the interface number.
Due to a bug in C_constant(), need to translate C<''> to 9900 by hand outside
of this subroutine.
=cut
sub code_C_translator {
# Some historic changes in interfaces we do not care about (E vs I)
my %c = (%old_expected_codes, %expected_codes);
my %codes;
@codes{values %c} = keys %c;
my $k;
for $k (keys %codes) {
(my $kk = $k) =~ s/I/E/g;
$codes{$kk} = $codes{$k} unless exists $codes{$kk};
($kk = $k) =~ s/D0,G,/DG/g; # New alternative syntax
$codes{$kk} = $codes{$k} unless exists $codes{$kk};
}
#$codes{''} = 9900; # bug in C_constant - can't handle
$codes{'p'} = 0;
require ExtUtils::Constant;
my @t = ExtUtils::Constant::constant_types(); # macro defs
my @tt =
ExtUtils::Constant::C_constant(
'Math::Pari::func_type',
'func_ord_by_type', undef, undef, undef, undef,
map {{name => $_, value => $codes{$_}, macro => 1}} keys %codes);
# 23 == 21 47==48 91 == 96 (this one unsupported)
join '', @t, @tt;
}
=back
=cut
1;