#!/usr/bin/perl

# Copyright (c) 2002-2009 Nokia Corporation and/or its subsidiary(-ies).

# All rights reserved.

# This component and the accompanying materials are made available

# under the terms of "Eclipse Public License v1.0"

# which accompanies this distribution, and is available

# at the URL "http://www.eclipse.org/legal/epl-v10.html".

#

# Initial Contributors:

# Nokia Corporation - initial contribution.

#

# Contributors:

#

# Description:

#

use strict;

use Getopt::Long;

use Cwd;

my $Pwd = cwd;

my $incroot = $Pwd;

if ($Pwd =~ /.\:(.*)$/) {

	$incroot = $1;

	$incroot =~ s/\//\\/go;

	$incroot = "$incroot"."\\";

}

if ($^O == "MSWin32" ) {

	my $PATHSEP='\\'

} else {

	my $PATHSEP='/'

}

my $commentToken = "//";

my $emitUnimplemented = 1;

my %opts = ();

my $result = GetOptions(\%opts,

						"record-emitter",

						"suppress-check",

						"no-original",

						"output:s",

						"error-string:s",

						"autoflush",

						"help",

						"lineno",

						);

Usage() if(!$result || $opts{'help'} || @ARGV < 1);

my $errorString = "\t>>> CHECK THIS <<<";

my $recordEmitter = $opts{"record-emitter"};

my $plineno = $opts{"lineno"};

my $forceCheck = !$opts{"suppress-check"};

my $printOriginal = !$opts{"no-original"};

my $outfile = $opts{"output"} if $opts{"output"};

my $infile = @ARGV[0];

$errorString = $opts{"error-string"} if $opts{"error-string"};

#my $symbolsfile = "tranasm-symbols.log";

my $symbolsfile = "";

my $savedOut;

# set to false to prevent recording files in \tranlated-files.log

#my $recordFile = 0;

#system "echo $infile >> \\translated-files.log" if $recordFile;

my @unmangledSymbols;

my $recordUnmangledSymbols = $symbolsfile;

if ($outfile) {

	open OUT, ">$outfile";

	$savedOut = select OUT;

}

$| = $opts{"autoflush"};

my $labelN = 0;

my $labelRoot = "Label";

my $lineno = 0;

my @knownLabels = ();

sub Croak($)

{

	my ($msg) = @_;

    die  "\nERROR: line $.: $msg";

}

sub PrintComment($)

{

	my ($comment) = @_;

    printf "\t$commentToken$comment" if $comment;

}

sub PrintCheck() { printf "\t$errorString\n" if $forceCheck; }

sub Nl () { printf "\n"; }

# cache for results of unmangling....

my %unmangledSymbols = ();

# cache to say whether symbol was mangled

my %mangledSymbols = ();

my $sourcefile = "\"$infile\"";

my @IncFiles;

sub Unmangle ($)

{

	my ($str) = @_;

	return $str if ($str =~ /\s*__cpp\(/); # these don't need unmangling

	my $res = $unmangledSymbols{$str};

	if ($res) {

		my $l = $lineno;

		if ($mangledSymbols{$str}) {

			my $sfile = $sourcefile;

			$sfile =~ s/\"//go;

			$sfile =~ s/\\\\/${main::PATHSEP}/go;

			push @unmangledSymbols, "$incroot$sfile $l: Symbol = $str : Result = $res : Filt = \?\?\? : @IncFiles"

			}

		return $res;

	} else {

		return $unmangledSymbols{$str} = UnmangleX($str);

	}

}

sub UnmangleX ($)

{

	my ($str) = @_;

	my $sfile = $sourcefile;

	$sfile =~ s/\"//go;

	$sfile =~ s/\\\\/${main::PATHSEP}/go;

	# recognize non-c++ derived symbols/labels

	if ($str =~ /^\s*(__.*)\s*$/) {

	    $str =~ s/\./_/;

	    return $str;

	} 

	my $cppfilt = $ENV{CPPFILT} ? $ENV{CPPFILT} : "c++filt";

	open UNM, "$cppfilt -s gnu $str|" or die "Error: Tranasm problem running $cppfilt to unmangle symbols.\n";

	my $result = <UNM> ;

	chop $result;

	my $pat = "\^\\s*$result\\s*\$";

	if ($str =~ $pat) {

	    return $str;

	}

	close UNM;

	#strip of any args

	if ($result =~ /([^\(]*)\s*\(/) {

		my $res = $1;

		if ($recordUnmangledSymbols) {

			my $l = $lineno;

			$mangledSymbols{$str} = 1;

			push @unmangledSymbols, "$incroot$sfile $l: Symbol = $str : Result = $res : Filt = $result : @IncFiles";

		}

		$result = $res;

	} else {

		# didn't have args so try as a (static) var

		my $res = "\&$result";

		if ($recordUnmangledSymbols) {

			my $l = $lineno;

			$mangledSymbols{$str} = 1;

			push @unmangledSymbols, "$incroot$sfile $l: Symbol = $str : Result = $res : Filt = $result : @IncFiles";

		}

		$result = $res;

	}		

	return $result;

}

sub EmitOriginal($$)

{

	my ($orig , $emitter) = @_;

	$orig =~ /\s*(.*)/;

	printf "\t$commentToken Original - $1\n" if ($printOriginal);

	printf "\t$commentToken emitted by $emitter\n" if ($recordEmitter);

}

sub EmitUnimplementedOpcode ($$$$)

{

    my ($original, $asm) = @_;

    if ($emitUnimplemented) {

		EmitOriginal ($original, "EmitUnimplementedOpcode");

		if ($asm =~ /(\S+)\s+/ or $asm =~ /\.*(\S+)/){

			my $opcode = uc $1;

			printf "\t$commentToken Translation of opcode $opcode not implemented\n";

			printf "\t**** Insert translation here ****\n";

		}

		else { 

			UnrecognisedAsmWarning("EmitUnimplementedOpcode", $original);

		}

    }

}

sub SimpleEmit ($$$$)

{

	my ($original, $str, $emitter, $comment) = @_;

	PrintCheck();

    EmitOriginal ($original, $emitter);

    printf "$str";

    PrintComment($comment);

    Nl();

}

sub UnrecognisedAsmWarning ($$)

{

    my ($where, $what) = @_;

    printf STDERR "WARNING: line $. unrecognised asm format in $where: $what";

}

sub Count ($$$$) {

	my ($str, $c, $start, $end) = @_;

	my $total = 0;

	my @a = split //, $str;

	for (;$start < $end; $start++) {

		$total++ if ($a[$start] eq $c);

	}

	return $total;

}

sub TranslateConstrainedArgs($$) {

	my ($args, $constraints) = @_;

	my $ins = GetInputConstraints($constraints) if ($constraints);

	my @arglist;

	my @rl;

	my $start = 0;

	my $end = length $args;

	my $cpos = index $args, ",", $start;

	if ($cpos > -1) {

		while ($cpos > -1) {

			#make sure we got a match number of '('s and ')' $start and $cpos

			my $nl = Count($args, '(', $start, $cpos);

			my $nr = Count($args, ')', $start, $cpos);

			if ($nl == $nr) {

				my $arg = substr($args, $start, $cpos - $start);

				push @arglist, $arg;

				$start = $cpos + 1;

				$cpos = index $args, ",", $start;

			} else {

				$cpos = index $args, ",", $cpos + 1;

			}

		}

		push @arglist, substr($args, $start, $end);

	} else {

		push @arglist, ChopWhiteSpace($args);

	}

	foreach (@arglist) {

		push @rl, SubstituteConstraint($_, $ins);

	}

	return join ", ", @rl;

}

sub GetInputConstraints($) {

	my ($cs) = @_;

	if ($cs =~ /\:\s+\:\s*(.*)/) {

		return join "", split '\"i\" ', $1;

	} else {

		Croak("unrecognized contraints format: $cs\n");

	}

}

sub ChopWhiteSpace ($) {

	my ($str) = @_;

	my @a = split //, $str;

	my $n = length($str);

	return $str if $n == 0;

	while (--$n) {

	    if ($a[$n] eq ' ') {

		next;

	    } else {

		last;

	    }

	}

	$n++ unless $a[$n] eq ' ';

	return substr $str, 0, $n;

}

sub SubstituteConstraint($$) {

    my ($arg, $cs) = @_;

    my $u;

	$arg = ChopWhiteSpace($arg);

	unless ($cs) {

		if ($arg =~ /\s*(.*)\s*$/ ) {

			$u = $1;

		} else {

			Croak("Arg not supplied in SubstituteConstraint\n");

		}

	} elsif ($arg =~ /\%\S+(\d+)/ ) {

		my $i = $1;

		my @c = split '\,', $cs;

        $u = $c[$i];

    } elsif ($arg =~ /\s*(.*)\s*$/ ) {

		$u = $1;

    } else {

		Croak("Arg not supplied in SubstituteConstraint\n");

	}

	my $metau = quotemeta "$u";

	if (NeedsImporting($u)) {

		print "\timport $u ";

		PrintComment("Added by Substitute Constraint");

		Nl();

		AssertSourceFile();

		return "$u";

	} elsif ($u =~ /\s*__cpp/) {

		return $u;

	} elsif (grep /^$metau/, @knownLabels) {

		return $u;

	} else {

		return "__cpp($u)";

	}

}

sub RegisterSymbol($)

{

	my ($sym) = @_;

	return 1 if ($sym =~ /^r1[0-5]\s*$/i);

	return 1 if ($sym =~ /^r[0-9]\s*$/i);

	return 1 if ($sym =~ /^lr\s*$/i);

	return 1 if ($sym =~ /^pc\s*$/i);

	return 1 if ($sym =~ /^ip\s*$/i);

	return 1 if ($sym =~ /^sp\s*$/i);

	return 0;

}	

sub NeedsImporting($)

{

	my ($sym) = @_;

	return 0 if ($sym =~ /\s*0x/i );

	return 0 if ($sym =~ /^\s*0\s*/ );

	return 0 if ($sym =~ /^\s*\d+\s*/ );

	return 0 if ($sym =~ /\s*\(/ );

	return 0 if ($sym =~ /\s*__cpp\(/ );

	return 0 if RegisterSymbol($sym);

	my $unms = Unmangle($sym);

	my $pat = quotemeta($unms);

	unless ($sym =~ /$pat/) {

		return 0;

	}

	if (($sym =~ /(\w*)/) && (grep /^$1/, @knownLabels) ) {

		return 0;

	} else {

		return 1;

	}

}

sub MaybeImportArgs($)

{

	my ($args) = @_;

	my $arg;

	foreach $arg (split /\,/, $args) {

		MaybeEmitImport($arg);

	}

}

sub GetInputConstraint($$$)

{

    # It would have been nice if we could have used split to get at the constraints

    # but we can't coz ':' can obviously appear as part of a qualified name. So we have to do it

    # by hand.

    my ($constraints, $index, $noError) = @_;

    # assume constraints look like " : output : input [: sideffects"]

    my $i1 = index($constraints, ":"); # output field after this index

    Croak("unrecognized contraints format: $constraints\n") if (!$noError and $i1 < 0);

    my $i2 = index($constraints, ":", $i1 + 1); # input field after this index

    Croak("unrecognized contraints format: $constraints\n") if !$noError and $i2 < 0;

    Croak("can't deal with output constraints: $constraints\n") 

		if !$noError and (substr($constraints, $i1 + 1, $i2 - $i1 - 1) =~ /\S+/);

    Croak("can't deal with side effect constraints: $constraints\n") 

		if (substr($constraints, $i2 + 1) =~ /(\s*\".+\".*\(.*\))\s*\:+/);

    if ($i2 > 0 

		and (length($constraints) - 1) > $i2 

		and substr($constraints, $i2 + 1) =~ /(\s*\".+\".*\(.*\S+.*\))\s*\:*/) {

        return $1;

    } else {

		return 0;

    }

}

sub GetOutputConstraint($$)

{

    # It would have been nice if we could have used split to get at the constraints

    # but we can't coz ':' can obviously appear as part of a qualified name. So we have to do it

    # by hand.

    my ($constraints, $index) = @_;

    # assume constraints look like " : output : input [: sideffects"]

    my $i1 = index($constraints, ":"); # output field after this index

    my $i2 = index($constraints, ":", $i1 + 1); # output field after this index

	if ($i2 != -1) {

		if ( substr($constraints, $i1 + 1, $i2 - $i1 - 1) =~ /\s*(\".*\"\s*\S*.*\))\s*\:*/) {

			return $1;

		} else {

			return 0;

		}

	} elsif ( substr($constraints, $i1 + 1) =~ /\s*(\".*\"\s*\S*.*\))\s*\:*/) {

		return $1;

    } else {

		return 0;

    }

}

# NB: assumes no mangled symbols in constraint expr.

sub CppExprFromConstraint ($)

{

    my ($constraints) = @_;

	return $constraints if ($constraints =~ /\s*__cpp/);

    my $inputExpr;

    if ($constraints =~ /\s*\".*\"\s+(.*)/) {

		$inputExpr = $1;

    } else {

		Croak( "Unrecognized constraint pattern @ $lineno: $constraints");

    }

    unless ($inputExpr =~ /^\(/) {

		$inputExpr = "($inputExpr)";

    }

    my $result = "__cpp$inputExpr";

    return $result;

}

sub TranslateConstrainedInputAsmDefault ($$$$)

{

    my ($original, $asm, $constraints, $comment) = @_;

    # we make some gross assumptions here which appear to hold for the majority of 

    # our code base namely:

    # 1. there is normally only one input operand and 

    # 2. it is named 'a0'

    # This allows us to carry out the simple minded substitution seen below.

    my $cppExpr0 = CppExprFromConstraint(GetInputConstraint($constraints, 0, 0));

    $asm =~ s/\%a0/$cppExpr0/;

    if ($asm =~ /(\w+)\s+(\S+)\s*\,\s*(.+)\s*,?(.+)?/) {

	PrintCheck();

	EmitOriginal($original, "TranslateConstrainedInputAsmDefault");

	EmitAsm($1, $2, $3, $4, $comment);

    } else {

	UnrecognisedAsmWarning("TranslateConstrainedInputAsmDefault", $original);

    }

}

sub TranslateAsmDefault ($$$$)

{

    my ($original, $asm, $constraints, $comment) = @_;

    if ($constraints) {

		TranslateConstrainedInputAsmDefault($original, $asm, $constraints, $comment);

    } elsif (@_[1] =~ /(\w+)\s+([^\,]+)\s*\,\s*([^\,]+)\s*,?(.+)?/) {

		my $opcode = uc $1;

		my $op1 = $2;

		my $op2 = $3;

		my $op3 = $4;

		# deal with hand introduced labels that correspond to a mangled C++ name

		if ($op2 =~ /\s*\[[^\,]+\,\s*\#([^\-]+)/) {

			my $adr = $1;

			my $pattern = quotemeta($adr);

			my $unmangledAdr = Unmangle($adr);

			$op2 =~ s/$adr/$unmangledAdr/i unless $unmangledAdr =~ /$pattern/;

		}

		if ($opcode =~ /ldr/i) {

			if ($op2 =~ /^(\d+)([fFbB])/) {

				my $id = $1;

				my $dir = uc $2;

				$op2 = "%$dir$id";

			} 

		}

		# rename obsolete shift ASL -> LSL

		if ($op3 =~ /([^\,]*)\,\s*asl (.*)/i) {

			$op3 = "$1, lsl $2";

		}

		# deal with the likes of #___2PP.KernCSLocked-.-8

		if ($op3 =~ /([^\-\s]\.[^\s\-])/ ) {

			my $s = "$1";

			my $p = quotemeta($1);

			$s =~ s/\./\_/;

			$op3 =~ s/$p/$s/;

		}

		PrintCheck();

		EmitOriginal ($original, "TranslateAsmDefault");

		EmitAsm($opcode, $op1, $op2, $op3, $comment);

    } else {

		UnrecognisedAsmWarning("TranslateAsmDefault", $original);

    }

}

# Work around 'feature' in embedded assembler stemming from the fact that

# 'and' is both asm and a C++ keyword.

sub TranslateConstrainedAnd ($$$$)

{

    my ($original, $asm, $constraints, $comment) = @_;

    # we make some gross assumptions here which appear to hold for the majority of 

    # our code base namely:

    # 1. there is normally only one input operand and 

    # 2. it is named 'a0'

    # This allows us to carry out the simple minded substitution seen below.

    my $cppExpr0 = CppExprFromConstraint(GetInputConstraint($constraints, 0, 0));

	$asm =~ s/\%a0/$cppExpr0/;

    if ($asm =~ /(\w+)\s+(.+)\s*\,\s*(.+)\s*,?(.+)?/) {

	my $opcode = uc $1;

	my $op1 = $2;

	my $op2 = $3;

	my $op3 = $4;

		# rename obsolete shift ASL -> LSL

		if ($op3 =~ /([^\,]*)\,\s*asl (.*)/) {

			$op3 = "$1, lsl $2";

		}

		PrintCheck();