mirror of
https://github.com/Mercury-Language/mercury.git
synced 2025-12-13 21:04:00 +00:00
124 lines
3.0 KiB
Perl
Executable File
124 lines
3.0 KiB
Perl
Executable File
#!/usr/local/bin/perl
|
|
#---------------------------------------------------------------------------#
|
|
# 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 converts .mod files to .c files.
|
|
|
|
sub println {
|
|
local ($line) = @_;
|
|
if ($line =~ /\n/) {
|
|
print "/* oops - line = $line */\n";
|
|
}
|
|
print "$line\n";
|
|
$line_count++;
|
|
}
|
|
|
|
sub printlines {
|
|
local ($lines) = @_;
|
|
foreach $line (split(/\n/,$lines)) {
|
|
do println($line);
|
|
}
|
|
}
|
|
|
|
$decl = $code = $init = $special_init = $gnudecl = $gnuinit = "";
|
|
$in_module = $in_code = 0;
|
|
|
|
unshift(@ARGV, '-') if $#ARGV < $[;
|
|
FILE:
|
|
while ($ARGV = shift) {
|
|
if ($ARGV eq "-s") {
|
|
shift;
|
|
next FILE;
|
|
}
|
|
if ($ARGV =~ /^-s/) {
|
|
next FILE;
|
|
}
|
|
open(F, $ARGV) || die "mod2c: can't open input file `$ARGV': $!\n";
|
|
LINE:
|
|
while (<F>) {
|
|
$target = $ARGV;
|
|
$target =~ s/\.mod/\.c/;
|
|
if (/^BEGIN_MODULE\((\w+)\)/) {
|
|
$module = $1;
|
|
$in_module = 1;
|
|
next LINE;
|
|
}
|
|
if (/^BEGIN_CODE/) {
|
|
$in_code = 1;
|
|
next LINE;
|
|
}
|
|
if (/^END_MODULE/) {
|
|
do printlines($decl);
|
|
do println("");
|
|
do println("BEGIN_MODULE($module)");
|
|
do printlines($special_init);
|
|
do printlines($init);
|
|
do println("BEGIN_CODE");
|
|
do printlines($code);
|
|
do println("END_MODULE");
|
|
$decl = $code = $init = $special_init = "";
|
|
$in_module = $in_code = 0;
|
|
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;
|
|
}
|
|
#
|
|
# 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/)))
|
|
{
|
|
$type = "entry";
|
|
}
|
|
else {
|
|
if ($label =~ /^([a-zA-Z0-9_]+)_([0-9]+)_l$/ && ! ($label =~ /^aux/))
|
|
{
|
|
$type = "local";
|
|
}
|
|
else
|
|
{
|
|
$type = "label";
|
|
}
|
|
}
|
|
$init .= "\tinit_$type($label);\n";
|
|
if ($type eq "entry") {
|
|
$decl .= "Define_extern_entry($label);\n";
|
|
} else {
|
|
$decl .= "Declare_$type($label);\n";
|
|
}
|
|
$code .= "Define_$type($label);\n";
|
|
} else {
|
|
$code .= $save;
|
|
}
|
|
}
|
|
}
|