#!/usr/bin/perl -w

use warnings;

use strict;

my %typesizes = (

'LONG' => 4,

'ULONG' => 4,

'SHORT' => 2,

'USHORT' => 2,

'HVIO' => 2,

'HKBD' => 2,

);

sub typesize {

my $t = shift;

return 4 if ($t =~ /\AP/); # pointers are 4 bytes (16:16).

die("Unknown type '$t', please update \%typesizes\n") if not defined $typesizes{$t};

return $typesizes{$t};

}

my $dirname = defined $ARGV[0] ? $ARGV[0] : 'native';

opendir(DIRH, $dirname) or die("Failed to opendir '$dirname': $!\n");

while (readdir(DIRH)) {

next if not /\.h\Z/;

next if /\Aos2/;

next if /\-lx\.h\Z/;

my $module = $_;

my $header = "$dirname/$module";

$module =~ s/\.h\Z//;

open(IN, '<', $header) or die("Failed to open '$header' for reading: $!\n");

print("$module ...\n");

my %ordinalmap = ();

my $has16bitfns = 0;

while (<IN>) {

chomp;

next if not /OS2APIINFO/;

my $line = $_;

if (/\AOS2EXPORT\s+(.*?)\s+(OS2API|OS2API16)\s+(.*?)\((.*?)\)\s+OS2APIINFO\((.*?)\);/) {

my %table = (

'rettype' => $1,

'apitype' => $2,

'fn' => $3,

'args' => $4,

);

my $apiinfo = $5;

my $is16bit = $table{'apitype'} eq 'OS2API16';

$table{'is16bit'} = $is16bit;

$has16bitfns |= $is16bit;

#print("rettype='$rettype' fn='$fn' args='$args' apiinfo='$apiinfo'\n");

my $fn = $table{'fn'};

my $ordinal = undef;

my $expname = undef;

if ($apiinfo =~ /\A(\d+)\Z/) {

$ordinal = int($1);

} else {

foreach (split(/,/, $apiinfo)) {

#print("apiinfoarg: '$_'\n");

my ($infokey, $infoval) = /\A(.*?)\=(.*)\Z/;

#print("apiinfo key='$infokey' val='$infoval'\n");

if ($infokey eq 'ord') {

if ($infoval =~ /\A(\d+)\Z/) {

$ordinal = int($1);

} else {

die("Invalid ordinal '$infoval' for '$fn'\n");

}

} elsif ($infokey eq 'name') {

$expname = $infoval;

} else {

die("unknown OS2APIINFO key '$infokey' for '$fn'\n");

}

}

}

$table{'ordinal'} = $ordinal;

if (defined $ordinalmap{$ordinal}) {

my $dupfn = $ordinalmap{$ordinal}{'fn'};

die("Duplicate ordinal #$ordinal between '$fn' and '$dupfn'\n");

}

$ordinalmap{$ordinal} = \%table;

} else {

die ("Couldn't parse:\n\n $line\n\n")

}

}

close(IN);

next if (not %ordinalmap); # no exported items?

#use Data::Dumper qw(Dumper); print Dumper \%ordinalmap;

# Here we go...

my $finalfname = "$dirname/$module-lx.h";

my $outfname = "$finalfname-new";

open(OUT, '>', $outfname) or die("Failed to open '$outfname' for writing: $!\n");

print OUT <<EOF

/**

* 2ine; an OS/2 emulator for Linux.

*

* Please see the file LICENSE.txt in the source's root directory.

*/

/* THIS FILE IS AUTOGENERATED. DO NOT EDIT BY HAND. see lxapigen.pl */

/* This is glue code for OS/2 binaries. Native binaries don't need this. */

#if LX_LEGACY

EOF

;

foreach (sort { $a <=> $b } keys(%ordinalmap) ) {

my $tableref = $ordinalmap{$_};

my $fn = $tableref->{'fn'};

my $argstr = $tableref->{'args'};

my $rettype = $tableref->{'rettype'};

my $is16bit = $tableref->{'is16bit'};

my @args = ();

if (($argstr ne 'VOID') and ($argstr ne 'void')) {

@args = split /,/, $argstr;

}

# Build a little wrapper that'll pull arguments off the stack and

# convert to whatever the native calling conventions are.

if ($is16bit) {

print OUT "static $rettype bridge16to32_$fn(uint8 *args) {\n";

#foreach (@args) {

# arguments are listed backwards here.

for my $i (reverse 0..$#args) {

my $arg = $args[$i];

my ($t, $n) = $arg =~ /\A\s*(.*?)\s+(.*?)\s*\Z/;

#print("arg='$_' t='$t' n='$n'\n");

my $a = ($t =~ /\AP/) ? 'PTRARG' : 'ARG'; # it's a pointer?

print OUT " LX_NATIVE_MODULE_16BIT_BRIDGE_$a($t, $n);\n";

}

print OUT " ";

if (($rettype ne 'void') && ($rettype ne 'VOID')) {

# Currently it's reasonable to assume the retval will land in EAX.

print OUT "return ";

}

print OUT "$fn(";

my $comma = '';

foreach (@args) {

my ($t, $n) = /\A\s*(.*?)\s+(.*?)\s*\Z/;

print OUT "$comma$n";

$comma = ', ';

}

print OUT ");\n";

print OUT "}\n\n";

}

}

if ($has16bitfns) {

print OUT "LX_NATIVE_MODULE_16BIT_SUPPORT()\n";

foreach (sort { $a <=> $b } keys(%ordinalmap) ) {

my $tableref = $ordinalmap{$_};

next if not $tableref->{'is16bit'};

my $fn = $tableref->{'fn'};

print OUT " LX_NATIVE_MODULE_16BIT_API($fn)\n";

}

print OUT "LX_NATIVE_MODULE_16BIT_SUPPORT_END()\n";

print OUT "\n";

print OUT "LX_NATIVE_MODULE_DEINIT({\n";

print OUT " LX_NATIVE_MODULE_DEINIT_16BIT_SUPPORT();\n";

print OUT "})\n";

print OUT "\n";

print OUT "static int init16_$module(void) {\n";

print OUT " LX_NATIVE_MODULE_INIT_16BIT_SUPPORT()\n";

foreach (sort { $a <=> $b } keys(%ordinalmap) ) {

my $tableref = $ordinalmap{$_};

next if not $tableref->{'is16bit'};

my $fn = $tableref->{'fn'};

my $argstr = $tableref->{'args'};

my $argbytes = 0;

my @args = ();

if (($argstr ne 'VOID') and ($argstr ne 'void')) {

@args = split /,/, $argstr;

}

foreach (@args) {

my ($t, $n) = /\A\s*(.*?)\s+(.*?)\s*\Z/;

$argbytes += typesize($t);

}

print OUT " LX_NATIVE_INIT_16BIT_BRIDGE($fn, $argbytes)\n";

}

print OUT " LX_NATIVE_MODULE_INIT_16BIT_SUPPORT_END()\n";

print OUT " return 1;\n";

print OUT "}\n\n";

}

print OUT "LX_NATIVE_MODULE_INIT(";

if ($has16bitfns) {

print OUT "{ if (!init16_$module()) return 0; }";

}

print OUT ")\n";

my $comma = '';

foreach (sort { $a <=> $b } keys(%ordinalmap) ) {

my $tableref = $ordinalmap{$_};

my $fn = $tableref->{'fn'};

my $ordinal = $tableref->{'ordinal'};

my $suffix = $tableref->{'is16bit'} ? '16' : '';

print OUT $comma;

if (defined $expname) {

print OUT " LX_NATIVE_EXPORT${suffix}_DIFFERENT_NAME($fn, \"$expname\", $ordinal)";

}

$comma = ",\n";

}

print OUT "\n";

print OUT <<EOF

LX_NATIVE_MODULE_INIT_END()

#endif /* LX_LEGACY */

/* end of $module-lx.h ... */

EOF

;

close(OUT);

rename($outfname, $finalfname) or die("Failed to rename '$outfname' to '$finalfname': $!\n");

} else {

unlink($outfname); # they match, just delete the new copy so build system doesn't rebuild everything.

}

}

closedir(DIRH);

# end of lxapigen.pl ...