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

# ========== Copyright Header Begin ==========================================
# 
# OpenSPARC T2 Processor File: Section.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::Section;
use strict;

use File::Spec;
use File::Copy;
use File::Basename;
use Carp;

use Midas::Command;
use Midas::Configure;
use Midas::Paths;
use Midas::Preprocess ':internals';
use Midas::State;
use Midas::Globals;
use Midas::Source;
use Midas::Application;
use Midas::Error;
use Midas::Segment;

use TRELoad 'BitFieldTie';

use fields qw(
	      name

	      seg_attrs
	      link_attrs

	      files

	      srcfile
	      srcline
	      srcfilestop
	      srclinestop

	      args

	      appobj

	     );

require Exporter;
our @ISA = qw(Exporter);
our @EXPORT = qw(init_section);

our $Num = 0;

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

sub init_section {
  $Num = 0;
}

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

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

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

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

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

sub new_from_line {
  my $class     = shift;
  my $startline = shift;
  my $fh        = shift;
  my $srcfile   = shift;
  my $srcline   = shift;
  my $appobj    = shift;

  my $srcfile_start = $srcfile;
  my $srcline_start = $srcline;

  local ($_);
  $_ = $startline;


  my $mmu = $STATE->get_mmu();


  fatal "Badly formatted SECTION line=$srcline, file=$srcfile:\n$_",
    M_SECSYNTAX unless /^\s*SECTION\s*(\S+)\s*(.*)\s*$/;

  my $secname = $1;
  my @secargs = split ',', $2;

  my $link_attrs;


  my $section_args = {};
  foreach my $secarg (@secargs) {
    $secarg =~ s/\s+//g;
    if($secarg =~ /(\S+)=(\S+)/) {
      $section_args->{lc $1} = $2;
    } elsif($secarg =~ /(\S+)/) {
      $section_args->{lc $1} = 1;
    }
  }

  if(keys %$section_args) {
    $link_attrs = $mmu->create_attrs_object('link');
    $link_attrs->init_from_args($srcfile, $srcline, name => $secname,
				%$section_args);
  }


  my $name = lc $secname;
  $name =~ s/^\.//;
  my $secnum = $Num++;
  my $file = "sec${secnum}.${name}.s";

  $file = path_to_build_file $file; # in build_dir


  (my $ofile = $file) =~ s/\.s$/.o/;

  my $source = Midas::Source::Assembly->new(sfile => $file,
					    ofile => $ofile,
					    fullsource => $file,
					   );

  my %seg_hash = ();
  foreach my $segment (Midas::Segment->all_names()) {
    $seg_hash{$segment} = [];
  }

  my $this = Midas::Section->new
    (
     name         => $secname,
     args         => $section_args,
     seg_attrs    => \%seg_hash,
     link_attrs   => defined $link_attrs ? [ $link_attrs ] : [],
     files        => [ $source ],
     srcfile      => $srcfile_start,
     srcline      => $srcline_start,
     srcfilestop  => $srcfile,
     srclinestop  => $srcline,
     appobj       => $appobj,
    );

  return $this;

}

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

sub get_segment_attrs {
  my $this = shift;
  my $segment = shift;
  return @{$this->{seg_attrs}{$segment}};
}

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

sub add_attrs {
  my $this = shift;
  my $attrs = shift;

  if($attrs->{type} eq 'link') {
    push @{$this->{link_attrs}}, $attrs;
  } elsif(exists $this->{seg_attrs}{$attrs->{type}}) {
    my $len = @{$this->{seg_attrs}{$attrs->{type}}};
    push @{$this->{seg_attrs}{$attrs->{type}}}, $attrs;
    $attrs->unique_name($this->secname . "_$attrs->{type}_$len");
  }
}

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

sub get_map_attrs {
  my $this = shift;
  my @attrs;
  foreach my $seg (Midas::Segment->all_names()) {
    push @attrs, $this->get_segment_attrs($seg);
  }
  return @attrs;
}

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

sub get_link_attrs {
  my $this = shift;
  return @{$this->{link_attrs}};
}

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

sub print_debug {
  my $this = shift;

  chat "Section $this->{name}\n", 3;

  foreach my $seg (Midas::Segment->all_names()) {
    my $num = $this->get_segment_attrs($seg);
    chat " num_$seg\t=$num\n", 3;
  }


  my $nl = $this->get_link_attrs();
  chat " num_link   = $nl\n", 3;

  my @files = @{$this->{files}}; my $n_files = @files;
  chat " FILES ($n_files)\n", 3;
  foreach my $f (@files) {
    chat "    " . $f->debug_string . "\n", 3;
  }
}

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

# This function may be called from a child thread, sot it is important
# that it doesn't write any state (i.e., have any side-effects)
sub build {
  my $this = shift;
  foreach my $source (@{$this->{files}}) {
    $source->build();
  }
}

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

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

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

sub preprocess_midas_directive {
  my $this = shift;
  my $line = shift;

  my $output = $line;


  $output =~ s/(\$(\w+))/exists $ENV{$2} ? $ENV{$2} : $1/ge;

  return $output;
}

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

sub parse_midas_cc_line {
  my $this = shift;
  my $line = shift;
  my $srcline = shift;
  my $srcfile = shift;

  my ($file, $output, $args);
  my $processed = $this->preprocess_midas_directive($line);
  if($processed =~ /\bFILE\s*=\s*(\S+)/) {
    $file = $1;
  }
  if($processed =~ /\bOUTPUT\s*=\s*(\S+)/) {
    $output = $1;
  }
  if($processed =~ /\bARGS\s*=\s*(.*)$/) {
    $args = $1;
  }

  fatal "MIDAS_CC line does not contain FILE argument at line=$srcline, ".
    "file=$srcfile\n", M_DIRECTIVESYNTAX unless defined $file;

  my $assemble = 0;
  $assemble = 1 if defined $args && $args =~ /(\s|\A)-S(\s|\Z)/;

  my $sfile;
  my $ofile;

  my $full_file = $file;
  $file = basename $file;

  if($assemble) {
    $sfile = $output;
    if(not defined $output) {
      if($file =~ /\.c$/) {
	($sfile = $file) =~ s/\.c$/.s/;
      } else {
	$sfile = $file . ".s";
      }
      ($ofile = $sfile) =~ s/\.s$/.o/;
    } elsif($sfile =~ /\.s$/) {
      ($ofile = $sfile) =~ s/\.s$/.o/;
    } elsif($sfile =~ /\.o$/) {
      $ofile = $sfile;
      $sfile =~ s/\.o$/.s/;
    } else {
      $ofile = $sfile . ".o";
    }
  } else {
    $ofile = $output;
    if(not defined $output) {
      if($file =~ /\.c$/) {
	($ofile = $file) =~ s/\.c$/.o/;
      } else {
	$ofile = $file . ".o";
      }
    }
  }

  my $rec = {
	     cfile => $file,
	     sfile => $sfile,
	     ofile => $ofile,
	     assemble => $assemble,
	     args => $args,
	    };

  chat "LINE: $line\n", 3;
  chat "  cfile = $file\n", 3;
  chat "  sfile = $sfile\n", 3;
  chat "  ofile = $ofile\n", 3;
  chat "  assemble = $assemble\n", 3;
  chat "  args = $args\n", 3;
  chat "  fullsource = $full_file", 3;

  my $source = Midas::Source::C->new(
				     cfile => $file,
				     sfile => $sfile,
				     ofile => $ofile,
				     args => $args,
				     fullsource => $full_file,
				    );

  $source->copy_to_build_dir();
  $source->process_source();

  push @{$this->{files}}, $source;

}

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

sub parse_midas_obj_line {
  my $this = shift;
  my $line = shift;
  my $srcline = shift;
  my $srcfile = shift;

  my $file;
  my $processed = $this->preprocess_midas_directive($line);
  if($processed =~ /\bFILE\s*=\s*(\S+)/) {
    $file = $1;
  }

  fatal "MIDAS_OBJ line does not contain FILE argument at line=$srcline, ".
    "file=$srcfile\n", M_DIRECTIVESYNTAX unless defined $file;

  chat "LINE: $line\n", 3;
  chat "  ofile = $file\n", 3;

  my $source = Midas::Source::Object->new(
					  ofile => $file,
					  fullsource => $file,
					 );

  $source->copy_to_build_dir();
  $source->process_source();

  push @{$this->{files}}, $source;

}

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

sub parse_midas_lib_line {
  my $this = shift;
  my $line = shift;
  my $srcline = shift;
  my $srcfile = shift;

  my $file;
  my $processed = $this->preprocess_midas_directive($line);
  if($processed =~ /\bFILE\s*=\s*(\S+)/) {
    $file = $1;
  }

  fatal "MIDAS_LIB line does not contain FILE argument at line=$srcline, ".
    "file=$srcfile\n", M_DIRECTIVESYNTAX unless defined $file;

  chat "LINE: $line\n", 3;
  chat "  ofile = $file\n", 3;

  my $source = Midas::Source::Library->new(
					   ofile => $file,
					   fullsource => $file,
					  );

  $source->copy_to_build_dir();
  $source->process_source();

  push @{$this->{files}}, $source;

}

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

sub get_object_list {
  my $this = shift;

  my @olist =
    map { $_->get_object_file() }
      grep { ! $_->is_library() }
	@{$this->{files}};
  return @olist;
}

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

sub get_library_list {
  my $this = shift;

  my @alist =
    map { $_->get_object_file() }
      grep { $_->is_library() }
	@{$this->{files}};
  return @alist;
}

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

sub sanity_check {
  my $this = shift;

  my $fline = "File=$this->{srcfile}, Line=$this->{srclinestop}";

  my $error = 0;
  my @messages;

  if(scalar($this->get_map_attrs()) == 0) {
    my $message = "Section $this->{name} has no attr blocks!\n";
    $message .="  at $fline\n";
    push @messages, { message => $message, code => M_SECSYNTAX };
  }

  my %link_seg;
  foreach my $link_attr ($this->get_link_attrs()) {
    push @messages, $link_attr->sanity_check();

    foreach my $seg (Midas::Segment->all_names()) {
      $link_seg{$seg} = 0 unless exists $link_seg{$seg};
      $link_seg{$seg} ||= $link_attr->has_segment($seg);
    }
  }

  foreach my $attr ($this->get_map_attrs()) {
    push @messages, $attr->sanity_check();
  }

  foreach my $seg (Midas::Segment->all_names()) {
    my @seg_attrs = $this->get_segment_attrs($seg);
    if(not $CONFIG{allow_empty_sections}) {
      if($link_seg{$seg} and ! @seg_attrs) {
	my $message =
	  "Section $this->{name} has ${seg}_va but no attr_${seg} ".
	    "blocks\n at $fline\n";
	push @messages, { message => $message, code => M_SECSYNTAX };
      }
    }
    foreach my $attr (@seg_attrs) {
      my $attr_fline = $attr->get_fline();
      if(not $link_seg{$seg}) {
	my $message = "Section $this->{name} has attr_$seg but no ${seg}_va\n".
	  " at $attr_fline\n";
	push @messages, { message => $message, code => M_SECSYNTAX };
     }
    }
  }

  return @messages;
}

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

sub has_segment {
  my $this = shift;
  my $segment = shift;
  return 1 if scalar $this->get_segment_attrs($segment);
  return;
}

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

sub get_section_link_tag {
  my $this = shift;
  my @olist = $this->get_object_list();
  @olist = $this->get_library_list() unless @olist;
  my $sectag = basename $olist[0], '.o', '.a';
  return $sectag;
}

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

sub get_segment_link_name {
  my $this = shift;
  my $segment = shift;
  my $sectag = $this->get_section_link_tag();
  my $link_suffix = Midas::Segment->name2link_suffix($segment);
  return "$sectag$link_suffix";
}

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


1;
Commit	Line	Data
86530b38 AT	1	# ========== Copyright Header Begin ==========================================
	2	#
	3	# OpenSPARC T2 Processor File: Section.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::Section;
	38	use strict;
	39
	40	use File::Spec;
	41	use File::Copy;
	42	use File::Basename;
	43	use Carp;
	44
	45	use Midas::Command;
	46	use Midas::Configure;
	47	use Midas::Paths;
	48	use Midas::Preprocess ':internals';
	49	use Midas::State;
	50	use Midas::Globals;
	51	use Midas::Source;
	52	use Midas::Application;
	53	use Midas::Error;
	54	use Midas::Segment;
	55
	56	use TRELoad 'BitFieldTie';
	57
	58	use fields qw(
	59	name
	60
	61	seg_attrs
	62	link_attrs
	63
	64	files
65
66	srcfile
67	srcline
68	srcfilestop
69	srclinestop
70
71	args
72
73	appobj
74
75	);
76
77	require Exporter;
78	our @ISA = qw(Exporter);
79	our @EXPORT = qw(init_section);
80
81	our $Num = 0;
82
83	##############################################################################
84
85	sub init_section {
86	$Num = 0;
87	}
88
89	##############################################################################
90
91	sub new {
92	my $this = shift;
93	my %args = @_;
94
95	unless (ref $this) {
96	$this = fields::new($this);
97	}
98
99	foreach my $key (keys %args) {
100	$this->{$key} = $args{$key};
101	}
102	return $this;
103	}
104
105	##############################################################################
106
107	sub new_from_line {
108	my $class = shift;
109	my $startline = shift;
110	my $fh = shift;
111	my $srcfile = shift;
112	my $srcline = shift;
113	my $appobj = shift;
114
115	my $srcfile_start = $srcfile;
116	my $srcline_start = $srcline;
117
118	local ($_);
119	$_ = $startline;
120
121
122	my $mmu = $STATE->get_mmu();
123
124
125	fatal "Badly formatted SECTION line=$srcline, file=$srcfile:\n$_",
126	M_SECSYNTAX unless /^\sSECTION\s(\S+)\s(.)\s*$/;
127
128	my $secname = $1;
129	my @secargs = split ',', $2;
130
131	my $link_attrs;
132
133
134	my $section_args = {};
135	foreach my $secarg (@secargs) {
136	$secarg =~ s/\s+//g;
137	if($secarg =~ /(\S+)=(\S+)/) {
138	$section_args->{lc $1} = $2;
139	} elsif($secarg =~ /(\S+)/) {
140	$section_args->{lc $1} = 1;
141	}
142	}
143
144	if(keys %$section_args) {
145	$link_attrs = $mmu->create_attrs_object('link');
146	$link_attrs->init_from_args($srcfile, $srcline, name => $secname,
147	%$section_args);
148	}
149
150
151	my $name = lc $secname;
152	$name =~ s/^\.//;
153	my $secnum = $Num++;
154	my $file = "sec${secnum}.${name}.s";
155
156	$file = path_to_build_file $file; # in build_dir
157
158
159	(my $ofile = $file) =~ s/\.s$/.o/;
160
161	my $source = Midas::Source::Assembly->new(sfile => $file,
162	ofile => $ofile,
163	fullsource => $file,
164	);
165
166	my %seg_hash = ();
167	foreach my $segment (Midas::Segment->all_names()) {
168	$seg_hash{$segment} = [];
169	}
170
171	my $this = Midas::Section->new
172	(
173	name => $secname,
174	args => $section_args,
175	seg_attrs => \%seg_hash,
176	link_attrs => defined $link_attrs ? [ $link_attrs ] : [],
177	files => [ $source ],
178	srcfile => $srcfile_start,
179	srcline => $srcline_start,
180	srcfilestop => $srcfile,
181	srclinestop => $srcline,
182	appobj => $appobj,
183	);
184
185	return $this;
186
187	}
188
189	##############################################################################
190
191	sub get_segment_attrs {
192	my $this = shift;
193	my $segment = shift;
194	return @{$this->{seg_attrs}{$segment}};
195	}
196
197	##############################################################################
198
199	sub add_attrs {
200	my $this = shift;
201	my $attrs = shift;
202
203	if($attrs->{type} eq 'link') {
204	push @{$this->{link_attrs}}, $attrs;
205	} elsif(exists $this->{seg_attrs}{$attrs->{type}}) {
206	my $len = @{$this->{seg_attrs}{$attrs->{type}}};
207	push @{$this->{seg_attrs}{$attrs->{type}}}, $attrs;
208	$attrs->unique_name($this->secname . "_$attrs->{type}_$len");
209	}
210	}
211
212	##############################################################################
213
214	sub get_map_attrs {
215	my $this = shift;
216	my @attrs;
217	foreach my $seg (Midas::Segment->all_names()) {
218	push @attrs, $this->get_segment_attrs($seg);
219	}
220	return @attrs;
221	}
222
223	##############################################################################
224
225	sub get_link_attrs {
226	my $this = shift;
227	return @{$this->{link_attrs}};
228	}
229
230	##############################################################################
231
232	sub print_debug {
233	my $this = shift;
234
235	chat "Section $this->{name}\n", 3;
236
237	foreach my $seg (Midas::Segment->all_names()) {
238	my $num = $this->get_segment_attrs($seg);
239	chat " num_$seg\t=$num\n", 3;
240	}
241
242
243	my $nl = $this->get_link_attrs();
244	chat " num_link = $nl\n", 3;
245
246	my @files = @{$this->{files}}; my $n_files = @files;
247	chat " FILES ($n_files)\n", 3;
248	foreach my $f (@files) {
249	chat " " . $f->debug_string . "\n", 3;
250	}
251	}
252
253	##############################################################################
254
255	# This function may be called from a child thread, sot it is important
256	# that it doesn't write any state (i.e., have any side-effects)
257	sub build {
258	my $this = shift;
259	foreach my $source (@{$this->{files}}) {
260	$source->build();
261	}
262	}
263
264	#############################################################################
265
266	sub secname {
267	my $this = shift;
268	return lc $this->{name};
269	}
270
271	##############################################################################
272
273	sub preprocess_midas_directive {
274	my $this = shift;
275	my $line = shift;
276
277	my $output = $line;
278
279
280	$output =~ s/(\$(\w+))/exists $ENV{$2} ? $ENV{$2} : $1/ge;
281
282	return $output;
283	}
284
285	##############################################################################
286
287	sub parse_midas_cc_line {
288	my $this = shift;
289	my $line = shift;
290	my $srcline = shift;
291	my $srcfile = shift;
292
293	my ($file, $output, $args);
294	my $processed = $this->preprocess_midas_directive($line);
295	if($processed =~ /\bFILE\s=\s(\S+)/) {
296	$file = $1;
297	}
298	if($processed =~ /\bOUTPUT\s=\s(\S+)/) {
299	$output = $1;
300	}
301	if($processed =~ /\bARGS\s=\s(.*)$/) {
302	$args = $1;
303	}
304
305	fatal "MIDAS_CC line does not contain FILE argument at line=$srcline, ".
306	"file=$srcfile\n", M_DIRECTIVESYNTAX unless defined $file;
307
308	my $assemble = 0;
309	$assemble = 1 if defined $args && $args =~ /(\s\|\A)-S(\s\|\Z)/;
310
311	my $sfile;
312	my $ofile;
313
314	my $full_file = $file;
315	$file = basename $file;
316
317	if($assemble) {
318	$sfile = $output;
319	if(not defined $output) {
320	if($file =~ /\.c$/) {
321	($sfile = $file) =~ s/\.c$/.s/;
322	} else {
323	$sfile = $file . ".s";
324	}
325	($ofile = $sfile) =~ s/\.s$/.o/;
326	} elsif($sfile =~ /\.s$/) {
327	($ofile = $sfile) =~ s/\.s$/.o/;
328	} elsif($sfile =~ /\.o$/) {
329	$ofile = $sfile;
330	$sfile =~ s/\.o$/.s/;
331	} else {
332	$ofile = $sfile . ".o";
333	}
334	} else {
335	$ofile = $output;
336	if(not defined $output) {
337	if($file =~ /\.c$/) {
338	($ofile = $file) =~ s/\.c$/.o/;
339	} else {
340	$ofile = $file . ".o";
341	}
342	}
343	}
344
345	my $rec = {
346	cfile => $file,
347	sfile => $sfile,
348	ofile => $ofile,
349	assemble => $assemble,
350	args => $args,
351	};
352
353	chat "LINE: $line\n", 3;
354	chat " cfile = $file\n", 3;
355	chat " sfile = $sfile\n", 3;
356	chat " ofile = $ofile\n", 3;
357	chat " assemble = $assemble\n", 3;
358	chat " args = $args\n", 3;
359	chat " fullsource = $full_file", 3;
360
361	my $source = Midas::Source::C->new(
362	cfile => $file,
363	sfile => $sfile,
364	ofile => $ofile,
365	args => $args,
366	fullsource => $full_file,
367	);
368
369	$source->copy_to_build_dir();
370	$source->process_source();
371
372	push @{$this->{files}}, $source;
373
374	}
375
376	##############################################################################
377
378	sub parse_midas_obj_line {
379	my $this = shift;
380	my $line = shift;
381	my $srcline = shift;
382	my $srcfile = shift;
383
384	my $file;
385	my $processed = $this->preprocess_midas_directive($line);
386	if($processed =~ /\bFILE\s=\s(\S+)/) {
387	$file = $1;
388	}
389
390	fatal "MIDAS_OBJ line does not contain FILE argument at line=$srcline, ".
391	"file=$srcfile\n", M_DIRECTIVESYNTAX unless defined $file;
392
393	chat "LINE: $line\n", 3;
394	chat " ofile = $file\n", 3;
395
396	my $source = Midas::Source::Object->new(
397	ofile => $file,
398	fullsource => $file,
399	);
400
401	$source->copy_to_build_dir();
402	$source->process_source();
403
404	push @{$this->{files}}, $source;
405
406	}
407
408	##############################################################################
409
410	sub parse_midas_lib_line {
411	my $this = shift;
412	my $line = shift;
413	my $srcline = shift;
414	my $srcfile = shift;
415
416	my $file;
417	my $processed = $this->preprocess_midas_directive($line);
418	if($processed =~ /\bFILE\s=\s(\S+)/) {
419	$file = $1;
420	}
421
422	fatal "MIDAS_LIB line does not contain FILE argument at line=$srcline, ".
423	"file=$srcfile\n", M_DIRECTIVESYNTAX unless defined $file;
424
425	chat "LINE: $line\n", 3;
426	chat " ofile = $file\n", 3;
427
428	my $source = Midas::Source::Library->new(
429	ofile => $file,
430	fullsource => $file,
431	);
432
433	$source->copy_to_build_dir();
434	$source->process_source();
435
436	push @{$this->{files}}, $source;
437
438	}
439
440	##############################################################################
441
442	sub get_object_list {
443	my $this = shift;
444
445	my @olist =
446	map { $_->get_object_file() }
447	grep { ! $_->is_library() }
448	@{$this->{files}};
449	return @olist;
450	}
451
452	##############################################################################
453
454	sub get_library_list {
455	my $this = shift;
456
457	my @alist =
458	map { $_->get_object_file() }
459	grep { $_->is_library() }
460	@{$this->{files}};
461	return @alist;
462	}
463
464	##############################################################################
465
466	sub sanity_check {
467	my $this = shift;
468
469	my $fline = "File=$this->{srcfile}, Line=$this->{srclinestop}";
470
471	my $error = 0;
472	my @messages;
473
474	if(scalar($this->get_map_attrs()) == 0) {
475	my $message = "Section $this->{name} has no attr blocks!\n";
476	$message .=" at $fline\n";
477	push @messages, { message => $message, code => M_SECSYNTAX };
478	}
479
480	my %link_seg;
481	foreach my $link_attr ($this->get_link_attrs()) {
482	push @messages, $link_attr->sanity_check();
483
484	foreach my $seg (Midas::Segment->all_names()) {
485	$link_seg{$seg} = 0 unless exists $link_seg{$seg};
486	$link_seg{$seg} \|\|= $link_attr->has_segment($seg);
487	}
488	}
489
490	foreach my $attr ($this->get_map_attrs()) {
491	push @messages, $attr->sanity_check();
492	}
493
494	foreach my $seg (Midas::Segment->all_names()) {
495	my @seg_attrs = $this->get_segment_attrs($seg);
496	if(not $CONFIG{allow_empty_sections}) {
497	if($link_seg{$seg} and ! @seg_attrs) {
498	my $message =
499	"Section $this->{name} has ${seg}_va but no attr_${seg} ".
500	"blocks\n at $fline\n";
501	push @messages, { message => $message, code => M_SECSYNTAX };
502	}
503	}
504	foreach my $attr (@seg_attrs) {
505	my $attr_fline = $attr->get_fline();
506	if(not $link_seg{$seg}) {
507	my $message = "Section $this->{name} has attr_$seg but no ${seg}_va\n".
508	" at $attr_fline\n";
509	push @messages, { message => $message, code => M_SECSYNTAX };
510	}
511	}
512	}
513
514	return @messages;
515	}
516
517	##############################################################################
518
519	sub has_segment {
520	my $this = shift;
521	my $segment = shift;
522	return 1 if scalar $this->get_segment_attrs($segment);
523	return;
524	}
525
526	##############################################################################
527
528	sub get_section_link_tag {
529	my $this = shift;
530	my @olist = $this->get_object_list();
531	@olist = $this->get_library_list() unless @olist;
532	my $sectag = basename $olist[0], '.o', '.a';
533	return $sectag;
534	}
535
536	##############################################################################
537
538	sub get_segment_link_name {
539	my $this = shift;
540	my $segment = shift;
541	my $sectag = $this->get_section_link_tag();
542	my $link_suffix = Midas::Segment->name2link_suffix($segment);
543	return "$sectag$link_suffix";
544	}
545
546	##############################################################################
547	##############################################################################
548
549
550	1;