#!/usr/bin/perl
#
# idl2ada.pl   IDL symbol tree to Ada95 translator
# Author:      Oliver M. Kellogg (oliver.kellogg@vs.dasa.de)
# Copyright:   (C) 1998, Daimler-Benz Aerospace AG (DASA), Ulm, Germany
#
# This file is part of GNACK, the GNU Ada CORBA Kit.
#
# GNACK 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.
#
# GNACK 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.
#
# -----------------------------------------------------------------------------
# Ver. |   Date   | History
# -----+----------+------------------------------------------------------------
#  0.0  1998/yy/xx  First public release, alpha stage, Ada pkg. specs only
#                   Features known to be missing:
#                   * package body generation: at this point it is unclear
#                     whether to interface to an existing C- or C++-based
#                     ORB (such as ILU, Flick, OmniORB, TAO) or to implement
#                     the entire ORB here -- ideas welcome.
#                   * #define (C++ preprocessor definitions)
#                   * forward declarations
#                   * multiple inheritance
#                   * the _IDL_File package for declarations in the IDL
#                     global scope
#                   * renaming/subtyping of parent type/constant/exception
#                     declarations in the child package (single inheritance)
#                   * Typecodes ; type Any
#                   * non-void methods with inout or out parameters
#                   * typedef struct (and other complicated typedefs)
#                   * expressions as the maximum length in bounded sequences
#                     and bounded strings
#                   * More things missing? Tell me about it! (e-mail, above)
# -----------------------------------------------------------------------------
#

use CORBA::IDLtree;

# Subroutine forward declarations

sub gen_ada;
sub gen_ada_recursive;
sub mapped_type;
sub check_scope;
sub open_files;
sub espec;
sub ebody;
sub eispec;
sub eibody;
sub especs;
sub ebodies;
sub eiboth;
sub eboth;
sub eall;
sub pspec;
sub pbody;
sub pboth;   # print to both (SPEC and BODY files)
sub pispec;
sub pibody;
sub piboth;  # print to both (ISPEC and IBODY files)
sub pspecs;
sub pbodies;
sub pall;
sub specindent;
sub specdedent;
sub print_spec_beginning;
sub print_body_beginning;
sub print_ispec_beginning;
sub print_ibody_beginning;
sub print_pkg_prologues;
sub print_spec_interface;
sub print_body_interface;
sub print_ispec_interface;
sub print_ibody_interface;
sub print_interface_prologues;


# Constants

$INDENT = 3;
    # Number of spaces for one indentation
$INDENT2 = (1 << (5 - $INDENT)) + 4;
    # Number of indents for an approx. 1/3-page (25 space) indentation
@proxy_spec_file_handle = qw/ PS0 PS1 PS2 PS3 PS4 PS5 PS6 PS7 PS8 PS9 /;
@proxy_body_file_handle = qw/ PB0 PB1 PB2 PB3 PB4 PB5 PB6 PB7 PB8 PB9 /;
@impl_spec_file_handle  = qw/ IS0 IS1 IS2 IS3 IS4 IS5 IS6 IS7 IS8 IS9 /;
@impl_body_file_handle  = qw/ IB0 IB1 IB2 IB3 IB4 IB5 IB6 IB7 IB8 IB9 /;
    # The file handles are indexed by $#scopestack.

# Global variables
@gen_ispec = ();     # Generate implementation package spec (see gen_ada)
@gen_ibody = ();     # Generate implementation package body (see gen_ada)
$in_comment = 0;     # Auxiliary to sub getline (multi-line comment processing)
@spec_ilvl = ();          # Proxy-indentlevel
@body_ilvl = ();          # Proxy-indentlevel
@ispec_ilvl = ();         # Impl-indentlevel
@ibody_ilvl = ();         # Impl-indentlevel
@scopestack = ();         # Stack of module/interface names
@withlist = ();           # List of user packages to "with"
$did_file_prologues = 0;  # Flag; true when prologues were already written
$psfh = 0;           # Shorthand for $proxy_spec_file_handle[$#scopestack]
$pbfh = 0;           # Shorthand for $proxy_body_file_handle[$#scopestack]
$isfh = 0;           # Shorthand for $impl_spec_file_handle[$#scopestack]
$ibfh = 0;           # Shorthand for $impl_body_file_handle[$#scopestack]

# Options processing
$verbose = 0;
for ($i=0; $i <= $#ARGV; $i++) {
    if ($ARGV[$i] =~ /^-/) {
        for (substr($ARGV[$i], 1)) {
            /^v$/ and $verbose = 1, last;
            /^V$/ and print("idl2ada version -.-\n"), last;
            die "unknown option: $ARGV[$i]\n";
        }
        splice(@ARGV, $i--, 1);
    }
}

# Main program

while (@ARGV) {
    $idl_filename = shift @ARGV;
        # $idl_filename is global and might be used in gen_ada for generating
        # the _IDL_File global-scope package.
    my $symroot = CORBA::IDLtree::Parse_File $idl_filename;
    die "idl2ada: errors while parsing $idl_filename\n" unless ($symroot);
    CORBA::IDLtree::Dump_Symbols($symroot) if ($verbose);
    gen_ada $symroot;
}

# End of main program


# Ada back end subroutines

sub mapped_type {
    # This is similar to typeof(), but the type returned is in Ada syntax.
    my $type_descr = shift;
    if (@_) {
        my $noderef = shift;
        if (exists $CORBA::IDLtree::Prefixes{$noderef}) {
            return($CORBA::IDLtree::Prefixes{$noderef});
        }
    }
    if (CORBA::IDLtree::is_elementary_type $type_descr) {
        return "CORBA." . ucfirst($CORBA::IDLtree::predef_types[$type_descr]);
    }
    my @node = @{$type_descr};   # We are sure that it IS a node at this point
    if ($#node != 2) {
        return "<INTERNAL ERROR: mapped_type called with non-node>";
    } elsif ($node[$CORBA::IDLtree::TYPE] == $CORBA::IDLtree::BOUNDED_STRING) {
        return "CORBA.Bounded_String_" . $node[$CORBA::IDLtree::NAME] .
               ".Bounded_String";
    } elsif ($node[$CORBA::IDLtree::TYPE] == $CORBA::IDLtree::INTERFACE) {
        return $node[$CORBA::IDLtree::NAME] . ".Ref";
    }
    return $node[$CORBA::IDLtree::NAME];
}


sub espec {
    my $text = shift;
    print $psfh $text;
}

sub ebody {
    my $text = shift;
    print $pbfh $text;
}

sub eispec {
    my $text = shift;
    if ($gen_ispec[$#scopestack]) {
        print $isfh $text;
    }
}

sub eibody {
    my $text = shift;
    if ($gen_ibody[$#scopestack]) {
        print $ibfh $text;
    }
}

sub especs {
    my $text = shift;
    espec $text;
    eispec $text;
}

sub ebodies {
    my $text = shift;
    ebody $text;
    eibody $text;
}

sub eiboth {
    my $text = shift;
    eispec $text;
    eibody $text;
}

sub eboth {
    my $text = shift;
    espec $text;
    ebody $text;
}

sub eall {
    my $text = shift;
    especs $text;
    ebodies $text;
}

sub pspec {
    my $text = (' ' x ($INDENT * $spec_ilvl[$#spec_ilvl])) . shift;
    espec $text;
}

sub pbody {
    my $text = (' ' x ($INDENT * $body_ilvl[$#body_ilvl])) . shift;
    ebody $text;
}

sub pboth {
    my $text = shift;
    pspec $text;
    pbody $text;
}

sub pispec {
    my $text = (' ' x ($INDENT * $ispec_ilvl[$#ispec_ilvl])) . shift;
    eispec $text;
}

sub pibody {
    my $text = (' ' x ($INDENT * $ibody_ilvl[$#ibody_ilvl])) . shift;
    eibody $text;
}

sub piboth {
    my $text = shift;
    pispec $text;
    pibody $text;
}

sub pspecs {
    my $text = shift;
    pspec $text;
    pispec $text;
}

sub pbodies {
    my $text = shift;
    pbody $text;
    pibody $text;
}

sub pall {
    my $text = shift;
    pspecs $text;
    pbodies $text;
}

sub specindent {
    pspec shift;
    $spec_ilvl[$#spec_ilvl]++;
}

sub specdedent {
    $spec_ilvl[$#spec_ilvl]--;
    pspec shift;
}

sub print_specfile_prologue {
    my $pkgname = shift;
    pspec "----------------------------------------------------------------\n";
    pspec "-- WARNING:  This is generated Ada source that is automatically\n";
    pspec "--           overwritten when idl2ada.pl is run.\n";
    pspec "--           Changes to this file will be lost.\n";
    pspec "----------------------------------------------------------------\n";
    pspec "\n\n";
    pspec "with CORBA.Object;\n";
    pspec "with CORBA.Trader;\n";
    pspec "with CORBA.InterfaceDef;\n";
    pspec "with CORBA.ImplementationDef;\n\n";
}

sub print_bodyfile_prologue {
    my $pkgname = shift;
    pbody "----------------------------------------------------------------\n";
    pbody "-- WARNING:  This is generated Ada source that is automatically\n";
    pbody "--           overwritten when idl2ada.pl is run.\n";
    pbody "--           Changes to this file will be lost.\n";
    pbody "----------------------------------------------------------------\n";
    pbody "\n\n";
    pbody "with CORBA.Environment;\n";
    pbody "with System;\n";
    pbody "with Interfaces.C.Strings;\n";
    pbody "with Interfaces.C;\n\n";
}

sub print_ispecfile_prologue {
    my $pkgname = shift;
    pispec "----------------------------------------------------------------\n";
    pispec "-- $pkgname\.Impl (spec)\n";
    pispec "--\n";
    pispec "-- Changes to this file will not be overwritten by idl2ada.pl\n";
    pispec "----------------------------------------------------------------\n";
    pispec "\n\n";
}

sub print_ibodyfile_prologue {
    my $pkgname = shift;
    pibody "----------------------------------------------------------------\n";
    pibody "-- $pkgname\.Impl (body)\n";
    pibody "--\n";
    pibody "-- Changes to this file will not be overwritten by idl2ada.pl\n";
    pibody "----------------------------------------------------------------\n";
    pibody "\n\n";
    pibody "with CORBA.Environment;\n";
    pibody "with System.Address_To_Access_Conversions; \n";
    pibody "with Interfaces.C.Strings;\n";
    pibody "with Ada.Characters.Latin_1; \n";
    pibody "with CORBA.C_Memory;\n";
    pibody "with Interfaces.C;\n\n";
}


sub print_withlist {
    if (@withlist) {
        print $psfh "with";
        my $first = 1;
        foreach $w (@withlist) {
            if ($first) {
                $first = 0;
            } else {
                print $psfh ',';
            }
            print $psfh (' ' . $w);
        }
        print $psfh ";\n\n";
    }
}


sub print_pkg_prologues {
    my $pkgname = shift;
    my $is_module = 0;
    if (@_) {
        $is_module = shift;
    }
    push @spec_ilvl, 0;
    push @body_ilvl, 0;
    print_specfile_prologue($pkgname, $is_module);
    print_bodyfile_prologue($pkgname, $is_module);
    if (! $is_module) {
        if ($gen_ispec[$#scopestack]) {
            push @ispec_ilvl, 0;
            print_ispecfile_prologue($pkgname);
        }
        if ($gen_ibody[$#scopestack]) {
            push @ibody_ilvl, 0;
            print_ibodyfile_prologue($pkgname);
        }
    }
    print_withlist;
    push @withlist, $pkgname;
}


sub print_pkg_decl {
    my $name = shift;
    specindent "package $name is\n\n";
    pbody "package body $name is\n\n";
    $body_ilvl[$#body_ilvl]++;
    if ($gen_ispec[$#scopestack]) {
        pispec "package $name\.Impl is\n\n";
        $ispec_ilvl[$#ispec_ilvl]++;
    }
    if ($gen_ibody[$#scopestack]) {
        pibody "package body $name\.Impl is\n\n";
        $ibody_ilvl[$#ibody_ilvl]++;
    }
}

sub finish_pkg_decl {
    my $name = shift;
    my $spartan = 0;
    if (@_) {
        $spartan = 1;
    }
    specdedent "end $name;\n\n";
    $body_ilvl[$#body_ilvl]--;
    pbody "end $name;\n\n";
    close $psfh;
    close $pbfh;
    if ($spartan) {
        return;
    }
    pop @spec_ilvl;
    pop @body_ilvl;
    if ($gen_ispec[$#scopestack]) {
        $ispec_ilvl[$#ispec_ilvl]--;
        pispec "end $name\.Impl;\n\n";
        close $isfh;
        pop @ispec_ilvl;
    }
    if ($gen_ibody[$#scopestack]) {
        $ibody_ilvl[$#ibody_ilvl]--;
        pibody "end $name\.Impl;\n\n";
        close $ibfh;
        pop @ibody_ilvl;
    }
    pop @scopestack;
    if (@scopestack) {
        $psfh = $proxy_spec_file_handle[$#scopestack];
        $pbfh = $proxy_body_file_handle[$#scopestack];
        if ($gen_ispec[$#scopestack]) {
            $isfh = $impl_spec_file_handle[$#scopestack];
        }
        if ($gen_ibody[$#scopestack]) {
            $ibfh = $impl_body_file_handle[$#scopestack];
        }
    }
}


sub print_spec_interface {
    my $iface = shift;
    my $ancestor = shift;
    # specindent "package $iface is\n\n";
    pspec "type Ref is new ";
    if (@{$ancestor}) {
        espec ${$ancestor}[$CORBA::IDLtree::NAME];
    } else {
        espec "CORBA.Object.Ref";
    }
    espec " with null record;\n\n";
    pspec "Typename : constant CORBA.String := CORBA.To_Unbounded_String (";
    espec "\"$iface\");\n\n";
    pspec "-- Narrow/Widen functions\n";
    pspec "--\n";
    pspec "function To_Ref (From: in CORBA.Object.Ref'CLASS) return Ref;\n";
    pspec "function To_Ref (From: in CORBA.Any) return Ref;\n";
    pspec "\n";
    pspec "-- CW/Ada specific functions\n";
    pspec "function Import (Trader  : CORBA.Trader.Ref;\n";
    pspec "                 Context : CORBA.String;\n";
    pspec "                 Propbuf : CORBA.String) return Ref;\n";
    pspec "function Get_Interface return CORBA.InterfaceDef.Ref;\n";
    pspec "function Get_Implementation return CORBA.ImplementationDef.Ref;\n";
    pspec "\n";
}

sub print_body_interface {
    my $iface = shift;
    # pbody "package body $iface is\n\n";
    # $body_ilvl[$#body_ilvl]++;
    pbody "function To_Ref (From: in CORBA.Any) return Ref is\n";
    pbody "  Temp: Ref;\n";
    pbody "begin\n";
    pbody "      -- Not yet implemented\n";
    pbody "      --  \n";
    pbody "  return Temp;\n";
    pbody "end To_Ref;\n";
    pbody "\n\n";
    pbody "function To_Ref (From: in CORBA.Object.Ref'CLASS) return Ref is\n";
    pbody "begin\n";
    pbody "  return Ref (From);\n";
    pbody "end To_Ref;\n";
    pbody "\n\n";
    pbody "function Import\n";
    pbody "          (Trader     : in     CORBA.Trader.Ref;\n";
    pbody "           Context    : in     CORBA.String;\n";
    pbody "           Propbuf    : in     CORBA.String)\n";
    pbody "      return Ref is\n";
    pbody "begin\n";
    pbody "  return Ref'(CORBA.Trader.Import (Trader, Typename, Context, Propbuf)\n";
    pbody "              with null record);\n";
    pbody "end Import;\n";
    pbody "\n\n";
    pbody "function Get_Interface return CORBA.InterfaceDef.Ref is\n";
    pbody "\n";
    pbody "  procedure $iface\_Dispatcher (Attr: System.Address; Buf: System.Address);\n";
    pbody "  pragma Import (C, $iface\_Dispatcher, \"$iface\_Dispatcher\");\n";
    pbody "  Result: CORBA.InterfaceDef.Ref;\n";
    pbody "\n";
    pbody "begin\n";
    pbody "  CORBA.InterfaceDef.Set_C_Ref (Result, $iface\_Dispatcher'Address);\n";
    pbody "  return Result;\n";
    pbody "end Get_Interface;\n";
    pbody "\n\n";
    pbody "function Get_Implementation return CORBA.ImplementationDef.Ref is\n";
    pbody "  Result : CORBA.ImplementationDef.Ref;\n";
    pbody "begin\n";
    pbody "  CORBA.ImplementationDef.Set_C_Ref (Result, System.Null_Address);\n";
    pbody "  return Result;\n";
    pbody "end Get_Implementation;\n";
    pbody "\n\n";
}

sub print_ispec_interface {
    my $iface = shift;
    my $ancestor = 0;
    if (@_) {
        $ancestor = shift;
    }
    # pispec "package $iface\.Impl is\n\n";
    # $ispec_ilvl[$#ispec_ilvl]++;
    pispec "type Object is new ";
    if ( $ancestor and @{$ancestor}) {   # multi-inheritance TBD
        eispec ${$ancestor}[$CORBA::IDLtree::NAME];
    } else {
        eispec "CORBA.Object.Object";
    }
    eispec " with private;\n\n";
}

sub print_ibody_interface {
    my $iface = shift;
    # pibody "package body $iface\.Impl is\n\n";
    # $ibody_ilvl[$#ibody_ilvl]++;
    # pibody "procedure Export\n";
    # pibody "          (Trader     : in     CORBA.Trader.Ref;\n";
    # pibody "           Context    : in     CORBA.String;\n";
    # pibody "           Propbuf    : in     CORBA.String;\n";
    # pibody "           Object     : access Ref) is\n";
    # pibody "begin\n";
    # pibody "  CORBA.Trader.Export (Trader, Typename, Context, Propbuf, Object);\n";
    # pibody "end Export;\n";
    # pibody "\n\n";
}

sub print_interface_prologues {
    my $ancestor = shift;
    my $adaname = join ".", @scopestack;
    print_pkg_decl $adaname;
    print_spec_interface($adaname, $ancestor);
    print_body_interface $adaname;
    print_ispec_interface($adaname, $ancestor);
    print_ibody_interface $adaname;
}


sub open_files {
    my $name = shift;
    my $type = shift;
    push @scopestack, $name;
    my $basename = lc(join "-", @scopestack);
    my $specfile = $basename . ".ads";
    my $bodyfile = $basename . ".adb";
    $psfh = $proxy_spec_file_handle[$#scopestack];
    $pbfh = $proxy_body_file_handle[$#scopestack];
    open($psfh, ">$specfile") or die "cannot create file $specfile\n";
    open($pbfh, ">$bodyfile") or die "cannot create file $bodyfile\n";
    if ($type == $CORBA::IDLtree::INTERFACE) {
        my $ispecfile = $basename . "-impl.ads";
        my $ibodyfile = $basename . "-impl.adb";
        if (-e $ispecfile) {
            $gen_ispec[$#scopestack] = 0;
        } else {
            $isfh = $impl_spec_file_handle[$#scopestack];
            open($isfh, ">$ispecfile") or die "cannot create $ispecfile\n";
            $gen_ispec[$#scopestack] = 1;
        }
        if (-e $ibodyfile) {
            if ($gen_ispec[$#scopestack]) {
                print "$ispecfile does not exist, but $ibodyfile does\n";
                print "         => generating only $ispecfile\n";
            } elsif ($verbose) {
                print "not generating $basename implementation files ";
                print "because they already exist\n";
            }
            $gen_ibody[$#scopestack] = 0;
        } else {
            $ibfh = $impl_body_file_handle[$#scopestack];
            open($ibfh, ">$ibodyfile") or die "cannot create $ibodyfile\n";
            if (! $gen_ispec[$#scopestack]) {
                print "$ispecfile does exist, but $ibodyfile does not\n";
                print "         => generating only $ibodyfile\n";
            }
            $gen_ibody[$#scopestack] = 1;
        }
    }
    print_pkg_prologues(join(".", @scopestack),
                        $type == $CORBA::IDLtree::MODULE);
}


$globuf = "";

sub charlit {
    my $input = shift;
    my $pos = 0;
    if ($input !~ /^\\/) {
        $globuf = substr($input, $pos, 1);
        return 1;
    }
    my $ch = substr($input, ++$pos, 1);
    my $consumed = 2;
    my $output = "";
    if ($ch eq 'n') {
        $output = '.LF';
    } elsif ($ch eq 't') {
        $output = '.HT';
    } elsif ($ch eq 'v') {
        $output = '.VT';
    } elsif ($ch eq 'b') {
        $output = '.BS';
    } elsif ($ch eq 'r') {
        $output = '.CR';
    } elsif ($ch eq 'f') {
        $output = '.FF';
    } elsif ($ch eq 'a') {
        $output = '.BEL';
    } elsif ($ch eq 'x') {         # hex number
        my $tuple = substr($input, ++$pos, 2);
        if ($tuple !~ /[0-9a-f]{2}/i) {
            $output = $ch;
            print "unknown escape \\x$tuple in string\n";
        } else {
            $output = "'val (16#" . $tuple . "#)";
            $consumed += 2;
        }
    } elsif ($ch eq '0' or $ch eq '1') {     # octal number
        my $triple = substr($input, $pos, 3);
        if ($triple !~ /[0-7]{3}/) {
            $output = $ch;
            print "unknown escape \\$triple in string\n";
        } else {
            $output = "'val (8#" . $triple . "#)";
            $consumed += 2;
        }
    } else {
        $output = $ch;
        print("unknown escape \\$ch in string\n") if ($ch =~ /[0-9A-z]/);
    }
    $globuf = 'Ada.Characters.Latin_1' . $output;
    return $consumed;
}

sub cvt_expr {
    my $lref = shift;
    my $output = "";
    
    foreach $input (@$lref) {
# print "cvt input = $input\n";
        my $ch = substr($input, 0, 1);
        if ($ch eq '"') {
            my $need_endquote = 1;
            $output .= '"';
            my $i;
            for ($i = 1; $i < length($input) - 1; $i++) {
                my $consumed = charlit(substr($input, $i));
                $i += $consumed - 1;
                if ($consumed > 1) {
                    $output .= '" & ';
                }
                $output .= $globuf;
                if ($consumed > 1) {
                    if ($i >= length($input) - 2) {
                        $need_endquote = 0;
                    } else {
                        # We had an escape, and are not yet at the end, so
                        # need to reopen the string
                        $output .= ' & "';
                    }
                }
            }
            if ($need_endquote) {
                $output .= '"';
            }
        } elsif ($ch eq "'") {
            my $consumed = charlit(substr($input, 1));
            if ($consumed == 1) {
                $output .= " '" . $globuf . "'";
            } else {
                $output .= " " . $globuf;
            }
        } elsif ($ch =~ /\d/) {
            if ($ch eq '0') {                   # check for hex/octal
                my $nxt = substr($input, 1, 1);
                if ($nxt eq 'x') {                  # hex const
                    $output .= ' 16#' . substr($input, 2) . '#';
                    next;
                } elsif ($nxt =~ /[0-7]/) {         # octal const
                    $output .= ' 8#' . substr($input, 1) . '#';
                    next;
                }
            }
            $output .= ' ' . $input;
        } elsif ($ch eq '.') {
            $output .= '0' . $input;
        } elsif ($input =~ /;/) {
            print "where the hell does this semicolon come from ?!?\n";
        } else {
            $output .= ' ' . $input;
        }
    }
    return $output;
}


sub check_sequence {
    my $type_descriptor = shift;
    my $scoperef = shift;
    if (! CORBA::IDLtree::isnode($type_descriptor)) {
        return mapped_type($type_descriptor, $scoperef);
    }
    my @node = @{$type_descriptor};
    my $element_type = $node[$CORBA::IDLtree::SUBORDINATES];
    my $eletypnam = mapped_type($element_type, $scoperef);
    if ($node[$CORBA::IDLtree::TYPE] != $CORBA::IDLtree::SEQUENCE) {
        return $eletypnam;
    }
    check_sequence($element_type, $scoperef);
    my $idltypnam = CORBA::IDLtree::typeof($element_type, $scoperef);
    $idltypnam =~ s/sequence<(.*)>/Seq_\1/;
    my $arrtypnam = "Seq_" . $idltypnam . "_Array";
    pspec "type $arrtypnam is array (Integer range <>) of $eletypnam;\n";
    my $bound = $node[$CORBA::IDLtree::NAME];
    my $pkgname = "Seq";
    if ($bound) {
        $pkgname .= "_" . $bound;
    }
    $pkgname .= "_" . $idltypnam;
    pspec "package $pkgname is new CORBA.Sequences.";
    espec(($bound ? "Bounded" : "Unbounded") . "\n");
    $spec_ilvl[$#spec_ilvl] += $INDENT2;
    pspec "($eletypnam, $arrtypnam";
    espec(", " . $bound) if ($bound);
    espec ");\n\n";
    $spec_ilvl[$#spec_ilvl] -= $INDENT2;
    return($pkgname . ".Sequence");
}


sub gen_ada_recursive {
    my $symroot = shift;

    if (! $symroot) {
        print "\ngen_ada: encountered empty elem (returning)\n";
        return;
    } elsif (not ref $symroot) {
        print "\ngen_ada: incoming symroot is $symroot (returning)\n";
        return;
    }
    if (not CORBA::IDLtree::isnode $symroot) {
        foreach $elem (@{$symroot}) {
            gen_ada_recursive $elem;
        }
        return;
    }
    my @node = @{$symroot};
    my $name = $node[$CORBA::IDLtree::NAME];
    my $type = $node[$CORBA::IDLtree::TYPE];
    my $subord = $node[$CORBA::IDLtree::SUBORDINATES];
    my @arg = @{$subord};
    if ($type == $CORBA::IDLtree::TYPEDEF) {
        my $typeref = $arg[0];
        my $dimref = $arg[1];
        my $adatype = check_sequence($typeref, $subord);
        pspec "type $name is ";
        if ($dimref and @{$dimref}) {
            espec "array (";
            my $is_first_dim = 1;
            foreach $dim (@{$dimref}) {
                if ($dim !~ /\D/) {   # if the dim is a number
                    $dim--;           # then modify that number directly
                } else {
                    $dim .= " - 1" ;  # else leave it to the Ada compiler
                }
                if ($is_first_dim) {
                    $is_first_dim = 0;
                } else {
                    espec ", ";
                }
                espec("0.." . $dim);
            }
            espec ") of ";
        } else {
            espec "new ";
        }
        espec "$adatype;\n\n";
    } elsif ($type == $CORBA::IDLtree::CONST) {
        pspec("$name : constant " . mapped_type($arg[0], $subord) .
              " := " . cvt_expr($arg[1]) . ";\n\n");
    } elsif ($type == $CORBA::IDLtree::ENUM) {
        pspec("type $name is ");
        my $enum_literals = join(', ', @arg);
        if (length($name) + length($enum_literals) < 65) {
            espec "($enum_literals);\n\n";
        } else {
            espec "\n";
            my $first = 1;
            $spec_ilvl[$#spec_ilvl] += $INDENT2 - 1;
            foreach $lit (@arg) {
                if ($first) {
                    pspec "  ($lit";
                    $spec_ilvl[$#spec_ilvl]++;
                    $first = 0;
                } else {
                    espec ",\n";
                    pspec $lit;
                }
            }
            espec ");\n\n";
            $spec_ilvl[$#spec_ilvl] -= $INDENT2;
        }
    } elsif ($type == $CORBA::IDLtree::STRUCT ||
             $type == $CORBA::IDLtree::UNION ||
             $type == $CORBA::IDLtree::EXCEPTION) {
        # First, generate array and sequence type declarations if necessary
        my $i = ($type == $CORBA::IDLtree::UNION ? 1 : 0);
        my @adatype = ();
        for (; $i <= $#arg; $i++) {
            my @node = @{$arg[$i]};
            my $type = $node[$CORBA::IDLtree::TYPE];
            next if ($type == $CORBA::IDLtree::CASE or
                     $type == $CORBA::IDLtree::DEFAULT);
            push @adatype, check_sequence($type, $arg[$i]);
            my $dimref = $node[$CORBA::IDLtree::SUBORDINATES];
            if ($dimref and @{$dimref}) {
                my $name = $node[$CORBA::IDLtree::NAME];
                pspec("type " . $name . "_Array is array (");
                my $is_first_dim = 1;
                foreach $dim (@{$dimref}) {
                    if ($dim !~ /\D/) {   # if the dim is a number
                        $dim--;           # then modify that number directly
                    } else {
                        $dim .= " - 1" ;  # else leave it to the Ada compiler
                    }
                    if ($is_first_dim) {
                        $is_first_dim = 0;
                    } else {
                        espec ", ";
                    }
                    espec("0.." . $dim);
                }
                espec(") of " . $adatype[$#adatype] . ";\n\n");
            }
        }
        # Now comes the actual struct/union/exception
        my $need_end_record = 1;
        if ($type == $CORBA::IDLtree::EXCEPTION) {
            pspec "$name : exception;\n\n";
            pspec "type $name\_Members is new CORBA.IDL_Exception_Members ";
            if (@arg) {
                espec "with record\n"
            } else {
                espec "with null record;\n\n";
                $need_end_record = 0;
            }
        } else {
            pspec "type $name ";
            if ($type == $CORBA::IDLtree::UNION) {
                my $adatype = mapped_type(shift @arg, $subord);
                espec "(Switch : $adatype := $adatype\'first) ";
            }
            espec "is record\n";
        }
        if ($need_end_record) {
            $spec_ilvl[$#spec_ilvl]++;
            my $had_case = 0;
            while (@arg) {
                my $node = shift @arg;
                my $name = $$node[$CORBA::IDLtree::NAME];
                my $type = $$node[$CORBA::IDLtree::TYPE];
                my $suboref = $$node[$CORBA::IDLtree::SUBORDINATES];
                if ($type == $CORBA::IDLtree::CASE or
                    $type == $CORBA::IDLtree::DEFAULT) {
                    if ($had_case) {
                        $spec_ilvl[$#spec_ilvl]--;
                    } else {
                        $had_case = 1;
                    }
                    if ($type == $CORBA::IDLtree::CASE) {
                        pspec "when ";
                        my $first_case = 1;
                        foreach $case (@{$suboref}) {
                            if ($first_case) {
                                $first_case = 0;
                            } else {
                                espec "| ";
                            }
                            espec "$case ";
                        }
                        espec "=>\n";
                    } else {
                        pspec "when others =>\n";
                    }
                    $spec_ilvl[$#spec_ilvl]++;
                } else {
                    pspec($name . " : " . shift(@adatype) . ";\n");
                }
            }
            $spec_ilvl[$#spec_ilvl] -= $had_case;
            specdedent "end record;\n\n";
        }
        if ($type == $CORBA::IDLtree::EXCEPTION) {
            pspec("procedure Get_Members (From : in " .
                  "Ada.Exceptions.Exception_Occurrence;\n");
            pspec "                       To : out $name\_Members);\n\n";
        }
    } elsif ($type == $CORBA::IDLtree::INCFILE) {
        $name =~ s/\.idl//i;
        pspec "with $name;\n";
    } elsif ($type == $CORBA::IDLtree::MODULE) {
        open_files($name, $type);
        my $adaname = join ".", @scopestack;
        print_pkg_decl $adaname;
        foreach $declaration (@arg) {
            gen_ada_recursive $declaration;
        }
        finish_pkg_decl $adaname;
    } elsif ($type == $CORBA::IDLtree::INTERFACE) {
        my $ancestor_ref = $arg[0];
        open_files($name, $type);
        print_interface_prologues($ancestor_ref);
        # For each attribute, a private member variable will be added
        # to the implementation object type.
        my @attributes = ();
        foreach $decl (@{$arg[1]}) {
            gen_ada_recursive $decl;
            if (CORBA::IDLtree::isnode($decl) and
                ${$decl}[$CORBA::IDLtree::TYPE] == $CORBA::IDLtree::ATTRIBUTE) {
                push @attributes, $decl;
            }
        }
        if ($gen_ispec[$#scopestack]) {
            $ispec_ilvl[$#ispec_ilvl]--;
            pispec "private\n";
            $ispec_ilvl[$#ispec_ilvl]++;
            pispec "type Object is new ";
            if (@{$ancestor_ref}) {
                my $first_ancestor_node = ${$ancestor_ref}[0];
                eispec ${$first_ancestor_node}[$CORBA::IDLtree::NAME];
                # multiple inheritance: TBD
            } else {
                eispec "CORBA.Object.Object";
            }
            if (@attributes) {
                eispec " with record\n";
                $ispec_ilvl[$#ispec_ilvl]++;
                foreach $attr_ref (@attributes) {
                    my $name = ${$attr_ref}[$CORBA::IDLtree::NAME];
                    my $subord = ${$attr_ref}[$CORBA::IDLtree::SUBORDINATES];
                    my $typename = mapped_type(${$subord}[1], $subord);
                    pispec "$name : $typename;";
                    eispec("   -- IDL: readonly") if (${$subord}[0]);
                    eispec "\n";
                }
                $ispec_ilvl[$#ispec_ilvl]--;
                pispec "end record;\n\n";
            } else {
                pispec " with null record;\n\n";
            }
        }
        finish_pkg_decl $adaname;

    } elsif ($type == $CORBA::IDLtree::ATTRIBUTE) {
        my $readonly = $arg[0];
        my $typename = mapped_type($arg[1], $subord);
        pall    "function Get_$name (Self : ";
        eboth   "Ref";
        eiboth  "access Object";
        eall    ") return $typename";
        especs  ";\n";
        ebodies " is\n";
        pbodies "begin\n";
        pbody   "  null;  -- To Be Done\n";
        pibody  "  return Self.$name;\n";
        pbodies "end Get_$name;\n\n";
        if ($readonly) {
            especs "\n";
            return;
        }
        pall    "procedure Set_$name (Self : ";
        eboth   "Ref";
        eiboth  "access Object";
        eall    "; To : $typename)";
        especs  ";\n\n";
        ebodies " is\n";
        pbodies "begin\n";
        pbody   "  null;  -- To Be Done\n";
        pibody  "  Self.$name := To;\n";
        pbodies "end Set_$name;\n\n"
    } elsif ($type == $CORBA::IDLtree::METHOD) {
        my $rettype = shift @arg;
        if ($rettype == $CORBA::IDLtree::ONEWAY) {
            pspecs "-- oneway\n";
            $rettype = $CORBA::IDLtree::VOID;
        }
        if ($rettype == $CORBA::IDLtree::VOID) {
            pall "procedure ";
        } else {
            pall "function  ";
        }
        eall(sprintf "%-12s (Self : ", $name);
        eboth "in Ref";
        eiboth "access Object";
        if ($#arg > 0) {
            eall ";\n";
            $spec_ilvl[$#spec_ilvl] += $INDENT2;
            $body_ilvl[$#body_ilvl] += $INDENT2;
            $ispec_ilvl[$#ispec_ilvl] += $INDENT2;
            $ibody_ilvl[$#ibody_ilvl] += $INDENT2;
            while ($#arg > 0) {
                my $pnode = shift @arg;
                my $ptype = mapped_type($$pnode[$CORBA::IDLtree::TYPE], $pnode);
                my $pname = $$pnode[$CORBA::IDLtree::NAME];
                my $m     = $$pnode[$CORBA::IDLtree::SUBORDINATES];
                my $pmode = ($m == $CORBA::IDLtree::IN ? 'in' :
                             $m == $CORBA::IDLtree::OUT ? 'out' : 'in out');
                pall "$pname : $pmode $ptype";
                eall(";\n") if ($#arg > 0);
            }
            $spec_ilvl[$#spec_ilvl] -= $INDENT2;
            $body_ilvl[$#body_ilvl] -= $INDENT2;
            $ispec_ilvl[$#ispec_ilvl] -= $INDENT2;
            $ibody_ilvl[$#ibody_ilvl] -= $INDENT2;
        }
        eall ")";
        if ($rettype != $CORBA::IDLtree::VOID) {
            pall("\n                    return " .
                 mapped_type($rettype, $subord));
        }
        especs  ";\n";
        ebodies " is\n";
        pbodies "begin\n";
        pbody   "  null;  -- To Be Done\n";
        pibody  "  null;  -- dear user, please fill me in\n";
        pbodies "end $name;\n\n";
        my @exc_list = @{shift @arg};  # last element in arg is exception list
        if (@exc_list) {
            pspecs "-- raises (";
            foreach $exc (@exc_list) {
                especs(${$exc}[$CORBA::IDLtree::NAME] . " ");
            }
            especs ")\n";
        }
        especs "\n";
    } else {
        print "gen_ada: unknown type value $type\n";
    }
}


sub gen_ada {
    my $symtree = shift;
    my $seen_global_scope = 0;
    @withlist = ();
    if (CORBA::IDLtree::isnode $symtree) {
        my $type = ${$symtree}[$CORBA::IDLtree::TYPE];
        my $name = ${$symtree}[$CORBA::IDLtree::NAME];
        if ($type != $CORBA::IDLtree::MODULE and
            $type != $CORBA::IDLtree::INTERFACE) {
            print "$name: expecting MODULE or INTERFACE\n";
            return;
        }
        $did_file_prologues = 0;
        gen_ada_recursive $symtree;
        return;
    } elsif (not ref $symtree) {
        print "\ngen_ada: unsupported declaration $symtree (returning)\n";
        return;
    }
    foreach $noderef (@{$symtree}) {
        my $type = ${$noderef}[$CORBA::IDLtree::TYPE];
        my $name = ${$noderef}[$CORBA::IDLtree::NAME];
        my $suboref = ${$noderef}[$CORBA::IDLtree::SUBORDINATES];
        $did_file_prologues = 0;
        if ($type == $CORBA::IDLtree::MODULE or
            $type == $CORBA::IDLtree::INTERFACE) {
            gen_ada_recursive $noderef;
        } elsif ($type == $CORBA::IDLtree::INCFILE) {
            my @incnodes = @{$suboref};
            if ($#incnodes > 0) {
                print("includefile $name: idl2ada.pl does not support " .
                      "multiple file scoped declarations.\n");
                print("Please put all declarations inside a single " .
                      "MODULE or INTERFACE\n");
            } elsif (not CORBA::IDLtree::isnode($incnodes[0])) {
                print("includefile $name: idl2ada.pl does not support " .
                      "file scoped declarations.\n");
                print("Please put all declarations inside a MODULE or " .
                      "INTERFACE\n");
            } else {
                my $inner_type = ${$incnodes[0]}[$CORBA::IDLtree::TYPE];
                if ($inner_type != $CORBA::IDLtree::MODULE and
                    $inner_type != $CORBA::IDLtree::INTERFACE) {
                    print("enclosing definition in $name must be either a " .
                          "MODULE or INTERFACE\n");
                } else {
                    push @withlist, ${$incnodes[0]}[$CORBA::IDLtree::NAME];
                }
            }
        } else {
            if (not $seen_global_scope) {
                $global_scope_pkgname = $idl_filename;
                $global_scope_pkgname =~ s/\.idl$//;
                $global_scope_pkgname =~ s/\W/_/g;
                $global_scope_pkgname .= "_IDL_File";
                open_files($global_scope_pkgname, $CORBA::IDLtree::MODULE);
                ###############################################################
                # Remove myself from the scope stack so that modules/interfaces
                # defined in this file will not be children of ..._IDL_File.
                pop @scopestack;
                ###############################################################
                print_withlist;
                print_pkg_decl $global_scope_pkgname;
                $seen_global_scope = 1;
            }
            gen_ada_recursive $noderef;
        }
    }
    if ($seen_global_scope) {
        finish_pkg_decl($global_scope_pkgname, 1);
    }
}

# The End.