#!/bin/perl

$multiple_modulef=0;
$multiple_module=0; #more than one module in a file
$entrym=""; #global
$entry=""; #global
@a=();
#Add a data base with file name and its module / arch.
@a_file_ModArc=();
$b_file_ModArc="";
$i_file_ModArc=0;
$t_file_ModArc=0;

$debug=0;


$fpn="no_name_report.txt";
if($ARGV[0] =~ /(.*)\.(.*)/) {
  $fpn=$1 . "_report.txt"
}
open(FPW, ">$fpn") || die("open fail $fpn\n");


open(FPTB, $ARGV[0]) || die("open fail $ARGV[0]\n");
while(eof(FPTB) != 1) {
  $line=<FPTB>; chomp($line); $line =~ s/ //g;
  if($line =~ /.*\.v$/) {
    $b_file_ModArc=$line;
    &get_hier_verilog($line, $entry, $multiple_module);
  }
  elsif($line =~ /.*\.vhd$/) {
    $b_file_ModArc=$line;
    $multiple_module=0;#not supported yet
    &get_hier_vhdl($line, $entry);
    $i_file_ModArc=index($entry, "::");
    $b_file_ModArc=$b_file_ModArc . " " . substr($entry, 0, $i_file_ModArc);
  }
  elsif($line =~ /.*\.VHD$/) {
    $b_file_ModArc=$line;
    $multiple_module=0;#not supported yet
    &get_hier_vhdl($line, $entry);
    $i_file_ModArc=index($entry, "::");
    $b_file_ModArc=$b_file_ModArc . " " . substr($entry, 0, $i_file_ModArc);
  }
  else { die("unsupported file type \"$line\"\n"); }
  if($multiple_module == 1) {
    $multiple_modulef=0;
    while($multiple_modulef == 0) {
      if($entry =~ /(^[a-zA-Z].*::.* )([a-zA-Z].*::.*)/) {
        $entry=$1; $entrym=$2;
        push(@a_entry, $entrym);
        $t_file_ModArc=$entrym; $t_file_ModArc =~ s/:://;
        $b_file_ModArc=$b_file_ModArc . " " . $t_file_ModArc;
      }
      else {
        push(@a_entry, $entry);
        $multiple_modulef=1;
        $i_file_ModArc=index($entry, "::");
        $b_file_ModArc=$b_file_ModArc . " " . substr($entry, 0, $i_file_ModArc);
      }
    }#while
  }
  else {#single module in HDL file

    push(@a_entry, $entry);
    $i_file_ModArc=index($entry, "::");
    $b_file_ModArc=$b_file_ModArc . " " . substr($entry, 0, $i_file_ModArc);
  }
  push(@a_file_ModArc, $b_file_ModArc);
  $entry="";
}#while

close(FPTB);
&prt_entry($ARGV[1]);

print FPW ("file -> module / architecture\n");
foreach $b_file_ModArc ( @a_file_ModArc ) {
  print FPW ("$b_file_ModArc\n");
}


sub prt_entry {
  print FPW ("$_[0]\n");
  &get_mod($_[0], 0);
}
sub get_mod {
  my $j="";
  my $k="";
  my $ix=0;
  my $spc="";
  my @as="";
  my $cmp="";
  my $hier="";
  my @amod="";
  my $src="";

  if($_[0] eq "") {
    print FPW ("start a not ordered report\n");
    foreach $j ( @a_entry ) {
      print FPW ("$j\n");
    }
    exit(0);
  }
  #

  my $src_a=lc($_[0]);
  foreach $j ( @a_entry ) {
    $src=$src_a . "::"; #to avoid a match on ABC -> ABCD
    $ix=index($j, $src);
	if($ix == 0) {#match module
	  if($j =~ /;/) {#has children
	    if($j =~ /.*:: *(.*)/) {
		  $cmp=$1;
		  @as=split(/ /, $cmp);
		}
		$hier=$_[1]+1; 
		if($hier > 30) {
          foreach $k ( @as ) { print("as-$k\n");}
          print FPW ("hierarchy level is too deep\n");
          print("hierarchy level is too deep\n");
          exit(0);
        }
		foreach $k ( @as ) {
          for($spc=0; $spc < $hier; $spc++) {print FPW (" ");}
		  print FPW ("$k\n");
		  @amod=split(/;/, $k);
		  &get_mod($amod[0], $hier);
		}#foreach
	  }
	}
  }#foreach
}
exit(0);



sub get_hier_vhdl {
  my $start=0;
  my $arch="";
  my $arch_cnt=0;
  my $arch_mul="";
  my $buf="";
  my $t1="";
  my $t2="";
  my @at="";
  my $last=0;
  my $file=$_[0];
  my $line="";

  open(FPR, $_[0]) || die("open fail $_[0]\n");
  
  my $skip_line=0;
  while(eof(FPR) != 1) {
    $line=<FPR>; chomp($line); $line =~ s/\t/ /g; $line =~ s/\r//g;
	$line=lc($line);
    if($line =~ /^ *--/) {#comment
      $skip_line=1;
    }
    elsif($line =~ /^ *$/) {
      $skip_line=1;
    }
    else {
      #remove remark
      my @line_r = split(/--/, $line);
      $line=$line_r[0]; 
      $skip_line=0;
    }


    if($skip_line == 0) {
      #get architecture
      if($start == 0) {
        if( length($arch) == 0 ) {
	      if($line =~ /architecture/) {
		    $arch=$line; $start=1;
		  }
	    }
	    else { $arch=$arch . $line; }
	    if($arch =~ /architecture .* of *([a-zA-Z].*) *is/) {
	      $start=2;
		  $_[1]=$1 . "::"; $_[1] =~ s/ *//g;
	    }
      }
      #get hier
	  if($start == 2) {
	    $buf=$buf . " " . $line;
	    if($buf =~ /;/) {
	      if( $buf =~ /([a-zA-Z].*) *: *([a-zA-Z].*) *port *map.*;/ ) {
		    $t2=$2; $t1=$1; $t2 =~ s/^ *//;
		    @at=split(/ /, $t2); $t2=$at[0];
		    if($t1 =~ / /) {
			  @at=split(/ /, $t1); $last=$#at;
			  $t1=$at[$last];
		    }
	        $_[1]=$_[1] . " " . $t2 . ";" . $t1;
	      }
          $buf="";
	    }
	    if($line =~ /^ *architecture /) {
		  if($arch_cnt > 0) {
		    $arch_mul="";
		    if($line =~ /architecture *.* of ([a-zA-Z].*) *is/) {
		      $arch_mul=$1;
		    }
		    print FPW ("xx $arch_mul $file\n");
		    $start=3;
		  }
		  $arch_cnt++;
	    }
	  }
    }#if($skip_line == 0)

  }#while
}#get_hier_vhdl


sub get_hier_verilog {
  open(FPR, $_[0]) || die("open fail $_[0]\n");
  
  my $remark_on=0;
  my $split_an="";
  my $split_on=0;
  my @split_st="";
  my $tmp=0;
  my $line="";
  while(eof(FPR) != 1) {
    $line=<FPR>; chomp($line); $line =~ s/\t/ /g; $line =~ s/\r//g;
    if($line =~ /^ *\/\//) {#comment
      $tmp=$1;
    }
    elsif($line =~ /timescale/) {
      $tmp=$1;
    }
    elsif($line =~ /endmodule/) {
      $tmp=$1;
    }
    elsif($line =~ /^ *$/) {
      $tmp=$1;
    }
    else {
      #remove remark
      my @line_r = split(/\/\//, $line);
      $line=$line_r[0];
      #remove remark of type /*...*/
      if($line =~ /(.*)\/\*.*\*\/(.*)/) {
        $line=$1 . $2;
      }
      elsif($line =~ /(.*)\/\*/) {
        $line=$1;#discard the remark part
        $remark_on=1;
        push(@a, $line);
      }
      elsif($remark_on == 1) {
        if($line =~ /\*\/(.*)/) {
          $line=$1;#discard the remark part
          $remark_on=0;
        }
      }
  
      if($remark_on == 0) {
        #At this point we look for any kind of statement, which ends with a ;.
        #Check for multiple ; lines.
        if( $line =~ /;.*;/ ) {
          @split_st=split(/;/, $line);
          $split_on=1;
        }
        #
        if($split_on == 0) {
          push(@a, $line);
          if( $line =~ /;/ ) {
            &parse_statement($_[1], $_[2]);
            @a="";
          }
        }
        else {
          $split_on=0;
          foreach $split_an ( @split_st ) {
            $split_an=$split_an . ";";
            push(@a, $split_an);
            &parse_statement($_[1], $_[2]);
            @a="";
          }
        }
      }
    }
  }#while
  
  close(FPR);
}#get_hier_verilog

sub parse_statement {
  my $j;
  my $min;
  my @ixa=();
  my $buf;
  my $defparam_flg;
  foreach $j ( @a ) { $buf=$buf . $j . " "; }

  #component with a paramater
  &rm_double_p($buf);

  #can not cope with nested (..(..)..)
  if( $buf =~ /([^ ]*) *# *\(.*\) *([^ ]*) *\( *\. *[^ ].*\).*\) *;/ ) {
    $_[0]=$_[0] . " " . $1 . ";" . $2;
  }
  #component without a paramater
  elsif( $buf =~ /([^ ]*) *([^ ]*) *\( *\. *[^ ].*\).*\) *;/ ) {
    $_[0]=$_[0] . " " . $1 . ";" . $2;
  }
  elsif($buf =~ /module *([a-zA-Z].*)/) {#module name
	my $module=$1; 
    ##my @am="";
	$module =~ s/ //g;
	##if($module =~ /[^#]\(/) {@am=split(/\(/, $module);}
	##elsif($module =~ /;/)   {@am=split(/;/ , $module);}
	##elsif($module =~ /#/)   {@am=split(/#/ , $module);}
	##else { die("can't handle module from module\n$module\n");}
    @ixa=();
    $j=index($module, '#'); push(@ixa, $j);
    $j=index($module, '('); push(@ixa, $j);
    $j=index($module, ';'); push(@ixa, $j);
    $min=-1;
    foreach $j ( @ixa ) {
      if($j != -1) {
        if($min == -1) {$min=$j;}
        else {
          $min=($j<$min)?$j:$min;
        }
      }
    }
    $module=substr($module, 0, $min);

    #check for : more than one module in a file
    if( length($_[0]) > 0 ) {$_[1]=1; $_[0]=$_[0] . " ";}
	$_[0] =$_[0] . $module . "::";
   #$_[0] =$_[0] . $am[0]  . "::";
  }
  

  $buf="";
}#sub parse_statement 


sub rm_double_p {
  my $buf=$_[0];
  my @a_a=();
  my @a_b=();
  my $off=0;
  my $flg=0;
  my $Na=0;
  my $Nb=0;
  my $i=0;
  my $cnt=20;

  while($flg == 0) {
    $off = index($buf, '(', $off);

	if( $off != -1 ) {
	  push(@a_a, $off); $Na++;
	  $off++;
	} else {$flg = 1; }
  }#while
  if( $Na > 1 ) {#need more than two ( to operate
	$off=0; $flg=0;
    while($flg == 0) {
      $off = index($buf, ')', $off);
	  if( $off != -1 ) {
	    push(@a_b, $off); $Nb++;
	    $off++;
	  } else {$flg = 1; }
    }#while
	if($Na == $Nb) {#must be balanced with ( and )
	  for($i=1; $i<$Na-1; $i++) {
	    if($a_a[$i] < $a_b[$i-1]) {
		  &sub_char($buf, $a_a[$i], $a_b[$i-1]);
		}
	  }#for
	}
  }
}
sub sub_char {
  my $new_b="";
  $new_b=substr($_[0], 0, $_[1]);
  $new_b=$new_b . "_";
  $new_b=$new_b . substr($_[0], $_[1]+1, $_[2]-$_[1]-1);
  $new_b=$new_b . "_";
  $new_b=$new_b . substr($_[0], $_[2]+1);
  $_[0]=$new_b;
}