Initial commit of OpenSPARC T2 design and verification files.

[OpenSPARC-T2-DV] / tools / perlmod / DiagList / 1.11 / lib / site_perl / 5.8.0 / DiagList / Objects.pm

# ========== Copyright Header Begin ==========================================
# 
# OpenSPARC T2 Processor File: Objects.pm
# Copyright (C) 1995-2007 Sun Microsystems, Inc. All Rights Reserved
# 4150 Network Circle, Santa Clara, California 95054, U.S.A.
#
# * DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER. 
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; version 2 of the License.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
#
# For the avoidance of doubt, and except that if any non-GPL license 
# choice is available it will apply instead, Sun elects to use only 
# the General Public License version 2 (GPLv2) at this time for any 
# software where a choice of GPL license versions is made 
# available with the language indicating that GPLv2 or any later version 
# may be used, or where a choice of which version of the GPL is applied is 
# otherwise unspecified. 
#
# Please contact Sun Microsystems, Inc., 4150 Network Circle, Santa Clara, 
# CA 95054 USA or visit www.sun.com if you need additional information or 
# have any questions. 
# 
# ========== Copyright Header End ============================================
package DiagList::Objects;

use strict;
use DiagList::Output;
use DiagList::Settings;

###############################################################################

{
 package DiagList;

 use DiagList::Output;
 use DiagList::Settings;

 use fields qw(
               file
               buildtags
               groups
              );

 our $COMMENT_RE = qr|\/\/|;
 our $TAG_RE     =
 qr|^
 \s*
 \<
    \s*
    (\S+)
    \s*
    (.*)
 \>
 |x;

 #############################################################################

 sub new {
   my $class = shift;
   my $file  = shift;
   my $fh    = shift;

   my $this = {};
   bless $this, $class;

   tie my %buildtags, 'Tie::IxHash';
   $this->{buildtags} = \%buildtags;
   tie my %groups, 'Tie::IxHash';
   $this->{groups}    = \%groups;
   $this->parse($file, $fh) if defined $file;
   return $this;
 }

 #############################################################################

 sub parse {
   my $this = shift;
   my $file = shift;
   my $fh   = shift;

   chat "Reading $file";
   $this->{file} = $file;

   if(defined $fh and not (ref $fh and $fh->isa('IO::File'))) {
     my $handle = $fh;
     $fh = IO::File->new();
     $fh->fdopen(fileno($handle), "r") or
       fatal "Cannot create IO::File object from handle $handle\n";
   } else {
     $fh = IO::File->new("<$file") or fatal "Cannot open $file: $!";
   }

   my $line = 0;

   my $cur_build_tag;
   my $cur_name_tag;

   my @group_stack;
   my %group_args;
   my @runarg_stack;
   my @owner_stack;

   while(<$fh>) {
     $line++;
     chomp;
     s/$COMMENT_RE.*//;
     next unless /\S/;


     if(/^\#\s*(\d+)\s*\"(.*)\"/) {
       $line = $1 - 1;
       $file = $2;
       next;
     }

     if(/$TAG_RE/) {
       my ($tag, $args) = ($1, $2);

       if($tag =~ s|^\/||) {
         # End tag

         if($tag eq 'runargs') {
           fatal "Nesting error, </runargs> with no matching beginning",
             $file, $line unless @runarg_stack;
           pop @runarg_stack;
         } elsif($tag eq 'debugowner') {
           fatal "Nesting error, </debugowners> with no matching beginning",
             $file, $line unless @owner_stack;
           pop @owner_stack;
         } else {
           my $group = pop @group_stack;
           fatal "Nesting error: /$tag found, /$group->{name} expected",
             $file, $line unless $tag eq $group->{name};

           undef $cur_build_tag if $group->compile_tag;
           undef $cur_name_tag  if $group->name_tag;
           delete $group_args{$group->{name}};
         }

       } else {

         if($tag eq 'runargs') {
           push @runarg_stack, $args;
         } elsif($tag eq 'debugowner') {
           push @owner_stack, $args;
         } else {

           # Start tag
           my $buildtag = ($args =~ /\bsys=(\S+)/);
           $buildtag = $1 if $buildtag;

           my $nametag  = ($args =~ s/\bname=(\S+)\s*//);
           $nametag  = $1 if $nametag;

           # Error checking here
           fatal "Build tag $tag multiply defined." , $file, $line
             if exists $this->{buildtags}{$tag};


           if($buildtag) {
             chat "Inserting tags: $tag=$buildtag\n";

             (my $buildargs = $args) =~ s/\b(sys=\S+)/-$1/;
       
             $this->{buildtags}{$tag} = $buildargs;

             # Strip sys= argument for use in group args
             $args =~ s/\bsys=(\S)+\s*//;

             $cur_build_tag = $tag;

           }
           if($nametag) {
             fatal "Nametag $nametag defined within nametag $cur_name_tag",
               $file, $line if defined $cur_name_tag;
             $cur_name_tag  = $nametag;
           }


           my $group;
           if(exists $this->{groups}{$tag}) {
             fatal "Group $tag is nested inside itself", $file, $line
               if exists $group_args{$tag};
       
             $group = $this->{groups}{$tag};
           } else {
       
             $group = DiagList::Group->new(name => $tag);
             $group->compile_tag($buildtag) if $buildtag;
             $group->name_tag($nametag)     if $nametag;
       
       
             $this->{groups}{$group->{name}} = $group;
           }
           $args =~ s/^\s+//;
           $args =~ s/\s+$//;
           $group_args{$group->{name}} = $args;
           push @group_stack, $group;
         }
       }
     } else {
       # Diag

       my $diag = DiagList::Diag->new_from_line($_, $cur_name_tag);

       fatal "Diag $diag->{alias} appears outside any group.", $file, $line
         unless @group_stack;
       fatal "Diag $diag->{alias} appears outside any name tag.", $file, $line
         unless defined $cur_name_tag;
       fatal "Diag $diag->{name} appears outside any build tag.", $file, $line
         unless defined $cur_build_tag;

       foreach my $group (@group_stack) {
         my $group_diag = $diag->new(); # Clone diag object
         $group_diag->prepend_args([@runarg_stack,
                                    $group_args{$group->{name}}]);
         $group_diag->set_group($group->{name});
         $group->add_diag($group_diag, $cur_build_tag);
         if(@owner_stack) {
           my $owner = $owner_stack[$#owner_stack];
           $group_diag->add_owner($owner) unless
             defined $group_diag->get_owner(); # diag has owner on cmdline
         }
       }

     }

   }

   fatal "End of file with <runargs> still open!" if @runarg_stack;

   undef $fh;
 }

 #############################################################################

 sub build_hash {
   my $this = shift;
   return $this->{buildtags};
 }

 #############################################################################

 sub build_list {
   my $this = shift;
   return keys %{$this->{buildtags}};
 }

 #############################################################################

 sub build_args {
   my $this = shift;
   my $build_tag = shift;
   return unless exists $this->{buildtags}{$build_tag};
   return $this->{buildtags}{$build_tag};
 }

 #############################################################################

 sub group_hash {
   my $this = shift;
   return $this->{groups};
 }

 #############################################################################

 sub group_list {
   my $this = shift;
   return keys %{$this->{groups}};
 }

 #############################################################################

 sub find_group {
   my $this = shift;
   my $group = shift;

   return unless exists $this->{groups}{$group};
   return $this->{groups}{$group};
 }

 #############################################################################

}

###############################################################################
##############################################################################

{
 package DiagList::Group;
 use strict;

 use DiagList::Settings;

 use fields qw(
               name
               compile_tag
               name_tag

               tags
               );

 ############################################################################

 sub new {
   my $this = shift;
   my %args = @_;

   unless (ref $this) {
     $this = fields::new($this);
   }

   foreach my $arg (keys %args) {
     $this->{$arg} = $args{$arg};
   }
   $this->{tags}  = {} unless defined $this->{tags};

   return $this;
 }

 ############################################################################

 sub name {
   my $this = shift;
   my $name = shift;
   $this->{name} = $name if defined $name;
   return $this->{name};
 }

 ############################################################################

 sub compile_tag {
   my $this = shift;
   my $tag  = shift;

   $this->{compile_tag} = undef unless exists $this->{compile_tag};
   $this->{compile_tag} = $tag if defined $tag;
   return $this->{compile_tag};
 }

 ############################################################################

 sub name_tag {
   my $this = shift;
   my $tag  = shift;

   $this->{name_tag} = undef unless exists $this->{name_tag};
   $this->{name_tag} = $tag if defined $tag;
   return $this->{name_tag};
 }

 ############################################################################

 sub build_tags {
   my $this = shift;
   my $name = shift;
   return keys %{$this->{tags}};
 }

 ############################################################################

 sub list_diags {
   my $this     = shift;
   my $buildtag = shift;

   return unless exists $this->{tags}{$buildtag};
   return keys %{$this->{tags}{$buildtag}};
 }

 ############################################################################

 sub diag_hash {
   my $this     = shift;
   my $buildtag = shift;
   return unless exists $this->{tags}{$buildtag};
   return $this->{tags}{$buildtag};
 }

 ############################################################################

 sub find_diag {
   my $this     = shift;
   my $buildtag = shift;
   my $diagname = shift;

   return unless exists $this->{tags}{$buildtag};
   return unless exists $this->{tags}{$buildtag}{$diagname};
   return $this->{tags}{$buildtag}{$diagname};
 }

 ############################################################################

 sub add_diag {
   my $this   = shift;
   my $diag   = shift;
   my $buildtag   = shift;

   if(not defined $this->{tags}{$buildtag}) {
     tie my %sys, 'Tie::IxHash';
     $this->{tags}{$buildtag} = \%sys;
   }

   my $key = $diag->{name};
   my $gname = $this->{name};

   warn "WARNING: Diag $key multiply defined in group $gname\n"
     if (exists $this->{tags}{$buildtag}{$key} and display_warnings());

   $this->{tags}{$buildtag}{$key} = $diag;

 }

 ############################################################################
}

##############################################################################

{
 package DiagList::Diag;
 use strict;

 use Text::ParseWords;

 use fields qw(
               name
               alias
               files
               args

               nametag
               buildtag
               group
               debugowner
               );

 our @FILE_SUFFIXES = qw(s pal vr tpt);
               
 ############################################################################

 sub new {
   my $this = shift;
   my %args = @_;

   if(ref $this) {
     # Cloning!
     my $that = $this;
     $this = fields::new(ref $that);
     foreach my $field (keys %$that) {

       if(ref $that->{$field} eq 'ARRAY') {
         $this->{$field} = [ @{$that->{$field}} ];
       } elsif(ref $that->{$field}) {
         die "Don't know how to clone non-array ref field $field in ".
           "DiagList::Diag\n";
       } else {
         $this->{$field} = $that->{$field};
       }

     }

   } else {
     $this = fields::new($this);

     foreach my $arg (keys %args) {
       $this->{$arg} = $args{$arg};
     }

   }


   $this->{args}       = [] unless defined $this->{args};
   $this->{files}      = [] unless defined $this->{files};

   return $this;
 }

 ############################################################################

 sub new_from_line {
   my $class   = shift;
   my $line    = shift;
   my $nametag = shift;

   $nametag = '' unless defined $nametag;
   my @fields = split ' ', $line;
   my $alias  = shift @fields;

   my @args;
   my @files;
   my $debugowner;

   my $suffix_re = join '|', @FILE_SUFFIXES;
   $suffix_re = qr/($suffix_re)/;

   foreach my $field (@fields) {
     if($field !~ /^[-+]/ and $field =~ /\.$suffix_re$/o) {
       push @files, $field;
     } else {

       if($field =~ /^debugowner=(\S+)$/) {
         $debugowner = $1;
       } else {
         push @args, $field;
       }
     }
   }
       
   my $diag = $class->new(
                          alias => $alias,
                          nametag => $nametag,
                          name => "$alias:$nametag",
                          files => \@files,
                          args  => \@args,
                         );

   $diag->{debugowner} = $debugowner if defined $debugowner;
   return $diag;
 }

 ############################################################################

 sub get_file {
   my $this = shift;
   return $this->{files}[0];
 }

 ############################################################################

 sub prepend_args {
   my $this = shift;
   my $args = shift;

   unshift @{$this->{args}}, @$args;
 }

 ############################################################################

 sub add_owner {
   my $this = shift;
   my $owner = shift;

   $this->{debugowner} = $owner;
 }

 ############################################################################

 sub get_owner {
   my $this = shift;
   return $this->{debugowner} if defined $this->{debugowner};
   return;
 }

 ############################################################################

 sub get_cmdline {
   my $this = shift;

   my @args = grep { $_ =~ /\S/ } @{$this->{args}};
   my $args  = (scalar @args) ? join ' ', @args : '';
   my $files = join ' ', @{$this->{files}};
   my $sep = (length $args) ? ' ' : '';
   my $cmdline = "$args$sep$files";
   $cmdline =~ s/^\s+//;
   $cmdline =~ s/\s+$//;
   return $cmdline;
 }

 ############################################################################

 sub get_cmd_argv {
   my $this = shift;
   my $line = $this->get_cmdline;

   my $keep = 0;
   my @words = `showargv $line`;

   my @argv;
   my $i = 0;
   while($i <= $#words) {
     my $word = $words[$i];

     # Strip off ARGV stuff at beginning of line
     # If next line doesn't start with /^ARGV/, then there must be an
     # embedded newline
     $word =~ s/^ARGV\[\d+\]\://;
     chomp $word;
     $i++;

     if($i > $#words) {
       push @argv, $word;
       last;
     }

     while($words[$i] !~ /^ARGV/) {
       my $new_word = $words[$i];
       $word .= "\n" . $new_word;
       chomp $new_word;
       $i++;
       if($i > $#words) {
         push @argv, $word;
         last;
       }
     }

     push @argv, $word;
   }

   # get rid of argv[0] (showargv executable)
   shift @argv;

   return @argv;
 }

 ############################################################################

 sub get_name {
   my $this = shift;
   return $this->{name};
 }

 ############################################################################

 sub get_alias {
   my $this = shift;
   return $this->{alias};
 }

 ############################################################################

 sub get_nametag {
   my $this = shift;
   return $this->{nametag};
 }

 ############################################################################

 sub set_group {
   my $this = shift;
   my $group = shift;
   $this->{group} = $group if defined $group;
   return $this->{group};
 }

 ############################################################################

 sub get_group {
   my $this = shift;
   return $this->{group};
 }

 ############################################################################

 sub get_full_name {
   my $this = shift;
   my $fullname = $this->{alias} . ':' . $this->{nametag} . ':' .
     $this->{group};
   return $fullname;
 }

 ############################################################################


 ############################################################################
}

##############################################################################

1;