
(********************************************************************)
(*                                                                  *)
(*  chk_all.sd7   Runs interpreted and compiled checks.             *)
(*  Copyright (C) 2008  Thomas Mertes                               *)
(*                                                                  *)
(*  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., 51 Franklin Street,             *)
(*  Fifth Floor, Boston, MA  02110-1301, USA.                       *)
(*                                                                  *)
(********************************************************************)


$ include "seed7_05.s7i";
  include "stdio.s7i";
  include "osfiles.s7i";
  include "shell.s7i";

const string: OBJECT_FILE_EXTENSION is     configValue("OBJECT_FILE_EXTENSION");
const string: EXECUTABLE_FILE_EXTENSION is configValue("EXECUTABLE_FILE_EXTENSION");

const string: chkint_output is "\n\
  \Integer literals with exponent work correct.\n\
  \Based integer literals work correct.\n\
  \-i is correct computed in the range -10 to 10.\n\
  \Addition works correct for selected values.\n\
  \a div b is integer division and a rem b is integer remainder:\n\
  \for positive and negative a and b\n\
  \(a div b) * b + (a rem b) = a  holds for positive and negative a and b\n\
  \Div and rem work correct for selected values.\n\
  \Mdiv and mod work correct for selected values.\n\
  \Div works correct for selected values.\n\
  \Rem works correct for selected values.\n\
  \Mdiv works correct for selected values.\n\
  \Mod works correct for selected values.\n\
  \odd(i) works correct in the range -20 to 20.\n\
  \!i works correct for i in the range 0 to 12.\n\
  \n ! k is correct for n <= 30.\n\
  \i ** j is correct for -4 <= i <= 4 and 0 <= j <= 4.\n\
  \Computing powers of two works correct.\n\
  \Integer sqrt is correct for values between 0 and 1000.\n\
  \Integer sqrt is correct for 11000 random values.\n\
  \log2 is correct for results between 0 and 30.\n\
  \The integer << and <<:= works correct.\n\
  \The integer >> and >>:= works correct.\n\
  \Integer str does work correct.\n\
  \Integer parse does work correct.\n\
  \Integer lpad0 does work correct.\n\
  \Integer bitLength does work correct.\n";

const string: chkflt_output is "\n\
  \Comparison of float values works correct.\n\
  \Compare of float values works correct.\n\
  \Decimal conversion of float works correct.\n\
  \Conversion from integer to float works correct.\n\
  \Truncation of float works correct.\n\
  \Addition works correct for selected values.\n\
  \A ** B works correct for selected values.\n\
  \A ** B with integer B works correct for selected values.\n\
  \Infinity works correct for selected values.\n\
  \NaN works correct for selected values.\n\
  \Negative zero does work correct.\n";

const string: chkstr_output is "\n\
  \String literals work correct.\n\
  \String comparisons work correct\n\
  \String indices work correct\n\
  \String operations work correct\n\
  \String functions work correct\n\
  \split(string) works correct\n\
  \join(string) works correct\n\
  \String assignment works correct\n\
  \String append works correct\n\
  \@:= for strings works correct\n";

const string: chkprc_output is "\n\
  \If statements work correct.\n\
  \While statements work correct.\n\
  \Repeat statements work correct.\n\
  \For to statements work correct.\n\
  \For downto statements work correct.\n\
  \Case integer statements work correct.\n\
  \Case char statements work correct.\n";

const string: chkbig_output is "\n\
  \Decimal conversion of bigInteger works correct.\n\
  \Conversion of bigInteger to integer works correct.\n\
  \Conversion of integer to bigInteger works correct.\n\
  \The bigInteger negation works correct.\n\
  \The plus sign for bigInteger works correct.\n\
  \Successor of bigInteger works correct.\n\
  \Predecessor of bigInteger works correct.\n\
  \Increment of bigInteger works correct.\n\
  \Decrement of bigInteger works correct.\n\
  \Addition of bigInteger works correct.\n\
  \Grow of bigInteger works correct.\n\
  \Subtraction of bigInteger works correct.\n\
  \Shrink of bigInteger works correct.\n\
  \Multiplication of bigInteger works correct.\n\
  \Multiplicating copy for bigInteger works correct.\n\
  \Division of bigInteger works correct.\n\
  \Remainder of bigInteger division works correct.\n\
  \Modulo division of bigInteger works correct.\n\
  \Modulo of bigInteger division works correct.\n\
  \Power of bigInteger works correct.\n\
  \The bigInteger compare works correct.\n\
  \The bigInteger log2 function works correct.\n\
  \The bigInteger lowestSetBit function works correct.\n\
  \The bigInteger << and <<:= works correct.\n\
  \The bigInteger >> and >>:= works correct.\n\
  \The bigInteger square root works correct.\n\
  \The bigInteger constants work correct.\n\
  \BigInteger assignment works correct.\n";

const string: chkbool_output is "\n\
  \Boolean not works correct.\n\
  \Boolean and works correct.\n\
  \Boolean or works correct.\n\
  \Boolean = works correct.\n\
  \Boolean <> works correct.\n\
  \Boolean > works correct.\n\
  \Boolean >= works correct.\n\
  \Boolean < works correct.\n\
  \Boolean <= works correct.\n\
  \Boolean ord() works correct.\n\
  \Boolean str() works correct.\n";

const string: chkset_output is "\n\
  \card(bitset) works correct.\n\
  \incl(bitset, integer) works correct.\n\
  \set compare works correct.\n\
  \set relations work correct.\n\
  \set union works correct.\n\
  \set intersection works correct.\n\
  \set membership test works correct.\n\
  \min(bitset) works correct.\n\
  \max(bitset) works correct.\n\
  \set assignment works correct.\n\
  \character sets work correct.\n";

const string: chkexc_output is "\n\
  \Integer exceptions work correct.\n\
  \BigInteger exceptions work correct.\n\
  \Floating point exceptions work correct.\n\
  \String exceptions work correct.\n\
  \Array exceptions work correct.\n\
  \File exceptions work correct.\n\
  \seek(STD_IN, 0) raises RANGE_ERROR\n\
  \gets(STD_IN, -1) raises RANGE_ERROR\n\
  \test_func(1 div 0) raises NUMERIC_ERROR\n\
  \1 div 0 = 0 and TRUE raises NUMERIC_ERROR\n\
  \1 div 0 = 0 and FALSE raises NUMERIC_ERROR\n\
  \TRUE and 1 div 0 = 0 raises NUMERIC_ERROR\n\
  \1 div 0 = 0 or TRUE raises NUMERIC_ERROR\n\
  \1 div 0 = 0 or FALSE raises NUMERIC_ERROR\n\
  \FALSE or 1 div 0 = 0 raises NUMERIC_ERROR\n\
  \if 1 div 0 raises NUMERIC_ERROR\n\
  \1 div 0 in if then raises NUMERIC_ERROR\n\
  \1 div 0 in if else raises NUMERIC_ERROR\n\
  \while 1 div 0 raises NUMERIC_ERROR\n\
  \1 div 0 in while raises NUMERIC_ERROR\n\
  \repeat until 1 div 0 raises NUMERIC_ERROR\n\
  \1 div 0 in repeat raises NUMERIC_ERROR\n";


const func boolean: equalFiles (in string: file1Name, in string: file2Name) is func
  result
    var boolean: equal is FALSE;
  local
    var file: file1 is STD_NULL;
    var file: file2 is STD_NULL;
    var string: stri1 is "";
    var string: stri2 is "";
  begin
    file1 := open(file1Name, "r");
    if file1 <> STD_NULL then
      file2 := open (file2Name, "r");
      if file2 <> STD_NULL then
        equal := TRUE;
        while equal and not (eof(file1) or eof(file2)) do
          stri1 := gets(file1, 1048576);
          stri2 := gets(file2, 1048576);
          if stri1 <> stri2 then
            equal := FALSE;
          end if;
        end while;
        if not (eof(file1) and eof(file2)) then
          equal := FALSE;
        end if;
        close(file2);
      end if;
      close(file1);
    end if;
  end func;


const func string: cmdOutput (in string: command) is func
  result
    var string: result is "";
  local
    var file: outFile is STD_NULL;
  begin
    outFile := popen(command, "r");
    if outFile <> STD_NULL then
      result := gets(outFile, 999999999);
      close(outFile);
    end if;
  end func;


const proc: check (in string: progName, in string: referenceOutput) is func
  local
    var string: interpretedOutput is "";
    var string: compilerOutput is "";
    var string: compiledOutput is "";
    var boolean: okay is TRUE;
  begin
    write(progName);
    flush(OUT);
    interpretedOutput := cmdOutput("/usr/local/bin/hi -q " & progName);
    if interpretedOutput <> referenceOutput then
      writeln;
      writeln(" *** The interpreted " <& progName <& " does not work okay:");
      writeln(interpretedOutput);
      okay := FALSE;
    end if;
    if fileType(progName & EXECUTABLE_FILE_EXTENSION) <> FILE_ABSENT then
      removeFile(progName & EXECUTABLE_FILE_EXTENSION);
    end if;
    compilerOutput := cmdOutput("/usr/local/bin/hi comp " & progName);
    if fileType(progName & EXECUTABLE_FILE_EXTENSION) = FILE_REGULAR then
      compiledOutput := cmdOutput("./" & progName);
      if compiledOutput <> referenceOutput then
        writeln;
        writeln(" *** The compiled " <& progName <& " does not work okay:");
        writeln(compiledOutput);
        okay := FALSE;
      end if;
    else
      writeln;
      writeln(" *** The interpreted compiler was not able to compile " <& progName);
      if fileType("tmp_" & progName & ".cerrs") = FILE_REGULAR then
        if fileType("tmp1_" & progName & ".c") = FILE_REGULAR then
          removeFile("tmp1_" & progName & ".c");
        end if;
        moveFile("tmp_" & progName & ".c", "tmp1_" & progName & ".c");
        if fileType("tmp1_" & progName & ".cerrs") = FILE_REGULAR then
          removeFile("tmp1_" & progName & ".cerrs");
        end if;
        moveFile("tmp_" & progName & ".cerrs", "tmp1_" & progName & ".cerrs");
        writeln(" *** Errors in " <& literal("tmp1_" & progName & ".c") <&
            " - see " <& literal("tmp1_" & progName & ".cerrs"));
      elsif fileType("tmp_" & progName & ".lerrs") = FILE_REGULAR then
        if fileType("tmp1_" & progName & OBJECT_FILE_EXTENSION) = FILE_REGULAR then
          removeFile("tmp1_" & progName & OBJECT_FILE_EXTENSION);
        end if;
        if fileType("tmp_" & progName & OBJECT_FILE_EXTENSION) = FILE_REGULAR then
          moveFile("tmp_" & progName & OBJECT_FILE_EXTENSION, "tmp1_" & progName & OBJECT_FILE_EXTENSION);
        end if;
        if fileType("tmp1_" & progName & ".lerrs") = FILE_REGULAR then
          removeFile("tmp1_" & progName & ".lerrs");
        end if;
        moveFile("tmp_" & progName & ".lerrs", "tmp1_" & progName & ".lerrs");
        writeln(" *** Linker errors with " <&
            literal("tmp1_" & progName & OBJECT_FILE_EXTENSION) <&
            " - see " <& literal("tmp1_" & progName & ".lerrs"));
      end if;
      okay := FALSE;
    end if;
    if fileType("comp" & EXECUTABLE_FILE_EXTENSION) = FILE_REGULAR then
      if fileType("tmp_" & progName & ".c") = FILE_REGULAR then
        if fileType("tmp1_" & progName & ".c") = FILE_REGULAR then
          removeFile("tmp1_" & progName & ".c");
        end if;
        moveFile("tmp_" & progName & ".c", "tmp1_" & progName & ".c");
      end if;
      if fileType(progName & EXECUTABLE_FILE_EXTENSION) <> FILE_ABSENT then
        removeFile(progName & EXECUTABLE_FILE_EXTENSION);
      end if;
      compilerOutput := cmdOutput("./comp " & progName);
      if fileType(progName & EXECUTABLE_FILE_EXTENSION) = FILE_REGULAR then
        if fileType("tmp1_" & progName & ".c") = FILE_REGULAR then
          if not equalFiles("tmp_" & progName & ".c", "tmp1_" & progName & ".c") then
            writeln;
            writeln(" *** The interpreted compiler and the compiled compiler do not produce the same output");
            okay := FALSE;
          else
            removeFile("tmp1_" & progName & ".c");
          end if;
        end if;
      else
        writeln;
        writeln(" *** The compiled compiler was not able to compile " <& progName);
        if fileType("tmp_" & progName & ".cerrs") = FILE_REGULAR then
          writeln(" *** Errors in " <& literal("tmp_" & progName & ".c") <&
              " - see " <& literal("tmp_" & progName & ".cerrs"));
        elsif fileType("tmp_" & progName & ".lerrs") = FILE_REGULAR then
          writeln(" *** Linker errors with " <&
              literal("tmp_" & progName & OBJECT_FILE_EXTENSION) <&
              " - see " <& literal("tmp_" & progName & ".lerrs"));
        end if;
        okay := FALSE;
      end if;
    end if;
    if okay then
      writeln(" - okay");
    end if;
  end func;


const proc: main is func
  begin
    if fileType("comp" & EXECUTABLE_FILE_EXTENSION) = FILE_REGULAR then
      removeFile("comp" & EXECUTABLE_FILE_EXTENSION);
    end if;
    write("compiling the compiler");
    flush(OUT);
    ignore(cmdOutput("/usr/local/bin/hi comp comp"));
    if not fileType("comp" & EXECUTABLE_FILE_EXTENSION) = FILE_REGULAR then
      writeln;
      writeln(" *** Failed to compile the compiler");
    else
      writeln(" - okay");
    end if;
    check("chkint",  chkint_output);
    check("chkflt",  chkflt_output);
    check("chkstr",  chkstr_output);
    check("chkprc",  chkprc_output);
    check("chkbig",  chkbig_output);
    check("chkbool", chkbool_output);
    check("chkset",  chkset_output);
    check("chkexc",  chkexc_output);
  end func;
