#!perl -w
# ==============================================================================
# Package Name: IPat_ReadBsdl.pm
# Revision: 20220430a
# Author: Altmo toolbox
# Description: BSDL Reader.
# ==============================================================================
package IPat_ReadBsdl;
use strict;

# ==============================================================================
# Global options : Don't modify below statements.
# ==============================================================================
my $G_PKG = __PACKAGE__;
my $G_ENABLE_HIGHZ = 1;
my $G_ENABLE_CLAMP = 1;

my $G_DEBUG_0 = 1;
my $G_DEBUG_1 = 1;
my $G_DEBUG_2 = 1;
my $G_DEBUG_3 = 1;

# ==============================================================================
# Main function
# ==============================================================================
sub new {
    my @args = @_;
    
  # operator check
    my $bsdl_fname = '';
    if ($#args >= 1) {
        $bsdl_fname = $args[1]; # called by allow operator
    } else {
        $bsdl_fname = $args[0]; # called by name space
    }
  
  # file exist check
    (-f $bsdl_fname) or die "ERR: $G_PKG: $bsdl_fname is not found.\n";
  
  # read bsdl file
    my $fr; # Read file handle
    
    open($fr, "< $bsdl_fname");
        my @bsdl_src = <$fr>; # BSDL source
    close($fr);
    
    print "INF: $G_PKG: bsdl=$bsdl_fname\n";
  
  # extract bsdl data
    my $bsdl_obj = readBsdlSource(\@bsdl_src);
  
  # add bsdl file information
    $bsdl_obj->{bsdl} = $bsdl_fname;
    
    print "INF: $G_PKG: read $bsdl_fname is successful.\n";
    return($bsdl_obj);
}

# ==============================================================================
# readBsdlSource
# ==============================================================================
sub readBsdlSource {
    my ($src) = @_;
    my %obj;
    
    removeExtraComments($src);
    
    $obj{entity} = extractEntity($src); # has string such as XA6SLX25_CSG324
    
    $obj{port}   = extractPort($src);   # $obj{port}->{<name>}->{dir}   input/output/inout
                                        #              :      ->{width} bit/bit_vector
                                        #              :      ->{msb}   msb for bit_vector
                                        #              :      ->{lsb}   lsb for bit_vector
    
    $obj{tap}    = extractTap($src);    # $obj{tap}->{mode}  port name of TAP_SCAN_MODE
                                        #          ->{in}    port name of TAP_SCAN_IN
                                        #          ->{out}   port name of TAP_SCAN_OUT
                                        #          ->{reset} port name of TAP_SCAN_RESET
                                        #          ->{clock} port name of TAP_SCAN_CLOCK
                                        #          ->{freq}  frequency of TAP_SCAN_CLOCK
    
    $obj{opcode} = extractOpcode($src); # $obj{opcode}->{length}          bit length of IR
                                        #             ->{capture}         capture value of IR
                                        #             ->{inst}->{<name>}->[list of IR values]
                                        #                        :
    
    $obj{devid} = extractDevid($src);   # has string such as 32'bxxx_....
    
    $obj{bsr}    = extractBsr($src);    # $obj{bsr}->[<num>]->{type} BC_1/BC_2/BC_4 ...
                                        #                   ->{pin}  */pin_name
                                        #                   ->{func} controlr/input/output3/internal
                                        #                   ->{init} 0/1/X
                                        #                   ->{o_cont} bit number of output control (for output3)
                                        #                   ->{o_val}  safe value of output control bit (for output3)
                                        #                   ->{o_stat} safe status (for output3)
    
    $obj{compl} = extractCompl($src);   # $obj{compl}->{<port_name>} compliance value for the port
                                        #                :
                                        # When the complinace rule is none, $obj{comple} has undef.
    
    return(\%obj);
}

# ------------------------------------------------------------------------------
sub extractCompl {
    my ($src) = @_;
    
    my $obj;
    
    my $str_compl = '';
    my $flag_compl = 0;
    
    for (my $i=0; $i<@{$src}; $i++) {
        $flag_compl = 1 if ($src->[$i] =~ /^\s*attribute\s*COMPLIANCE_PATTERNS\s+of\s+\S+\s*:\s*entity\s*is/i);
        if ($flag_compl) {
            $str_compl .= $src->[$i];
            last if ($src->[$i] =~ /;/);
        }
    }
    
    my $str_ports = '';
    my $str_values = '';
    
    if ($str_compl =~ /^\s*attribute\s*COMPLIANCE_PATTERNS\s+of\s+\S+\s*:\s*entity\s*is.*\((.*)\)\s*\((.*)\).*;/i) {
        $str_ports = $1;
        $str_values = $2;
        $str_ports =~ s/\s//g;
        $str_values =~ s/\s//g;
    }
    
    if ($str_ports eq '') {
        print "INF: $G_PKG: compl=undef\n";
        return(undef);
    }
    
    my @ports  = split(/,/, $str_ports);
    my @values = split(/,/, $str_values);
    
    for (my $i=0; $i<@ports; $i++) {
        $obj->{$ports[$i]}=$values[$i];
        print "INF: $G_PKG: compl: $ports[$i]=$obj->{$ports[$i]}\n";
    }
    
    return($obj);
}

# ------------------------------------------------------------------------------
sub extractTap {
    my ($src) = @_;
    
    my $obj;
    
    my $port = '';
    my $clkinfo = '';
    
    for (my $i=0; $i<@{$src}; $i++) {
        if ($src->[$i] =~ /^\s*attribute\s+TAP_SCAN_CLOCK\s+of\s+(\S+)\s*:\s*signal\s+is\s*\((.*)\)/i) {
            $port = $1;
            $clkinfo = $2;
            $obj->{clock} = $port;
            $clkinfo =~ s/\s//g;
            my @list = split(/,/, $clkinfo);
            $obj->{freq} = $list[0] if ($#list >= 0);
        }
        elsif ($src->[$i] =~ /^\s*attribute\s+TAP_SCAN_CLOCK\s+of\s+(\S+)\s*:/i) {
            $port = $1;
            if ($src->[$i+1] =~ /^\s*signal\s+is\s*\((.*)\)\s*;/i) {
                $clkinfo = $1;
                $obj->{clock} = $port;
                $clkinfo =~ s/\s//g;
                my @list = split(/,/, $clkinfo);
                $obj->{freq} = $list[0] if ($#list >= 0);
            }
        }
        elsif ($src->[$i] =~ /^\s*attribute\s+TAP_SCAN_IN\s+of\s+(\S+)\s*:\s*signal\s+is\s+true/i) {
            $port = $1;
            $obj->{in} = $port;
        }
        elsif ($src->[$i] =~ /^\s*attribute\s+TAP_SCAN_MODE\s+of\s+(\S+)\s*:\s*signal\s+is\s+true/i) {
            $port = $1;
            $obj->{mode} = $port;
        }
        elsif ($src->[$i] =~ /^\s*attribute\s+TAP_SCAN_OUT\s+of\s+(\S+)\s*:\s*signal\s+is\s+true/i) {
            $port = $1;
            $obj->{out} = $port;
        }
        elsif ($src->[$i] =~ /^\s*attribute\s+TAP_SCAN_RESET\s+of\s+(\S+)\s*:\s*signal\s+is\s+true/i) {
            $port = $1;
            $obj->{reset} = $port;
        }
    }
    
  # clock is mandatory
    if (exists($obj->{clock})) {
        print "INF: $G_PKG: tap: clock=$obj->{clock}\n";
    } else {
        die "ERR: $G_PKG: tap: scan clock port is not found.\n";
    }
    
  # freq is mandatory
    if (exists($obj->{freq})) {
        print "INF: $G_PKG: tap: freq=$obj->{freq}\n";
    } else {
        die "ERR: $G_PKG: tap: scan clock frequency is not found.\n";
    }
    
  # in is mandatory
    if (exists($obj->{in})) {
        print "INF: $G_PKG: tap: in=$obj->{in}\n";
    } else {
        die "ERR: $G_PKG: tap: scan in port is not found.\n";
    }
    
  # mode is mandatory
    if (exists($obj->{mode})) {
        print "INF: $G_PKG: tap: mode=$obj->{mode}\n";
    } else {
        die "ERR: $G_PKG: tap: scan mode port is not found.\n";
    }
    
  # out is mandatory
    if (exists($obj->{out})) {
        print "INF: $G_PKG: tap: out=$obj->{out}\n";
    } else {
        die "ERR: $G_PKG: tap: scan out port is not found.\n";
    }
    
  # reset is optional
    if (exists($obj->{reset})) {
        print "INF: $G_PKG: tap: reset=$obj->{reset}\n";
    }
    
    return($obj);
}

# ------------------------------------------------------------------------------
sub extractBsr {
    my ($src) = @_;
    
    my $str_bsr_0 = '';
    
    my $flag = 0;
    for (my $i=0; $i<@{$src}; $i++) {
        $flag = 1 if ($src->[$i] =~ /BOUNDARY_REGISTER\s+of\s+\S+\s*:\s*entity\s+is/i);
        
        if ($flag) {
            $str_bsr_0 .= $src->[$i];
            last if ($src->[$i] =~ /;/);
        }
    }
    
    my $str_bsr_1 = '';
    if ($str_bsr_0 =~ /BOUNDARY_REGISTER\s+of\s+\S+\s*:\s*entity\s+is\s*(.*);/i) {
        $str_bsr_1 = $1;
    }
    
    $str_bsr_1 =~ s/\s//g;
    $str_bsr_1 =~ s/\"//g;
    my @l_bsr_0 = split(/&/,$str_bsr_1);
   #print "INF: $G_PKG: bsr: max_num: $#l_bsr_0\n" if ($G_DEBUG_3);
    
    my $obj;
    
    for (my $i=0; $i<@l_bsr_0; $i++) {
        if ($l_bsr_0[$i] =~ /(\d+)+\((\S+)\)/) {
            my $num = $1;
            my $inf = $2;
            my @l_inf = split(/,/, $inf);
            if ($#l_inf >= 3) {
                $obj->[$num]->{type} = $l_inf[0];
                $obj->[$num]->{pin}  = $l_inf[1];
                $obj->[$num]->{func} = $l_inf[2];
                $obj->[$num]->{init} = $l_inf[3];
            }
            
            if ($#l_inf >= 6) {
                $obj->[$num]->{o_cont} = $l_inf[4];
                $obj->[$num]->{o_val}  = $l_inf[5];
                $obj->[$num]->{o_stat} = $l_inf[6];
            }

            print "INF: $G_PKG: bsr: [$num]: type=$obj->[$num]->{type}" if ($G_DEBUG_3);
            print ", pin=$obj->[$num]->{pin}"   if ($G_DEBUG_3);
            print ", func=$obj->[$num]->{func}" if ($G_DEBUG_3);
            print ", init=$obj->[$num]->{init}" if ($G_DEBUG_3);
            
            if ($obj->[$num]->{func} =~ /output3/i) {
                print ", o_cont=$obj->[$num]->{o_cont}" if ($G_DEBUG_3);
                print ", o_val=$obj->[$num]->{o_val}"   if ($G_DEBUG_3);
                print ", o_stat=$obj->[$num]->{o_stat}" if ($G_DEBUG_3);
            }
            print "\n" if ($G_DEBUG_3);
        }
    }
    
    return($obj);
}

# ------------------------------------------------------------------------------
sub extractDevid {
    my ($src) = @_;
    
    my $str_idcode = '';
    my $device_id = '';
    
    my $flag_idcode = 0;
    for (my $i=0; $i<@{$src}; $i++) {
        $flag_idcode = 1 if ($src->[$i] =~ /IDCODE_REGISTER\s+of\s+\S+\s*:\s*entity\s*is/i);
        if ($flag_idcode) {
            $str_idcode .= $src->[$i];
            last if ($src->[$i] =~ /;/);
        }
    }
    
    if ($str_idcode =~ /IDCODE_REGISTER\s+of\s+\S+\s*:\s*entity\s*is\s*(.*);/i) {
        $device_id = "32'b".$1;
        $device_id =~ s/\s//g;
        $device_id =~ s/\"//g;
        $device_id =~ s/&/_/g;
        $device_id =~ s/X/x/g;
        print "INF: $G_PKG: devid=$device_id\n" if ($G_DEBUG_2);
    } else {
        die "ERR: $G_PKG: devid is not found.\n";
    }
    
    return($device_id);
}

# ------------------------------------------------------------------------------
sub extractOpcode {
    my ($src) = @_;
    
    my %opcode;
    
    extractIrLength($src, \%opcode);

    extractIrCapture($src, \%opcode);
    
    my $str_opcode = '';
    my $flag_opcode = 0;
    for (my $i=0; $i<@{$src}; $i++) {
        $flag_opcode = 1 if ($src->[$i] =~ /INSTRUCTION_OPCODE\s+of\s+\S+\s*:\s*entity\s*is/i);
        
        if ($flag_opcode) {
            $str_opcode .= $src->[$i];
            last if ($src->[$i] =~ /;/);
        }
    }
    
    my $str_opcode_body = '';
    if ($str_opcode =~ /entity\s+is\s*(.*);\s*$/i) {
        $str_opcode_body = $1;
    }
    ($str_opcode_body ne '') or die "ERR: $G_PKG: OPCODE data is not be found.\n";
    
    extractOpcodeDef($str_opcode_body, \%opcode);
    
    checkOpcodeSet(\%opcode);
    
    return(\%opcode);
}

# ------------------------------------------------------------------------------
sub checkOpcodeSet {
    my ($obj) = @_;
    
    die "ERR: $G_PKG: opcode: inst: IDCODE is not found.\n" unless (exists($obj->{inst}->{IDCODE}));
    
    die "ERR: $G_PKG: opcode: inst: SAMPLE is not found.\n" unless (exists($obj->{inst}->{SAMPLE}));
    
    die "ERR: $G_PKG: opcode: inst: EXTEST is not found.\n" unless (exists($obj->{inst}->{EXTEST}));
    
    die "ERR: $G_PKG: opcode: inst: BYPASS is not found.\n" unless (exists($obj->{inst}->{BYPASS}));
}

# ------------------------------------------------------------------------------
sub extractIrCapture {
    my ($src, $obj) = @_;
    
    my $ir_capture = '';
    
    my $flag = 0;
    my $str = '';
    
    for (my $i=0; $i<@{$src}; $i++) {
        $flag = 1 if ($src->[$i] =~ /INSTRUCTION_CAPTURE\s+of\s+\S+\s*:\s*entity\s*is/i);
         if ($flag) {
             $str .= $src->[$i];
             last if ($src->[$i] =~ /;/);
         }
    }
    
    if ($flag) {
        if ($str =~ /\"\s*(\S+)\s*\"\s*;/) {
            $ir_capture = $1;
        }
        
        if ($ir_capture ne '') {
            $ir_capture = $obj->{length}."'b".$ir_capture;
            $ir_capture =~ s/X/x/g;
            $obj->{capture} = $ir_capture;
            print "INF: $G_PKG: opcode: capture=$obj->{capture}\n" if ($G_DEBUG_1);
        }
    }
}

# ------------------------------------------------------------------------------
sub extractIrLength {
    my ($src, $obj) = @_;
    
    my $ir_length = '';
    for (my $i=0; $i<@{$src}; $i++) {
        if ($src->[$i] =~ /INSTRUCTION_LENGTH\s+of\s*\S+\s*:\s*entity\s+is\s+(\d+)/i) {
            $ir_length = $1;
            last;
        }
    }
    
    ($ir_length ne '') or die "ERR: $G_PKG: INSTRUCTION_LENGTH is not be found.\n";
    $obj->{length} = $ir_length;
    print "INF: $G_PKG: opcode: length=$obj->{length}\n" if ($G_DEBUG_1);
}

# ------------------------------------------------------------------------------
sub extractOpcodeDef {
    my ($str_src, $obj) = @_;
    
    my @src = split(/&/, $str_src);
    
    for (my $i=0; $i<@src; $i++) {
        my $opcode = '';
        my $str_vals = '';
        if ($src[$i] =~ /\"\s*(\S+)\s*\((.*)\)/) {
            $opcode = $1;
            $str_vals = $2;
            $str_vals =~ s/\s//g;
            my @vals = split(/,/, $str_vals);
            for (my $j=0; $j<@vals; $j++) {
                $vals[$j] = $obj->{length}."'b".$vals[$j]
            }
            
            $obj->{inst}->{$opcode}=\@vals;
            print "INF: $G_PKG: opcode: inst: $opcode=[",join(",",@{$obj->{inst}->{$opcode}}),"]\n" if ($G_DEBUG_1);
        }
    }
}

# ------------------------------------------------------------------------------
sub extractPort {
    my ($src) = @_;
    
    my $port_str = '';
    my $port_flag = 0;
    
    for (my $i=0; $i<@{$src}; $i++) {
        $port_flag = 1 if ($src->[$i] =~ /^\s*port\s*\(/i);
        
        if ($port_flag) {
            last if ($src->[$i] =~ /^\s*use\s+STD_1149/i);
            $port_str .= $src->[$i];
        }
    }
    
    my @list_def_ports;
    if ($port_str =~ /^\s*port\s*\((.+)\s*\)\s*;\s*$/i) {
        my $str_def_ports = $1;
        @list_def_ports = split(/;/, $str_def_ports);
    }
    
    my %port;
    
    for (my $i=0; $i<@list_def_ports; $i++) {
        if ($list_def_ports[$i] =~ /(.*)\s*:\s*(.*)$/) {
            my $ports_str = $1;
            my $attr = $2;
            
            extractIoDef($ports_str, $attr, \%port) if ($attr !~ /^\s*linkage/);
        }
    }
    
    return(\%port);
}

# ------------------------------------------------------------------------------
sub extractIoDef {
    my ($ports, $attr, $obj) = @_;
    
    my $dir = '';
    my $width = '';
    my $msb_lsb = '';
    my $lsb = '';
    my $msb = '';
    
    if ($attr =~ /^\s*(\S+)\s+(\S+)\s*\((.*)\)$/) {
        $dir = $1;
        $width = $2;
        $msb_lsb = $3;
        if ($msb_lsb =~ /^\s*(\d+)\s*to\s*(\d+)/) {
            $msb = $1;
            $lsb = $2;
        }
    } elsif ($attr =~ /^\s*(\S+)\s+(\S+)\s*$/) {
        $dir = $1;
        $width = $2;
    }
    
    my @list_ports = split(/,/, $ports);
    
    for (my $i=0; $i<@list_ports; $i++) {
        $dir = 'input' if ($dir eq 'in');
        $list_ports[$i] =~ s/\s//g;
        
        $obj->{$list_ports[$i]}->{dir}=$dir;
        $obj->{$list_ports[$i]}->{width}=$width;
        $obj->{$list_ports[$i]}->{msb}=$msb;
        $obj->{$list_ports[$i]}->{lsb}=$lsb;
        
        if ($G_DEBUG_0) {
            print "INF: $G_PKG: port: $list_ports[$i]: dir=$obj->{$list_ports[$i]}->{dir}";
            print ", width=$obj->{$list_ports[$i]}->{width}";
            print ", msb=$obj->{$list_ports[$i]}->{msb}" if ($obj->{$list_ports[$i]}->{width} =~ /vec/i);
            print ", lsb=$obj->{$list_ports[$i]}->{lsb}" if ($obj->{$list_ports[$i]}->{width} =~ /vec/i);
            print "\n";
        }
    }
}

# ------------------------------------------------------------------------------
sub extractEntity {
    my ($src) = @_;
    my $entity = '';
    
    for (my $i=0; $i<@{$src}; $i++) {
        if ($src->[$i] =~ /^\s*entity\s+(\S+)\s+is/i) {
            $entity = $1;
            last;
        }
    }
    
    ($entity ne '') or die "ERR: $G_PKG: Entity name is not be found.\n";
    
    print "INF: $G_PKG: entity=$entity\n" if ($G_DEBUG_0);
    
    return($entity);
}

# ------------------------------------------------------------------------------
sub removeExtraComments {
    my ($src) = @_;
    
    for (my $i=0; $i<@{$src}; $i++) {
        $src->[$i] =~ s/--.*$//;
        $src->[$i] =~ s/\s+$//;
        $src->[$i] =~ s/^\s+//;
        $src->[$i] =~ s/\s+/ /g;
    }
}

1;