dfhack/library/xml/codegen.pl

906 lines
25 KiB
Perl

2011-12-24 03:37:00 -07:00
#!/usr/bin/perl
use strict;
use warnings;
use XML::LibXML;
my $input_dir = $ARGV[0] || '.';
my $output_dir = $ARGV[1] || 'codegen';
my $main_namespace = $ARGV[2] || 'df';
my $export_prefix = 'DFHACK_EXPORT ';
my %types;
my %type_files;
# Misc XML analysis
our $typename;
our $filename;
sub parse_address($;$) {
my ($str,$in_bits) = @_;
return undef unless defined $str;
# Parse the format used by offset attributes in xml
$str =~ /^0x([0-9a-f]+)(?:\.([0-7]))?$/
or die "Invalid address syntax: $str\n";
my ($full, $bv) = ($1, $2);
die "Bits not allowed: $str\n" unless $in_bits;
return $in_bits ? (hex($full)*8 + ($bv||0)) : hex($full);
}
sub check_bad_attrs($;$$) {
my ($tag, $allow_size, $allow_align) = @_;
die "Cannot use size, alignment or offset for ".$tag->nodeName."\n"
if ((!$allow_size && defined $tag->getAttribute('size')) ||
defined $tag->getAttribute('offset') ||
(!$allow_align && defined $tag->getAttribute('alignment')));
}
sub check_name($) {
my ($name) = @_;
$name =~ /^[_a-zA-Z][_a-zA-Z0-9]*$/
or die "Invalid identifier: $name\n";
return $name;
}
sub is_attr_true($$) {
my ($tag, $name) = @_;
return ($tag->getAttribute($name)||'') eq 'true';
}
sub type_header_def($) {
my ($name) = @_;
return uc($main_namespace).'_'.uc($name).'_H';
}
# Text generation with indentation
our @lines;
our $indentation = 0;
sub with_emit(&;$) {
# Executes the code block, and returns emitted lines
my ($blk, $start_indent) = @_;
local @lines;
local $indentation = ($start_indent||0);
$blk->();
return @lines;
}
sub emit(@) {
# Emit an indented line to be returned from with_emit
my $line = join('',map { defined($_) ? $_ : '' } @_);
$line = (' 'x$indentation).$line unless length($line) == 0;
push @lines, $line;
}
sub indent(&) {
# Indent lines emitted from the block by one step
my ($blk) = @_;
local $indentation = $indentation+2;
$blk->();
}
sub outdent(&) {
# Unindent lines emitted from the block by one step
my ($blk) = @_;
local $indentation = ($indentation >= 2 ? $indentation-2 : 0);
$blk->();
}
sub emit_block(&;$$) {
# Emit a full {...} block with indentation
my ($blk, $prefix, $suffix) = @_;
$prefix ||= '';
$suffix ||= '';
emit $prefix,'{';
&indent($blk);
emit '}',$suffix;
}
# Static file output
my @static_lines;
my %static_includes;
sub with_emit_static(&) {
my ($blk) = @_;
$static_includes{$typename}++;
push @static_lines, &with_emit($blk,2);
}
# Anonymous variable names
our $anon_id = 0;
our $anon_prefix;
sub ensure_name($) {
# If the name is empty, assign an auto-generated one
my ($name) = @_;
unless ($name) {
$name = $anon_prefix.(($anon_id == 0) ? '' : '_'.$anon_id);
$anon_id++;
}
return check_name($name);
}
sub with_anon(&;$) {
# Establish a new anonymous namespace
my ($blk,$stem) = @_;
local $anon_id = $stem ? 0 : 1;
local $anon_prefix = ($stem||'anon');
$blk->();
}
# Primitive types
my @primitive_type_list =
qw(int8_t uint8_t int16_t uint16_t
int32_t uint32_t int64_t uint64_t
s-float
bool ptr-string stl-string flag-bit
pointer);
my %primitive_aliases = (
'stl-string' => 'std::string',
'ptr-string' => 'char*',
'flag-bit' => 'void',
'pointer' => 'void*',
's-float' => 'float',
);
my %primitive_types;
$primitive_types{$_}++ for @primitive_type_list;
sub primitive_type_name($) {
my ($tag_name) = @_;
$primitive_types{$tag_name}
or die "Not primitive: $tag_name\n";
return $primitive_aliases{$tag_name} || $tag_name;
}
# Type references
our %weak_refs;
our %strong_refs;
sub register_ref($;$) {
# Register a reference to another type.
# Strong ones require the type to be included.
my ($ref, $is_strong) = @_;
if ($ref) {
my $type = $types{$ref}
or die "Unknown type $ref referenced.\n";
if ($is_strong) {
$strong_refs{$ref}++;
} else {
$weak_refs{$ref}++;
}
}
}
# Determines if referenced other types should be included or forward-declared
our $is_strong_ref = 1;
sub with_struct_block(&$;$%) {
my ($blk, $tag, $name, %flags) = @_;
my $kwd = (is_attr_true($tag,'is-union') ? "union" : "struct");
my $exp = $flags{-export} ? $export_prefix : '';
my $prefix = $kwd.' '.$exp.($name ? $name.' ' : '');
emit_block {
local $_;
local $is_strong_ref = 1; # reset the state
if ($flags{-no_anon}) {
$blk->();
} else {
&with_anon($blk);
}
} $prefix, ";";
}
sub decode_type_name_ref($;%) {
# Interpret the type-name field of a tag
my ($tag,%flags) = @_;
my $force_type = $flags{-force_type};
my $force_strong = $flags{-force_strong};
my $tname = $tag->getAttribute($flags{-attr_name} || 'type-name')
or return undef;
if ($primitive_types{$tname}) {
die "Cannot use type $tname as type-name of ".$tag->nodeName."\n"
if ($force_type && $force_type ne 'primitive');
return primitive_type_name($tname);
} else {
register_ref $tname, ($force_strong||$is_strong_ref);
die "Cannot use type $tname as type-name of ".$tag->nodeName."\n"
if ($force_type && $force_type ne $types{$tname}->nodeName);
return $main_namespace.'::'.$tname;
}
}
# CONDITIONALS
sub is_conditional($) {
my ($tag) = @_;
return $tag->nodeName =~ /^(cond-if|cond-elseif)$/;
}
sub translate_if_cond($) {
my ($tag) = @_;
my @rules;
if (my $defvar = $tag->getAttribute('defined')) {
push @rules, "defined($defvar)";
}
if (my $cmpvar = $tag->getAttribute('var')) {
if (my $cmpval = $tag->getAttribute('lt')) {
push @rules, "($cmpvar < $cmpval)";
}
if (my $cmpval = $tag->getAttribute('le')) {
push @rules, "($cmpvar <= $cmpval)";
}
if (my $cmpval = $tag->getAttribute('eq')) {
push @rules, "($cmpvar == $cmpval)";
}
if (my $cmpval = $tag->getAttribute('ge')) {
push @rules, "($cmpvar >= $cmpval)";
}
if (my $cmpval = $tag->getAttribute('gt')) {
push @rules, "($cmpvar > $cmpval)";
}
if (my $cmpval = $tag->getAttribute('ne')) {
push @rules, "($cmpvar != $cmpval)";
}
}
return '('.(join(' && ',@rules) || '1').')';
}
our $in_cond = 0;
sub render_cond_if($$$;@) {
my ($tag, $in_elseif, $render_cb, @tail) = @_;
local $in_cond = 1;
{
local $indentation = 0;
my $op = ($in_elseif && $in_elseif >= 2) ? '#elif' : '#if';
emit $op, ' ', translate_if_cond($tag);
}
for my $child ($tag->findnodes('child::*')) {
&render_cond($child, $render_cb, @tail);
}
unless ($in_elseif) {
local $indentation = 0;
emit "#endif";
}
}
sub render_cond($$;@) {
my ($tag, $render_cb, @tail) = @_;
my $tag_name = $tag->nodeName;
if ($tag_name eq 'cond-if') {
render_cond_if($tag, 0, $render_cb, @tail);
} elsif ($tag_name eq 'cond-elseif') {
my $idx = 1;
for my $child ($tag->findnodes('child::*')) {
($child->nodeName eq 'cond-if')
or die "Only cond-if tags may be inside a cond-switch: ".$child->nodeName."\n";
render_cond_if($child, $idx++, $render_cb, @tail);
}
{
local $indentation = 0;
emit "#endif";
}
} else {
local $_ = $tag;
$render_cb->($tag, @tail);
}
}
# ENUM
sub render_enum_core($$) {
my ($name,$tag) = @_;
my $base = 0;
emit_block {
my @items = $tag->findnodes('child::*');
my $idx = 0;
for my $item (@items) {
render_cond $item, sub {
my $tag = $_->nodeName;
return if $tag eq 'enum-attr';
($tag eq 'enum-item')
or die "Invalid enum member: ".$item->nodeName."\n";
my $name = ensure_name $_->getAttribute('name');
my $value = $_->getAttribute('value');
$base = ($idx == 0 && !$in_cond) ? $value : undef if defined $value;
$idx++;
emit $name, (defined($value) ? ' = '.$value : ''), ',';
};
}
emit "_last_item_of_$name";
} "enum $name ", ";";
return $base;
}
sub render_enum_tables($$$) {
my ($name,$tag,$base) = @_;
# Enumerate enum attributes
my %aidx = ('key' => 0);
my @anames = ('key');
my @avals = ('NULL');
my @atypes = ('const char*');
my @atnames = (undef);
for my $attr ($tag->findnodes('child::enum-attr')) {
my $name = $attr->getAttribute('name') or die "Unnamed enum-attr.\n";
my $type = $attr->getAttribute('type-name');
my $def = $attr->getAttribute('default-value');
die "Duplicate attribute $name.\n" if exists $aidx{$name};
check_name $name;
$aidx{$name} = scalar @anames;
push @anames, $name;
push @atnames, $type;
if ($type) {
push @atypes, $type;
push @avals, (defined $def ? $def : "($type)0");
} else {
push @atypes, 'const char*';
push @avals, (defined $def ? "\"$def\"" : 'NULL');
}
}
# Emit accessor function prototypes
emit "const $name _first_item_of_$name = ($name)$base;";
emit_block {
emit "return (value >= _first_item_of_$name && value < _last_item_of_$name);";
} "inline bool is_valid($name value) ";
for (my $i = 0; $i < @anames; $i++) {
emit "${export_prefix}$atypes[$i] get_$anames[$i]($name value);";
}
# Emit implementation
with_emit_static {
emit_block {
emit_block {
# Emit the entry type
emit_block {
for (my $i = 0; $i < @anames; $i++) {
emit "$atypes[$i] $anames[$i];";
}
} "struct _info_entry ", ";";
# Emit the info table
emit_block {
for my $item ($tag->findnodes('child::*')) {
render_cond $item, sub {
my $tag = $_->nodeName;
return if $tag eq 'enum-attr';
# Assemble item-specific attr values
my @evals = @avals;
my $name = $_->getAttribute('name');
$evals[0] = "\"$name\"" if $name;
for my $attr ($_->findnodes('child::item-attr')) {
my $name = $attr->getAttribute('name') or die "Unnamed item-attr.\n";
my $value = $attr->getAttribute('value') or die "No-value item-attr.\n";
my $idx = $aidx{$name} or die "Unknown item-attr: $name\n";
if ($atnames[$idx]) {
$evals[$idx] = $value;
} else {
$evals[$idx] = "\"$value\"";
}
}
emit "{ ",join(', ',@evals)," },";
};
}
emit "{ ",join(', ',@avals)," }";
} "static const _info_entry _info[] = ", ";";
for (my $i = 0; $i < @anames; $i++) {
emit_block {
emit "return is_valid(value) ? _info[value - $base].$anames[$i] : $avals[$i];";
} "$atypes[$i] get_$anames[$i]($name value) ";
}
} "namespace $name ";
} "namespace enums ";
};
}
sub render_enum_type {
my ($tag) = @_;
emit_block {
emit_block {
my $base = render_enum_core($typename,$tag);
if (defined $base) {
render_enum_tables($typename,$tag,$base);
} else {
print STDERR "Warning: complex enum: $typename\n";
}
} "namespace $typename ";
} "namespace enums ";
emit "using enums::",$typename,"::",$typename,";";
}
# BITFIELD
sub get_primitive_base($;$) {
my ($tag, $default) = @_;
my $base = $tag->getAttribute('base-type') || $default || 'uint32_t';
$primitive_types{$base} or die "Must be primitive: $base\n";
return $base;
}
sub render_bitfield_core {
my ($name, $tag) = @_;
emit_block {
emit get_primitive_base($tag), ' whole;';
emit_block {
for my $item ($tag->findnodes('child::*')) {
render_cond $item, sub {
my ($item) = @_;
($item->nodeName eq 'flag-bit')
or die "Invalid bitfield member:".$item->nodeName."\n";
check_bad_attrs($item);
my $name = ensure_name $item->getAttribute('name');
my $size = $item->getAttribute('count') || 1;
emit "unsigned ", $name, " : ", $size, ";";
};
}
} "struct ", " bits;";
} "union $name ", ";";
}
sub render_bitfield_type {
my ($tag) = @_;
render_bitfield_core($typename,$tag);
}
# STRUCT
my %struct_field_handlers;
sub get_struct_fields($) {
# Retrieve subtags that are actual struct fields
my ($struct_tag) = @_;
local $_;
return grep {
my $tag = $_->nodeName;
die "Unknown field tag: $tag\n"
unless exists $struct_field_handlers{$tag};
$struct_field_handlers{$tag};
} $struct_tag->findnodes('child::*');
}
sub get_struct_field_type($) {
# Dispatch on the tag name, and retrieve the type prefix & suffix
my ($tag) = @_;
my $handler = $struct_field_handlers{$tag->nodeName}
or die "Unexpected tag: ".$tag->nodeName;
return $handler->($tag);
}
sub do_render_struct_field($) {
my ($tag) = @_;
my $tag_name = $tag->nodeName;
my $field_name = $tag->getAttribute('name');
# Special case: anonymous compounds.
if ($tag_name eq 'compound' && !defined $field_name &&
!defined $tag->getAttribute('type-name'))
{
check_bad_attrs($tag);
with_struct_block {
render_struct_field($_) for get_struct_fields($tag);
} $tag, undef, -no_anon => 1;
return;
}
# Otherwise, create the name if necessary, and render
my $name = ensure_name $field_name;
with_anon {
my ($prefix, $postfix) = get_struct_field_type($tag);
emit $prefix, ' ', $name, $postfix, ';';
} "T_$name";
}
sub render_struct_field($) {
my ($tag) = @_;
render_cond $tag, \&do_render_struct_field;
}
sub emit_typedef($$) {
# Convert a prefix/postfix pair into a single name
my ($pre, $post) = @_;
my $name = ensure_name undef;
emit 'typedef ', $pre, ' ', $name, $post, ';';
return $name;
}
sub get_container_item_type($$;$) {
# Interpret the type-name and nested fields for a generic container type
my ($tag,$strong_ref,$allow_void) = @_;
check_bad_attrs($tag);
my $prefix;
my $postfix = '';
local $is_strong_ref = $strong_ref;
unless ($prefix = decode_type_name_ref($tag)) {
my @fields = get_struct_fields($tag);
if (scalar(@fields) == 1 && !is_conditional($fields[0])) {
($prefix, $postfix) = get_struct_field_type($fields[0]);
} elsif (scalar(@fields) == 0) {
$allow_void or die "Empty container: ".$tag->nodeName."\n";
$prefix = $allow_void;
} else {
$prefix = ensure_name undef;
with_struct_block {
render_struct_field($_) for @fields;
} $tag, $prefix;
}
}
return ($prefix,$postfix) if wantarray;
return emit_typedef($prefix, $postfix) if $postfix;
return $prefix;
}
sub get_primitive_field_type {
# Primitive type handler
my ($tag,$fname) = @_;
check_bad_attrs($tag);
my $name = $tag->nodeName;
return (primitive_type_name($name), "");
}
sub get_static_string_type {
# Static string handler
my ($tag, $fname) = @_;
check_bad_attrs($tag, 1);
my $count = $tag->getAttribute('size') || 0;
return ('char', "[$count]");
}
sub get_padding_type {
# Padding handler. Supports limited alignment.
my ($tag, $fname) = @_;
check_bad_attrs($tag, 1, 1);
my $count = $tag->getAttribute('size') || 0;
my $align = $tag->getAttribute('alignment') || 1;
if ($align == 1) {
return ('char', "[$count]");
} elsif ($align == 2) {
($count % 2 == 0) or die "Size not aligned in padding: $count at $align\n";
return ('short', "[".($count/2)."]");
} elsif ($align == 4) {
($count % 4 == 0) or die "Size not aligned in padding: $count at $align\n";
return ('int', "[".($count/4)."]");
} else {
die "Bad padding alignment $align in $typename in $filename\n";
}
}
sub get_static_array_type {
# static-array handler
my ($tag, $fname) = @_;
my ($pre, $post) = get_container_item_type($tag, 1);
my $count = $tag->getAttribute('count')
or die "Count is mandatory for static-array in $typename in $filename\n";
return ($pre, "[$count]".$post);
}
sub get_pointer_type($) {
# pointer handler
my ($tag) = @_;
my $item = get_container_item_type($tag, 0, 'void');
return ($item.'*', '');
}
sub get_compound_type($) {
# compound (nested struct) handler
my ($tag) = @_;
check_bad_attrs($tag);
my $tname = decode_type_name_ref($tag);
unless ($tname) {
$tname = ensure_name undef;
with_struct_block {
render_struct_field($_) for get_struct_fields($tag);
} $tag, $tname;
}
return ($tname,'');
}
sub get_bitfield_type($) {
# nested bitfield handler
my ($tag) = @_;
check_bad_attrs($tag);
my $tname = decode_type_name_ref($tag, -force_type => 'bitfield-type');
unless ($tname) {
$tname = ensure_name undef;
with_anon {
render_bitfield_core($tname, $tag);
};
}
return ($tname,'');
}
sub get_enum_type($) {
# nested enum handler
my ($tag) = @_;
check_bad_attrs($tag);
my $tname = decode_type_name_ref($tag, -force_type => 'enum-type', -force_strong => 1);
my $base = get_primitive_base($tag, 'int32_t');
unless ($tname) {
$tname = ensure_name undef;
with_anon {
render_enum_core($tname,$tag);
};
}
return ("enum_field<$tname,$base>", '');
}
sub get_stl_vector_type($) {
# STL vector
my ($tag) = @_;
my $item = get_container_item_type($tag,1,'void*');
$item = 'char' if $item eq 'bool';
return ("std::vector<$item>", '');
}
sub get_stl_bit_vector_type($) {
# STL bit vector
my ($tag) = @_;
check_bad_attrs($tag);
return ("std::vector<bool>", '');
}
sub get_df_flagarray_type($) {
# DF flag array
my ($tag) = @_;
check_bad_attrs($tag);
my $type = decode_type_name_ref($tag, -attr_name => 'index-enum', -force_type => 'enum-type', -force_strong => 1) || 'int';
return ("BitArray<$type>", '');
}
# Struct dispatch table and core
%struct_field_handlers = (
'comment' => undef, # skip
'code-helper' => undef, # skip
'cond-if' => sub { die "cond handling error"; },
'cond-elseif' => sub { die "cond handling error"; },
'static-string' => \&get_static_string_type,
'padding' => \&get_padding_type,
'static-array' => \&get_static_array_type,
'pointer' => \&get_pointer_type,
'compound' => \&get_compound_type,
'bitfield' => \&get_bitfield_type,
'enum' => \&get_enum_type,
'stl-vector' => \&get_stl_vector_type,
'stl-bit-vector' => \&get_stl_bit_vector_type,
'df-flagarray' => \&get_df_flagarray_type,
);
$struct_field_handlers{$_} ||= \&get_primitive_field_type for @primitive_type_list;
sub render_struct_type {
my ($tag) = @_;
my $tag_name = $tag->nodeName;
my $is_class = ($tag_name eq 'class-type');
my $has_methods = $is_class || is_attr_true($tag, 'has-methods');
my $inherits = $tag->getAttribute('inherits-from');
my $original_name = $tag->getAttribute('original-name');
my $ispec = '';
if ($inherits) {
register_ref $inherits, 1;
$ispec = ' : '.$inherits;
} elsif ($is_class) {
$ispec = ' : virtual_class';
}
with_struct_block {
render_struct_field($_) for get_struct_fields($tag);
if ($has_methods) {
if ($is_class) {
emit "static class_virtual_identity<$typename> _identity;";
with_emit_static {
emit "class_virtual_identity<$typename> ${typename}::_identity(",
"\"$typename\",",
($original_name ? "\"$original_name\"" : 'NULL'), ',',
($inherits ? "&${inherits}::_identity" : 'NULL'),
");";
}
}
outdent {
emit "protected:";
};
if ($is_class) {
emit "virtual ~",$typename,"() {}";
} else {
emit "~",$typename,"() {}";
}
}
} $tag, "$typename$ispec", -export => 1;
}
# MAIN BODY
# Collect all type definitions from XML files
sub add_type_to_hash($) {
my ($type) = @_;
my $name = $type->getAttribute('type-name')
or die "Type without a name in $filename\n";
die "Duplicate definition of $name in $filename\n" if $types{$name};
local $typename = $name;
check_bad_attrs $type;
$types{$name} = $type;
$type_files{$name} = $filename;
}
for my $fn (glob "$input_dir/*.xml") {
local $filename = $fn;
my $parser = XML::LibXML->new();
my $doc = $parser->parse_file($filename);
add_type_to_hash $_ foreach $doc->findnodes('/data-definition/enum-type');
add_type_to_hash $_ foreach $doc->findnodes('/data-definition/bitfield-type');
add_type_to_hash $_ foreach $doc->findnodes('/data-definition/struct-type');
add_type_to_hash $_ foreach $doc->findnodes('/data-definition/class-type');
}
# Generate text representations
my %type_handlers = (
'enum-type' => \&render_enum_type,
'bitfield-type' => \&render_bitfield_type,
'class-type' => \&render_struct_type,
'struct-type' => \&render_struct_type,
);
my %type_data;
for my $name (sort { $a cmp $b } keys %types) {
local $typename = $name;
local $filename = $type_files{$typename};
local %weak_refs;
local %strong_refs;
eval {
my $type = $types{$typename};
# Emit the actual type definition
my @code = with_emit {
with_anon {
$type_handlers{$type->nodeName}->($type);
};
} 2;
delete $weak_refs{$name};
delete $strong_refs{$name};
# Add wrapping
my @all = with_emit {
my $def = type_header_def($typename);
emit "#ifndef $def";
emit "#define $def";
for my $strong (sort { $a cmp $b } keys %strong_refs) {
my $sdef = type_header_def($strong);
emit "#ifndef $sdef";
emit "#include \"$strong.h\"";
emit "#endif";
}
emit_block {
for my $weak (sort { $a cmp $b } keys %weak_refs) {
next if $strong_refs{$weak};
my $ttype = $types{$weak};
my $tstr = 'struct';
$tstr = 'enum' if $ttype->nodeName eq 'enum-type';
$tstr = 'union' if $ttype->nodeName eq 'bitfield-type';
$tstr = 'union' if ($ttype->nodeName eq 'struct-type' && is_attr_true($ttype,'is-union'));
emit $tstr, ' ', $weak, ';';
}
push @lines, @code;
} "namespace $main_namespace ";
emit "#endif";
};
$type_data{$typename} = \@all;
};
if ($@) {
print 'Error: '.$@."Type $typename in $filename ignored\n";
}
}
# Write output files
mkdir $output_dir;
{
# Delete the old files
for my $name (glob "$output_dir/*.h") {
unlink $name;
}
# Write out the headers
local $, = "\n";
local $\ = "\n";
for my $name (keys %type_data) {
open FH, ">$output_dir/$name.h";
print FH "/* THIS FILE WAS GENERATED. DO NOT EDIT. */";
print FH @{$type_data{$name}};
close FH;
}
# Write out the static file
open FH, ">$output_dir/static.inc";
print FH "/* THIS FILE WAS GENERATED. DO NOT EDIT. */";
for my $name (sort { $a cmp $b } keys %static_includes) {
print FH "#include \"$name.h\"";
}
print FH "namespace $main_namespace {";
print FH @static_lines;
print FH '}';
close FH;
}