use strict;
use warnings;
use Parse::RecDescent;

use constant DEBUG => 0;

if($ARGV[0] eq '-v') {
	print "babyperl 0.02, copyright 2001 Brent Dax\n\n";
	print "This release supports variables, operators, function calls, comments,\nand various control flow structures (if, if/else, while, do/while).";
	exit;
}

our(%Accum);
@Accum{qw(I N S P)}=qw(I0 N0 S0 P0);

our($asm, $pool, %symbols, @args, $NO_ERROR);
our(%unop_to_name, %binop_to_name, %funcs);

$NO_ERROR=$NO_ERROR;	#get rid of the stupid warning


{
	my(%regcounts);
	#0 is accum
	@regcounts{qw(I N S P)}=(5) x 4;
	warn values %regcounts if DEBUG;

	sub alloc($$) {
		my($type, $var)=@_;

		($type)=$type=~/^(\w)/;
		$type=uc $type;
		$type='P' unless $type =~ /[INSP]/;	#default to PMC register
		
		$symbols{$var}=$type.$regcounts{$type}++;
		die "Out of $type registers!\n" if $regcounts{$type} > 31;
		add_asm("#	$var($type) => $symbols{$var}");
	}
}

sub asm_command {
	my(@args);
	($_, @args)=@_;
	my($last, $ret)=(0)x2;

	for(my $i=0; $i < @args; $i++) {
		unless(defined $args[$i]) {
			splice @args, $i, 1;
			$i--;
			next;
		}
	}

	if(/\$\{d\}/) { #returns to the accumulator
		$ret=$Accum{picktype(@args)};
	}
	elsif($#args) { #more than one arg
		$ret=$args[0];
	}
	else {			#one arg only
		$ret=undef;
	}

	#the default accumulator
	s{
		\$
		\{
			d
		\}
	}
	{
		$Accum{picktype(@args)}
	}egx;

	#${N}, where N is an index into the array
	s{
		\$
		\{
			(\d*)
		\}
	}
	{
		$last=$1 if $1 > $last; $args[$1];
	}egx;

	#${...}, all remaining arguments
	s{
		\$
		\{
			\.\.\.
		\}
	}
	{
		join(", ", @args[$last..@args-1])
	}egx;

	warn($_, '::::', $ret, "\n") if DEBUG;

	return($_, $ret);
}


my $tree=parse(slurp(shift()));

die "Cannot continue after parsing errors\n" unless $tree;
add_asm('');

if(DEBUG) {
	print STDERR "Symbol dump:\n";
	for(keys %symbols) {
		print STDERR "	$_ => $symbols{$_}\n";
	}
	print STDERR "\n";
}

$tree->traverse;

print $asm;

warn "Warning: some arguments still on the stack\n" if(@args);

sub picktype {
	no warnings 'uninitialized';
	my($r, $cur);
	until($r =~ /^[INSP]/) {
		$cur=shift;
		($r)=($cur =~ /^(.)/);

		unless(@_ or defined $r) {
			if($cur =~ /^[+-]\d+(?:\.\d+)?$/) {
				return 'N';
			}
			else {
				return 'S';
			}
		}
	}


	for(@_) {
		($r)=/^(.)/ if(/^([INSP])/ gt $r);
	}

	return $r;
}

sub argpush($) {
	push @args, shift if defined $_[0];
}

sub argpop() {
	pop @args;
}

sub argpush2($$) {
	argpush(shift);
	argpush(shift);
}

sub argpop2() {
	(argpop, argpop);
}

sub argpushn(@) {
	push @args, @_;
}

sub argpopn($) {
	my @r;
	for(1..shift) {
		unshift @r, argpop();
	}
	return @r;
}

sub argpoptomark {
	my @r;
	no warnings 'uninitialized';
	while($r[0] ne '::MARK::') {
		unshift @r, argpop();
	}
	shift @r;
	return @r;
}

sub slurp {
	my($filename)=shift()||'-';
	open(IN, $filename) or die "Can't open $filename: $!";
	add_asm("#File: $filename\n\n#Variables: ");

	my $r;

	while(<IN>) {
		chomp;
		s/#.*?$//;
		$r.=$_."\n";
	}

	close(IN);
	return $r;
}

sub parse {
	my($file)=shift;

	#warn $file;

	my $p=new Parse::RecDescent(our $grammar);

	$p->start($file);
}



sub add_asm {
	$asm .= shift();
	$asm .= ($asm =~ /:$/ ? " " : "\n");
}

sub UNIVERSAL::preaction {}
sub UNIVERSAL::action    {}

sub UNIVERSAL::traverse  {
	my($me)=shift;

	$me->preaction;

	if(ref $me->{__DIRECTIVE1__}) {
		for( @{$me->{__DIRECTIVE1__}} ) {
			$_->traverse if ref $_ and ref $_ ne 'BLOCK';
		}
	}
	else {
		for(keys %$me) {
			next if /^__.*__$/;

			$me->{$_}->traverse if ref $me->{$_} and ref $me->{$_} ne 'BLOCK';
		}
	}

	$me->action;
	no warnings 'uninitialized';
	warn ref $me, ": [@::args]\n" if DEBUG;
}

sub start::preaction {}
sub start::action {
	::add_asm("end");
}

sub statement::preaction {
	$::pool=1;
	push @::args, '::MARK::';
}

sub statement::action {
	::argpoptomark();
}

sub expression::preaction {
	push @::args, '::MARK::'
}

sub expression::action {
	my($me)=shift;

	my(@myargs)=::argpoptomark();
	my($type, $name)=(shift @myargs, shift @myargs);
	@myargs=reverse @myargs;

	for($type) {
		if(/:f/)    {
			#function call
			$::funcs{$name}||=$name.' ${d}, ${...}';
			my($str, $dest)=asm_command($::funcs{$name}, @myargs);
			::add_asm($str);
			::argpush($dest);
		}
		elsif(/:u/) {
			my($str, $dest)=asm_command($::unop_to_name{$name}, @myargs);

			::add_asm($str);
			::argpush($dest);
		}
		elsif(/:b/) {
			my($str, $dest)=asm_command($::binop_to_name{$name}, @myargs);
			::add_asm($str);
			::argpush($dest);
		}
		else {
			unshift @myargs, $type, $name;
			::argpushn(@myargs);
		}
	}
}

sub subcall::preaction {
	my($me)=shift;
	::argpush2(':f', $me->{subname}{IDENT}{__VALUE__});
}

sub if_command::preaction {
	::add_asm("#if condition");
	push @::args, '::MARK::';
}

sub if_command::action {
	#Label format: xIF_c (x=(B => begin, E => end)
	my $me=shift;
	our $ifcount;
	my $count=$ifcount++;
	my ($reg)=::argpoptomark();

	if($me->{IF}{__VALUE__} eq 'if') {
		::add_asm("if $reg, BIF_$count	#if");
		::add_asm("branch EIF_$count");
		::add_asm("BIF_$count:");
	}
	else {	#unless was used
		::add_asm("if $reg, EIF_$count	#unless");
	}
	::add_asm("#then");
	$me->{block}->traverse();
	::add_asm("#end if");
	::add_asm("EIF_$count:");
	$count++
}

sub ifelse_command::preaction {
	::add_asm("#if/else condition");
	push @::args, '::MARK::';
}

sub ifelse_command::action {
	#Label format: xIFE_c (x=(B => begin, L => else, E => end))
	my $me=shift;
	our $ifelsecount;
	my $count=$ifelsecount++;
	my ($reg)=::argpoptomark();

	if($me->{IF}{__VALUE__} eq "if") {
		::add_asm("if $reg, BIFE_$count	#if");
		::add_asm("branch LIFE_$count");
		::add_asm("BIFE_$count:");
	}
	else {	#unless was used
		::add_asm("if $reg, LIFE_$count	#unless");
	}
	::add_asm("#then");
	$me->{BLOCK}->traverse;
	::add_asm("branch EIFE_$count");
	::add_asm("#else");
	::add_asm("LIFE_$count:");
	$me->{block}->traverse;
	::add_asm("#end if");
	::add_asm("EIFE_$count:");
}

sub while_command::preaction {
	my $me=shift;
	our $whilecount;
	my $count=$whilecount++;
	::add_asm("#while");
	::add_asm("TWL_$count:");
	$me->{_count}=$count;
	::add_asm("#while condition");
}

sub while_command::action {
	my $me=shift;
	my $count=$me->{_count};
	my $reg;
	$reg=::argpop() until $reg;
	::add_asm("if $reg, BWL_$count");
	::add_asm("branch EWL_$count");
	::add_asm("#while block");
	::add_asm("BWL_$count:");
	$me->{block}->traverse;
	::add_asm("branch TWL_$count");
	::add_asm("#end while");
	::add_asm("EWL_$count:");
}

sub dowhile_command::preaction {
	my $me=shift;
	our $dowhilecount;
	my $count=$dowhilecount++;
	$me->{_count}=$count;

	::add_asm("TDWL_$count:");
	$me->{BLOCK}->traverse;
}

sub dowhile_command::action {
	my $me=shift;
	my $count=$me->{_count};
	my $reg;
	$reg=::argpop() until $reg;
	::add_asm("if $reg, TDWL_$count");	
}

sub BLOCK::preaction {
	#::add_asm("enter");
}

sub BLOCK::action {
	#::add_asm("leave");
}

sub BINOP::preaction      {
	my($me)=shift;
	::argpush2(':b', $me->{__VALUE__});
}

sub UNOP::preaction {
	my($me)=shift;
	::argpush2(':u', $me->{__VALUE__});
}

sub CONSTANT::action {
	my($me)=shift;
	::argpush($me->{__VALUE__});
}

sub VARIABLE::action {
	my($me)=shift;
	my($name)=pop @::args;
	::argpush($symbols{'$'.$name}||die("Variable \$$name hasn't been declared\n"));
}

sub IDENT::action         {
	my($me)=shift;
	::argpush($me->{__VALUE__});
}

sub IF::preaction		  {}
sub IF::action			  {}

sub WHILE::preaction	  {}
sub WHILE::action		  {}


INIT {
	#$RD_HINT=1;


	our $grammar=<<'PARSER';

<autotree>

start:
	statements /^\Z/ | ''
	{
		unless($::NO_ERROR) {
			print STDERR "Error (L${thisline}C$thiscolumn): Program ended prematurely.";
		}
		undef;
	} <reject>

statements:
	statement(s /;/) /;?/

statement:
	declaration						|
	command							|
	expression						|
	#''								|
	<error>

expression: 
	value BINOP expression			|
	UNOP expression					|
	value							|
	<error>

value:
	CONSTANT						|
	VARIABLE						|
	subcall							|
	OPENPAREN expression CLOSEPAREN	|
	<error>

subcall:
	subname OPENPAREN 
		expression(s /,/) 
	CLOSEPAREN ...! '{'				|
	subname	expression(s /,/)
	...! '{'						|
	subname							|
	<error:A subroutine call was expected, but '${[split "\n", $text]}[0]' doesn't seem to be one>

declaration:
	'our' <commit> IDENT OPENPAREN VARIABLE CLOSEPAREN
	{
		::alloc(
			$item{IDENT}{__VALUE__},
			'$'.$item{VARIABLE}{IDENT}{__VALUE__}
		);
		$return=undef;
		1;
	}								|
	<error:A variable declaration was expected, but '${[split "\n", $text]}[0]' doesn't seem to be one>

command: ...must_be_command try_command

try_command:
	...IF some_sort_of_if			|
	...WHILE while_command			|
	...'do'	dowhile_command

must_be_command:
	IF | WHILE | 'do'

some_sort_of_if:
	ifelse_command					|
	if_command

if_command:
	IF OPENPAREN
		expression
	CLOSEPAREN block				| ''
	{
		if($text =~ /^(if|unless)/) {
			print STDOUT "Error (L${thisline}C$thiscolumn): An if or unless statement was started, but was incomplete\n";
			$::NO_ERROR=1;
		}
	}

ifelse_command:
	IF OPENPAREN
		expression
	CLOSEPAREN 
	BLOCK
	'else' block

while_command:
	WHILE OPENPAREN
		expression
	CLOSEPAREN block				| ''
	{
		if($text =~ /^while/) { 
			print STDERR "Error (L${thisline}C$thiscolumn): A while statement was expected, but was incomplete\n";
			$::NO_ERROR=1;
		}
	}

dowhile_command:
	'do' BLOCK
	WHILE OPENPAREN
		expression
	CLOSEPAREN						| ''
	{
		if($text =~ /^do/) {
			print STDERR "Error (L${thisline}C$thiscolumn): A do/while statement was expected, but was incomplete\n";
			$::NO_ERROR=1;
		}
	}

subname: ...!must_be_command IDENT

IF:
	'if' | 'unless'					| ''
	<error:An 'if' or 'unless' was expected, but '${[split ' ', $text]}[0]' doesn't seem to be one>

WHILE:
	'while' | 'until'				| ''
	<error:A 'while' or 'until' was expected, but '${[split ' ', $text]}[0]' doesn't seem to be one>

block:
	BLOCK autoend
	{ $return=$item{BLOCK} }

autoend: ''
	{ $text=';'.$text }

BLOCK:
	'{' <commit> statements '}'		|
	<error:A block was expected, but '${[split "\n", $text]}[0]' doesn't seem to start one> 

CONSTANT: 
	/[+-]?\d+(?:\.\d+)?/			|
	/^".*?"/						|
	/^'.*?'/						|
	<error:A constant was expected, but '${[split ' ', $text]}[0]' doesn't seem to be one> 

VARIABLE: 
	'$' IDENT						|
	'${' IDENT '}'					|
	<error:A variable was expected, but '${[split ' ', $text]}[0]' doesn't seem to be one> 

BINOP:	
	'+'  | '-'  | '*'  | '/'  | '%'  | '_'  | 'x'  | '='  |
	'+=' | '-=' | '*=' | '/=' | '%=' | '~=' | 'x=' |
	'>'  | '<'  | '==' | 'lt' | 'gt' | 'eq' |
    '<=' | '>=' | '!=' | 'ge' | 'le' | 'ne' |
	'&&' | '||' | 'and'| 'or'		 |
	<error>

UNOP: 
	'-'  | '+'  | '!'				|
	<error>

IDENT:
	/^\w+/							|
	<error>

OPENPAREN:
	'(' {1}

CLOSEPAREN:
	')' {1}

PARSER

	%unop_to_name=(
		'+'  => '#unary + has no effect - returns to ${0}',
		'-'  => 'neg ${d}, ${0}',
		'++' => 'incr ${0}',
		'--' => 'decr ${0}'
	);

	%binop_to_name=(
		'+'  => 'add ${d}, ${0}, ${1}',
		'-'  => 'sub ${d}, ${0}, ${1}',
		'*'  => 'mul ${d}, ${0}, ${1}',
		'/'  => 'div ${d}, ${0}, ${1}',
		'%'  => 'mod ${d}, ${0}, ${1}',
		'_'  => 'concat ${d}, ${0}, ${1}',
		'='  => 'set ${0}, ${1}',
		'+=' => 'incr ${0}, ${1}',
		'-=' => 'decr ${0}, ${1}',
		'*=' => 'mul ${0}, ${0}, ${1}',
		'/=' => 'div ${0}, ${0}, ${1}',
		'%=' => 'mod ${0}, ${0}, ${1}',
		'_=' => 'concat ${0}, ${1}'
	);

	%funcs=(
		'print' => 'print ${0}',
	);
}