#!/usr/local/bin/perl
#
#  add_line_directive
#
#     add c line directive 
#          to 
#     Small Eiffel generated C-code 
#
#----------------------------------------------------------------------------- 
#    History
# 	Vers	 Date		Coder		Description
# 	00-00	May 15,1997	Masato Mogaki	first version
# 	00-01	Aug 28,1997	Masato Mogaki	for -0.85
#----------------------------------------------------------------------------- 
# 
$remove_rs = 1;
$remove_ci = 1;
$use_gc = 0;

@c = ();
@h = ();

for ($i=0; $i<=$#ARGV;$i++) {   # collect options and source file names.
    $s = $ARGV[$i];
    if($s =~ /\.c$/) {
	push(@c,$s);
    } elsif($s =~ /\.h$/) {
	push(@h,$s);
    } elsif($s eq "-gc") {
	$use_gc = 1;
    } elsif($s eq "-ci") {
	$remove_ci = 0;
    } elsif($s eq "-rs") {
	$remove_rs = 0;
    }
}
#
# get class inheritance from mangle comment in *.h
# most deferred classes are not defined here.
# we have to find them from the other resource.
# Possible candidate is Xnnn routine.
#
foreach $s (@h) {
    open(IN,$s);
    $mangle = 0;
    while(<IN>) {
	
	if($mangle) {
	    if(/Mangling Table End/) {
		last;
	    } elsif(/[AD]\s+\d+\s*T(\d+)\s*[RE] ([0-9_A-Z]+)(\[[0-9_A-Z,]+\])? ([0-9,]+)/) {

		$c = $1;
		$n = $2;
		#$g = $3;
		$d = $4;
		$class_name[$c] = $n;
		$decendants[$c] = $d;
		@dec = split(',',$decendants[$c]);
		shift @dec;  #first one ins self.
		foreach $d (@dec) {
		    $ancestors[$d] .= ",$c";
		}
	    }
	} elsif(/Mangling Table Start/) {
	    $mangle=1;
	}
    }
}

# Make @ancestors from @decendants.
#
for ($i=0;$i<=$#ancestors;$i++) {

    $ans = $ancestors[$i];
    $ans =~ s/^,//;
    if($ans =~ /,/) {
	@ans = split(',',$ans); # sort it by specific order.
	@ans = sort {($decendants[$b] =~ /\b$a\b/)?-1:1;} @ans;
	$ancestors[$i] = join(',',@ans);
    } else {
	$ancestors[$i] = $ans;
    }
}
#find eiffel souce file name from line like  p[123]="./test.e";
#and class name from                         g[123]="TEST";
#             
foreach $s (@c) {
    open(IN,$s);
    $se_init = 0;
    while(<IN>) {
	if($se_init) {
	    if(/^p\[(\d+)\]="(.*)";/) {
		$src_name[$1] = $2;
	    }elsif(/^p\[(\d+)\]=p\[(\d+)\];/) {
		$src_name[$1] = $src_name[$2];
	    }elsif(/^g\[(\d+)\]="(.*)";/) {
		$class_name[$1]=$2;
	    }elsif(/^g\[(\d+)\]=g\[(\d+)\];/) {
		$class_name[$1]=$class_name[$2];
	    }
	} elsif(/^void se_initialize/) {
	    $se_init = 1;
	}
    }
    close(IN);
}

# Scan Eiffel sources and register 
# the starting line number of each feature.
#

foreach $src_name(@src_name) {
    if(!$checked{$src_name}) {
	$checked{$src_name}=1;
	&scan_e_src($src_name);
    }
}
#
# convert header file.
# change prototype of selector routine X\d+\w+.
# 
foreach $s (@h) {
    $o = "B/$s";
    $t = "C/$s";
    if(system("cmp -s $s $o")) { # $s is changed 
	print STDERR "$s is changed\n";
	rename($s,$o);
	open(IN,$o);
	open(OUT,">$t");
	&convert_h;
    } else {
	unlink($s);
    }
}
#
# convert c source.
#  remove runtime trace routine like rs_XXX
#  add line directive #line NN "source.e"
#
foreach $s (@c) {
    $o = "B/$s";
    $t = "C/$s";
    if(system("cmp -s $s $o")) { # $s is changed 
	print STDERR "$s is changed\n";
	rename($s,$o);
	open(IN,$o);
	open(OUT,">$t");
	&convert_c;
    } else {
	unlink($s);
    }
}

sub convert_h {
    while(<IN>) {
	if($remove_ci) {
	    s/(X\d+\w+).int l,int c,int f, /$1\(/;
	    if(/^T0\*ci/) {next;}
	    if(/^T0\*vc/) {next;}
	}
	print OUT $_;
    }
    close IN;
    if($use_gc) {
	print OUT "#include <gc.h>\n";
	print OUT "#define malloc(_n) GC_malloc(_n)\n";
	print OUT "#define calloc(_m,_n) GC_malloc((_m)*(_n))\n";
	print OUT "#define realloc(_p,_n) GC_realloc(_p,_n)\n";
	print OUT "#define free(_p) GC_free(_p)\n";
    }
    if($remove_ci) {
	print OUT "#define ci(_id,_o,_l,_c,_f)	(_o)\n";
	print OUT "#define vc(_o,_l,_c,_f) ((T0*)(_o))\n";
	print OUT "#define error1(_m,_l,_c,_f)\n"; 
	print OUT "#define error2(_o,_l,_c,_f)\n"; 
    }
    close OUT;
}


sub convert_c {
    $in_routine = 0;
    $directive_printed=0;
    $i_line = 0;
    $o_line = 1;
    while(<IN>) {
	s/\/\*\w+\*\///g;
	s/\)exit\(0\)/)abort()/; # to be caught by gdb
	s/\bexit\(1\)/abort()/;  # to be caught by gdb
	if($remove_rs) {
	    s/rs-=8;//g;
	    s/([^ ])rs_pop_int\b/$1/g;
	}
	if($remove_ci) {
	    s/(X\d+\w+)\(\d+,\d+,\d+,/$1\(/g;
	    s/(X\d+\w+).int l,int c,int f, /$1\(/;
	}
	$i_line++;
	if(!$in_routine) {
	    if($remove_ci &&/^void error1\(char\*m,int l,int c,int f\)\{/) {
		# remove definitions of error1 and error2.
		while(<IN>) { 
		    if(/^void evobt/) {last;}
		}
	    }
	    if($remove_rs) {
		s/rs_pPOS\(tag_pos_[123456],(\d+),(\d+),(\d+)\)[,;]//;
	    }
	    if(/^(T0\*|T\d+|int|char|void|void\*) r(\d+)(\w+)\(.*\)\{$/) {    # feature begin.
		chop;
		$cl = $2;
		$fn = $3;
		$head_line_directive = &source_line_directive($cl,$fn);
		$directive_printed=0;
		$in_routine++;
		$head = $_;
		@body = ();
		%name_map=();
	    } else {
		print OUT $_;
		$o_line++;
		if($directive_printed && (/return/ || /^\}$/)) {
		   $directive_printed=0;
		   print OUT "\#line $o_line \"$o\"\n";
		   $o_line++;
	       }
	    }
	} else {
	    chop;
	    if(/^\};/) {
		push(@body,'};');
		$_ = $';
	    }
	    $l = "";
	    $e_pos = 0;
	    while(/rs_pPOS\(tag_pos_[123456],(\d+),(\d+),(\d+)\)[,;]/) {
		$e_pos = $1;
		$e_src = "\"$src_name[$3]\"";
		
		$l .= $`;
		if(!$remove_rs) { $l .= $0;}
		$_ = $';
	    }
	    if($e_pos) {
		push(@body,"#line $e_pos $e_src");
		$directive_printed = 1;
		$_ = $l . $_;
	    }
	    if(/^rs_link/) {
		$rest = $';
		if(!$remove_rs) {push(@body,$_);}
		if(!$head_line_directive) {
		    $fn = "";
		    if($rest =~ /\(\"(\w+) of (\w+)\"/) {
			$fn = $1;
			$class = $2;
		    } elsif($rest =~ /\(\"(infix|prefix) (.*) of (\w+)\"/) {
			$fn = "$1 \"2\"";
			$class = $2;
		    }
		    if($fn) {
			$head_line_directive = $feature_position{$class,$fn};
		    }
		}
	    } elsif(/^rs_p[A-Z][A-Z][A-Z]\((\(void\*\*\))?&(a\d+),"(\w+)"\);/) {
		$name_map{$2} = "_$3"; # _ is added for consistency with other local var.
		if(!$remove_rs) {push(@body,$_);}
	    } elsif($remove_rs && /^rs_p[A-Z][A-Z][A-Z]/) {
		#simply ignore it.
	    } elsif(/rs_unlink\(\);/) {
		if($remove_rs) {
		    s/rs_unlink\(\);//;
		}
		if($_) {
		    push(@body,$_);
		}
		$in_routine = 0;
		if($head_line_directive) {
		    $directive_printed++;
		    print OUT "$head_line_directive\n";
		}
		$head = &replace_name($head);
		print OUT "$head\n";
		$o_line++;
		#_______ print body begin
		@body = &merge_lines(@body);
		$i_line=0;
		$i_file="";
		while(@body) {
		    $l = shift(@body);
		    if($l =~ /\#line (\d+) (\".*\")/) {
			# do not print if synclonized 
			if($1 == $i_line && $i_file eq $2) {next;}
			else {
			    $i_line = $1;
			    $i_file = $2;
			}
		    } else {
			$l = &replace_name($l);
			$i_line++;
		    }
		    print OUT "$l\n";
		    $o_line++;
		}
		#_______ print body end
	    } elsif($_) {
		push(@body,$_);
	    }
	}
    }
    close(OUT);
    close(IN);
}
# replace name of local variables.
sub replace_name {
    my ($line) = @_;
    my($n,$v);

    if(!/^\#/) {
	foreach $v (keys %name_map) {
	    $n = $name_map{$v};
	    $line =~ s/\b$v\b/$n/g;
	}
    } 
    return $line;
}

# merge lines to synclonize with line directive.
sub merge_lines {
    my @lines = @_;
    my (@merged,@wl,$l,$ll,$last_lno,$lno);
    @merged = ();
    @wl = ();
    $last_lno = 0;
    while(@lines) {
	$l = shift(@lines);
	if($l =~ /^\{T\d+\*n;$/) {
	    $ll = '';
	    while($l && $l !~ /\}$/) {
		$ll .= $l;
		$l = shift(@lines);
	    }
	    $l = $ll . $l;
	# line like     if(NULL!=(C->_abc))switch(((T0*)C->_abc)->id) {
	} elsif($l =~ /^if.NULL!=.C->_\w+..switch...T0..C->_\w+.->id. \{$/) {
	    $ll = pop(@wl);
	    do {
		$ll .= $l;
		$l = shift(@lines);
	    } until(!$l || ($l =~ /^\};$/));
	    $ll .= $l;
	    push(@wl,$ll);
	    $l = shift(@lines);
	} elsif($l =~ /^if.NULL!=.\w+..switch...T0\*.\w+.->id. \{$/) {
	    $ll = pop(@wl);
	    do {
		$ll .= $l;
		$l = shift(@lines);
	    } until(!$l || ($l =~ /^\};$/));
	    $ll .= $l;
	    push(@wl,$ll);
	    $l = shift(@lines);
	} elsif($l =~ /^ ?else/) {
	    $ll = pop(@wl);
	    $l = $ll.$l;
	}
	push(@wl,$l);
	if($l =~ /\#line (\d+)/) {
	    $lno = $1;
	    if(!$last_lno) {
		@merged = @wl;
		$last_lno = $lno;
	    } else {
		@wl = &merge_into($lno-$last_lno,@wl);
		@merged = (@merged,@wl);
	    }
	    @wl = ();
	}
    }
    return (@merged,@wl);
}

sub merge_into {
    my($lno,@lines) = @_;
    my($lm,$ln);
    if($#lines <= $lno) {
	return @lines;
    } else {
	while ($#lines <= $lno) {
	    $ln = pop(@lines);
	    $lm = pop(@lines);
	    push (@lines, $lm.$ln);
	}
	return @lines;
    }
}
# 
# register feature's definition line.
sub scan_e_src {
    my($src_name)=@_;
    open(IN,$src_name);
    my($class,$l);
    $l=0;
    while(<IN>) {
	$l++;
	if(/^[ \ta-z]*class\s+([0-9_A-Z]+)/) {
	    $class=$1;
	}
	if(/^\s*frozen\s+(\w+).*\sis\s*$/) {
	    $feature_position{$class,$1}="\#line $l \"$src_name\"";
	} elsif(/^\s*((infix|prefix) \".*\").* \sis\s*$/) {
	    $feature_position{$class,$1}="\#line $l \"$src_name\"";
	} elsif(/^\s*(\w+).*\sis\s*$/) {
	    $feature_position{$class,$1}="\#line $l \"$src_name\"";
	}
    }
}
# 
# recall feature's definition line.
#
sub source_line_directive {
    my($cl,$fn)= @_;
    my($c,$class,$fp);
    $class = $class_name[$cl];
    $fp =  $feature_position{$class,$fn};
    if($fp) { 
	return "$fp";
    } else {
	foreach $c (split(',', $ancestors[$cl])) {
	    $class = $class_name[$c];
	    $fp =  $feature_position{$class,$fn};
	    if($fp) { 
		return "$fp";
	    }	    
	}
    }
    return "";
}
#-------- add_line_directive END 

