#! /usr/local/bin/perl
#
# addtnm -- read .tnm file and add TNM parameters to corresponding
#           path endpoints in XFF file
#
# addtnm [-d] <design>
#
# revision 2.5.1.2

$script_name    = "addtnm";
$script_version = "2.3.4";

print( "$script_name Version $script_version\n" );
print( "(c) Copyright 1994-1995 Xilinx Inc. All rights reserved.\n\n" );

&usage() if ( ! @ARGV );

#
# process arguments
#
$bad_args = 0;

foreach $arg ( @ARGV )
{
  if ( $arg =~ m|^-(\S+)$| )
  {
    if ( $1 eq "d" )
    {
      $debug = 1;
      print( "$script_name: debugging mode enabled ...\n" );
    }
    else
    {
      print( "$script_name: ERROR: option $1 not recognized.\n" );
      ++$bad_args;
    }
  }
  elsif ( ! $base )
  {
    $base = $arg;
  }
  else
  {
    print( "$script_name: ERROR: extra file name $arg specified.\n" );
    ++$bad_args;
  }
}

if ( $bad_args != 0 )
{
  print( "$script_name: ERROR: could not process $bad_args argument(s)\n\n" );
  &usage();
}

#
# define file names
#
if ( $base =~ /\./ )
{
  $base = substr( $base, 0, rindex( $base, "." ) );
}

if ( ! -e ( $tnm_file = $base.".tnm" ) )
{
  die( "$script_name: ERROR: $tnm_file does not exist.\n\n" );
}
if ( ! -e ( $xff_file = $base.".xff" ) )
{
  die( "$script_name: ERROR: $xff_file does not exist.\n\n" );
}
$out_file = $base.".txff";

#
# record timestamp
#
$got_pkg = eval( "require( \"ctime.pl\" )" );
if ( defined( $got_pkg ) && $got_pkg )
{
  $timestamp = &ctime( time );
  chop $timestamp;
}

#
# process control file
#
open( TNM, $tnm_file ) || die;

print( "$script_name: reading control file $tnm_file ...\n" );

$tnm_errors = 0;

while ( <TNM> )
{
  #
  # store signal TNMs 
  #
  if ( m|^\s*SIG\s+(\S+)\s*:\s*(.*)$|i )
  {
    if ( $2 !~ m|^\s*$| )
    {
      $sig_table{ $1 } = $2;
      $sig_status{ $1 } = 0;
    }
  }
  #
  # store pad TNMs
  #
  elsif ( m|^\s*PADS\s+(\S+)\s*:\s*(.*)$|i )
  {
    if ( $2 !~ m|^\s*$| )
    {
      $pads_table{ $1 } = $2;
      $pads_status{ $1 } = 0;
    }
  }
  #
  # store RAM TNMs
  #
  elsif ( m|^\s*RAMS\s+(\S+)\s*:\s*(.*)$|i )
  {
    if ( $2 !~ m|^\s*$| )
    {
      $rams_table{ $1 } = $2;
      $rams_status{ $1 } = 0;
    }
  }
  #
  # store flip-flop TNMs (no keyword defaults to FFS)
  #
  elsif ( ( m|^\s*FFS\s+(\S+)\s*:\s*(.*)$|i )
        || ( m|^\s*(\S+)\s*:\s*(.*)$|i ) )
  {
    if ( $2 !~ m|^\s*$| )
    {
      $ffs_table{ $1 } = $2;
      $ffs_status{ $1 } = 0;
    }
  }
  #
  # bad statement detected
  #
  elsif ( ! ( m|^#| || m|^\s*$| ) )
  { 
    print( "$script_name: ERROR: line $. of $tnm_file not recognized.\n" );
    ++$tnm_errors;
  }
}

close( TNM );

if ( $tnm_errors != 0 )
{
  die( "$script_name: ERROR: $tnm_errors error(s) found in $tnm_file.\n\n" );
}

#
# add TNMs to XFF file
#
open( XFF, $xff_file ) || die;
open( OUT, ">".$out_file ) || die;

print( "$script_name: processing XFF file $xff_file ...\n" );

while ( <XFF> )
{
  chop;

  #
  # process SYM records
  #
  if ( m|^\s*SYM\s*,\s*([^,]+)\s*,\s*([^,]+)\s*,*\s*(.*)$|i )
  {
    ( $symname, $symtype, $symparams ) = ( $1, $2, $3 );

    if ( &is_flop( $symtype ) ) # found a flip-flop SYM record
    {
      if ( @newgroups = 
           &grep_object_table( $symname, *ffs_table, *ffs_status ) ) # instance matched
      {
        $newparams = &merge_tnms( $symparams, @newgroups );
        if ( $debug )
        {
          print( "$script_name: $symname ($symtype) got TNM(s) @newgroups\n" );
        }
        printf( OUT "SYM, %s, %s, %s\n", $symname, $symtype, $newparams );
      }
      else # not found in instance table
      {
        printf( OUT "%s\n", $_ );
      }
    }
    elsif ( &is_ram( $symtype ) ) # found a RAM
    {
      if ( @newgroups = 
           &grep_object_table( $symname, *rams_table, *rams_status ) ) # instance matched
      {
        $newparams = &merge_tnms( $symparams, @newgroups );
        if ( $debug )
        {
          print( "$script_name: $symname ($symtype) got TNM(s) @newgroups\n" );
        }
        printf( OUT "SYM, %s, %s, %s\n", $symname, $symtype, $newparams );
      }
      else # not found in instance table
      {
        printf( OUT "%s\n", $_ );
      }
    }
    elsif ( &is_xblox_io( $symtype ) ) # found an XBLOX I/O symbol
    {
      #
      # search pads_table for XBLOX I/O; possible name clash if
      # XBLOX symbols are given same names as unrelated EXTs;
      # other possibility is to add /PAD or value of PADNAME
      #
      if ( @newgroups = 
           &grep_object_table( $symname, *pads_table, *pads_status ) ) # instance matched
      {
        $newparams = &merge_tnms( $symparams, @newgroups );
        if ( $debug )
        {
          print( "$script_name: $symname ($symtype) got TNM(s) @newgroups\n" );
        }
        printf( OUT "SYM, %s, %s, %s\n", $symname, $symtype, $newparams );
      }
      else # not found in instance table
      {
        printf( OUT "%s\n", $_ );
      }
    }
    else # not a flip-flop or RAM or XBLOX I/O
    {
      printf( OUT "%s\n", $_ );
    }
  }
  #
  # process EXT records
  #
  elsif ( m|^\s*EXT\s*,\s*([^,]+)\s*,\s*(.)\s*,?\s*([^,]*)\s*,?\s*(.*)$|i )
  {
    ( $padname, $paddir, $pinnum, $extparams ) = ( $1, $2, $3, $4 );

    if ( @newgroups =
         &grep_object_table( $padname, *pads_table, *pads_status ) ) # pad matched
    {   
      $newparams = &merge_tnms( $extparams, @newgroups );
      if ( $debug )
      { 
        print( "$script_name: I/O pad $padname got TNM(s) @newgroups\n" );
      }
      printf( OUT "EXT, %s, %s, %s, %s\n", $padname, $paddir, $pinnum, $newparams );
    }
    else # not found in pad table
    {
      printf( OUT "%s\n", $_ );
    }
  } 
  #
  # process PIN records
  #
  elsif ( m|^\s*PIN\s*,\s*([^,]+)\s*,\s*I\s*,\s*([^,]+)\s*,?[^,]*,?\s*(.*)$|i )
  {
    ( $pinname, $signame, $pinparams ) = ( $1, $2, $3 );

    if ( @newgroups =
         &grep_object_table( $signame, *sig_table, *sig_status ) ) # signal matched
    {
      $newparams = &merge_tnms( $pinparams, @newgroups );
      if ( $debug )
      {
        print( "$script_name: pin on $signame got TNM(s) @newgroups\n" );
      }
      printf( OUT "PIN, %s, I, %s,, %s\n", $pinname, $signame, $newparams );
    }
    else # not found in signal table
    {
      printf( OUT "%s\n", $_ );
    }
  }
  #
  # append PROG record to LCANET record
  #
  elsif ( m|^\s*LCANET.*$|i )
  {
    printf( OUT "%s\n", $_ );
    printf( OUT "PROG, %s, %s, \"%s\"\n",
            $script_name,
            $script_version,
            "Added TNMs from $tnm_file: ".$timestamp );
  }
  #
  # other record type
  #
  else
  {
    printf( OUT "%s\n", $_ );
  }
}

close( XFF );
close( OUT );

#
# report unmatched instances and signals
#
&rpt_nomatch( *ffs_status, "flip-flops" );
&rpt_nomatch( *rams_status, "RAMs" );
&rpt_nomatch( *pads_status, "I/O pads" );
&rpt_nomatch( *sig_status, "signals" );

print( "$script_name: updated XFF file written to $out_file ...\n\n" );


#---------------------------------------------------------------------------
#
# make_regex( wildcard_string )
#
#   convert name string with * and ? wildcards into regular expression
#   string, anchored at beginning and end, and escape $ characters
#
sub make_regex
{
  local( $wildcard_string ) = @_;

  $wildcard_string =~ s'\$'\$'g;

  $wildcard_string =~ s'\*'.*'g;

  $wildcard_string =~ s'\?'.'g;

  '^'.$wildcard_string.'$';
}

#---------------------------------------------------------------------------
#
# is_flop( symtype )
#
#   return true if symbol type represents a flip-flop
#   (including FFS-type XBLOX symbols)
#
sub is_flop
{
  local( $symtype ) = @_;

  $symtype =~ tr|a-z|A-Z|; # force symtype to all upper case

  ( $symtype eq "DFF" )
  || ( $symtype eq "INFF" )
  || ( $symtype eq "INLAT" )
  || ( $symtype eq "INREG" )
  || ( $symtype eq "OUTFF" )
  || ( $symtype eq "OUTFFT" )
  || ( $symtype eq "ACCUM" )
  || ( $symtype eq "SHIFT" )
  || ( $symtype eq "COUNTER" )
  || ( $symtype eq "DATA_REG" )
  || ( $symtype eq "CLK_DIV" );
}

#---------------------------------------------------------------------------
#
# is_xblox_io( symtype )
#
#   return true if symbol type represents an XBLOX I/O symbol
#
sub is_xblox_io
{
  local( $symtype ) = @_;

  $symtype =~ tr|a-z|A-Z|; # force symtype to all upper case

  ( $symtype eq "INPUTS" )
  || ( $symtype eq "OUTPUTS" )
  || ( $symtype eq "BIDIR_IO" )
}

#---------------------------------------------------------------------------
#
# is_ram( symtype )
#
#   return true if symbol type represents a RAM, including XC4000E
#   RAM primitives and RAMS-type XBLOX symbols
#
sub is_ram
{
  local( $symtype ) = @_;

  $symtype =~ tr|a-z|A-Z|; # force symtype to all upper case

  ( $symtype eq "RAM" )
  || ( $symtype eq "RAMS" )
  || ( $symtype eq "RAMD" )
  || ( $symtype eq "SRAM" )
  || ( $symtype eq "SYNC_RAM" )
  || ( $symtype eq "DP_RAM" )
}

#---------------------------------------------------------------------------
#
# merge_tnms( $params, @newgroups )
#
#   merge new group names into existing TNM parameters (if any) and
#   return complete XNF parameter string
#
sub merge_tnms
{
  local( $params, @newgroups ) = @_;

  local( @paramlist );
  local( $param );
  local( @otherparams );
  local( @tnmparams );

  @paramlist = split( /\s*,\s*/, $params ); # get existing parameters

  while ( @paramlist ) # divide into TNM and other parameters
  {
    if ( ( $param = pop( @paramlist ) ) =~ /^TNM=(.+)/ )
    {
      push( @tnmparams, split( /;/, $1 ) );
    }
    else
    {
      push( @otherparams, $param );
    }
  }

  $param = "TNM=" . join( ";", @tnmparams, @newgroups ); # make new TNM

  join( ", ", $param, @otherparams ); # return all parameters
}

#---------------------------------------------------------------------------
#
# grep_object_table( $srcname, *object_table, *status_table )
#
#   find srcname in keys( %object_table ) and return corresponding values;
#   mark as matched in %status_table
#
sub grep_object_table
{
  local( $srcname, *object_table, *status_table ) = @_;

  local( @newgroups );
  local( @namelist );
  local( $name );
  local( $regex );

  @newgroups = ();
  @namelist = keys( %object_table );

  while ( @namelist ) # search for matching name from table keys
  {
    $name = pop( @namelist ); 
    $regex = &make_regex( $name );

    if ( $srcname =~ m|$regex|i )
    {
      push( @newgroups, split( /\s+/, $object_table{ $name } ) );
      $status_table{ $name } = 1;
    }
  }

  @newgroups;
}

#---------------------------------------------------------------------------
#
# rpt_nomatch( *status_table, $object_name )
#
#   find objects in status_table not marked as found and report same
#
sub rpt_nomatch
{
  local( *status_table, $object_name ) = @_;

  local( @next );

  while ( @next = each( %status_table ) )
  {
    if ( ! $next[1] )
    {
      print( "$script_name: WARNING: no $object_name matched to \"$next[0]\"\n" );
    }
  }
}


#---------------------------------------------------------------------------
#
# usage()
#
sub usage
{
  print( "usage: addtnm [-d] <design>\n\n" );
  print( "<design>.tnm statement syntax\n" );
  print( "------------------------------------------------\n" );
  print( "  <object> <name> : <groupname> [<groupname>]\n" );
  print( "------------------------------------------------\n" );
  print( "where <object> is one of: FFS PADS RAMS SIG\n" );
  die( "\n" );
}

