#!/usr/bin/perl
#
#  Unit Interface Generator
#
#  $0 file.pas
#  - makes a unit int/file.pas which is compilable and
#    interface compatible, but does not have a real
#    implementation part
#

my $iface;
my $ok = 0;
my $fname = shift @ARGV or die "usage: $0 filename.pas";

open IN, "< $fname" or die "can't open $fname: $!";
while (<IN>) {
    if (/^implementation\b/i) {
        $iface .= $`;
        &emit (0, $iface, "int/$fname");
        $ok = 1;
        last;
    } else {
        $iface .= $_;
    }
}
if (!$ok) {
    &emit (1, $iface, "int/$fname");
}
exit 0;

sub emit {
    my $prog = shift;
    my $src = shift;
    my $outfname = shift;
    my $scope = "";
    my @protos;                   # list of prototypes
    my $name = "";
    while ($src ne "") {
        # chew certain tokens
        if ($src =~ s/^\{\$ifn?def[^\}]*\}//i || $src =~ s/^\{\$(else|endif)[^\}]*\}//i) {
            push @protos, "$&\n";
        } elsif ($src =~ s/^\{[^\}]*\}// || $src =~ s/^\s+// ||
            $src =~ s/^\(\*([^\*]|\*[^\)])*\*+\)// ||
            $src =~ s/^('[^']*')+//) {
        } elsif ($src =~ s/^unit\s*(\w+);//i) {
            $name = $1;
        } elsif ($src =~ s/^(\w+)\s*=\s*object\b//i) {
            $scope = "$1.";
        } elsif ($src =~ s/^(PROCEDURE|FUNCTION|CONSTRUCTOR|DESTRUCTOR)\s+(\w+)\s*((\([^\)]+\))?(\s*:\s*\w+)?)\s*;//i) {
            my $line = "$1 $scope$2$3;";
            next if $src =~ s/^\s*inline//i;
            push @protos, "$line\nBEGIN END;\n\n";
        } elsif ($src =~ s/^end\s*;//i) {
            $scope = "";
        } elsif ($prog && $src =~ s/^uses\b[^;]+;//i) {
            print STDERR "-- program --\n";
            # print $&, "\nBEGIN END.\n";
            return;
        } else {
            ($src =~ s/^\w+// || $src =~ s/^.//)
#                 && print "$&\n"
            ;
        }
    }

    if ($prog) {
        print STDERR "-- program w/o uses clause --\n";
        return;
    }

    open OUT, "> $outfname" or die "can't create $outfname: $!";
    print OUT $iface, "\nIMPLEMENTATION\n\n", @protos, "\nBEGIN
  Writeln('ERROR: stub module $name');
  Halt(255);
END.\n\n";
    close OUT;
}