/d/dmd-script

#! /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
  \@cmdfile      read arguments from cmdfile
  -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
  -gs            always emit stack frame
  -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
  -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
  -property      enforce property syntax
  -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/^-gs$/ ) {
        push @out, '-fno-omit-frame-pointer';
    } 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;
        }
    } elsif ( $arg =~ m/^\@.+\.rsp$/i ) {
        # Append response file to end of ARGV.
    } else {
        push @objects, $arg
    }
}

# Slightly different from dmd... allows -of to specify
# the name of the executable.

$combine = scalar(@sources) > 1;
#  (! $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 $outf = $output_file;
    if ( $output_directory ) {
        $outf = File::Spec->catfile($output_directory, $output_file);
    }
    my @cmd = (@ar_cmd, $outf, @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);