#!/usr/bin/perl -w
# SCCS $Id: make-fermat,v 1.37 2004/09/15 13:02:07 dcs0mpw Exp dcs0mpw $
# Build a Scheme version of FermaT
# Usage: make-fermat [options] [filename.scm]
#
# -force   runs wsl2scm on all the WSL files
# -debug   adds print statements as each file is loaded
# -gambit  generates code for gambit (include and defmacro)
# -comp    compiles everything with hobbit and builds SCM-fermat-comp
# -install compiles and installs SCM-fermat-comp (this is the default)
# -big     put all the code in ALL.scm
# -bigloo  call make-fermat-bigloo
#

BEGIN {
  $FermaT = $ENV{'FermaT'} || "/usr/local/fermat2";
  $FermaT =~ s/"//g; #"
  unshift(@INC, "$FermaT/config");
}

use fermat;

sub read_dir($);
sub quit;
sub alarm_clock;
sub make_stubs(@);
sub make_stub($$$);
sub diff($$);
sub gcc($$$);
sub make_hobbit();
sub read_file($);

($myname = $0) =~ s|(.*/)*||;   # strip path component from name
$Usage = "$myname [options] [filename.scm] \n";

my $HOME = $ENV{'HOME'} || $ENV{'LOGDIR'} ||
		(getpwuid($<))[7] || die "You're homeless!\n" unless ($dos);

$output = "ALL.scm";			# default output file
$scm_base = "$FermaT/scm";
$scm_comp = "SCM-fermat-comp";
$scmfmt   = "scmfmt";
$expand_macros = 1;
$ldflags = "";
 $optimise = "-O2";
#$optimise = "   ";
#$optimise = "-g ";
%done_stub = ();
%args = ();
$proc_num = ($$ % 32768);
$tmpfile = "$tmpdir/h$proc_num.scm";

# Functions called in perl scripts which may need to be stubified:
%extern = ();
grep { $extern{$_}++ } qw(
	@BL_Metric @CFDF_Metric @CRP_Item @Call_Graph @Effective_Size
	@Fail_Message @Find_Type @Flowchart @Gen_Type_Count @I @Item
	@McCabe @New_Program @PP_Item @Parse_File @Print_Assigns @Program
	@Stat_Count @Struct_Metric @Summ_To_WSL @Summarise @Syntax_OK @Trans
	@WSL_To_C @WSL_To_Cx86 @WSL_To_COBOL @WSL_To_Scheme
	@Print_Summ2 @Print_Proc_Summ2);

$gcc = "gcc";

# We can't use a hobbit-compiled hobbit since we are
# modifying some of hobbit's internal variables.
# Also hobbit-compiled hobbit requires floats to be built in.
$hobbit = "$FermaT/$arch/scmlit";
$scmlit = "$FermaT/$arch/scmlit";

if ($exe) {
  $scm_comp .= ".exe";
  $hobbit   .= ".exe";
  $scmlit   .= ".exe";
  $scmfmt   .= ".exe";
}

$defs1 = "defs1.scm";	# List of functions defined in compiled code
$defs2 = "defs2.scm";	# List of variables needing to be defined in compiled code

# scm5b1 objects:
#@objects = qw(time.o repl.o scl.o sys.o eval.o subr.o unif.o ramap.o continue.o
#	      gsubr.o ecrt0.o ioext.o rgx.o script.o posix.o rope.o socket.o
#	      unexelf.o findexec.o sc2.o gmalloc.o record.o unix.o);

# scm4e2 objects:
#@objects = qw(repl.o sys.o unif.o eval.o ramap.o scl.o subr.o time.o);

# scm5b2 objects:
#@objects = qw(continue.o scl.o subr.o unif.o eval.o repl.o
#	       sys.o findexec.o rope.o script.o time.o);

# scm5d4 objects:
#@objects = qw(continue.o findexec.o rope.o script.o sys.o unif.o
#	       eval.o repl.o scl.o scmmain.o subr.o time.o);

# scm5d6 objects:
@objects = qw(time.o repl.o scl.o sys.o eval.o subr.o unif.o rope.o
	      continue.o findexec.o script.o debug.o scmmain.o);

#$libs = "-lm -lsocket -lnsl";
$libs = "";	# Libraries for the final link step

$big = 0;
$force = 0;
$debug = 0;
$gambit = 0;
$comp = 1;
$install = 1;

$| = 1;			# unbuffered output
$PID = 0;		# sub-process PID
$outfile = "";		# output file of mysystem process
$SIG{'ALRM'} = \&alarm_clock;
$SIG{'PIPE'} = 'IGNORE';

END {
  if (-f $outfile) {
    print "Deleting $outfile\n";
    unlink($outfile);
  }
}

for $arg (@ARGV) {
  if ($arg eq "-force") {
    $force = 1;
  } elsif ($arg eq "-debug") {
    $debug = 1;
    $optimise = "-g";
  } elsif ($arg eq "-gambit") {
    $gambit = 1;
    $expand_macros = 0;
    $big = 0;
    $comp = 0;
    $install = 0;
    $output = "gambit.scm";
  } elsif (($arg eq "-guile") || ($arg eq "-scm")) {
    $big = 0;
    $comp = 0;
    $install = 0;
  } elsif ($arg eq "-big") {
    $big = 1;
  } elsif ($arg eq "-comp") {
    $comp = 1;
  } elsif ($arg eq "-install") {
    $comp = 1;
    $install = 1;
  } elsif ($arg eq "-gprof") {
    $optimise = "-pg -g -O2";
    $ldflags = "-pg -g -O2";
    $gprof = 1;
    $comp = 1;
    $install = 0;
    @objects = grep { s/^/gprof\// } @objects;
  } elsif ($arg eq "-mingw") {
    $comp = 1;
    $ENV{PATH} = "$HOME/mingw/bin:$ENV{PATH}";
    $gcc = "mingw32-gcc";
    $arch = "MinGW";
    $scmfmt = "scmfmt.exe";
    # DOS has its own dld_find_executable in script.c
    # so it doesn't need (and can't compile) findexec.c:
    @objects = grep { $_ ne "findexec.o" } @objects;
  } elsif ($arg =~ /^-/) {
    die $Usage;
  } else {
    $output = $arg;
  }
}
if ($dos) {
  $comp = 1;
  @objects = grep { $_ ne "findexec.o" } @objects;
}
if (!-d "$FermaT/$arch") {
  mkdir "$FermaT/$arch" or die "Can't mkdir $FermaT/$arch: $!\n";
}
$objdir = "$FermaT/$arch/obj";

chdir "$FermaT/src" or die "Cannot chdir to $FermaT/src: $!\n";

# Get the subdirectories:
@dirs = ("adt", "scheme", "trans", "wslib");

if (! -d $objdir) {
  mkdir $objdir or die "Cannot mkdir $objdir: $!\n";
}

# Put the scheme directory first:
@dirs = ("scheme", grep($_ ne "scheme", @dirs));
$root = cwd();
@badfiles = ();
@links = ();

if (defined($ENV{SCM_IMPL}) && ($ENV{SCM_IMPL} eq "bigloo")) {
  $expand_macros = 0;
} else {
  # Compile the SCM files if necessary:
  chdir "../scm" or die "Can't chdir to scm directory: $!\n";
  foreach my $obj (@objects) {
    ($src = $obj) =~ s/\.o$/\.c/;
    $obj = "$objdir/scm-$obj";
    gcc("scm", $src, $obj);
  }
  die "Some files failed to compile.\n" if (@badfiles);

  make_hobbit();
}

chdir $root;

# Check if we need to run Meta_Trans:
if (-f "adt/maths2-1.src" && !newer("adt/maths2-2.wsl", "adt/maths2-1.src")) {
  chdir "adt" or die "Can't chdir to adt: $!\n";
  print "dotrans maths2-1.src maths2-2.wsl Meta_Trans ... ";
  $ok = 1;
  $outfile = "maths2-2.wsl";
  unlink($outfile) if (-f $outfile);
  mysystem("dotrans maths2-1.src maths2-2.wsl Meta_Trans", "maths2-1.log");
  $log = read_file("maths2-1.log");
  $outfile = "";
  if (!(-f "maths2-2.wsl" && -s _)) {
    # no output file, or empty output file,
    # so keep the log file
    $ok = 0;
  } elsif ($ok) {
    if ($log =~ /ERROR|!!!!|Too many/) {
      $ok = 0; # keep the log file
    } else {
      unlink("maths2-1.log");
    }
  }
  if (!$ok) {
    push(@badfiles, "adt/maths2-1.src");
    print "failed!\n";
    print $log;
  } else {
    print "succeeded.\n";
  }
}

chdir $root;

# Run wsl2scm where necessary:
@badfiles = ();
foreach $dir (@dirs) {
  chdir $dir or die "Can't chdir to `$dir': $!\n";
  foreach $base (grep(s/\.wsl$//, read_dir("."))) {
    $wsl = "$base.wsl";
    $scm = "$base.scm";
    if ($gambit && ($base eq "ADT2")) {
      $wsl = "ADT2.debug";
      $scm = "ADT2.debugs";
    }
    $ok = 1;
    # If the -force option was given, or the wsl file has changed,
    # or there is a log file (previous wsl2scm failed),
    # then run wsl2scm:
    if ($force || !newer($scm, $wsl) || -f "$base.log") {
      print "wsl2scm $dir/$wsl ... ";
      $outfile = $scm;
      unlink($outfile) if (-f $outfile);
      mysystem("wsl2scm $wsl $scm", "$base.log");
      $log = read_file("$base.log");
      $outfile = "";
      if (!(-f $scm && -s _)) {
	# no output file, or empty output file,
	# so keep the log file
	$ok = 0;
      } elsif ($ok) {
	if ($log =~ /ERROR|!!!!|Too many/) {
	  $ok = 0; # keep the log file
	} else {
	  unlink("$base.log");
	}
      }
      if (!$ok) {
	push(@badfiles, "$dir/$base.wsl");
	print "failed!\n";
	print $log;
      } else {
	print "succeeded.\n";
      }
    }
  } # next file
  chdir $root or die "Can't chdir to `$root': $!\n";
} # next dir

# Add the Scheme files to @src and get the list of global variables:
@src = ();
%globals = ();
foreach $dir (@dirs) {
  foreach $file (grep(/\.scm$/, read_dir($dir))) {
    next if (($file eq "patch.scm") || ($file eq $defs2));
    if ($gambit && ($file eq "ADT2.scm")) {
      $file = "ADT2.debugs";
    }
    push(@src, "$dir/$file");
    open(IN, "$dir/$file") or die "Can't open file `$dir/$file': $!\n";
    while (<IN>) {
      $globals{$1}++ while (s/([^,() "]+)\-save //);
      $globals{$1}++ while (s/\(set\! ([^,() "]+) //);
      $globals{$2}++ while (s/\(cons \(([^,()]+)\) ([^() "]+)\)//);
      $globals{$1}++ while (s/\(for-in ([^,() "]+) //);
      $globals{$1}++ while (s/\(for ([^,() "]+) //); #"
    }
    close(IN);
  } # next file
} # next dir

if (@badfiles) {
  print "The following files failed wsl2scm:\n";
  print join(" ", @badfiles), "\n";
  print "The output file $output will not be created.\n";
  exit(0);
}

print "All Scheme files OK.\n";

print "Expanding macros in source files ... \n";

@macros = grep(/-mac\.scm$/, @src);
@int_macros = ();
@src = grep(!/-mac\.scm$/, @src);

# Create config/macros.scm:
open(MAC, ">../config/macros.scm") or die "Can't write to config/macros.scm: $!\n";
foreach $mac (@macros) {
  open(IN, $mac) or die "Can't read macro file $mac: $!\n";
  while (<IN>) {
    s/;.*$//;
    print MAC unless (/^\s*$/);
  }
  close(IN);
}
close(MAC);


if ($expand_macros) {
  # Expand macros:
  $macros = join(" ", @macros);
  foreach $file (@src) {
    ($out = $file) =~ s/\.scm$/\.scx/;
    if ($force || !newer($out, $file)) {
      print "Expanding $file ... ";
      $outfile = $out;
      mysystem("expand-macros $file $out $macros");
      $outfile = "";
      print "done.\n";
    }
    $file = $out;
  }
  @int_macros = @macros;
  @macros = ();
  $macros = "";
} else {
  # Move any macro files (filename-mac.scm) to the beginning of src:
  @src = (@macros, @src);
}

if (defined($ENV{SCM_IMPL}) && ($ENV{SCM_IMPL} = "bigloo")) {
  mysystem "make-fermat-bigloo @ARGV";
  exit(0);
}

if (!$comp || $big) {
  print "Creating output file `$output' ... ";

  # Write the output file:
  open(OUT, ">$output") or die "Can't open output file `$output': $!\n";

  print OUT qq[(display "Start of file\\n")\n] if ($debug);
  print OUT <<'EOF' if ($gambit);

; Special code for gambit Scheme:

(##readtable-char-class-set! ##main-readtable #\\ #f ##read-number/keyword/symbol)

(define-macro (defmacro name args . body)
  `(define-macro (,name ,@args) ,@body))

; ##shell-command is an "unstable addition":
;(define (system line) (##shell-command line))

; ... but we can open a pipe from a shell:

(define (system line)
  (let* ((pipe (open-input-pipe line))
	 (line '()))
    (let loop ()
      (set! line (@Read_Line pipe))
      (cond ((eof-object? line)
	     #t)
	    (#t (display line)
		(newline)
		(force-output)
		(loop))))))

(define (delete-file file)
  (let* ((pipe (open-input-pipe (string-append "rm -f " file)))
	 (line '()))
    (let loop ()
      (set! line (@Read_Line pipe))
      (cond ((eof-object? line)
	     #t)
	    (#t (display line)
		(newline)
		(force-output)
		(loop))))))

;(define get-internal-run-time runtime)
(define get-internal-run-time cpu-time)

(define print pp)

(define MAX max)

(define MIN min)

(define (force-output) #t)

(define integer-expt expt)

; End of special code for gambit Scheme.

EOF
#` xemacs hack

  foreach $name (sort keys %globals) {
    $name =~ tr/A-Z/a-z/ unless ($gambit);
    print OUT "(define $name '())\n";
  }
  print OUT "\n";

  @stubs = ();
  foreach $file ((@int_macros, @src)) {
    if ($gambit && !$big && ($file =~ /^trans.*_d\.scm$/)) {
      # Make stubs for transformation functions
      # (The definitions of @Foo_Test and @Foo_Code must appear before
      # the foo_d.scm file can be loaded):
      open(FILE, $file);
      while (<FILE>) {
	if (/\(funct \((@[^ \(\)]+)/) {
	  $func = $1;
	  if ($func =~ /_Code$/) {
	    $args{$func} = " //Data";
	  } else {
	    $args{$func} = "";
	  }
	  ($main = $file) =~ s/_d\.scm$/\.scm/;
	  make_stub($func, $main, $file);
	}
      }
    } elsif ($gambit && !$big && ($file =~ /^(trans|wslib)/)) {
      push(@stubs, $file);
      next;
    }
    print OUT qq[(display "Loading $file\\n")\n] if ($debug);
    if ($big) {
      # Copy in the whole file contents
      # Don't copy macros if they have been expanded:
      next if $expand_macros && ($file =~ /-mac\.scm$/);
      open(IN, $file) or die "Can't open source file `$file': $!\n";
      print OUT <IN>;
      close(IN);
    } else {
      if ($gambit && ($file =~ /-mac\.scm$/)) {
	print OUT qq[(include "$root/$file")\n];
      } else {
	print OUT qq[(load "$root/$file")\n];
      }
    }
  } # next source file

  make_stubs(@stubs) if (@stubs);

  print OUT qq[(display "All files loaded\\n")\n] if ($debug);
  close(OUT);

  print "Done.\n";

}

exit(0) unless ($comp);

# Compilation section:

$macros = "";
$load_macros = "";
for $macro (@macros) {
  $macros .= qq[ "../$macro"];
  $load_macros .= qq[(load "../$macro")\n];
}

if ($big) {
  @comp = ($output);
  $load_hobbit = qq[(load "$scm_base/hobbit.scm")];
  if (-f "$FermaT/$arch/hobbit") {
    # hobbit-compiled hobbit is available
    $load_hobbit = "";
    $hobbit = "$FermaT/$arch/hobbit";
  }
  # Compile the big $output we just created
  ($base = $output) =~ s/\.scm$//;
  $data = <<EOF;
(define (user-interrupt . args) (exit 1)) ; Cause ^C to force an exit
$load_macros
;(load "$scm_base/hobbit.scm")
(hobbit "$output" $macros)
(exit)
EOF
  # Protect \'s in data:
  $data =~ s/\\/\\\\/g;
  $tmpfile = tmpfile($data);
  print "Compiling $output... ";
  mysystem qq["$hobbit" -p1 -f $tmpfile], "$base.clog";
  unlink($tmpfile);
  $log = read_file("$base.clog");
  if (($log =~ /C source file $base\.c is built/)
         && ($log =~ /C header file $base\.h is built/)) {
    print "succeeded.\n";
    unlink("$base.clog");
  } else {
    print "failed!\n";
    print $log;
    exit(1);
  }
  # Compile the C file and add the object to @links:
  gcc(".", "$base.c", "$objdir/$base.o");

} else {

  @comp = @src;
  # File $defs2 will be created from the other Scheme files:
  print "Building $defs2 ...\n";
  rename("scheme/$defs2", "scheme/$defs2.orig");
  open(DEFS2, ">scheme/$defs2") or die "Can't write to $defs2: $!\n";
  foreach $name (sort keys %globals) {
    $name =~ tr/A-Z/a-z/ if ($expand_macros);
    print DEFS2 "(define $name '())\n";
  }
  print DEFS2 "\n";
  close(DEFS2);
  if (diff("scheme/$defs2", "scheme/$defs2.orig")) {
    # Use the new one:
    unlink("scheme/$defs2.orig");
  } else {
    # Keep the old one:
    print "Using old $defs2\n";
    rename("scheme/$defs2.orig", "scheme/$defs2");
  }

  # Prepend $defs2 to @comp list:
  unshift(@comp, "scheme/$defs2");

  ### Build and compile separate C files: ###

  print "Building $defs1 ...\n";
  %defs = ();
  foreach $file (@comp) {
    open(IN, $file) or die "Can't open $file: $!\n";
    while (<IN>) {
      $defs{$1} = 1 if (/^\(define \(([^\(\) ]+)/);
    }
    close(IN);
  }

  open(DEFS1, ">$defs1") or die "Can't write to $defs1: $!\n";
  # was: *special-scm->c-functions*
  print DEFS1 "(set! *internal-c-functions* (append *internal-c-functions* '(\n";
  foreach $name (sort(keys(%defs))) {
    print DEFS1 "$name\n";
  }
  print DEFS1 ")))\n";
  close(DEFS1);

  print "Compiling files ...\n";
  foreach $file (@comp) {
    next if ($file =~ /-mac\.scm$/);
    next if ($file =~ /_d\.sc[mx]$/);
    ($dir, $base, $ext) = ($file =~ m!^([^/]*)/(.*)\.(sc[mx])$!);
    if ($ext eq "scm") {
      $cbase = $base;
    } else {
      $cbase = "$base.$ext";
    }
    chdir $dir or die "Can't chdir to `$dir': $!\n";
    # If the -force option was given, or the scm file has changed,
    # or there is a log file (previous compile failed),
    # then run hobbit:
    if ($force || !newer("$cbase.c", "$base.$ext") || -f "$base.clog") {
      print "hobbit $dir/$base.$ext ...   ";

      # Add a prefix so that local vars/consts are unique accross files:
      ($pref = $base) =~ s/-/_/g;
      # Check for a foo_d file and compile it with the base file:
      $files = qq["$base.$ext"];
      $files .= qq[ "${base}_d.$ext"] if (-f "${base}_d.$ext");
      $data = <<EOF;

(define (user-interrupt . args) (exit 1)) ; Cause ^C to force an exit
$load_macros
; Cannot use hobbit-compiled hobbit because we need to
; change some internal variables for each file:
(load "$scm_base/hobbit.scm")
; Add $pref to these defines:

(define *local-var-infix* "__$pref")
(define *new-var-name* "new_var$pref")
(define *tmp-var-name* "tmp_var$pref")
(define *new-parameter-prefix* "npar__$pref")
(define *new-fun-infix* "_aux$pref")
(define *new-letfun-infix* "_fn$pref")
(define *new-instfun-infix* "_inst$pref")
(define *new-constant-prefix* "const_$pref")
(define *closure-name-suffix* "_cl$pref")
(define *closure-vector-name* "clargsv_$pref")

(load "../$defs1")
;(define (unknown-function? fn args) #f) ; Assume external fns are also compiled
(hobbit $files $macros)
(exit)

EOF

      # Protect \'s in data:
      $data =~ s/\\/\\\\/g;
      $tmpfile = tmpfile($data);
      mysystem qq["$hobbit" -p1 -f $tmpfile], "$base.clog";
      unlink($tmpfile);
      $log = read_file("$base.clog");
      if (    ($log =~ /C source file ${base}\.${ext}\.c is built/)
           && ($log =~ /C header file ${base}\.${ext}\.h is built/)) {
        $ok = 1;
        unlink("$base.clog");
      } elsif (    ($log =~ /C source file ${base}\.c is built/)
                && ($log =~ /C header file ${base}\.h is built/)) {
        $ok = 1;
        unlink("$base.clog");
      } else {
        $ok = 0;
      }
      if (!$ok) {
        push(@badfiles, "$dir/$base.$ext");
        print "failed!\n$log";
      } else {
        print "succeeded.\n";
      }
    }
    gcc($dir, "$cbase.c", "$objdir/$dir-$cbase.o");
    chdir $root or die "Can't chdir to `$root': $!\n";
  } # next file

  if (@badfiles) {
    print "The following files failed to compile:\n";
    print join(" ", @badfiles), "\n";
    print "The output file `$scm_comp' will not be created.\n";
    exit(0);
  }
}

print "All .o files ready.\n";

# Load all the object files into an executable:

print "Building scm.c ...\n";

$scmobj = "$objdir/scm-init-scm.o";
if (-f $scmobj && -f "scm.c" && newer($scmobj, "scm.c")) {
  # Save existing .c file in case existing .o file can be used
  # (It only changes when a new file is added to or removed from the build)
  rename("scm.c", "scm.c.orig");
} else {
  unlink("scm.c.orig");
}

# Get a list of all init functions:
$inits = "";
foreach $file (@comp) {
  if ($file =~ /\.scm$/) {
    ($cfile = $file) =~ s/\.scm/.c/;
  } else {
    $cfile = "$file.c";
  }
  open(IN, $cfile) || next;
  while (<IN>) {
    next unless (/^SCM (init_\D\w*)\(\)$/);
    $inits .= "printf(\"$1()\\n\");\n" if ($debug);
    $inits .= "$1();\n";
  }
}

open(IN, "$scm_base/scm.c") or die "Can't open $scm_base/scm.c: $!\n";
open(OUT, ">scm.c") or die "Can't write to scm.c: $!\n";
while (<IN>) {
  s/^\s*COMPILED_INITS;/$inits/;
  print OUT;
}
close(IN);
close(OUT);

if ((-f "scm.c.orig") && !diff("scm.c", "scm.c.orig")) {
  print "Using old scm.o\n";
  rename("scm.c.orig", "scm.c");
} else {
  print "Compiling scm.c ... ";
  mysystem qq[$gcc -I"$scm_base" -DCOMPILED_INITS $optimise -c scm.c -o "$scmobj"];
  if (!-f $scmobj) {
    print "failed!\n";
    exit(0)
  } else {
    print "succeeded.\n";
  }
}
push(@links, $scmobj);

foreach (@links) {
  s/^$objdir\///;
}

print "Linking $scm_comp ... \n";
$line = qq[$gcc $optimise -o "$root/$scm_comp" ] . join(" ", @links) . " $libs";

unlink("$root/$scm_comp");
chdir $objdir or die "Can't chdir $objdir: $!\n";
#print "$line\n";
mysystem($line);
chdir $root;
if (-f $scm_comp) {
  print "\nExecutable $scm_comp sucessfully built.\n";
  mysystem("strip $scm_comp") unless ($gprof || $optimise =~ /-g/);
  if ($install) {
    rename("../$arch/$scmfmt", "../$arch/$scmfmt.old");
    rename($scm_comp, "../$arch/$scmfmt");
    chmod(0755, "../$arch/$scmfmt");
    print "  $scmfmt installed to $arch.\n";
  }
} else {
  print "\nFailed to create $scm_comp.\n";
}

exit(0);


# Get a sorted list of files in a directory, skipping "." and ".."
# and sccs-create files (,filename):

sub read_dir($) {
  my ($dir) = @_;
  my @files = ();
  local(*DIR);
  opendir(DIR, $dir) or die "Can't read directory `$dir': $!\n";
  @files = sort grep { !/^\./ && !/^,/ } readdir(DIR);
  closedir(DIR);
  return(@files);
}



sub alarm_clock {
  print "!!! Alarm clock call: the current process is taking too long...\n";
  if ($PID) {
    print "!!! Killing job: $PID... ";
    $result = kill -15, $PID;
    if ($result) {
      print "succeeded.\n";
      if (-f $outfile) {
	print "Deleting $outfile\n";
	unlink($outfile);
      }
    } else {
      print "failed\n";
    }
    # Ensure that the process is really dead:
    sleep(10);
    kill -9, $PID;
  }
}


# Find all functions defined in these files and called from another file
# (including transformation files @xxx_Test @xxx_Code)
# and make a stub definition which loads the file:

sub make_stubs(@) {
  my (@files) = @_;
  my ($file, $func);
  local $_;
  print "making stub definitions ... ";
  # Ignore calls to functions in the adt files:
  %ignore = ();
  foreach $file (@src) {
    next unless ($file =~ /^adt/);
    open(FILE, $file);
    while (<FILE>) {
      $ignore{$1}++ if (/^\(define \((@[^ \(\)]+) /);
    }
    close(FILE);
  }
  # Record which files call which functions
  # and which functions are defined in each file
  %called_in = ();
  %defined_in = ();
  foreach $file (@src) {
    open(FILE, $file);
    while (<FILE>) {
      while (s/\(define \((@[^ \(\)]+)([^\(\)]*)\)/ /) {
	next if ($ignore{$1});
	$args{$1} = $2;
	$defined_in{$file}{$1}++;
      }
      while (s/\((@[^ \(\)]+)/ /) {
	next if ($ignore{$1});
	$called_in{$1}{$file}++;
      }
    }
    close(FILE);
  }
  # Make stubs for functions defined in a stub file and called elsewhere:
  foreach $file (@files) {
    foreach $func (keys %{$defined_in{$file}}) {
      if ($extern{$func} || grep { $_ ne $file } keys %{$called_in{$func}}) {
	make_stub($func, $file, "");
      }
    }
  }
}

sub make_stub($$$) {
  my ($func, $file, $dfile) = @_;
  return() if ($done_stub{$func}++);
  my $call = "($func" . "$args{$func})";
  #print "Stubifying $func, $file\n";
  print OUT "(define $call\n";
  print OUT "  (display \"Loading $file\\n\")\n" if ($debug);
  print OUT "  (load \"$FermaT/src/$file\")\n";
  print OUT "  (load \"$FermaT/src/$dfile\")\n" if ($dfile ne "");
  print OUT "  $call)\n";
}


# Compare two files:

sub diff($$) {
  my ($file1, $file2) = @_;
  my ($buf1, $buf2, $n1, $n2);
  die "Can't read `$file1': $!\n" unless (-r $file1);
  $n1 = -s _;
  die "Can't read `$file2': $!\n" unless (-r $file2);
  $n2 = -s _;
  # Compare sizes first:
  return(1) unless ($n1 == $n2);
  local (*F1, *F2);
  open(F1, $file1);
  open(F2, $file2);
  my $blksize = (stat F1)[11] || 8192;
  for (;;) {
    $n1 = sysread(F1, $buf1, $blksize);
    $n2 = sysread(F2, $buf2, $blksize);
    last if (($n1 < $blksize) || ($n2 < $blksize));
    last if ($buf1 ne $buf2);
  }
  close(F1);
  close(F2);
  return($buf1 ne $buf2);
}


# Compile a C file if necessary and add the object file to @links:

sub gcc($$$) {
  my ($dir, $src, $obj) = @_;
  if (!newer($obj, $src)) {
    print "   $gcc $dir/$src ... ";
    $outfile = $obj;
    mysystem qq[$gcc -I"$scm_base" $optimise -c "$src" -o "$obj"];
    if (!-f $obj) {
      push(@badfiles, $src);
      print "failed!\n";
    } else {
      print "succeeded.\n";
      $outfile = "";
    }
  }
  push(@links, $obj);
}

# Ensure scmlit and hobbit are up to date
# We are currently in the scm directory
sub make_hobbit() {
  return() if (-f $hobbit);
  if (!-f $scmlit) {
    # Link scmlit:
    print "Compiling scm.c ...\n";
    mysystem qq[$gcc -I"$scm_base" $optimise -c scm.c -o "$objdir/scm-scm.o"];
    print "Linking scmlit ...\n";
    mysystem qq[$gcc -o "$scmlit" "$objdir/scm-scm.o" ]
		 . join(" ", map { qq["$_"] } @objects) . " $libs";
    die "Build of $scmlit failed!\n" unless (-f $scmlit);
  }
  return() if (-f $hobbit); # in case $hobbit eq $scmlit
  # Compile hobbit:
  $tmpfile = tmpfile(qq[(load "hobbit.scm")(hobbit "hobbit.scm")\n]);
  print "Compiling hobbit.scm ...\n";
  mysystem qq["$scmlit" -f $tmpfile];
  unlink($tmpfile);
  die "Hobbit compile of hobbit failed!\n" unless (-f "hobbit.c");
  print "Compiling hobbit.c ...\n";
  mysystem qq[$gcc -I"$scm_base" $optimise -c hobbit.c -o "$objdir/h-hobbit.o"];
  print "Compiling scm.c ...\n";
  mysystem qq[$gcc -I"$scm_base" $optimise -c scm.c ]
	    . qq[-DCOMPILED_INITS="init_hobbit();" -o "$objdir/h-scm.o"];
  print "Linking hobbit ...\n";
  mysystem qq[$gcc -o $hobbit $objdir/h-scm.o $objdir/h-hobbit.o ]
	       . join(" ", map { qq["$_"] } @objects) . " $libs";
}


sub read_file($) {
  my ($file) = @_;
  my $fh;
  open($fh, $file) or die "Can't read $file: $!\n";
  my $r = join("", <$fh>);
  close($fh);
  return($r);
}

