coregrind/gen_toolint.pl

#!/usr/bin/perl -w

#  This file is part of Valgrind, a dynamic binary instrumentation
#  framework.
#
#  Copyright (C) 2000-2005 Julian Seward 
#     jseward@acm.org
#
#  This program is free software; you can redistribute it and/or
#  modify it under the terms of the GNU General Public License as
#  published by the Free Software Foundation; either version 2 of the
#  License, or (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful, but
#  WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
#  General Public License for more details.
#
#  You should have received a copy of the GNU General Public License
#  along with this program; if not, write to the Free Software
#  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
#  02111-1307, USA.
#
#  The GNU General Public License is contained in the file COPYING.

use strict;

my $output = shift @ARGV;
my $indent = "";
my $headerguard;
my $include;
my $passcomment = 1;
my $pre;
my $post;
my $generate;

my $struct = "VG_(tdict)";

my %pfxmap = ("track" => "TL_",
	      "tool"  => "TL_",
	      "malloc"=> "TL_",
	     );

sub getargnames(@) {
    my @args = @_;
    my @ret;

    foreach my $a (@args) {
	my @pieces = split /\s+/, $a;
	my $name = pop @pieces;
	push @ret, $name unless $name eq "void";
    }
    return @ret;
}

sub getargtypes(@) {
    my @args = @_;
    my @ret;

    foreach my $a (@args) {
	my @pieces = split /\s+/, $a;
	pop @pieces;
	push @ret, (join " ", @pieces);
    }
    @ret = "void" if ($#ret == -1);
    return @ret;
}

# Different output modes
if ($output eq "callwrap") {
    $include = "core.h";
    $generate = sub ($$$@) {
	my ($pfx, $ret, $func, @args) = @_;
	my $args = join ", ", @args;
	my $argnames = join ", ", getargnames(@args);
	print "$ret $pfxmap{$pfx}($func)($args)\n{\n";
	print "   return (*$struct.${pfx}_$func)($argnames);\n";
	print "}\n";
    }
} elsif ($output eq "proto") {
    $include = "core.h";
    $generate = sub ($$$@) {
	my ($pfx, $ret, $func, @args) = @_;
	my $args = join ', ', @args;

	print "$ret $pfxmap{$pfx}($func)($args);\n";
	print "$ret VG_(missing_$func)($args);\n";
	print "Bool VG_(defined_$func)(void);\n";
    }
} elsif ($output eq "toolproto") {
    $generate = sub ($$$@) {
	my ($pfx, $ret, $func, @args) = @_;
	my $args = join ', ', @args;

	print "$ret $pfxmap{$pfx}($func)($args);\n";
    }
} elsif ($output eq "missingfuncs") {
    $include = "core.h";
    $generate = sub ($$$@) {
	my ($pfx, $ret, $func, @args) = @_;
	my $args = join ", ", @args;

	print "__attribute__ ((weak))\n$ret VG_(missing_$func)($args) {\n";
	print "   VG_(missing_tool_func)(\"${pfx}_$func\");\n";
	print "}\n";
	print "Bool VG_(defined_$func)(void) {\n";
	print "   return $struct.${pfx}_$func != VG_(missing_$func);\n";
	print "}\n\n";
    };
    $indent = "   ";
} elsif ($output eq "struct") {
    $include = "core.h";
    $pre = sub () {
	print "typedef struct {\n";
    };
    $post = sub () {
	print "} VgToolInterface;\n\n";
	print "extern VgToolInterface $struct;\n"
    };
    $generate = sub ($$$@) {
	my ($pfx, $ret, $func, @args) = @_;
	my $args = join ", ", @args;

	print "$indent$ret (*${pfx}_$func)($args);\n";
    };
    $indent = "   ";
    $headerguard=$output;
} elsif ($output eq "structdef") {
    $include = "vg_toolint.h";
    $pre = sub () {
	print "VgToolInterface $struct = {\n";
    };
    $post = sub () {
	print "};\n";
    };
    $generate = sub ($$$@) {
	my ($pfx, $ret, $func, @args) = @_;

	print "$indent.${pfx}_$func = VG_(missing_$func),\n"
    };
    $indent = "   ";
} elsif ($output eq "initfunc") {
    $include = "tool.h";
    $generate = sub ($$$@) {
	my ($pfx, $ret, $func, @args) = @_;
	my $args = join ", ", @args;
	my $argnames = join ", ", getargnames(@args);

	print <<EOF;
void VG_(init_$func)($ret (*func)($args))
{
	if (func == NULL)
		func = VG_(missing_$func);
	if (VG_(defined_$func)())
		VG_(printf)("Warning tool is redefining $func\\n");
	if (func == TL_($func))
		VG_(printf)("Warning tool is defining $func recursively\\n");
	$struct.${pfx}_$func = func;
}
EOF
    }
} elsif ($output eq "initproto") {
    $generate = sub ($$$@) {
	my ($pfx, $ret, $func, @args) = @_;
	my $args = join ', ', @args;
	print "void VG_(init_$func)($ret (*func)($args));\n";
    };
    $headerguard=$output;
}

die "Unknown output format \"$output\"" unless defined $generate;

print "/* Generated by \"gen_toolint.pl $output\" */\n";

print <<EOF if defined $headerguard;

#ifndef VG_toolint_$headerguard
#define VG_toolint_$headerguard

EOF

print <<EOF if defined $include;
#include \"$include\"
EOF

&$pre() if defined $pre;	# preamble

my $state = "idle";

my $buf;
my $lines;
my $prefix;

while(<STDIN>) {
    # skip simple comments
    next if (/^#[^#]/);

    if (/^:/) {
	s/^://;
	chomp;
	$prefix=$_;
	next;
    }

    # look for inserted comments
    if (/^##/) {
	if ($state eq "idle") {
	    $state = "comment";
	    $lines = 1;
	    $_ =~ s,^## ,/* ,;
	    $buf = $_;
	    next;
	} elsif ($state eq "comment") {
	    $lines++;
	    $_ =~ s,^## ,   ,;
	    print $indent.$buf if $passcomment;
	    $buf = $_;
	    next;
	}
	next;
    }

    # blank lines in a comment are part of the comment
    if (/^\s*$/) {
	if ($state eq "comment") {
	    $lines++;
	    print $indent.$buf if $passcomment;
	    $buf = "\n";
	} else {
	    print "\n" if $passcomment;
	}
	next;
    }

    # coming out of a comment
    if ($state eq "comment") {
	chomp $buf;

	if ($passcomment) {
	    if ($lines == 1) {
		print "$indent$buf */\n";
	    } else {
		print "$indent$buf\n$indent */\n";
	    }
	}
	$buf = "";
	$state = "idle";
    }

    chomp;
    my @func = split /,\s*/;

    my $rettype = shift @func;
    my $funcname = shift @func;

    @func = "void" if scalar @func == 0;

    &$generate ($prefix, $rettype, $funcname, @func);
}

&$post() if defined $post;	# postamble

print <<EOF if defined $headerguard;

#endif /* VG_toolint_$headerguard */
EOF