163 lines
3.9 KiB
Perl
Executable File
163 lines
3.9 KiB
Perl
Executable File
#!/usr/bin/perl
|
|
#
|
|
# This file is part of Cygwin.
|
|
#
|
|
# This software is a copyrighted work licensed under the terms of the
|
|
# Cygwin license. Please consult the file "CYGWIN_LICENSE" for
|
|
# details.
|
|
#
|
|
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);
|
|
$rest .= ', ' . (($dev =~ m%/dev/%o) ? 'true' : 'false');
|
|
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,
|
|
"const _RDATA _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;
|
|
if ($? == -1) {
|
|
die "$0: shilka command missing? - $!\n";
|
|
} else {
|
|
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 do {{
|
|
if (chmod(0664, $output)) {
|
|
open(OUTPUT, '>', $output);
|
|
last;
|
|
}
|
|
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;
|
|
$fh =~ s%^:%__%o;
|
|
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 =~ /^(.*), =(\S*_dev)\b\s*(.*)$/) {
|
|
$pointers{$2} ||= "const _device *$2 = $storage_loc;\n";
|
|
$rest = $1 . $3;
|
|
}
|
|
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;
|
|
$a0 =~ s%^//%:%o;
|
|
$b0 =~ s%^//%:%o;
|
|
return $a0 cmp $b0;
|
|
}
|