(********************************************************************)
(*                                                                  *)
(*  error.s7i     Support to raise exceptions.                      *)
(*  Copyright (C) 1990 - 1994, 2004 - 2014  Thomas Mertes           *)
(*                                                                  *)
(*  This file is part of the Seed7 compiler.                        *)
(*                                                                  *)
(*  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.                       *)
(*                                                                  *)
(********************************************************************)


var type: catchExceptionLevelType is hash [string] integer;

var catchExceptionLevelType: catchExceptionLevel is catchExceptionLevelType.value;
var integer: catchAllExceptionsLevel is 0;


const proc: increaseLevelOfCatchedExceptions (in var reference: current_catch) is func

  local
    var ref_list: catch_expr is ref_list.EMPTY;
    var string: exceptionName is "";
  begin
    catch_expr := getValue(current_catch, ref_list);
    while current_catch <> NIL and
        category(current_catch) = MATCHOBJECT and
        length(catch_expr) >= 5 do
      exceptionName := str(catch_expr[3]);
      if exceptionName in catchExceptionLevel then
        incr(catchExceptionLevel[exceptionName]);
      else
        catchExceptionLevel @:= [exceptionName] 0;
      end if;
      if length(catch_expr) >= 6 then
         current_catch := catch_expr[6];
        catch_expr := getValue(current_catch, ref_list);
      else
        current_catch := NIL;
      end if;
    end while;
  end func;


const proc: decreaseLevelOfCatchedExceptions (in var reference: current_catch) is func

  local
    var ref_list: catch_expr is ref_list.EMPTY;
    var string: exceptionName is "";
  begin
    catch_expr := getValue(current_catch, ref_list);
    while current_catch <> NIL and
        category(current_catch) = MATCHOBJECT and
        length(catch_expr) >= 5 do
      exceptionName := str(catch_expr[3]);
      if exceptionName in catchExceptionLevel then
        decr(catchExceptionLevel[exceptionName]);
      else
        raise RANGE_ERROR;
      end if;
      if length(catch_expr) >= 6 then
         current_catch := catch_expr[6];
        catch_expr := getValue(current_catch, ref_list);
      else
        current_catch := NIL;
      end if;
    end while;
  end func;


const func string: raiseError (in string: exceptionName) is func

  result
    var string: expr is "";
  begin
    expr &:= "raiseError(";
    expr &:= exceptionName;
    expr &:= ");\n";
  end func;


const func string: intRaiseError (in string: exceptionName) is func

  result
    var string: expr is "";
  begin
    expr &:= "intRaiseError(";
    expr &:= exceptionName;
    expr &:= ")";
  end func;


const func string: bigRaiseError (in string: exceptionName) is func

  result
    var string: expr is "";
  begin
    expr &:= "bigRaiseError(";
    expr &:= exceptionName;
    expr &:= ")";
  end func;


const func string: strRaiseError (in string: exceptionName) is func

  result
    var string: expr is "";
  begin
    expr &:= "strRaiseError(";
    expr &:= exceptionName;
    expr &:= ")";
  end func;


const func string: refRaiseError (in string: exceptionName) is func

  result
    var string: expr is "";
  begin
    expr &:= "refRaiseError(";
    expr &:= exceptionName;
    expr &:= ")";
  end func;


const proc: writeLine (in string: fileName, in integer: fileLine) is func

  local
    const integer: bufferSize is 4096;
    var file: sourceFile is STD_NULL;
    var string: buffer is "";
    var integer: lineNumber is 1;
    var integer: startPos is 1;
    var integer: endPos is 0;
    var integer: pos is 1;
  begin
    sourceFile := open(fileName, "r");
    if sourceFile <> STD_NULL then
      repeat
        buffer := gets(sourceFile, bufferSize);
        pos := pos(buffer, '\n');
        while pos <> 0 and lineNumber < fileLine do
          incr(lineNumber);
          startPos := succ(pos);
          pos := pos(buffer, '\n', startPos);
        end while;
      until lineNumber = fileLine or buffer = "";
      if lineNumber = fileLine then
        if pos <> 0 then
          if pos > 1 and buffer[pred(pos)] = '\r' then
            writeln(buffer[startPos .. pos - 2]);
          else
            writeln(buffer[startPos .. pred(pos)]);
          end if;
        else
          if length(buffer) > 1 and
              buffer[length(buffer)] = '\r' then
            write(buffer[startPos .. pred(length(buffer))]);
          else
            write(buffer[startPos ..]);
          end if;
          repeat
            buffer := gets(sourceFile, bufferSize);
            pos := pos(buffer, '\n');
            if pos = 0 then
              if length(buffer) > 1 and
                  buffer[length(buffer)] = '\r' then
                write(buffer[startPos .. pred(length(buffer))]);
              else
                write(buffer[startPos ..]);
              end if;
            end if;
          until pos <> 0 or buffer = "";
          if pos <> 0 then
            if pos > 1 and buffer[pred(pos)] = '\r' then
              writeln(buffer[.. pos - 2]);
            else
              writeln(buffer[.. pred(pos)]);
            end if;
          end if;
        end if;
      end if;
      close(sourceFile);
    end if;
  end func;


const proc: warning (COMPARISON_RESULT_CONSTANT, in string: comparisonName,
    in boolean: comparisonResult, in expr_type: c_expr) is func
  begin
    if warning_level >= 2 then
      writeln("*** " <& c_expr.currentFile <& "(" <& c_expr.currentLine <&
              "): Comparison with " <& comparisonName <&
              " always evaluates to " <& comparisonResult <& ".");
      writeLine(c_expr.currentFile, c_expr.currentLine);
      writeln;
    end if;
  end func;


const proc: warning (DOES_RAISE, in string: exceptionName, in expr_type: c_expr) is func
  begin
    if warning_level >= 2 then
      writeln("*** " <& c_expr.currentFile <& "(" <& c_expr.currentLine <&
              "): Expression raises " <& exceptionName <& ".");
      writeLine(c_expr.currentFile, c_expr.currentLine);
      writeln;
    end if;
  end func;


const proc: checkWarning (CATCH_WITH_SUPPRESSED_CHECK, in string: exceptionName, in reference: place) is func
  begin
    if warning_level >= 1 and
        ((not (string_index_check and bstring_index_check and array_index_check) and exceptionName = "INDEX_ERROR") or
         (not integer_division_check and exceptionName = "NUMERIC_ERROR") or
         (not integer_overflow_check and exceptionName = "OVERFLOW_ERROR") or
         (not (function_range_check and conversion_range_check) and exceptionName = "RANGE_ERROR")) then
      writeln("*** " <& sourceNameString(file(place)) <& "(" <& line(place) <&
              "): Catch of " <& exceptionName <& " although the checks are suppressed.");
      writeLine(file(place), line(place));
      writeln;
    end if;
  end func;


const proc: checkWarning (CATCH_OTHERWISE_WITH_SUPPRESSED_CHECK, in reference: place) is func
  local
    var array string: exceptionNameList is 0 times "";
    var integer: index is 0;
  begin
    if warning_level >= 2 then
      if not (string_index_check and bstring_index_check and array_index_check) then
        exceptionNameList &:= "INDEX_ERROR";
      end if;
      if not integer_division_check then
        exceptionNameList &:= "NUMERIC_ERROR";
      end if;
      if not integer_overflow_check then
        exceptionNameList &:= "OVERFLOW_ERROR";
      end if;
      if not (function_range_check and conversion_range_check) then
        exceptionNameList &:= "RANGE_ERROR";
      end if;
      if length(exceptionNameList) <> 0 then
        write("*** " <& sourceNameString(file(place)) <& "(" <& line(place) <&
              "): Catch of otherwise although the checks for ");
        for index range 1 to pred(length(exceptionNameList)) do
          if index <> 1 then
            write(", ");
          end if;
          write(exceptionNameList[index]);
        end for;
        if length(exceptionNameList) >= 2 then
          write(" and ");
        end if;
        write(exceptionNameList[length(exceptionNameList)]);
        writeln(" are suppressed.");
        writeLine(file(place), line(place));
        writeln;
      end if;
    end if;
  end func;


const proc: error (WHEN_OVERLAPPING, in bitset: overlappingWhenValues,
    in reference: current_expression) is func
  begin
    if warning_level >= 1 then
      writeln("*** " <& file(current_expression) <& "(" <& line(current_expression) <&
              "): Duplicate when values " <& overlappingWhenValues <& ".");
      writeLine(file(current_expression), line(current_expression));
      writeln;
    end if;
  end func;


const proc: error (WHEN_PREVIOUS, in bitset: overlappingWhenValues,
    in reference: current_expression) is func
  begin
    if warning_level >= 1 then
      writeln("*** " <& file(current_expression) <& "(" <& line(current_expression) <&
              "): Previous usage of " <& overlappingWhenValues <& ".");
      writeLine(file(current_expression), line(current_expression));
      writeln;
    end if;
  end func;


const proc: error (EMPTY_WHEN_SET, in reference: current_expression) is func
  begin
    if warning_level >= 1 then
      writeln("*** " <& file(current_expression) <& "(" <& line(current_expression) <&
              "): When set is empty.");
      writeLine(file(current_expression), line(current_expression));
      writeln;
    end if;
  end func;


const proc: error (VARIABLE_WHEN, in reference: current_expression) is func
  begin
    if warning_level >= 1 then
      writeln("*** " <& file(current_expression) <& "(" <& line(current_expression) <&
              "): When value must be constant.");
      writeLine(file(current_expression), line(current_expression));
      writeln;
    end if;
  end func;


const proc: error (VARIABLE_USED_FOR_TWO_INOUT_PARAMETERS, in reference: currentVariable,
    in reference: inoutParam, in expr_type: c_expr) is func
  begin
    if warning_level >= 2 then
      writeln("*** " <& c_expr.currentFile <& "(" <& c_expr.currentLine <&
              "): The variable " <& literal(str(currentVariable)) <&
              " is used for two or more inout-parameters (" <& str(inoutParam) <& ").");
      writeLine(c_expr.currentFile, c_expr.currentLine);
      writeln;
    end if;
  end func;


const proc: error (VARIABLE_USED_AS_INOUT_AND_REF_PARAMETER, in reference: currentVariable,
    in reference: inoutParam, in reference: refParam, in expr_type: c_expr) is func
  begin
    if warning_level >= 2 then
      writeln("*** " <& c_expr.currentFile <& "(" <& c_expr.currentLine <&
              "): The variable " <& literal(str(currentVariable)) <&
              " is used as inout-parameter (" <& str(inoutParam) <&
              ") and ref-parameter (" <& str(refParam) <& ").");
      writeLine(c_expr.currentFile, c_expr.currentLine);
      writeln;
    end if;
  end func;


const proc: error (FORWARD_CALLED, in reference: current_expression,
    in reference: function) is func
  begin
    if warning_level >= 1 then
      writeln("*** " <& file(current_expression) <& "(" <& line(current_expression) <&
              "): Forward defined function called.");
      writeLine(file(current_expression), line(current_expression));
      writeln;
      writeln("*** " <& file(function) <& "(" <& line(function) <&
              "): Forward definition of the called function.");
      writeLine(file(function), line(function));
      writeln;
    end if;
  end func;


const proc: checkRangeFromZero (in string: number_name, in string: beyond,
    inout expr_type: c_expr) is func

  begin
    if ccConf.TWOS_COMPLEMENT_INTTYPE then
      c_expr.expr &:= "(uintType)";
      c_expr.expr &:= number_name;
      c_expr.expr &:= ">=(uintType)";
      c_expr.expr &:= beyond;
    else
      c_expr.expr &:= number_name;
      c_expr.expr &:= "<0||";
      c_expr.expr &:= number_name;
      c_expr.expr &:= ">=";
      c_expr.expr &:= beyond;
    end if;
  end func;