/d/dmd-script
Perl | 704 lines | 581 code | 64 blank | 59 comment | 124 complexity | cad0e7b4c236cdd366482c11c202b468 MD5 | raw file
Possible License(s): GPL-2.0, AGPL-1.0
- #! /usr/bin/perl -w
- # GDC -- D front-end for GCC
- # Copyright (C) 2004 David Friedman
- #
- # Modified by
- # Michael Parrott, (C) 2010
- # Iain Buclaw, (C) 2010
- #
- # 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; either version 2 of the License, or
- # (at your option) any later version.
- #
- # 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
- # This is a wrapper script for gdc that emulates the dmd command.
- # -f and -m options are passed to gdc. Extra options are:
- #
- # -vdmd Print commands executed by this wrapper script
- # -q,<arg1>[,<arg2>,<arg3>,...] Pass the comma-separated arguments to gdc
- use strict;
- use warnings;
- use Cwd qw(abs_path);
- use FindBin qw($Bin);
- use File::Basename;
- use File::Spec;
- use File::Path;
- use File::Temp qw(tempdir);
- my $output_directory;
- my $output_parents;
- my $output_file;
- my $header_directory;
- my $header_file;
- my $documentation_directory;
- my $documentation_file;
- my $debug = 0;
- my $link = 1;
- my $header = 0;
- my $documentation = 0;
- my $json = 0;
- my $json_file;
- my $map = 0;
- my $map_file;
- my $run = 0;
- my $verbose = 0;
- my $show_commands = 0;
- my $seen_all_sources_flag = 0;
- my $first_input_file;
- my $combine; # Compile multiple sources into a single object file
- my $lib = 0;
- my $tmpdir;
- my %tmpdir_objs;
- my @sources;
- my @objects;
- my @dobjects;
- my @out;
- my @link_out;
- my @run_args;
- # Use the gdc executable in the same directory as this script and account
- # for the target prefix.
- basename($0) =~ m/^(.*-)?g?dmd(-.*)?$/;
- my $target_prefix = $1?$1:"";
- my $gdc_dir = abs_path(dirname($0));
- my $gdc = File::Spec->catfile( $gdc_dir, $target_prefix . "gdc" . ($2?$2:""));
- sub osHasEXE() {
- return $^O =~ m/MS(DOS|Win32)|os2/i; # taken from File::Basename
- }
- sub targetHasEXE() {
- my $target = `$gdc -dumpmachine`;
- return $target =~ m/mingw/ || $target =~ m/cygwin/;
- }
- sub pathSep() {
- return ";" if $^O =~ m/MS(DOS|Win32)/i;
- return "," if $^O =~ m/MacOS/i;
- return ":";
- }
- sub expandHome($) {
- my ($path) = (@_);
- if ( $^O !~ m/MS(DOS|Win32)|MacOS/i ) {
- $path =~ s/^~/$ENV{HOME}/;
- }
- return $path;
- }
- sub printUsage() {
- print <<EOF
- Documentation: http://www.digitalmars.com/d/1.0/index.html
- http://dgcc.sourceforge.net/
- http://bitbucket.org/goshawk/gdc/wiki/Home
- Usage:
- gdmd files.d ... { -switch }
- files.d D source files
- -arch ... pass an -arch ... option to gdc
- -c do not link
- -cov do code coverage analysis
- -D generate documentation
- -Dddocdir write documentation file to docdir directory
- -Dffilename write documentation file to filename
- -d allow deprecated features
- -debug compile in debug code
- -debug=level compile in debug code <= level
- -debug=ident compile in debug code identified by ident
- -debuglib=lib debug library to use instead of phobos
- -defaultlib=lib default library to use instead of phobos
- -deps=filename write module dependencies to filename
- -f... pass an -f... option to gdc
- -fall-sources for every source file, semantically process each file preceding it
- -framework ... pass a -framework ... option to gdc
- -g add symbolic debug info
- -gc add symbolic debug info, pretend to be C
- -H generate 'header' file
- -Hdhdrdir write 'header' file to hdrdir directory
- -Hffilename write 'header' file to filename
- --help print help
- -Ipath where to look for imports
- -ignore ignore unsupported pragmas
- -property enforce property syntax
- -inline do function inlining
- -Jpath where to look for string imports
- -Llinkerflag pass linkerflag to link
- -lib generate library rather than object files
- -m... pass an -m... option to gdc
- -man open web browser on manual page
- -map generate linker .map file
- -noboundscheck turns off array bounds checking for all functions
- -nofloat do not emit reference to floating point
- -O optimize
- -o- do not write object file
- -odobjdir write object files to directory objdir
- -offilename name output file to filename
- -op do not strip paths from source file
- -pipe use pipes rather than intermediate files
- -profile profile runtime performance of generated code
- -quiet suppress unnecessary messages
- -q,arg1,... pass arg1, arg2, etc. to to gdc
- -release compile release version
- -run srcfile args... run resulting program, passing args
- -unittest compile in unit tests
- -v verbose
- -v1 D language version 1
- -vdmd print commands run by this script
- -version=level compile in version code >= level
- -version=ident compile in version code identified by ident
- -vtls list all variables going into thread local storage
- -w enable warnings
- -wi enable informational warnings
- -X generate JSON file
- -Xffilename write JSON file to filename
- EOF
- ;
- }
- sub errorExit(@) {
- print STDERR "gdmd: ", @_, "\n" if @_;
- exit 1;
- }
- use subs qw(errorExit);
- sub readINI {
- # look for dmd.conf in the following sequence of directories:
- # - current working directory
- # - directory specified by the HOME environment variable
- # - directory gdmd resides in
- # - /etc directory
- my @confpaths = ("./", "$ENV{HOME}/", "$Bin/", "/etc/");
- my $dmdconfpath = "";
- my $dmdconf = "";
- foreach my $confpath (@confpaths) {
- if (-e $confpath."dmd.conf") {
- $dmdconfpath = $confpath;
- $dmdconf = $confpath."dmd.conf";
- last;
- }
- }
- if (-e $dmdconf) {
- open(DMDCONF, "<$dmdconf");
- my $envsection = 0;
- while(<DMDCONF>) {
- # Ignore all lines up to [Environment] section
- if ($_ =~ /^\s*\[\s*Environment\s*\]\s*$/) {
- $envsection = 1;
- next;
- }
- next if (!$envsection);
- # Ignore comments
- next if ($_ =~ /^\s*;/);
- # Ignore empty lines
- next if ($_ =~ /^\s*$/);
- # Check correct syntax
- $_ =~ /^\s*(\S+?)\s*=\s*(.*)\s*$/;
- if ($&) {
- my $VAR = $1;
- my $VAL = $2;
- # The special name %@P% is replaced with the path to dmd.conf
- $VAL =~ s/%\@P%/$dmdconfpath/g;
- # Names enclosed by %% are searched for in the existing environment and inserted
- while ($VAL =~ /%(\S+?)%/) {
- my $envp = $1;
- if ($ENV{$envp}) {
- $VAL =~ s/%$envp%/$ENV{$envp}/g;
- } else {
- $VAL =~ s/%$envp%//g;
- }
- }
- $ENV{$VAR} = "$VAL";
- } else {
- errorExit "syntax error at line $. in file $dmdconf";
- }
- }
- close DMDCONF;
- }
- }
- my $gcc_version = `$gdc -dumpversion`;
- chomp $gcc_version;
- $gcc_version =~ m/^(\d+)\.(\d+)/;
- my ($gcc_maj, $gcc_min) = ( $1, $2 );
- #my $target_machine = `$gdc -dumpmachine`;
- #chomp $target_machine;
- sub addSourceFile($) {
- my ($arg) = @_;
- $first_input_file = $arg if ! $first_input_file;
- push @sources, $arg;
- }
- sub argCheck($$) {
- my ($name,$arg) = @_;
- errorExit "argument expected for switch '$name'" unless defined $arg;
- }
- sub determineARexe() {
- my $name = $target_prefix . 'ar';
- $name .= '.exe' if (osHasEXE());
- # Prefer the 'ar' in the same directory as gdc even if there is no
- # target prefix.
- my $path = File::Spec->catfile( $gdc_dir, $name );
- return $path if -x $path;
- if ( length $target_prefix ) {
- foreach my $dir (split pathSep, $ENV{PATH}) {
- $path = File::Spec->catfile( $dir, $name );
- return $name if -x $path; # Could return $path, but this looks better
- }
- errorExit "Could not find archiver command '$name'.";
- } else {
- return "ar";
- }
- }
- sub determineARcommand() {
- my @exe = determineARexe();
- return (@exe, 'cru');
- }
- sub browse($) {
- my ($url) = @_;
- my @cmd;
- if ($^O =~ m/MSWin32/i) {
- @cmd = qw(cmd /c start);
- } elsif ($^O =~ m/darwin/i &&
- -x '/usr/bin/open') { # MacOS X vs. just Darwin
- @cmd = 'open';
- } elsif ($ENV{KDE_FULL_SESSION} eq 'true') {
- @cmd = qw(kfmclient exec);
- } elsif ($ENV{GNOME_DESKTOP_SESSION_ID} ne '') {
- @cmd = 'gnome-open';
- } else {
- errorExit "Sorry, I do not know how to start your browser.\nManual URL: $url"
- }
- push @cmd, $url;
- system @cmd;
- print "Opening documentation page.";
- exit 0;
- }
- # Load dmd.conf before before parsing arguments.
- readINI();
- if ($ENV{DFLAGS}) {
- push @ARGV, split /\s+/, $ENV{DFLAGS};
- }
- my $arg_i = 0;
- while ( $arg_i < scalar(@ARGV) ) {
- my $arg = $ARGV[$arg_i++];
- if ($arg eq '-arch' ) {
- push @out, '-arch', $ARGV[$arg_i++];
- } elsif ($arg =~ m/^-c$/ ) {
- $link = 0;
- } elsif ( $arg eq '-cov' ) {
- push @out, '-fprofile-arcs', '-ftest-coverage';
- } elsif ( $arg =~ m/^-D$/ ) {
- $documentation = 1;
- } elsif ( $arg =~ m/^-Dd(.*)$/ ) {
- $documentation = 1;
- $documentation_directory = $1;
- } elsif ( $arg =~ m/^-Df(.*)$/ ) {
- $documentation = 1;
- $documentation_file = $1;
- } elsif ( $arg =~ m/^-d$/ ) {
- push @out, '-fdeprecated';
- } elsif ( $arg =~ m/^-debug(?:=(.*))?$/ ) {
- push @out, (defined($1) ? "-fdebug=$1" : '-fdebug');
- } elsif ( $arg =~ m/^-debuglib=(.*)$/ ) {
- push @link_out, '-debuglib', $1;
- } elsif ( $arg =~ m/^-debug.*$/ ) {
- # Passing this to gdc only gives warnings; exit with an error here
- errorExit "unrecognized switch '$arg'";
- } elsif ( $arg =~ m/^-defaultlib=(.*)$/ ) {
- push @link_out, '-defaultlib', $1;
- } elsif ( $arg =~ m/^-deps=(.*)$/ ) {
- push @out, (defined($1) ? "-fdeps=$1" : '-fdeps');
- } elsif ( $arg =~ m/^-g$/ ) {
- $debug = 1;
- push @out, '-g';
- } elsif ( $arg =~ m/^-gc$/ ) {
- $debug = 1;
- push @out, '-fdebug-c';
- } elsif ( $arg =~ m/^-gt$/ ) {
- errorExit "use -profile instead of -gt";
- push @out, '-pg';
- } elsif ( $arg =~ m/^-H$/ ) {
- $header = 1;
- } elsif ( $arg =~ m/^-Hd(.*)$/ ) {
- $header = 1;
- $header_directory = $1;
- } elsif ( $arg =~ m/^-Hf(.*)$/ ) {
- $header = 1;
- $header_file = $1;
- } elsif ( $arg eq '--help' ) {
- printUsage;
- exit 0;
- } elsif ($arg eq '-framework' ) {
- push @link_out, '-framework', $ARGV[$arg_i++];
- } elsif ( $arg eq '-ignore' ) {
- push @out, '-fignore-unknown-pragmas';
- } elsif ( $arg eq '-property' ) {
- push @out, '-fproperty';
- } elsif ( $arg =~ m/^-inline$/ ) {
- push @out, '-finline-functions';
- } elsif ( $arg =~ m/^-I(.*)$/ ) {
- foreach my $i (split pathSep, $1) {
- push @out, '-I', expandHome $i;
- }
- } elsif ( $arg =~ m/^-J(.*)$/ ) {
- foreach my $i (split pathSep, $1) {
- push @out, '-J', expandHome $i;
- }
- } elsif ( $arg =~ m/^-L(.*)$/ ) {
- push @link_out, '-Wl,' . $1;
- } elsif ( $arg eq '-lib' ) {
- $lib = 1;
- $link = 0;
- $tmpdir = tempdir(CLEANUP => 1);
- } elsif ( $arg =~ m/^-O$/ ) {
- push @out, '-O3';
- if( ! grep(/^-inline$/,@ARGV) ) {
- push @out, '-fno-inline-functions';
- }
- if ( $gcc_maj < 4) {
- push @out, '-frename-registers';
- }
- if ( $gcc_maj > 3 || ( $gcc_maj == 3 && $gcc_min >= 4 ) ) {
- push @out, '-fweb';
- }
- } elsif ( $arg =~ m/^-o-$/ ) {
- push @out, '-fsyntax-only';
- $link = 0;
- } elsif ( $arg =~ m/^-od(.*)$/ ) {
- $output_directory = $1;
- } elsif ( $arg =~ m/^-of(.*)$/ ) {
- $output_file = $1;
- } elsif ( $arg =~ m/^-op$/ ) {
- $output_parents = 1;
- } elsif ( $arg =~ m/^-nofloat$/ ) {
- # do nothing
- } elsif ( $arg =~ m/^-pipe$/ ) {
- push @out, '-pipe';
- } elsif ( $arg =~ m/^-profile$/ ) {
- # there is more to profiling than this ... -finstrument-functions?
- push @out, '-pg';
- } elsif ( $arg =~ m/^-release$/ ) {
- push @out, '-frelease';
- } elsif ( $arg eq '-run' ) {
- $run = 1;
- $arg = $ARGV[$arg_i++];
- argCheck '-run', $arg;
- addSourceFile $arg;
- push @run_args, @ARGV[$arg_i..$#ARGV];
- last;
- } elsif ( $arg =~ m/^-noboundscheck$/ ) {
- push @out, '-fno-bounds-check';
- } elsif ( $arg =~ m/^-unittest$/ ) {
- push @out, '-funittest';
- } elsif ( $arg =~ m/^-v$/ ) {
- $verbose = 1;
- push @out, '-fd-verbose';
- } elsif ( $arg =~ m/^-vtls$/ ) {
- push @out, '-fd-vtls';
- } elsif ( $arg =~ m/^-v1$/ ) {
- push @out, '-fd-version=1';
- } elsif ( $arg =~ m/^-version=(.*)$/ ) {
- push @out, "-fversion=$1";
- } elsif ( $arg =~ m/^-version.*$/ ) {
- errorExit "unrecognized switch '$arg'";
- } elsif ( $arg =~ m/^-vdmd$/ ) {
- $show_commands = 1;
- } elsif ( $arg =~ m/^-w$/ ) {
- push @out, "-Werror";
- } elsif ( $arg =~ m/^-wi$/ ) {
- push @out, "-Wall";
- } elsif ( $arg =~ m/^-quiet$/ ) {
- # ignored
- } elsif ( $arg =~ m/^-q,(.*)$/ ) {
- push @out, split(qr/,/, $1);
- } elsif ( $arg =~ m/^-X$/ ) {
- $json = 1;
- } elsif ( $arg =~ m/^-Xf(.*)$/ ) {
- $json = 1;
- $json_file = $1;
- } elsif ( $arg eq '-fall-sources' ) {
- $seen_all_sources_flag = 1;
- } elsif ( $arg =~ m/^-f.+/ ) {
- # Pass -fxxx options
- push @out, $arg;
- } elsif ($arg eq '-man') {
- browse("http://bitbucket.org/goshawk/gdc/wiki/UserDocumentation");
- exit 0;
- } elsif ( $arg =~ m/^-map$/ ) {
- $map = 1;
- if ($ARGV[$arg_i] =~ m/.map$/ ) {
- $map_file = $ARGV[$arg_i++];
- }
- } elsif ( $arg =~ m/^-m.+/ ) {
- # Pass -mxxx options
- push @out, $arg;
- } elsif ( $arg =~ m/^-.+$/ ) {
- errorExit "unrecognized switch '$arg'";
- } elsif ( $arg =~ m/^.+\.d$/i ||
- $arg =~ m/^.+\.dd$/i ||
- $arg =~ m/^.+\.di$/i ||
- $arg =~ m/^.+\.htm$/i ||
- $arg =~ m/^.+\.html$/i ||
- $arg =~ m/^.+\.xhtml$/i) {
- addSourceFile $arg;
- } elsif ( $arg =~ m/^.+\.ddoc/i ) {
- push @out, "-fdoc-inc=$arg";
- } elsif ( $arg !~ m/\./ ) {
- addSourceFile $arg . ".d";
- } elsif ( $arg =~ m/^(.+)(\.exe)$/i ) {
- $first_input_file = $arg if ! $first_input_file;
- $output_file = $1;
- if ( targetHasEXE() ) {
- $output_file .= $2;
- }
- } else {
- push @objects, $arg
- }
- }
- # Slightly different from dmd... allows -of to specify
- # the name of the executable.
- $combine =
- (! $link && ! $lib && scalar(@sources) > 1 && $output_file ) ||
- ($link && scalar(@sources) > 1); # > 0 ? does DMD now do the same for 1 vs many sources?
- if ( $run && ! $link ) {
- errorExit "flags conflict with -run";
- }
- if ( ($link || $lib) && ! $output_file && $first_input_file ) {
- $output_file = fileparse( $first_input_file, qr/\..*$/ );
- if ( $link && targetHasEXE() ) {
- $output_file .= '.exe';
- } elsif ( $lib ) {
- $output_file .= '.a';
- }
- }
- if (! scalar(@sources) && ! ($link && scalar(@objects))) {
- my @cmd = ($gdc, '--version', @out);
- my $result = system(@cmd);
- errorExit if $result & 0xff; # Give up if can't exec or gdc exited with a signal
- printUsage;
- exit 1;
- }
- my $ok = 1;
- foreach my $srcf_i (@sources) {
- # Step 1: Determine the object file path
- my $outf;
- my $hdrd;
- my $docd;
- my $srcf = $srcf_i; # To avoid modifying elements of @sources
- my @outbits;
- my @hdrbits;
- my @docbits;
- if ( $lib ) {
- # Generate a unique name in the temporary directory. The -op argument
- # is ignored in this case and there could very well be duplicate base
- # names.
- my $base = basename( $srcf, '.d' );
- my $i = 1;
- $outf = $base . '.o';
- while ( defined $tmpdir_objs{$outf} ) {
- $outf = $base . '-' . $i++ . '.o';
- }
- $tmpdir_objs{$outf} = 1;
- $outf = File::Spec->catfile( $tmpdir, $outf );
- } elsif ( ! ($link || $lib) && $output_file ) {
- $outf = $output_file;
- } else {
- if ( $output_directory ) {
- push @outbits, $output_directory;
- }
- if ( $output_parents ) {
- push @outbits, dirname( $srcf );
- }
- if ( scalar( @outbits )) {
- my $dir = File::Spec->catfile( @outbits );
- eval { mkpath($dir) };
- if ($@) {
- errorExit "could not create $dir: $@";
- }
- }
- # Note: There is currently no ($combine && $lib) case to check
- if ( $combine && $link) {
- push @outbits, basename( $output_file, '.exe' ) . '.o';
- } else {
- push @outbits, basename( $srcf, '.d' ) . '.o';
- }
- $outf = File::Spec->catfile( @outbits );
- if ( $combine && $link && $outf eq $output_file) {
- $outf .= '.o';
- }
- }
- if ($header) {
- if ( $header_directory ) {
- push @hdrbits, $header_directory;
- }
- if ( $output_parents ) {
- push @hdrbits, dirname( $srcf );
- }
- if ( scalar( @hdrbits )) {
- $hdrd = File::Spec->catfile( @hdrbits );
- eval { mkpath($hdrd) };
- if ($@) {
- errorExit "could not create $hdrd: $@";
- }
- }
- }
- if ($documentation) {
- if ( $documentation_directory ) {
- push @docbits, $documentation_directory;
- }
- if ( $output_parents ) {
- push @docbits, dirname( $srcf );
- }
- if ( scalar( @docbits )) {
- $docd = File::Spec->catfile( @docbits );
- eval { mkpath($docd) };
- if ($@) {
- errorExit "could not create $docd: $@";
- }
- }
- }
- if ($json) {
- if (! $json_file) {
- $json_file = substr($first_input_file, 0, length($first_input_file)-2) . ".json";
- }
- push @out, '-fXf=' . $json_file;
- }
- if ($map) {
- if (! $map_file) {
- $map_file = substr($first_input_file, 0, length($first_input_file)-2) . ".map";
- }
- # Check for Mac (Untested)
- if ($^O =~ m/darwin/i) {
- push @link_out, '-Wl,-map=' . $map_file;
- } else {
- push @link_out, '-Wl,-Map=' . $map_file;
- }
- }
- push @dobjects, $outf;
- my @source_args;
- if ( $combine ) {
- if ($gcc_maj >= 4 && $gcc_min <= 5) {
- push @source_args, "-combine";
- }
- push @source_args, @sources;
- } elsif ( $seen_all_sources_flag ) {
- @source_args = (@sources, "-fonly=$srcf");
- } else {
- @source_args = $srcf;
- }
- my @interface;
- if ( $header ) {
- push @interface, '-fintfc';
- push @interface, "-fintfc-dir=$hdrd" if $hdrd;
- push @interface, "-fintfc-file=$header_file" if $header_file;
- }
- my @documentation;
- if ( $documentation ) {
- push @documentation, '-fdoc';
- push @documentation, "-fdoc-dir=$docd" if $docd;
- push @documentation, "-fdoc-file=$documentation_file" if $documentation_file;
- }
- # Step 2: Run the compiler driver
- my @cmd = ($gdc, @out, '-c', @source_args, '-o', $outf, @interface, @documentation);
- if ( $show_commands ) {
- print join(' ', @cmd), "\n";
- }
- my $result = system(@cmd);
- errorExit if $result & 0xff; # Give up if can't exec or gdc exited with a signal
- $ok = $ok && $result == 0;
- last if $combine;
- }
- if ($ok && $link) {
- my @cmd = ($gdc, @out, @dobjects, @objects, @link_out);
- if ( $output_file ) {
- push @cmd, '-o', $output_file;
- }
- if ( $show_commands ) {
- print join(' ', @cmd), "\n";
- }
- $ok = $ok && system(@cmd) == 0;
- } elsif ($ok && $lib) {
- my @ar_cmd = determineARcommand();
- my @cmd = (@ar_cmd, $output_file, @dobjects, @objects);
- if ( $show_commands ) {
- print join(' ', @cmd), "\n";
- }
- $ok = $ok && system(@cmd) == 0;
- }
- if ($ok && $run) {
- my @cmd = (abs_path($output_file), @run_args);
- if ($verbose) {
- print join(' ', @cmd), "\n";
- }
- my $result = system @cmd;
- unlink ($output_file, @dobjects);
- if ($result == -1) {
- print STDERR "$output_file: $!\n";
- exit 127;
- } elsif ($result & 127) {
- exit 128 + ($result & 127);
- } else {
- exit $result >> 8;
- }
- }
- exit ($ok ? 0 : 1);