#! /usr/bin/perl -w

# GDC -- D front-end for GCC
# Copyright (C) 2004 David Friedman
#
# 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 Cwd qw(abs_path);
use File::Basename;
use File::Spec;
use File::Path;

my $output_directory;
my $output_parents;
my $output_file;
my $header_directory;
my $header_parents;
my $header_file;
my $link = 1;
my $header = 0;
my $run = 0;
my $verbose = 0;
my $show_commands = 0;
my $seen_all_sources_flag = 0;
my $first_input_file;

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 $gdc = File::Spec->catfile( abs_path(dirname($0)),
			       ($1?$1:"") . "gdc" . ($2?$2:""));

sub osHasEXE() {
    return $^O =~ m/MS(DOS|Win32)|os2/i; # taken from File::Basename
}

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/
Usage:
  gdmd files.d ... { -switch }

  files.d        D source files
  -arch ...      pass an -arch ... option to gdc
  -c             do not link
  -D             generate documentation
  -Dddocdir      write documentation file to docdir directory
  -Dffilename    write documentation file to filename
  -d             allow deprecated features
  -f...          pass an -f... option to gdc
  -framework ... pass a -framework ... option to gdc
  -debug         compile in debug code
  -debug=level   compile in debug code <= level
  -debug=ident   compile in debug code identified by ident
  -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
  -Jpath         where to look for string imports
  -inline        do function inlining
  -Llinkerflag   pass linkerflag to link
  -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
  -m...          pass an -m... option to gdc
  -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
  -w             enable warnings
EOF
;
}

sub errorExit(@) {
    print STDERR "dmd: ", @_, "\n" if @_;
    exit 1;
}
use subs qw(errorExit);

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;
}

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$/ ) {
	push @out, '-fdoc';
    } elsif ( $arg =~ m/^-Dd(.*)$/ ) {
	push @out, "-fdoc-dir=$1";
    } elsif ( $arg =~ m/^-Df(.*)$/ ) {
	push @out, "-fdoc-file=$1";
    } elsif ( $arg =~ m/^-d$/ ) {
	push @out, '-fdeprecated';
    } elsif ( $arg =~ m/^-debug(?:=(.*))?$/ ) {
	push @out, (defined($1) ? "-fdebug=$1" : '-fdebug');
    } elsif ( $arg =~ m/^-debug.*$/ ) {
	# Passing this to gdc only gives warnings; exit with an error here
	errorExit "unrecognized switch '$arg'";
    } elsif ( $arg =~ m/^-g$/ ) {
	push @out, '-g';
    } elsif ( $arg =~ m/^-gc$/ ) {
	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_directory = $1;
    } elsif ( $arg =~ m/^-Hf(.*)$/ ) {
	$header_file = $1;
    } elsif ( $arg eq '--help' ) {
	printUsage;
	exit 0;
    } elsif ($arg eq '-framework' ) {
	push @link_out, '-framework', $ARGV[$arg_i++];
    } 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 =~ m/^-O$/ ) {
	push @out, '-O3', '-fomit-frame-pointer';
	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;
	$header_parents = 1;
    } elsif ( $arg =~ m/^-nofloat$/ ) {
	# do nothing
    } 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/^-unittest$/ ) {
	push @out, '-funittest';
    } elsif ( $arg =~ m/^-v$/ ) {
	$verbose = 1;
	push @out, '-fd-verbose';
    } 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, "-Wall";
    } elsif ( $arg =~ m/^-quiet$/ ) {
	# ignored
    } elsif ( $arg =~ m/^-q,(.*)$/ ) {
	push @out, split(qr/,/, $1);
    } elsif ( $arg eq '-fall-sources' ) {
	$seen_all_sources_flag = 1;
	# push @out, $arg;
    } elsif ( $arg =~ m/^-f.+/ ) {
	# Pass -fxxx options
	push @out, $arg;
    } elsif ( $arg =~ m/^-m.+/ ) {
	# Pass -mxxx options
	push @out, $arg;
    } elsif ( $arg =~ m/^-.+$/ ) {
	errorExit "unrecognized switch '$arg'";
    } elsif ( $arg =~ m/^.+\.d$/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 ( osHasEXE() ) {
	    $output_file .= $2;
	}
    } else {
	push @objects, $arg
    }
}

# Slightly different from dmd... allows -of to specify
# the name of the executable.
if ( ! $link && scalar(@sources) > 1 && $output_file ) {
    errorExit "object file name specified with multiple source files";
}

if ( $run && ! $link ) {
    errorExit "flags conflict with -run";
}

if ( $link && ! $output_file && $first_input_file ) {
    $output_file = fileparse( $first_input_file, qr/\..*$/ );
    if ( osHasEXE() ) {
	$output_file .= '.exe';
    }
}

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 $srcf = $srcf_i; # To avoid modifying elements of @sources
    my @outbits;
    my @hdrbits;

    if ( ! $link && !$header && $output_file ) {
	$outf = $output_file;
    } else {
	if ( $output_directory ) {
	    push @outbits, $output_directory;
	    #$outf = $output_directory;
	    #$outf .= '/';
	}
	if ( $output_parents ) {
	    #my $dir = dirname( $srcf ); # should be '.' for no directory spec, but...
	    #$outf .= (dirname( $srcf ) . '/') if $dir;
	    push @outbits, dirname( $srcf );
	}

	if ( scalar( @outbits )) {
	    my $dir = File::Spec->catfile( @outbits );
	    eval { mkpath($dir) };
	    if ($@) {
		errorExit "could not create $dir: $@";
	    }
	}

	if ( $header_directory ) {
	    push @hdrbits, $header_directory;
	}
	if ( $header_parents ) {
	    push @hdrbits, dirname( $srcf );
	}

	if ( scalar( @hdrbits )) {
	    my $dir = File::Spec->catfile( @hdrbits );
	    eval { mkpath($dir) };
	    if ($@) {
		errorExit "could not create $dir: $@";
	    }
	    $hdrd = File::Spec->catfile( @hdrbits );
	}

	push @outbits, basename( $srcf, '.d' ) . '.o';
	# $outf .= basename( $srcf, '.d' ) . '.o';
	$outf = File::Spec->catfile( @outbits );
    }
    push @dobjects, $outf;

    my @all_sources_hack;
    if ( $seen_all_sources_flag ) {
	@all_sources_hack = (@sources);
	$srcf = "-fonly=$srcf";
    }

    my @interface;
    if ( $header ) {
	push @interface, '-fintfc';
	push @interface, "-fintfc-dir=$hdrd" if $hdrd;
	push @interface, "-fintfc-file=$header_file" if $header_file;
    }

    # Step 2: Run the compiler driver
    my @cmd = ($gdc, @out, '-c', @all_sources_hack, $srcf, '-o', $outf, @interface);
    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;
}

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;
}

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);
