newlib/winsup/cygwin/gendevices

142 lines
3.4 KiB
Perl
Executable File

#!/usr/bin/perl
use File::Basename;
use Cwd;
my $cwd = getcwd;
use strict;
use integer;
sub devsort;
my $input = shift;
my $output = shift;
my $base = "/tmp/" . basename($input, '.in') . '.' . $$;
my $c = $base . '.c';
my $shilka = $base . '.shilka';
open(INPUT, $input) or die "$0: couldn't open '$input' - $!\n";
my @lines = ();
my $storage_ix = -1;
my @storage = ();
my %pointers = ();
my @patterns = ();
my $patterns_ix = -1;
while (<INPUT>) {
if (/%storage_here/) {
$storage_ix = @lines;
} elsif (/^"([^"]+)",\s*(.*)$/o) {
push(@patterns, [$1, $2]);
next;
}
if (@patterns) {
for my $f (sort devsort @patterns) {
my $x = $f->[0];
my $rest = $f->[1];
my ($dev, $devrest) = ($x =~ /([^%]+)(%.*)?$/o);
push(@lines, generate($dev, $devrest, $rest, []));
}
@patterns = ();
}
push(@lines, $_);
}
close INPUT;
# @storage = sort devsort @storage;
chop $storage[$#storage];
chop $storage[$#storage];
$storage[$#storage] .= "\n";
splice(@lines, $storage_ix, 1,
"static const device dev_storage[] =\n", "{\n",
@storage, "};\n\n",
sort {$a cmp $b} values %pointers);
open(SHILKA, '>', $shilka);
print SHILKA @lines;
close SHILKA;
chdir '/tmp';
system qw'shilka -length -strip -no-definitions', $shilka;
exit $? if $?;
chdir $cwd;
unlink $shilka;
open(C, $c) or die "$0: couldn't open $c - $!\n";
@lines = <C>;
close C;
unlink $c;
splice(@lines, 0, 3);
my $ign_until_brace = 0;
for (my $i = 0; $i < @lines; $i++) {
$_ = $lines[$i];
$ign_until_brace = 1 if /(?:KR_reset|KR_output_statistics).*\)\s*$/o;
if ($ign_until_brace || /(?:#\s*line|(?:KR_reset|KR_output_statistics).*;)/) {
$ign_until_brace = 0 if $ign_until_brace && /}/o;
splice(@lines, $i, 1);
redo;
};
}
open(OUTPUT, '>', $output) or die "$0: couldn't open $output - $!\n";
print OUTPUT @lines;
close OUTPUT;
sub generate {
my $dev = shift;
my $devrest = shift;
my $rest = shift;
my $vars = shift;
my $res;
my @lines = ();
if ($devrest) {
my ($a, $low, $high, $fmt, $b) = ($devrest =~ /%([\({])([^-]+)-([^\)}]+)[\)}](.)(.*)/o);
my ($middle, $devrest0) = ($b =~ /^([^%]*)(%.*)?$/);
$fmt = "%$fmt";
my $vars_ix = @{$vars};
for my $f ($low .. $high) {
$vars->[$vars_ix] = $f;
$#{$vars} = $vars_ix;
my $dev0 = $dev . sprintf($fmt, $f) . $middle;
push(@lines, generate($dev0, $devrest0, $rest, $vars));
}
} else {
my $fh = $dev;
$fh =~ s%/%_%og;
my $shilka_id = $fh;
my $storage_str = $fh . '_storage';
$fh =~ s/^_dev_/FH_/o;
$fh = uc $fh;
$shilka_id =~ s/^_dev_//o;
$storage_str =~ s/^_dev/dev/o;
my $storage_loc = "dev_storage + " . @storage;
@lines = ('"' . $dev . '"' . " = $shilka_id {return $storage_loc;}\n");
$rest = "$fh, $rest" if $rest =~ /^"/o;
$rest = fixup($rest, $vars);
if ($rest =~ /^(.*), ([a-z_]*_dev)/) {
$pointers{$2} ||= "const device *$2 = $storage_loc;\n";
$rest = $1;
}
push(@storage, " {\"$dev\", " . $rest . "},\n");
}
return @lines;
}
sub fixup {
my $rest = shift;
my $vars = shift;
0 while $rest =~ s/{([^}]*)}/evalit($1, $vars)/eg;
return $rest;
}
sub evalit {
my $what = shift;
my $vars = shift;
$what =~ s/\$(\d+)/'$vars->[$1-1]'/g;
my $res = eval $what;
return $res;
}
sub devsort {
my $a0 = $a->[0];
my $b0 = $b->[0];
$a0 =~ s/(\D)(\d+)/"$1" . sprintf "%05d", $2/e;
$b0 =~ s/(\D)(\d+)/"$1" . sprintf "%05d", $2/e;
return $a0 cmp $b0;
}