#!/usr/bin/env perl

###############################################################################
$[    = 1 ;
$prog = $0;
($tmp = rindex ($prog, "/")) && ($prog = substr ($prog, $tmp + 1));
###############################################################################

sub fatal {
    print STDERR ($prog, ": fatal: ", @_, "\n");
    exit (1);
}

sub ifatal {
    print STDERR ($prog, ": fatal: ", $lexer'file, ": ", $lexer'line_num, ": ",
		  @_, "\n");
    exit (1);
}

###############################################################################
### Lexical analyser:

$lexer'file		= undef;
$lexer'line_num		= undef;
$lexer'line		= undef;

###############################################################################

$TOK_EOF		= 0;
$TOK_OPEN_BRACE		= 1;
$TOK_CLOSE_BRACE	= 2;
$TOK_COMMA		= 3;
$TOK_SEMI_COLON		= 4;
$TOK_COLON		= 5;
$TOK_STRING		= 6;
$TOK_PROGRAM		= 7;
$TOK_SEVERITY		= 8;
$TOK_HEADER		= 9;
$TOK_C_HEADER		= 10;
$TOK_OPEN		= 11;
$TOK_CLOSE		= 12;

%error_severity		= (
	"info",		"ERROR_SEVERITY_INFORMATION",
	"information",	"ERROR_SEVERITY_INFORMATION",
	"warning",	"ERROR_SEVERITY_WARNING",
	"error",	"ERROR_SEVERITY_ERROR",
	"fatal",	"ERROR_SEVERITY_FATAL",
	"internal",	"ERROR_SEVERITY_INTERNAL",
);

###############################################################################

sub reset_lexer {
    local ($file) = @_;

    $lexer'file     = $file;
    $lexer'line_num = 0;
    $lexer'line     = "";
    open (INFILE, "<" . $file) ||
	&fatal ("cannot open input file '", $file, "'");
}

sub lexer'read_string {
    local ($string) = "";

    read_string: {
	(($lexer'line eq "") &&
	    (($lexer'line = <INFILE>), ($lexer'line_num ++)));
	(defined ($lexer'line)) ||
	    &ifatal ("unexpected end of file in string");

	if ($lexer'line =~ s/^([^"]*)"//) {
	    $string .= $1;
	} else {
	    $string    .= $lexer'line;
	    $lexer'line = "";
	    redo read_string;
	}
    }
    $string;
}

sub lexer'read_program {
    local ($program) = "";
    local ($index, $tmp);

    read_program: {
	(($lexer'line eq "") &&
	    (($lexer'line = <INFILE>), ($lexer'line_num ++)));
	(defined ($lexer'line)) ||
	    &ifatal ("unexpected end of file in program segment");

	if ($index = index ($lexer'line, "]\$")) {
	    $tmp        = substr ($lexer'line, 1, $index - 1);
	    $lexer'line = substr ($lexer'line, $index + 2);
	    $tmp        =~ s/^[ \t]*//;
	    $program   .= $tmp;
	} else {
	    $program   .= $lexer'line;
	    $lexer'line = "";
	    redo read_program;
	}
    }
    $program;
}

sub next_token {
    local ($token, $data);

    get_token: {
	(($lexer'line eq "") &&
	    (($lexer'line = <INFILE>), ($lexer'line_num ++)));
	(defined ($lexer'line)) || return ($TOK_EOF, 0);
	$lexer'line =~ s/^[ \t\n]*(#.*$)?\n?//;
	($lexer'line eq "") && redo get_token;

	if ($lexer'line =~ s/^{//) {
	    $token = $TOK_OPEN_BRACE;
	    $data  = 0;
	} elsif ($lexer'line =~ s/^}//) {
	    $token = $TOK_CLOSE_BRACE;
	    $data  = 0;
	} elsif ($lexer'line =~ s/^\(//) {
	    $token = $TOK_OPEN;
	    $data  = 0;
	} elsif ($lexer'line =~ s/^\)//) {
	    $token = $TOK_CLOSE;
	    $data  = 0;
	} elsif ($lexer'line =~ s/^,//) {
	    $token = $TOK_COMMA;
	    $data  = 0;
	} elsif ($lexer'line =~ s/^;//) {
	    $token = $TOK_SEMI_COLON;
	    $data  = 0;
	} elsif ($lexer'line =~ s/^://) {
	    $token = $TOK_COLON;
	    $data  = 0;
	} elsif ($lexer'line =~ s/^"//) {
	    $token = $TOK_STRING;
	    $data  = &lexer'read_string;
	} elsif ($lexer'line =~ s/^\$\[([ \t]*\n)?//) {
	    $token = $TOK_PROGRAM;
	    $data  = &lexer'read_program;
	} elsif ($lexer'line =~ s/^header\(c\)//) {
	    $token = $TOK_C_HEADER;
	    $data  = 0;
	} elsif ($lexer'line =~ s/^header\(h\)//) {
	    $token = $TOK_HEADER;
	    $data  = 0;
	} elsif ($lexer'line =~ s/^header//) {
	    $token = $TOK_HEADER;
	    $data  = 0;
	} elsif ($lexer'line =~ s/^[A-Za-z_]+//) {
	    $token = $TOK_SEVERITY;
	    $data  = $error_severity{$&};
	    defined ($data) ||
		&ifatal ("unknown error severity '", $&, "'");
	} elsif ($lexer'line =~ s/^.//) {
	    &ifatal ("illegal character '", $&, "'");
	}
    }
    ($token, $data);
}

###############################################################################
### Parser:

$error_header		= "";
$error_c_header		= "";
$error_tag_index	= 0;
$error_struct_num	= 0;
$error_tproc_num	= 0;

@error_tag_order	= ();
@error_order		= ();
@error_structures	= ();
@error_tag_procs	= ();

%error_tags		= ();
%error_tag_index	= ();
%error_severities	= ();
%error_munged_names	= ();
%error_messages		= ();
%error_client_data	= ();
%error_struct_match	= ();
%error_struct_name	= ();
%error_proc_decs	= ();
%error_proc_defs	= ();
%error_index		= ();
%error_tproc_match	= ();
%error_tproc_name	= ();

###############################################################################

sub munge_name {
    local ($name) = @_;

    $name =~ s/[^A-Za-z0-9_]/_/g;
    $name;
}

sub basename {
    local ($name) = @_;
    local ($tmp);

    ($tmp = rindex ($name, "/")) && ($name = substr ($name, $tmp + 1));
    $name;
}

sub find_tags {
    local ($mesg) = @_;
    local (%tag_names);

    while ($mesg =~ /\$\{([^\}\n]+)\}/) {
	$tag_names{$1} = 1;
	$mesg          = $';
    }
    keys (%tag_names);
}

sub indent_to {
    local ($prefix, $col) = @_;
    local ($length);

    if (($length = length ($prefix)) >= $col) {
	" ";
    } else {
	(" " x ($col - $length));
    }
}

###############################################################################

sub parse_param_list {
    local ($error, *param_types, *param_order) = @_;
    local ($token, $data, $name, $type);

    parse_param: {
	if ((($token, $data) = &next_token), ($token != $TOK_STRING)) {
	    &ifatal ("expected parameter name string");
	}
	$name = $data;
	if ((($token, $data) = &next_token), ($token != $TOK_COLON)) {
	    &ifatal ("expected ':'");
	}
	if ((($token, $data) = &next_token), ($token != $TOK_STRING)) {
	    &ifatal ("expected parameter type string");
	}
	$type = $data;
	if (defined ($param_types{$name})) {
	    &fatal ("parameter '", $name, "' already defined in error '",
		    $error, "'");
	} else {
	    $param_types{$name} = $type;
	    push (@param_order, $name);
	}
	if ((($token, $data) = &next_token), ($token == $TOK_COMMA)) {
	    redo parse_param;
	} elsif ($token != $TOK_CLOSE) {
	    &ifatal ("expected ')'");
	}
    }
}

sub parse_error_header {
    local ($severity, *tag_names, *param_types, *param_order) = @_;
    local ($token, $data, $name, $munged_name, $tmp);

    if ((($token, $data) = &next_token), ($token != $TOK_STRING)) {
	&ifatal ("expected error name string");
    }
    $name = $data;
    if (defined ($error_severities{$name})) {
	&ifatal ("error '", $name, "' is already defined");
    }
    $error_severities{$name} = $severity;
    if ((($token, $data) = &next_token), ($token == $TOK_COLON)) {
	if ((($token, $data) = &next_token), ($token != $TOK_STRING)) {
	    &ifatal ("expected error function name string");
	} elsif (($data =~ /[^A-Za-z_0-9]/) || ($data =~ /^[0-9]/)) {
	    &ifatal ("illegal error function name string '", $data, "'");
	}
	$munged_name = $data;
	($token, $data) = &next_token;
    } else {
	$munged_name = &munge_name ($name);
    }
    if (defined ($tmp = $error_munged_names{$munged_name})) {
	&ifatal ("error '", $name, "' clashes with error '", $tmp, "'");
    }
    $error_munged_names{$munged_name} = $name;
    if ($token == $TOK_OPEN) {
	&parse_param_list ($error, *param_types, *param_order);
	($token, $data) = &next_token;
    }
    if ($token != $TOK_OPEN_BRACE) {
	&ifatal ("expected '{'");
    }
    if ((($token, $data) = &next_token), ($token != $TOK_STRING)) {
	&ifatal ("expected error message text string");
    }
    $error_messages{$name} = $data;
    @tag_names = &find_tags ($data);
    ($name, $munged_name);
}

sub parse_error_tag {
    local ($name, *tag_types, *tag_names, *tag_mnames, *tag_code, *tag_init,
	   *tag_order, *param_types) = @_;
    local ($token, $data, $tag_name, $tag_type, $tag_code, $tag_init);
    local ($munged_name, $tmp);

    if ((($token, $data) = &next_token), ($token != $TOK_OPEN_BRACE)) {
	&ifatal ("expected '{'");
    }
    if ((($token, $data) = &next_token), ($token != $TOK_STRING)) {
	&ifatal ("expected tag name");
    }
    $tag_name    = $data;
    $munged_name = &munge_name ($tag_name);
    if (defined ($tag_types{$tag_name})) {
	&ifatal ("tag '", $tag_name, "' defined twice in error '", $name, "'");
    } elsif (defined ($tmp = $tag_mnames{$munged_name})) {
	&ifatal ("tag '", $tag_name, "' clashes with tag '", $tmp,
		 "' in error '", $name, "'");
    } elsif (defined ($tmp = $param_types{$munged_name})) {
	&ifatal ("tag '", $tag_name, "' clashes with parameter '",
		 $munged_name, "' in error '", $name, "'");
    }
    if ((($token, $data) = &next_token), ($token != $TOK_COLON)) {
	&ifatal ("expected ':'");
    }
    if ((($token, $data) = &next_token), ($token != $TOK_STRING)) {
	&ifatal ("expected tag type string");
    }
    $tag_type = $data;
    if ((($token, $data) = &next_token), ($token != $TOK_PROGRAM)) {
	&ifatal ("expected tag handling code");
    }
    $tag_code = $data;
    if ((($token, $data) = &next_token), ($token == $TOK_PROGRAM)) {
	$tag_init = $data;
	($token, $data) = &next_token;
    }
    if ($token != $TOK_CLOSE_BRACE) {
	&ifatal ("expected '}'");
    }
    if (!defined ($error_tags{$tag_name})) {
	$error_tags{$tag_name} = $error_tag_index ++;
	push (@error_tag_order, $tag_name);
    }
    $tag_types{$tag_name}     = $tag_type;
    $tag_mnames{$munged_name} = $tag_name;
    $tag_names{$tag_name}     = $munged_name;
    $tag_code{$tag_name}      = $tag_code;
    if (defined ($tag_init)) {
	$tag_init{$tag_name}  = $tag_init;
    }
    push (@tag_order, $tag_name);
}

sub build_structure {
    local ($error, *tag_types, *tag_names, *tag_order) = @_;
    local ($header, $def, $i, $tag, $type, $name, $indent, $tmp);

    if ($#tag_order) {
	$def = (" {\n");
	for ($i = 1; $i <= $#tag_order; $i ++) {
	    $tag    = $tag_order [$i];
	    $type   = $tag_types{$tag};
	    $name   = $tag_names{$tag};
	    $indent = &indent_to ("    " . $type, 30);
	    $def   .= ("    " . $type . $indent . $name . ";\n");
	}
	$def .= "};\n";
	if (defined ($tmp = $error_struct_match{$def})) {
	    $error_struct_name{$error} = $tmp;
	} else {
	    $header = sprintf ("struct ES_%05d", $error_struct_num ++);
	    $error_struct_match{$def}  = $header;
	    $error_struct_name{$error} = $header;
	    push (@error_structures, ($header . $def));
	}
    }
}

sub build_tag_proc {
    local ($error, *tag_types, *tag_names, *tag_order, *tag_code) = @_;
    local ($header, $def, $i, $tag, $code, $index, $name, $struct);

    if (defined ($struct = $error_struct_name{$error})) {
	$def    = ("{\n    " . $struct . " *closure = (" . $struct .
		   " *)gclosure;\n\n");
	for ($i = 1; $i <= $#tag_order; $i ++) {
	    $tag   = $tag_order [$i];
	    $name  = $tag_names{$tag};
	    $code  = $tag_code{$tag};
	    $index = $error_tags{$tag};
	    if ($i == 1) {
		$def .= ("    if (tag == ET[" . $index . "].tag) {\n");
	    } else {
		$def .= ("    } else if (tag == ET[" . $index . "].tag) {\n");
	    }
	    $def .= $code;
	}
	$def .= "    }\n}\n";
    } else {
	$def = ("{\n    UNUSED(ostream);\n" . "    UNUSED(tag);\n" .
		"    UNUSED(gclosure);\n}\n");
    }
    if (defined ($tmp = $error_tproc_match{$def})) {
	$error_tproc_name{$error} = $tmp;
    } else {
	$name   = sprintf ("ET_%05d", $error_tproc_num ++);
	$header = ("static void\n" . $name .
		   "(OStreamP ostream, ETagP tag, GenericP gclosure)\n");
	$error_tproc_match{$def}  = $name;
	$error_tproc_name{$error} = $name;
	push (@error_tag_procs, ($header . $def));
    }
}

sub build_proc_dec {
    local ($error, $munged_name, *tag_types, *tag_names, *tag_init, *tag_order,
	   *param_types, *param_order) = @_;
    local ($dec, $i, $tag, $type, $sep, $args, $param);

    $sep  = undef;
    $dec  = ("extern void E_" . $munged_name . "(");
    $args = 0;
    for ($i = 1; $i <= $#param_order; $i ++) {
	$param = $param_order [$i];
	$type  = $param_types{$param};
	if (defined ($sep)) {
	    $dec .= $sep;
	}
	$dec .= $type;
	$sep  = ", ";
	$args ++;
    }
    for ($i = 1; $i <= $#tag_order; $i ++) {
	$tag  = $tag_order [$i];
	$type = $tag_types{$tag};
	if (!defined ($tag_init{$tag})) {
	    if (defined ($sep)) {
		$dec .= $sep;
	    }
	    $dec .= $type;
	    $sep  = ", ";
	    $args ++;
	}
    }
    if ($args == 0) {
	$dec .= "void";
    }
    $error_proc_decs{$error} = ($dec . ");\n");
}

sub build_proc_def {
    local ($error, $munged_name, *tag_types, *tag_names, *tag_init,
	   *tag_order, *param_types, *param_order) = @_;
    local ($def, $tmp_def, $i, $tag, $type, $name, $col, $sep, $init, $args);
    local ($param, $struct, $closure);

    $sep     = undef;
    $def     = ("void\nE_" . $munged_name);
    $tmp_def = "";
    $col     = (length ($munged_name) + 2);
    $args    = 0;
    $sep     = undef;
    for ($i = 1; $i <= $#param_order; $i ++) {
	$param = $param_order [$i];
	if (defined ($sep)) {
	    $tmp_def .= $sep;
	}
	$args ++;
    }
    for ($i = 1; $i <= $#tag_order; $i ++) {
	$tag  = $tag_order [$i];
	$name = $tag_names{$tag};
	if (!defined ($tag_init{$tag})) {
	    if (defined ($sep)) {
		$tmp_def .= $sep;
	    }
	    $args ++;
	}
    }
    $tmp_def .= "(";
    $col     += 1;

    if ($args == 0) {
	$def .= "(void)\n";
    } else {
	$def .= $tmp_def;
	$sep  = undef;
	for ($i = 1; $i <= $#param_order; $i ++) {
	    $param = $param_order [$i];
	    $type  = $param_types{$param};
	    if (defined ($sep)) {
		$def .= $sep;
	    }
	    $def .= ($type . " " . $param);
	    $sep  = (",\n" . &indent_to ("", $col));
	}
	for ($i = 1; $i <= $#tag_order; $i ++) {
	    $tag  = $tag_order [$i];
	    $name = $tag_names{$tag};
	    $type = $tag_types{$tag};
	    if (!defined ($tag_init{$tag})) {
		if (defined ($sep)) {
		    $def .= $sep;
		}
		if ((length($def) + length($type) + length($name) + 1) > 78) {
			$def .= ($type . " " . $name);
#		$sep  = (",\n" . &indent_to ("", $col));
			$sep = (", ");
		} else {
			$sep = (",\n" . &indent_to("", $col));
			$def .= ($type . " " . $name);
		}
	    }
	}
	$def .= ")\n";
    }
    $def .= "{\n";
    if (defined ($struct = $error_struct_name{$error})) {
	$def .= ("    " . $struct . " closure;\n\n");
	for ($i = 1; $i <= $#tag_order; $i ++) {
	    $tag  = $tag_order [$i];
	    $name = $tag_names{$tag};
	    if (defined ($init = $tag_init{$tag})) {
		$def .= $init;
	    } else {
		$def .= ("    closure." . $name . " = " . $name . ";\n");
	    }
	}
	$closure = "(GenericP)&closure";
    } else {
	$closure = "NIL(GenericP)";
    }
    $def .= ("    error_call_init_proc();\n    error_report(EE[" .
	     $error_index{$error} . "].error, " . $error_tproc_name{$error} .
	     ", " . $closure . ");\n");
    if (($error_severities{$error} eq "ERROR_SEVERITY_FATAL") ||
	($error_severities{$error} eq "ERROR_SEVERITY_INTERNAL")) {
	$def .= "    UNREACHED;\n";
    }
    $error_proc_defs{$error} = ($def . "}\n");
}

sub parse_error {
    local ($severity) = @_;
    local ($token, $data, $name, $munged_name);
    local (%tag_types, %tag_names, %tag_mnames, %tag_code, %tag_init,
	   @tag_order, @used_tags, $tag, %param_types, @param_order);

    ($name, $munged_name) = &parse_error_header ($severity, *used_tags,
						 *param_types, *param_order);
    while ((($token, $data) = &next_token), ($token == $TOK_COMMA)) {
	&parse_error_tag ($name, *tag_types, *tag_names, *tag_mnames,
			  *tag_code, *tag_init, *tag_order, *param_types);
    }
    if ($token == $TOK_PROGRAM) {
	$error_client_data{$name} = $data;
	($token, $data) = &next_token;
    } else {
	$error_client_data{$name} = "NIL(GenericP)";
    }
    if ($token != $TOK_CLOSE_BRACE) {
	&ifatal ("expected '}'");
    }
    foreach $tag (@used_tags) {
	if (!defined ($tag_types{$tag})) {
	    &fatal ("error '", $name, "' uses undefined tag '", $tag, "'");
	}
    }
    $error_index{$name} = $#error_order;
    &build_structure ($name, *tag_types, *tag_names, *tag_order);
    &build_tag_proc  ($name, *tag_types, *tag_names, *tag_order, *tag_code);
    &build_proc_dec  ($name, $munged_name, *tag_types, *tag_names, *tag_init,
		      *tag_order, *param_types, *param_order);
    &build_proc_def  ($name, $munged_name, *tag_types, *tag_names, *tag_init,
		      *tag_order, *param_types, *param_order);
    push (@error_order, $name);
}

sub parse_header {
    local ($token, $data);

    if ((($token, $data) = &next_token), ($token != $TOK_PROGRAM)) {
	&ifatal ("expected program section");
    }
    $error_header .= ("/* Header from input file '" . $infile . "' */\n" .
		      $data . "\n");
}

sub parse_c_header {
    local ($token, $data);

    if ((($token, $data) = &next_token), ($token != $TOK_PROGRAM)) {
	&ifatal ("expected program section");
    }
    $error_c_header .= ("/* Header from input file '" . $infile . "' */\n" .
			$data . "\n");
}

sub parse_file {
    local ($file) = @_;

    &reset_lexer ($file);
    while ((($token, $data) = &next_token), ($token != $TOK_EOF)) {
	if ($token == $TOK_HEADER) {
	    &parse_header;
	} elsif ($token == $TOK_C_HEADER) {
	    &parse_c_header;
	} elsif ($token == $TOK_SEVERITY) {
	    &parse_error ($data);
	} else {
	    &ifatal ("expected header or severity level");
	}
	if ((($token, $data) = &next_token), ($token != $TOK_SEMI_COLON)) {
	    &ifatal ("expected ';'");
	}
    }
    close (INFILE);
}

###############################################################################
### Output:

sub output_c_file {
    local ($i, $tag, $error, $name);

    print OUTFILE ("/* Automatically generated by '", $prog, "' */\n\n");
    print OUTFILE ("#include \"", &basename ($outfile), ".h\"\n");
    print OUTFILE ("#include \"error.h\"\n");
    print OUTFILE ("#include \"ostream.h\"\n\n");
    print OUTFILE ($error_c_header, "\n");

    print OUTFILE ("static ETagDataT ET[] = {\n");
    for ($i = 1; $i <= $#error_tag_order; $i ++) {
	$tag = $error_tag_order [$i];
	print OUTFILE ("    UB \"", $tag, "\" UE,\n");
    }
    print OUTFILE ("    ERROR_END_TAG_LIST\n");
    print OUTFILE ("};\n\n");

    print OUTFILE ("static ErrorDataT EE[] = {\n");
    for ($i = 1; $i <= $#error_order; $i ++) {
	$error = $error_order [$i];
	print OUTFILE ("    UB {\n\t\"", $error, "\",\n\t",
		       $error_severities{$error}, ",\n\t\"",
		       $error_messages{$error}, "\",\n\t",
		       $error_client_data{$error}, "\n    } UE,\n");
    }
    print OUTFILE ("    ERROR_END_ERROR_LIST\n");
    print OUTFILE ("};\n\n");

    for ($i = 1; $i <= $#error_structures; $i ++) {
	print OUTFILE ($error_structures [$i]);
    }
    print OUTFILE ("\n");

    for ($i = 1; $i <= $#error_tag_procs; $i ++) {
	print OUTFILE ($error_tag_procs [$i]);
    }
    print OUTFILE ("\n");

    for ($i = 1; $i <= $#error_order; $i ++) {
	$error = $error_order [$i];
	print OUTFILE ($error_proc_defs{$error});
    }
    $name = &munge_name (&basename ($outfile));
    print OUTFILE ("\nvoid\n", $name, "_init_errors(void)\n",
		   "{\n    error_intern_tags (ET);\n",
		   "    error_intern_errors (EE);\n}\n");
}

sub output_h_file {
    local ($i);

    print OUTFILE ("/* Automatically generated by '", $prog, "' */\n\n");
    print OUTFILE ("#include \"os-interface.h\"\n\n");
    print OUTFILE ($error_header, "\n");

    print OUTFILE ("/* Error function declarations */\n\n");
    for ($i = 1; $i <= $#error_order; $i ++) {
	$error = $error_order [$i];
	print OUTFILE ($error_proc_decs{$error});
    }
    print OUTFILE ("\nextern void ", &munge_name (&basename ($outfile)),
		   "_init_errors(void);\n");
}

###############################################################################

$outfile	= "error-mesgs";

###############################################################################

arg:
while (defined ($arg = shift (@ARGV))) {
    if ($arg =~ /^-o/) {
	(defined ($outfile = shift (@ARGV))) ||
	    &fatal ("no output file name specified after '", $arg, "' option");
    } elsif ($arg =~ /^-/) {
	&fatal ("unknown option '", $arg, "'");
    } else {
	unshift (@ARGV, $arg);
	last arg;
    }
}

while (defined ($infile = shift (@ARGV))) {
    &parse_file ($infile);
}

open (OUTFILE, ">" . $outfile . ".c") ||
    &fatal ("cannot open output file '", $outfile, ".c'");
&output_c_file;
close (OUTFILE);
open (OUTFILE, ">" . $outfile . ".h") ||
    &fatal ("cannot open output file '", $outfile, ".h'");
&output_h_file;
close (OUTFILE);
exit (0);