[OpenSPARC-T2-DV] / tools / perl-5.8.0 / lib / site_perl / 5.8.0 / Midas_samy / AttrBlock.pm

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