dmd-script

   1 #! /usr/bin/perl -w
   2
   3 # GDC -- D front-end for GCC
   4 # Copyright (C) 2004 David Friedman
   5 #
   6 # This program is free software; you can redistribute it and/or modify
   7 # it under the terms of the GNU General Public License as published by
   8 # the Free Software Foundation; either version 2 of the License, or
   9 # (at your option) any later version.
  10 #
  11 # This program is distributed in the hope that it will be useful,
  12 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 # GNU General Public License for more details.
  15 #
  16 # You should have received a copy of the GNU General Public License
  17 # along with this program; if not, write to the Free Software
  18 # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  19
  20 # This is a wrapper script for gdc that emulates the dmd command.
  21 # -f and -m options are passed to gdc.  Extra options are:
  22 #
  23 # -vdmd                         Print commands executed by this wrapper script
  24 # -q,<arg1>[,<arg2>,<arg3>,...] Pass the comma-separated arguments to gdc
  25
  26
  27 use strict;
  28 use Cwd qw(abs_path);
  29 use File::Basename;
  30 use File::Spec;
  31 use File::Path;
  32 use File::Temp qw(tempdir);
  33
  34 my $output_directory;
  35 my $output_parents;
  36 my $output_file;
  37 my $header_directory;
  38 my $header_parents;
  39 my $header_file;
  40 my $documentation_directory;
  41 my $documentation_file;
  42 my $default_lib;
  43 my $debug_lib;
  44 my $debug = 0;
  45 my $link = 1;
  46 my $header = 0;
  47 my $documentation = 0;
  48 my $run = 0;
  49 my $verbose = 0;
  50 my $show_commands = 0;
  51 my $seen_all_sources_flag = 0;
  52 my $first_input_file;
  53 my $combine; # Compile multiple sources into a single object file
  54 my $lib = 0;
  55 my $tmpdir;
  56 my %tmpdir_objs;
  57
  58 my @sources;
  59 my @objects;
  60 my @dobjects;
  61
  62 my @out;
  63 my @link_out;
  64 my @run_args;
  65
  66 # Use the gdc executable in the same directory as this script and account
  67 # for the target prefix.
  68 basename($0) =~ m/^(.*-)?g?dmd(-.*)?$/;
  69 my $target_prefix = $1?$1:"";
  70 my $gdc_dir = abs_path(dirname($0));
  71 my $gdc = File::Spec->catfile( $gdc_dir, $target_prefix . "gdc" . ($2?$2:""));
  72
  73 sub osHasEXE() {
  74     return $^O =~ m/MS(DOS|Win32)|os2/i; # taken from File::Basename
  75 }
  76
  77 sub targetHasEXE() {
  78     my $target = `$gdc -dumpmachine`;
  79     return $target =~ m/mingw/ || $target =~ m/cygwin/;
  80 }
  81
  82 sub pathSep() {
  83     return ";" if $^O =~ m/MS(DOS|Win32)/i;
  84     return "," if $^O =~ m/MacOS/i;
  85     return ":";
  86 }
  87
  88 sub expandHome($) {
  89     my ($path) = (@_);
  90     if ( $^O !~ m/MS(DOS|Win32)|MacOS/i ) {
  91         $path =~ s/^~/$ENV{HOME}/;
  92     }
  93     return $path;
  94 }
  95
  96 sub printUsage() {
  97     print <<EOF
  98 Documentation: http://www.digitalmars.com/d/1.0/index.html
  99                http://dgcc.sourceforge.net/
 100 Usage:
 101   gdmd files.d ... { -switch }
 102
 103   files.d        D source files
 104   -arch ...      pass an -arch ... option to gdc
 105   -c             do not link
 106   -D             generate documentation
 107   -Dddocdir      write documentation file to docdir directory
 108   -Dffilename    write documentation file to filename
 109   -d             allow deprecated features
 110   -f...          pass an -f... option to gdc
 111   -framework ... pass a -framework ... option to gdc
 112   -debug         compile in debug code
 113   -debug=level   compile in debug code <= level
 114   -debug=ident   compile in debug code identified by ident
 115   -g             add symbolic debug info
 116   -gc            add symbolic debug info, pretend to be C
 117   -H             generate 'header' file
 118   -Hdhdrdir      write 'header' file to hdrdir directory
 119   -Hffilename    write 'header' file to filename
 120   --help         print help
 121   -ignore        ignore unsupported pragmas
 122   -Ipath         where to look for imports
 123   -inline        do function inlining
 124   -Jpath         where to look for string imports
 125   -Llinkerflag   pass linkerflag to link
 126   -nofloat       do not emit reference to floating point
 127   -O             optimize
 128   -o-            do not write object file
 129   -odobjdir      write object files to directory objdir
 130   -offilename    name output file to filename
 131   -op            do not strip paths from source file
 132   -m...          pass an -m... option to gdc
 133   -profile       profile runtime performance of generated code
 134   -quiet         suppress unnecessary messages
 135   -q,arg1,...    pass arg1, arg2, etc. to to gdc
 136   -release       compile release version
 137   -run srcfile args...   run resulting program, passing args
 138   -unittest      compile in unit tests
 139   -v             verbose
 140   -v1            D language version 1
 141   -vdmd          print commands run by this script
 142   -version=level compile in version code >= level
 143   -version=ident compile in version code identified by ident
 144   -w             enable warnings
 145 EOF
 146 ;
 147 }
 148
 149 sub errorExit(@) {
 150     print STDERR "dmd: ", @_, "\n" if @_;
 151     exit 1;
 152 }
 153 use subs qw(errorExit);
 154
 155 my $gcc_version = `$gdc -dumpversion`;
 156 chomp $gcc_version;
 157 $gcc_version =~ m/^(\d+)\.(\d+)/;
 158 my ($gcc_maj, $gcc_min) = ( $1, $2 );
 159
 160 my $target_machine = `$gdc -dumpmachine`;
 161 chomp $target_machine;
 162
 163 sub addSourceFile($) {
 164     my ($arg) = @_;
 165     $first_input_file = $arg if ! $first_input_file;
 166     push @sources, $arg;
 167 }
 168
 169 sub argCheck($$) {
 170     my ($name,$arg) = @_;
 171     errorExit "argument expected for switch '$name'" unless defined $arg;
 172 }
 173
 174 sub determineARexe() {
 175     my $name = $target_prefix . 'ar';
 176     $name .= '.exe' if (osHasEXE());
 177
 178     # Prefer the 'ar' in the same directory as gdc even if there is no
 179     # target prefix.
 180     my $path = File::Spec->catfile( $gdc_dir, $name );
 181     return $path if -x $path;
 182
 183     if ( length $target_prefix ) {
 184         foreach my $dir (split pathSep, $ENV{PATH}) {
 185             $path = File::Spec->catfile( $path, $name );
 186             return $name if -x $path; # Could return $path, but this looks better
 187         }
 188         errorExit "Could not find archiver command '$name'.";
 189     } else {
 190         return "ar";
 191     }
 192 }
 193
 194 sub determineARcommand() {
 195     my @exe = determineARexe();
 196     return (@exe, 'cru');
 197 }
 198
 199 sub browse($) {
 200     my ($url) = @_;
 201     my @cmd;
 202
 203     if ($^O =~ m/MSWin32/i) {
 204         @cmd = qw(cmd /c start);
 205     } elsif ($^O =~ m/darwin/i &&
 206              -x '/usr/bin/open') { # MacOS X vs. just Darwin
 207         @cmd = 'open';
 208     } elsif ($ENV{KDE_FULL_SESSION} eq 'true') {
 209         @cmd = qw(kfmclient exec);
 210     } elsif ($ENV{GNOME_DESKTOP_SESSION_ID} ne '') {
 211         @cmd = 'gnome-open';
 212     } else {
 213         errorExit "Sorry, I do not know how to start your browser.\nManual URL: $url"
 214     }
 215     push @cmd, $url;
 216     system @cmd;
 217     exit 0;
 218 }
 219
 220 my $arg_i = 0;
 221 while ( $arg_i < scalar(@ARGV) ) {
 222     my $arg = $ARGV[$arg_i++];
 223
 224     if ($arg eq '-arch' ) {
 225         push @out, '-arch', $ARGV[$arg_i++];
 226     } elsif ($arg =~ m/^-c$/ ) {
 227         $link = 0;
 228     } elsif ( $arg eq '-cov' ) {
 229         push @out, '-fprofile-arcs', '-ftest-coverage';
 230     } elsif ( $arg =~ m/^-D$/ ) {
 231         $documentation = 1;
 232     } elsif ( $arg =~ m/^-Dd(.*)$/ ) {
 233         $documentation = 1;
 234         $documentation_directory = $1;
 235     } elsif ( $arg =~ m/^-Df(.*)$/ ) {
 236         $documentation = 1;
 237         $documentation_file = $1;
 238     } elsif ( $arg =~ m/^-d$/ ) {
 239         push @out, '-fdeprecated';
 240     } elsif ( $arg =~ m/^-debug(?:=(.*))?$/ ) {
 241         push @out, (defined($1) ? "-fdebug=$1" : '-fdebug');
 242     } elsif ( $arg =~ m/^-debuglib=(.*)$/ ) {
 243         $debug_lib = $1;
 244     } elsif ( $arg =~ m/^-debug.*$/ ) {
 245         # Passing this to gdc only gives warnings; exit with an error here
 246         errorExit "unrecognized switch '$arg'";
 247     } elsif ( $arg =~ m/^-defaultlib=(.*)$/ ) {
 248         $default_lib = $1;
 249     } elsif ( $arg =~ m/^-g$/ ) {
 250         $debug = 1;
 251         push @out, '-g';
 252     } elsif ( $arg =~ m/^-gc$/ ) {
 253         $debug = 1;
 254         push @out, '-fdebug-c';
 255     } elsif ( $arg =~ m/^-gt$/ ) {
 256         errorExit "use -profile instead of -gt";
 257         push @out, '-pg';
 258     } elsif ( $arg =~ m/^-H$/ ) {
 259         $header = 1;
 260     } elsif ( $arg =~ m/^-Hd(.*)$/ ) {
 261         $header = 1;
 262         $header_directory = $1;
 263     } elsif ( $arg =~ m/^-Hf(.*)$/ ) {
 264         $header = 1;
 265         $header_file = $1;
 266     } elsif ( $arg eq '--help' ) {
 267         printUsage;
 268         exit 0;
 269     } elsif ($arg eq '-framework' ) {
 270         push @link_out, '-framework', $ARGV[$arg_i++];
 271     } elsif ( $arg eq '-ignore' ) {
 272         push @out, '-fignore-unknown-pragmas';
 273     } elsif ( $arg =~ m/^-inline$/ ) {
 274         push @out, '-finline-functions';
 275     } elsif ( $arg =~ m/^-I(.*)$/ ) {
 276         foreach my $i (split pathSep, $1) {
 277             push @out, '-I', expandHome $i;
 278         }
 279     } elsif ( $arg =~ m/^-J(.*)$/ ) {
 280         foreach my $i (split pathSep, $1) {
 281             push @out, '-J', expandHome $i;
 282         }
 283     } elsif ( $arg =~ m/^-L(.*)$/ ) {
 284         push @link_out, '-Wl,' . $1;
 285     } elsif ( $arg eq '-lib' ) {
 286         $lib = 1;
 287         $link = 0;
 288         $tmpdir = tempdir(CLEANUP => 1);
 289     } elsif ( $arg =~ m/^-O$/ ) {
 290         push @out, '-O3', '-fomit-frame-pointer';
 291         if( ! grep(/^-inline$/,@ARGV) ) {
 292             push @out, '-fno-inline-functions';
 293         }
 294         if ( $gcc_maj < 4) {
 295             push @out, '-frename-registers';
 296         }
 297         if ( $gcc_maj > 3 || ( $gcc_maj == 3 && $gcc_min >= 4 ) ) {
 298             push @out, '-fweb';
 299         }
 300     } elsif ( $arg =~ m/^-o-$/ ) {
 301         push @out, '-fsyntax-only';
 302         $link = 0;
 303     } elsif ( $arg =~ m/^-od(.*)$/ ) {
 304         $output_directory = $1;
 305     } elsif ( $arg =~ m/^-of(.*)$/ ) {
 306         $output_file = $1;
 307     } elsif ( $arg =~ m/^-op$/ ) {
 308         $output_parents = 1;
 309     } elsif ( $arg =~ m/^-nofloat$/ ) {
 310         # do nothing
 311     } elsif ( $arg =~ m/^-profile$/ ) {
 312         # there is more to profiling than this ... -finstrument-functions?
 313         push @out, '-pg';
 314     } elsif ( $arg =~ m/^-release$/ ) {
 315         push @out, '-frelease';
 316     } elsif ( $arg eq '-run' ) {
 317         $run = 1;
 318
 319         $arg = $ARGV[$arg_i++];
 320         argCheck '-run', $arg;
 321
 322         addSourceFile $arg;
 323
 324         push @run_args, @ARGV[$arg_i..$#ARGV];
 325         last;
 326     } elsif ( $arg =~ m/^-unittest$/ ) {
 327         push @out, '-funittest';
 328     } elsif ( $arg =~ m/^-v$/ ) {
 329         $verbose = 1;
 330         push @out, '-fd-verbose';
 331     } elsif ( $arg =~ m/^-v1$/ ) {
 332         push @out, '-fd-version=1';
 333     } elsif ( $arg =~ m/^-version=(.*)$/ ) {
 334         push @out, "-fversion=$1";
 335     } elsif ( $arg =~ m/^-version.*$/ ) {
 336         errorExit "unrecognized switch '$arg'";
 337     } elsif ( $arg =~ m/^-vdmd$/ ) {
 338         $show_commands = 1;
 339     } elsif ( $arg =~ m/^-w$/ ) {
 340         push @out, "-Wall";
 341     } elsif ( $arg =~ m/^-quiet$/ ) {
 342         # ignored
 343     } elsif ( $arg =~ m/^-q,(.*)$/ ) {
 344         push @out, split(qr/,/, $1);
 345     } elsif ( $arg eq '-fall-sources' ) {
 346         $seen_all_sources_flag = 1;
 347     } elsif ( $arg =~ m/^-f.+/ ) {
 348         # Pass -fxxx options
 349         push @out, $arg;
 350     } elsif ($arg eq '-man') {
 351         browse("http://dgcc.sourceforge.net/gdc/manual.html");
 352         exit 0;
 353     } elsif ( $arg =~ m/^-m.+/ ) {
 354         # Pass -mxxx options
 355         push @out, $arg;
 356     } elsif ( $arg =~ m/^-.+$/ ) {
 357         errorExit "unrecognized switch '$arg'";
 358     } elsif ( $arg =~ m/^.+\.d$/i ||
 359               $arg =~ m/^.+\.htm$/i ||
 360               $arg =~ m/^.+\.html$/i ||
 361               $arg =~ m/^.+\.xhtml$/i) {
 362         addSourceFile $arg;
 363     } elsif ( $arg =~ m/^.+\.ddoc/i ) {
 364         push @out, "-fdoc-inc=$arg";
 365     } elsif ( $arg !~ m/\./ ) {
 366         addSourceFile $arg . ".d";
 367     } elsif ( $arg =~ m/^(.+)(\.exe)$/i ) {
 368         $first_input_file = $arg if ! $first_input_file;
 369         $output_file = $1;
 370         if ( targetHasEXE() ) {
 371             $output_file .= $2;
 372         }
 373     } else {
 374         push @objects, $arg
 375     }
 376 }
 377
 378 # Slightly different from dmd... allows -of to specify
 379 # the name of the executable.
 380
 381 $combine =
 382   (! $link && ! $lib && scalar(@sources) > 1 && $output_file ) ||
 383   ($link && scalar(@sources) > 1); # > 0 ? does DMD now do the same for 1 vs many sources?
 384
 385 if ( $run && ! $link ) {
 386     errorExit "flags conflict with -run";
 387 }
 388
 389 if ( ($link || $lib) && ! $output_file && $first_input_file ) {
 390     $output_file = fileparse( $first_input_file, qr/\..*$/ );
 391     if ( $link && targetHasEXE() ) {
 392         $output_file .= '.exe';
 393     } elsif ( $lib ) {
 394         $output_file .= '.a';
 395     }
 396 }
 397
 398 if (! scalar(@sources) && ! ($link && scalar(@objects))) {
 399     my @cmd = ($gdc, '--version', @out);
 400     my $result = system(@cmd);
 401     errorExit if $result & 0xff; # Give up if can't exec or gdc exited with a signal
 402     printUsage;
 403     exit 1;
 404 }
 405
 406 my $ok = 1;
 407
 408 foreach my $srcf_i (@sources) {
 409     # Step 1: Determine the object file path
 410     my $outf;
 411     my $hdrd;
 412     my $docd;
 413     my $srcf = $srcf_i; # To avoid modifying elements of @sources
 414     my @outbits;
 415     my @hdrbits;
 416     my @docbits;
 417
 418     if ( $lib ) {
 419         # Generate a unique name in the temporary directory.  The -op argument
 420         # is ignored in this case and there could very well be duplicate base
 421         # names.
 422         my $base = basename( $srcf, '.d' );
 423         my $i = 1;
 424         $outf = $base . '.o';
 425         while ( defined $tmpdir_objs{$outf} ) {
 426             $outf = $base . '-' . $i++ . '.o';
 427         }
 428         $tmpdir_objs{$outf} = 1;
 429
 430         $outf = File::Spec->catfile( $tmpdir, $outf );
 431     } elsif ( ! ($link || $lib) && $output_file ) {
 432         $outf = $output_file;
 433     } else {
 434         if ( $output_directory ) {
 435             push @outbits, $output_directory;
 436         }
 437         if ( $output_parents ) {
 438             push @outbits, dirname( $srcf );
 439         }
 440
 441         if ( scalar( @outbits )) {
 442             my $dir = File::Spec->catfile( @outbits );
 443             eval { mkpath($dir) };
 444             if ($@) {
 445                 errorExit "could not create $dir: $@";
 446             }
 447         }
 448
 449         # Note: There is currently no ($combine && $lib) case to check
 450         if ( $combine && $link) {
 451             push @outbits, basename( $output_file, '.exe' ) . '.o';
 452         } else {
 453             push @outbits, basename( $srcf, '.d' ) . '.o';
 454         }
 455         $outf = File::Spec->catfile( @outbits );
 456         if ( $combine && $link && $outf eq $output_file) {
 457             $outf .= '.o';
 458         }
 459     }
 460
 461     if ($header) {
 462         if ( $header_directory ) {
 463             push @hdrbits, $header_directory;
 464         }
 465         if ( $output_parents ) {
 466             push @hdrbits, dirname( $srcf );
 467         }
 468
 469         if ( scalar( @hdrbits )) {
 470             $hdrd = File::Spec->catfile( @hdrbits );
 471             eval { mkpath($hdrd) };
 472             if ($@) {
 473                 errorExit "could not create $hdrd: $@";
 474             }
 475         }
 476     }
 477
 478     if ($documentation) {
 479         if ( $documentation_directory ) {
 480             push @docbits, $documentation_directory;
 481         }
 482         if ( $output_parents ) {
 483             push @docbits, dirname( $srcf );
 484         }
 485
 486         if ( scalar( @docbits )) {
 487             $docd = File::Spec->catfile( @docbits );
 488             eval { mkpath($docd) };
 489             if ($@) {
 490                 errorExit "could not create $docd: $@";
 491             }
 492         }
 493     }
 494
 495     push @dobjects, $outf;
 496
 497     my @source_args;
 498     if ( $combine ) {
 499         if ($gcc_maj >= 4) {
 500             push @source_args, "-combine";
 501         }
 502         push @source_args, @sources;
 503     } elsif ( $seen_all_sources_flag ) {
 504         @source_args = (@sources, "-fonly=$srcf");
 505     } else {
 506         @source_args = $srcf;
 507     }
 508
 509     my @interface;
 510     if ( $header ) {
 511         push @interface, '-fintfc';
 512         push @interface, "-fintfc-dir=$hdrd" if $hdrd;
 513         push @interface, "-fintfc-file=$header_file" if $header_file;
 514     }
 515
 516     my @documentation;
 517     if ( $documentation ) {
 518         push @documentation, '-fdoc';
 519         push @documentation, "-fdoc-dir=$docd" if $docd;
 520         push @documentation, "-fdoc-file=$documentation_file" if $documentation_file;
 521     }
 522
 523     # Step 2: Run the compiler driver
 524     my @cmd = ($gdc, @out, '-c', @source_args, '-o', $outf, @interface, @documentation);
 525     if ( $show_commands ) {
 526         print join(' ', @cmd), "\n";
 527     }
 528     my $result = system(@cmd);
 529     errorExit if $result & 0xff; # Give up if can't exec or gdc exited with a signal
 530     $ok = $ok && $result == 0;
 531
 532     last if $combine;
 533 }
 534
 535 if ($ok && $link) {
 536     my @override_lib = ();
 537     if ($debug && defined($debug_lib)) {
 538         @override_lib = ('-nophoboslib', "-l$debug_lib")
 539     } elsif (! $debug && defined($default_lib)) {
 540         @override_lib = ('-nophoboslib', "-l$default_lib")
 541     }
 542
 543     my @cmd = ($gdc, @out, @dobjects, @objects, @override_lib, @link_out);
 544     if ( $output_file ) {
 545         push @cmd, '-o', $output_file;
 546     }
 547     if ( $show_commands ) {
 548         print join(' ', @cmd), "\n";
 549     }
 550     $ok = $ok && system(@cmd) == 0;
 551 } elsif ($ok && $lib) {
 552     my @ar_cmd = determineARcommand();
 553     my @cmd = (@ar_cmd, $output_file, @dobjects, @objects);
 554     if ( $show_commands ) {
 555         print join(' ', @cmd), "\n";
 556     }
 557     $ok = $ok && system(@cmd) == 0;
 558 }
 559
 560 if ($ok && $run) {
 561     my @cmd = (abs_path($output_file), @run_args);
 562     if ($verbose) {
 563         print join(' ', @cmd), "\n";
 564     }
 565     my $result = system @cmd;
 566     unlink ($output_file, @dobjects);
 567     if ($result == -1) {
 568         print STDERR "$output_file: $!\n";
 569         exit 127;
 570     } elsif ($result & 127) {
 571         exit 128 + ($result & 127);
 572     } else {
 573         exit $result >> 8;
 574     }
 575 }
 576
 577 exit ($ok ? 0 : 1);