#!/usr/bin/perl
#
# adareps2c.pl - Convert Ada represented records to C
#
# Usage:
# perl adareps2c.pl AdaPkgSpec
#                  (AdaPkgSpec is your Ada package spec source file)
# Output is written to stdout.
#
# Copyright (C) 2008-2009, Oliver Kellogg <okellogg@users.sourceforge.net>
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program 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 General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
#
# $Log: adareps2c.pl,v $
# Revision 0.3  2009/03/06 08:38:46  kellogg
# Fixed placement of __attribute__((packed)).
# The bitlengths of components are now always printed outside comment.
# New switch -c (conservative) switches back to previous behavior where
# bitlengths of components that could not be determined to be scalar
# are printed in comment.
#
# Revision 0.2  2008/08/16 18:18:33  kellogg
# initial public version
#
#
if (scalar(@ARGV) < 1 or $ARGV[0] =~ /^-[^c]/) {
    warn("Usage: adareps2c.pl [-c] inputfile\n");
    warn(
      "The option -c switches to conservative mode in which the bitlengths\n"
    . "of components whose type cannot be determined to be scalar are\n"
    . "printed in C comments.\n");
    exit 0;
}
my $conservative = 0;
if ($ARGV[0] eq "-c") {
    $conservative = 1;
    shift @ARGV;
}
$inputfile=$ARGV[0];
open(IN, "<$inputfile") or die "cannot open file $inputfile\n";

%type_ada_to_cplusplus =
  ( character              => "char",
    boolean                => "bool",
    short_short_integer    => "signed char",
    short_integer          => "short",
    integer                => "int",
    long_integer           => "long",
    interfaces.integer_8   => "signed char",
    interfaces.integer_16  => "short",
    interfaces.integer_32  => "int",
    interfaces.unsigned_8  => "unsigned char",
    interfaces.unsigned_16 => "unsigned short",
    interfaces.unsigned_32 => "unsigned long",
    corba.boolean          => "bool",
    corba.octet            => "CORBA::Octet",
    corba.unsigned_short   => "CORBA::UShort",
    corba.unsigned_long    => "CORBA::ULong",
    corba.short            => "CORBA::Short",
    corba.long             => "CORBA::Long",
    corba.float            => "CORBA::Float",
    corba.double           => "CORBA::Double" );

@lex = ();

while (<IN>) {
    chop;
    next if (/^\s*$/ or /^\s*--/);
    s/^\s+//;     # no whitespace at start of line
    s/\s+$//;     # no whitespace at end of line
    s/\s*--.*$//; # suppress comments
    my $line = lc($_);
    my @a = split /\s+/, $line;
    for (my $i = 0; $i < scalar(@a); $i++) {
        my $lxm = $a[$i];
        # Split sticky range
        if ($lxm =~ /\w\.\./ or $lxm =~ /\.\.\w/) {
           my @b = split /(\.\.)/, $lxm;
           # remove $a[$i] and insert @b in its place
           splice(@a, $i, 1, @b);
           $i += scalar(@b) - 1;
        }
        # Split sticky parentheses
        if ($lxm =~ /\(./ or $lxm =~ /.\)/) {
           my @b = split /([\(\)])/, $lxm;
           # remove $a[$i] and insert @b in its place
           splice(@a, $i, 1, @b);
           $i += scalar(@b) - 1;
        }
        # Split sticky punctuation
        if ($lxm =~ /.[,:;]/ or $lxm =~ /[,:;]./) {
           my @b = split /([,:;])/, $lxm;
           # remove $a[$i] and insert @b in its place
           splice(@a, $i, 1, @b);
           $i += scalar(@b) - 1;
        }
    }
    # foreach (@a) {
    #     print "$_\n";
    # }
    # print "------------------\n";
    push @lex, @a;
}
close IN;

#
# Compare the list pointed-to by $listref starting at index
# $offset with the list given as the third to nth argument.
# Return 1 if the elements match, else 0.
# Return 0 also if the list pointed-to by $listref does not
# contain as many elements as given by the third to nth arg.
#
sub listeq {
    my $listref = shift;
    my $offset = shift;
    my @elements = @_;
    my @list = @$listref;
    for (my $i = 0; $i < scalar(@elements); $i++) {
        my $listindex = $offset + $i;
        if ($listindex > $#list || $list[$listindex] ne $elements[$i]) {
            return 0;
        }
    }
    return 1;
}

# List of tuples, each tuple is:
# [0] => type name
# [1] => reference to components list
#        Each entry in the components-list is:
#        [0] => component name
#        [1] => component type
#        [2] => starting bit position (optional)
#        [3] => bit length (optional)
#
@recordtypes = ();

# for (my $i = 0; $i < scalar(@lex); $i++) {
#     my $lx = $lex[$i];
#     print "$lx\n";
# }
# print "======================================================\n";

sub skip_stmt {
    my $lexindex = shift;
    while ($lex[$lexindex] and $lex[$lexindex] ne ';') {
        $lexindex++;
    }
    return $lexindex;
}

for (my $i = 0; $i < scalar(@lex); $i++) {
    my $lx = $lex[$i];
    if ($lx eq 'with' || $lx eq 'use') {
        $i = skip_stmt($i);
        next;
    }
    if ($lx eq 'type') {
        my $typename = $lex[++$i];
        my @recordtype = ($typename);
        my $nxt = $lex[++$i];
        if ($nxt eq '(') {
            while ($lex[++$i] ne ')') {
                # Skip discriminant
            }
            $nxt = $lex[++$i];
        }
        if ($nxt ne 'is') {
            warn "syntax error after $typename\n";
            next;
        }
        $nxt = $lex[++$i];
        if ($nxt eq 'record') {
            my @components;
            while ($lex[++$i] ne 'end') {
                my @comp = ($lex[$i]);   # component name
                if ($lex[++$i] ne ':') {
                    warn("$typename component " . $comp[0] . ": expecting ':'\n");
                    next;
                }
                my $type = $lex[++$i];
                if (exists $type_ada_to_cplusplus{$type}) {
                    $type = $type_ada_to_cplusplus{$type};
                }
                push @comp, $type;  # component type
                while ($lex[++$i] ne ';') {
                    # Skip rest of line
                }
                push @components, [ @comp ];
            }
            push @recordtype, [ @components ];
        }
        push @recordtypes, [ @recordtype ];
    } elsif ($lx eq 'for') {
        my $typename = $lex[++$i];
        my $nxt = $lex[++$i];
        if ($nxt eq 'use') {
            $nxt = $lex[++$i];
            if ($nxt ne 'record') {
                next;
            }
            my @lastrec = @{$recordtypes[$#recordtypes]};
            if ($typename ne $lastrec[0]) {
                warn("$typename repspec: lastrec is " . $lastrec[0] . "\n");
                next;
            }
            my $comps_ref = $lastrec[1];
            while ($lex[++$i] ne 'end') {
                my $compname = $lex[$i];     # component name
                my $compref;
                foreach (@$comps_ref) {
                    if ($_->[0] eq $compname) {
                        $compref = $_;
                        last;
                    }
                }
                unless ($compref) {
                    warn("$typename repspec: component $compname not found\n");
                    next;
                }
                if ($lex[++$i] ne 'at') {
                    warn("$typename component " . $comp[0] . ": expecting 'at'\n");
                    next;
                }
                my $abs_startbit = $lex[++$i] * 8;
                if ($lex[++$i] ne 'range') {
                    warn("$typename component " . $comp[0] . ": expecting 'range'\n");
                    next;
                }
                my $startbit = $lex[++$i];
                if ($lex[++$i] ne '..'){
                    warn("$typename component " . $comp[0] . ": expecting '..'\n");
                    next;
                }
                my $endbit = $lex[++$i];
                $abs_startbit += $startbit;
                my $bitlength = $endbit - $startbit + 1;
                # print("$typename " . $comp[0] .
                #       " abs_startbit=$abs_startbit, bitlength=$bitlength\n");
                push @$compref, $abs_startbit, $bitlength;
                if ($lex[++$i] ne ';') {
                    warn("$typename component " . $comp[0] . ": expecting ';'\n");
                }
            }
        }
    }
}

print "\n\n===================\n";

sub by_startbit {
    $a->[2] <=> $b->[2];
}

sub externally_defined_or_record_type {
    my $type = shift;
    if ($type =~ /\./ or $type =~ /::/) {
        # Scope qualification means it's externally defined.
        return 1;
    }
    foreach (@recordtypes) {
        my $typename = $_->[0];
        if ($type eq $typename) {
            return 1;
        }
    }
    return 0;
}

foreach $recref (@recordtypes) {
    my $typename = $recref->[0];
    print("struct $typename {\n");
    my $sparecount = 0;
    my @components = sort by_startbit @{$recref->[1]};

    # Determine maximum component name and type length for later pretty printing.
    my $max_componamelen = 0;
    my $max_compotypelen = 0;
    my $max_bitlen = 1;
    foreach (@components) {
        my $name = $_->[0];
        if (length($name) > $max_componamelen) {
            $max_componamelen = length($name);
        }
        my $type = $_->[1];
        $type =~ s/\./::/g;
        if (length($type) > $max_compotypelen) {
            $max_compotypelen = length($type);
        }
        if (scalar(@$_) > 3 && length($_->[3]) > $max_bitlen) {
            $max_bitlen = length($_->[3]);
        }
    }

    for (my $i = 0; $i < scalar(@components); $i++) {
        my $c = $components[$i];
        # Check if insertion of spare is needed
        if ($i > 0 && scalar(@$c) > 2) {
            my $prev = $components[$i - 1];
            if (scalar(@$prev) > 2) {
                my $should_start = $prev->[2] + $prev->[3];
                my $actual_start = $c->[2];
                if ($actual_start > $should_start) {
                    $sparecount++;
                    my $sparebits = $actual_start - $should_start;
                    my $typewhite = ' ' x ($max_compotypelen - 2);
                    print "   int${typewhite}a2c_spare$sparecount : $sparebits;\n";
                }
            }
        }
        my $name = $c->[0];
        my $namewhite = ' ' x ($max_componamelen - length($name) + 1);
        my $type = $c->[1];
        $type =~ s/\./::/g;
        my $typewhite = ' ' x ($max_compotypelen - length($type) + 1);
        print("   $type$typewhite$name");
        if (scalar(@$c) > 2) {
            print($namewhite);
            my $is_record_type = externally_defined_or_record_type($type);
            if ($is_record_type && $conservative) {
                print(" /* ");
            }
            print(": " . sprintf("%${max_bitlen}.${max_bitlen}s", $c->[3]));
            if ($is_record_type && $conservative) {
                print(" */");
            }
            print(";  // startbit " . $c->[2]);
        } else {
            print(";");
        }
        print("\n");
    }
    print("} __attribute__ ((packed));\n\n");
}