newlib-cygwin/winsup/cygwin/gendevices

#!/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 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;
	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;
}