Rev 124 | Go to most recent revision | Blame | Compare with Previous | Last modification | View Log | RSS feed
#!/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);