
# Leave the first line of this file blank!
# This is a Perl script; the following two lines allow us to avoid
# embedding the path of the perl interpreter in the script.
eval "exec perl -S $0 $*"
    if $running_under_some_shell;

#---------------------------------------------------------------------------#
# Copyright (C) 1995 University of Melbourne.
# This file may only be copied under the terms of the GNU General
# Public License - see the file COPYING in the Mercury distribution.
#---------------------------------------------------------------------------#

# This script creates a vi style `tags' file or (if the `-e' or `--emacs'
# option is specified) an emacs style `TAGS' file for Mercury programs.
# It takes its list of filenames from the command line.

$warnings = 0;
$emacs = 0;

if ($ARGV[0] eq "-e" || $ARGV[0] eq "--emacs") {
	$emacs = 1;
	shift(ARGV);
}

die "Usage: mtags [-e] [--emacs] file1.m ...\n" if $#ARGV < 0;

#---------------------------------------------------------------------------#

sub output_name {
	# figure out the part of the body that is the name

	$name =~ s/^[ \t]*//;

	if ($name =~ /^\(/) {
	    $name =~ s/\(//;
	    $name =~ s/\).*//;
	} else {
	    $name =~ s/\.$//;
	    $name =~ s/\(.*//;
	    $name =~ s/ .*//;
	}

	if (!$emacs && $seen{$name}) {
	    if ($warnings &&
		$file ne $prev_file{$name} &&
		$. != $prev_line{$name})
	    {
	        printf STDOUT "%s:%03d: Warning: ignoring duplicate defn " .
		    "for `$name'\n", $file, $., $name;
	        printf STDOUT
		    "%s:%03d:   (previous definition of `%s' was here).\n",
		    $prev_file{$name}, $prev_line{$name}, $name;
	    }
	} else {
	    if ($emacs) {
		printf out "%s\177%s\001%d,%d\n",
		    $_, $name, $., $.;
	    } else {
		printf out "%s\t%s\t/^%s\$/;-;/%s/\n",
		    $name, $file, $_, $name;
	    }
	    $seen{$name} = 1;
	    $prev_file{$name} = $file;
	    $prev_line{$name} = $.;
	}
}

#---------------------------------------------------------------------------#

if ($emacs) {
	open(out, "> TAGS") || die "mtags: error opening TAGS: $!\n";
} else {
	open(out, "| sort -u +0 -1 > tags") ||
		die "mtags: error opening pipe: $!\n";
}
while ($#ARGV >= 0)
{
    $file = shift(ARGV);
    open(srcfile, $file) || die "mtags: can't open $file: $!\n";
    if ($emacs) {
	close(out) || die "mtags: error closing TAGS: $!\n";
	open(out, ">> TAGS") || die "mtags: error opening TAGS: $!\n";
	printf out "\f\n%s,%d\n", $file, 0;
	close(out) || die "mtags: error closing TAGS: $!\n";
	# open(out, "| sort -u +0 -1 >> TAGS") ||
	open(out, ">> TAGS") ||
		die "mtags: error opening pipe: $!\n";
    }
    while ($_ = <srcfile>)
    {
	# skip lines which are not declarations
	next unless ($_ =~ /^:- /);

	chop;

	($cmd, $decl, @rest) = split;
	$body = join(' ', @rest);

	# skip lines which are not pred, func, type, inst, or mode
	# declarations.
	next unless (
	    $decl eq "pred" ||
	    $decl eq "func" ||
	    $decl eq "type" ||
	    $decl eq "inst" ||
	    ($decl eq "mode" && $body =~ /::/)
	);

	# skip declarations which are not definitions
	next unless (
	    # pred and func declarations are always definitions
	    $decl eq "pred" ||
	    $decl eq "func" ||

	    # if it doesn't end in a `.' (i.e if it doesn't fit on one line),
	    # then it's probably a definition
	    ($body !~ /\.[ \t]*$/ && $body !~ /\.[ \t]*%.*$/) ||

	    # if it contains `--->', `=', or `::', it's probably a
	    # definition.
	    $body =~ /--->/ ||
	    $body =~ /=/ ||
	    $body =~ /::/
	);

	$name = $body;
	do output_name();
	
	# for everything except type declarations, we're done
	next unless ($decl eq "type");

	# make sure we're at the line with the `--->'
	if ($body !~ /--->/) {
		next if $_ =~ /\.[ \t]*$/ || $_ =~ /\.[ \t]*%.*$/;
		$_ = <srcfile>;
		chop;
		$body = $_;
	}
	next unless ($body =~ /--->/);

	# replace everything up to the `--->' with `;'
	$body =~ s/.*--->/;/;

	for(;;) {
	    # if the body starts with `;', we assume it must be the start of a
	    # constructor definition
	    if ($body =~ /^[ \t]*;/) {

		# delete the leading `;'
		$body =~ s/[^;]*;[ \t]*//;

		if ($body =~ /^[ \t]*$/) {
		    $_ = <srcfile>;
		    chop;
		    $body = $_;
		}

		$name = $body;
		$name =~ s/[;.%].*//;
		do output_name();

		# if there are more constructor definitions on the same line,
		# process the next one
	        if ($body =~ /;/) {
			$body =~ s/[^;]*;/;/;
			next;
		}
	    }
		
	    last if $_ =~ /\.[ \t]*$/ || $_ =~ /\.[ \t]*%.*$/;
	    $_ = <srcfile>;
	    chop;
	    $body = $_;
	}
    }
    close(srcfile) || die "mtags: error closing `$file': $!\n";
}
close(out) || die "mtags: error closing pipe: $!\n";
