#!/usr/bin/perl

# script for expanding condensed netlist format

# Syntax:
#
# netspec Type CHIP-pin ...
#
# CHIP npins ...pin-spec-item...
#            ...pin-spec-item...
#   defines some pins from CHIP which has pins 1..npins
#
# minline-maxline/perchip CHIP pins ...pin-spec-item...
#                                   ...pin-spec-item...
#   Defines some pins from several chips.  See assignpins_multi comment.
#
# !PIC picpinlist
#   Defines PIC pins - see assignpicpins
#
# !type Type ...netspec/netrange...
#            ...netspec/netrange...   [see below for netrange]


# CHIP is [A-Z][A-Z0-9]*
#
# netspec is net[,net]* and indicates that all the nets are aliases for same
#   net even if not mentioned together anywhere else
#
# net is [a-z][a-z0-9_]*
#
# pin-spec-item is one of
#
#      netspec       assigns next pin to netspec
#
#      net{ fornet }{ usegate }
#                    remapping specification:
#                    every time net\d+ would be assigned instead,
#                    this remapping table is consulted.  fornet
#                    and usegate are lists of net assignments or
#                    just digits (which are taken to mean net\d+);
#                    they must be of equal length and will be taken
#                    pairwise as instructions that each time an entry in
#                    usegate is to be assigned, the corresponding entry
#                    from fornet will be used instead.
#
#      net\d+..\d+   netrange: specifies sequentially named nets
#                    nets will be net\d+ where numbers will go from first
#                    \d+ to 2nd \d+ in pin-spec-item inclusive (whether
#                    up or down)
#
#      pin           asserts that next pin number to assign would be pin
#
#      :start[step][%jump/modulo][,number,:start[step]...]
#                    specifies that the next pin to assign will be start,
#                    and what the following pin will be to assign, and so
#                    on in arithmetic sequence indefinitely until the
#                    next :start[... etc.
#                      start can be pin (meaning to start with pin)
#                            or -backpin meaning to start with npins-backpin
#                      step can be + or - to indicate +1 or -1 or
#                            a possibly negative number
#                      %jump/modulo means don't generate a simple
#                            arithmetic sequence; instead, generate
#                            modulo arithmetic sequences starting at
#                            start, start+jump, ... start+(modulo-1)*jump
#                            and then interleave the sequences to
#                            generate the sequence of pins to assign
#                      :number:start...
#                            means to assign only number pins in this
#                            way and then to start with a new (set of)
#                            sequences as defined by :start etc.
#      : stuff things etc ... :
#                    is as if you wrote   :stuff:things:etc...

die if $ARGV[0] =~ m/^\-/;

sub o ($$$) {
    my ($netname, $type, $stuff) = @_;
    print "# o $netname $type $stuff\n" or die $!;
    if (length $type && exists $net{$netname}{Type}) {
	die "$netname $type" if $net{$netname}{Type} ne $type;
    }
    $net{$netname}{Stuff}.= " ".$stuff;
    $net{$netname}{Type}= $type if length $type;
}

sub expand_netranges (@) {
    my (@in) = @_;
    local ($_);
    my (@expanded) = ();
    foreach $_ (@in) {
	if (m/^(\w*[A-Za-z])(\d+)\.\.(\d+)$/) {
	    my ($base,$start,$end)=($1,$2,$3);
	    my ($step)= $start<=$end ? 1 : -1;
	    for ($i=$start; $i!=$end+$step; $i+=$step) {
		push @expanded, $base.$i;
	    }
	} elsif (m/^(\w+)\*(\d+)/) {
	    my ($base,$end)=($1,$2);
	    die unless $end >= 1;
	    for ($i=1; $i<=$end; $i++) {
		push @expanded, $base;
	    }
	} else {
	    push @expanded, $_;
	}
    }
    return @expanded;
}

sub unpack_iter_list ($$@) {
    my ($max,$options,@in) = @_;
    # options: zero or more characters from
    #     r   allow several occurrences of same pin number
    #     p   allow only partial specification
    #     o   return array of pins (first entry is undef) in order
    #           instead of array of  { Pin =>, Action => }
    my (@expanded, @done, @out);
    my ($i);
    local ($_);

    @expanded= expand_netranges(@in);

    my $start= 1;
    my $step= 1;
    my $jump= 0;
    my $modulo= '';
    my $counter= 0;
    my $limitcounter= '';
    my ($usepin, $remainder, $quotient, $afterlimit);
    my (@toprocess) = @expanded;
    my (%gatemap);
    while (@toprocess) {
	$_= shift @toprocess;
	if (!length $modulo) {
	    $remainder= 0;
	    $quotient= $counter;
	} else {
	    $remainder= $counter % $modulo;
	    $quotient= ($counter-$remainder) / $modulo;
	}
	$usepin=
	    ($start +
	     $step * $quotient +
	     $jump * $remainder);
	if (m/^(\w+)\{$/) {
	    my ($netbase) = $1;
	    my (@fornet,@usegate,$i);
	    my ($current) = \@fornet;
	    for (;;) {
		die unless @toprocess;
		$_= shift @toprocess;
		if (m/^\}\{$/) {
		    die unless $current==\@fornet;
		    $current= \@usegate;
		} elsif (m/^\}$/) {
		    die unless $current==\@usegate;
		    last;
		} elsif (m/^(?:[a-z]\w*|\-)$/) {
		    push @$current, $&;
		} elsif (m/^\d+$/) {
		    push @$current, $netbase.$&;
		} else {
		    die "$_ (@in) (@expanded)";
		}
	    }
	    die "(@fornet) (@usegate (@in) (@expanded)"
		unless @fornet == @usegate;
	    for ($i=0; $i<@fornet; $i++) {
		$gatemap{$fornet[$i]}= $usegate[$i];
	    }
	} elsif (m/^\d+$/) {
	    die "$_ != $usepin $max (@in) (@expanded)"
		if $usepin ne $&;
	} elsif (
 m/^\:(\-?)(\d+)(?:([-+]\d+)|([-+])|)(?:\%(\-?\d+)\/(\d+))?(?:\:(\d+)\:(.*))?$/
		 ) {
	    my ($back,$base,$stepval,$sign)=($1,$2,$3,$4);
	    ($jump,$modulo,$limitcounter,$afterlimit)=($5,$6,$7,$8);
	    $start= length $back ? $max-$base : $base;
	    $step= length $stepval ? $stepval : length $sign ? $sign.'1' : 1;
	    $counter= 0;
	} elsif (m/^\:$/) {
	    my ($accum) = '';
	    for (;;) {
		die "end (@in) (@expanded)" unless @toprocess;
		$_= shift @toprocess;
		last if m/^\:$/ && length $accum;
		die "$_ (@in) (@expanded)" if m/\:/;
		$accum .= ':'.$_;
	    }
	    unshift @toprocess, $accum;
	} elsif (m/^\:/) {
	    die "$_ (@in) (@expanded)";
	} else {
	    if ($_ ne '-') {
		die "$usepin<1 $_ $max (@in) (@expanded)"
		    if $usepin < 1;
		die "$usepin>$max $_ $max (@in) (@expanded)"
		    if $usepin > $max;
		die "already $done[$usepin] $_ $max (@in) (@expanded)"
		    if ($options !~ m/r/) && defined $done[$usepin];
		$_= $gatemap{$_} if exists $gatemap{$_};
		push @out, { Pin => $usepin, Action => $_ };
		$done[$usepin]= $_;
	    }
	    $counter++;
	    if (length $limitcounter && $counter == $limitcounter) {
		unshift @toprocess, ":$afterlimit";
	    }
	}
    }
    if ($options !~ m/p/) {
	for ($i=1; $i<$max; $i++) {
	    die "$i missing $max (@in) (@expanded)" unless defined $done[$i];
	}
    }
    print "# uil $max $options $max (@in) => (@done)\n";
    return ($options =~ m/o/) ? @done : @out;
}

sub definepicpins (@) {
    die if defined $numpicpins;
    die unless @_;
    $numpicpins = shift @_;
    my (@l) = unpack_iter_list($numpicpins,'o',@_);
    my ($i);
    local ($_);
    for ($i=1; $i<@l; $i++) {
	$_= $l[$i];
	if (m/^[A-Z]/) {
	    die "$_ repeated" if exists $picport2pin{$_};
	    $picpin2port{$i}= $_;
	    $pinport2pin{$_}= $i;
	} else {
	    $picpin2port{$i}= $_;
	    o($_,'',"PIC-$i");
	}
    }
}

sub assignpicpins (@) {
    die unless defined $numpicpins;
    my (@l) = unpack_iter_list($numpicpins,'o',@_);
    my ($i, $port);
    for ($i=1; $i<@l; $i++) {
	$_= $l[$i];
	$port= exists $picpin2port{$i} ? $picpin2port{$i} : '';
	if ($port =~ m/^[a-z]/) {
	    die "$i $_ $port" unless $port eq $_;
	} else {
	    o($_,'',"PIC-$i");
	}
    }
}

sub assignpins (@) {
    my ($name,$pins,@il) = @_;
    my ($e);
    foreach $e (unpack_iter_list($pins,'p',@il)) {
	o($e->{Action},'',$name.'-'.$e->{Pin});
    }
}

sub assignpins_multi ($$@) {
    # Args are  linemin linemax linesperchip  and a list like for assignpins
    # assignpins is done several times to handle all of the lines.
    # Each iteration (aka `chip') handles (up to) linesperchip
    # lines, starting at linemin for the first chip.  The last
    # chip may be partial.
    # List may contain extra characters, which are substituted:
    #   @      chip number (starts at 0)
    #   &      lines handled by this chip (linesperchip except for last chip)
    #   <      first line handled by this chip
    #   >      last line handled by this chip
    #   X@@Y   X for all `full' chips, Y for any incomplete chip
    my ($line_min, $line_max, $perchip, @il) = @_;
    my ($chipno, $line_low, $line_high, $linesthischip, @ol, $full_chip);
    print "# m $line_min $line_max $perchip (@il)\n";
    for ($chipno=0;
	 ($line_low = $line_min + $perchip*$chipno) <= $line_max;
	 $chipno++) {
	$line_high= $line_low + $perchip-1;
	$full_chip= $line_high <= $line_max;
	$line_high= $line_max if !$full_chip;
	$linesthischip= $line_high - $line_low + 1;
	@ol= @il;
	map {
	    s/^(.*)\=\=(.*)$/ $full_chip ? $1 : $2 /ge;
	    s/\=/ $chipno /ge;
	    s/\</ $line_low /ge;
	    s/\>/ $line_high /ge;
	    s/\&/ $linesthischip /ge;
	    $_;
	} @ol;
	print "# m$chipno (@ol)\n";
	assignpins(@ol);
    }
}

sub data_fin () {
    return if !length $data_accum;
    local ($_);
    my (@s) = split /\s+/, $data_accum;
    if ($data_accum =~ s,^(\d+)\-(\d+)/(\d+)\s+,,) {
	@s= split /\s+/, $data_accum;
	assignpins_multi($1,$2,$3, @s);
    } elsif ($data_accum =~ m/^\!PIC\-ASSIGN\s/) {
	shift @s;
	assignpicpins(@s);
    } elsif ($data_accum =~ m/^\!PIC\-DEFINE\s/) {
	shift @s;
	definepicpins(@s);
    } elsif ($data_accum =~ m/^\!type\s+[A-Z]\w+\s+/) {
	shift @s;
	my ($type) = shift @s;
	map { o($_,$type,''); } expand_netranges(@s);
    } elsif ($data_accum =~ m/^\!/) {
	die "bad directive $data_accum";
    } else {
	assignpins(@s);
    }
    undef $data_accum;
} 

while (<>) {
    next if m/^\#/;
    next unless m/\S/;
    chomp;
    s/\s+$//;
    if (s/^\s+//) {
	die unless length $data_accum;
	$data_accum .= " ".$_;
	next;
    }
    data_fin();
    if (m/^([a-z]\S+)\s+(\S+)(\s+(\S.*\S))?$/) {
	o($1,$2,$3);
    } elsif (m/^\!/ || m/^[A-Z].*/ || m,^\d+\-\d+/\d+\s+[A-Z],) {
	$data_accum= $_;
    } else {
	die "$_ ?";
    }
}
data_fin();

# Firstly, assemble
#   $othernames{$sn}{$sn2}=1 iff $sn and $sn2 are mentioned together
# by iterating over all composite names, and then for each sn
# in the composite name, to find (at least once) every sn ever
# mentioned ...
foreach $compname (keys %net) {
    foreach $sn (split /\,/, $compname) { # at least once for any $sn
	next if exists $othernames{$sn}; # already done ?
	$othernames{$sn}= { };
	# now look for all names mentioned together with $sn
	foreach $compname2 (keys %net) {
	    # search all composite names ...
	    @sns2= split /\,/, $compname2; # ... whose mentions ...
	    next unless grep { $_ eq $sn } @sns2; # ... include $sn ...
	    map { $othernames{$sn}{$_}=1; } @sns2; # ... recording mentions.
	}
    }
}

sub add_other_sn($$$) {
    my ($stack,$me,$ofthis) = @_;
    my (@others,$other);
    return if $othernames{$me}{$ofthis} == 2;
    $othernames{$me}{$ofthis}= 2;
    @others= keys %{ $othernames{$me} };
    print "# tc $stack (@others)\n";
    foreach $other (@others) {
	add_other_sn($stack.">$other",$me,$other);
	add_other_sn($stack."<$other",$other,$me);
    }
}

# Now compute the transitive closure of %othernames
foreach $sn (keys %othernames) {
    add_other_sn($sn,$sn,$sn);
}

# Process each net exactly once.  We go through the singlenames
# and process each singlename if it's the lexically least singlename
# for that net.
foreach $sn (keys %othernames) {
    @sns= sort { $a cmp $b } keys %{ $othernames{$sn} }; # singlenames in order
    next unless $sns[0] eq $sn; # is this the lexcially least ?
    $canon= join '__', @sns;
    undef $type;
    $stuff= '';
    foreach $compname (keys %net) {
	@sns2= split /\,/, $compname;
	print "# snq $sn $canon $compname (@sns2)\n";
	next unless exists $othernames{$sn}{$sns2[0]};
	print "# sna $sn $canon $compname ($net{$compname}{Stuff})\n";
	if (!exists $net{$compname}{Type}) {
	} elsif (!defined $type) {
	    $type= $net{$compname}{Type};
	} elsif ($type ne $net{$compname}{Type}) {
	    die "$compname $canon $type $net{$ccompname}{Type}";
	}
	$stuff .= $net{$compname}{Stuff};
    }
    print "# snr $sn $canon $type (@sns) ($stuff)\n";
    map {
	if (length) {
	    $pinuse{$_}++;
	    m/\-/ or die "$_ ?";
	    $chipuse{$`}++;
	}
    } split /\s+/, $stuff;
    $type= 'Signal' if !defined $type;
    $propernet{$canon}{Type}= $type;
    $propernet{$canon}{Stuff}= $stuff;
}

foreach $pinuse (sort keys %pinuse) {
    print "# pin $pinuse $pinuse{$pinuse}\n";
}
foreach $chipuse (sort keys %chipuse) {
    print "# chip $chipuse $chipuse{$chipuse}\n";
}

foreach $canon (sort keys %propernet) {
    @stuff= sort { $a cmp $b } split /\s+/, $propernet{$canon}{Stuff};
    $output= sprintf("%s\t%s\t%s\n",
		     $canon,
		     $propernet{$canon}{Type},
		     join ' ', @stuff);
    while ($output =~ m/.{80,}/m) {
	$lhs= $`;
	$rhs= $';
	$mid= $&;
	$mid =~ s/^(.{1,60})[\t ]/$1\\\n\t\t/m
	    or die "overlong $output ($lhs|$mid|$rhs)";
	$output = $lhs.$mid.$rhs;
    }
    print $output
	or die $!;
}