tools/winapi/c_type.pm

#
# Copyright 2002 Patrik Stridvall
#
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Lesser General Public
# License as published by the Free Software Foundation; either
# version 2.1 of the License, or (at your option) any later version.
#
# This library is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
# Lesser General Public License for more details.
#
# You should have received a copy of the GNU Lesser General Public
# License along with this library; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
#

package c_type;

use strict;

use output qw($output);

sub new {
    my $proto = shift;
    my $class = ref($proto) || $proto;
    my $self  = {};
    bless ($self, $class);

    return $self;
}

########################################################################
# set_find_align_callback
#
sub set_find_align_callback {
    my $self = shift;

    my $find_align = \${$self->{FIND_ALIGN}};

    $$find_align = shift;
}

########################################################################
# set_find_size_callback
#
sub set_find_size_callback {
    my $self = shift;

    my $find_size = \${$self->{FIND_SIZE}};

    $$find_size = shift;
}

sub kind {
    my $self = shift;
    my $kind = \${$self->{KIND}};
    my $dirty = \${$self->{DIRTY}};

    local $_ = shift;

    if(defined($_)) { $$kind = $_; $$dirty = 1; }

    return $$kind;
}

sub _name {
    my $self = shift;
    my $_name = \${$self->{_NAME}};
    my $dirty = \${$self->{DIRTY}};

    local $_ = shift;

    if(defined($_)) { $$_name = $_; $$dirty = 1; }

    return $$_name;
}

sub name {
    my $self = shift;
    my $name = \${$self->{NAME}};
    my $dirty = \${$self->{DIRTY}};

    local $_ = shift;

    if(defined($_)) { $$name = $_; $$dirty = 1; }

    if($$name) {
	return $$name;
    } else {
	my $kind = \${$self->{KIND}};
	my $_name = \${$self->{_NAME}};

	return "$$kind $$_name";
    }
}

sub pack {
    my $self = shift;
    my $pack = \${$self->{PACK}};
    my $dirty = \${$self->{DIRTY}};
    
    local $_ = shift;

    if(defined($_)) { $$pack = $_; $$dirty = 1; }

    return $$pack;
}

sub align {
    my $self = shift;

    my $align = \${$self->{ALIGN}};

    $self->_refresh();

    return $$align;
}

sub fields {
    my $self = shift;

    my $count = $self->field_count;

    my @fields = ();
    for (my $n = 0; $n < $count; $n++) {
	my $field = 'c_type_field'->new($self, $n);
	push @fields, $field;
    }
    return @fields;
}

sub field_base_sizes {
    my $self = shift;
    my $field_base_sizes = \${$self->{FIELD_BASE_SIZES}};

    $self->_refresh();

    return $$field_base_sizes;
}

sub field_aligns {
    my $self = shift;
    my $field_aligns = \${$self->{FIELD_ALIGNS}};

    $self->_refresh();

    return $$field_aligns;
}

sub field_count {
    my $self = shift;
    my $field_type_names = \${$self->{FIELD_TYPE_NAMES}};

    my @field_type_names = @{$$field_type_names}; 
    my $count = scalar(@field_type_names);

    return $count;
}

sub field_names {
    my $self = shift;
    my $field_names = \${$self->{FIELD_NAMES}};
    my $dirty = \${$self->{DIRTY}};

    local $_ = shift;

    if(defined($_)) { $$field_names = $_; $$dirty = 1; }

    return $$field_names;
}

sub field_offsets {
    my $self = shift;
    my $field_offsets = \${$self->{FIELD_OFFSETS}};

    $self->_refresh();

    return $$field_offsets;
}

sub field_sizes {
    my $self = shift;
    my $field_sizes = \${$self->{FIELD_SIZES}};

    $self->_refresh();

    return $$field_sizes;
}

sub field_type_names {
    my $self = shift;
    my $field_type_names = \${$self->{FIELD_TYPE_NAMES}};
    my $dirty = \${$self->{DIRTY}};

    local $_ = shift;

    if(defined($_)) { $$field_type_names = $_; $$dirty = 1; }

    return $$field_type_names;
}

sub size {
    my $self = shift;

    my $size = \${$self->{SIZE}};

    $self->_refresh();

    return $$size;
}

sub _refresh {
    my $self = shift;

    my $dirty = \${$self->{DIRTY}};

    return if !$$dirty;

    my $find_align = \${$self->{FIND_ALIGN}};
    my $find_size = \${$self->{FIND_SIZE}};

    my $align = \${$self->{ALIGN}};
    my $kind = \${$self->{KIND}};
    my $size = \${$self->{SIZE}};
    my $field_aligns = \${$self->{FIELD_ALIGNS}};
    my $field_base_sizes = \${$self->{FIELD_BASE_SIZES}};
    my $field_offsets = \${$self->{FIELD_OFFSETS}};
    my $field_sizes = \${$self->{FIELD_SIZES}};

    my $pack = $self->pack;

    my $max_field_align = 0;

    my $offset = 0;
    my $offset_bits = 0;

    my $n = 0;
    foreach my $field ($self->fields) {
	my $type_name = $field->type_name;
	my $size = &$$find_size($type_name);

	my $base_type_name = $type_name;
	if ($base_type_name =~ s/^(.*?)\s*(?:\[\s*(.*?)\s*\]|:(\d+))?$/$1/) {
	    my $count = $2;
	    my $bits = $3;
	}
	my $base_size = &$$find_size($base_type_name);
	my $align = &$$find_align($base_type_name);

	if (defined($align)) { 
	    $align = $pack if $align > $pack;
	    $max_field_align = $align if $align > $max_field_align;

	    if ($offset % $align != 0) {
		$offset = (int($offset / $align) + 1) * $align;
	    }
	}

	if (!defined($size)) {
	    $$align = undef;
	    $$size = undef;
	    return;
	} elsif ($size >= 0) {
	    if ($offset_bits) {
		$offset += $pack * int(($offset_bits + 8 * $pack - 1 ) / (8 * $pack));
		$offset_bits = 0;
	    }

	    $$$field_aligns[$n] = $align;
	    $$$field_base_sizes[$n] = $base_size;
	    $$$field_offsets[$n] = $offset;
	    $$$field_sizes[$n] = $size;

	    $offset += $size;
	} else {
	    $$$field_aligns[$n] = $align;
	    $$$field_base_sizes[$n] = $base_size;
	    $$$field_offsets[$n] = $offset;
	    $$$field_sizes[$n] = $size;

	    $offset_bits += -$size;
	}

	$n++;
    }

    $$align = $pack;
    $$align = $max_field_align if $max_field_align < $pack;

    $$size = $offset;
    if ($$kind =~ /^(?:struct|union)$/) {
	if ($$size % $$align != 0) {
	    $$size = (int($$size / $$align) + 1) * $$align;
	}
    }

    $$dirty = 0;
}

package c_type_field;

sub new {
    my $proto = shift;
    my $class = ref($proto) || $proto;
    my $self  = {};
    bless ($self, $class);

    my $type = \${$self->{TYPE}};
    my $number = \${$self->{NUMBER}};

    $$type = shift;
    $$number = shift;

    return $self;
}

sub align {
    my $self = shift;
    my $type = \${$self->{TYPE}};
    my $number = \${$self->{NUMBER}};

    my $field_aligns = $$type->field_aligns;

    return $$field_aligns[$$number];
}

sub base_size {
    my $self = shift;
    my $type = \${$self->{TYPE}};
    my $number = \${$self->{NUMBER}};

    my $field_base_sizes = $$type->field_base_sizes;

    return $$field_base_sizes[$$number];
}

sub name {
    my $self = shift;
    my $type = \${$self->{TYPE}};
    my $number = \${$self->{NUMBER}};

    my $field_names = $$type->field_names;

    return $$field_names[$$number];
}

sub offset {
    my $self = shift;
    my $type = \${$self->{TYPE}};
    my $number = \${$self->{NUMBER}};

    my $field_offsets = $$type->field_offsets;

    return $$field_offsets[$$number];
}

sub size {
    my $self = shift;
    my $type = \${$self->{TYPE}};
    my $number = \${$self->{NUMBER}};

    my $field_sizes = $$type->field_sizes;

    return $$field_sizes[$$number];
}

sub type_name {
    my $self = shift;
    my $type = \${$self->{TYPE}};
    my $number = \${$self->{NUMBER}};

    my $field_type_names = $$type->field_type_names;

    return $$field_type_names[$$number];
}

1;