mercury/scripts/mod2c

#!/usr/contrib/bin/perl

# This converts .mod files to .c files.
# It accepts two options: -g, which causes it to generate
# the gcc-specific output instead of the portable output,
# and -l, which causes it to generate #line directives in the output file.


require "getopts.pl";

$line_count = 1;

sub println {
    local ($line) = @_;
    if ($line =~ /\n/) {
	print "/* oops - line = $line */\n";
    }
    if ($line eq "\@\@LINE\@\@") {
	return unless $line_nums;
	$line = "#line $line_count \"$target\"";
    }
    print "$line\n";
    $line_count++;
}

sub printlines {
    local ($lines) = @_;
    foreach $line (split(/\n/,$lines)) {
	do println($line);
    }
}

sub parse_options {
    $opt_g = 0;
    $opt_l = 0;
    $opt_s = "";
    do Getopts("gls:");
    if ($opt_g || $opt_s eq "fast" || $opt_s eq "fast.gc"
		|| $opt_s eq "jump" || $opt_s eq jump.gc)
    {
	    $gnuc = 1;
    } else {
	    $gnuc = 0;
    }
    $line_nums = $opt_l;

    $options = "";
    $options .= "-g " if ($opt_g);
    $options .= "-l " if ($opt_l);
    $options .= "-s$opt_s " if ($opt_s ne "");
    chop $options;
    $options = "no options" if ($options eq "");
}

do parse_options();

do println("/*");
do println("** This code was automatically generated by mod2c.");
do println("** Do not edit.");
do println("**");
do println("** mod2c options used: $options");
do println("*/");
do println("");

if ($gnuc) {
	do println("#ifndef USE_GCC_NONLOCAL_GOTOS");
	do println("#error \"If you don't define USE_GCC_NONLOCAL_GOTOS, then you must not use mod2c's -sfast or -sjump options\"");
	do println("#endif");
} else {
	do println("#ifdef USE_GCC_NONLOCAL_GOTOS");
	do println("#error \"If you define USE_GCC_NONLOCAL_GOTOS, you must use one of mod2c's -sfast or -sjump options\"");
	do println("#endif");
}
do println("");

$decl = $code = $init = $special_init = $gnudecl = $gnuinit = "";
$in_module = $in_code = $some_code = 0;
$need_line = 1;

unshift(@ARGV, '-') if $#ARGV < $[;
while ($ARGV = shift) {
  open(F, $ARGV) || die "mod2c: can't open input file `$ARGV': $!\n";
  LINE:
  while (<F>) {
    $target = $ARGV;
    $target =~ s/\.mod/\.c/;
    if ($line_nums && $need_line) {
        do println("#line $. \"$ARGV\"");
	$need_line = 0;
    }
    if (/^BEGIN_MODULE\((\w+)\)/) {
        $module = $1;
        $in_module = 1;
	$l = $. + 2;
	$special_init = "#line $l \"$ARGV\"\n" if $line_nums;
        next LINE;
    }
    if (/^BEGIN_CODE/) {
        $in_code = 1;
	$l = $. + 1;
	$code_line = "#line $l \"$ARGV\"";
        next LINE;
    }
    if (/^END_MODULE/) {
	do println("#line $line_count \"$target\"") if $line_nums;
        if ($gnuc) {
	    do printlines($gnudecl);
	} else {
            do printlines($decl);
            if ($some_code) {
		# do println($code_line) if $line_nums;
                do printlines($code);
		do println("#line $line_count \"$target\"") if $line_nums;
                do println("\tassert(0);");
		do println("}");
            }
	}
	do println("");
        do println("void $module(void); /* suppress gcc warning */");
        do println("void $module(void)");
	do println("{");
        do printlines($init);
        if ($gnuc) {
	    do printlines($gnuinit);
        }
        do printlines($special_init);
        if ($gnuc) {
	    do println("\treturn;");
	    do println($code_line) if $line_nums;
            do printlines($code);
	    do println("#line $line_count \"$target\"") if $line_nums;
            do println("\tassert(0);");
        }
        do println("}");
	$decl = $code = $init = $special_init = $gnudecl = $gnuinit = "";
        $in_module = $in_code = $some_code = 0;
	$l = $. + 1;
	do println("#line $l \"$ARGV\"") if $line_nums;
        next LINE;
    }
    if (! $in_module) {
	chop;
        do println("$_");
        next LINE;
    }
    if (! $in_code) {
        $special_init .= $_;
        next LINE;
    }
    $save = $_;
    s/^[ \t]*//;
    ($label, $_) = split;
    if ($label =~ /^[a-zA-Z0-9_]*:$/)
    {
        chop $label;
	if ($label =~ /^default/ || $label =~ /^otherwise/) {
	    $code .= $save;
	    next LINE;
	}
        if (! $gnuc) {
            if ($some_code) { $code .= "\@\@LINE\@\@\n\tGOTO($label);\n}\n"; }
            $some_code = 1;
	#
	# A label is considered an entry point if
	#	- it starts with "do_" (eg. do_fail)
	#	- it matches <alphanumerics and underlines><underline><digits>
	#	  but does NOT start with "aux"
	#	- it matches the same pattern followed by "_input"
	#
            if ($label =~ /^do_/ ||
	        ($label =~ /^([a-zA-Z0-9_]+)_([0-9]+)$/ && ! ($label =~ /^aux/)) ||
	        ($label =~ /^([a-zA-Z0-9_]+)_([0-9]+)_input$/ && ! ($label =~ /^aux/)))
	    {
                $code .= "Code *$label(void); /* suppress gcc warning */\n";
                $code .= "Code *$label(void)\n{\n";
	    } else {
                $code .= "static Code *$label(void)\n{\n";
	    }
	    $l = $. + 1;
	    $code .= "#line $l \"$ARGV\"\n" if $line_nums;
	    $save = "";
        }
	#
	# A label is considered an entry point if
	#	- it starts with "do_" (eg. do_fail)
	#	- it matches <letters and underlines><underline><digits>
	#	  but does NOT start with "aux"
	#	- it matches the same pattern followed by "_input"
	#
	# A label is considered a local entry point if
	#	- it matches <letters and underlines><underline><digits>_l
	#	  but does NOT start with "aux"
	#
        if ($label =~ /^do_/ ||
	    ($label =~ /^([a-zA-Z0-9_]+)_([0-9]+)$/ && ! ($label =~ /^aux/)) ||
	    ($label =~ /^([a-zA-Z0-9_]+)_([0-9]+)_input$/ && ! ($label =~ /^aux/)))
        {
            $init .= "\tmakeentry(\"$label\", LABEL($label));\n";
            $decl .= "Code *$label(void);\n";
	    $gnudecl .= "Code *entry_$label;\n";
	    $gnuinit .= "\tentry_$label = &&$label;\n";
        }
        else {
	if ($label =~ /^([a-zA-Z0-9_]+)_([0-9]+)_l$/ && ! ($label =~ /^aux/))
        {
	    $init .= "\tmakelocalentry(\"$label\", LABEL($label));\n";
            $decl .= "static Code *$label(void);\n";
	}
        else
        {
            $init .= "\tmakelabel(\"$label\", LABEL($label));\n";
            $decl .= "static Code *$label(void);\n";
        }
	}
    }
    $code .= $save;
  }
}