#!/usr/bin/perl

my $ws = "[ \t\n]";

sub addid {
	my $l = shift;
	my $id = shift;
	unless (grep /^$T$id$/, @$l) {
		#print STDERR "adding new id: $T - $id\n";
		push @$l, "$T$id"
	}
}

#sub meth_add {
#	my $l = shift;
#	my $o = shift;
#	my $m = shift;
#	my $argl = shift;
#	my %meth;
#}

sub meth {
	my $in = shift;
	$_ = $in; my %msg; my %fwd; my %tab;
	while (s/CO_METH_INI$ws*\((.*?),(.*?)(?:,(.*?)|)\)//) {
		my $o = $1;
		my $m = $2;
		my $argl = $3;
		$o =~ s/^$ws+|$ws+$//g;
		$m =~ s/^$ws+|$ws+$//g;
		my $def = "#define CO_METH_INI_${o}_$m ";
		#print STDERR "${o}_$m ($argl)\n";
		my @arg = split /,/, $argl;
		for (@arg) {
			s/^$ws+|$ws+$//g;
			my $t = $_;
			$t =~ s/[a-zA-Z_@]+$//;
			$t =~ s/^$ws+|$ws+$//g;
			#print STDERR "arg: $_ = va_arg (ap, $t);\n";
			$def .= "$_ = va_arg (ap, $t); ";
		}
		print OUT "$def\n";
		$msg{$o} = "\tCO_MH_BEGIN;\n" unless ($msg{$o});
		$msg{$o} .= "\tCO_MH_CASE (message, $m) {\n\t\treturn "
			."${o}_$m (this, self, message, ap);\n\t}\n";
		$fwd{$o} .= "co_v ${o}_$m ($o this, co self, co_id_t message, va_list"
			." ap);\n";
		$tab{$o} .= "\tco_meth_add (o -> __co_meth_ar, COM ($m),"
			." (co_msg_h) ${o}_$m);\n";
	}
	my $o;
	while (s/(CO_OBJECT|CO_ATTR)$ws*\((.*?)\)//) {
		my $match = $1;
		if ($match eq "CO_OBJECT") {
			$o = $2;
		} else {
			my ($t, $m) = split /,/, $2;
			#my $m = $2;
			$o =~ s/^$ws+|$ws+$//g;
			$t =~ s/^$ws+|$ws+$//g;
			$m =~ s/^$ws+|$ws+$//g;
			$msg{$o} = "\tCO_MH_BEGIN;\n" unless ($msg{$o});
			$msg{$o} .= "\tCO_MH_CASE (message, $m) {\n\t\tCO_RETURN (${t}_p, "
				."&(this -> $m));\n\t}\n";
			#$fwd{$o} .= "co_v ${o}_$m (co this, co self, co_id_t message, va_list"
			#	." ap);\n";
			$tab{$o} .= "\tco_meth_add (o -> __co_meth_ar, COM ($m),"
				." (co_msg_h) ${o}_$m);\n";
			$fwd{$o} .= "co_v ${o}_$m ($o this, co self, co_id_t message, va_list"
				." ap)\n{\n\tCO_RETURN (${t}_p, &(this -> $m));\n}\n";
		}
	}
	for (keys %msg) {
		print OUT "\n";
		print OUT $fwd{$_}."\n";
		print OUT "/* static co_v ${_}_msg (co __this, co self, co_id_t"
			." message, va_list ap) {\n";
		print OUT "$_ this = __this;\n";
		print OUT $msg{$_};
		if ($in =~ /CO_MSG_DEFAULT$ws*\($ws*$_$ws*,(.*?)\)/) {
			print OUT "\tCO_MH_DEFAULT(message) {\n\t\treturn CO_D_V "
				."($1, self, message, ap);\n\t}\n";
		}
		print OUT "\tCO_RETURN (int, 0xBAD0);\n";
		print OUT "} */\n";
		print OUT "\nstatic void ${_}_meth_ar_init (co object) {\n";
		print OUT "\tco_o_head_full o = object;\n";
		print OUT "\to -> __co_meth_ar = co_meth_array_new ();\n";
		print OUT "\tco_meth_add (o -> __co_meth_ar, COM (has_method),"
			." co_has_method);\n";
		print OUT $tab{$_};
		print OUT "}\n\n";
	}
	#return \%msg;
}

sub append {
	$_ = shift;
	my $rx = shift;
	my $l = shift;
	my $T = shift;
	while (s/$rx//) {
		my $id = $1;
		$id =~ s/^$ws+|$ws+$//g;
		&addid ($l, "$T$id");
	}
}

sub dump2 {
	my $templ = shift;
	my $lst = shift;
	for (@$lst) {
		/(.)(.*)/;
		my $T = $1;
		my $id = $2;
		my $l = $$templ{$T};
		$l =~ s/#ID#/$id/g;
		#print STDERR "$l";
		print OUT $l;
	}
}

sub erruse {
	print STDERR "usage error!\n";
	exit (1);
}

my $decls = {
	"M" => "static co_id_t __co_id_message_#ID#;\n",
	"P" => "static co_id_t __co_id_property_#ID#;\n",
	"E" => "static co_id_t __co_id_event_#ID#;\n",
	"X" => "static co_id_t __co_id_exception_#ID#;\n",
	"T" => "static co_id_t __co_id_type_#ID#;\n"
};
my $defs = {
	"M" => "\tCOM (#ID#) = co_id_init (super -> id_msg, \"#ID#\");\n",
	"P" => "\tCOP (#ID#) = co_id_init (super -> id_prop, \"#ID#\");\n",
	"E" => "\tCOE (#ID#) = co_id_init (super -> id_event, \"#ID#\");\n",
	"X" => "\tCOX_ID (#ID#) = co_id_init (super -> id_exception, \"#ID#\");\n",
	"T" => "\tCOT (#ID#) = co_id_init (super -> id_type, \"#ID#\");\n",
};

use Digest::SHA1;

my $cmd = "erruse";
my @args;
my $out = "-";
my $suff = ".cometa";
my $check = 1;
my $ahash = 1;
my $header = "";

while (scalar @ARGV) {
	$_ = shift @ARGV;
	#print STDERR "'$_'\n";
	if ($_ eq "-m") {
		&erruse if ($mode);
		$cmd = "meta";
		push @args, (shift @ARGV);
	} elsif ($_ eq "-i") {
		my @files;
		while (($_ = shift @ARGV) !~ /^-/) {
			push @args, $_;
		}
		unshift @ARGV, $_;
		$cmd = "init"
	} elsif ($_ eq "-o") {
		$out = shift @ARGV;
		#print STDERR "out: $out\n";
	} elsif ($_ eq "-s") {
		$suff = shift @ARGV;
	} elsif ($_ eq "-h") {
		$header = shift @ARGV;
	} elsif ($_ eq "-H") {
		$ahash = 0;
	} elsif ($_ eq "-f") {
		$check = 0;
	} else {
		&erruse;
	}
}

&$cmd (@args);

sub getf {
	my $file = shift;
	my $in;
	open (IN, $file);
	$in .= $_ while (<IN>);
	close (IN);
	if ($header) {
		open (IN, $header);
		$in .= $_ while (<IN>);
		close (IN);
	}
	$in =~ s!(\#if 0\n).*?(\#endif /\* 0 \*/\n)!!gsm;
	$in =~ s/\/\*.*?\*\///gsm;
	$in =~ s/\/\/.*?$//gsm;
	return $in;
}

sub meta {
	my $file = shift;
	my $in = &getf ($file);
	#print STDERR "out: \">$out\"\n";
	open (OUT, ">$out");

	my $hash = &Digest::SHA1::sha1_hex ($in);

	my @list;
	&append ($in, qr/\bCO_CNT$ws*\(.*?,(.*?),/, \@list, "E");
	&append ($in, qr/\bCO_CNT$ws*\(.*?,.*?,.*?,(.*?)\)/, \@list, "M");
	&append ($in, qr/\bCO_M$ws*\(.*?,(.*?)[,)]/, \@list, "M");
	#&append ($in, qr/CO_ATTR$ws*\(.*?,(.*?)[,)]/, \@list, "M");
	&append ($in, qr/\bCO_ATTR$ws*\(.*?,(.*?)[,)]/, \@list, "M");
	&append ($in, qr/\bCO_METH$ws*\(.*?,(.*?)[,)]/, \@list, "M");
	&append ($in, qr/\bCO_METH$ws*\((.*?),/, \@list, "T");
	&append ($in, qr/\bCO_OBJECT$ws*\((.*?)\)/, \@list, "T");
	&append ($in, qr/\bCO_EV$ws*\(.*?,(.*?)[,)]/, \@list, "E");
	&append ($in, qr/\bCO_P$ws*\(.*?,(.*?)[,)]/, \@list, "P");
	&append ($in, qr/\bCO_PH_RET$ws*\(.*?,(.*?)[,)]/, \@list, "P");
	&append ($in, qr/\bCO_PH_RET_C$ws*\(.*?,(.*?)[,)]/, \@list, "P");
	&append ($in, qr/\bCO_MH_CASE$ws*\(.*?,(.*?)[,)]/, \@list, "M");
	&append ($in, qr/\bCOM$ws*\((.*?)\)/, \@list, "M");
	&append ($in, qr/\bCOE$ws*\((.*?)\)/, \@list, "E");
	&append ($in, qr/\bCOP$ws*\((.*?)\)/, \@list, "P");
	&append ($in, qr/\bCOX_THROW$ws*\((.*?)\)/, \@list, "X");
	&append ($in, qr/\bCOX_ID$ws*\((.*?)\)/, \@list, "X");
	&append ($in, qr/\bCO_BLESS(?:_M|_MP|_0|)$ws*\(.*?,(.*?)[,)]/, \@list, "T");
	if ($in =~ /#include[ \t]*[<"].*?co_conv.h[">]/) {
		&append ($in, qr/\bP$ws*\(.*?,(.*?)[,)]/, \@list, "P");
		&append ($in, qr/\bM$ws*\(.*?,(.*?)[,)]/, \@list, "M");
		&append ($in, qr/\bE$ws*\(.*?,(.*?)[,)]/, \@list, "E");
	}
	&addid (\@list, "Mhas_method"); # FIXME?

	print OUT "#include <co_object.h>\n";
	print OUT "#include <co_super.h>\n";
	print OUT "#include <co_type.h>\n";
	&dump2 ($decls, \@list);
	&meth ($in);

	$file =~ s#.*?/##g;
	$file =~ s/\./_/g;

	if ($ahash) {
		$hash = "_$hash";
	} else {
		$hash = "";
	}

	print OUT "void __co_mod_init_${file}$hash (co_super super);\n";
	print OUT "void __co_mod_init_${file}$hash (co_super super) {\n";
	&dump2 ($defs, \@list);
	print OUT "}\n";
	close OUT;
}

sub init {
	my %ifcs;
	open (OUT, ">$out");
	for (@_) {
		my $f = $_;
		my $in = &getf ($_);
		if ($check) {
			my $b = $f;
			$b =~ s/^.*\///;
			$b =~ s/\..*//;
			#print STDERR "checking: ($f) $b$suff\n";
			next unless ($in =~ /^#include$ws*[<"]$b$suff[">]/sm);
		}
		$f =~ s#.*?/##g;
		$f =~ s/\./_/g;
		$ifcs{$f} = &Digest::SHA1::sha1_hex ($in);
	}
	print OUT "#include <co_super.h>\n";
	for (keys %ifcs) {
		print OUT "void __co_mod_init_${_}_$ifcs{$_} (co);\n";
	}
	print OUT "void __co_mod_init (co_super super) {\n";
	for (keys %ifcs) {
		print OUT "__co_mod_init_${_}_$ifcs{$_} (super);\n";
	}
	print OUT "}\n";
	close OUT;
}

__END__
