#!/usr/bin/perl -w
use strict;
use Config;

my ($miss) = ( ($ARGV[0] || '') =~ /^--miss=(.*)/ );
my %miss = map +($_, 1), split /,/, ($miss || '');
$miss{sinl} ||= $miss{logl};	# OpenBSD has sinl(), but not most of others

my $has_sinl = !$miss{sinl} || 0;
# trunc() and rint() are not in C90.  (So far no complaints about rint()...)
my @trunc_rint = map +($miss{$_} ? () : $_), qw(trunc rint);

open OUT_ASS,   '> driver_ass.h'  or die;
open OUT_0ARG,  '> driver_0arg.h' or die;

open OUT_1ARG,  '> driver_1arg.h' or die;
open OUT_1ARGA, '> driver_1argA.h' or die;
open OUT_1ARGB, '> driver_1argB.h' or die;
open OUT_1ARGC, '> driver_1argC.h' or die;

open OUT_2ARG,  '> driver_2arg.h' or die;
open OUT_2ARGA, '> driver_2argA.h' or die;
open OUT_2ARGB, '> driver_2argB.h' or die;
open OUT_2ARGC, '> driver_2argC.h' or die;
open OUT_2ARGD, '> driver_2argD.h' or die;
open OUT_2ARGE, '> driver_2argE.h' or die;
open OUT_2ARGF, '> driver_2argF.h' or die;

open OUT_2ARG_T, '> table_1arg_2targs.h' or die;

my @_letters = ('', 'A' .. 'Z');
my(@list_ass, @list_0arg, @list_2arg, @list_1arg_2targs, $name);
my ($out_1arg_i, $out_2arg_i, $j, $out_2targ, @out_1arg, @out_2arg) = (0, 0, 0);
push @out_1arg,
 { fh => $_, sym => [], ary => 1,
   tname => "_1arg", name => "_1arg$_letters[$j++]"}
  for (\*OUT_1ARG, \*OUT_1ARGA, \*OUT_1ARGB, \*OUT_1ARGC);
$j=0;
push @out_2arg,
 { fh => $_, sym => [], ary => 2,
   tname => "_2arg", name => "_2arg$_letters[$j++]"}
  for (\*OUT_2ARG, \*OUT_2ARGA, \*OUT_2ARGB, \*OUT_2ARGC, \*OUT_2ARGD, \*OUT_2ARGE, \*OUT_2ARGF);

print $_ <<EOP

    /* !!!!! Autogenerated file !!!!!  Any change will be lost !!!!! */

EOP
  for (\*OUT_ASS, \*OUT_0ARG, \*OUT_2ARG_T, map $_->{fh}, @out_1arg, @out_2arg);

print OUT_0ARG "const int has_sinl = $has_sinl;\n\n";

my %type = (		# XXX Add long flavors later...
		c => 'signed char',
		C => 'unsigned char',
		s => 'signed short',
		S => 'unsigned short',
		i => 'signed int',
		I => 'unsigned int',
		l => 'signed long',
		L => 'unsigned long',
		f => 'float',
		d => 'double',
	);

$type{D} = 'long double' if $Config{d_longdbl};
# XXXX Could do also with d_longlong, but need to define Quad_t ourselves...
$type{'q'} = 'Quad_t', $type{Q} = 'Uquad_t' if $Config{d_quad};

# The generated C file takes ages to compile; reduce duplicates...
my %size = (qw(c 1 s), $Config{shortsize}, i => $Config{intsize},
	l => $Config{longsize}, q => $Config{longlongsize},
	d => $Config{doublesize}, D => $Config{longdblsize},
	f => length pack 'f', 0);
my($prevs, $prev, %dups, %dups_lc) = 0;
my(@first, @dups, %ss, %first_ind, %next_lc);

for my $t (grep $type{$_}, qw(c s i l q)) {
  my $ss = $ss{$t} = $size{$t} || ($prevs+1);  # Some Config stuff undefined???
  push(@dups, $t), $dups{$t} = $prev, next if $ss <= $prevs;
  push @first, $t;
  $first_ind{$t} = @first;
  $prev = $t;
  $prevs = $ss;
}
for my $ind (0 .. ($#first - 1)) {
  $next_lc{lc $first[$ind]} = $next_lc{uc $first[$ind]} = lc $first[$ind+1];
}
$dups{uc $_} = uc $dups{$_} for keys %dups;
$ss{uc $_} = $ss{$_} for keys %ss;
my @first_uc = map uc, @first;

($prevs, $prev) = 0;
for my $t (grep $type{$_}, qw(f d D)) {	# On MSWin32: longdblsize=8 ???
  my $ss = $ss{$t} = $size{$t} || ($prevs+1);  # Some Config stuff undefined???
  push(@dups, $t), $dups{$t} = $prev, next if $ss == $prevs;
  push @first, $t;
  $first_ind{$t} = @first;
  $prev = $t;
  $prevs = $ss;
}
# warn "Dups: @dups{keys %dups}";
delete $type{$_} for keys %dups;

#my @dup = sort {} keys %dups;

my $dups_s = join '', map "$_$dups{$_}", keys %dups;
my $sizeof = join ', ', map "sizeof($type{$_})", @first, @first_uc;
my $types_str = join '', @first, @first_uc;

print OUT_0ARG <<EOP;
#define RET_0__(a)	(0)
#define RET_1__(a)	(1)
#define RET_2__(a)	(2)
#define RET_m1__(a)	(-1)

const char duplicate_types_s[] = "$dups_s";
const char name_by_t[]         = "$types_str";
const unsigned char size_by_t[]      = {  $sizeof, 0 };

EOP

#sub protect_q ($) {my $t = shift; $t =~ /q/i ? ('#ifdef HAVE_QUAD', "#endif") : ('' '')}
#my($protect_q, $unprotect_q) = ('','');

my @use_types = grep $type{$_}, split //, 'cCsSiIlLfdDqQ';	# A particular order

# accessors
for my $t (@use_types) {
  my $create = ($t =~ /[fdDqQ]/) ? 'newSVnv' 
    : (($t =~ /[CSIL]/) ? 'newSVuv' : 'newSViv');

  $name = "a_accessor__$t";
  push @list_ass, [$name, $t];
  print OUT_ASS <<EOP;
#define TARG_ELT_TYPE		$type{$t}
#define THIS_OP_NAME		$name
#define newSV_how		$create
#include "code_accessor.h"
#undef  newSV_how
#undef  TARG_ELT_TYPE
#undef  THIS_OP_NAME

EOP
}

# do 1-arg calls inplace, and, for floating-point, with source

for my $c (['!', 'negate'], ['-', 'flip_sign'], ['~', 'bit_complement'],
	   map(["RET_${_}__", $_], qw(0 1 2 m1)), ['my_ne0', 'ne0'],
	   map([$_, $_, 0], qw(log log10 sqrt abs cbrt)), # Allow int args
	   map([$_, $_, 1], qw(cos sin tan acos asin atan exp ceil floor), @trunc_rint),) {
  my @allowed_types = @use_types;
  @allowed_types = grep !/[fdD]/, @allowed_types if $c->[0] eq '~';
  @allowed_types = grep /[fdD]/, @allowed_types if $c->[2];
  @allowed_types = grep !/D/, @allowed_types if defined $c->[2] and $miss{sinl};
  my (%c_suff, %c_pref, %do_conv);
  @c_pref{@allowed_types} = @c_suff{@allowed_types} = @do_conv{@allowed_types}
    = ('') x @allowed_types;
  $c_suff{D} = 'l' if defined $c->[2];
  $c_suff{D} and "$c->[0]$c_suff{D}" eq 'cbrtl' and $c_pref{D} = 'my_';
  $c->[0] eq 'abs' and $c_pref{$_} = 'f' for qw(f d D);
  $c->[0] eq 'abs' and $c_pref{$_} = 'l' for qw(l);
  $c->[0] eq 'abs' and $c_pref{$_} = 'my_ll' for qw(q);
  $c->[0] eq 'abs' and $c_pref{$_} = 'my_u' for qw(C S I L Q);
  $do_conv{Q} = 'uquad2double' if $miss{uquad2double} and defined $c->[2];
  $name = "${_}0_$c->[1]", push(@list_0arg, [$name, $_]),
    print OUT_0ARG <<EOP for @allowed_types;
#define TARG_ELT_TYPE		$type{$_}
#define DO_0OP(targ)		(targ) = $c_pref{$_}$c->[0]$c_suff{$_}($do_conv{$_}(targ))
#define THIS_OP_NAME		$name
#include "code_0arg.h"
#undef  TARG_ELT_TYPE
#undef  DO_0OP
#undef  THIS_OP_NAME

EOP
  next unless $c->[2];

  $name = "${_}2${_}1_$c->[1]", push(@{$out_1arg[$out_1arg_i]{sym}}, [$name, $_, $_]),
    print {$out_1arg[$out_1arg_i]{fh}} <<EOP for @allowed_types;
#define SOURCE_ELT_TYPE		$type{$_}
#define TARG_ELT_TYPE		$type{$_}
#define DO_1OP(targ,source)	(targ) = $c_pref{$_}$c->[0]$c_suff{$_}($do_conv{$_}(source))
#define THIS_OP_NAME		$name
#include "code_1arg.h"
#undef  SOURCE_ELT_TYPE
#undef  TARG_ELT_TYPE
#undef  DO_1OP
#undef  THIS_OP_NAME

EOP
}

# C modifiers (as 0-arg)
for my $c (['++', 'incr'], ['--', 'decr']) {
  $name = "${_}0_$c->[1]", push(@list_0arg, [$name, $_]),
    print OUT_0ARG <<EOP for @use_types;
#define TARG_ELT_TYPE		$type{$_}
#define DO_0OP(targ)		$c->[0](targ)
#define THIS_OP_NAME		$name
#include "code_0arg.h"
#undef  TARG_ELT_TYPE
#undef  DO_0OP
#undef  THIS_OP_NAME

EOP
}

### $out_1arg_i++;
# conversion calls (1-arg)
for my $s (@use_types) {
  for my $t (@use_types) {
    my $mid_convert = '';
    $mid_convert = '(int)' if "$s$t" =~ /[cs][fdD]|[fdD][cs]/; # Needed?
    $mid_convert = '(unsigned int)' if "$s$t" =~ /[CS][fdD]|[fdD][CS]/; # Needed?
    $mid_convert = 'uquad2double'
      if $miss{uquad2double} and "$s$t" =~ /Q[fdD]/; # d==D when {uquad2double}
    $name = "${s}2${t}1_assign", push(@{$out_1arg[$out_1arg_i]{sym}}, [$name, $t, $s]),
      print {$out_1arg[$out_1arg_i]{fh}} <<EOP;
#define SOURCE_ELT_TYPE		$type{$s}
#define TARG_ELT_TYPE		$type{$t}
#define DO_1OP(targ,source)	(targ) = (TARG_ELT_TYPE)($mid_convert(source))
#define THIS_OP_NAME		$name
#include "code_1arg.h"
#undef  SOURCE_ELT_TYPE
#undef  TARG_ELT_TYPE
#undef  DO_1OP
#undef  THIS_OP_NAME

EOP
  }
}

my %fp_vars = qw( << ldexp >> ldexp_neg );

### $out_1arg_i++;
# other 1-arg calls (with possible source and target types)
for my $c (['!', 'negate'], ['-', 'flip_sign'], ['~', 'bit_complement'],
	   ['my_ne0', 'ne0'], ['<<=', 'lshift_assign'],
	   '---',
	   map([$_, $_, 0], qw(log log10 sqrt abs cbrt)), # Allow int args
	   '---',
	   ['+=', 'plus_assign'], ['-=', 'minus_assign'],
	   ['*=', 'mult_assign'], ['/=', 'div_assign'],
	   ['|=', 'bitor_assign'], ['&=', 'bitand_assign'], ['^=', 'bitxor_assign'],
	   '---',
	   map([$_, $_, 1], qw(ceil floor), @trunc_rint),
	   ['%=', 'remainder_assign'], ['pow((targ), ', 'pow_assign'],
	   ['self_assign_min((targ), ', 'min_assign'],
	   ['self_assign_max((targ), ', 'max_assign'],
	   ['>>=', 'rshift_assign']) {
  $out_1arg_i++, next if $c eq '---';
  die "too many parts in the 1arg list" if $out_1arg_i >=  @out_1arg;
  my @allowed_types = @use_types;
  @allowed_types = grep !/[fdD]/, @allowed_types if $c->[0] =~ /[~%|&^]/;
  @allowed_types = grep !/D/, @allowed_types
    if $miss{sinl} and ($c->[0] =~ /^(pow|<<|>>)/ or defined $c->[2]);
  my (%c_suff, %c_pref, %do_conv);
  @c_pref{@allowed_types} = @c_suff{@allowed_types} = @do_conv{@allowed_types}
    = ('') x @allowed_types;
  $c_suff{D} = 'l' if defined $c->[2];
  $c_suff{D} and "$c->[0]$c_suff{D}" eq 'cbrtl' and $c_pref{D} = 'my_';
  $c->[0] eq 'abs' and $c_pref{$_} = 'f' for qw(f d D);
  $c->[0] eq 'abs' and $c_pref{$_} = 'l' for qw(l);
  $c->[0] eq 'abs' and $c_pref{$_} = 'my_ll' for qw(q);
  $c->[0] eq 'abs' and $c_pref{$_} = 'my_u' for qw(C S I L Q);
  $do_conv{Q} = 'uquad2double' if $miss{uquad2double} and defined $c->[2];
  for my $s (@allowed_types) {
    next if $s =~ /[fdD]/ and $c->[0] =~ /<<|>>/;
    for my $t (@allowed_types) {
      next if $c->[2] and ($s eq $t or $s !~ /[fdD]/);	# $s==$t: done earlier
      next if $miss{uquad2double} and "$s$t" =~ /[fdD]Q|Q[fdD]/
	and not defined $c->[2]; # XXXX tricky
      (my $_c = my $ccc = $c->[0]) =~ s/=//;
      $ccc = "$fp_vars{$_c}((targ), " if $fp_vars{$_c} and "$s$t" =~ /[fdD]/;
      $ccc =~ s/^(pow|ldexp(_neg)?)/${1}l/ if "$s$t" =~ /D/;
      my $eq = ($ccc =~ s/=$/= / or $ccc =~ /^self/) ? '' : '=';
      my $trailer = ($ccc =~ /\(/) ? ')' : '';
      $ccc =~ s/^(self_\w+)/$1_su/ if "$t$s" =~ /^[csilq][CSILQ]$/;
      $ccc =~ s/^(self_\w+)/$1_us/ if "$t$s" =~ /^[CSILQ][csilq]$/;
      $name = "${s}2${t}1_$c->[1]";
      push(@{$out_1arg[$out_1arg_i]{sym}}, [$name, $t, $s]);
      my $targ = ($ccc =~ /^self/) ? '' : '(targ)';
      print {$out_1arg[$out_1arg_i]{fh}} <<EOP;
#define SOURCE_ELT_TYPE		$type{$s}
#define TARG_ELT_TYPE		$type{$t}
#define DO_1OP(targ,source)	$targ $eq $c_pref{$s}$ccc$c_suff{$s}($do_conv{$s}(source))$trailer
#define THIS_OP_NAME		$name
#include "code_1arg.h"
#undef  SOURCE_ELT_TYPE
#undef  TARG_ELT_TYPE
#undef  DO_1OP
#undef  THIS_OP_NAME

EOP
    }
  }
}

my(@commutative, %commutative) = qw(+ * == != my_eq my_ne);
@commutative{@commutative} = @commutative;
my %t2_type = (qw( frexp int modf double modfl), 'long double');

# 2-arg calls (with possible source and target types)
for my $c (['+', 'plus'], ['-', 'minus'],
	   ['|', 'bitor'], ['&', 'bitand'], ['assign_max', 'max'],
	   '---',	# Break into parts; try to equalize # of functions
	   ['*', 'mult'], ['assign_min', 'min'],
	   '---',
	   ['*', 'sproduct'], ['%', 'remainder'], ['^', 'bitxor'], ['>>', 'rshift'],
	   '---',		# modf AND frexp must be in the same section!
	   ['modf', 'modf', 1], ['frexp', 'frexp', 1],
	   ['<<', 'lshift'],
	   '---',
	   (map ["my_$_", $_], qw( eq ne )),
	   '---',
	   (map ["my_$_", $_], qw( lt )), ['pow', 'pow'],
	   '---',
	   (map ["my_$_", $_], qw( le )), ['/', 'div'],
	   # ['<', 'lt'], ['<=', 'le'], ['==', 'eq'], ['!=', 'ne'],
     ) {
  $out_2arg_i++, next if $c eq '---';
  die "too many parts in the 2arg list" if $out_2arg_i >=  @out_2arg;
  my @allowed_types = @use_types;
  @allowed_types = grep !/[fdD]/, @allowed_types if $c->[0] =~ /[~%|&^]/;
  @allowed_types = grep !/D/, @allowed_types if $miss{sinl} and $c->[0] =~ /^(pow|<<|>>)/;
  for my $s1 (@allowed_types) {
    for my $s2 (@allowed_types) {
      next if ($ss{$s1} > $ss{$s2}
	       or $ss{$s1} == $ss{$s2} and "$s1$s2" =~ /[CSILQ][csilq]/)
	and $commutative{$c->[0]};
      next if $s2 =~ /[fdD]/ and $c->[0] =~ /<<|>>/;
      my %t;  $t{$s1}++; $t{$s2}++;	# Output types to support
      my %cast_needed;			# Need to cast sources before the op?
      if ($c->[0] eq '*') {		# Wider output for mult/sproduct
	if ("$s1$s2" =~ /[fdD]/) {	# Add wider floating types
	  $t{$_}++, $cast_needed{$_}++
	    for grep $type{$_} && $ss{$_} > $ss{$s2}, qw(f d D);
	} else {
	  $t{$_}++, $cast_needed{$_} = ($ss{$_} > $ss{$s2} ? 1 : 222)
	    for grep $type{$_}, qw(f d D);	# add floating types
	  $ss{$_} > $ss{$s2} and $t{$_}++, $cast_needed{$_}++
	    for grep $type{$_}, qw(s S l L i I q Q);
	  # Add unsigned variant of wider type (one of $s2):
	  $cast_needed{uc $s2}++ unless $t{uc $s2}++;
        } # if equal sizes & different types, $s2 = uc $s1 already added
      }
      if ($c->[0] eq '<<') {	# Same for lshift
	unless ("$s1$s2" =~ /[fdD]/) {	# Add wider floating types
	  $ss{$_} > $ss{$s2} and $t{$_}++, $cast_needed{$_}++
	    for grep $type{$_}, qw(C S L I Q);
        } # if equal sizes & different types, $s2 = uc $s1 already added
      }
      if ($c->[0] =~ /^my_/) {	# Any-signed-int output for comparisons
	$t{$_}++ for grep $type{$_}, qw(c s i l q);
        delete $t{$_} for qw(C S I L Q);
      }				# Increases the DLL size 1.5 times???
      my $next = $next_lc{$s2};
      $next = uc($next || '') unless "$s1$s2" !~ /[A-Z]/;
      for my $t (keys %t) {
	next if $miss{uquad2double} and "$s1$s2$t" =~ /[fdD].*Q|Q.*[fdD]/
	  and not $c->[2];	# XXXX tricky
        my ($mid, $pre, $OP) = ($c->[0], '');
	($mid, $pre) = (',', $mid) if $mid =~ /^\w+$/;
	($mid, $pre) = (',', $fp_vars{$mid})
	  if $fp_vars{$mid} and "$s1$t" =~ /[fdD]/;
        $pre =~ s/^(pow|ldexp(_neg)?)/${1}l/   if "$s1$s2$t" =~ /D/;
	$pre =~ s/^((my|assign)_\w+)/$1_su/ if "$s1$s2" =~ /^[csilq][CSILQ]$/;
	$pre =~ s/^((my|assign)_\w+)/$1_us/ if "$s1$s2" =~ /^[CSILQ][csilq]$/;
	my $preassign = ($c->[1] eq 'sproduct') ? '+' : '';
	my ($s2_const, $targ2_type) = ('', '#undef DO_2OP_t');
	if ($t2_type{$pre}) {
	  $targ2_type = "#define DO_2OP_t $t2_type{$pre}";
	} else {
	  $s2_const = 'const';
	}
	my $cast = $cast_needed{$t} ? '(TARG_ELT_TYPE)' : '';
	$cast = "($type{$next})" if 222 == ($cast_needed{$t} || 0) and $next;
	my ($cast1, $cast2) = ($cast, $cast);
	$cast1 .= 'uquad2double' if $miss{uquad2double} and $c->[2] and $s1 eq 'Q';
	$name = "${s1}${s2}2${t}2_$c->[1]";
	push(@{ $t2_type{$pre} ? ($out_2targ = $out_2arg_i, \@list_1arg_2targs)
			       : $out_2arg[$out_2arg_i]{sym} },
	     [$name, $t, $s1, $s2]);
	$OP = "(targ) $preassign= $pre($cast1 (s1) $mid $cast2 (s2))";
	$OP = "$pre((s1), (s2), (targ))" if $pre =~ /^assign/;
	print {$out_2arg[$out_2arg_i]{fh}} <<EOP;
#define SOURCE1_ELT_TYPE	$type{$s1}
#define SOURCE2_ELT_TYPE	$type{$s2}
#define TARG_ELT_TYPE		$type{$t}
$targ2_type
#define S2_CONST		$s2_const
#define DO_2OP(targ,s1,s2)	$OP
#define THIS_OP_NAME		${s1}${s2}2${t}2_$c->[1]
#include "code_2arg.h"
#undef  SOURCE1_ELT_TYPE
#undef  SOURCE2_ELT_TYPE
#undef  TARG_ELT_TYPE
#undef  DO_2OP_t
#undef  S2_CONST
#undef  DO_2OP
#undef  THIS_OP_NAME

EOP
      }
    }
  }
}

my @list_t = ({name => '_ass',  sym => \@list_ass,  ary => 0, fh => \*OUT_ASS},
	      {name => '_0arg', sym => \@list_0arg, ary => 0, fh => \*OUT_0ARG},
#	      {name => '_1arg', sym => \@list_1arg, ary => 1, fh => \*OUT_1ARG},
	      @out_1arg, @out_2arg,
	      {name => '_1arg_2targs', sym => \@list_1arg_2targs, ary => 2, fh => \*OUT_2ARG_T},
#	      {name => '_2arg', sym => \@list_2arg, ary => 2, fh => \*OUT_2ARG}
  );
for my $file (@list_t) {
  $file->{tname} ||= $file->{name};
  print {$file->{fh}} <<EOP;
const f$file->{tname}_descr f$file->{name}_names[] = {
	{ "\\0\\0\\0\\0", (f$file->{tname}_p)&croak_on_invalid_entry},
EOP

  for my $f (@{ $file->{sym} }) {
    my($name) = @$f;
    die "array `@$f' of unexpected length" unless @$f == $file->{ary}+2;
    my @args = @$f[1..$#$f];
    $_ = sprintf qq("\\%03o"), $ss{$_} for @args;
    print {$file->{fh}} <<EOP;
    { @args "$name", &$name },
EOP
  }

  print {$file->{fh}} <<EOP;
};

const f$file->{tname}_descr * const f$file->{name}_names_p = f$file->{name}_names;
const int f$file->{name}_names_c = sizeof(f$file->{name}_names)/sizeof(f$file->{name}_names[0]);

EOP
}

print {$out_2arg[$out_2targ]{fh}} qq(\n#include "table_1arg_2targs.h"\n\n);

close OUT_ASS or die;
close OUT_0ARG or die;
close $_->{fh} for (@out_1arg, @out_2arg);
close OUT_2ARG_T or die;