[OpenSPARC-T2-DV] / tools / perlmod / Midas / 3.32 / lib / site_perl / 5.8.0 / Midas / AttrBlock.pm

# ========== Copyright Header Begin ==========================================
# 
# OpenSPARC T2 Processor File: AttrBlock.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 ============================================
# -*- perl -*-
{
 package Midas::AttrBlock;
 use strict;

 use Midas::Command;
 use Midas::Error;
 use Midas::Globals;

 use fields qw(
	       name

	       type
	       srcfile
	       srcline

	       secobj

	       endfile
	       endline

	       has_set

	       settable
	      );

 our @Settable = qw(name section);
 our %Settable = map { $_ => 1 } Midas::AttrBlock->settable();

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

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

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

   $this->set_defaults();

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

   $this->{settable} = \%Settable;

   return $this;
 }

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

 sub set_defaults {
   my $this = shift;
   $this->{has_set} = {};
 }

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

 sub set_end_file_line {
   my $this = shift;
   my $endfile = shift;
   my $endline = shift;
   $this->{endfile} = $endfile;
   $this->{endline} = $endline;
 }

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

 sub get_end_file_line {
   my $this = shift;
   return ($this->{endfile}, $this->{endline});
 }

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

 sub clone {
   my $this = shift;

   my $class = ref $this;
   my $that = $class->new();

   $that->copy($this);
   return $that;
 }

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

 sub copy {
   my $this = shift;
   my $src  = shift;

   my @fields = keys %$this;

   my @shallow_refs = qw(Midas::Section);

   # Note this does a shallow copy of elements in arrays and values in hashes.
   # May need to fix that if this gets more complicated

   foreach my $field (@fields) {
     if(not ref $src->{$field}) {
       $this->{$field} = $src->{$field};
     } else {
       my $reftype = ref $src->{$field};
       if($reftype eq 'ARRAY') {
	 $this->{$field} = [ @{$src->{$field}} ];
       } elsif($reftype eq 'HASH') {
	 $this->{$field} = { %{$src->{$field}} };
       } elsif(grep /^$reftype$/, @shallow_refs) {
	 $this->{$field} = $src->{$field};
       } else {
	 $this->{$field} = $src->{$field}->clone();
       }
     }
   }

 }

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

 sub settable {
   my $this = shift;
   return @Settable;
 }

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

 sub is_settable {
   my $this = shift;
   my $attr = shift;

   $attr = lc $attr;
   return 1 if exists $this->{settable}{$attr};
   return;
 }

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

 sub set_attr {
   my $this  = shift;
   my $attr  = shift;
   my $value = shift;

   $this->attr_fatal("Attribute \"$attr\" is not a settable attribute.",
		     M_ILLEGALPARAM) unless $this->is_settable($attr);

   $attr = lc $attr;

   # make "section" a synonym for "name"
   if ($attr eq 'section') {
     $attr = 'name';
   }

   if ($this->{has_set}{$attr}) {
     $this->attr_fatal("Attribute \"$attr\" is set multiple times.",
		       M_ILLEGALPARAM);
   }

   $this->{$attr} = $value;

   $this->{has_set}{$attr} = 1;

   return $value;
 }

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

 sub sanity_check {
   my $this = shift;
   my $message;

   my $fline = $this->get_fline();
   my @messages;
   if(not defined $this->{name}) {
     my $message = '' unless defined $message;
     $message .= "Block has no \"name\" or \"section\" tag.\n";
     push @messages, { message => $message, code => M_ATTRSYNTAX }
   }

   return @messages;
 }

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

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

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

 sub secobj {
   my $this = shift;
   my $obj = shift;

   $this->{secobj} = $obj if defined $obj;

   return $this->{secobj};
 }

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

 sub get_fline {
   my $this = shift;
   my $fline = "File=$this->{srcfile}, Line=$this->{srcline}";
   return $fline;
 }

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

 sub attr_fatal {
   my $this = shift;
   my $message = shift;
   my $errcode = shift;
   my $secname = $this->{name};
   my $fline   = $this->get_fline();

   chomp $message;
   fatal "SECTION '$secname': $message\n  At $fline\n", $errcode;
 }

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

 sub init_from_args {
   my $this = shift;
   my $srcfile = shift;
   my $srcline = shift;
   my %args = @_;

   $this->{srcfile} = $srcfile;
   $this->{srcline} = $srcline;


   # Make sure that name => or section => gets set first.  That way, if any
   # later attributes cause an error, at least the error message will
   # look good.
   my @attr_names = keys %args;
   if(exists $args{name}) {
     my $name = $args{name};
     delete $args{name};
     @attr_names = ('name', keys %args);
     $args{name} = $name;
   }
   if(exists $args{section}) {
     my $section = $args{section};
     delete $args{section};
     @attr_names = ('section', keys %args);
     $args{section} = $section;
   }

   foreach my $attr (@attr_names) {
     if ($this->is_settable($attr)) {
       $this->set_attr($attr, $args{$attr});
     } else {
       $this->attr_fatal("No such attribute '$attr'.",M_ILLEGALPARAM);
     }
   }
 }

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

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

{
  package Midas::AttrBlock::LinkAttrs;

  use strict;
  use Midas::Command;
  use Midas::Globals;
  use Midas::Error;
  use Midas::Segment;
  use TRELoad 'BitFieldTie';

  use base 'Midas::AttrBlock';

  BEGIN: {
      require fields;
      fields->import(Midas::Segment->all_va_names());
    }

  our @Settable = Midas::Segment->all_va_names();
  our %Settable = map { $_ => 1 } Midas::AttrBlock::LinkAttrs->settable();

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

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


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


    $this->set_defaults();

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

    $this->{settable} = \%Settable;

    return $this;
  }

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

  sub settable {
    my $this = shift;
    my @settable = $this->SUPER::settable();
    push @settable, @Settable;
    return @settable;
  }

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

  sub has_segment {
    my $this = shift;
    my $segment = shift;

    return 1 if defined $this->{ Midas::Segment->name2va_name($segment) };
    return;
  }

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

  sub get_segment_va_bf {
    my $this = shift;
    my $segment = shift;


    $this->attr_fatal("No segment argument to has_segment.\n", M_CODE)
     unless defined $segment;

    my $vaname = Midas::Segment->name2va_name($segment);

    return unless defined $this->{$vaname};

    my $va = string2bf($this->{$vaname}, $VASIZE);
    my $uc = uc $segment;
    if(not ref $va) {
      $this->attr_fatal("Cannot interpret $uc \"$this->{$vaname}\":\n$va",
			M_NOTNUM);
    }

    return $va;
  }

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

 sub get_segment_va {
   my $this = shift;
   my $segment = shift;
   my $va_bf = $this->get_segment_va_bf($segment);
   return unless ref $va_bf;
   return "0x$va_bf";
 }

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

 sub defined_segments {
   my $this = shift;
   return grep { $this->has_segment($_) } Midas::Segment->all_names();
 }

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

 sub sanity_check {
   my $this = shift;

   my @messages = $this->SUPER::sanity_check();

   my $name = $this->get_section_name();
   my $fline = $this->get_fline();

   my %seg_vas;

   foreach my $segment ($this->defined_segments()) {
     my $vaname = Midas::Segment->name2va_name($segment);
     my $va = string2bf($this->{$vaname}, $VASIZE);
     if (not ref $va) {
       my $message = "Section '$name' specified ${segment}_va isn't a ".
	 "number:\n".
	 "$va\n at $fline\n";
       push @messages, { message => $message, code => M_NOTNUM };
     } else {
       $seg_vas{$segment} = $va;

       my $dword_offset = $va->extract(2, 0);
       if ($dword_offset != 0) {
	 my $message = "Section '$name' ${segment}_va 0x$va is not 8-byte ".
	   "aligned.\n at $fline\n";
	 push @messages, { message => $message, code => M_BADALIGN };
       }
	
     }
   }

   my %rev;
   foreach my $segment (keys %seg_vas) {
     my $vastring = $seg_vas{$segment};

     if(exists $rev{$vastring}) {
       my $oldseg = $rev{$vastring};

       my $message = "Section '$name', ${oldseg}_va and ${segment}_va are ".
	 "the same\n at $fline\n";
       push @messages, { message => $message, code => M_SECSYNTAX };
     }

     $rev{$vastring} = $segment;
   }


   return @messages;
 }

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

}

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

{
  package Midas::AttrBlock::MapAttrs;

  use strict;
  use Carp;
  use Midas::Command;
  use Midas::Globals;
  use Midas::Error;
  use Midas::Segment;

  use base 'Midas::AttrBlock';
  use fields qw(
		segment

		unique_name
		compressimage

		tsbnames

		va
		end_va
		start_label
		end_label

		mmutype

	       );
  our @Settable = qw(
		     compressimage
		     va end_va
		     start_label end_label
		    );

  our %Settable = map { $_ => 1} Midas::AttrBlock::MapAttrs->settable();


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

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

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

    $this->set_defaults();

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

    $this->{settable} = \%Settable;

    return $this;
  }

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

  sub set_defaults {
    my $this = shift;
    $this->{segment} = Midas::Segment->new(SEG_UNDEF)
      unless defined $this->{segment};
    $this->SUPER::set_defaults;
    $this->{tsbnames} = [];
    $this->{mmutype} = 'generic' unless defined $this->{mmutype};
  }

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

  sub settable {
    my $this = shift;
    my @settable = $this->SUPER::settable();
    push @settable, @Settable;
    return @settable;
  }

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

 sub is_settable {
   my $this = shift;
   my $attr = shift;

   $attr = lc $attr;

   return 1 if exists $MapAttr_Settable{$attr};
   return;
 }

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

 sub get_field_size_hash {
   my $this = shift;
   return {};
 }

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

 sub set_attr {
   my $this  = shift;
   my $attr  = shift;
   my $value = shift;

   $attr = lc $attr;

   if(exists $STATE->{tsbs}{$attr}) {
     push @{$this->{tsbnames}}, $attr;
     $STATE->{tsbs}{$attr}->touch();
   } else {
     return $this->SUPER::set_attr($attr, $value);
   }

   return $value;
 }

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

 sub get_tsb_list {
   my $this = shift;

   return [ @{$this->{tsbnames}} ];
 }

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

  sub is_segment {
    my $this = shift;
    my $segment = shift;

    return 1 if $this->{segment}->name() eq $segment;
    return 0;
  }

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

  sub get_type {
    my $this = shift;
    return $this->{segment}->name();
  }

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

  sub skip_image {
    my $this = shift;
    return 0;
  }

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

  sub is_mapped {
    my $this = shift;
    return 0;
  }

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

  sub write_to_segment {
    my $this = shift;
    my $segment = shift;
    return 1 if $this->is_segment($segment);
    return 0;
  }

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

  sub get_va_bf {
    my $this = shift;

    if(defined $this->{va}) {
      return BitFieldTie->new($VASIZE, $this->{va});
    }
    return;
  }

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

  sub get_va {
    my $this = shift;

    my $bf = $this->get_va_bf();
    return unless defined $bf;
    return "0x$bf";
  }

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

  sub get_pa_bf {
    my $this = shift;
    return undef;
  }

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

  sub get_pa {
    my $this = shift;
    my $bf = $this->get_pa_bf();
    return unless defined $bf;
    return "0x$bf";
  }

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

  sub get_ra_bf {
    my $this = shift;
    return $this->get_pa_bf();
  }

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

  sub get_ra {
    my $this = shift;
    my $bf = $this->get_ra_bf();
    return unless defined $bf;
    return "0x$bf";
  }

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

  sub unique_name {
    my $this = shift;
    my $name = shift;

    $this->{unique_name} = $name if defined $name;
    return $this->{unique_name};
  }

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

  sub write_to_goldfinger {
    my $this = shift;
    my $segment = shift;
    my $linkname = shift;
    my $fh   = shift;


    my $in_image = ((not $this->skip_image) and
		    $this->write_to_segment($segment)) ? 1 : 0;

    if (not defined $this->{compressimage}) {
      $this->{compressimage} = 0;
    }
    $this->{compressimage} &&= $CONFIG{compress_image};

    my $type = $this->get_type();

    my $name = $this->{name};
    my $va = $this->get_va();
    my $ra = $this->get_ra();
    my $pa = $this->get_pa();

    my $unique_name = $this->unique_name();
    $fh->print("  BLOCK $unique_name\n");
    $fh->print("    SECTION_NAME = \"$name\";\n");
    $fh->print("    SEGMENT_NAME = \"$type\";\n");
    $fh->print("    LINK_SECTION = \"$linkname\";\n");
    $fh->print("    SRC_FILE     = \"$this->{srcfile}\";\n");
    $fh->print("    SRC_LINE     = $this->{srcline};\n");
    $fh->print("    COMPRESS     = $this->{compressimage};\n");
    $fh->print("    VA           = $va;\n") if defined $va;
    $fh->print("    RA           = $ra;\n") if defined $ra;
    $fh->print("    PA           = $pa;\n") if defined $pa;
    $fh->print("    IN_IMAGE     = $in_image;\n");
    $fh->print("    END_VA       = $this->{end_va};\n")
      if defined $this->{end_va};
    $fh->print("    START_LABEL  = \"$this->{start_label}\";\n")
      if defined $this->{start_label};
    $fh->print("    END_LABEL    = \"$this->{end_label}\";\n")
      if defined $this->{end_label};
    $this->write_goldfinger_mmu_params($fh);

    $fh->print("  END BLOCK\n");
    $fh->print("\n");

  }

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

  sub write_goldfinger_mmu_params {
    my $fh = shift;
  }

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

}

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

1;
Commit	Line	Data
86530b38 AT	1	# ========== Copyright Header Begin ==========================================
	2	#
	3	# OpenSPARC T2 Processor File: AttrBlock.pm
	4	# Copyright (C) 1995-2007 Sun Microsystems, Inc. All Rights Reserved
	5	# 4150 Network Circle, Santa Clara, California 95054, U.S.A.
	6	#
	7	# * DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
	8	#
	9	# This program is free software; you can redistribute it and/or modify
	10	# it under the terms of the GNU General Public License as published by
	11	# the Free Software Foundation; version 2 of the License.
	12	#
	13	# This program is distributed in the hope that it will be useful,
	14	# but WITHOUT ANY WARRANTY; without even the implied warranty of
	15	# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	16	# GNU General Public License for more details.
	17	#
	18	# You should have received a copy of the GNU General Public License
	19	# along with this program; if not, write to the Free Software
	20	# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
	21	#
	22	# For the avoidance of doubt, and except that if any non-GPL license
	23	# choice is available it will apply instead, Sun elects to use only
	24	# the General Public License version 2 (GPLv2) at this time for any
	25	# software where a choice of GPL license versions is made
	26	# available with the language indicating that GPLv2 or any later version
	27	# may be used, or where a choice of which version of the GPL is applied is
	28	# otherwise unspecified.
	29	#
	30	# Please contact Sun Microsystems, Inc., 4150 Network Circle, Santa Clara,
	31	# CA 95054 USA or visit www.sun.com if you need additional information or
	32	# have any questions.
	33	#
	34	# ========== Copyright Header End ============================================
	35	# -- perl --
	36	{
	37	package Midas::AttrBlock;
	38	use strict;
	39
	40	use Midas::Command;
	41	use Midas::Error;
	42	use Midas::Globals;
	43
	44	use fields qw(
	45	name
	46
	47	type
	48	srcfile
	49	srcline
	50
	51	secobj
	52
	53	endfile
	54	endline
	55
	56	has_set
	57
	58	settable
	59	);
	60
	61	our @Settable = qw(name section);
	62	our %Settable = map { $_ => 1 } Midas::AttrBlock->settable();
	63
	64	##############################################################################
65
66	sub new {
67	my $this = shift;
68	my %args = @_;
69
70	unless (ref $this) {
71	$this = fields::new($this);
72	}
73
74	$this->set_defaults();
75
76	foreach my $key (keys %args) {
77	$this->{$key} = $args{$key};
78	}
79
80	$this->{settable} = \%Settable;
81
82	return $this;
83	}
84
85	##############################################################################
86
87	sub set_defaults {
88	my $this = shift;
89	$this->{has_set} = {};
90	}
91
92	##############################################################################
93
94	sub set_end_file_line {
95	my $this = shift;
96	my $endfile = shift;
97	my $endline = shift;
98	$this->{endfile} = $endfile;
99	$this->{endline} = $endline;
100	}
101
102	##############################################################################
103
104	sub get_end_file_line {
105	my $this = shift;
106	return ($this->{endfile}, $this->{endline});
107	}
108
109	##############################################################################
110
111	sub clone {
112	my $this = shift;
113
114	my $class = ref $this;
115	my $that = $class->new();
116
117	$that->copy($this);
118	return $that;
119	}
120
121	##############################################################################
122
123	sub copy {
124	my $this = shift;
125	my $src = shift;
126
127	my @fields = keys %$this;
128
129	my @shallow_refs = qw(Midas::Section);
130
131	# Note this does a shallow copy of elements in arrays and values in hashes.
132	# May need to fix that if this gets more complicated
133
134	foreach my $field (@fields) {
135	if(not ref $src->{$field}) {
136	$this->{$field} = $src->{$field};
137	} else {
138	my $reftype = ref $src->{$field};
139	if($reftype eq 'ARRAY') {
140	$this->{$field} = [ @{$src->{$field}} ];
141	} elsif($reftype eq 'HASH') {
142	$this->{$field} = { %{$src->{$field}} };
143	} elsif(grep /^$reftype$/, @shallow_refs) {
144	$this->{$field} = $src->{$field};
145	} else {
146	$this->{$field} = $src->{$field}->clone();
147	}
148	}
149	}
150
151	}
152
153	##############################################################################
154
155	sub settable {
156	my $this = shift;
157	return @Settable;
158	}
159
160	##############################################################################
161
162	sub is_settable {
163	my $this = shift;
164	my $attr = shift;
165
166	$attr = lc $attr;
167	return 1 if exists $this->{settable}{$attr};
168	return;
169	}
170
171	##############################################################################
172
173	sub set_attr {
174	my $this = shift;
175	my $attr = shift;
176	my $value = shift;
177
178	$this->attr_fatal("Attribute \"$attr\" is not a settable attribute.",
179	M_ILLEGALPARAM) unless $this->is_settable($attr);
180
181	$attr = lc $attr;
182
183	# make "section" a synonym for "name"
184	if ($attr eq 'section') {
185	$attr = 'name';
186	}
187
188	if ($this->{has_set}{$attr}) {
189	$this->attr_fatal("Attribute \"$attr\" is set multiple times.",
190	M_ILLEGALPARAM);
191	}
192
193	$this->{$attr} = $value;
194
195	$this->{has_set}{$attr} = 1;
196
197	return $value;
198	}
199
200	##############################################################################
201
202	sub sanity_check {
203	my $this = shift;
204	my $message;
205
206	my $fline = $this->get_fline();
207	my @messages;
208	if(not defined $this->{name}) {
209	my $message = '' unless defined $message;
210	$message .= "Block has no \"name\" or \"section\" tag.\n";
211	push @messages, { message => $message, code => M_ATTRSYNTAX }
212	}
213
214	return @messages;
215	}
216
217	##############################################################################
218
219	sub get_section_name {
220	my $this = shift;
221	return lc $this->{name};
222	}
223
224	##############################################################################
225
226	sub secobj {
227	my $this = shift;
228	my $obj = shift;
229
230	$this->{secobj} = $obj if defined $obj;
231
232	return $this->{secobj};
233	}
234
235	##############################################################################
236
237	sub get_fline {
238	my $this = shift;
239	my $fline = "File=$this->{srcfile}, Line=$this->{srcline}";
240	return $fline;
241	}
242
243	##############################################################################
244
245	sub attr_fatal {
246	my $this = shift;
247	my $message = shift;
248	my $errcode = shift;
249	my $secname = $this->{name};
250	my $fline = $this->get_fline();
251
252	chomp $message;
253	fatal "SECTION '$secname': $message\n At $fline\n", $errcode;
254	}
255
256	##############################################################################
257
258	sub init_from_args {
259	my $this = shift;
260	my $srcfile = shift;
261	my $srcline = shift;
262	my %args = @_;
263
264	$this->{srcfile} = $srcfile;
265	$this->{srcline} = $srcline;
266
267
268	# Make sure that name => or section => gets set first. That way, if any
269	# later attributes cause an error, at least the error message will
270	# look good.
271	my @attr_names = keys %args;
272	if(exists $args{name}) {
273	my $name = $args{name};
274	delete $args{name};
275	@attr_names = ('name', keys %args);
276	$args{name} = $name;
277	}
278	if(exists $args{section}) {
279	my $section = $args{section};
280	delete $args{section};
281	@attr_names = ('section', keys %args);
282	$args{section} = $section;
283	}
284
285	foreach my $attr (@attr_names) {
286	if ($this->is_settable($attr)) {
287	$this->set_attr($attr, $args{$attr});
288	} else {
289	$this->attr_fatal("No such attribute '$attr'.",M_ILLEGALPARAM);
290	}
291	}
292	}
293
294	##############################################################################
295	}
296
297	###############################################################################
298	###############################################################################
299
300	{
301	package Midas::AttrBlock::LinkAttrs;
302
303	use strict;
304	use Midas::Command;
305	use Midas::Globals;
306	use Midas::Error;
307	use Midas::Segment;
308	use TRELoad 'BitFieldTie';
309
310	use base 'Midas::AttrBlock';
311
312	BEGIN: {
313	require fields;
314	fields->import(Midas::Segment->all_va_names());
315	}
316
317	our @Settable = Midas::Segment->all_va_names();
318	our %Settable = map { $_ => 1 } Midas::AttrBlock::LinkAttrs->settable();
319
320	#############################################################################
321
322	sub new {
323	my $this = shift;
324	my %args = @_;
325
326
327	unless (ref $this) {
328	$this = fields::new($this);
329	}
330
331
332	$this->set_defaults();
333
334	foreach my $key (keys %args) {
335	$this->{$key} = $args{$key};
336	}
337
338	$this->{settable} = \%Settable;
339
340	return $this;
341	}
342
343	#############################################################################
344
345	sub settable {
346	my $this = shift;
347	my @settable = $this->SUPER::settable();
348	push @settable, @Settable;
349	return @settable;
350	}
351
352	#############################################################################
353
354	sub has_segment {
355	my $this = shift;
356	my $segment = shift;
357
358	return 1 if defined $this->{ Midas::Segment->name2va_name($segment) };
359	return;
360	}
361
362	#############################################################################
363
364	sub get_segment_va_bf {
365	my $this = shift;
366	my $segment = shift;
367
368
369	$this->attr_fatal("No segment argument to has_segment.\n", M_CODE)
370	unless defined $segment;
371
372	my $vaname = Midas::Segment->name2va_name($segment);
373
374	return unless defined $this->{$vaname};
375
376	my $va = string2bf($this->{$vaname}, $VASIZE);
377	my $uc = uc $segment;
378	if(not ref $va) {
379	$this->attr_fatal("Cannot interpret $uc \"$this->{$vaname}\":\n$va",
380	M_NOTNUM);
381	}
382
383	return $va;
384	}
385
386	#############################################################################
387
388	sub get_segment_va {
389	my $this = shift;
390	my $segment = shift;
391	my $va_bf = $this->get_segment_va_bf($segment);
392	return unless ref $va_bf;
393	return "0x$va_bf";
394	}
395
396	#############################################################################
397
398	sub defined_segments {
399	my $this = shift;
400	return grep { $this->has_segment($_) } Midas::Segment->all_names();
401	}
402
403	#############################################################################
404
405	sub sanity_check {
406	my $this = shift;
407
408	my @messages = $this->SUPER::sanity_check();
409
410	my $name = $this->get_section_name();
411	my $fline = $this->get_fline();
412
413	my %seg_vas;
414
415	foreach my $segment ($this->defined_segments()) {
416	my $vaname = Midas::Segment->name2va_name($segment);
417	my $va = string2bf($this->{$vaname}, $VASIZE);
418	if (not ref $va) {
419	my $message = "Section '$name' specified ${segment}_va isn't a ".
420	"number:\n".
421	"$va\n at $fline\n";
422	push @messages, { message => $message, code => M_NOTNUM };
423	} else {
424	$seg_vas{$segment} = $va;
425
426	my $dword_offset = $va->extract(2, 0);
427	if ($dword_offset != 0) {
428	my $message = "Section '$name' ${segment}_va 0x$va is not 8-byte ".
429	"aligned.\n at $fline\n";
430	push @messages, { message => $message, code => M_BADALIGN };
431	}
432
433	}
434	}
435
436	my %rev;
437	foreach my $segment (keys %seg_vas) {
438	my $vastring = $seg_vas{$segment};
439
440	if(exists $rev{$vastring}) {
441	my $oldseg = $rev{$vastring};
442
443	my $message = "Section '$name', ${oldseg}_va and ${segment}_va are ".
444	"the same\n at $fline\n";
445	push @messages, { message => $message, code => M_SECSYNTAX };
446	}
447
448	$rev{$vastring} = $segment;
449	}
450
451
452
453	return @messages;
454	}
455
456	#############################################################################
457
458	}
459
460	###############################################################################
461	###############################################################################
462
463	{
464	package Midas::AttrBlock::MapAttrs;
465
466	use strict;
467	use Carp;
468	use Midas::Command;
469	use Midas::Globals;
470	use Midas::Error;
471	use Midas::Segment;
472
473	use base 'Midas::AttrBlock';
474	use fields qw(
475	segment
476
477	unique_name
478	compressimage
479
480	tsbnames
481
482	va
483	end_va
484	start_label
485	end_label
486
487	mmutype
488
489	);
490	our @Settable = qw(
491	compressimage
492	va end_va
493	start_label end_label
494	);
495
496	our %Settable = map { $_ => 1} Midas::AttrBlock::MapAttrs->settable();
497
498
499	#############################################################################
500
501	sub new {
502	my $this = shift;
503	my %args = @_;
504
505	unless (ref $this) {
506	$this = fields::new($this);
507	}
508
509	$this->set_defaults();
510
511	foreach my $key (keys %args) {
512	$this->{$key} = $args{$key};
513	}
514
515	$this->{settable} = \%Settable;
516
517	return $this;
518	}
519
520	#############################################################################
521
522	sub set_defaults {
523	my $this = shift;
524	$this->{segment} = Midas::Segment->new(SEG_UNDEF)
525	unless defined $this->{segment};
526	$this->SUPER::set_defaults;
527	$this->{tsbnames} = [];
528	$this->{mmutype} = 'generic' unless defined $this->{mmutype};
529	}
530
531	#############################################################################
532
533	sub settable {
534	my $this = shift;
535	my @settable = $this->SUPER::settable();
536	push @settable, @Settable;
537	return @settable;
538	}
539
540	##############################################################################
541
542	sub is_settable {
543	my $this = shift;
544	my $attr = shift;
545
546	$attr = lc $attr;
547
548	return 1 if exists $MapAttr_Settable{$attr};
549	return;
550	}
551
552	#############################################################################
553
554	sub get_field_size_hash {
555	my $this = shift;
556	return {};
557	}
558
559	#############################################################################
560
561	sub set_attr {
562	my $this = shift;
563	my $attr = shift;
564	my $value = shift;
565
566	$attr = lc $attr;
567
568	if(exists $STATE->{tsbs}{$attr}) {
569	push @{$this->{tsbnames}}, $attr;
570	$STATE->{tsbs}{$attr}->touch();
571	} else {
572	return $this->SUPER::set_attr($attr, $value);
573	}
574
575	return $value;
576	}
577
578	#############################################################################
579
580	sub get_tsb_list {
581	my $this = shift;
582
583	return [ @{$this->{tsbnames}} ];
584	}
585
586	#############################################################################
587
588	sub is_segment {
589	my $this = shift;
590	my $segment = shift;
591
592	return 1 if $this->{segment}->name() eq $segment;
593	return 0;
594	}
595
596	#############################################################################
597
598	sub get_type {
599	my $this = shift;
600	return $this->{segment}->name();
601	}
602
603	############################################################################
604
605	sub skip_image {
606	my $this = shift;
607	return 0;
608	}
609
610	############################################################################
611
612	sub is_mapped {
613	my $this = shift;
614	return 0;
615	}
616
617	#############################################################################
618
619	sub write_to_segment {
620	my $this = shift;
621	my $segment = shift;
622	return 1 if $this->is_segment($segment);
623	return 0;
624	}
625
626	#############################################################################
627
628	sub get_va_bf {
629	my $this = shift;
630
631	if(defined $this->{va}) {
632	return BitFieldTie->new($VASIZE, $this->{va});
633	}
634	return;
635	}
636
637	#############################################################################
638
639	sub get_va {
640	my $this = shift;
641
642	my $bf = $this->get_va_bf();
643	return unless defined $bf;
644	return "0x$bf";
645	}
646
647	############################################################################
648
649	sub get_pa_bf {
650	my $this = shift;
651	return undef;
652	}
653
654	############################################################################
655
656	sub get_pa {
657	my $this = shift;
658	my $bf = $this->get_pa_bf();
659	return unless defined $bf;
660	return "0x$bf";
661	}
662
663	############################################################################
664
665	sub get_ra_bf {
666	my $this = shift;
667	return $this->get_pa_bf();
668	}
669
670	############################################################################
671
672	sub get_ra {
673	my $this = shift;
674	my $bf = $this->get_ra_bf();
675	return unless defined $bf;
676	return "0x$bf";
677	}
678
679	#############################################################################
680
681	sub unique_name {
682	my $this = shift;
683	my $name = shift;
684
685	$this->{unique_name} = $name if defined $name;
686	return $this->{unique_name};
687	}
688
689	#############################################################################
690
691	sub write_to_goldfinger {
692	my $this = shift;
693	my $segment = shift;
694	my $linkname = shift;
695	my $fh = shift;
696
697
698	my $in_image = ((not $this->skip_image) and
699	$this->write_to_segment($segment)) ? 1 : 0;
700
701	if (not defined $this->{compressimage}) {
702	$this->{compressimage} = 0;
703	}
704	$this->{compressimage} &&= $CONFIG{compress_image};
705
706	my $type = $this->get_type();
707
708	my $name = $this->{name};
709	my $va = $this->get_va();
710	my $ra = $this->get_ra();
711	my $pa = $this->get_pa();
712
713	my $unique_name = $this->unique_name();
714	$fh->print(" BLOCK $unique_name\n");
715	$fh->print(" SECTION_NAME = \"$name\";\n");
716	$fh->print(" SEGMENT_NAME = \"$type\";\n");
717	$fh->print(" LINK_SECTION = \"$linkname\";\n");
718	$fh->print(" SRC_FILE = \"$this->{srcfile}\";\n");
719	$fh->print(" SRC_LINE = $this->{srcline};\n");
720	$fh->print(" COMPRESS = $this->{compressimage};\n");
721	$fh->print(" VA = $va;\n") if defined $va;
722	$fh->print(" RA = $ra;\n") if defined $ra;
723	$fh->print(" PA = $pa;\n") if defined $pa;
724	$fh->print(" IN_IMAGE = $in_image;\n");
725	$fh->print(" END_VA = $this->{end_va};\n")
726	if defined $this->{end_va};
727	$fh->print(" START_LABEL = \"$this->{start_label}\";\n")
728	if defined $this->{start_label};
729	$fh->print(" END_LABEL = \"$this->{end_label}\";\n")
730	if defined $this->{end_label};
731	$this->write_goldfinger_mmu_params($fh);
732
733	$fh->print(" END BLOCK\n");
734	$fh->print("\n");
735
736	}
737
738	#############################################################################
739
740	sub write_goldfinger_mmu_params {
741	my $fh = shift;
742	}
743
744	#############################################################################
745
746	}
747
748	###############################################################################
749	###############################################################################
750
751	1;