#! perl
#
# perl6 driver:  parse assemble compile and run .p6 files
#
# perl6 -h   for help - pod is at end of file
#
# (c) 2002-2003 Leopold Toetsch <lt@toetsch.at>
# s. LICENCES in parrot root dir for licence
#
# TODO's:
# s. pod
BEGIN{$SIG{__WARN__}=sub{print STDERR @_;$DB::single=1;}}

# With 5.005, you get: Can't locate object method "new" via package
# "P6C::IMCC::ExtRegex::CodeGen" at P6C/IMCC/ExtRegex.pm line 68.
# when running the tests in t/rx/
use 5.006;

use strict;
use FindBin;
use lib "$FindBin::Bin/../../lib";
use Getopt::Long;
use Parrot::Config;
use P6C::Tree;
use P6C::Parser;
use Carp qw(croak);

use lib "$FindBin::Bin/../regex/lib";

use vars qw($PARROT $PBC2C $HERE $CD $VERSION $PERL $slash $exe);
use vars qw($PARROT_ROOT @temp_files $LIB $TEST_IMPORT $LIBPA %STATS);
$VERSION = '0.1.1';

do 'perl6-config' or	# read pconfig, which was generated by Makefile
die "'perl6-config' not found: $!";

BEGIN {
    eval "use Time::HiRes qw(time);";
    $STATS{phases} = [ 'init' ];
    $STATS{start} = $STATS{init}{start} = time;
};
$STATS{init}{end} = time;

# Uncomment this to use the internal perl6 regex compiler (mostly
# working, with some known bugs) instead of the external regex
# compiler in languages/regex.
# $ENV{ORIGINAL_REGEXES} = 1;

$slash = $PConfig{slash};
$exe = $PConfig{exe};
$LIB = $PConfig{a};
# somewhen we need install paths
$PERL	= $PConfig{perl};
$PARROT = "$PARROT_ROOT${slash}parrot$exe";
$CD = "cd $PARROT_ROOT; ";
$PBC2C = "$CD $PERL pbc2c.pl";
$LIBPA = "$PARROT_ROOT${slash}" .$PConfig{blib_lib_libparrot_a};
$LIBPA =~ s/\$\(A\)/$LIB/;
#
# imported meth's for Test::More
$TEST_IMPORT = 'skip is';

use vars '%OPT';

sub usage($) {
    my $fh = shift;
    if ($OPT{'help-imcc'}) {
	print $fh <<'END';
IMCC options:
    -O{0,1,2}        perform (some rudimentary) optimizations
    -d|--debug       write various debug messages to STDERR
    -y|--yydebug     debug bison

    for other options (-t, -P ...) s. --help-parrot
    (--gc-debug, -. are unsupported in imcc)
END
    } elsif ($OPT{'help-parrot'}) {
	print $fh <<'END';
Parrot options:
    --shared         use dynamic parrot lib
    -Rc              create pbc
    -Rx|--parrot-options=bdhjpPgtv.
                     pass option(s) to parrot
END
	system("$PARROT -h");
    } elsif ($OPT{'help-global'}) {
	print $fh <<'END';
Global options:
    -h|--help        Print this message and exit
    --help-(imcc|parrot|test|parser|global|output)
                     Print detailed help for one subpart
    -v|--verbose     Print messages about compile stages (repeat for
                         more verbosity)
    -V|--version     Print versions and exit
    -w|--warnings    Print warnings (repeat for more warnings)
    --test           run tests like "make test"
    --test-parser    interactive parser-testing mode
    --timings        Report timing statistics
    --ignore-exitcode don't report non zero exit codes
    -c|--checksyntax Check syntax only, do not generate bytecode
    --clean          delete all possible produced files for all mentioned
END
    } elsif ($OPT{'help-output'}) {
	print $fh <<'END';
Output options:
    -o|--output F    Write output to file F
    -C|--compile-pbc compile to executable
    -B|--pbc         stop after creating .pbc file
    -I|--imc         stop after creating .imc file'
    -E               Preprocess input files and terminate processing
    --tree           stop after creating parse tree
    --raw-tree       stop after creating raw parse tree
    --keep-X         keep intermediate ".X" file (X = imc|pbc)
    -k|--keep-all    keep all intermediate files
    -g|--debug-info  generate debug info, i.e. produce and keep #line comments
    -Ox              optimize flag (currently only gcc)
                     Note: these does not optimize parrot's obj file
END
    } elsif ($OPT{'help-test'}) {
	print $fh <<'END';
Test options:
    --test           run tests like "make test"
                         .p6 source files
      --rm-exe       remove executable (mainly for testnative)
      -q|--quick     run .pbc directly, if present and newer then .p6
END
    } elsif ($OPT{'help-parser'}) {
	print $fh <<'END';
Parser options:
    --test-parser    interactive parser-testing mode

      Parse::RecDescent control:
        --trace      set $::RD_TRACE (or construct trace-enabled parser)
        --grammar NAME
                     use precompiled grammar NAME (default = Perl6grammar)

          only useful when constructing parser:
        --hitem      keep track of %item hash
        --force-grammar
                     Rebuild grammar even if it exists.
      Misc:
        -e|--eval 'command'
                       evaluate perl6 command
        --rule NAME    start with rule NAME (default = "prog")
                           (only useful in interactive mode)
END
    } else {
	print $fh <<'END';
usage:  perl6 [options] file.p6
        perl6 -e code
        perl6 --clean *.p6
        perl6 --test  *.t

Global options:
    -h|--help        Print this message and exit
    --help-(imcc|parrot|test|parser|output|global)
                     Print detailed help for one subpart
    -v|--verbose     Print messages about compile stages (repeat for
                         more verbosity)
    -V|--version     Print versions and exit
    -w|--warnings    Print warnings (repeat for more warnings)
    --test           run tests like "make test"
    --clean          delete all possible produced files for all mentioned
    --test-parser    interactive parser-testing mode
Parrot options:
    -R|--parrot-options=[bdhjpPgtv.]
                     pass option(s) to parrot. If -r is given, these
		     options apply to imcc
    --gc-debug       run parrot with --gc-debug flags
Output options:
    -o|--output F    Write output to file F
    -B|--pbc         stop after creating .pbc file
    -I|--imc         stop after creating .imc file
    -k|--keep-all    keep all intermediate files
END
    }
    exit(1);
}

Getopt::Long::Configure(qw(bundling));
GetOptions(\%OPT,qw{
    test-parser test
    timings
    trace hitem tree raw-tree
    eval|e=s rule=s grammar=s force-grammar
    debug|d yydebug life-info
    debug-info|g
    verbose|v+
    warnings|w+
    parrot-options|R=s
    compile-pbc|C quick|q ignore-exitcode rm-exe shared
    output|o=s
    gc-debug
    optimize|O=s
    pbc|B imc|I
    keep-imc keep-pbc keep-c keep-o keep-all|k keep-warn
    keep-tree clean
    help|h version|V help-imcc help-parrot help-test help-parser help-output
    help-global
}) or usage(\*STDERR);

# print version of parts and exit
sub version {
    print "perl6 driver $VERSION\n\n";
    system("$PARROT -v");
    exit(0);
}

################
usage(\*STDOUT) if grep /^help/, keys %OPT;
version() if ($OPT{version});

$::RD_TRACE = $OPT{trace};
$::RD_NO_HITEM = !$OPT{hitem};
$::RD_NO_TRACE = !$OPT{trace};
$::rule = $OPT{rule} || 'prog';
$OPT{grammar} ||= 'Perl6grammar';
$OPT{'parrot-options'} ||= '';
$OPT{verbose} = 0 unless (defined $OPT{verbose});
$OPT{tree} = 1 if $OPT{'test-parser'};
$OPT{'ignore-exitcode'} = 1 if $OPT{test};

my $filebase = 'a';		# basename for output files.

######## run parser and following steps

if ($OPT{test}) {
    run_tests();
}
else {
    run();
}
clean_temps();
$STATS{end} = time if $OPT{timings};
report_timings() if $OPT{timings};
########

###### utils
#
sub clean_temps {
    return if ($OPT{'keep-all'});
    for my $f (@temp_files) {
	my $ext;
	($ext = $f) =~ s/.*\.//;
	$f =~ s/$exe$//;
	next unless (-e $f);
	if ($OPT{verbose} > 1) {
	    print STDERR "unlink($f)\n" unless ($OPT{"keep-$ext"});
	}
	unlink($f) unless ($OPT{"keep-$ext"});
    }
}

sub clean_files($) {
    my $base = shift;
    push @temp_files, map {"$base.$_"} qw(imc pasm pbc c o warn tree trace dis);
    push(@temp_files, "$base$exe");
}

sub verbose($@) {
    my ($level, @t) = @_;
    if ($level <= $OPT{verbose}) {
	print STDERR "@t\n";
    }
}

#
# catch warnings of sub $sub and redirect them to file
#
my $wn = 0;
sub warnings($$) {
    my ($sub, $file) = @_;

    unless ($OPT{warnings}) {
	$wn++;

	if ($wn == 1) {
	    verbose(1, "Writing warnings to '$file'");
	    push(@temp_files, $file);
	}
	# redirect STDERR to file
	open(OERR, '>&STDERR');
	open(STDERR, ">>$file");
	select(STDERR); $|=1;
	select(STDOUT); $|=1;
	# and all warn messages too
	$SIG{'__WARN__'} = sub { print STDERR @_; };
	$SIG{'__DIE__'} = sub {
	    # print to file
	    print STDERR @_;
	    close(STDERR);
	    open(STDERR, '>&OERR');
	    # and to old dest, i.e. term
	    print STDERR "\n", @_;
	    die "\n",@_
	};
    }

    my $ret = &$sub;
    if ($wn) {
	# restore above redirects
	close(STDERR);
	open(STDERR, '>&OERR');
	close(OERR);	# avoid perl warning
	$SIG{'__WARN__'} = sub { warn @_; };
	$SIG{'__DIE__'} = sub { die @_; };
    }
    $ret;
}

sub run_pass ($$;$) {
    my ($desc, $sub, $warnfile) = @_;
    if (! $OPT{timings}) {
        return $warnfile ? warnings($sub, $warnfile) : $sub->();
    }

    # Accumulate results from multiple passes (I'm not sure whether
    # this will happen or not.)
    if (exists $STATS{$desc}{start}) {
        $STATS{$desc}{other} += $STATS{$desc}{end} - $STATS{$desc}{start};
    } else {
        push @{ $STATS{phases} }, $desc;
    }

    $STATS{$desc}{start} = time;
    my $ret = $warnfile ? warnings($sub, $warnfile) : $sub->();
    $STATS{$desc}{end} = time;
    return $ret;
}

sub mydie($$) {
    my ($ret, $prog) = @_;
    my $exit = $ret >> 8;
    my $sig = $ret & 127;
    my $dcore = $ret & 128;
    print STDERR "Error: '$prog' failed";
    if ($sig) {	# FIXME && OS ne Win?
	use Config;
	print STDERR "\n\tdied with signal $sig (SIG",(split(' ',$Config{sig_name}))[$sig],")\n";
	if ($dcore) {
	    print STDERR "\tand dumped core\n";
	    if ($OPT{verbose} > 1) {
		my ($prog) = split(' ', $prog);
		print STDERR "\tplease run 'gdb $prog core' and type 'bac' for reason\n";
	    }
	}
    }
    else {
	print STDERR " with exit code $exit\n";
    }
    croak('Stopped');
}

sub report_timing {
    my ($title, $info) = @_;
    printf("  % 20s: ", $title);

    if (! exists $info->{end}) {
        print "(incomplete)\n";
        return;
    }

    my $time = $info->{other};
    $time += $info->{end} - $info->{start};
    printf("%.4f sec", $time);
    print $info->{other} ? " (from multiple runs)\n" : "\n";
}

sub report_timings {
    print "TIMINGS REPORT:\n";

    my $total = $STATS{end} - $STATS{start};

    # A test to check whether any significant amount of time passed
    # between the end of one timing and the beginning of the next.
    my $tween_test = sub {
        return 1 if $OPT{verbose};
        return (shift() >= $total * 0.01);
    };

    my $prev = $STATS{start};
    foreach my $phase (@{ $STATS{phases} }) {
        my $tween = $STATS{$phase}{start} - $prev;
        if ($phase ne 'init' && $tween_test->($tween)) {
            print "".(" " x 23);
            printf("(%.4f sec in between)\n", $tween);
        }
        report_timing($phase, $STATS{$phase});
        $prev = $STATS{$phase}{end};
    }
    my $tween = $STATS{end} - $prev;
    printf("    (%f sec in between)\n", $tween)
      if $tween_test->($tween);
    report_timing("Overall", \%STATS);
}

##########################
# Pass 1 P6C parser
#        output file.imc [ file.tree ]
#

# dump tree or write imc
#
sub output_tree {
    my $tree = shift;
    my $file = shift;
    my $fw = shift || 0;
    if ($OPT{tree}) {
	my $tf;
	if ($file eq '-') {
	    $tf = '&STDOUT';
	} else {
	    $tf = "$filebase.tree";
	}
	verbose(2, "Dump tree to '$tf'");
	open(OUT, ">$tf") or die("Can't write '$tf': $!");
	print OUT Dumper($tree) if ($OPT{'raw-tree'});
	my $x = $tree->tree;
	print OUT Dumper($x);
	close OUT;
    } else {
        # Create a default description of main, to be used only if the
        # code doesn't create its own main() sub. The default will be
        # sub main (@ARGS) { ... }, except it won't pass in a named
        # argument hash. This is hopefully a temporary hack, until we
        # can find a better place to put all the named arguments than
        # in a magical extra hash arg.
        my $sub_def = new P6C::sub_def name => 'main';
        my ($default_sig) = P6C::Parser::parse_sig('');
        $sub_def->closure(new P6C::closure params => $default_sig);

        # Add a default 'main' function, but allow it to be overridden
        # without warning by defining a main() in the Perl6 source.
	my $func = P6C::IMCC::add_function('main', $sub_def, weak => 1);

	P6C::IMCC::set_function('main');
	my $x = $tree->tree;
	verbose(2, "compiling tree");
        run_pass('compile', sub { P6C::IMCC::compile($x) }, $fw);
	my $f = "$filebase.imc";
	$OPT{output} ||= '';
	if ($OPT{output} eq '-') {
	    verbose(2, "Writing to STDOUT");
	    $OPT{imc} = 1;	# stop after pipeing output to imcc
	}
	else {
	    verbose(2, "Writing '$f'");
	    open(OOUT, '>&STDOUT');
	    open(STDOUT, ">$f");
	}
	run_pass('emit', sub { P6C::IMCC::emit() }, $fw);
	if ($OPT{output} ne '-') {
	    close(STDOUT);
	    open(STDOUT, '>&OOUT');
	    close(OOUT);
	}
	return if ($OPT{imc});
	push(@temp_files, $f);
	pass2($f, $fw);
    }
}

# load Perlgrammar or generate new
# make new parser
#
sub get_parser() {
    my $parser;
    # load needed moduls
    if (defined $OPT{tree}) {
	eval <<'END';
	use Data::Dumper;
	$Data::Dumper::Terse = 1;
	$Data::Dumper::Indent = 1;
END
	die $@ if $@;
    } else {
	eval 'use P6C::IMCC qw(:external)';
	die $@ if $@;
    }
    if (!$OPT{'force-grammar'} && eval("require $OPT{grammar}")) {
	$parser = eval "new $OPT{grammar}" or die "$OPT{grammar}: $@";
    } else {
	warn $@ if $@;
	verbose(1,"Constructing parser for $OPT{grammar}...");
	if ($OPT{grammar}) {
	    P6C::Parser->Precompile($OPT{grammar});
	    eval "require $OPT{grammar}" or die $@;
	    $parser = $OPT{grammar}->new;
	} else {
	    $parser = P6C::Parser->new();
	}
	verbose(1, "Done");
    }
    if (defined $OPT{'debug-info'}) {
	if ($parser->can('Debug')) {
	    $parser->Debug(1);
	}
	else {
	    $parser->Replace(q!stmts:  __stmt[$arg[0]](s?) !);
	}
    }
    $parser;
}

#
# Convert perl6 code to imc
#
sub pass1($$$;$) {
    my ($parser, $f, $fw, $expr) = @_;
    my $in = '';
    local $/ = undef;
    verbose(1, "P6C '$f'");
    if ($f eq '__eval__') {
        $in = $expr;
    }
    else {
        open(IN, $f) or die("Can't read '$f': $!");
        $in = <IN>;
        close(IN);
    }
    verbose(2, "Parsing");
    P6C::IMCC::init() unless $OPT{tree};
    my $result = run_pass('parse', sub {$parser->$::rule($in,0,$f)}, $fw);
    output_tree($result, $f, $fw);
}

sub pbc_is_newer($) {
    my $base = shift;
    my $mp6  = (stat("$base.p6"))[9];
    my $mpbc = (stat("$base.pbc"))[9];
    return $mpbc >= $mp6;
}

sub p6_is_newer($) {
    my $base = shift;
    my $mp6  = (stat("$base.p6"))[9];
    my $test;
    ($test = $base) =~ s/_\d+$//;
    my $mt  = (stat("$test.t"))[9];
    return $mp6 >= $mt;
}

sub run {
    my $parser;

    if ($OPT{'test-parser'}) {
	run_interactive();
	return;
    }
    unshift(@ARGV, "__eval__") if defined($OPT{'eval'});
    while (@ARGV) {
        my $f = shift @ARGV;
        print STDERR "processing file '$f'\n" if($OPT{verbose}>1);
        if ($f eq '-') {
            $filebase = 'a';
        } else {
	    if ($OPT{output} && $OPT{output} ne '-') {
		($filebase = $OPT{output}) =~ s/\.[^.]*$//;
	    }
	    else {
		($filebase = $f) =~ s/\.[^.]*$//;
	    }
        }
	# special, clean all generated files
        if ($OPT{clean}) {
	    clean_files($filebase) if ($f =~ /\.p6$/ || $f eq '-');
            next;
        }

	# normal processing, passes rest of ARGV to running prog
        # run next passes
        my $fw = "$filebase.warn";
        unlink($fw);
        if ($OPT{quick} && -e "$filebase.pbc" && pbc_is_newer($filebase)) {
            pass4("$filebase.pbc", $fw); # run pbc
        }
        elsif ($f =~ /\.imc$/ || $f =~ /\.pasm$/) {
            pass2($f, $fw); # imc | pasm -> pbc
        }
        elsif ($f =~ /\.(?:pb)?c$/) {
            pass4($f, $fw); # run pbc
        }
        else {
            $parser = run_pass('get_parser', sub { get_parser() })
              unless ($parser);
            pass1($parser, $f, $fw, $OPT{'eval'}); # p6 -> imc
        }
	return;
    }
}

# run tests like "make test"
sub output_is($$;$);
sub output_like($$;$);

sub run_tests {
    my @testfiles = @ARGV ? @ARGV : grep !m{t/parser/},
      glob 't/*/*.t t/*/*/*.t t/*/*/*/*.t';
    my %map = ( 'output_is' => 'is', 'output_like' => 'like' );
    undef $/;
    my ($ntot, $len);
    my $BS = "\cH";
    my $parser = run_pass('get_parser', sub { get_parser() })
      unless ($OPT{"parrot-test"});
    foreach my $meth (keys(%map)) {
	no strict 'refs';
	*{$meth} = sub($$;$) {
	my ($test, $out, $desc) = @_;
	my $n = Test::Builder->current_test+1;
	my $t = "$n/$ntot";
	print STDERR $BS x length($t), $t;
	$filebase =~ s/(?:_\d+)?$/_$n/;
	my $fw = "$filebase.warn";
	my $file = "$filebase.p6";
	my $outf = "$filebase.out";
	$ARGV[0] = "> $outf";
	if ($OPT{quick} && -e "$filebase.pbc" &&
	    -e "$filebase.p6" &&
	    p6_is_newer($filebase) &&
	    pbc_is_newer($filebase)) {
	    pass4("$filebase.pbc", $fw);
	}
	else {
	    # reinit IMCC
	    P6C::IMCC::init();
	    my $result = run_pass('parse', sub {
		$parser->$::rule($test,0,'-')}, $fw);
	    # write .p6 file for reuse
	    # XXX if --keep only ??
	    open(OUT, ">$file");
	    print OUT $test;
	    close(OUT);
	    # run all steps
	    output_tree($result, $file, $fw);
	}
	# XXX should we delete test.out, test.warn?
	open(IN, $outf) or warn("Can't read '$outf': $!");
	my $res = <IN>;
	close(IN);
	$res =~ s/\cM//g;
	$out =~ s/\cM//g;
	# send result to Test::Builder
	    &{$map{$meth}} ($res, $out, $desc);
	};
    };
    $|=1;
    my $Test;
    my @tests;
    print "Test details:\n";
    eval(<<EOF);
    use Test::Builder;
    use Test::More;
    \$Test = Test::Builder->new();
EOF
    $len = 0;
    for my $f (@testfiles) {
	$len = length($f) if (length($f) > $len);
    }
    for my $f (@testfiles) {
	open (IN, $f) or die("Can't read '$f': $!");
	my $contents = <IN>;
	close(IN);
	($filebase = $f) =~ s/\.[^.]*$//;
	my ($i, $nr, $ok, $nok) = (0)x4;
	print STDERR $f, '.' x ($len+10-length($f));
	# get # of tests from 'tests => ...'
	# and delete all use .. TEST ... stuff
	if ($contents =~ s/use\s+.*?tests\s*=>\s*(\d+).*?[\r\n]+//) {
	    $ntot = $1;
	}
	# set file name for test results
	my $fh = $Test->output("$filebase.test");
	push(@tests, "$filebase.test");
	# print header for Test::Harness
	print $fh "#!perl\n";
	print $fh qq(print <<"EOF";\n);
	$Test->plan(tests => $ntot, import => [qw($TEST_IMPORT)]);
	# reset test counter
	$Test->current_test(0);
	$contents =~ s/use\s+TEST.*?[\r\n]+//;
	eval(<<"EOFTEST");
	$contents
EOFTEST
        print STDERR ("\n");
	print STDERR $@ if($@);
	# end footer
	print $fh "EOF\n";
	# close .test file, else last one is missing below
	close($fh);
    }

    print "\nTest summary:\n";
    system($PERL, "t/harness", @tests);
}

sub run_interactive {
    my $in = '';
    # Delay loading Term::ReadLine if we don't need it.
    my $parser = get_parser();
    eval {
    require Term::ReadLine;

    my $term = new Term::ReadLine $0 or die $!;
    my $prompt = '> ';

    while (defined(my $l = $term->readline($prompt))) {
	if ($in =~ /^:(.*)/) {
	    print eval $1, "\n";
	    $in = '';
	    next;
	}
	unless ($l =~ /^$/) {
	    $in .= "$l\n";
	    $prompt = '? ';
	    next;
	}
	print "as $::rule:\n";
	my $result = $parser->$::rule($in);
	print STDERR "done\n";
	if ($result) {
	    output_tree($result, '-');
	} else {
	    print "parse error\n";
	}
	print "\n";
	$in = '';
	$prompt = '> ';
    }
};
    die $@ if $@;
}

#
# compile intermediate compile code .imc => .pbc or/and run it
#
sub pass2($$) {
    my $file = shift;
    my $fw = shift;
    if ($OPT{'parrot-options'} =~ /c/) {
	$OPT{'parrot-options'} =~ s/c//;
	$OPT{c} = 1;
    }
    if ($OPT{c} && $OPT{'parrot-options'} =~ /G/) {
	$OPT{'parrot-options'} =~ s/G//;
	$OPT{G} = 1;
    }
    my $debug = join(' ', map { defined $OPT{$_} && $OPT{$_} ? "--$_" : '' }
	qw(debug yydebug verbose));
    $debug .= ' -O'.$OPT{optimize}.' ' if ($OPT{optimize});
    # create .pbc through parrot
    if ($OPT{'compile-pbc'} || $OPT{'c'}) {
	my $outfile = "$filebase.pbc";
	my $cmd = "$PARROT $debug -o$outfile $file";
	verbose(1, $cmd);
	run_pass('imcc', sub {
	    if (system($cmd)) {
		mydie($?, $cmd);
	    }
	}, $fw);
        push(@temp_files, $outfile);
	pass4($outfile, $fw);
	return;
    }

    $OPT{'parrot-options'} .= 'r' unless($OPT{'parrot-options'} =~ /r/);
    pass4($file, $fw);
    return;
}

#
# compile and run
# or run byte code
#
sub pass4($$) {
    my $file = shift;
    my $fw = shift;

    if ($OPT{'compile-pbc'}) {
	die $@ if $@;
	my $cmd;
	$cmd = "$PBC2C $HERE/$file";    # FIXME
	push(@temp_files, $file);
	push(@temp_files, "$filebase.c");
	push(@temp_files, "$filebase$PConfig{o}");
	verbose(1, "compiling $cmd");
	my $c;
	run_pass('pbc2c', sub {
	    $c = `$cmd`;
	}, $fw);
	open(C, ">$filebase.c") or die("Can't write '$filebase.c'");
	print C $c;
	close(C);
	my $opt = $OPT{optimize} ? '-O'.$OPT{optimize} : '';
	$cmd = "$CD $PConfig{cc} $PConfig{ccflags} $opt ".
	"$PConfig{cg_flag} $PConfig{cc_inc} ".
	"$PConfig{cc_warn} -c $HERE/$filebase.c $PConfig{'cc_o_out'} ".
	"$HERE/$filebase$PConfig{o}";
	verbose(1, "compiling $cmd");
	if (run_pass('compile-gencode', sub { system($cmd) }, $fw)) {
	    mydie($?, $cmd);
	}
	# XXX running --shared needs
	#
	# export LD_LIBRARY_PATH=../../blib/lib
	#
	# in advance
	#
	my $lib = !$OPT{shared} ? $LIBPA : '-L blib/lib -lparrot';
	$cmd = "$CD $PConfig{link} $PConfig{linkflags} ".
	"$PConfig{ld_out} $HERE/$filebase $HERE/$filebase$PConfig{'o'} ".
	"$lib ".
	"$PConfig{libs}";
	verbose(1, "linking $cmd");
	if (run_pass('link', sub { system($cmd) })) {
	    mydie($?,"Linking");
	}
	$filebase = ".$slash$filebase" if($filebase !~ m!/!);
	verbose(1, "running $filebase @ARGV");
        my $error = run_pass('exec', sub { system("$filebase @ARGV") });
        if ($error && !$OPT{'ignore-exitcode'}) {
	    mydie($?, $filebase);
	}
	unlink($filebase) if (-e $filebase && $OPT{'rm-exe'});

    }
    else {
	my @opt = map { "-$_" } split(//, $OPT{'parrot-options'});
	push(@opt, '--gc-debug') if ($OPT{'gc-debug'});
	push(@opt, '--debug') if ($OPT{'debug'});
	push(@opt, '-O'.$OPT{optimize}) if $OPT{optimize};
	my $cmd = "$PARROT @opt $file @ARGV";
	verbose(1, "running: $cmd");

        local *SAVEOUT;
	open(SAVEOUT, ">&STDOUT");
        if (defined($ARGV[0]) && $ARGV[0] =~ /> (.*)/) {
            open(STDOUT, $ARGV[0]);
            shift(@ARGV);
        }
        my $error = run_pass($OPT{runpbc} ? 'imcc-run' : 'parrot',
                             sub { system($PARROT, @opt, $file, @ARGV) });
        if ($error && !$OPT{'ignore-exitcode'}) {
            open(STDOUT, ">&SAVEOUT");
	    mydie($?, $cmd);
	}
	open(STDOUT, ">&SAVEOUT");
    }
}

__END__

=head1 NAME

perl6 - perl6 driver program

=head1 SYNOPSIS

perl6 [ p6c-options ] [ imcc-options ] [ asm-options ]
      [ run-options ] [ global-options ] file ...

perl6 --clean *.p6

perl6 --test [testfiles...]

=head1 DESCRIPTION

perl6 calls all the appropriate stages to parse, assemble and run a perl6
source file. As these steps evolve this program will, or it will be garbage
collected sometime in the future.

If called with .imc, .pasm or .pbc files, the appropriate pass(es) will be run.

=head1 OPTIONS

=head2 p6c-options

These options are for the parser P6C and for output generation.

=head2 Output options

=over 4

=item -C|--compile-pbc

Compile to executable and run native. See also Run options below.

=item -B|--pbc

Stop after creating .pbc file.

=item -I|--imc

Stop after creating .imc file.

=item --tree

Stop after creating parse tree, do not generate .imc output.

=item --raw-tree

Output raw parser tree, additionally to parse tree.

=item --keep-imc --keep-pbc --keep-c --keep-o --keep-warn --keep-exe

Keep intermediate file.ext. If perl6 stops with an error or with above options,
temp files are always kept.  The last output step (.pmc or executable) is of
course kept.

=item -k|--keep-all

Keep all intermediate files.

=item --clean

Unlink all files perl6 might have generated (see FILES below), except those
to --keep, e.g.

	perl6 file.p6 --clean --keep-exe

=item --test

Run tests like "make test". As the program startup and parser generation
are done only once, with this option tests run much faster.

=item --test-parser

Interactive parser-testing mode. The parser enters an interactive mode. An
empty line sends input to the parser.

=item -g|--debug-info

Generate debug info. This adds #line n "file" and source comments to the
.imc file.

=back

=head2 Parse::RecDescent control

=over 4

=item --trace

Set $::RD_TRACE. You know what it is when you want this.

=item --hitem

Keep track of %item hash.
(only useful when constructing parser)

=item --force-grammar

Rebuild grammar even if it exists.

=item --grammar NAME

Use precompiled grammar NAME (default = Perl6grammar)

=back

=head2 Misc

=over 4

=item --rule NAME

Start with rule NAME (default = 'prog')
(only useful in interactive mode)

=back

=head2 imcc-options

=over 4

=item --debug

Write various debug messages to STDERR.

=item --yydebug

Show bison's debug output

=back

=head2 asm-options

=over 4

=item -E

Preprocess input files and terminate processing.

=item -h|--help

Print this message.

=item -o|--output F

Write output to file F.

=item -c|--checksyntax

Check syntax only, do not generate bytecode.

=back

=head2 run-options

=over 4

=item -q|--quick

Run the .pbc file directly if it does exist and is not older then the
.p6 source file.

=item -R..|--parrot-options=bdhjpPgtv.

pass option(s) to parrot, see parrot -h.

    e.g. "perl6 -Rb. ..."  calls "parrot -b -. ..."

=item --shared

Run against shared dynamic libparrot - you must currently build it manually
in parrot root with:

	cd ../..
	make libparrot.a	# static lib
	make shared		# dynamic lib
	cd -			# back to perl6
	# and set this LD_LIBRARY_PATH
	# as libparrot.so is not installed during testing
	#
	export LD_LIBRARY_PATH=../../blib/lib

=item --ignore-exitcode

Don't report non zero exit codes. This is needed e.g. for make test,
when native code is tested.

=item --rm-exe

Remove executables after running. This is useful for testnative.

=back

=head2 global-options

=over 4

=item -h|--help

Print this message and exit

=item -v|--verbose

Print messages about compile stages

=item -vv

Be more verbose, print intermediate stages.

=item -V|--version

Print versions to STDOUT and exit

=item -w|--warnings

Print warnings. If -w is off, warnings are collected in file.warn.

=item -ww

Print diagnostics. N/Y.

=back

=head1 RETURN VALUE

Zero means successful compilation/run.

=for =head1 ERRORS

=head1 EXAMPLES

=over 4

=item perl6 foo.pl

Parse, assemble and run foo.pl, warnings and errors will go to foo.warn.
Intermediate files are foo.*, s. FILES below.

=item echo 'my $a=2; print $a _ "\n"' | perl6 -vvw

Show individual steps, display warning, intermediate files are named
a.*.

=item perl6 mops.pasm

Assemble and run mops.pasm.

=back

=head1 ENVIRONMENT

As perl6 is written in perl5, see perldoc perlrun. No environment vars
are used currently.

=head1 FILES

Perl6 process the following files:

	file.p6 ... perl6 source
	file.imc ... intermediate compiler code
	file.pasm ... parrot assember code
	file.pbc ... parrot byte code

The following files may be generated too:

	file.warn ... various warnings and errors during all stages
	file.tree ... parser tree (--tree)
	file.c
	file.o
	file	 ...  with option -C or
	file.exe      depending on $^O

	file.out  ... perl6 --test result file
	file.test ... perl6 --test Test::Harness input

Additionally the following files are cleaned by --clean

	file.trace	$ ../../parrot -t file.pbc 2> file.trace
	file.diss	$ ../../disassemble file.pbc > file.diss

If STDIN in processed, the filebase "a" will be used.

=head1 SEE ALSO

Have a look at the individual stages:

	P6C  ... perl6 parser, imc generator

	imcc ... intermediate code compiler, which is really:

	parrot ... byte code interpreter

=head1 BUGS

Parrot::Config doesn't provide all info needed to run, so there are
some hard coded values at the beginning of the program.

When a intermediate stage dumps core, the message is not in file.warn.

=head1 TODO

- clean up the option handling, parrot hash long options now
- Check for core files, and optionally get backtrace
- clean up source file
- more use of Parrot::Config
- filter warnings/diagnostics ...
  -Wofile -W/frompat/../topat/ (grep expr)

=head1 AUTHOR

Leopold Ttsch <lt@toetsch.at>

With a lot of help Sean O'Rourke and parts from his prd-perl6.pl.

=cut

# vim: set sw=4:
