#! @PERL_PATH@
#Copyright (C) 2003-2013  The PARI group.
#
#This file is part of the GP2C package.
#
#PARI/GP is free software; you can redistribute it and/or modify it under the
#terms of the GNU General Public License as published by the Free Software
#Foundation. It is distributed in the hope that it will be useful, but WITHOUT
#ANY WARRANTY WHATSOEVER.
#
#Check the License for details. You should have received a copy of it, along
#with the package; see the file 'COPYING'. If not, write to the Free Software
#Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.

#This is the description compiler for gp2c.

BEGIN
{
  $pari_desc=shift @ARGV;
  $compat_desc=shift @ARGV;
  $override_desc=shift @ARGV;
  -f "@PARI_DATADIR@/PARI/822.pm" || exit 1;
  -f $pari_desc || exit 1;
}
use lib "@PARI_DATADIR@";
use PARI::822;

PARI::822::read(\%funcs,$override_desc,0) if defined($override_desc);
PARI::822::read(\%funcs,$pari_desc,0);
PARI::822::read(\%funcs,$compat_desc,0) if defined($compat_desc);

%accepted_class=(
''=>1, 'basic'=>1,
'gp'=>1,'highlevel'=>1,
'symbolic_operators'=>1,
'member_functions'=>1,
'gp2c'=>1,
'gp2c_internal'=>1);


%accepted_command=
(
 'add'=>1, 'sub'=>1, 'neg'=>1,
 'mul'=>1, 'div'=>1, 'mod'=>1,
 'and'=>1, 'or'=>1, 'xor'=>1, 'not'=>1,
 'parens'=>1, 'stdref'=>1,
 'value'=>1, 'type'=>1, 'nbarg'=>1,
 'str_format'=>1, 'str_raw'=>1,
 'cast'=>1, 'code'=>1, 'prec'=>1, 'bitprec'=>1,
 'format_string'=>1,'format_args'=>1,
 'cookie' => 1, 'wrapper' => 1
);

sub check_cname
{
  my ($gpname, $cname) = @_;
  while($cname =~ /\$\{([^}]*)\}(.*)/)
  {
    my ($rpl) = $1;
    $cname = $2;
    for (split(' ', $rpl))
    {
      /^-?[0-9]+$/ and next;
      /^:[a-z_A-Z]+$/ and next;
      defined($accepted_command{$_}) and next;
      print STDERR "Warning: $gpname unsupported command $_, skipped\n";
      return 0;
    }
  }
  return 1;
}

for $gpname (sort keys %funcs)
{
  my $f=$funcs{$gpname};
  next unless (defined($accepted_class{$f->{'Class'}}));
  my $description=$f->{'Description'};
  my $proto=$f->{'Prototype'};
  my $wrapper=$f->{'Wrapper'};
  my $iterator=$f->{'Iterator'};
  print "$gpname\n";
  my @entry=();
  if (defined($description))
  {
    my @rules = split("\n",$description);
    @rules = grep { $_ !~ /^[ \n\t]*$/ } @rules;
    my @erules = ();
    push @erules, join("\n",0,scalar(@rules));
    foreach (@rules)
    {
      /^[ \n\t]*
        \(([^)]*)\)
        (?::([A-Za-z0-9_:]*))?
        [ \n\t]*
        ([^\n]*)
        [ \n\t]*$/x or die "badly formatted description $_";
      my $arglist=$1;
      my $cname=$3;
      my $typelist=$2;
      $arglist =~ tr/ \n\t//d;
      my @args=split(',',$arglist,-1);
      my @type=split(':',$typelist,-1);

      $cname =~ s/\$%([0-9]+)/\${$1 str_format}/g;
      $cname =~ s/\$#/\${nbarg}/g;

      $cname =~ s/\$\(([0-9]+)\)/\${parens $1 code}/g;
      $cname =~ s/\$([0-9]+)/\${$1 code}/g;

      $cname =~ s/\$([a-z_A-Z]+):([0-9]+)/\${$2 :$1 cast}/g;

      $cname =~ s/\$\(([a-z_A-Z]+):([0-9]+)\)/\${parens $2 :$1 cast}/g;

      $cname =~ s/\$prec\b/\${prec}/g;
      $cname =~ s/\$bitprec\b/\${bitprec}/g;

      check_cname($gpname,$cname) or next;
      push @erules, join("\n",$cname,scalar(@args),@args,scalar(@type),@type);
    }
    push @entry, join("\n",@erules);
  }
  if (defined($proto))
  {
    $type="gen";
    $type="void" if ($proto =~ /^v/);
    $type="small" if ($proto =~ /^l/);
    $type="small_int" if ($proto =~ /^i/);
    $type="usmall" if ($proto =~ /^u/);
    @type=($type);
    push @type,"copy" if ($proto =~ /^m/);
    push @type,"prec" if ($proto =~ /[pb]/);
    $proto =~ s/^[uilmv]//;
    $proto =~ s/\\n.*$//;
    push @entry, join("\n",1,$f->{'C-Name'},$proto,scalar(@type),@type);
  }
  if (defined($wrapper))
  {
    $wrapper =~ tr/ \n\t//d;
    $wrapper =~ m/^\(([^)]*)\)/ or die "badly formatted wrapper $wrapper";
    my $wraplist=$1;
    my @wrap=map { ($_ eq "" || $_ eq "_") ? "$_":"_wrap_$_"; } split(',',$wraplist,-1);
    push @entry, join("\n",2,scalar(@wrap),@wrap);
  }
  if (defined($iterator))
  {
    my @rules = split("\n",$iterator);
    @rules = grep { $_ !~ /^[ \n\t]*$/ } @rules;
    my @erules = ();
    push @erules, join("\n",3,scalar(@rules));
    foreach (@rules)
    {
      /^[ \n\t]*
        \(([^)]*)\)
        (?::([A-Za-z0-9_:]*))?
        [ \n\t]*
        \(([^\n]*)\)
        [ \n\t]*$/x or die "badly formatted iterator $_";
      my $arglist=$1;
      my $iterlist=$3;
      my $typelist=$2;
      $arglist =~ tr/ \n\t//d;
      $iterlist =~ tr/ \n\t//d;
      my @args=split(',',$arglist,-1);
      my @type=split(':',$typelist,-1);
      my @iter=split(',',$iterlist,-1);
      push @erules, join("\n",scalar(@iter),@iter, scalar(@args),@args,
                                                   scalar(@type),@type);
    }
    push @entry, join("\n",@erules);
  }
  print scalar(@entry),"\n";
  print join("\n",@entry)."\n" if (@entry);
}