From 93d89c2b5e8497365be152fb53cb6cd4c5764d34 Mon Sep 17 00:00:00 2001 From: xleroy Date: Wed, 3 Mar 2010 10:25:25 +0000 Subject: Getting rid of CIL git-svn-id: https://yquem.inria.fr/compcert/svn/compcert/trunk@1270 fca1b0fc-160b-0410-b1d3-a4f43f01ea2e --- cil/lib/Cilly.pm | 2137 ------------------------------------------------- cil/lib/KeptFile.pm | 88 -- cil/lib/OutputFile.pm | 213 ----- cil/lib/TempFile.pm | 90 --- 4 files changed, 2528 deletions(-) delete mode 100644 cil/lib/Cilly.pm delete mode 100644 cil/lib/KeptFile.pm delete mode 100644 cil/lib/OutputFile.pm delete mode 100644 cil/lib/TempFile.pm (limited to 'cil/lib') diff --git a/cil/lib/Cilly.pm b/cil/lib/Cilly.pm deleted file mode 100644 index fa7aa53b..00000000 --- a/cil/lib/Cilly.pm +++ /dev/null @@ -1,2137 +0,0 @@ -# -# -# Copyright (c) 2001-2002, -# George C. Necula -# Scott McPeak -# Wes Weimer -# All rights reserved. -# -# Redistribution and use in source and binary forms, with or without -# modification, are permitted provided that the following conditions are -# met: -# -# 1. Redistributions of source code must retain the above copyright -# notice, this list of conditions and the following disclaimer. -# -# 2. Redistributions in binary form must reproduce the above copyright -# notice, this list of conditions and the following disclaimer in the -# documentation and/or other materials provided with the distribution. -# -# 3. The names of the contributors may not be used to endorse or promote -# products derived from this software without specific prior written -# permission. -# -# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS -# IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -# TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A -# PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER -# OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, -# EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -# PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR -# PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF -# LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING -# NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -# SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -# - - - -# This module implements a compiler stub that parses the command line -# arguments of gcc and Microsoft Visual C (along with some arguments for the -# script itself) and gives hooks into preprocessing, compilation and linking. - - -$::cilbin = 'bin'; - -package Cilly; -@ISA = (); - -use strict; -use File::Basename; -use File::Copy; -use File::Spec; -use Data::Dumper; -use Carp; -use Text::ParseWords; - -use KeptFile; -use OutputFile; -use TempFile; - -$Cilly::savedSourceExt = "_saved.c"; - -# Pass to new a list of command arguments -sub new { - my ($proto, @args) = @_; - - my $class = ref($proto) || $proto; - - my $ref = - { CFILES => [], # C input files - SFILES => [], # Assembly language files - OFILES => [], # Other input files - IFILES => [], # Already preprocessed files - EARLY_PPARGS => [], # Preprocessor args, first (pre-CIL) pass only - PPARGS => [], # Preprocessor args - CCARGS => [], # Compiler args - LINKARGS => [], # Linker args - NATIVECAML => 1, # this causes the native code boxer to be used - RELEASELIB => 0, # if true, use the release runtime library (if any) - # IDASHI => 1, # if true, pass "-I-" to gcc's preprocessor - IDASHDOT => 1, # if true, pass "-I." to gcc's preprocessor - VERBOSE => 0, # when true, print extra detail - TRACE_COMMANDS => 1, # when true, echo commands being run - SEPARATE => ! $::default_is_merge, - LIBDIR => [], - OPERATION => 'TOEXE', # This is the default for all compilers - }; - my $self = bless $ref, $class; - - if(! @args) { - print "No arguments passed\n"; - $self->printHelp(); - exit 0; - } - # Look for the --mode argument first. If not found it is GCC - my $mode = $::default_mode; - { - my @args1 = (); - foreach my $arg (@args) { - if($arg =~ m|--mode=(.+)$|) { - $mode = $1; - } else { - push @args1, $arg; - } - } - @args = @args1; # These are the argument after we extracted the --mode - - } - if(defined $self->{MODENAME} && $self->{MODENAME} ne $mode) { - die "Cannot re-specify the compiler"; - } - { - my $compiler; - if($mode eq "MSVC") { - unshift @Cilly::ISA, qw(MSVC); - $compiler = MSVC->new($self); - } elsif($mode eq "GNUCC") { - unshift @Cilly::ISA, qw(GNUCC); - $compiler = GNUCC->new($self); - } elsif($mode eq "MSLINK") { - unshift @Cilly::ISA, qw(MSLINK); - $compiler = MSLINK->new($self); - } elsif($mode eq "MSLIB") { - unshift @Cilly::ISA, qw(MSLIB); - $compiler = MSLIB->new($self); - } elsif($mode eq "AR") { - unshift @Cilly::ISA, qw(AR); - $compiler = AR->new($self); - } else { - die "Don't know about compiler $mode\n"; - } - # Now grab the fields from the compiler and put them inside self - my $key; - foreach $key (keys %{$compiler}) { - $self->{$key} = $compiler->{$key}; - } - - # For MSVC we have to use --save-temps because otherwise the - # temporary files get deleted somehow before CL gets at them ! - if($mode ne "GNUCC" && $mode ne "AR") { - $self->{SAVE_TEMPS} = '.'; - } - } - - # Scan and process the arguments - $self->setDefaultArguments; - collectArgumentList($self, @args); - - # sm: if an environment variable is set, then do not merge; this - # is intended for use in ./configure scripts, where merging delays - # the reporting of errors that the script is expecting - if (defined($ENV{"CILLY_NOMERGE"})) { - $self->{SEPARATE} = 1; - if($self->{VERBOSE}) { print STDERR "Merging disabled by CILLY_NOMERGE\n"; } - } - -# print Dumper($self); - - return $self; -} - -# Hook to let subclasses set/override default arguments -sub setDefaultArguments { -} - -# work through an array of arguments, processing each one -sub collectArgumentList { - my ($self, @args) = @_; - - # Scan and process the arguments - while($#args >= 0) { - my $arg = $self->fetchNextArg(\@args); - - if(! defined($arg)) { - last; - } - if($arg eq "") { next; } - - #print("arg: $arg\n"); -# -# my $arg = shift @args; # Grab the next one - if(! $self->collectOneArgument($arg, \@args)) { - print "Warning: Unknown argument $arg\n"; - push @{$self->{CCARGS}}, $arg; - } - } -} - -# Grab the next argument -sub fetchNextArg { - my ($self, $pargs) = @_; - return shift @{$pargs}; -} - -# Collecting arguments. Take a look at one argument. If we understand it then -# we return 1. Otherwise we return 0. Might pop some more arguments from pargs. -sub collectOneArgument { - my($self, $arg, $pargs) = @_; - my $res; - # Maybe it is a compiler option or a source file - if($self->compilerArgument($self->{OPTIONS}, $arg, $pargs)) { return 1; } - - if($arg eq "--help" || $arg eq "-help") { - $self->printVersion(); - $self->printHelp(); - exit 1; - } - if($arg eq "--version" || $arg eq "-version") { - $self->printVersion(); exit 0; - } - if($arg eq "--verbose") { - $self->{VERBOSE} = 1; return 1; - } - if($arg eq "--flatten_linker_scripts") { - $self->{FLATTEN_LINKER_SCRIPTS} = 1; return 1; - } - if($arg eq '--nomerge') { - $self->{SEPARATE} = 1; - return 1; - } - if($arg eq '--merge') { - $self->{SEPARATE} = 0; - return 1; - } - if($arg =~ "--ccargs=(.+)\$") { - push @{$self->{CCARGS}}, $1; - return 1; - } - if($arg eq '--trueobj') { - $self->{TRUEOBJ} = 1; - return 1; - } - # zf: force curing when linking to a lib - if ($arg eq '--truelib') { - $self->{TRUELIB} = 1; - return 1; - } - if($arg eq '--keepmerged') { - $self->{KEEPMERGED} = 1; - return 1; - } - if($arg eq '--stdoutpp') { - $self->{STDOUTPP} = 1; - return 1; - } - if($arg =~ m|--save-temps=(.+)$|) { - if(! -d $1) { - die "Cannot find directory $1"; - } - $self->{SAVE_TEMPS} = $1; - return 1; - } - if($arg eq '--save-temps') { - $self->{SAVE_TEMPS} = '.'; - return 1; - } - if($arg =~ m|--leavealone=(.+)$|) { - push @{$self->{LEAVEALONE}}, $1; - return 1; - } - if($arg =~ m|--includedir=(.+)$|) { - push @{$self->{INCLUDEDIR}}, $1; return 1; - } - if($arg =~ m|--stages|) { - $self->{SHOWSTAGES} = 1; - push @{$self->{CILARGS}}, $arg; - return 1; - } - if($arg eq "--bytecode") { - $self->{NATIVECAML} = 0; return 1; - } -# if($arg eq "--no-idashi") { -# $self->{IDASHI} = 0; return 1; -# } - if($arg eq "--no-idashdot") { - $self->{IDASHDOT} = 0; return 1; - } - - # sm: response file - if($arg =~ m|-@(.+)$| || - (($self->{MODENAME} eq "MSVC" || - $self->{MODENAME} eq "MSLINK" || - $self->{MODENAME} eq "MSLIB") && $arg =~ m|@(.+)$|)) { - my $fname = $1; # name of response file - &classifyArgDebug("processing response file: $fname\n"); - - # read the lines into an array - if (!open(RF, "<$fname")) { - die("cannot open response file $fname: $!\n"); - } - my @respArgs = (); - while() { - # Drop spaces and empty lines - my ($middle) = ($_ =~ m|\s*(\S.*\S)\s*|); - if($middle ne "") { - # Sometimes we have multiple arguments in one line :-() - if($middle =~ m|\s| && - $middle !~ m|[\"]|) { - # Contains spaces and no quotes - my @middles = split(/\s+/, $middle); - push @respArgs, @middles; - } else { - push @respArgs, $middle; - } -# print "Arg:$middle\n"; - } - } - close(RF) or die; - - - # Scan and process the arguments - collectArgumentList($self, @respArgs); - - #print("done with response file: $fname\n"); - return 1; # argument undestood - } - if($arg eq "-@" || ($self->{MODENAME} eq "MSVC" && $arg eq "@")) { - # sm: I didn't implement the case where it takes the next argument - # because I wasn't sure how to grab add'l args (none of the - # cases above do..) - die("For ccured/cilly, please don't separate the -@ from the\n", - "response file name. e.g., use -@", "respfile.\n"); - } - - # Intercept the --out argument - if($arg =~ m|^--out=(\S+)$|) { - $self->{CILLY_OUT} = $1; - push @{$self->{CILARGS}}, "--out", $1; - return 1; - } - # All other arguments starting with -- are passed to CIL - if($arg =~ m|^--|) { - # Split the == - if($arg =~ m|^(--\S+)=(.+)$|) { - push @{$self->{CILARGS}}, $1, $2; return 1; - } else { - push @{$self->{CILARGS}}, $arg; return 1; - } - } - return 0; -} - - -sub printVersion { - system ($CilCompiler::compiler, '--version'); -} - -sub printHelp { - my($self) = @_; - $self->usage(); - print <helpMessage(); -} - -# For printing the first line of the help message -sub usage { - my ($self) = @_; - print ""; -} - -# The rest of the help message -sub helpMessage { - my ($self) = @_; - print <{OUTLIB} . $dest); - # Pass the linkargs last because some libraries must be passed after - # the sources - my @cmd = (@{$self->{LDLIB}}, @dest, @{$ppargs}, @{$ccargs}, @sources, @{$ldargs}); - return $self->runShell(@cmd); -} - -# Customize the linking into libraries -sub linktolib { - my($self, $psrcs, $dest, $ppargs, $ccargs, $ldargs) = @_; - if($self->{VERBOSE}) { print STDERR "Linking into library $dest\n"; } - - # Now collect the files to be merged - my ($tomerge, $trueobjs, $ccargs) = - $self->separateTrueObjects($psrcs, $ccargs); - - if($self->{SEPARATE} || @{$tomerge} == 0) { - # Not merging. Regular linking. - - return $self->straight_linktolib($psrcs, $dest, - $ppargs, $ccargs, $ldargs); - } - # We are merging. Merge all the files into a single one - - if(@{$trueobjs} > 0) { - # We have some true objects. Save them into an additional file - my $trueobjs_file = "$dest" . "_trueobjs"; - if($self->{VERBOSE}) { - print STDERR - "Saving additional true object files in $trueobjs_file\n"; - } - open(TRUEOBJS, ">$trueobjs_file") || die "Cannot write $trueobjs_file"; - foreach my $true (@{$trueobjs}) { - my $abs = File::Spec->rel2abs($true); - print TRUEOBJS "$abs\n"; - } - close(TRUEOBJS); - } - if(@{$tomerge} == 1) { # Just copy the file over - (!system('cp', '-f', ${$tomerge}[0], $dest)) - || die "Cannot copy ${$tomerge}[0] to $dest\n"; - return ; - } - # - # We must do real merging - # - # Prepare the name of the CIL output file based on dest - my ($base, $dir, $ext) = fileparse($dest, "(\\.[^.]+)"); - - # Now prepare the command line for invoking cilly - my ($aftercil, @cmd) = $self->MergeCommand ($psrcs, $dir, $base); - die unless $cmd[0]; - - if($self->{MODENAME} eq "MSVC") { - push @cmd, "--MSVC"; - } - if($self->{VERBOSE}) { - push @cmd, "--verbose"; - } - if(defined $self->{CILARGS}) { - push @cmd, @{$self->{CILARGS}}; - } - # Eliminate duplicates - - # Add the arguments - if(@{$tomerge} > 20) { - my $extraFile = "___extra_files"; - open(TOMERGE, ">$extraFile") || die $!; - #FRANJO added the following on February 15th, 2005 - #REASON: extrafiles was TempFIle=HASH(0x12345678) - # instead of actual filename - my @normalized = @{$tomerge} ; - $_ = (ref $_ ? $_->filename : $_) foreach @normalized; - foreach my $fl (@normalized) { - print TOMERGE "$fl\n"; - } - close(TOMERGE); - push @cmd, '--extrafiles', $extraFile; - } else { - push @cmd, @{$tomerge}; - } - push @cmd, "--mergedout", $dest; - # Now run cilly - return $self->runShell(@cmd); -} - -############ -############ PREPROCESSING -############ -# -# All flavors of preprocessing return the destination file -# - -# THIS IS THE ENTRY POINT FOR COMPILING SOURCE FILES -sub preprocess_compile { - my ($self, $src, $dest, $early_ppargs, $ppargs, $ccargs) = @_; - &mydebug("preprocess_compile(src=$src, dest=$dest)\n"); - Carp::confess "bad dest: $dest" unless $dest->isa('OutputFile'); - - my ($base, $dir, $ext) = fileparse($src, "\\.[^.]+"); - if($ext eq ".c" || $ext eq ".cpp" || $ext eq ".cc") { - if($self->leaveAlone($src)) { - print "Leaving alone $src\n"; - # We leave this alone. So just compile as usual - return $self->straight_compile($src, $dest, $early_ppargs, $ppargs, $ccargs); - } - my $out = $self->preprocessOutputFile($src); - $out = $self->preprocess($src, $out, - [@{$early_ppargs}, @{$ppargs}, - "$self->{DEFARG}CIL=1"]); - return $self->compile($out, $dest, $ppargs, $ccargs); - } - if($ext eq ".i") { - return $self->compile($src, $dest, $ppargs, $ccargs); - } - if($ext eq ".$::cilbin") { - return $self->compile($src, $dest, $ppargs, $ccargs); - } -} - -# THIS IS THE ENTRY POINT FOR JUST PREPROCESSING A FILE -sub preprocess { - my($self, $src, $dest, $ppargs) = @_; - Carp::confess "bad dest: $dest" unless $dest->isa('OutputFile'); - return $self->preprocess_before_cil($src, $dest, $ppargs); -} - -# Find the name of the preprocessed file before CIL processing -sub preprocessOutputFile { - my($self, $src) = @_; - return $self->outputFile($src, 'i'); -} - -# Find the name of the preprocessed file after CIL processing -sub preprocessAfterOutputFile { - my($self, $src) = @_; - return $self->outputFile($src, 'cil.i'); -} - -# When we use CIL we have two separate preprocessing stages. First is the -# preprocessing before the CIL sees the code and the is the preprocessing -# after CIL sees the code - -sub preprocess_before_cil { - my ($self, $src, $dest, $ppargs) = @_; - Carp::confess "bad dest: $dest" unless $dest->isa('OutputFile'); - my @args = @{$ppargs}; - - # See if we must force some includes - if(defined $self->{INCLUDEDIR} && !defined($ENV{"CILLY_NOCURE"})) { - # And force the other includes. Put them at the begining - if(($self->{MODENAME} eq 'GNUCC') && - # sm: m88k doesn't work if I pass -I. - $self->{IDASHDOT}) { - unshift @args, "-I."; - } - if(! defined($self->{VERSION})) { - $self->setVersion(); - } - unshift @args, - map { my $dir = $_; - $self->{INCARG} . $dir . "/" . $self->{VERSION} } - @{$self->{INCLUDEDIR}}; - #matth: include the main include dir as well as the compiler-specific directory - unshift @args, - map { my $dir = $_; - $self->{INCARG} . $dir } - @{$self->{INCLUDEDIR}}; - if($self->{MODENAME} eq 'GNUCC') { - # sm: this is incompatible with wu-ftpd, but is apparently needed - # for apache.. more investigation is needed - # update: now when I try it, apache works without -I- also.. but - # I'll make this into a switchable flag anyway - # matth: this breaks other tests. Let's try without. -# if ($self->{IDASHI}) { -# unshift @args, "-I-"; -# } - } - } - - return $self->straight_preprocess($src, $dest, \@args); -} - -# Preprocessing after CIL -sub preprocess_after_cil { - my ($self, $src, $dest, $ppargs) = @_; - Carp::confess "bad dest: $dest" unless $dest->isa('OutputFile'); - return $self->straight_preprocess($src, $dest, $ppargs); -} - -# -# This is intended to be the true invocation of the underlying preprocessor -# You should not override this method -sub straight_preprocess { - my ($self, $src, $dest, $ppargs) = @_; - Carp::confess "bad dest: $dest" unless $dest->isa('OutputFile'); - if($self->{VERBOSE}) { - my $srcname = ref $src ? $src->filename : $src; - print STDERR "Preprocessing $srcname\n"; - } - if($self->{MODENAME} eq "MSVC" || - $self->{MODENAME} eq "MSLINK" || - $self->{MODENAME} eq "MSLIB") { - $self->MSVC::msvc_preprocess($src, $dest, $ppargs); - } else { -# print Dumper($self); - my @cmd = (@{$self->{CPP}}, @{$ppargs}, - $src, $self->makeOutArguments($self->{OUTCPP}, $dest)); - $self->runShell(@cmd); - - } - return $dest; -} - - -# -# -# -# COMPILATION -# -# - -sub compile { - my($self, $src, $dest, $ppargs, $ccargs) = @_; - &mydebug("Cilly.compile(src=$src, dest=$dest->{filename})\n"); - Carp::confess "bad dest: $dest->{filename}" - unless $dest->isa('OutputFile'); - - if($self->{SEPARATE}) { - # Now invoke CIL and compile afterwards - return $self->applyCilAndCompile([$src], $dest, $ppargs, $ccargs); - } - # We are merging - # If we are merging then we just save the preprocessed source - my ($mtime, $res, $outfile); - if(! $self->{TRUEOBJ}) { - $outfile = $dest->{filename}; $mtime = 0; $res = $dest; - } else { - # Do the real compilation - $res = $self->straight_compile($src, $dest, $ppargs, $ccargs); - # Now stat the result - my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, - $atime,$mtime_1,$ctime,$blksize,$blocks) = stat($dest->{filename}); - if(! defined($mtime_1)) { - die "Cannot stat the result of compilation $dest->{filename}"; - } - $mtime = $mtime_1; - $outfile = $dest->{filename} . $Cilly::savedSourceExt; - } - my $srcname = ref $src ? $src->filename : $src; - if($self->{VERBOSE}) { - print STDERR "Saving source $srcname into $outfile\n"; - } - open(OUT, ">$outfile") || die "Cannot create $outfile"; - my $toprintsrc = $srcname; - $toprintsrc =~ s|\\|/|g; - print OUT "#pragma merger($mtime,\"$toprintsrc\",\"" . - join(',', @{$ccargs}), "\")\n"; - open(IN, '<', $srcname) || die "Cannot read $srcname"; - while() { - print OUT $_; - } - close(OUT); - close(IN); - return $res; -} - -sub makeOutArguments { - my ($self, $which, $dest) = @_; - $dest = $dest->{filename} if ref $dest; - if($self->{MODENAME} eq "MSVC" || - $self->{MODENAME} eq "MSLINK" || - $self->{MODENAME} eq "MSLIB") { - # A single argument - return ("$which$dest"); - } else { - return ($which, $dest); - } -} -# This is the actual invocation of the underlying compiler. You should not -# override this -sub straight_compile { - my ($self, $src, $dest, $ppargs, $ccargs) = @_; - if($self->{VERBOSE}) { - print STDERR 'Compiling ', ref $src ? $src->filename : $src, ' into ', - $dest->filename, "\n"; - } - my @dest = - $dest eq "" ? () : $self->makeOutArguments($self->{OUTOBJ}, $dest); - my @forcec = @{$self->{FORCECSOURCE}}; - my @cmd = (@{$self->{CC}}, @{$ppargs}, @{$ccargs}, - @dest, @forcec, $src); - return $self->runShell(@cmd); -} - -# This is compilation after CIL -sub compile_cil { - my ($self, $src, $dest, $ppargs, $ccargs) = @_; - return $self->straight_compile($src, $dest, $ppargs, $ccargs); -} - - - -# THIS IS THE ENTRY POINT FOR JUST ASSEMBLING FILES -sub assemble { - my ($self, $src, $dest, $ppargs, $ccargs) = @_; - if($self->{VERBOSE}) { print STDERR "Assembling $src\n"; } - my @dest = - $dest eq "" ? () : $self->makeOutArguments($self->{OUTOBJ}, $dest); - my @cmd = (@{$self->{CC}}, @{$ppargs}, @{$ccargs}, - @dest, $src); - return $self->runShell(@cmd); -} - - - -# -# This is intended to be the true invocation of the underlying linker -# You should not override this method -sub straight_link { - my ($self, $psrcs, $dest, $ppargs, $ccargs, $ldargs) = @_; - my @sources = ref($psrcs) ? @{$psrcs} : ($psrcs); - my @dest = - $dest eq "" ? () : $self->makeOutArguments($self->{OUTEXE}, $dest); - # Pass the linkargs last because some libraries must be passed after - # the sources - my @cmd = (@{$self->{LD}}, @dest, - @{$ppargs}, @{$ccargs}, @sources, @{$ldargs}); - return $self->runShell(@cmd); -} - -# -# See if some libraries are actually lists of files -sub expandLibraries { - my ($self) = @_; - - my @tolink = @{$self->{OFILES}}; - - # Go through the sources and replace all libraries with the files that - # they contain - my @tolink1 = (); - while($#tolink >= 0) { - my $src = shift @tolink; -# print "Looking at $src\n"; - # See if the source is a library. Then maybe we should get instead the - # list of files - if($src =~ m|\.$self->{LIBEXT}$| && -f "$src.files") { - open(FILES, "<$src.files") || die "Cannot read $src.files"; - while() { - # Put them back in the "tolink" to process them recursively - while($_ =~ m|[\r\n]$|) { - chop; - } - unshift @tolink, $_; - } - close(FILES); - next; - } - # This is not for us - push @tolink1, $src; - next; - } - $self->{OFILES} = \@tolink1; -} - -# Go over a list of object files and separate them into those that are -# actually sources to be merged, and the true object files -# -sub separateTrueObjects { - my ($self, $psrcs, $ccargs) = @_; - - my @sources = @{$psrcs}; -# print "Sources are @sources\n"; - my @tomerge = (); - my @othersources = (); - - my @ccmerged = @{$ccargs}; - foreach my $src (@sources) { - my ($combsrc, $combsrcname, $mtime); - my $srcname = ref $src ? $src->filename : $src; - if(! $self->{TRUEOBJ}) { - # We are using the object file itself to save the sources - $combsrcname = $srcname; - $combsrc = $src; - $mtime = 0; - } else { - $combsrcname = $srcname . $Cilly::savedSourceExt; - $combsrc = $combsrcname; - if(-f $combsrcname) { - my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, - $atime,$mtime_1,$ctime,$blksize,$blocks) = stat($srcname); - $mtime = $mtime_1; - } else { - $mtime = 0; - } - } - # Look inside and see if it is one of the files created by us - open(IN, "<$combsrcname") || die "Cannot read $combsrcname"; - my $fstline = ; - close(IN); - if($fstline =~ m|CIL|) { - goto ToMerge; - } - if($fstline =~ m|^\#pragma merger\((\d+),\".*\",\"(.*)\"\)$|) { - my $mymtime = $1; - # Get the CC flags - my @thisccargs = split(/,/, $2); - foreach my $arg (@thisccargs) { - # print "Looking at $arg\n ccmerged=@ccmerged\n"; - if(! grep(/$arg/, @ccmerged)) { - # print " adding it\n"; - push @ccmerged, $arg - } - } - ToMerge: - if($mymtime == $mtime) { # It is ours - # See if we have this already - if(! grep { $_ eq $srcname } @tomerge) { # It is ours - push @tomerge, $combsrc; - # See if there is a a trueobjs file also - my $trueobjs = $combsrcname . "_trueobjs"; - if(-f $trueobjs) { - open(TRUEOBJS, "<$trueobjs") - || die "Cannot read $trueobjs"; - while() { - chop; - push @othersources, $_; - } - close(TRUEOBJS); - } - } - next; - } - } - push @othersources, $combsrc; - } - # If we are merging, turn off "warnings are errors" flag - if(grep(/$self->{WARNISERROR}/, @ccmerged)) { - @ccmerged = grep(!/$self->{WARNISERROR}/, @ccmerged); - print STDERR "Turning off warn-is-error flag $self->{WARNISERROR}\n"; - } - - return (\@tomerge, \@othersources, \@ccmerged); -} - - -# Customize the linking -sub link { - my($self, $psrcs, $dest, $ppargs, $ccargs, $ldargs) = @_; - my $destname = ref $dest ? $dest->filename : $dest; - if($self->{SEPARATE}) { - if (!defined($ENV{CILLY_DONT_LINK_AFTER_MERGE})) { - if($self->{VERBOSE}) { print STDERR "Linking into $destname\n"; } - # Not merging. Regular linking. - return $self->link_after_cil($psrcs, $dest, - $ppargs, $ccargs, $ldargs); - } - else { - return 0; # sm: is this value used?? - } - } - my $mergedobj = new OutputFile($destname, - "${destname}_comb.$self->{OBJEXT}"); - - # We must merge - if($self->{VERBOSE}) { - print STDERR "Merging saved sources into $mergedobj->{filename} (in process of linking $destname)\n"; - } - - # Now collect the files to be merged - - my ($tomerge, $trueobjs, $ccargs) = - $self->separateTrueObjects($psrcs, $ccargs); - - if($self->{VERBOSE}) { - print STDERR "Will merge the following: ", - join(' ', @{$tomerge}), "\n"; - print STDERR "Will just link the genuine object files: ", - join(' ', @{$trueobjs}), "\n"; - print STDERR "After merge compile flags: @{$ccargs}\n"; - } - # Check the modification times and see if we can just use the combined - # file instead of merging all over again - if(@{$tomerge} > 1 && $self->{KEEPMERGED}) { - my $canReuse = 1; - my $combFile = new OutputFile($destname, - "${destname}_comb.c"); - my @tmp = stat($combFile); - my $combFileMtime = $tmp[9] || 0; - foreach my $mrg (@{$tomerge}) { - my @tmp = stat($mrg); my $mtime = $tmp[9]; - if($mtime >= $combFileMtime) { goto DoMerge; } - } - if($self->{VERBOSE}) { - print STDERR "Reusing merged file $combFile\n"; - } - $self->applyCilAndCompile([$combFile], $mergedobj, $ppargs, $ccargs); - } else { - DoMerge: - $self->applyCilAndCompile($tomerge, $mergedobj, $ppargs, $ccargs); - } - - # Put the merged OBJ at the beginning because maybe some of the trueobjs - # are libraries which like to be at the end - unshift @{$trueobjs}, $mergedobj; - - # And finally link - # zf: hack for linking linux stuff - if ($self->{TRUELIB}) { - my @cmd = (@{$self->{LDLIB}}, ($dest), - @{$ppargs}, @{$ccargs}, @{$trueobjs}, @{$ldargs}); - return $self->runShell(@cmd); - } - - # sm: hack: made this conditional for dsw - if (!defined($ENV{CILLY_DONT_LINK_AFTER_MERGE})) { - $self->link_after_cil($trueobjs, $dest, $ppargs, $ccargs, $ldargs); - } - -} - -sub applyCil { - my ($self, $ppsrc, $dest) = @_; - - # The input files - my @srcs = @{$ppsrc}; - - # Now prepare the command line for invoking cilly - my ($aftercil, @cmd) = $self->CillyCommand ($ppsrc, $dest); - Carp::confess "$self produced bad output file: $aftercil" - unless $aftercil->isa('OutputFile'); - - if($self->{MODENAME} eq "MSVC" || - $self->{MODENAME} eq "MSLINK" || - $self->{MODENAME} eq "MSLIB") { - push @cmd, '--MSVC'; - } - if($self->{VERBOSE}) { - push @cmd, '--verbose'; - } - if(defined $self->{CILARGS}) { - push @cmd, @{$self->{CILARGS}}; - } - - # Add the arguments - if(@srcs > 20) { - my $extraFile = "___extra_files"; - open(TOMERGE, ">$extraFile") || die $!; - foreach my $fl (@srcs) { - my $fname = ref $fl ? $fl->filename : $fl; - print TOMERGE "$fname\n"; - } - close(TOMERGE); - push @cmd, '--extrafiles', $extraFile; - } else { - push @cmd, @srcs; - } - if(@srcs > 1 && $self->{KEEPMERGED}) { - my ($base, $dir, undef) = fileparse($dest->filename, qr{\.[^.]+}); - push @cmd, '--mergedout', "$dir$base" . '.c'; - } - # Now run cilly - $self->runShell(@cmd); - - # Tell the caller where we put the output - return $aftercil; -} - - -sub applyCilAndCompile { - my ($self, $ppsrc, $dest, $ppargs, $ccargs) = @_; - Carp::confess "$self produced bad destination file: $dest" - unless $dest->isa('OutputFile'); - - # The input files - my @srcs = @{$ppsrc}; - &mydebug("Cilly.PM.applyCilAndCompile(srcs=[",join(',',@{$ppsrc}),"])\n"); - - # Now run cilly - my $aftercil = $self->applyCil($ppsrc, $dest); - Carp::confess "$self produced bad output file: $aftercil" - unless $aftercil->isa('OutputFile'); - - # Now preprocess - my $aftercilpp = $self->preprocessAfterOutputFile($aftercil); - $self->preprocess_after_cil($aftercil, $aftercilpp, $ppargs); - - if (!defined($ENV{CILLY_DONT_COMPILE_AFTER_MERGE})) { - # Now compile - return $self->compile_cil($aftercilpp, $dest, $ppargs, $ccargs); - } -} - -# Linking after CIL -sub link_after_cil { - my ($self, $psrcs, $dest, $ppargs, $ccargs, $ldargs) = @_; - if (!defined($ENV{CILLY_DONT_COMPILE_AFTER_MERGE})) { - return $self->straight_link($psrcs, $dest, $ppargs, $ccargs, $ldargs); - } -} - -# See if we must merge this one -sub leaveAlone { - my($self, $filename) = @_; - my ($base, $dir, $ext) = fileparse($filename, "(\\.[^.]+)"); - if(grep { $_ eq $base } @{$self->{LEAVEALONE}}) { - return 1; - } else { - return 0; - } -} - - -# DO EVERYTHING -sub doit { - my ($self) = @_; - my $file; - my $out; - -# print Dumper($self); - - # Maybe we must preprocess only - if($self->{OPERATION} eq "TOI" || $self->{OPERATION} eq 'SPECIAL') { - # Then we do not do anything - my @cmd = (@{$self->{CPP}}, - @{$self->{EARLY_PPARGS}}, - @{$self->{PPARGS}}, @{$self->{CCARGS}}, - @{$self->{CFILES}}, @{$self->{SFILES}}); - push @cmd, @{$self->{OUTARG}} if defined $self->{OUTARG}; - - return $self->runShell(@cmd); - } - # We expand some libraries names. Maybe they just contain some - # new object files - $self->expandLibraries(); - - # Try to guess whether to run in the separate mode. In that case - # we can go ahead with the compilation, without having to save - # files - if(! $self->{SEPARATE} && # Not already separate mode - $self->{OPERATION} eq "TOEXE" && # We are linking to an executable - @{$self->{CFILES}} + @{$self->{IFILES}} <= 1) { # At most one source - # If we have object files, we should keep merging if at least one - # object file is a disguised source - my $turnOffMerging = 0; - if(@{$self->{OFILES}}) { - my ($tomerge, $trueobjs, $mergedccargs) = - $self->separateTrueObjects($self->{OFILES}, $self->{CCARGS}); - $self->{CCARGS} = $mergedccargs; - $turnOffMerging = (@{$tomerge} == 0); - } else { - $turnOffMerging = 1; - } - if($turnOffMerging) { - if($self->{VERBOSE}) { - print STDERR - "Turn off merging because the program contains one file\n"; - } - $self->{SEPARATE} = 1; - } - } - - # Turn everything into OBJ files - my @tolink = (); - - foreach $file (@{$self->{IFILES}}, @{$self->{CFILES}}) { - $out = $self->compileOutputFile($file); - $self->preprocess_compile($file, $out, - $self->{EARLY_PPARGS}, - $self->{PPARGS}, $self->{CCARGS}); - push @tolink, $out; - } - # Now do the assembly language file - foreach $file (@{$self->{SFILES}}) { - $out = $self->assembleOutputFile($file); - $self->assemble($file, $out, $self->{PPARGS}, $self->{CCARGS}); - push @tolink, $out; - } - # Now add the original object files. Put them last because libraries like - # to be last. - push @tolink, @{$self->{OFILES}}; - - # See if we must stop after compilation - if($self->{OPERATION} eq "TOOBJ") { - return; - } - - # See if we must create a library only - if($self->{OPERATION} eq "TOLIB") { - if (!$self->{TRUELIB}) { - # zf: Creating a library containing merged source - $out = $self->linkOutputFile(@tolink); - $self->linktolib(\@tolink, $out, - $self->{PPARGS}, $self->{CCARGS}, - $self->{LINKARGS}); - return; - } else { - # zf: Linking to a true library. Do real curing. - # Only difference from TOEXE is that we use "partial linking" of the - # underlying linker - if ($self->{VERBOSE}) { - print STDERR "Linking to a true library!"; - } - push @{$self->{CCARGS}}, "-r"; - $out = $self->linkOutputFile(@tolink); - $self->link(\@tolink, $out, - $self->{PPARGS}, $self->{CCARGS}, $self->{LINKARGS}); - return; - } - - } - - # Now link all of the files into an executable - if($self->{OPERATION} eq "TOEXE") { - $out = $self->linkOutputFile(@tolink); - $self->link(\@tolink, $out, - $self->{PPARGS}, $self->{CCARGS}, $self->{LINKARGS}); - return; - } - - die "I don't understand OPERATION:$self->{OPERATION}\n"; -} - -sub classifyArgDebug { - if(0) { print @_; } -} - -sub mydebug { - if(0) { print @_; } -} - -sub compilerArgument { - my($self, $options, $arg, $pargs) = @_; - &classifyArgDebug("Classifying arg: $arg\n"); - my $idx = 0; - for($idx=0; $idx < $#$options; $idx += 2) { - my $key = ${$options}[$idx]; - my $action = ${$options}[$idx + 1]; - &classifyArgDebug("Try match with $key\n"); - if($arg =~ m|^$key|) { - &classifyArgDebug(" match with $key\n"); - my @fullarg = ($arg); - my $onemore; - if(defined $action->{'ONEMORE'}) { - &classifyArgDebug(" expecting one more\n"); - # Maybe the next arg is attached - my $realarg; - ($realarg, $onemore) = ($arg =~ m|^($key)(.+)$|); - if(! defined $onemore) { - # Grab the next argument - $onemore = $self->fetchNextArg($pargs); - $onemore = "eIfNecessary($onemore); - push @fullarg, $onemore; - } else { - $onemore = "eIfNecessary($onemore); - } - &classifyArgDebug(" onemore=$onemore\n"); - } - # Now see what action we must perform - my $argument_done = 1; - if(defined $action->{'RUN'}) { - &{$action->{'RUN'}}($self, @fullarg, $onemore, $pargs); - $argument_done = 1; - } - # Quote special SHELL caracters - @fullarg = map { $_ =~ s%([<>;&|])%'$1'%g; $_ } @fullarg; - # print "fullarg = ", @fullarg, "\n"; - if(defined $action->{'TYPE'}) { - &classifyArgDebug(" type=$action->{TYPE}\n"); - if($action->{TYPE} eq 'EARLY_PREPROC') { - push @{$self->{EARLY_PPARGS}}, @fullarg; return 1; - } - elsif($action->{TYPE} eq "PREPROC") { - push @{$self->{PPARGS}}, @fullarg; return 1; - } - elsif($action->{TYPE} eq 'SPECIAL') { - push @{$self->{PPARGS}}, @fullarg; - $self->{OPERATION} = 'SPECIAL'; - return 1; - } - elsif($action->{TYPE} eq "CC") { - push @{$self->{CCARGS}}, @fullarg; return 1; - } - elsif($action->{TYPE} eq "LINKCC") { - push @{$self->{CCARGS}}, @fullarg; - push @{$self->{LINKARGS}}, @fullarg; return 1; - } - elsif($action->{TYPE} eq "ALLARGS") { - push @{$self->{PPARGS}}, @fullarg; - push @{$self->{CCARGS}}, @fullarg; - push @{$self->{LINKARGS}}, @fullarg; return 1; - } - elsif($action->{TYPE} eq "LINK") { - push @{$self->{LINKARGS}}, @fullarg; return 1; - } - elsif($action->{TYPE} eq "CSOURCE") { - OutputFile->protect(@fullarg); - $fullarg[0] = &normalizeFileName($fullarg[0]); - push @{$self->{CFILES}}, @fullarg; return 1; - } - elsif($action->{TYPE} eq "ASMSOURCE") { - OutputFile->protect(@fullarg); - $fullarg[0] = &normalizeFileName($fullarg[0]); - push @{$self->{SFILES}}, @fullarg; return 1; - } - elsif($action->{TYPE} eq "OSOURCE") { - OutputFile->protect(@fullarg); - $fullarg[0] = &normalizeFileName($fullarg[0]); - push @{$self->{OFILES}}, @fullarg; return 1; - } - elsif($action->{TYPE} eq "ISOURCE") { - OutputFile->protect(@fullarg); - $fullarg[0] = &normalizeFileName($fullarg[0]); - push @{$self->{IFILES}}, @fullarg; return 1; - } - elsif($action->{TYPE} eq 'OUT') { - if(defined($self->{OUTARG})) { - print "Warning: output file is multiply defined: @{$self->{OUTARG}} and @fullarg\n"; - } - $fullarg[0] = &normalizeFileName($fullarg[0]); - $self->{OUTARG} = [@fullarg]; return 1; - } - print " Do not understand TYPE\n"; return 1; - } - if($argument_done) { return 1; } - print "Don't know what to do with option $arg\n"; - return 0; - } - } - return 0; -} - - -sub runShell { - my ($self, @cmd) = @_; - - my $msvcFriends = - ($self->{MODENAME} eq "MSVC" || - $self->{MODENAME} eq "MSLINK" || - $self->{MODENAME} eq "MSLIB"); - - foreach (@cmd) { - $_ = $_->filename if ref; - # If we are in MSVC mode then we might have to convert the files - # from cygwin names to the actual Windows names - if($msvcFriends && $^O eq "cygwin") { - my $arg = $_; - if ($arg =~ m|^/| && -f $arg) { - my $mname = `cygpath -m $arg`; - chop $mname; - if($mname ne "") { $_ = $mname; } - } - } - } - - # sm: I want this printed to stderr instead of stdout - # because the rest of 'make' output goes there and this - # way I can capture to a coherent file - # sm: removed conditional on verbose since there's already - # so much noise in the output, and this is the *one* piece - # of information I *always* end up digging around for.. - if($self->{TRACE_COMMANDS}) { print STDERR "@cmd\n"; } - - # weimer: let's have a sanity check - my $code = system { $cmd[0] } @cmd; - if ($code != 0) { - # sm: now that we always print, don't echo the command again, - # since that makes the output more confusing - #die "Possible error with @cmd!\n"; - $code >>= 8; # extract exit code portion - - exit $code; - } - return $code; -} - -sub quoteIfNecessary { - my($arg) = @_; - # If it contains spaces or "" then it must be quoted - if($arg =~ m|\s| || $arg =~ m|\"|) { - return "\'$arg\'"; - } else { - return $arg; - } -} - - -sub cilOutputFile { - Carp::croak 'bad argument count' unless @_ == 3; - my ($self, $basis, $suffix) = @_; - - if (defined $self->{SAVE_TEMPS}) { - return new KeptFile($basis, $suffix, $self->{SAVE_TEMPS}); - } else { - return $self->outputFile($basis, $suffix); - } -} - - -sub outputFile { - Carp::confess 'bad argument count' unless @_ == 3; - my ($self, $basis, $suffix) = @_; - - if (defined $self->{SAVE_TEMPS}) { - return new KeptFile($basis, $suffix, $self->{SAVE_TEMPS}); - } else { - return new TempFile($basis, $suffix); - } -} - - -########################################################################### -#### -#### MS CL specific code -#### -package MSVC; - -use strict; -use File::Basename; -use Data::Dumper; - -# For MSVC we remember which was the first source, because we use that to -# determine the name of the output file -sub setFirstSource { - my ($self, $src) = @_; - - if(! defined ($self->{FIRST_SOURCE})) { - $self->{FIRST_SOURCE} = $src; - } -} - -sub new { - my ($proto, $stub) = @_; - my $class = ref($proto) || $proto; - # Create $self - - my $self = - { NAME => 'Microsoft cl compiler', - MODENAME => 'MSVC', - CC => ['cl', '/nologo', '/D_MSVC', '/c'], - CPP => ['cl', '/nologo', '/D_MSVC', '/P'], - LD => ['cl', '/nologo', '/D_MSVC'], - DEFARG => "/D", - INCARG => "/I", - DEBUGARG => ['/Zi', '/MLd', '/DEBUG'], - OPTIMARG => ['/Ox', '/G6'], - OBJEXT => "obj", - LIBEXT => "lib", # Library extension (without the .) - EXEEXT => ".exe", # Executable extension (with the .) - OUTOBJ => "/Fo", - OUTEXE => "/Fe", - WARNISERROR => "/WX", - FORCECSOURCE => ['/Tc'], - LINEPATTERN => "^#line\\s+(\\d+)\\s+\"(.+)\"", - - OPTIONS => -# Describe the compiler options as a list of patterns and associated actions. -# The patterns are matched in order against the _begining_ of the argument. -# -# If the action contains ONEMORE => 1 then the argument is expected to be -# parameterized by a following word. The word can be attached immediately to -# the end of the argument or in a separate word. -# -# If the action contains TYPE => "..." then the argument is put into -# one of several lists, as follows: "PREPROC" in ppargs; "CC" in -# ccargs; "LINK" in linkargs; "LINKCC" both in ccargs and linkargs; -# "ALLARGS" in ppargs, ccargs, and linkargs; "CSOURCE" in cfiles; -# "ASMSOURCE" in sfiles; "OSOURCE" in ofiles; "ISOURCE" in ifiles; -# "OUT" in outarg. "SPECIAL" flags indicate that the compiler should -# be run directly so that it can perform some special action other -# than generating code (e.g. printing out version or configuration -# information). -# -# If the TYPE is not defined but the RUN => sub { ... } is defined then the -# given subroutine is invoked with the self, the argument and the (possibly -# empty) additional word and a pointer to the list of remaining arguments -# - ["^[^/\\-@].*\\.($::cilbin|c|cpp|cc)\$" => - { TYPE => 'CSOURCE', - RUN => sub { &MSVC::setFirstSource(@_); } }, - "[^/].*\\.(asm)\$" => { TYPE => 'ASMSOURCE' }, - "[^/].*\\.i\$" => { TYPE => 'ISOURCE' }, - "[^/\\-@]" => { TYPE => "OSOURCE" }, - "[/\\-]O" => { TYPE => "CC" }, - "[/\\-][DI]" => { TYPE => "PREPROC"}, - "[/\\-]EH" => { TYPE => "CC" }, - "[/\\-]G" => { TYPE => "CC" }, - "[/\\-]F[aA]" => { TYPE => 'CC' }, - "[/\\-]Fo" => { TYPE => 'OUT' }, - "/Fe" => { TYPE => 'OUT', - RUN => sub { $stub->{OPERATION} = "TOEXE" }}, - "[/\\-]F[dprR]" => { TYPE => "CC" }, - "[/\\-]FI" => { TYPE => "PREPROC" }, - "[/\\-][CXu]" => { TYPE => "PREPROC" }, - "[/\\-]U" => { ONEMORE => 1, TYPE => "PREPROC" }, - "[/\\-](E|EP|P)" => { RUN => sub { push @{$stub->{PPARGS}}, $_[1]; - $stub->{OPERATION} = "PREPROC"; }}, - "[/\\-]c" => { RUN => sub { $stub->{OPERATION} = "TOOBJ"; }}, - "[/\\-](Q|Z|J|nologo|w|W|Zm)" => { TYPE => "CC" }, - "[/\\-]Y(u|c|d|l|X)" => { TYPE => "CC" }, - "[/\\-]T(C|P)" => { TYPE => "PREPROC" }, - "[/\\-]Tc(.+)\$" => - { RUN => sub { - my $arg = $_[1]; - my ($fname) = ($arg =~ m|[/\\-]Tc(.+)$|); - $fname = &normalizeFileName($fname); - push @{$stub->{CFILES}}, $fname; - }}, - "[/\\-]v(d|m)" => { TYPE => "CC" }, - "[/\\-]F" => { TYPE => "CC" }, - "[/\\-]M" => { TYPE => 'LINKCC' }, - "/link" => { RUN => sub { push @{$stub->{LINKARGS}}, "/link", - @{$_[3]}; - @{$_[3]} = (); } }, - "-cbstring" => { TYPE => "CC" }, - "/" => { RUN => - sub { print "Unimplemented MSVC argument $_[1]\n";}}, - ], - }; - bless $self, $class; - return $self; -} - - -sub msvc_preprocess { - my($self, $src, $dest, $ppargs) = @_; - my $res; - my $srcname = ref $src ? $src->filename : $src; - my ($sbase, $sdir, $sext) = - fileparse($srcname, - "(\\.c)|(\\.cc)|(\\.cpp)|(\\.i)"); - # If this is a .cpp file we still hope it is C. Pass the /Tc argument to - # cl to force this file to be interpreted as a C one - my @cmd = @{$ppargs}; - - if($sext eq ".cpp") { - push @cmd, "/Tc"; - } - # MSVC cannot be told where to put the output. But we know that it - # puts it in the current directory - my $msvcout = "./$sbase.i"; - if($self->{STDOUTPP}) { - @cmd = ('cmd', '/c', 'cl', '/nologo', '/E', ">$msvcout", '/D_MSVC', - @cmd); - - } else { - @cmd = ('cl', '/nologo', '/P', '/D_MSVC', @cmd); - } - $res = $self->runShell(@cmd, $srcname); - # Check file equivalence by making sure that all elements of the stat - # structure are the same, except for the access time. - my @st1 = stat $msvcout; $st1[8] = 0; - my @st2 = stat $dest->{filename}; $st2[8] = 0; - # print Dumper(\@st1, \@st2); - if($msvcout ne $dest->{filename}) { - while($#st1 >= 0) { - if(shift @st1 != shift @st2) { -# print "$msvcout is NOT the same as $afterpp\n"; - if($self->{VERBOSE}) { - print STDERR "Copying $msvcout to $dest->{filename} (MSVC_preprocess)\n"; - } - unlink $dest; - File::Copy::copy($msvcout, $dest->filename); - unlink $msvcout; - return $res; - } - } - } - return $res; -} - -sub forceIncludeArg { - my($self, $what) = @_; - return "/FI$what"; -} - - - # MSVC does not understand the extension .i, so we tell it it is a C file -sub fixupCsources { - my (@csources) = @_; - my @mod_csources = (); - my $src; - foreach $src (@csources) { - my ($sbase, $sdir, $sext) = fileparse($src, - "\\.[^.]+"); - if($sext eq ".i") { - push @mod_csources, "/Tc"; - } - push @mod_csources, $src; - } - return @mod_csources; -} - - -# Emit a line # directive -sub lineDirective { - my ($self, $fileName, $lineno) = @_; - return "#line $lineno \"$fileName\"\n"; -} - -# The name of the output file -sub compileOutputFile { - my($self, $src) = @_; - - die "compileOutputFile: not a C source file: $src\n" - unless $src =~ /\.($::cilbin|c|cc|cpp|i|asm)$/; - - Carp::carp ("compileOutputFile: $self->{OPERATION}, $src", - Dumper($self->{OUTARG})) if 0; - if ($self->{OPERATION} eq 'TOOBJ') { - if(defined $self->{OUTARG} - && "@{$self->{OUTARG}}" =~ m|[/\\-]Fo(.+)|) { - my $dest = $1; - # Perhaps $dest is a directory - if(-d $dest) { - return new KeptFile($src, $self->{OBJEXT}, $dest); - } else { - return new OutputFile($src, $1); - } - } else { - return new KeptFile($src, $self->{OBJEXT}, '.'); - } - } else { -# die "compileOutputfile: operation is not TOOBJ"; - return $self->outputFile($src, $self->{OBJEXT}); - } -} - -sub assembleOutputFile { - my($self, $src) = @_; - return $self->compileOutputFile($src); -} - -sub linkOutputFile { - my($self, $src) = @_; - $src = $src->filename if ref $src; - if(defined $self->{OUTARG} && "@{$self->{OUTARG}}" =~ m|/Fe(.+)|) { - return $1; - } - # Use the name of the first source file, in the current directory - my ($base, $dir, $ext) = fileparse ($src, "\\.[^.]+"); - return "./$base.exe"; -} - -sub setVersion { - my($self) = @_; - my $cversion = ""; - open(VER, "cl 2>&1|") || die "Cannot start Microsoft CL\n"; - while() { - if($_ =~ m|Compiler Version (\S+) |) { - $cversion = "cl_$1"; - close(VER); - $self->{VERSION} = $cversion; - return; - } - } - die "Cannot find Microsoft CL version\n"; -} - -######################################################################## -## -## MS LINK specific code -## -### -package MSLINK; - -use strict; - -use File::Basename; -use Data::Dumper; - -sub new { - my ($proto, $stub) = @_; - my $class = ref($proto) || $proto; - - # Create a MSVC compiler object - my $msvc = MSVC->new($stub); - - # Create $self - - my $self = - { NAME => 'Microsoft linker', - MODENAME => 'MSLINK', - CC => $msvc->{CC}, - CPP => $msvc->{CPP}, - LD => ['link'], - DEFARG => $msvc->{DEFARG}, - INCARG => $msvc->{INCARG}, - DEBUGARG => ['/DEBUG'], - OPTIMARG => [], - LDLIB => ['lib'], - OBJEXT => "obj", - LIBEXT => "lib", # Library extension (without the .) - EXEEXT => ".exe", # Executable extension (with the .) - OUTOBJ => $msvc->{OUTOBJ}, - OUTEXE => "-out:", # Keep this form because build.exe looks for it - WARNISERROR => "/WX", - LINEPATTERN => "", - FORCECSOURCE => $msvc->{FORCECSOURCE}, - - MSVC => $msvc, - - OPTIONS => - ["[^/\\-@]" => { TYPE => 'OSOURCE' }, - "[/\\-](OUT|out):" => { TYPE => 'OUT' }, - "^((/)|(\\-[^\\-]))" => { TYPE => 'LINK' }, - ], - }; - bless $self, $class; - return $self; -} - - -sub forceIncludeArg { # Same as for CL - my($self, $what) = @_; - return "/FI$what"; -} - - - -sub linkOutputFile { - my($self, $src) = @_; -# print Dumper($self); - Carp::confess "Cannot compute the linker output file" - if ! defined $self->{OUTARG}; - - if("@{$self->{OUTARG}}" =~ m|.+:(.+)|) { - return $1; - } - die "I do not know what is the link output file\n"; -} - -sub setVersion { - my($self) = @_; - my $cversion = ""; - open(VER, "link 2>&1|") || die "Cannot start Microsoft LINK\n"; - while() { - if($_ =~ m|Linker Version (\S+)|) { - $cversion = "link_$1"; - close(VER); - $self->{VERSION} = $cversion; - return; - } - } - die "Cannot find Microsoft LINK version\n"; -} - -######################################################################## -## -## MS LIB specific code -## -### -package MSLIB; - -our @ISA = qw(MSLINK); - -use strict; - -use File::Basename; -use Data::Dumper; - -sub new { - my ($proto, $stub) = @_; - my $class = ref($proto) || $proto; - - # Create a MSVC linker object - my $self = MSLINK->new($stub); - - $self->{NAME} = 'Microsoft librarian'; - $self->{MODENAME} = 'MSLIB'; - $self->{OPERATION} = "TOLIB"; - $self->{LDLIB} = ['lib']; - bless $self, $class; - return $self; -} - -sub setVersion { - my($self) = @_; - my $cversion = ""; - open(VER, "lib 2>&1|") || die "Cannot start Microsoft LIB\n"; - while() { - if($_ =~ m|Library Manager Version (\S+)|) { - $cversion = "lib_$1"; - close(VER); - $self->{VERSION} = $cversion; - return; - } - } - die "Cannot find Microsoft LINK version\n"; -} - -######################################################################## -## -## GNU ar specific code -## -### -package AR; - -use strict; - -use File::Basename; -use Data::Dumper; - -sub new { - my ($proto, $stub) = @_; - my $class = ref($proto) || $proto; - # Create $self - - my $self = - { NAME => 'Archiver', - MODENAME => 'ar', - CC => ['no_compiler_in_ar_mode'], - CPP => ['no_compiler_in_ar_mode'], - LDLIB => ['ar', 'crv'], - DEFARG => "??DEFARG", - INCARG => '??INCARG', - DEBUGARG => ['??DEBUGARG'], - OPTIMARG => [], - OBJEXT => "o", - LIBEXT => "a", # Library extension (without the .) - EXEEXT => "", # Executable extension (with the .) - OUTOBJ => "??OUTOBJ", - OUTLIB => "", # But better be first - LINEPATTERN => "", - - OPTIONS => - ["^[^-]" => { RUN => \&arArguments } ] - - }; - bless $self, $class; - return $self; -} - -# We handle arguments in a special way for AR -sub arArguments { - my ($self, $arg, $onemore, $pargs) = @_; - # If the first argument starts with -- pass it on - if($arg =~ m|^--|) { - return 0; - } - # We got here for the first non -- argument. - # Will handle all arguments at once - if($self->{VERBOSE}) { - print "AR called with $arg @{$pargs}\n"; - } - - #The r flag is required: - if($arg !~ m|r| || $#{$pargs} < 0) { - die "Error: CCured's AR mode implements only the r and cr operations."; - } - if($arg =~ /[^crvus]/) { - die "Error: CCured's AR mode supports only the c, r, u, s, and v flags."; - } - if($arg =~ /v/) { - $self->{VERBOSE} = 1; - } - - if($arg =~ /c/) - { - # Command is "cr": - # Get the name of the library - my $out = shift @{$pargs}; - $self->{OUTARG} = [$out]; - unlink $out; - } - else - { - # if the command is "r" alone, we should add to the current library, - # not replace it, unless the library does not exist - - # Get the name of the library - my $out = shift @{$pargs}; - $self->{OUTARG} = [$out]; - - #The library is both an input and an output. - #To avoid problems with reading and writing the same file, move the - #current version of the library out of the way first. - if(-f $out) { - - my $temp_name = $out . "_old.a"; - if($self->{VERBOSE}) { - print "Copying $out to $temp_name so we can add " - . "to it.\n"; - } - if(-f $temp_name) { - unlink $temp_name; - } - rename $out, $temp_name; - - #now use $temp_name as the input. $self->{OUTARG} will, - # as usual, be the output. - push @{$self->{OFILES}}, $temp_name; - } else { - warn "Library $out not found; creating."; - } - - } - - # The rest of the arguments must be object files - push @{$self->{OFILES}}, @{$pargs}; - $self->{OPERATION} = 'TOLIB'; - @{$pargs} = (); -# print Dumper($self); - return 1; -} - -sub linkOutputFile { - my($self, $src) = @_; - if(defined $self->{OUTARG}) { - return "@{$self->{OUTARG}}"; - } - die "I do not know what is the link output file\n"; -} - -sub setVersion { - # sm: bin/cilly wants this for all "compilers" -} - - -######################################################################### -## -## GNUCC specific code -## -package GNUCC; - -use strict; - -use File::Basename; - -# The variable $::cc is inherited from the main script!! - -sub new { - my ($proto, $stub) = @_; - my $class = ref($proto) || $proto; - # Create $self - - my @native_cc = Text::ParseWords::shellwords($ENV{CILLY_NATIVE_CC} || $::cc); - - my $self = - { NAME => 'GNU CC', - MODENAME => 'GNUCC', # do not change this since it is used in code - # sm: added -O since it's needed for inlines to be merged instead of causing link errors - # sm: removed -O to ease debugging; will address "inline extern" elsewhere - CC => [@native_cc, '-D_GNUCC', '-c'], - LD => [@native_cc, '-D_GNUCC'], - LDLIB => ['ld', '-r', '-o'], - CPP => [@native_cc, '-D_GNUCC', '-E'], - DEFARG => "-D", - INCARG => "-I", - DEBUGARG => ['-g', '-ggdb'], - OPTIMARG => ['-O4'], - CPROFILEARG => '-pg', - LPROFILEARG => '-pg', - OBJEXT => "o", - LIBEXT => "a", - EXEEXT => "", - OUTOBJ => '-o', - OUTEXE => '-o', - OUTCPP => '-o', - WARNISERROR => "-Werror", - FORCECSOURCE => [], - LINEPATTERN => "^#\\s+(\\d+)\\s+\"(.+)\"", - - OPTIONS => - [ "[^-].*\\.($::cilbin|c|cpp|cc)\$" => { TYPE => 'CSOURCE' }, - "[^-].*\\.(s|S)\$" => { TYPE => 'ASMSOURCE' }, - "[^-].*\\.i\$" => { TYPE => 'ISOURCE' }, - # .o files can be linker scripts - "[^-]" => { RUN => sub { &GNUCC::parseLinkerScript(@_); }}, - "-E" => { RUN => sub { $stub->{OPERATION} = "TOI"; }}, - "-pipe\$" => { TYPE => 'ALLARGS' }, - "-[DIU]" => { ONEMORE => 1, TYPE => "PREPROC" }, - "-isystem" => { ONEMORE => 1, TYPE => "PREPROC" }, - '-undef$' => { TYPE => 'PREPROC' }, - '-w$' => { TYPE => 'PREPROC' }, - '-M$' => { TYPE => 'SPECIAL' }, - '-MM$' => { TYPE => 'SPECIAL' }, - '-MF$' => { TYPE => 'EARLY_PREPROC', ONEMORE => 1 }, - '-C$' => { TYPE => 'EARLY_PREPROC'}, # zra - '-MG$' => { TYPE => 'EARLY_PREPROC' }, - '-MP$' => { TYPE => 'EARLY_PREPROC' }, - '-MT$' => { TYPE => 'EARLY_PREPROC', ONEMORE => 1 }, - '-MQ$' => { TYPE => 'EARLY_PREPROC', ONEMORE => 1 }, - '-MD$' => { TYPE => 'EARLY_PREPROC' }, - '-MMD$' => { TYPE => 'EARLY_PREPROC' }, - "-include" => { ONEMORE => 1, TYPE => "PREPROC" }, # sm - "-iwithprefix" => { ONEMORE => 1, TYPE => "PREPROC" }, - '-Wp,' => { TYPE => 'PREPROC' }, - "-ansi" => { TYPE => 'ALLARGS' }, - "-c" => { RUN => sub { $stub->{OPERATION} = "TOOBJ"; }}, - "-x" => { ONEMORE => 1, TYPE => "CC" }, - "-v" => { TYPE => 'ALLARGS', - RUN => sub { $stub->{TRACE_COMMANDS} = 1; } }, - "^-e\$" => { ONEMORE => 1, TYPE => 'LINK' }, - "^-T\$" => { ONEMORE => 1, TYPE => 'LINK' }, - # GCC defines some more macros if the optimization is On so pass - # the -O to the preprocessor and the compiler - '-O' => { TYPE => 'ALLARGS' }, - "-S" => { RUN => sub { $stub->{OPERATION} = "TOOBJ"; - push @{$stub->{CCARGS}}, $_[1]; }}, - "-o" => { ONEMORE => 1, TYPE => 'OUT' }, - "-p\$" => { TYPE => 'LINKCC' }, - "-pg" => { TYPE => 'LINKCC' }, - "-a" => { TYPE => 'LINKCC' }, - "-pedantic\$" => { TYPE => 'ALLARGS' }, - "-Wall" => { TYPE => 'CC', - RUN => sub { push @{$stub->{CILARGS}},"--warnall";}}, - "-W[-a-z]*\$" => { TYPE => 'CC' }, - '-g' => { TYPE => 'ALLARGS' }, - "-save-temps" => { TYPE => 'ALLARGS', - RUN => sub { if(! defined $stub->{SAVE_TEMPS}) { - $stub->{SAVE_TEMPS} = '.'; } }}, - '--?print-' => { TYPE => 'SPECIAL' }, - '-dump' => { TYPE => 'SPECIAL' }, - "-l" => - { RUN => sub { - my ($libname) = ($_[1] =~ m|-l(.+)$|); - # See if we can find this library in the LIBDIR - my @libdirs = @{$stub->{LIBDIR}}; - if($#libdirs == -1) { - push @libdirs, '.'; - } - foreach my $d (@libdirs) { - if(-f "$d/lib$libname.a") { - # Pretend that we had a straight argument - push @{$stub->{OFILES}}, "$d/lib$libname.a"; - return; - } - } - # We get here when we cannot find the library in the LIBDIR - push @{$stub->{LINKARGS}}, $_[1]; - }}, - "-L" => - { RUN => sub { - # Remember these directories in LIBDIR - my ($dir) = ($_[1] =~ m|-L(.+)$|); - push @{$stub->{LIBDIR}}, $dir; - push @{$stub->{LINKARGS}}, $_[1]; - }}, - "-f" => { TYPE => 'LINKCC' }, - "-r\$" => { RUN => sub { $stub->{OPERATION} = "TOLIB"; }}, - "-i\$" => { RUN => sub { $stub->{OPERATION} = "TOLIB"; }}, - "-m" => { TYPE => 'LINKCC', ONEMORE => 1 }, - "-s\$" => { TYPE => 'LINKCC' }, - "-Xlinker" => { ONEMORE => 1, TYPE => 'LINK' }, - "-nostdlib" => { TYPE => 'LINK' }, - "-nostdinc" => { TYPE => 'PREPROC' }, - '-rdynamic$' => { TYPE => 'LINK' }, - "-static" => { TYPE => 'LINK' }, - "-shared" => { TYPE => 'LINK' }, - "-static-libgcc" => { TYPE => 'LINK' }, - "-shared-libgcc" => { TYPE => 'LINK' }, - '-Wl,--(no-)?whole-archive$' => { TYPE => 'OSOURCE' }, - '-Wl,' => { TYPE => 'LINK' }, - "-traditional" => { TYPE => 'PREPROC' }, - '-std=' => { TYPE => 'ALLARGS' }, - "--start-group" => { RUN => sub { } }, - "--end-group" => { RUN => sub { }}, - "-pthread\$" => { TYPE => 'ALLARGS' }, - ], - - }; - bless $self, $class; - return $self; -} -# ' - -my $linker_script_debug = 0; -sub parseLinkerScript { - my($self, $filename, $onemore, $pargs) = @_; - - if(! defined($self->{FLATTEN_LINKER_SCRIPTS}) || - $filename !~ /\.o$/) { - NotAScript: - warn "$filename is not a linker script\n" if $linker_script_debug; - push @{$self->{OFILES}}, $filename; - return 1; - } - warn "parsing OBJECT FILE:$filename ****************\n" if - $linker_script_debug; - open OBJFILE, $filename or die $!; - my $line = ; - if ($line !~ /^INPUT/) { - close OBJFILE or die $!; - goto NotAScript; - } - warn "\tYES an INPUT file.\n" if $linker_script_debug; - my @lines = ; # Read it all and close it - unshift @lines, $line; - close OBJFILE or die $!; - # Process recursively each line from the file - my @tokens = (); - my $incomment = 0; # Whether we are in a comment - foreach my $line (@lines) { - chomp $line; - if($incomment) { - # See where the comment ends - my $endcomment = index($line, "*/"); - if($endcomment < 0) { # No end on this line - next; # next line - } else { - $line = substr($line, $endcomment + 2); - $incomment = 0; - } - } - # Drop the comments that are on a single line - $line =~ s|/\*.*\*/| |g; - # Here if outside comment. See if a comment starts - my $startcomment = index($line, "/*"); - if($startcomment >= 0) { - $incomment = 1; - $line = substr($line, 0, $startcomment); - } - # Split the line into tokens. Sicne we use parentheses in the pattern - # the separators will be tokens as well - push @tokens, split(/([(),\s])/, $line); - } - print "Found tokens:", join(':', @tokens), "\n" - if $linker_script_debug; - # Now parse the file - my $state = 0; - foreach my $token (@tokens) { - if($token eq "" || $token =~ /\s+/) { next; } # Skip spaces - if($state == 0) { - if($token eq "INPUT") { $state = 1; next; } - else { die "Error in script: expecting INPUT"; } - } - if($state == 1) { - if($token eq "(") { $state = 2; next; } - else { die "Error in script: expecting ( after INPUT"; } - } - if($state == 2) { - if($token eq ")") { $state = 0; next; } - if($token eq ",") { next; } # Comma could be a separator - # Now we better see a filename - if(! -f $token) { - warn "Linker script mentions inexistent file:$token.Ignoring\n"; - next; - } - # Process it recursively because it could be a script itself - warn "LISTED FILE:$token.\n" if $linker_script_debug; - $self->parseLinkerScript($token, $onemore, $pargs); - next; - } - die "Invalid linker script parser state\n"; - - } -} - -sub forceIncludeArg { - my($self, $what) = @_; - return ('-include', $what); -} - - -# Emit a line # directive -sub lineDirective { - my ($self, $fileName, $lineno) = @_; - return "# $lineno \"$fileName\"\n"; -} - -# The name of the output file -sub compileOutputFile { - my($self, $src) = @_; - - die "objectOutputFile: not a C source file: $src\n" - unless $src =~ /\.($::cilbin|c|cc|cpp|i|s|S)$/; - - if ($self->{OPERATION} eq 'TOOBJ') { - if (defined $self->{OUTARG} - && "@{$self->{OUTARG}}" =~ m|^-o\s*(\S.+)$|) { - return new OutputFile($src, $1); - } else { - return new KeptFile($src, $self->{OBJEXT}, '.'); - } - } else { - return $self->outputFile($src, $self->{OBJEXT}); - } -} - -sub assembleOutputFile { - my($self, $src) = @_; - return $self->compileOutputFile($src); -} - -sub linkOutputFile { - my($self, $src) = @_; - if(defined $self->{OUTARG} && "@{$self->{OUTARG}}" =~ m|-o\s*(\S.+)|) { - return $1; - } - return "a.out"; -} - -sub setVersion { - my($self) = @_; - my $cversion = ""; - open(VER, "@{$self->{CC}} -dumpversion " - . join(' ', @{$self->{PPARGS}}) ." |") - || die "Cannot start GNUCC"; - while() { - if($_ =~ m|^(\d+\S+)| || $_ =~ m|^(egcs-\d+\S+)|) { - $cversion = "gcc_$1"; - close(VER) || die "Cannot start GNUCC\n"; - $self->{VERSION} = $cversion; - return; - } - } - die "Cannot find GNUCC version\n"; -} - -1; - - -__END__ - - - diff --git a/cil/lib/KeptFile.pm b/cil/lib/KeptFile.pm deleted file mode 100644 index 904b5145..00000000 --- a/cil/lib/KeptFile.pm +++ /dev/null @@ -1,88 +0,0 @@ -package KeptFile; -use OutputFile; -@ISA = (OutputFile); - -use strict; -use Carp; -use File::Basename; -use File::Spec; - - -######################################################################## - - -sub new { - croak 'bad argument count' unless @_ == 4; - my ($proto, $basis, $suffix, $dir) = @_; - my $class = ref($proto) || $proto; - - $basis = $basis->basis if ref $basis; - my ($basename, undef, $basefix) = fileparse($basis, qr{\.[^.]+}); - my $filename = File::Spec->catfile($dir, "$basename.$suffix"); - - my $self = $class->SUPER::new($basis, $filename); - return $self; -} - - -######################################################################## - - -1; - -__END__ - - -=head1 Name - -KeptFile - persistent compiler output files - -=head1 Synopsis - - use KeptFile; - - my $cppOut = new KeptFile ('code.c', 'i', '/output/directory'); - system 'cpp', 'code.c', '-o', $cppOut->filename; - -=head2 Description - -C represents an intermediate output file generated by some -stage of a C-based compiler that should be retained after -compilation. It is a concrete subclass of L. -Use C when the user has asked for intermediate files to be -retained, such as via gcc's C<-save-temps> flag. - -=head2 Public Methods - -=over - -=item new - -C constructs a new C -instance. The new file name is constructed using the base file name -of C<$basis> with its suffix replaced by C<$suffix> and its path given -by C<$dir>. For example, - - new KeptFile ('/foo/code.c', 'i', '/bar') - -yields a C with file name F. - -C<$basis> may be either absolute or relative; only the trailing file -name is used. C<$basis> can also be an C instance, in -which case C<< $basis->basis >> is used as the actual basis. See -L for more information on basis flattening. - -C<$suffix> should not include a leading dot; this will be added -automatically. - -C<$dir> may be either absolute or relative. It is common to use F<.> -as the directory, which puts the C in the current working -directory. - -=back - -=head1 See Also - -L, L. - -=cut diff --git a/cil/lib/OutputFile.pm b/cil/lib/OutputFile.pm deleted file mode 100644 index 8f02ba23..00000000 --- a/cil/lib/OutputFile.pm +++ /dev/null @@ -1,213 +0,0 @@ -package OutputFile; -@ISA = (); - -use strict; -use Carp; -use File::Basename; -use File::Spec; - - -######################################################################## - - -my $debug = 0; - - -sub new { - croak 'bad argument count' unless @_ == 3; - my ($proto, $basis, $filename) = @_; - my $class = ref($proto) || $proto; - - $basis = $basis->basis if ref $basis; - my $ref = { filename => $filename, - basis => $basis }; - my $self = bless $ref, $class; - - $self->checkRef($filename); - $self->checkRef($basis); - $self->checkProtected(); - $self->checkTemporary(); - - Carp::cluck "OutputFile: filename == $filename, basis == $basis" if $debug; - return $self; -} - - -sub filename { - my ($self) = @_; - return $self->{filename}; -} - - -sub basis { - my ($self) = @_; - return $self->{basis}; -} - - -######################################################################## - - -sub checkRef { - my ($self, $filename) = @_; - confess "ref found where string expected: $filename" if ref $filename; - confess "stringified ref found where string expected: $filename" if $filename =~ /\w+=HASH\(0x[0-9a-f]+\)/; -} - - -sub checkTemporary { - my ($self) = @_; - my ($basename, $path) = fileparse $self->filename; - return if $path eq File::Spec->tmpdir . '/'; - confess "found temporary file in wrong directory: ", $self->filename - if $basename =~ /^cil-[a-zA-Z0-9]{8}\./; -} - - -######################################################################## - - -my @protected = (); - - -sub checkProtected { - my ($self) = @_; - my $abs = File::Spec->rel2abs($self->filename); - - foreach (@protected) { - confess "caught attempt to overwrite protected file: ", $self->filename - if $_ eq $abs; - } -} - - -sub protect { - my ($self, @precious) = @_; - push @protected, File::Spec->rel2abs($_) - foreach @precious; -} - - -######################################################################## - - -1; - -__END__ - - -=head1 Name - -OutputFile - base class for intermediate compiler output files - -=head1 Description - -C represents an intermediate output file generated by some -stage of a C-based compiler. This is an abstract base class -and should never be instantiated directly. It provides common -behaviors used by concrete subclasses L and -L. - -=head2 Public Methods - -=over - -=item filename - -An C instance is a smart wrapper around a file name. C<< -$out->filename >> returns the name of the file represented by -C instance C<$out>. When building a command line, this is -the string to use for the file. For example: - - my $out = ... ; # some OutputFile subclass - my @argv = ('gcc', '-E', '-o', $out->filename, 'input.c'); - system @argv; - -C often creates command vectors with a mix of strings and -C objects. This is fine, but before using a mixed vector -as a command line, you must replace all C objects with -their corresponding file names: - - my @mixed = (...); # mix of strings and objects - my @normalized = @mixed; - $_ = (ref $_ ? $_->filename : $_) foreach @normalized; - system @normalized; - -Common utility methods like C already do exactly this -normalization, but you may need to do it yourself if you are running -external commands on your own. - -=item protect - -C contains safety interlocks that help it avoid stomping -on user input files. C<< OutputFile->protect($precious) >> marks -C<$precious> as a protected input file which should not be -overwritten. If any C tries to claim this same file name, -an error will be raised. In theory, this never happens. In practice, -scripts can have bugs, and it's better to be safe than sorry. - -C uses this method to register input files that it discovers -during command line processing. If you add special command line -processing of your own, or if you identify input files through other -means, we highly recommend using this method as well. Otherwise, -there is some risk that a buggy client script could mistakenly create -an output file that destroys the user's source code. - -Note that C is a class method: call it on the C -module, rather than on a specific instance. - -=back - -=head2 Internal Methods - -The following methods are used within C or by -C subclasses. They are not intended for use by outside -scripts. - -=over - -=item basis - -In addition to L, each C -instance records a second file name: its I. The basis file -name is initialized and used differently by different subclasses, but -typically represents the input file from which this output file is -derived. C<< $out->basis >> returns the basis file name for instance -C<$out>. - -When instantiating an C, the caller can provide either a -file name string as the basis or another C instance. -However, basis file names are not chained: if C<< $a->basis >> is -F, and C<$b> is constructed with C<$a> as its basis, C<< -$b->basis >> will return F, not C<$a> or C<< $a->filename >>. -This flattening is done at construction time. - -See L and L for more details on how -basis file names are used. - -=item checkRef - -C<< OutputFile->checkRef($filename) >> raises an error if C<$filename> -is an object reference, or looks like the string representation of an -object reference. Used to sanity check arguments to various methods. - -=item checkTemporary - -C<< $out->checkTemporary >> raises an error if C<< $out->filename >> -looks like a temporary file name but is not in the system temporary -directory. Used to sanity check arguments in various methods. - -=item checkProtected - -C<< $out->checkProtected >> raises an error if C<< $out->filename >> -is listed as a protected file. This check, performed at construction -time, implements a safety interlock to prevent overwriting of user -input files. Protected files are registered using L<"protect">. - -=back - -=head1 See Also - -L, L. - -=cut diff --git a/cil/lib/TempFile.pm b/cil/lib/TempFile.pm deleted file mode 100644 index 608713cf..00000000 --- a/cil/lib/TempFile.pm +++ /dev/null @@ -1,90 +0,0 @@ -package TempFile; -use OutputFile; -@ISA = (OutputFile); - -use strict; -use Carp; -use File::Temp qw(tempfile); - - -######################################################################## - - -sub new { - croak 'bad argument count' unless @_ == 3; - my ($proto, $basis, $suffix) = @_; - my $class = ref($proto) || $proto; - - my (undef, $filename) = tempfile('cil-XXXXXXXX', - DIR => File::Spec->tmpdir, - SUFFIX => ".$suffix", - UNLINK => 1); - - my $self = $class->SUPER::new($basis, $filename); - return $self; -} - - -######################################################################## - - -1; - -__END__ - - -=head1 Name - -TempFile - transitory compiler output files - -=head1 Synopsis - - use TempFile; - - my $cppOut = new TempFile ('code.c', 'i'); - system 'cpp', 'code.c', '-o', $cppOut->filename; - -=head2 Description - -C represents an intermediate output file generated by some -stage of a C-based compiler that should be removed after -compilation. It is a concrete subclass of L. -Use C when the user has asked not for intermediate files to -be retained. - -All C files are removed when the script terminates. This -cleanup happens for both normal exits as well as fatal errors. -However, the standard L does not -perform cleanups, and therefore should be avoided in scripts that use -C. - -=head2 Public Methods - -=over - -=item new - -C constructs a new C -instance. The new file name is constructed in some system-specific -temporary directory with a randomly generated file name that ends with -C<$suffix>. For example, - - new TempFile ('/foo/code.c', 'i') - -might yield a C with file name F. - -C<$basis> gives the basis file name for this instance. The file name -is not used directly, but is retained in case this instance is later -passed as the basis for some other C. See -L for more information on basis flattening. - -C<$suffix> should not include a leading dot; this will be added -automatically. - -=back - -=head1 See Also - -L, L. - -=cut -- cgit