c2ph

早期freebsd实现

	$type = $type[$typeno];

	$type =~ /([^[]*)(\[.*\])?/;
	$mytype = $1;
	$count .= $2;
	$fieldtype = &psou($mytype);

	local($fname) = &psou($name);

	if ($build_templates) {

	    $pad = ($offset - ($lastoffset + $lastlength))/8 
		if defined $lastoffset;

	    if (! $finished_template{$sname}) {
		if ($isaunion{$what}) {
		    $template{$sname} .= 'X' x $revpad . ' '    if $revpad;
		} else {
		    $template{$sname} .= 'x' x $pad    . ' '    if $pad;
		}
	    }

	    $template = &fetch_template($type) x 
			    ($count ? &scripts2count($count) : 1);

	    if (! $finished_template{$sname}) {
		$template{$sname} .= $template;
	    }

	    $revpad = $length/8 if $isaunion{$what};

	    ($lastoffset, $lastlength) = ($offset, $length);

	} else { 
	    print '# ' if $perl && $verbose;
	    $entry = sprintf($pmask1,
			' ' x ($nesting * $indent) . $fieldtype,
			"$prefix.$fieldname" . $count); 

	    $entry =~ s/(\*+)( )/$2$1/; 

	    printf $pmask2,
		    $entry,
		    ($base+$offset)/8,
		    ($bits = ($base+$offset)%8) ? ".$bits" : "  ",
		    $length/8,
		    ($bits = $length % 8) ? ".$bits": ""
			if !$perl || $verbose;


	    if ($perl && $nesting == 1) {
		$template = &scrunch(&fetch_template($type) x 
				($count ? &scripts2count($count) : 1));
		push(@sizeof, int($length/8) .",\t# $fieldname");
		push(@offsetof, int($offset/8) .",\t# $fieldname");
		push(@typedef, "'$template', \t# $fieldname");
		$type =~ s/(struct|union) //;
		push(@typeof, "'$type" . ($count ? $count : '') .
		    "',\t# $fieldname");
	    }

	    print '  ', ' ' x $indent x $nesting, $template
				if $perl && $verbose;

	    print "\n" if !$perl || $verbose;

	}    
	if ($perl) {
	    local($mycount) = defined $struct{$mytype} ? $countof{$mytype} : 1;
	    $mycount *= &scripts2count($count) if $count;
	    if ($nesting==1 && !$build_templates) {
		$pcode .= sprintf("sub %-32s { %4d; }\n", 
			"${mname}'${fieldname}", $struct_count);
		push(@indices, $struct_count);
	    }
	    $struct_count += $mycount;
	} 


	&pstruct($type, "$prefix.$fieldname", $base+$offset) 
		if $recurse && defined $struct{$type}; 
    }

    $countof{$what} = $struct_count unless defined $countof{$whati};

    $template{$sname} .= '$' if $build_templates;
    $finished_template{$sname}++;

    if ($build_templates && !defined $sizeof{$name}) {
	local($fmt) = &scrunch($template{$sname});
	print STDERR "no size for $name, punting with $fmt..." if $debug;
	eval '$sizeof{$name} = length(pack($fmt, ()))';
	if ($@) {
	    chop $@;
	    warn "couldn't get size for \$name: $@";
	} else {
	    print STDERR $sizeof{$name}, "\n" if $debUg;
	}
    } 

    --$nesting;
}


sub psize {
    local($me) = @_; 
    local($amstruct) = $struct{$me} ?  'struct ' : '';

    print '$sizeof{\'', $amstruct, $me, '\'} = '; 
    printf "%d;\n", $sizeof{$me}; 
}

sub pdecl {
    local($pdecl) = @_;
    local(@pdecls);
    local($tname);

    warn "pdecl: $pdecl\n" if $debug;

    $pdecl =~ s/\(\d+,(\d+)\)/$1/g;
    $pdecl =~ s/\*//g; 
    @pdecls = split(/=/, $pdecl); 
    $typeno = $pdecls[0];
    $tname = pop @pdecls;

    if ($tname =~ s/^f//) { $tname = "$tname&"; } 
    #else { $tname = "$tname*"; } 

    for (reverse @pdecls) {
	$tname  .= s/^f// ? "&" : "*"; 
	#$tname =~ s/^f(.*)/$1&/;
	print "type[$_] is $tname\n" if $debug;
	$type[$_] = $tname unless defined $type[$_];
    } 
}



sub adecl {
    ($arraytype, $unknown, $lower, $upper) = ();
    #local($typeno);
    # global $typeno, @type
    local($_, $typedef) = @_;

    while (s/^((\d+)=)?ar(\d+);//) {
	($arraytype, $unknown) = ($2, $3); 
	if (s/^(\d+);(\d+);//) {
	    ($lower, $upper) = ($1, $2); 
	    $scripts .= '[' .  ($upper+1) . ']'; 
	} else {
	    warn "can't find array bounds: $_"; 
	} 
    }
    if (s/^([\d*f=]*),(\d+),(\d+);//) {
	($start, $length) = ($2, $3); 
	local($whatis) = $1;
	if ($whatis =~ /^(\d+)=/) {
	    $typeno = $1;
	    &pdecl($whatis);
	} else {
	    $typeno = $whatis;
	}
    } elsif (s/^(\d+)(=[*suf]\d*)//) {
	local($whatis) = $2; 

	if ($whatis =~ /[f*]/) {
	    &pdecl($whatis); 
	} elsif ($whatis =~ /[su]/) {  # 
	    print "$prefix.$fieldname is an array$scripts anon structs; disgusting\n" 
		if $debug;
	    #$type[$typeno] = $name unless defined $type[$typeno];
	    ##printf "new type $typeno is $name" if $debug;
	    $typeno = $1;
	    $type[$typeno] = "$prefix.$fieldname";
	    local($name) = $type[$typeno];
	    &sou($name, $whatis);
	    $_ = &sdecl($name, $_, $start+$offset);
	    1;
	    $start = $start{$name};
	    $offset = $sizeof{$name};
	    $length = $offset;
	} else {
	    warn "what's this? $whatis in $line ";
	} 
    } elsif (/^\d+$/) {
	$typeno = $_;
    } else {
	warn "bad array stab: $_ in $line ";
	next STAB;
    } 
    #local($wasdef) = defined($type[$typeno]) && $debug;
    #if ($typedef) { 
	#print "redefining $type[$typeno] to " if $wasdef;
	#$type[$typeno] = "$whatis$scripts"; # unless defined $type[$typeno];
	#print "$type[$typeno]\n" if $wasdef;
    #} else {
	#$type[$arraytype] = $type[$typeno] unless defined $type[$arraytype];
    #}
    $type[$arraytype] = "$type[$typeno]$scripts" if defined $type[$typeno];
    print "type[$arraytype] is $type[$arraytype]\n" if $debug;
    print "$prefix.$fieldname is an array of $type[$arraytype]\n" if $debug;
    $_;
}



sub sdecl {
    local($prefix, $_, $offset) = @_;

    local($fieldname, $scripts, $type, $arraytype, $unknown,
    $whatis, $pdecl, $upper,$lower, $start,$length) = ();
    local($typeno,$sou);


SFIELD:
    while (/^([^;]+);/) {
	$scripts = '';
	warn "sdecl $_\n" if $debug;
	if (s/^([\$\w]+)://) { 
	    $fieldname = $1;
	} elsif (s/(\d+)=([us])(\d+|\(\d+,\d+\))//) { # 
	    $typeno = &typeno($1);
	    $type[$typeno] = "$prefix.$fieldname";
	    local($name) = "$prefix.$fieldname";
	    &sou($name,$2);
	    $_ = &sdecl("$prefix.$fieldname", $_, $start+$offset);
	    $start = $start{$name};
	    $offset += $sizeof{$name};
	    #print "done with anon, start is $start, offset is $offset\n";
	    #next SFIELD;
	} else  {
	    warn "weird field $_ of $line" if $debug;
	    next STAB;
	    #$fieldname = &gensym;
	    #$_ = &sdecl("$prefix.$fieldname", $_, $start+$offset);
	}

	if (/^\d+=ar/) {
	    $_ = &adecl($_);
	}
	elsif (s/^(\d+|\(\d+,\d+\))?,(\d+),(\d+);//) {
	    ($start, $length) =  ($2, $3); 
	    &panic("no length?") unless $length;
	    $typeno = &typeno($1) if $1;
	}
	elsif (s/^((\d+|\(\d+,\d+\))(=[*f](\d+|\(\d+,\d+\)))+),(\d+),(\d+);//) {
	    ($pdecl, $start, $length) =  ($1,$5,$6); 
	    &pdecl($pdecl); 
	}
	elsif (s/(\d+)=([us])(\d+|\(\d+,\d+\))//) { # the dratted anon struct
	    ($typeno, $sou) = ($1, $2);
	    $typeno = &typeno($typeno);
	    if (defined($type[$typeno])) {
		warn "now how did we get type $1 in $fieldname of $line?";
	    } else {
		print "anon type $typeno is $prefix.$fieldname\n" if $debug;
		$type[$typeno] = "$prefix.$fieldname" unless defined $type[$typeno];
	    };
	    local($name) = "$prefix.$fieldname";
	    &sou($name,$sou);
	    print "anon ".($isastruct{$name}) ? "struct":"union"." for $prefix.$fieldname\n" if $debug;
	    $type[$typeno] = "$prefix.$fieldname";
	    $_ = &sdecl("$prefix.$fieldname", $_, $start+$offset); 
	    $start = $start{$name};
	    $length = $sizeof{$name};
	}
	else {
	    warn "can't grok stab for $name ($_) in line $line "; 
	    next STAB; 
	}

	&panic("no length for $prefix.$fieldname") unless $length;
	$struct{$name} .= join(',', $fieldname, $typeno, $scripts, $start, $length) . ';';
    }
    if (s/;\d*,(\d+),(\d+);//) {
	local($start, $size) = ($1, $2); 
	$sizeof{$prefix} = $size;
	print "start of $prefix is $start, size of $sizeof{$prefix}\n" if $debug; 
	$start{$prefix} = $start; 
    } 
    $_;
}

sub edecl {
    s/;$//;
    $enum{$name} = $_;
    $_ = '';
} 

sub resolve_types {
    local($sou);
    for $i (0 .. $#type) {
	next unless defined $type[$i];
	$_ = $type[$i];
	unless (/\d/) {
	    print "type[$i] $type[$i]\n" if $debug;
	    next;
	}
	print "type[$i] $_ ==> " if $debug;
	s/^(\d+)(\**)\&\*(\**)/"$2($3".&type($1) . ')()'/e;
	s/^(\d+)\&/&type($1)/e; 
	s/^(\d+)/&type($1)/e; 
	s/(\*+)([^*]+)(\*+)/$1$3$2/;
	s/\((\*+)(\w+)(\*+)\)/$3($1$2)/;
	s/^(\d+)([\*\[].*)/&type($1).$2/e;
	#s/(\d+)(\*|(\[[\[\]\d\*]+]\])+)/&type($1).$2/ge;
	$type[$i] = $_;
	print "$_\n" if $debug;
    }
}
sub type { &psou($type[$_[0]] || "<UNDEFINED>"); } 

sub adjust_start_addrs {
    for (sort keys %start) {
	($basename = $_) =~ s/\.[^.]+$//;
	$start{$_} += $start{$basename};
	print "start: $_ @ $start{$_}\n" if $debug;
    }
}

sub sou {
    local($what, $_) = @_;
    /u/ && $isaunion{$what}++;
    /s/ && $isastruct{$what}++;
}

sub psou {
    local($what) = @_;
    local($prefix) = '';
    if ($isaunion{$what})  {
	$prefix = 'union ';
    } elsif ($isastruct{$what})  {
	$prefix = 'struct ';
    }
    $prefix . $what;
}

sub scrunch {
    local($_) = @_;

    study;

    s/\$//g;
    s/  / /g;
    1 while s/(\w) \1/$1$1/g;

    # i wanna say this, but perl resists my efforts:
    #	   s/(\w)(\1+)/$2 . length($1)/ge;

    &quick_scrunch;

    s/ $//;

    $_;
}

sub buildscrunchlist {
    $scrunch_code = "sub quick_scrunch {\n";
    for (values %intrinsics) {
        $scrunch_code .= "\ts/($_{2,})/'$_' . length(\$1)/ge;\n";
    } 
    $scrunch_code .= "}\n";
    print "$scrunch_code" if $debug;
    eval $scrunch_code;
    &panic("can't eval scrunch_code $@ \nscrunch_code") if $@;
} 

sub fetch_template {
    local($mytype) = @_;
    local($fmt);
    local($count) = 1;

    &panic("why do you care?") unless $perl;

    if ($mytype =~ s/(\[\d+\])+$//) {
	$count .= $1;
    } 

    if ($mytype =~ /\*/) {
	$fmt = $template{'pointer'};
    } 
    elsif (defined $template{$mytype}) {
	$fmt = $template{$mytype};
    } 
    elsif (defined $struct{$mytype}) {
	if (!defined $template{&psou($mytype)}) {
	    &build_template($mytype) unless $mytype eq $name;
	} 
	elsif ($template{&psou($mytype)} !~ /\$$/) {
	    #warn "incomplete template for $mytype\n";
	} 
	$fmt = $template{&psou($mytype)} || '?';
    } 
    else {
	warn "unknown fmt for $mytype\n";
	$fmt = '?';
    } 

    $fmt x $count . ' ';
}

sub compute_intrinsics {
    local($TMP) = "/tmp/c2ph-i.$$.c";
    open (TMP, ">$TMP") || die "can't open $TMP: $!";
    select(TMP);

    print STDERR "computing intrinsic sizes: " if $trace;

    undef %intrinsics;

    print <<'EOF';
main() {
    char *mask = "%d %s\n";
EOF

    for $type (@intrinsics) {
	next if $type eq 'void';
	print <<"EOF";
    printf(mask,sizeof($type), "$type");
EOF
    } 

    print <<'EOF';
    printf(mask,sizeof(char *), "pointer");
    exit(0);
}
EOF
    close TMP;

    select(STDOUT);
    open(PIPE, "cd /tmp && $CC $TMP && /tmp/a.out|");
    while (<PIPE>) {
	chop;
	split(' ',$_,2);;
	print "intrinsic $_[1] is size $_[0]\n" if $debug;
	$sizeof{$_[1]} = $_[0];
	$intrinsics{$_[1]} = $template{$_[0]};
    } 
    close(PIPE) || die "couldn't read intrinsics!";
    unlink($TMP, '/tmp/a.out');
    print STDERR "done\n" if $trace;
} 

sub scripts2count {
    local($_) = @_;

    s/^\[//;
    s/\]$//;
    s/\]\[/*/g;
    $_ = eval;
    &panic("$_: $@") if $@;
    $_;
}

sub system {
    print STDERR "@_\n" if $trace;
    system @_;
} 

sub build_template { 
    local($name) = @_;

    &panic("already got a template for $name") if defined $template{$name};

    local($build_templates) = 1;

    local($lparen) = '(' x $build_recursed;
    local($rparen) = ')' x $build_recursed;

    print STDERR "$lparen$name$rparen " if $trace;
    $build_recursed++;
    &pstruct($name,$name,0);
    print STDERR "TEMPLATE for $name is ", $template{&psou($name)}, "\n" if $debug;
    --$build_recursed;
}


sub panic {

    select(STDERR);

    print "\npanic: @_\n";

    exit 1 if $] <= 4.003;  # caller broken

    local($i,$_);
    local($p,$f,$l,$s,$h,$a,@a,@sub);
    for ($i = 0; ($p,$f,$l,$s,$h,$w) = caller($i); $i++) {
	@a = @DB'args;
	for (@a) {
	    if (/^StB\000/ && length($_) == length($_main{'_main'})) {
		$_ = sprintf("%s",$_);
	    }
	    else {
		s/'/\\'/g;
		s/([^\0]*)/'$1'/ unless /^-?[\d.]+$/;
		s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
		s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
	    }
	}
	$w = $w ? '@ = ' : '$ = ';
	$a = $h ? '(' . join(', ', @a) . ')' : '';
	push(@sub, "$w&$s$a from file $f line $l\n");
	last if $signal;
    }
    for ($i=0; $i <= $#sub; $i++) {
	last if $signal;
	print $sub[$i];
    }
    exit 1;
} 

sub squishseq {
    local($num);
    local($last) = -1e8;
    local($string);
    local($seq) = '..';

    while (defined($num = shift)) {
        if ($num == ($last + 1)) {
            $string .= $seq unless $inseq++;
            $last = $num;
            next;
        } elsif ($inseq) {
            $string .= $last unless $last == -1e8;
        }

        $string .= ',' if defined $string;
        $string .= $num;
        $last = $num;
        $inseq = 0;
    }
    $string .= $last if $inseq && $last != -e18;
    $string;
}