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