#!/usr/bin/perl -w

use strict;
no strict 'refs';
use warnings;
use Carp;
use Parse::RecDescent;

$Carp::Verbose = 0; # set to 1 when command-line option '-v' is given.

# variables handled from both main and Parse::RecDescent package.
# must be declared as 'our' storage.
#
our %Parameter = ( # user given parameters w/default values.
                       ARCH => 'GRAPE7M100',
                 );
our %Constant;     # user given constants.
our %Var;          # node of logic tree.
our $Varid;        # unique id assigned to each variable.

# all variables below are used only from main package.
# declarared as 'my' storage.
#
my  $Nodeprefix = 'node';
my  $Nnode;        # number of nodes generated.
my  $Rootpath;     # pgpg2 root path (eg. /usr/local/pgpg2/)
my  $Tableresolution = 9; # default resolution of table (2**9 = 512 entries).

# pre-defined operators.
my %Operator = (
    '+'  => 'add',
    '-'  => 'sub',
    '*'  => 'mul',
    '/'  => 'div',
    '='  => 'connect',
    '+=' => 'inc',
    '^'  => 'cross',
    '<<' => 'lshift',
    '>>' => 'rshift',
    '<'  => 'comp_l',
    '==' => 'comp_e',
    '>'  => 'comp_g',
    '>=' => 'comp_ge',
    '<=' => 'comp_le',
    '!=' => 'comp_ne',
);

# pre-defined special functions
#
my %Function = (
    pg_cutoff => 1,
    pg_sqrt   => 1,
    pg_store  => 1,
    pg_pow    => 1,
);

my @Mandatoryparameter = qw/ARCH PREFIX NPIPE JMEMSIZE/;

# enable warnings within the Parse::RecDescent module.
#
$::RD_ERRORS = 1; # Make sure the parser dies when it encounters an error
$::RD_WARN   = 1; # Enable warnings. This will warn on unused rules &c.
$::RD_HINT   = 1; # Give out hints to help fix problems.
$::RD_TRACE  = undef; # output parse tree. set when command-line option '-t' is given.

#
# local code starts from here
#
my $Verbose = 0;
my $Debug = 0;
my $Infile;
my $Imgoutfile;
my $Outbuf = '';
my $Schematic3D = 1; # draw a schematic in 3D-view by default.

#
# main function starts from here
#
{
    $Rootpath = $ENV{PGPG2PATH};
    parse_commandline_arguments();

    my $PG2grammar;
    {
        local $/;
        $PG2grammar = <DATA>;
    }

    my $parser = Parse::RecDescent->new($PG2grammar);
    my $intext = read_pg2($Infile);

    dprintf("\ntext read, preprocessed, and comment stripped: --------\n");
    dprintf($intext);
    dprintf("--------------------------------------------------------\n\n");
    
    my $tree = $parser->PG2grammar($intext);
    die "Error: syntax error found in the input.\n" if !$tree;

    use Data::Dumper 'Dumper';
    dprintf(Dumper [ $tree ]);

    # remove unnecessary intermediate variables.
    for my $var (values %Var) {
        next if ($var->{io} ne 'fout');
        for my $node (@{$var->{elements}}) {
            recconect_parsed_tree($node);
        }
    }

    # insert pipeline delay, and then calculate total delay.
    my $max_delay = 0;
    for my $var (values %Var) {
        next if ($var->{io} ne 'fout');
        for my $node (@{$var->{elements}}) {
            my $delay = calc_pipeline_delay_of_a_node_tree($node);
            if ($max_delay < $delay) {
                $max_delay = $delay;
            }
        }
    }

    vprintf("\nnodes dependency and pipeline delay:\n");
    for my $var (values %Var) {
        next if ($var->{io} ne 'fout');
        for my $node (@{$var->{elements}}) {
            check_node_usage_tree($node, 0);
        }
    }
    vprintf("\n    total pipeline delay: $max_delay\n");

    vprintf("\nnodes defined:\n");
    my $fmt = "    %-8s %-6s %4s %8s %10s  %-8s  %4s\n";

    vprintf("  nodes in use:\n");
    vprintf($fmt, 'name', 'type', 'width', 'mantissa', 'nelement', 'io', 'id');
    for my $var (sort {$a->{name} cmp $b->{name}} values %Var) {
        for my $node (@{$var->{elements}}) {
            next if ! defined $node->{inuse};
            vprintf($fmt,
                    $node->{name},
                    $var->{type},
                    $var->{width},
                    $var->{mantissa},
                    $var->{nelement},
                    sprint_ifdef($var->{io}),
                    $var->{id},
                   );
        }
    }
    vprintf("\n  nodes defined, but optimized out:\n");
    vprintf($fmt, 'name', 'type', 'width', 'mantissa', 'nelement', 'io', 'id');
    for my $var (sort {$a->{name} cmp $b->{name}} values %Var) {
        for my $node (@{$var->{elements}}) {
            next if defined $node->{inuse};
            vprintf($fmt,
                    $node->{name},
                    $var->{type},
                    $var->{width},
                    $var->{mantissa},
                    $var->{nelement},
                    sprint_ifdef($var->{io}),
                    $var->{id},
                   );
        }
    }

    vprintf("\nscaling constants of I/O variables\n" .
            "(only for variables which need to be scaled):\n");
    $fmt = "    %-8s %s";
    for my $var (values %Var) {
        next if ($var->{io} !~ /ipin|jpin|cin|fout/);
        next if ($var->{ctype} ne 'double');
        next if ($var->{type} !~ /float|log|int/);
        next if ($var->{type} =~ /int/ && $var->{io} =~ /ipin|jpin|cin/);

        my $name = uc $var->{name} . 'SCALE';
        my $value = $Constant{$name};
        if (defined $value) {
            vprintf($fmt . "\n", $var->{name}, $value);
        }
        else {
            $value = $Constant{$name} = '1.0';
            vprintf($fmt, $var->{name}, $value);
            vprintf(" (scaling constant is not given. use default value 1.0)\n");
        }
    }
    vprintf("\n\n");

    print "// PGDL output:\n\n";

    # user given constants
    for my $c (sort keys %Constant) {
        printf("#define %-15s %s\n", $c, $Constant{$c});
    }
    print "\n";

    # auto calculated parameters
    $Parameter{DELAY} = $max_delay;

    # print parameter list
    for my $p (sort keys %Parameter) {
        printf("/%-15s %s\n", $p, $Parameter{$p});
    }
    print "\n";

    for my $mp (@Mandatoryparameter) {
        croak "mandatory parameter '$mp' not defined.\n" if !defined $Parameter{$mp};
    }

    # I/O port definition
    #
  IOPORT:
    for my $var (sort {$a->{id} <=> $b->{id}} values %Var) {
        my %ioname = (
                      ipin => '/IPSET',
                      jpin => '/JPSET',
                      cin  => '/COEFFSET',
                      fout => '/FOSET',
                     );
        my $ioname = $ioname{$var->{io}};

        next IOPORT if !defined $ioname;
        next IOPORT if !defined $var->{elements}->[0]->{inuse};

        my $name = uc $var->{name};
        printf("%-7s %-10s, %-6s, %-10s, %-6s, %-3s, ",
               $ioname,
               $var->{name},
               defined $var->{ctype} ? $var->{ctype} : q{-},
               $var->{name} . q{[} . $var->{nelement} . q{]},
               $var->{type},
               $var->{width},
               );
        if ($var->{mantissa}) {
            printf("%-3s, %-10s\n", $var->{mantissa}, $name . 'SCALE');
        } else {
            printf("     %-15s, %-15s\n", $name . 'SCALE', $name . 'OFFSET');
        }
    }
    print "\n";

    # pipeline description
    #
    for my $var (values %Var) {
        for my $node (@{$var->{elements}}) {
            next if ($var->{io} ne 'fout');
            generate_modules($node);
        }
    }
    print $Outbuf;

    print "\n// end of PGDL\n";
    if (defined $Imgoutfile) {
        draw_schematic();
    }
}

#############################################################
#
# sub routines used by the main routine
#

# parse command line arguments
#
sub parse_commandline_arguments {
    while (@ARGV) {
        $_ = shift @ARGV;

        /-v/     and do {
            $Verbose = 1;
            $Carp::Verbose = 1;
            next;
        };

        /-d/     and do {
            $Debug = 1;
            next;
        };

        /-t/     and do {
            $::RD_TRACE  = 1;
            next;
        };

        /-h/     and do {
            my $umsg = << 'EOUMSG';
convert a .pg2 file to .pgdl format.
input is taken from stdin if no file name is given.
  usage: %s [-v|-d|-t|-s <image-file>|-h] [pg2-file]
    switches are
      -v: be verbose.
      -d: output messages for debugging purpose.
      -t: output parse tree (may be useful for debugging .pg2 code).
      -s <image-file>: output a schematic of generated pipeline in eps and pdf.
      -h: print this help.
EOUMSG
            my $cmdname = $0;
            $cmdname =~ s/.+\/(.+)/$1/g;
            $umsg = sprintf($umsg, $cmdname);
            die $umsg;
            next;
        };

        /-s/     and do {
            $Imgoutfile = shift @ARGV;
            if (! ($Imgoutfile =~ /\.eps$/)) {
                $Imgoutfile .= '.eps';
            }
            next;
        };

        /[^-]+/  and do {
            if (! defined $Infile) {
                $Infile = $_;
            }
            next;
        };
    }
}

sub read_pg2 {
    local ($/);
    local (*IN);
    my ($fname) = @_;
    my $intext;

    if (!defined $fname) {
        $fname = q{-};
    }
    croak "$!\n" if !open(IN, "cpp $fname | grep -v '\#' |");
    $intext = <IN>;
    close IN;

    return $intext;
}

sub type_match {
    my ($var0, $var1) = @_;

    if (!defined($var0->{type}) || !defined($var0->{width}) || !defined($var0->{mantissa}) ||
        !defined($var1->{type}) || !defined($var1->{width}) || !defined($var1->{mantissa})
        ) {
        return 0;
    }
    elsif ($var0->{type}  ne $var1->{type} ||
        $var0->{mantissa} != $var1->{mantissa}) {
        return 0;
    }
    elsif ($var0->{width} != $var1->{width}) {
        if (defined $var0->{operator} &&
            $var0->{operator} eq 'inc' &&
           $var0->{width} >= $var1->{width}) {
            return 1;
        }
        else {
            return 0;
        }
    }
    else {
        return 1;
    }
}

# check if $var is a NUMBER.
#
sub is_number {
    my ($var) = @_;

    if (defined $var->{elements}->[0]->{literal}) {
        return 1;
    }
    else {
        return 0;
    }
}

# check if $var is a constant.
#
sub is_constant {
    my ($var) = @_;

    croak("variable '$var->{name}' not defined.\n") if !defined $Var{$var->{name}};

    if (is_number($var) || $var->{io} eq 'ipin' || $var->{io} eq 'cin') {
        return 1;
    }
    else {
        return 0;
    }
}

# check if $var is a leaf (has no child)
#
sub is_leaf {
    my ($var) = @_;

    croak("variable '$var->{name}' not defined.\n") if !defined $Var{$var->{name}};

    if (is_number($var) ||                # a literal number.
        $var->{io} =~ /jpin|ipin|cin/ ||  # an I/O var.
        ! defined $var->{operator}) {     # an intermediate var connected to an I/O.
        return 1;
    }
    else {
        return 0;
    }
}

sub type_and_nelement_match {
    my ($var0, $var1) = @_;
    if (type_match($var0, $var1) &&
        defined($var0->{nelement}) && defined($var1->{nelement}) &&
        $var0->{nelement} == $var1->{nelement}
        ) {
        return 1;
    }
    else {
        return 0;
    }
}


sub type_mismatch {
    my ($var0, $var1, $func) = @_;

    if (!defined($func)) {
        $func = 'die';
    }

    my $msg = "type mismatch: " .
        "'$var0->{name}' of type ". $var0->{type}. $var0->{width} .
        ($var0->{mantissa} ? "." . $var0->{mantissa} : "") .
        ($var0->{nelement} == 1 ? "" : "[$var0->{nelement}]") .
        ((defined $var0->{elements}->[0]->{literal}) ? qq{(literal "$var0->{elements}->[0]->{literal}")} : q{}).

        " and " .
        "'$var1->{name}' of type ". $var1->{type}. $var1->{width} .
        ($var1->{mantissa} ? "." . $var1->{mantissa} : "") . 
        ($var1->{nelement} == 1 ? "" : "[$var1->{nelement}]") .
        ((defined $var1->{elements}->[0]->{literal}) ? qq{(literal "$var1->{elements}->[0]->{literal}")} : q{}).

        "\n";

    for ($func) {
        /die/ and do {
            die "Error: " . $msg;
            last;
        };
        /croak/ and do {
            croak "Error: " . $msg;
            last;
        };
        /warn/ and do {
            warn "Warning: " . $msg;
            last;
        };
        /carp/ and do {
            carp "Warning: " . $msg;
            last;
        };
    }
}

sub nelement_mismatch {
    my ($svar0, $svar1, $dvar) = @_;
    my $buf = sprintf("'%s%s', '%s%s', and '%s%s' have inconsistent number of elements.\n",
                      $dvar->{name},  ($dvar->{nelement} == 1  ? '' : "[$dvar->{nelement}]"),
                      $svar0->{name}, ($svar0->{nelement} == 1 ? '' : "[$svar0->{nelement}]"),
                      $svar1->{name}, ($svar1->{nelement} == 1 ? '' : "[$svar1->{nelement}]"));
    croak "$buf\n";
}

sub generate_a_module {
    my ($node) = @_;
    my @children = @{$node->{children}};

    return if (!defined $node->{variable}->{operator});

    for ($node->{variable}->{operator}) {
        /connect/ and do {
            generate_connect($node, $children[0]);
            last;
        };
        /inc/ and do {
            generate_inc($node, $children[0]);
            last;
        };
        /conv/ and do {
            generate_conv($node, $children[0]);
            last;
        };
        /delay/ and do {
            generate_delay($node, $children[0]);
            last;
        };
        /store/ and do {
            generate_store($node, $children[0], $children[1]);
            last;
        };
        /add|sub|mul|div|comp|lshift|rshift/ and do {
            generate_binaryoperation($node, $children[0], $children[1]);
            last;
        };
        /selector/ and do {
            generate_selector($node, \@children);
            last;
        };
        /pg_pow/ and do {
            generate_pg_pow($node, \@children);
            last;
        };
        do {
            if ($Function{$_}) {
                generate_function_generic($node, \@children);
            }
            else {
                die "Error: unknown operator '$_'.\n";
            }
            last;
        };
    }
}

sub conv_node_to_signal {
    my ($node) = @_;
    my $var = $node->{variable};
    my $signal = $node->{basename};

    return q{"} . $node->{value} . q{"} if defined $node->{value};

    $signal .= $var->{nelement} > 1 ? '_' . $node->{index} : q{};

    return $signal;
}

sub conv_var_to_signal {
    my ($var) = @_;

    return q{"} . $var->{elements}->[0]->{value} . q{"} if defined $var->{elements}->[0]->{value};

    return $var->{name};
}

# generate signal connection
#
sub generate_connect {
    my ($dnode, $snode) = @_;
    $Outbuf .= sprintf("pg_connect(%s, %s);\n",
                       conv_node_to_signal($dnode),
                       conv_node_to_signal($snode));
}

# generate accumulator module
#
sub generate_inc {
    my ($dnode, $snode) = @_;
    my $dvar = $dnode->{variable};
    my $svar = $snode->{variable};

    # word length of destination should be equal or longer than source.
    #
    $Outbuf .= sprintf("pg_inc_%s(%s, %d, %d, %s, %d, %d, %d);\n",
                       $dvar->{type},
                       conv_node_to_signal($snode), $svar->{width}, $svar->{mantissa},
                       conv_node_to_signal($dnode), $dvar->{width}, $dvar->{mantissa},
                       $snode->{delay});
}

# generate type conversion module
#
sub generate_conv {
    my ($dnode, $snode) = @_;
    my $dvar = $dnode->{variable};
    my $svar = $snode->{variable};

    $Outbuf .= sprintf("pg_conv_%s_to_%s(%s, %s, %s, %s, %s, %s);\n",
                       $svar->{type}, $dvar->{type},
                       conv_node_to_signal($snode), $svar->{width}, $svar->{mantissa},
                       conv_node_to_signal($dnode), $dvar->{width}, $dvar->{mantissa});
}

# generate delay module
#
sub generate_delay {
    my ($dnode, $snode) = @_;
    my $dvar = $dnode->{variable};
    my $svar = $snode->{variable};

    $Outbuf .= sprintf("pg_delay(%s, %s, %s, %d);\n",
                       conv_node_to_signal($snode),
                       conv_node_to_signal($dnode),
                       $svar->{width},
                       $dnode->{delay} - $snode->{delay});
}

# generate store module
#
sub generate_store {
    my ($dnode, $snode0, $snode1) = @_;
    my $dvar = $dnode->{variable};
    my $svar0 = $snode0->{variable};
    my $svar1 = $snode1->{variable};

    if ($svar1->{nelement} != 1 || $svar1->{width} != 1) {
        croak "'$svar1->{name}' must have one element of 1-bit width.\n";
    }

    return if $dnode->{index} != 0; # generate only one module for one $dvar.

    $Outbuf .= sprintf("pg_store(%s, %s, %s, %d, %d, %d);\n",
                       conv_var_to_signal($svar0),
                       conv_var_to_signal($dvar),
                       conv_var_to_signal($svar1),
                       $svar0->{width},
                       $dvar->{nelement},
                       $snode0->{delay});
}

# generate pre-defined function module
#
# module_name_<type1>_<type2>..._<typeN>(
#     arg1, width1, mantissa1,
#     arg2, width2, mantissa2,
#     ...
#     argN, widthN, mantissaN);
#
sub generate_function_generic {
    my ($dnode, $snodes) = @_;
    my $dvar = $dnode->{variable};

    # module name
    $Outbuf .= sprintf("$dvar->{operator}");

    # argument types
    for my $snode (@$snodes) {
        $Outbuf .= "_$snode->{variable}->{type}";
    }
    $Outbuf .= sprintf("_$dvar->{type}(");

    # argument names, widths, mantissas
    for my $snode (@$snodes) {
        my $svar = $snode->{variable};
        $Outbuf .= conv_node_to_signal($snode) . ", ";
        $Outbuf .= "$svar->{width}, ";
        $Outbuf .= "$svar->{mantissa}, ";
    }
    $Outbuf .= sprintf(conv_node_to_signal($dnode) . ", ");
    $Outbuf .= sprintf("$dvar->{width}, ");
    $Outbuf .= sprintf("$dvar->{mantissa});\n");
}

sub generate_selector {
    my ($dnode, $snodes) = @_;
    my $dvar = $dnode->{variable};

    # module name
    $Outbuf .= "pg_$dvar->{operator}(";

    # argument names, widths, mantissas
    for my $snode (@$snodes) {
        my $svar = $snode->{variable};
        $Outbuf .= conv_node_to_signal($snode) . ", ";
        $Outbuf .= "$svar->{width}, ";
        $Outbuf .= "$svar->{mantissa}, ";
    }
    $Outbuf .= sprintf(conv_node_to_signal($dnode) . ", ");
    $Outbuf .= sprintf("$dvar->{width}, ");
    $Outbuf .= sprintf("$dvar->{mantissa});\n");
}

# generate pg_pow function module
#
# pg_pow_ufloat(src, dst, w1, m1, pindex_numerator, pindex_denominator,
#               table_file_name, table_size, table_entry_width, table_output_widths[0..3]);
#
sub generate_pg_pow {
    my ($dnode, $snodes) = @_;
    my $svar = $snodes->[0]->{variable};
    my $dvar = $dnode->{variable};
    my $n = $snodes->[1]->{value};
    my $m = $snodes->[2]->{value};
    my $resolution = (defined $snodes->[3]) ? $snodes->[3]->{value} : $Tableresolution;
    # module name
    $Outbuf .= sprintf("$dvar->{operator}");
    $Outbuf .= '_' . $svar->{type} . '(';
    $Outbuf .= conv_node_to_signal($snodes->[0]) . ", ";
    $Outbuf .= sprintf(conv_node_to_signal($dnode) . ", ");
    $Outbuf .= sprintf("$svar->{width}, ");
    $Outbuf .= sprintf("$svar->{mantissa}, ");
    $Outbuf .= sprintf("$n, ");
    $Outbuf .= sprintf("$m, ");
    $Outbuf .= sprintf("$resolution");
    $Outbuf .= sprintf(");\n");
}

# S = S [+-*] S
# V = S [+-*] V
# V = V [+-*] S
# V = V [+-] V
# S = S <<|>> S
# V = V <<|>> S
#
sub generate_binaryoperation {
    my ($dnode, $snode0, $snode1) = @_;
    my $dvar = $dnode->{variable};
    my $svar0 = $snode0->{variable};
    my $svar1 = $snode1->{variable};
    my $op = $dvar->{operator};

    my $opname;
    my $postfix;
    if ($op =~ /lshift|rshift/) {
        $opname = "shift";
        $postfix = q{, } . ($op =~ /lshift/ ? q{"LEFT"} : q{"RIGHT"}) . ");\n";
    }
    elsif ($op =~ /comp/) {
        $opname = "comp";
        $op =~ /^comp_(.+)$/;
        $postfix = q{, } . q{"} . uc $1 . q{"} . ");\n";
    } else {
        $opname = $op;
        $postfix = ");\n";
    }

    $Outbuf .= sprintf("pg_%s_%s(%s, %d, %d, %s, %d, %d, %s, %d, %d" . $postfix,
                       $opname, $svar0->{type},
                       conv_node_to_signal($snode0), $svar0->{width}, $svar0->{mantissa},
                       conv_node_to_signal($snode1), $svar1->{width}, $svar1->{mantissa},
                       conv_node_to_signal($dnode) ,  $dvar->{width} , $dvar->{mantissa});
}

# returns the num of elems of the result of binary operation
#
sub calc_dst_nelement {
    my ($ns1, $ns2, $op) = @_;
    my $nd = 1;

    if ($ns1 > 1 && $ns1 == $ns2 && $op =~ /mul/) { # dot product
        $nd = 1;
    }
    elsif (
           ($ns1 == 1 && $ns2 == 1) ||                     # S = S [+-*/] S
           ($ns1 == 1 && $ns2 > 1 ) ||                     # V = S [+-*/] V
           ($ns1 > 1  && $ns2 == 1) ||                     # V = V [+-*/] S
           ($ns1 > 1  && $ns2 == $ns1 && !($op =~ /mul/)) # V = V [+-/]  V
           ) {
        $nd = ($ns1 > $ns2 ? $ns1 : $ns2);

        if (($nd != 1) && ($op =~ /comp/)) {
            croak "$op: number of element must be 1.\n";
        }
    }
    return $nd;
}

# returns delay of a $node itself
# (delay does not include its decendants').
#
sub calc_pipeline_delay_of_a_node {
    my ($node) = @_;
    my @children;
    my $modulename = undef;
    my $delay = undef;
    my $var = $node->{variable};
    my $type = $var->{type};

    return 0 if (is_constant($var) || is_leaf($var));

    if (defined $node->{children}) {
        @children = @{$node->{children}};
    }

    croak("variable '$var->{name}' has no 'operator' field.\n") if !defined $var->{operator};
    for ($var->{operator}) {
      /connect/ and do {
        $delay = 0;
      };

      /inc/ and do {
        $modulename = 'pg_inc_' . $type;
      };

      /conv/ and do {
        $modulename = 'pg_conv_' . $children[0]->{variable}->{type} . '_to_' . $type;
      };

      /add|sub|div|mul/ and do {
        $modulename = 'pg_' . $var->{operator} . '_' . $type;
      };

      /lshift|rshift/ and do {
        $modulename = 'pg_shift_' . $type;
      };

      /comp/ and do {
        $modulename = 'pg_comp_' . $children[0]->{variable}->{type};
      };

      /pg_cutoff/ and do {
        $modulename = 'pg_cutoff_' .
          $children[0]->{variable}->{type} . '_' .
          $children[1]->{variable}->{type} . '_' . $type;
      };

      /selector/ and do {
        $modulename = 'pg_selector';
      };

      /pg_pow/ and do {
        $modulename = 'pg_pow_' .
          $children[0]->{variable}->{type};
      };

      /pg_sqrt/ and do {
        $modulename = 'pg_sqrt_' . $children[0]->{variable}->{type} . '_' . $type;
      };

      /pg_store/ and do {
        $modulename = 'pg_store';
      };
    }

    # obtain $delay from $modulename
    if (defined $modulename) {
      eval {
          $delay = read_delay_tag_of_module($modulename);
      };
      if ($@) {
          printf STDERR "Error: $modulename(";
          my $firstarg = 1;
          for my $child (@children) {
              if ($firstarg) {
                  $firstarg = 0;
              }
              else {
                  printf STDERR ", ";
              }
              printf STDERR "%s", $child->{variable}->{name};
          }
          printf STDERR ")\n";
          printf STDERR "  a VHDL module '$modulename' does not exist.\n";
          exit;
      }

      vprintf("module:$modulename    delay:$delay\n");
    }

    # abort if there's no delay definition
    if (!defined $delay) {
      carp "no delay info found for node $node->{name}\n";
    }

    return $delay;
}

sub read_delay_tag_of_module {
    local (*IN);
    local ($/); # slurp the input
    my ($name) = @_;
    my $delay = undef;
    my $intext;

    if (open( IN, "< $Rootpath/src/templates/$name.template.vhd")) {
        $intext = <IN>;
        close IN;
    }
    else {
        croak "Warning: cannot open $name.template.vhd";
    }

    if ($intext =~ /<DELAY \s* = \s* (\d+)>/x) {
        $delay = $1;
    }
    return $delay;
}

# remove unnecessary intermediate variables.
#
sub recconect_parsed_tree {
    my ($node) = @_;

    return if (!@{$node->{children}});

    # recconect childrent of myself.
    my @new_children = ();
    for my $child (@{$node->{children}}) {
        my $op = $child->{variable}->{operator};
        if (defined $op && ($op eq 'connect')) {
            push @new_children, $child->{children}->[0];
        }
        else {
            push @new_children, $child;
        }
    }
    $node->{children} = \@new_children;

    # reconnect descendants.
    for my $child (@{$node->{children}}) {
        recconect_parsed_tree($child);
    }

    return;
}

sub calc_pipeline_delay_of_a_node_tree {
    my ($node) = @_;
    my $delay;

    # already calculated.
    return $delay if ($delay = $node->{delay});

    # delay of the $node itself.
    $delay = $node->{delay} = calc_pipeline_delay_of_a_node($node);
    return $delay if (!@{$node->{children}});

    # calculate descendant's max delay.
    my $max_delay = 0;
    for my $child (@{$node->{children}}) {
        $delay =calc_pipeline_delay_of_a_node_tree($child);
        if ($max_delay < $delay) {
            $max_delay = $delay;
        }
    }

    # adjust delay of $node itself.
    $node->{delay} += $max_delay;

    # insert a delay node between $node and its children.
    my @delayed_children = ();

  DELAY_INSERTION:
    for my $child (@{$node->{children}}) {

        my $delay = $child->{delay};

        # no delay is necessary for a child which has the longest
        # delay or which has constant value.
        if ($delay == $max_delay || is_constant($child->{variable})) {
            push @delayed_children, $child;
            next DELAY_INSERTION;
        }

        # create a delayed variable if it does not exist yet.
        my $dcvname = $child->{variable}->{name} . 'D' . ($max_delay - $delay);
        my $dcvar;
        if (!defined $Var{$dcvname}) {
            $dcvar = define_a_variable({name => $dcvname});
            copy_a_variable($child->{variable}, $dcvar);
            $dcvar->{operator} = 'delay';
        }
        $dcvar = $Var{$dcvname};

        my $dcnode = define_a_node(
            {
                basename => $dcvname,
                index    => $child->{index},
                nelement => $dcvar->{nelement},
                variable => $dcvar,
                delay    => $max_delay,
                children => [$child],
            }
        );
        push @delayed_children, $dcnode;
    }

    $node->{children} = \@delayed_children;

    return $node->{delay};
}


sub check_node_usage_tree {
    my ($node, $level) = @_;
    vprintf('    ' . '    ' x $level);
    vprintf("$node->{name} ($node->{delay})\n");

    $node->{inuse} = 1; # mark up this node is actually in use.

    if (defined $node->{children}) {
        for my $child (@{$node->{children}}) {
           check_node_usage_tree($child, $level+1);
        }
    }
}

sub generate_modules {
    my ($node) = @_;

    return if (defined $node->{generated});
    return if ($node->{variable}->{io} =~ /ipin|jpin|cin/);
    return if is_number($node->{variable});
    carp "Warning: node '$node->{name}' is assigned to no value.\n"
        if (!defined $node->{children});

    # generate children
    for my $child (@{$node->{children}}) {
        generate_modules($child);
    }

    # generate $node itself
    generate_a_module($node);
    $node->{generated} = 1; # avoid duplicate generation

}

sub width_of {
    my ($value) = @_;
    my $width;

    if ((abs $value) > 0) {
        $width = int log(abs $value) / log(2) + 1;
    }
    else {
        $width = 1;
    }
    return $width;
}

sub vprintf {
    if ($Verbose) {
        printf STDERR @_;
    }
}

sub dprintf {
    if ($Debug) {
        printf STDERR @_;
    }
}



#############################################################
#
# sub routines used by the parser
#

sub define_a_node {
    my ($arg_ref) = @_;
    my $basename = $arg_ref->{basename};
    my $index = $arg_ref->{index};
    my $variable = $arg_ref->{variable};
    my $ne = $arg_ref->{nelement};
    my $name = $basename . ($ne > 1 ? q{[} . $index . q{]} : q{});
    my $node;
    my $oldnode = $variable->{elements}->[$index];

    if ( defined $oldnode ) {
        vprintf("define_a_node: element $name already exists. do not redefine.\n");
        $node = $oldnode;
    }
    else {
        $node = {
            name     => $name,
            basename => $basename,
            index    => $index,
            variable => $variable,
            children => defined $arg_ref->{children} ? $arg_ref->{children} : [],
            delay => defined $arg_ref->{delay} ? $arg_ref->{delay} : undef,
            value    => $arg_ref->{value},
            literal  => $arg_ref->{literal},
        };
        $variable->{elements}->[$index] = $node;
    }

    return $node;
}

# copy all hashed values of $svar to $dvar,
# except for $dvar->{name},{id},{io},{elements}.
#
# note: this subroutine do not create a new variable.
#       it just copy contents of $svar to $dvar.
#
sub copy_a_variable {
    my ($svar, $dvar) = @_;

    # save $dvar's attributes which should not be overwritten by $svar's.
    #
    my $name     = $dvar->{name};
    my $id       = $dvar->{id};
    my $io       = $dvar->{io};
    my $ctype    = $dvar->{ctype};
    my $elements = $dvar->{elements};

    %$dvar = %$svar;

    # recover saved attributes.
    #
    $dvar->{name}     = $name;
    $dvar->{id}       = $id;
    $dvar->{io}       = $io;
    $dvar->{ctype}    = $ctype;
    $dvar->{elements} = $elements;
}

sub define_a_variable {
    my ($arg_ref) = @_;
    my $ne =$arg_ref->{nelement},
    my $id = $main::Varid++;
    my $name;

    if (defined $arg_ref->{name}) {
        $name = $arg_ref->{name};
    }
    else {
        $name = $Nodeprefix . $id;
    }
    my $var = $Var{$name} = {
        name     => $name,
        type     => $arg_ref->{type},
        width    => $arg_ref->{width},
        mantissa => $arg_ref->{mantissa},
        nelement => $ne,
        elements => [],
        io       => defined $arg_ref->{io} ? $arg_ref->{io} : q{-},
        ctype    => defined $arg_ref->{ctype} ? $arg_ref->{ctype} : q{-},
        id       => $id,
        operator => $arg_ref->{operator},
    };
    
    # define each component as a node.
    if (defined $ne) {
        for my $i ( 0 .. $ne - 1 ) {
            my $node = define_a_node(
                {
                    basename => $name,
                    index    => $i,
                    nelement => $ne,
                    variable => $var,
                }
            );
        }
    }

    vprintf("defined a variable '$var->{name}'\n");
    vprintf(sprint_variable($var) . "\n");

    return $var;
}

sub define_a_number {
    my ($number) = @_;

    my $var = define_a_variable(
        {
            name     => undef,
            type     => undef,
            width    => undef,
            mantissa => 0,
            nelement => 1,
            io       => '-',
        }
    );
    my $node = $var->{elements}->[0];
    $node->{literal} = $number;
    $node->{value} = $number;

    return $var->{name};
}

sub sprint_ifdef {
    my ($text) = @_;
    return defined $text ? $text : 'not defined';
}

sub sprint_node {
    my ($node) = @_;
    my $outtext = "";
    my $indent = 8;

    $outtext .= ' ' x $indent . 'name => '     . sprint_ifdef($node->{name})     . "\n";
    $outtext .= ' ' x $indent . 'basename => ' . sprint_ifdef($node->{basename}) . "\n";
    $outtext .= ' ' x $indent . 'index => '    . sprint_ifdef($node->{index})    . "\n";
    $outtext .= ' ' x $indent . 'delay => '    . sprint_ifdef($node->{delay})    . "\n";
}

sub sprint_variable {
    my ($var) = @_;
    my $outtext = "";
    my $indent = 4;

    $outtext .= ' ' x $indent . 'name => '     . sprint_ifdef($var->{name})     . "\n";
    $outtext .= ' ' x $indent . 'type => '     . sprint_ifdef($var->{type})     . "\n";
    $outtext .= ' ' x $indent . 'width => '    . sprint_ifdef($var->{width})    . "\n";
    $outtext .= ' ' x $indent . 'mantissa => ' . sprint_ifdef($var->{mantissa}) . "\n";
    $outtext .= ' ' x $indent . 'nelement => ' . sprint_ifdef($var->{nelement}) . "\n";
    $outtext .= ' ' x $indent . 'io => '       . sprint_ifdef($var->{io})       . "\n";
    $outtext .= ' ' x $indent . 'id => '       . sprint_ifdef($var->{id})       . "\n";
    $outtext .= ' ' x $indent . 'operator => ' . sprint_ifdef($var->{operator}) . "\n";

    for my $node (@{$var->{elements}}) {
        $outtext .= sprint_node($node);
        $outtext .= "\n";
    }

    return $outtext;
}

sub define_variables {
    my ($type, $vnames, $io) = @_;
    $type =~ /([a-zA-Z_]*)(\d+)(?:.(\d+)|)/;
    my $ctype;
    my ($t, $w, $m) = ($1, $2, $3);
    defined $m or $m = 0;

    if (defined $io->[0]) {
        $io = $io->[0];
        $io =~ /(?: \( ( int | double ) \))? ( ipin | jpin | fout | cin ) /x;
        ($ctype, $io) = ($1, $2);
        if (! defined $ctype) {
            $ctype = 'double';
        }
    }
    else {
        $io = '-';
    }

    for my $vn (@{$vnames}) {
        $vn =~ /([a-zA-Z_]\w*)(?:\[(\d+)\]|)/;
        my ($name, $ne) = ($1, $2);
        if (!defined $ne) {
            $ne = 1;
        }

        define_a_variable(
            {
                name     => $name,
                type     => $t,
                width    => $w,
                mantissa => $m,
                nelement => $ne,
                io       => $io,
                ctype    => $ctype,
                operator => undef,
            }
        );
    }
}

# define a scalar function
#
sub define_function {
    my ($function, $vnames) = @_;
    my @children = ();
    my $prototype = $Function{$function};
    croak "function '$function' not defined.\n" if !defined $prototype;

    for my $vname (@{$vnames}) {
        my ($vbasename, $index);
        if ($vname =~ /([a-zA-Z_]\w*)(?:\[(\d+)\]|)/) {
            ($vbasename, $index) = ($1, $2);
        }
        $index = defined $index ? $index : 0;
        my $var = $Var{$vbasename};
        croak "variable '$vbasename' not defined.\n" if !defined $var;
        vprintf("function:$function  added arg%d  var:$var->{name}  " .
                "node:$var->{elements}->[$index]->{name}\n", scalar @children);
        push @children, $var->{elements}->[$index];
    }

    my $v0 = $children[0]->{variable};
    my $dvar = define_a_variable(
        {
            name     => undef,
            type     => $v0->{type},  # !!! this part should be rewritten for practical usage.
            width    => $v0->{width}, # function should be typed using prototype definition or something.
            mantissa => $v0->{mantissa},
            nelement => 1,
            io       => undef,
            operator => $function,
        }
    );
    $dvar->{elements}->[0]->{children} = \@children;

    return $dvar->{name};
}

sub convert_a_variable {
    my ($type, $sname) = @_;
    $type =~ /([a-zA-Z_]*)(\d+)(?:.(\d+)|)/;
    my ($t, $w, $m) = ($1, $2, $3);
    defined $m or $m = 0;

    my ($sbasename, $seid, $ns, $svar) = parse_variable_name($sname);

    croak "variable $sbasename not defined.\n" if !defined $ns;

    if (is_number($svar)) {
        $svar->{type}     = $t;
        $svar->{width}    = $w;
        $svar->{mantissa} = $m;
        my $snode = $svar->{elements}->[0];

        for ($svar->{type}) {
            /int/ and do {
                $snode->{value} = convert_literal_to_int($svar);
                last;
            };

            /float/ and do {
                $snode->{value} = convert_literal_to_float($svar);
                last;
            };

            /log/ and do {
                $snode->{value} = convert_literal_to_log($svar);
                last;
            };
        }

        return $svar->{name};
    }

    if ($type eq $svar->{type} &&
        $w eq $svar->{width} &&
        $m eq $svar->{mantissa}) { # no type conversion necessary
        return $sname;
    }

    my $cvar = define_a_variable(
        {
            name     => undef,
            type     => $t,
            width    => $w,
            mantissa => $m,
            nelement => $ns,
            io       => undef,
            operator => 'conv',
        }
    );

    for my $i (0 .. $cvar->{nelement} - 1) {
        $cvar->{elements}->[$i]->{children} = [$svar->{elements}->[defined $seid ? $seid : $i]];
    }

    return $cvar->{name};
}

sub convert_literal_to_int {
    my ($var) = @_;
    my $node = $var->{elements}->[0];
    my $val = int $node->{literal};
    my $w2  = $var->{width};
    my $ret;

    vprintf(qq{literal "$node->{literal}" is handled as a number of type $var->{type}$w2\n});

    if ($node->{literal} != 0 &&
        int log(abs $node->{literal}) / log(2.0) + 1 > $w2) {
        die qq{Error: literal "$node->{literal}" does not fit within $w2 bits.\n};
    }
    if ($val < 0) {
	my $aval = abs $val;
	$val = (1 << $w2) - $aval;
    }

    $ret = sprintf("%0" . $w2 . "b", $val);

    dprintf("literal:$node->{literal}  binary:$ret\n");
    return $ret;
}

sub convert_literal_to_float {
    my ($var) = @_;
    my $node = $var->{elements}->[0];
    my $val = $node->{literal};
    my $w2  = $var->{width};
    my $m2  = $var->{mantissa};
    my $e2  = $w2 - $m2 - 1;
    my $offset;
    my ($sign, $exp, $man, $bexp, $bman);

    vprintf(qq{literal "$node->{literal}" is handled as a number of type $var->{type}$w2.$m2\n});

    # sign bit
    $sign = ($val >= 0) ? 0 : 1;

    if ($val == 0) {
        $bexp = sprintf("%0" . $e2 . "b", 0);
        $bman = sprintf("%0" . $m2 . "b", 0);
        $exp = 0;
        $offset = 0;
        $man = 0;
    }
    else {
        # exponent
        $exp = int log(abs $val) / log(2.0);
        $offset = 1 << ($e2 - 1);
        $bexp = sprintf("%0" . $e2 . "b", $exp + $offset);

        # mantissa
        $man = abs $val;
        while ($man != int $man) {  # shift to the left
            $man *= 2.0;
        }
        $bman = sprintf("%b", $man) . '0' x ($m2+2);

        # $bman looks like:
        # 1 HHHHHHHHH x LLLLLLLL0000000000
        #
        my $bman_higher = substr $bman, 1, $m2-1; # higher $m2-1 bits (hidden 1 removed).
        my $bman_lower  = substr $bman, $m2+1; # lower bits to be cut off.
        my $bman_round;             # biased force-1 rounded.
        if ($bman_lower == 0) {
            $bman_round = $bman_higher . '0';
        } else {
            $bman_round = $bman_higher . '1';
        }
        $bman = $bman_round;
        dprintf("bman:$bman  bman_higher:$bman_higher  bman_lower:$bman_lower\n");
    }
    dprintf("literal:$node->{literal}  sign:$sign  exp:$exp  offset:$offset  man:$man  binary:$sign $bexp $bman\n");

    return $sign . $bexp . $bman;
}

sub convert_literal_to_log {
    my ($var) = @_;
    my $node = $var->{elements}->[0];
    my $val = $node->{literal};
    my $w2  = $var->{width};
    my $m2  = $var->{mantissa};
    my $e2  = $w2 - $m2 - 1;
    my $offset;
    my ($sign, $expman, $bexp, $bman, $bexpman);


    vprintf(qq{literal "$node->{literal}" is handled as a number of type $var->{type}$w2.$m2\n});

    # sign bit
    $sign = ($val >= 0) ? 0 : 1;

    if ($val == 0) {
        $bexpman = sprintf("%0" . ($e2 + $m2) . "b", 0);
        $offset = 0;
        $expman = 0;
    }
    else {
        # exponent & mantissa
        $expman = int (log(abs $val) / log(2.0) * 2**$m2 + 0.5);
        $offset = 1 << ($e2 + $m2 - 1);
        $bexpman = sprintf("%0" . ($e2 + $m2) . "b", $expman + $offset);
    }
    $bexp = substr $bexpman, 0, $e2;
    $bman = substr $bexpman, $e2;
    dprintf("literal:$node->{literal}  sign:$sign  exp&man:$expman  offset:$offset binary:$sign $bexp $bman\n");

    return $sign . $bexp . $bman;
}

sub convert_literal_number {
    my ($var) = @_;

    croak "${var}->{name} is not a number.\n" if ! is_number($var);

    return convert_literal_to_int($var)   if $var->{type} =~ /int/;
    return convert_literal_to_float($var) if $var->{type} =~ /float/;
    return convert_literal_to_log($var)   if $var->{type} =~ /log/;
}


sub inherit_attributes_of_a_number {
    my ($lvar, $rvar, $op) = @_;

    if (is_number($lvar) && ! defined $lvar->{type}) {
        if (is_number($rvar) && !defined $rvar->{type}) {
            croak "Error: cannot determine type of a constant number $lvar->{name}\n";
        }
        else {
            $lvar->{type}     = $rvar->{type};
            $lvar->{width}    = $rvar->{width};
            $lvar->{mantissa} = $rvar->{mantissa};
            $lvar->{elements}->[0]->{value} = convert_literal_number($lvar);
        }
    }
    elsif (is_number($rvar) && ! defined $rvar->{type}) {
        if ($op =~ /lshift|rshift/) {
	    $rvar->{type}  = 'int';
	    $rvar->{mantissa} = 0;
	    $rvar->{width} = $lvar->{width};    # shift int.
            if ($lvar->{type} =~ /float|log/) { # shift float or log.
		$rvar->{width} = $lvar->{width} - $lvar->{mantissa} - 1;
            }
            $rvar->{elements}->[0]->{value} = convert_literal_number($rvar);
        }
        else {
            $rvar->{type}  = $lvar->{type};
            $rvar->{width} = $lvar->{width};
            $rvar->{mantissa} = $lvar->{mantissa};
            $rvar->{elements}->[0]->{value} = convert_literal_number($rvar);
        }
    }
}

sub combine_variables {
    my @items = @_;
    my (@terms, @ops);

    while (1) {
        push @terms, (shift @items);
        last if !(@items);
        push @ops,   $Operator{(shift @items)};
    }
    my $lhs = shift @terms;
    while (@terms) {
        my $rhs = shift @terms;
        my $op = shift @ops;
        $lhs = combine_2variables($lhs, $rhs, $op);
    }
    return $lhs;
}

#
# return 1 if ($var0 $op $var1) should return dot product.
# return 0 otherwise.
#
sub is_dotproduct {
    my ($ne0, $ne1, $op) = @_;
    return 1 if ($ne0 > 1 && $ne0 == $ne1 && $op eq 'mul');
    return 0;
}

sub combine_2variables_to_a_dotproduct {
    my ($sname0, $sname1) = @_;
    my $svar0 = $Var{$sname0};
    my $svar1 = $Var{$sname1};
    my $ne = $svar0->{nelement};
    my @rhs_expression = ();

    # multiply each element
    for my $i (0..$ne-1) {

        push @rhs_expression, combine_2variables($svar0->{elements}->[$i]->{name},
                                                 $svar1->{elements}->[$i]->{name},
                                                 'mul');
        if ($i < $ne - 1) {
            push @rhs_expression, q{+};
        }
    }

    # add them up
    my $dname = combine_variables(@rhs_expression);

    return $dname;
}

sub is_float_div {
    my ($svar0, $svar1, $op) = @_;

    return 0 if $op ne 'div';
    return 0 if $svar1->{type} ne 'float';
    if ($svar1->{nelement} != 1) {
        die "Error: cannot divide by a vector ($svar1->{name}).\n";
    }

    return 1;
}

sub replace_div_with_pow1 {
    my ($sname0, $sname1) = @_;

    # generate pg_pow($sname1, -1, 1).
    my $minusone = define_a_number('-1');
    my $one = define_a_number('1');
    my @powargs = ($sname1, $minusone, $one);
    my $powname = define_function('pg_pow', \@powargs);

    # multiply $sname0 and $powname.
    my $dname = combine_2variables($sname0, $powname, 'mul');

    return $dname;
}

#
#  parse variable name and return its name, nelement,
#  reference to hash. return index also, if 
#  
#  -----------------------------------------------------------------------------------------------------
#   in                    out
#   expression  defined?  name  index  nelement  var
#  -----------------------------------------------------------------------------------------------------
#   var[i]      yes       (var, i,     1,        \%var)  # input is a node (an element of a variable).
#   var         yes       (var, undef, nelement, \%var)  # input is a variable.
#   var[i]      no        (var, i,     undef,    \%var)  #
#   var         no        (var, undef, undef,    \%var)  # index set to 0, if nelement == 1
#  -----------------------------------------------------------------------------------------------------
#
sub parse_variable_name {
    my ($name0) = @_;
    croak "invalid variable name:$name0.\n" if ($name0 !~ /([a-zA-Z_]\w*)(?:\[(\d+)\]|)/);
    my ($basename, $index) = ($1, $2);
    my $nelement = undef;
    my $var = $Var{$basename};

    if (defined $var) {
        if (defined $index) {
            $nelement = 1;

            if (($var->{nelement} -1) < $index) {
                die "Error: index $basename\[$index\] too large.\n";
            }
        }
        else {
            $nelement = $var->{nelement};
        }
    }
    return ($basename, $index, $nelement, $var);
}

sub combine_2variables {
    my ($name0, $name1, $op) = @_;
    my ($sname0, $eid0, $ns0, $svar0) = parse_variable_name($name0);
    my ($sname1, $eid1, $ns1, $svar1) = parse_variable_name($name1);
    my $nd = calc_dst_nelement($ns0, $ns1, $op);

    croak "variable $sname0 not defined.\n" if !defined $svar0;
    croak "variable $sname1 not defined.\n" if !defined $svar1;

    inherit_attributes_of_a_number($svar0, $svar1, $op); # special care for a NUMBER

    my $dvar;
    my $dname; # the name of combined variable to be returned.

    # V = V * V
    #
    if (is_dotproduct($ns0, $ns1, $op)) {
	$dname = combine_2variables_to_a_dotproduct($sname0, $sname1);
    }
    elsif (is_float_div($svar0, $svar1, $op)) {
        $dname = replace_div_with_pow1($sname0, $sname1);
    }
    else {
        # Scalar = S [+-*] S
        # Vector = V [+-] V
        # S      = S [<<|>>] S
        # V      = S [+-*] V
        # V      = V [+-*/] S
        # V      = V <<|>> S
        #
        $dvar = define_a_variable(
            {
                name     => undef,
                type     => $svar0->{type},
                width    => $svar0->{width},
                mantissa => $svar0->{mantissa},
                nelement => $nd,
                io       => undef,
                operator => $op,
            }
        );
        $dname = $dvar->{name};

        # $dvar can be a vactor even if $svar0 is a scalar.
        # in that case $svar0 should bevahe as a vector
        # which has $svar0->{elements}->[0] for all components.
        #
        if (!defined $eid0 && $ns0 < $nd) {
            $eid0 =  0;
        }
        if (!defined $eid1 && $ns1 < $nd) {
            $eid1 =  0;
        }
        for my $i ( 0 .. $nd - 1 ) {
              $dvar->{elements}->[$i]->{children} =
                [ defined $eid0 ? $svar0->{elements}->[$eid0] : $svar0->{elements}->[$i],
                  defined $eid1 ? $svar1->{elements}->[$eid1] : $svar1->{elements}->[$i]];
        }

        # Boolean = S [>/</>=/<=/==/!=/] S
        #
        if ( $op =~ /comp/ ) {
            $dvar->{type} = 'int';
            $dvar->{width} = 1;
            $dvar->{mantissa} = 0;
        }
    }

    return $dname;
}

sub select_one_of_two {
    my ($cond, $branch0, $branch1) = @_;
    my ($cname, $cid, $nc, $cvar) = parse_variable_name($cond);
    my ($bname0, $bid0, $nb0, $bvar0) = parse_variable_name($branch0);
    my ($bname1, $bid1, $nb1, $bvar1) = parse_variable_name($branch1);
    my $nd = $nb0;

    croak "variable $cname  not defined.\n" if !defined $cvar;
    croak "variable $bname0 not defined.\n" if !defined $bvar0;
    croak "variable $bname1 not defined.\n" if !defined $bvar1;

    inherit_attributes_of_a_number($bvar0, $bvar1, 'selector'); # special care for a NUMBER

    if (!type_and_nelement_match($bvar0, $bvar1)) {
        type_mismatch($bvar0, $bvar1);
    }
    if ($nc != 1) {
        croak "Error: branch condition of trinary operator ('cond ? branch0 : branch1') " .
          "can have only one element, but has $nc.\n";
    }
    if ($cvar->{width} != 1) {
        croak "Error: width of branch condition of trinary operator ('cond ? branch0 : branch1') "
          . "should be 1, but is $cvar->{width}.\n";
    }

    my $dvar;
    my $dname; # the name of combined variable to be returned.

    $dvar = define_a_variable(
        {
            name     => undef,
            type     => $bvar0->{type},
            width    => $bvar0->{width},
            mantissa => $bvar0->{mantissa},
            nelement => $nd,
            io       => undef,
            operator => 'selector',
        }
    );
    $dname = $dvar->{name};

    for my $i ( 0 .. $nd - 1 ) {
        $dvar->{elements}->[$i]->{children} =
          [ defined $cid  ? $cvar->{elements}->[$cid]   : $cvar->{elements}->[$i],
            defined $bid0 ? $bvar0->{elements}->[$bid0] : $bvar0->{elements}->[$i],
            defined $bid1 ? $bvar1->{elements}->[$bid1] : $bvar1->{elements}->[$i]];
    }

    return $dname;
}

sub assign_terms_to_variables {
    my @items = @_;
    my (@terms, @ops);

    while (1) {
        push @terms, (pop @items);
        last if !(@items);
        push @ops,   $Operator{(pop @items)};
    }

    my $rhs = shift @terms;
    while (@terms) {
        my $lhs = shift @terms;
        my $op = shift @ops;

        if ($op =~ /connect|inc/) {
            $rhs = assign_terms_to_a_variable($lhs, $rhs, $op);
        }
        else {
            croak "unknown operator $op\n";
        }
    }
    return $rhs;
}

sub assign_terms_to_a_variable {
    my ($dname0, $sname0, $op) = @_;
    my ($sname, $seid, $ns, $svar) = parse_variable_name($sname0);
    my ($dname, $deid, $nd, $dvar) = parse_variable_name($dname0);

    croak "variable $sname not defined.\n" if !defined $svar;

    # make a copy of rhs, if lhs is not defined.
    if (!defined $dvar) {
        if (defined $deid) {
            die "Error: cannot determine the number of elements of a variable '$dname'.\n" .
                "       define $dname before using it.\n";
        }

        $dvar = define_a_variable(
            {
                name     => $dname0,
                type     => $svar->{type},
                width    => $svar->{width},
                mantissa => $svar->{mantissa},
                nelement => $ns,
                io       => q{-},
                ctype    => q{-},
                operator => undef,
            }
        );
        vprintf("a variable '$dname' auto generated.\n");
        $nd = $ns;
        $deid = $seid;
    }

    for my $i (0 .. $nd - 1) {
        my $delement = $dvar->{elements}->[defined $deid ? $deid : $i];
        if (@{$delement->{children}}) {
            carp "Warning: previous assignment to '$delement->{name}' is overwritten.\n";
        }
    }

    inherit_attributes_of_a_number($dvar, $svar, $op); # special care for a NUMBER

    $dvar->{operator} = $op;

    if (!type_match($dvar, $svar) || $ns != $nd) {
        # note that $ns/$nd may or may not equal to the number of elements of $svar/$dvar.

        if ($svar->{operator} =~ /pg_store/) { # very exceptional care.
            $svar->{nelement} = $dvar->{nelement}; # fit storage size to the size of dvar.
        }
        else {
            type_mismatch($dvar, $svar);
        }
    }

    # assign the entire variable
    #

    # assignment to an individual component of a variable found.
    # gave up generating a 3D-view schematic.
    if (defined $deid) {
        $Schematic3D = 0;
    }

    if ($op eq 'connect') {

        if (is_leaf($svar) || defined $deid) {
            # make connection to $svar.
            #
            # before : dvar    svar(no_child)
            # after  : dvar -> svar(no_child)
            #
            for my $i (0 .. $nd - 1) {
                my $delement = $dvar->{elements}->[defined $deid ? $deid : $i];
                my $selement = $svar->{elements}->[defined $seid ? $seid : $i];
                $delement->{children} = [$selement];
            }
        }
        else { 
            # $svar is just a place holder. connect to its children.
            # $svar will be removed from the pipeline tree.
            #
            # before : dvar                     svar -> svar's_children
            # after  : dvar -> svar's_children  svar -> svar's_children
            #
            copy_a_variable($svar, $dvar);

            for my $i (0 .. $nd - 1) {
                my $delement = $dvar->{elements}->[defined $deid ? $deid : $i];
                my $selement = $svar->{elements}->[defined $seid ? $seid : $i];
                $delement->{children} = $selement->{children};
            }
        }
    }
    else {                    # connect svar to dvar
        # make connection to $svar.
        #
        # before : dvar    svar(no_child)
        # after  : dvar -> svar(no_child)
        #
        for my $i (0 .. $nd - 1) {
            my $delement = $dvar->{elements}->[defined $deid ? $deid : $i];
            my $selement = $svar->{elements}->[defined $seid ? $seid : $i];
            $delement->{children} = [$selement];
        }
    }

    return $dname0;
}



#############################################################
#
# sub routines below are for optional schematic drawings.
#

my $mwidth;
my $mheight;
my $xspace;
my $yspace;
my $Imgbuf = '';

sub draw_schematic {

    $mwidth    = 32;
    $mheight   = 15;
    $xspace    = 40;
    $yspace    = 10;

    # calculate image size
    my $imgwidth =  0;
    my $imgheight = 0;
    for my $var (sort {$a->{id} <=> $b->{id}} values %Var) {
        next if ($var->{io} ne 'fout') ;
        my $h0 = 0;
        for my $node (@{$var->{elements}}) { 
            my ($h, $w) = calc_image_size($node, 0, 0);
            if ($imgwidth < $w) {
                $imgwidth = $w;
            }
            if ($Schematic3D) {
                if ($h0 < $h) {
                    $h0 = $h;
                }
            }
            else {
                $h0 += $h;
            }
        }
        $imgheight += $h0;
    }
    dprintf("imgsize: $imgwidth, $imgheight\n");

    $imgwidth += 1;
    $imgwidth  *= ($mwidth  + $xspace);
    $imgwidth += $mwidth;
    $imgheight *= ($mheight + $yspace);
    $imgheight += $mheight / 2;

    # create a new image
    image_open($imgwidth, $imgheight);
    image_linewidth(0.7);

    # draw a tree for each 'fout' node
    image_moveto($imgwidth - $mwidth / 2, $imgheight - $mheight - $yspace);
    for my $var (sort {$a->{id} <=> $b->{id}} values %Var) {
        next if ($var->{io} ne 'fout') ;
        my $theight;
        my @nodes = $Schematic3D ? $var->{elements}->[0] : @{$var->{elements}};
        for my $node (@nodes) {
            $theight = draw_a_tree($node, 0, 0, undef);
            image_rmoveto(0, -($mheight + $yspace) * $theight);
        }
    }
    image_close();
    croak "$Imgoutfile: !$\n" if !open(OUT, "> $Imgoutfile");
    printf OUT $Imgbuf;
    close OUT;
    system("epstopdf $Imgoutfile");
}

sub calc_image_size {
    my ($node, $w, $wmax) = @_;
    my $h = 0;

    if (defined $node->{children} && @{$node->{children}} > 0 && !$node->{calculated}) {
        for my $c (@{$node->{children}}) {
            my ($hc, $wmaxc) = calc_image_size($c, $w+1, $wmax);
            $h += $hc;
            if ($wmax < $wmaxc) {
                $wmax = $wmaxc;
            }
        }
    }
    else {
        $h = 1;
        $wmax = $w;
    }
    $node->{calculated} = 1;
    return ($h, $wmax);
}

sub draw_a_tree {
    my ($node, $level, $hpos, $parent) = @_;
    my $height = 0;
    my $var = $node->{variable};
    my $drawn = $Schematic3D ? $var->{drawn} : $node->{drawn};
    
    image_push(); {
        image_rmoveto((-$xspace-$mwidth),
                      -($mheight + $yspace) * $hpos);
        my $cid = 0;
        if (defined $node->{children} && @{$node->{children}} > 0 && !$drawn) {
            my $nc = 0; # the number of children processed.
            for my $c (@{$node->{children}}) {
                my $tm = 0.4;                                      # top margin
                my $spc = (@{$node->{children}} > 1) ? (1 - $tm * 2) / (@{$node->{children}} - 1) : 0; # space between 2 lines
                my $dy = (@{$node->{children}} > 1) ? 1 - $tm - $spc * $nc : 0.5;
                $dy *= $mheight;
                my $dx = $mheight * $spc * $nc;

                image_push(); {
                    image_rmoveto(0, $dy);
                    image_rlinesto($xspace * (-0.15) + $dx, 0,
                                   0                      , -($mheight+$yspace) * $height - $dy + $mheight * 0.5,
                                   $xspace * (-0.95) - $dx, 0);
                }
                image_pop();
                $height += draw_a_tree($c, $level+1, $height, $node);
                $nc++;
            }
        }
        else {
            $height = 1;
        }

        draw_a_module($node, $parent);
        $Schematic3D ? $var->{drawn} : $node->{drawn} = 1;

    }
    image_pop();

    return $height;
}

sub draw_a_module {
    my ($node, $parent) = @_;
    my $var = $node->{variable};
    my $drawn = $Schematic3D ? $var->{drawn} : $node->{drawn};

    image_push(); {

        if (($var->{io} =~ /fout/)) { # output arrow
            image_push(); {
                image_rmoveto($mwidth * 0.9, $mheight * 0.5);
                image_rarrowto($mwidth * 1.4, 0);
            }
            image_pop();
        }
        if ($drawn && !is_leaf($var)) { # abbreviate descendant nodes
            my $dw = $mwidth * 0.03;
            image_push(); {
                image_abbrev_node($mwidth, $mheight);
            }
            image_pop();

            if (!$Schematic3D || defined $parent && $parent->{variable}->{nelement} == 1) {
                image_string($mwidth*1.2, $mheight*0.7, $node->{name});
            }
            else {
                image_string($mwidth*1.2, $mheight*0.7, $var->{name});
            }
        }
        else { # draw all descendant
            image_push(); {
                if (!$Schematic3D) {
                    image_a_node($var->{io}, $mwidth, $mheight);
                }
                elsif ($var->{nelement} < 5) { # a scalar node or a vector node with a few elements.
                    image_rmoveto(2*$var->{nelement}-1, -2*$var->{nelement}-1);
                    for my $i (0..$var->{nelement}-1) {
                        image_rmoveto(-2, 2);
                        image_a_node($var->{io}, $mwidth, $mheight);
                    }
                }
                else { # a vector node with a large number of elements.
                    image_rmoveto(2*5-1, -2*5-1);
                    for my $i (0..1) {
                        image_rmoveto(-2, 2);
                        image_a_node($var->{io}, $mwidth, $mheight);
                    }
                    image_push(); {
                        image_linewidth(0.3);
                        image_linetype(1, 1);

                        image_push(); {
                            image_rmoveto(0.8, 0.8);
                            image_rlineto(-2*3, 2*3);
                        }
                        image_pop();
                        image_push(); {
                            image_rmoveto(-0.8+$mwidth, 0.8);
                            image_rlineto(-2*3, 2*3);
                        }
                        image_pop();
                        image_push(); {
                            image_rmoveto(-0.8+$mwidth, -0.8+$mheight);
                            image_rlineto(-2*3, 2*3);
                        }
                        image_pop();
                    }
                    image_pop();
                    image_rmoveto(-2*3, 2*3);
                    image_a_node($var->{io}, $mwidth, $mheight);
                    image_string($mwidth*0.6, $mheight*(-0.35), 'x' . $var->{nelement});
                }
            }            
            image_pop();
            if ($var->{operator}) {
                image_string($mwidth*0.0, $mheight*0.5, $var->{operator});
            }
            elsif (($var->{io} !~ '-')) {
                image_string($mwidth*0.1, $mheight*0.5, $var->{io});
            }
            elsif (is_number($var)) {
                image_string($mwidth*0.1, $mheight*0.5, '"' . $var->{elements}->[0]->{literal} . '"');
            }
            else {
                image_string($mwidth*0.1, $mheight*0.5, '????');
            }

            my $ddelay = $node->{delay};
            if (defined $node->{children}->[0]) {
                $ddelay -= $node->{children}->[0]->{delay};
            }
            image_push();
            image_color(1.0, 0.0, 0.0);
            image_string($mwidth*0.2, $mheight*(0.0), $ddelay . ' / ' . $node->{delay});
            image_pop();

            if (!$Schematic3D || defined $parent && $parent->{variable}->{nelement} == 1) {
                image_string($mwidth*1.2, $mheight*0.7, $node->{name});
            }
            else {
                image_string($mwidth*1.2, $mheight*0.7, $var->{name});
            }
        }

        # type and width of module output
        # 
        image_push();
        image_color(0.0, 0.0, 1.0);
        if ($var->{type}) {
            image_string($mwidth*1.2, $mheight*(-0.1), $var->{type});
        }
        image_pop();
        if ($var->{width}) {
            image_push();
            image_linewidth(0.3);
            image_rmoveto($mwidth*1.6, $mheight*0.3);
            image_rlineto($mwidth*0.1, $mheight*0.4);
            image_pop();
            image_string($mwidth*1.7, $mheight*0.10, $var->{width});
        }
    }
    image_pop();
}

sub image_a_node {
    my ($io, $w, $h) = @_;

    if ($io =~ /jpin|ipin|cin|fout/) {
        image_io_node($w, $h);
    }
    else {
        image_rectangle($w, $h);
    }
}

sub image_string {
    my ($x, $y, $str) = @_;
    image_push(); {
        $Imgbuf .= sprintf("$x $y rmoveto\n");
        $Imgbuf .= sprintf("($str) show\n");
    }
    image_pop();
}

my %Imgpos;

sub image_moveto {
    my ($x, $y) = @_;
    $Imgbuf .= sprintf("$x $y moveto\n");
    $Imgpos{x} = $x;
    $Imgpos{y} = $y;
}

sub image_lineto {
    my ($x, $y) = @_;
    $Imgbuf .= sprintf("$x $y lineto\n");
    $Imgbuf .= sprintf("stroke\n\n");
    $Imgpos{x} = $x;
    $Imgpos{y} = $y;
}

sub image_rmoveto {
    my ($x, $y) = @_;
    $Imgbuf .= sprintf("$Imgpos{x} $Imgpos{y} moveto\n");
    $Imgbuf .= sprintf("$x $y rmoveto\n");
    $Imgpos{x} += $x;
    $Imgpos{y} += $y;
}

sub image_rlineto {
    my ($x, $y) = @_;
    $Imgbuf .= sprintf("$Imgpos{x} $Imgpos{y} moveto\n");
    $Imgbuf .= sprintf("$x $y rlineto\n");
    $Imgbuf .= sprintf("stroke\n\n");
    $Imgpos{x} += $x;
    $Imgpos{y} += $y;
}

sub image_rcurvesto {
    my @lines = @_;
    my $x0 = $Imgpos{x};
    my $y0 = $Imgpos{y};

    image_push(); {
        while (@lines) {
            my $x = shift @lines;
            my $y = shift @lines;
            $x0 += $x;
            $y0 += $y;
            $Imgbuf .= sprintf("$x0 $y0 ");
        }
        $Imgbuf .= sprintf("curveto\n");
        $Imgbuf .= sprintf("stroke\n\n");
    }
    image_pop();
}

sub image_rlinesto {
    my @lines = @_;
    $Imgbuf .= sprintf("$Imgpos{x} $Imgpos{y} moveto\n");
    while (@lines) {
        my $x = shift @lines;
        my $y = shift @lines;
        $Imgpos{x} += $x;
        $Imgpos{y} += $y;
        $Imgbuf .= sprintf("$x $y rlineto\n");
    }
    $Imgbuf .= sprintf("stroke\n\n");
}

sub image_rarrowto {
    my ($x, $y) = @_;
    image_push(); {
        $Imgbuf .= sprintf("$Imgpos{x} $Imgpos{y} moveto\n");
        $Imgbuf .= sprintf("%s %s %s %s arrow\n",
                           $Imgpos{x}, $Imgpos{y}, $Imgpos{x}+$x, $Imgpos{y}+$y);
        $Imgbuf .= sprintf("stroke\n\n");
    }
    image_pop();
    $Imgpos{x} += $x;
    $Imgpos{y} += $y;
}

sub image_linewidth {
    my ($width) = @_;
    $Imgbuf .= sprintf("%f setlinewidth\n", $width);
}

sub image_linetype {
    my @type = @_;
    $Imgbuf .= sprintf("[@type] 0 setdash\n");
}

sub image_color {
    my ($r, $g, $b) = @_;
    $Imgbuf .= sprintf("%f %f %f setrgbcolor\n", $r, $g, $b);
}

sub image_circle {
    my ($x, $y, $r) = @_;
    image_push(); {
        image_linewidth(0.3);
        $Imgbuf .= sprintf("%s %s moveto\n", $Imgpos{x}+$x, $Imgpos{y}+$y);
        $Imgbuf .= sprintf("newpath\n");
        $Imgbuf .= sprintf("%s %s %s 0 360 arc\n",
                           $Imgpos{x}+$x, $Imgpos{y}+$y, $r);
        $Imgbuf .= sprintf("gsave\n");
        $Imgbuf .= sprintf("1.0 1.0 1.0 setgray\n\n");
        $Imgbuf .= sprintf("fill\n\n");
        $Imgbuf .= sprintf("grestore\n");
        $Imgbuf .= sprintf("stroke\n\n");
    }
    image_pop();
}

sub image_roundrectangle {
    my ($w, $h, $linewidth) = @_;
    my $r = ($w > $h ? $h : $w) * 0.2;

    image_push(); {
        if (defined $linewidth) {
            image_linewidth($linewidth);
        }
        else {
            image_linewidth(0.3);
        }
        $Imgbuf .= sprintf("$Imgpos{x} $Imgpos{y} moveto\n");

        $Imgbuf .= sprintf("newpath\n");

        # bottom
        $Imgbuf .= sprintf("%s %s %s 180 270 arc\n",
                           $Imgpos{x}+$r, $Imgpos{y}+$r, $r);
        $Imgbuf .= sprintf("%d 0 rlineto\n", $w-$r*2);

        # right
        $Imgbuf .= sprintf("%s %s %s 270 360 arc\n",
                           $Imgpos{x}+$w-$r, $Imgpos{y}+$r, $r);
        $Imgbuf .= sprintf("0 %d rlineto\n", $h-$r*2);

        # top
        $Imgbuf .= sprintf("%s %s %s 0 90 arc\n",
                           $Imgpos{x}+$w-$r, $Imgpos{y}+$h-$r, $r);
        $Imgbuf .= sprintf("%d  0 rlineto\n", -$w+$r*2);

        #left
        $Imgbuf .= sprintf("%s %s %s 90 180 arc\n",
                           $Imgpos{x}+$r, $Imgpos{y}+$h-$r, $r);
        $Imgbuf .= sprintf("0 %d  rlineto\n", -$h+$r*2);

        $Imgbuf .= sprintf("closepath\n");

        $Imgbuf .= sprintf("gsave\n");
        $Imgbuf .= sprintf("1.0 1.0 1.0 setgray\n\n");
        $Imgbuf .= sprintf("fill\n\n");
        $Imgbuf .= sprintf("grestore\n");

        $Imgbuf .= sprintf("stroke\n\n");
    }
    image_pop();
}


=pod

h  -------
   |       \
h0 |       /
   -------
 0       w0 w
          w1
=cut
sub image_io_node {
    my ($w, $h, $linewidth) = @_;
    my $w0 = $w * 0.8;
    my $w1 = $w - $w0;
    my $h0 = $h * 0.5;
    image_push(); {
        $Imgbuf .= sprintf("newpath\n");
        if (defined $linewidth) {
            image_linewidth($linewidth);
        }
        else {
            image_linewidth(0.3);
        }
        $Imgbuf .= sprintf("$Imgpos{x} $Imgpos{y} moveto\n");
        $Imgbuf .= sprintf("$w0 0 rlineto\n");
        $Imgbuf .= sprintf("$w1 $h0 rlineto\n");
        $Imgbuf .= sprintf("-$w1 $h0 rlineto\n");
        $Imgbuf .= sprintf("-$w0 0 rlineto\n");
        $Imgbuf .= sprintf("0 -$h0 rlineto\n");
        $Imgbuf .= sprintf("closepath\n");

        $Imgbuf .= sprintf("gsave\n");
        $Imgbuf .= sprintf("1.0 1.0 1.0 setgray\n\n");
        $Imgbuf .= sprintf("fill\n\n");
        $Imgbuf .= sprintf("grestore\n");

        $Imgbuf .= sprintf("stroke\n\n");
    }
    image_pop();
}

sub image_rectangle {
    my ($w, $h, $linewidth) = @_;
    image_push(); {
        $Imgbuf .= sprintf("newpath\n");
        if (defined $linewidth) {
            image_linewidth($linewidth);
        }
        else {
            image_linewidth(0.3);
        }
        $Imgbuf .= sprintf("$Imgpos{x} $Imgpos{y} moveto\n");
        $Imgbuf .= sprintf("$w 0 rlineto\n");
        $Imgbuf .= sprintf("0 $h rlineto\n");
        $Imgbuf .= sprintf("-$w 0 rlineto\n");
        $Imgbuf .= sprintf("closepath\n");

        $Imgbuf .= sprintf("gsave\n");
        $Imgbuf .= sprintf("1.0 1.0 1.0 setgray\n\n");
        $Imgbuf .= sprintf("fill\n\n");
        $Imgbuf .= sprintf("grestore\n");

        $Imgbuf .= sprintf("stroke\n\n");
    }
    image_pop();
}

sub image_abbrev_node0 {
    my ($w, $h) = @_;
    my $w0 = $w * 0.1;
    my $h0 = $h * 0.5;
    my $h1 = $h * 0.4;
    image_push(); {
        $Imgbuf .= sprintf("newpath\n");
        image_rmoveto($w*0.9, $h0);
        image_rlineto(-$w0, +$h1);
        image_rmoveto(+$w0, -$h1);
        image_rlineto(-$w0, -$h1);
        image_rmoveto(+$w0, +$h1);

        image_rmoveto(-$w*0.1, 0);
        image_rlineto(-$w0, +$h1);
        image_rmoveto(+$w0, -$h1);
        image_rlineto(-$w0, -$h1);
        image_rmoveto(+$w0, +$h1);
    }
    image_pop();
}

sub image_abbrev_node {
    my ($w, $h) = @_;
    my $w0 = $w * 0.7;
    my $w1 = $w * 0.1;
    my $h0 = $h * 0.1;
    my $h1 = $h * 0.3;
    my $h2 = $h * 0.1;
    my $dw = $w * 0.07;

    image_push(); {
        image_linewidth(0.2);
        $Imgbuf .= sprintf("newpath\n");
        image_rmoveto(+$w0, $h0);
        image_rcurvesto(+$w1, $h1,
                        -$w1*1.5, $h2,
                        +$w1, $h1);
    }
    image_pop();

    image_push(); {
        image_linewidth(0.2);
        $Imgbuf .= sprintf("newpath\n");
        image_rmoveto(+$w0 + $dw, $h0);
        image_rcurvesto(+$w1, $h1,
                        -$w1*1.5, $h2,
                        +$w1, $h1);
    }
    image_pop();
}


my @poslist;
sub image_push {
    $Imgbuf .= "gsave\n";
    push @poslist, [$Imgpos{x}, $Imgpos{y}];
}

sub image_pop {
    $Imgbuf .= "grestore\n\n";

    my $pos_ref = pop @poslist;
    $Imgpos{x} = $pos_ref->[0];
    $Imgpos{y} = $pos_ref->[1];
}

sub image_open {
    my ($w, $h) = @_;

    my $psheader = << 'EOPSHEADER';
%%!PS-Adobe-3.0 EPSF-3.0
%%%%BoundingBox: 0 0 <W> <H>
%%%%Title: pgpg2 schematic
%%%%Creator: pgpg2
%%%%EndComments

/fontsz 7 def
/defaultFont /Times-Roman findfont fontsz scalefont def
%%/kanaFont /Ryumin-Light-H findfont fontsz 0.8 mul scalefont def
%%%%EndProlog

/arrow{ /halfheadwidth tipwidth 2 div def /halfarrowwidth arrowwidth 2 div def
  /tipy exch def /tipx exch def /taily exch def /tailx exch def /dx tipx tailx sub def
  /dy tipy taily sub def /arrowlength dx 2 exp dy 2 exp add sqrt def /angle dy dx atan def
  /base arrowlength tiplength sub def /baselength base tiplength ratio mul add def
  tailx taily translate angle rotate 0 halfarrowwidth neg moveto baselength 0 rlineto
  base halfheadwidth neg lineto arrowlength 0 lineto base halfheadwidth lineto
  baselength halfarrowwidth lineto baselength neg 0 rlineto closepath fill
  angle neg rotate tailx neg taily neg translate tipx tipy moveto }def

/arrowwidth  0.7 def
/tiplength   6.0 def
/tipwidth    4.0 def
/ratio       0.15 def

%%kanaFont setfont
defaultFont setfont
0.0 0.0 0.0 setrgbcolor
2 setlinejoin
EOPSHEADER

    $psheader =~ s/<W>/$w/g;
    $psheader =~ s/<H>/$h/g;
    $Imgbuf .= $psheader;
}

sub image_close {
    my $pstrailer = << 'EOPSTRAILER';
%%%%Trailer
EOPSTRAILER

    $Imgbuf .= $pstrailer;
}

__DATA__

# PG2 grammer definition ------------------------------------------------
#

PG2grammar:
  instruction(s) EOINPUT
  {
    $return = $item[1];
  }

instruction :
    comment_statement
 |  constant_statement
 |  parameter_statement
 |  definition_statement
 |  equation_statement
 |  nop
 | <error?><reject>

constant_statement:
    CONSTANT CONSTANT_KEY STRING ';'
    {
      $main::Constant{$item{CONSTANT_KEY}} = $item{STRING};
      $return = "$item{CONSTANT} $item{CONSTANT_KEY} defined as $item{STRING}.";
    }
 |  CONSTANT <error>

parameter_statement:
   PARAMETER PARAMETER_KEY STRING ';'
   {
     $main::Parameter{$item{PARAMETER_KEY}} = $item{STRING};
     $return = "$item{PARAMETER} $item{PARAMETER_KEY} defined as $item{STRING}.";
   }
 | PARAMETER <error>


definition_statement:
    TYPE VARIABLE(s /,/) IO(?) ';'
    {
      main::define_variables($item{TYPE}, $item[2], $item[3]);
      $return = "variable of type $item{TYPE} @{$item[2]} defined" .
                (@{$item[3]} > 0 ? " as @{$item[3]}." : ".");
    }
 |  TYPE VARIABLE(s /,/) IO(?) <commit><error>
 |  TYPE <error>

equation_statement :
    <rightop: VARIABLE ASSIGN expr> ';'
    {
      $return = main::assign_terms_to_variables(@{$item[1]});
    }
    | VARIABLE ASSIGN <commit><error>
    | VARIABLE <error>

expr:
    conditional_expr

conditional_expr:
    relational_expr '?' relational_expr ':' conditional_expr
    {
        $return = main::select_one_of_two($item[1], $item[3], $item[5]);
    }
 |  relational_expr '?' relational_expr ':' <error>
 |  relational_expr '?' relational_expr <error>
 |  relational_expr '?' <error>
 |  relational_expr

relational_expr:
    <leftop: shift_expr /(\=\= | \!\= | \>\= | \<\= | \<|\> )/x shift_expr>
    {
      $return = main::combine_variables(@{$item[1]});
    }
 |  shift_expr <commit><error>

shift_expr:
    <leftop: additive_expr /( \<\< | \>\> )/x additive_expr>
    {
      $return = main::combine_variables(@{$item[1]});
    }
 |  additive_expr <commit><error>

additive_expr :
    <leftop: multiplicative_expr /( \+ | \- )/x multiplicative_expr>
    {
        $return = main::combine_variables(@{$item[1]});
    }
 |  multiplicative_expr <commit><error>

multiplicative_expr : <leftop: unary_expr /( \* | \/ )/x unary_expr> {
          $return = main::combine_variables(@{$item[1]});
       }

unary_expr :
    '(' TYPE ')' unary_expr
    {
      $return = main::convert_a_variable($item{TYPE}, $item{unary_expr});
    }
 | '(' expr ')'
    {
      my $name = $item{expr};
      if (!defined $main::Var{$name}) {
        printf STDERR ("Warning: variable '$name' not defined.\n");
        $return = undef;
      }
      $return = $name;
    }
 | atmF
 | atmV
 | atmN

atmF :
    FUNCTION '(' expr(s? /,/) ')'
    {
      $return = main::define_function($item{FUNCTION}, $item[3]);
    }
 |  FUNCTION '(' expr(s? /,/) <commit><error>
 |  FUNCTION '(' <commit><error>
 |  FUNCTION <commit><error>

atmV :
    VARIABLE
    {
      $item{VARIABLE} =~ /([a-zA-Z_]\w*)(\[\d+\])?/;
      my $name = $1;
      if (!defined $main::Var{$name}) {
        printf STDERR ("Warning: variable '$name' not defined.\n");
        $return = undef;
      }
      $return = $item{VARIABLE};
    }

atmN : 
    NUMBER
    {
        $return = main::define_a_number($item{NUMBER});
    }

comment_statement :
    m{\s*                       # optional whitespace
      //                        # comment delimiter
      [^\n]*                    # anything except a newline
      \n                        # then a newline
     }x                         # do nothing

  | m{\s*                       # optional whitespace
      /\*                       # comment opener
      (?:[^*]+|\*(?!/))*        # anything except */
      \*/                       # comment closer
      ([ \t]*)?                 # trailing blanks or tabs
     }x                         # do nothing

nop : ';'

# Terminals

reserved_token:
  CONSTANT
| PARAMETER
| PARAMETER_KEY
| TYPE
| ASSIGN

CONSTANT_KEY  : /[a-zA-Z_]\w*/

PARAMETER_KEY :
  /(?:
     ARCH | BACKENDID | PREFIX | NPIPE | DELAY | JMEMSIZE |   # parameter keywords
     USE_FIXED_CHIPID | CHIPID | HEADERPATH | LIBPATH
   )
   (?= [\s+|\t+])/x                                           # followed by space(s) or tab(s).


TYPE      : /int\d+/ | /float\d+\.\d+/ | /log\d+\.\d+/
NUMBER    : /[\+\-]?\d+(?:.\d+)?/     # a literal number
VARIABLE  : ...!reserved_token /[a-zA-Z_]\w*(\[\d+\])?/
FUNCTION  : /[a-zA-Z_]\w*/
IO        : / (?: \( (?: int | double ) \))? (?: ipin | jpin | fout | cin ) /x
STRING    :  /[^\n\;]*/           # whatever text other than semicolon & new line
EOINPUT   : /^\Z/
ASSIGN    : /( \= | \+= )/x

CONSTANT  : 'constant'
PARAMETER : 'parameter'

# end of PG2 grammer definition -----------------------------------------
