(********************************************************************)
(*                                                                  *)
(*  const.s7i     Recognize if an expression is constant.           *)
(*  Copyright (C) 1990 - 1994, 2004 - 2016  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.                       *)
(*                                                                  *)
(********************************************************************)


const set of category: basicExpressionCategories is {
    TYPEOBJECT, INTOBJECT, BIGINTOBJECT, CHAROBJECT, STRIOBJECT,
    BSTRIOBJECT, ARRAYOBJECT, HASHOBJECT, STRUCTOBJECT, SETOBJECT,
    FILEOBJECT, SOCKETOBJECT, LISTOBJECT, FLOATOBJECT, BOOLOBJECT,
    WINOBJECT, POINTLISTOBJECT, PROCESSOBJECT, ENUMLITERALOBJECT,
    REFLISTOBJECT, SYMBOLOBJECT};

(**
 *  Special actions are used for function inlining. It is checked if
 *  the top level action of a function body is a special action.
 *  In this case code for the function is not generated. Instead of
 *  calling this function the code of the special action is inlined.
 *)
const set of string: specialActions is
    {"ARR_SORT", "ARR_SORT_REVERSE",
     "BIG_PARSE1", "BIN_AND", "BIN_OR", "BIN_XOR", "BLN_ICONV1",
     "BLN_ICONV3", "BLN_ORD", "BLN_TERNARY", "BST_PARSE1", "CHR_ICONV1",
     "CHR_ICONV3", "CHR_ORD", "ENU_ICONV2", "ENU_LIT", "ENU_ORD2",
     "FLT_PARSE1", "HSH_CONTAINS", "HSH_EXCL", "HSH_INCL", "HSH_KEYS",
     "INT_ICONV1", "INT_ICONV3", "INT_ODD", "INT_PARSE1", "SET_BASELIT",
     "SET_CONV1", "SET_CONV3", "SET_ELEM", "SET_EXCL", "SET_INCL",
     "SET_NOT_ELEM", "SET_RAND"};


const func boolean: isPureFunction (in reference: function) is forward;


const func boolean: isConstant (in reference: current_expression,
    in boolean_obj_hash: local_objects) is forward;


const func boolean: isConstantCall (in reference: current_expression,
    in boolean_obj_hash: local_objects) is func

  result
    var boolean: isConstantCall is FALSE;
  local
    const set of string: copyActions is
        {"ACT_CPY", "ARR_CPY", "BIG_CPY", "BLN_CPY", "BST_CPY", "CHR_CPY",
         "DRW_CPY", "ENU_CPY", "FIL_CPY", "FLT_CPY", "HSH_CPY", "INT_CPY",
         "ITF_CPY", "LST_CPY", "PCS_CPY", "PLT_CPY", "POL_CPY", "PRC_CPY",
         "PRG_CPY", "REF_CPY", "RFL_CPY", "SCT_CPY", "SET_CPY", "SOC_CPY",
         "SQL_CPY_DB", "SQL_CPY_STMT", "STR_CPY", "TYP_CPY"};
    var ref_list: formal_params is ref_list.EMPTY;
    var ref_list: actual_params is ref_list.EMPTY;
    var reference: function is NIL;
    var integer: number is 0;
    var reference: formal_param is NIL;
    var reference: actual_param is NIL;
    var category: paramCategory is category.value;
    var string: action_name is "";
  begin
    # write("isConstantCall: " <& file(current_expression) <& "(" <& line(current_expression) <& "): ");
    actual_params := getValue(current_expression, ref_list);
    function := actual_params[1];
    actual_params := actual_params[2 ..];
    if not isVar(function) then
      if category(function) in basicExpressionCategories then
        isConstantCall := TRUE;
      elsif isPureFunction(function) then
        # write(" {isPureFunction(" <& str(function) <& ")}");
        isConstantCall := TRUE;
        formal_params := formalParams(function);
        for number range 1 to length(actual_params) do
          formal_param := formal_params[number];
          actual_param := actual_params[number];
          paramCategory := category(formal_param);
          if paramCategory <> SYMBOLOBJECT and paramCategory <> TYPEOBJECT then
            if not isConstant(actual_param, local_objects) then
              # write(" [not isConstant(" <& str(actual_param) <& ") " <& str(category(actual_param)) <& "]");
              isConstantCall := FALSE;
            end if;
          end if;
        end for;
      else
        # write(" [not isPureFunction(" <& str(function) <& ") " <& str(category(function)) <& "]");
        if category(function) = ACTOBJECT then
          # write(" [" <& str(getValue(function, ACTION)) <& "]");
          action_name := str(getValue(function, ACTION));
          if action_name = "PRC_NOOP" then
            isConstantCall := TRUE;
            for actual_param range actual_params until not isConstantCall do
              if not isConstant(actual_param, local_objects) then
                # write(" [not isConstant(" <& str(actual_param) <& ") " <& str(category(actual_param)) <& "]");
                isConstantCall := FALSE;
              end if;
            end for;
          elsif action_name in copyActions then
            # writeln(str(actual_params[1]) <& " := ...");
            noop;
          end if;
        end if;
        # writeln;
      end if;
    end if;
    # writeln("isConstantCall: " <& file(current_expression) <& "(" <& line(current_expression) <& ") --> " <& isConstantCall);
  end func;


const func boolean: isConstant (in reference: current_expression,
    in boolean_obj_hash: local_objects) is func

  result
    var boolean: isConstant is FALSE;
  local
    var category: exprCategory is category.value;
  begin
    # write("isConstant: " <& file(current_expression) <& "(" <& line(current_expression) <& "): ");
    if current_expression in local_objects then
      # write(" [local " <& str(current_expression) <& "]");
      isConstant := TRUE;
    elsif not isVar(current_expression) then
      exprCategory := category(current_expression);
      if exprCategory = MATCHOBJECT or exprCategory = CALLOBJECT then
        isConstant := isConstantCall(current_expression, local_objects);
      elsif exprCategory in basicExpressionCategories then
        isConstant := TRUE;
      end if;
    end if;
    # writeln(" --> " <& isConstant);
  end func;


const func boolean: isPureBlockFunction (in reference: function) is func

  result
    var boolean: isPureBlockFunction is FALSE;
  local
    var type: function_type is void;
    var reference: result_object is NIL;
    var ref_list: local_object_list is ref_list.EMPTY;
    var reference: obj is NIL;
    var boolean_obj_hash: local_objects is boolean_obj_hash.value;
  begin
    # writeln("isPureBlockFunction: " <& str(function));
    function_type := getType(function);
    result_object := resultVar(function);
    if not isVarfunc(function_type) then
      if result_object <> NIL then
        local_object_list := make_list(result_object);
      end if;
      local_object_list &:= formalParams(function) & localVars(function);
      for obj range local_object_list do
        # writeln("isPureBlockFunction local: " <& str(obj));
        local_objects @:= [obj] TRUE;
      end for;
      isPureBlockFunction := isConstant(body(function), local_objects);
    end if;
    # writeln("isPureBlockFunction: " <& str(function) <& " --> " <& isPureBlockFunction);
  end func;


const func boolean: isPureFunction (in reference: function) is func

  result
    var boolean: isPureFunction is FALSE;
  local
    const set of string: pureFunctionActions is
        {"ACT_EQ", "ACT_NE", "ACT_ORD", "ACT_STR",
         "ARR_ARRLIT", "ARR_ARRLIT2", "ARR_BASELIT", "ARR_BASELIT2", "ARR_CAT",
         "ARR_CONV", "ARR_EMPTY", "ARR_EXTEND", "ARR_GEN", "ARR_HEAD", "ARR_IDX",
         "ARR_LNG", "ARR_MAXIDX", "ARR_MINIDX", "ARR_RANGE", "ARR_SORT",
         "ARR_SUBARR", "ARR_TAIL", "ARR_TIMES",
         "BIG_ABS", "BIG_ADD", "BIG_BIT_LENGTH", "BIG_CMP", "BIG_CONV", "BIG_DIV",
         "BIG_EQ", "BIG_FROM_BSTRI_BE", "BIG_FROM_BSTRI_LE", "BIG_GCD", "BIG_GE",
         "BIG_GT", "BIG_HASHCODE", "BIG_ICONV1", "BIG_ICONV3", "BIG_IPOW",
         "BIG_LE", "BIG_LOG10", "BIG_LOG2", "BIG_LOWEST_SET_BIT", "BIG_LSHIFT",
         "BIG_LT", "BIG_MDIV", "BIG_MOD", "BIG_MULT", "BIG_NE", "BIG_NEGATE",
         "BIG_ODD", "BIG_ORD", "BIG_PARSE1", "BIG_PARSE_BASED", "BIG_PLUS",
         "BIG_PRED", "BIG_radix", "BIG_RADIX", "BIG_REM", "BIG_RSHIFT",
         "BIG_SBTR", "BIG_STR", "BIG_SUCC", "BIG_TO_BSTRI_BE", "BIG_TO_BSTRI_LE",
         "BIG_VALUE",
         "BIN_AND", "BIN_BIG", "BIN_BINARY", "BIN_CARD", "BIN_CMP", "BIN_LSHIFT",
         "BIN_N_BYTES_BE", "BIN_N_BYTES_LE", "BIN_OR", "BIN_ORD", "BIN_radix",
         "BIN_RADIX", "BIN_RSHIFT", "BIN_STR", "BIN_XOR",
         "BLN_AND", "BLN_EQ", "BLN_GE", "BLN_GT", "BLN_ICONV1", "BLN_ICONV3",
         "BLN_LE", "BLN_LT", "BLN_NE", "BLN_NOT", "BLN_OR", "BLN_ORD", "BLN_PRED",
         "BLN_SUCC", "BLN_TERNARY", "BLN_VALUE",
         "BST_CAT", "BST_CMP", "BST_EMPTY", "BST_EQ", "BST_HASHCODE", "BST_IDX",
         "BST_LNG", "BST_NE", "BST_PARSE1", "BST_STR", "BST_VALUE",
         "CHR_CLIT", "CHR_CMP", "CHR_EQ", "CHR_GE", "CHR_GT", "CHR_HASHCODE",
         "CHR_ICONV1", "CHR_ICONV3", "CHR_LE", "CHR_LOW", "CHR_LT", "CHR_NE",
         "CHR_ORD", "CHR_PRED", "CHR_STR", "CHR_SUCC", "CHR_UP", "CHR_VALUE",
         "CMD_CONFIG_VALUE", "DRW_VALUE",
         "ENU_CONV", "ENU_EQ", "ENU_ICONV2", "ENU_NE", "ENU_ORD2", "ENU_VALUE",
         "FIL_EQ", "FIL_NE", "FIL_VALUE",
         "FLT_ABS", "FLT_ACOS", "FLT_ADD", "FLT_ASIN", "FLT_ATAN", "FLT_ATAN2",
         "FLT_BITS2DOUBLE", "FLT_BITS2SINGLE", "FLT_CEIL", "FLT_CMP", "FLT_COS",
         "FLT_COSH", "FLT_DGTS", "FLT_DIV", "FLT_DOUBLE2BITS", "FLT_EQ",
         "FLT_EXP", "FLT_FLOOR", "FLT_GE", "FLT_GT", "FLT_HASHCODE", "FLT_ICONV1",
         "FLT_ICONV3", "FLT_IPOW", "FLT_ISNAN", "FLT_ISNEGATIVEZERO", "FLT_LE",
         "FLT_LOG", "FLT_LOG10", "FLT_LOG2", "FLT_LSHIFT", "FLT_LT", "FLT_MOD",
         "FLT_MULT", "FLT_NE", "FLT_NEGATE", "FLT_PARSE1", "FLT_PLUS", "FLT_POW",
         "FLT_REM", "FLT_ROUND", "FLT_RSHIFT", "FLT_SBTR", "FLT_SCI", "FLT_SIN",
         "FLT_SINGLE2BITS", "FLT_SINH", "FLT_SQRT", "FLT_STR", "FLT_TAN",
         "FLT_TANH", "FLT_TRUNC", "FLT_VALUE",
         "HSH_CONTAINS", "HSH_EMPTY", "HSH_IDX", "HSH_KEYS", "HSH_LNG",
         "HSH_VALUES",
         "INT_ABS", "INT_ADD", "INT_BINOM", "INT_BIT_LENGTH", "INT_BYTES_BE",
         "INT_BYTES_BE_2_INT", "INT_BYTES_BE_2_UINT", "INT_BYTES_BE_SIGNED",
         "INT_BYTES_BE_UNSIGNED", "INT_BYTES_LE_2_INT", "INT_BYTES_LE_2_UINT",
         "INT_BYTES_LE_SIGNED", "INT_BYTES_LE_UNSIGNED", "INT_CMP", "INT_DIV",
         "INT_EQ", "INT_FACT", "INT_GE", "INT_GT", "INT_HASHCODE", "INT_ICONV1",
         "INT_ICONV3", "INT_LE", "INT_LOG10", "INT_LOG2", "INT_LOWEST_SET_BIT",
         "INT_LPAD0", "INT_LSHIFT", "INT_LT", "INT_MDIV", "INT_MOD", "INT_MULT",
         "INT_NE", "INT_NEGATE", "INT_N_BYTES_BE_SIGNED",
         "INT_N_BYTES_BE_UNSIGNED", "INT_N_BYTES_LE_SIGNED",
         "INT_N_BYTES_LE_UNSIGNED", "INT_ODD", "INT_PARSE1", "INT_PLUS",
         "INT_POW", "INT_PRED", "INT_radix", "INT_RADIX", "INT_REM",
         "INT_RSHIFT", "INT_SBTR", "INT_SQRT", "INT_STR", "INT_SUCC",
         "INT_VALUE",
         "ITF_CMP", "ITF_EQ", "ITF_HASHCODE", "ITF_NE",
         "LST_CAT", "LST_EMPTY", "LST_HEAD", "LST_IDX", "LST_LNG", "LST_RANGE",
         "LST_TAIL",
         "PLT_BSTRING", "PLT_CMP", "PLT_EQ", "PLT_HASHCODE", "PLT_NE",
         "PLT_POINT_LIST", "PLT_VALUE",
         "PRG_EQ", "PRG_NE",
         "REF_CMP", "REF_EQ", "REF_NE", "REF_NIL",
         "RFL_CAT", "RFL_ELEM", "RFL_EMPTY", "RFL_EQ", "RFL_HEAD", "RFL_IDX",
         "RFL_IPOS", "RFL_LNG", "RFL_NE", "RFL_NOT_ELEM", "RFL_POS", "RFL_RANGE",
         "RFL_TAIL", "RFL_VALUE",
         "SCT_LNG", "SCT_SELECT",
         "SET_ARRLIT", "SET_BASELIT", "SET_CARD", "SET_CMP", "SET_CONV1",
         "SET_CONV3", "SET_DIFF", "SET_ELEM", "SET_EMPTY", "SET_EQ", "SET_GE",
         "SET_GT", "SET_HASHCODE", "SET_ICONV1", "SET_ICONV3", "SET_INTERSECT",
         "SET_LE", "SET_LT", "SET_MAX", "SET_MIN", "SET_NE", "SET_NEXT",
         "SET_NOT_ELEM", "SET_SCONV1", "SET_SCONV3", "SET_SYMDIFF", "SET_UNION",
         "SET_VALUE",
         "SOC_EQ", "SOC_NE",
         "STR_CAT", "STR_CHIPOS", "STR_CHPOS", "STR_CHSPLIT", "STR_CLIT",
         "STR_CMP", "STR_EQ", "STR_FROM_UTF8", "STR_GE", "STR_GT", "STR_HASHCODE",
         "STR_HEAD", "STR_IDX","STR_IPOS", "STR_LE", "STR_LIT", "STR_LNG",
         "STR_LOW", "STR_LPAD", "STR_LPAD0", "STR_LT", "STR_LTRIM", "STR_MULT",
         "STR_NE", "STR_POS", "STR_RANGE", "STR_RCHIPOS", "STR_RCHPOS",
         "STR_REPL", "STR_RIPOS", "STR_RPAD", "STR_RPOS", "STR_RTRIM",
         "STR_SPLIT", "STR_STR", "STR_SUBSTR", "STR_SUBSTR_FIXLEN", "STR_TAIL",
         "STR_TO_UTF8", "STR_TRIM", "STR_UP", "STR_VALUE",
         "TYP_CMP", "TYP_EQ", "TYP_NE"};
    const set of string: specialFunctionActions is
        {"PRC_FOR_DOWNTO", "PRC_FOR_TO", "SET_INCL", "TYP_VARCONV"};
    var category: functionCategory is category.value;
    var string: action_name is "";
  begin
    # writeln("isPureFunction: " <& str(function));
    functionCategory := category(function);
    if functionCategory = ACTOBJECT then
      action_name := str(getValue(function, ACTION));
      isPureFunction := action_name in pureFunctionActions or action_name in specialFunctionActions;
    elsif functionCategory = BLOCKOBJECT then
      isPureFunction := isPureBlockFunction(function);
    end if;
    # writeln("isPureFunction: " <& str(function) <& " --> " <& isPureFunction);
  end func;


const func boolean: isConstant (in reference: current_expression) is forward;


const func boolean: isConstantCall (in reference: current_expression) is func

  result
    var boolean: isConstantCall is FALSE;
  local
    var ref_list: params is ref_list.EMPTY;
    var reference: function is NIL;
    var reference: obj is NIL;
  begin
    # write("isConstantCall: " <& file(current_expression) <& "(" <& line(current_expression) <& "): ");
    params := getValue(current_expression, ref_list);
    function := params[1];
    params := params[2 ..];
    if not isVar(function) then
      if category(function) in basicExpressionCategories or
          isPureFunction(function) then
        isConstantCall := TRUE;
        for obj range params until not isConstantCall do
          if not isConstant(obj) then
            isConstantCall := FALSE;
          end if;
        end for;
      end if;
    end if;
    # writeln("isConstantCall --> " <& isConstantCall);
  end func;


const func boolean: isConstant (in reference: current_expression) is func

  result
    var boolean: isConstant is FALSE;
  local
    var category: exprCategory is category.value;
  begin
    # write("isConstant: " <& file(current_expression) <& "(" <& line(current_expression) <& "): ");
    if not isVar(current_expression) then
      exprCategory := category(current_expression);
      if exprCategory = MATCHOBJECT or exprCategory = CALLOBJECT then
        isConstant := isConstantCall(current_expression);
      elsif exprCategory in basicExpressionCategories then
        isConstant := TRUE;
      elsif exprCategory = BLOCKOBJECT then
        isConstant := TRUE;
      elsif exprCategory = ACTOBJECT then
        isConstant := TRUE;
      end if;
    end if;
    # writeln("isConstant --> " <& isConstant);
  end func;


const func boolean: isConstantExpr (in reference: current_expression) is func

  result
    var boolean: isConstantExpr is FALSE;
  local
    var category: exprCategory is category.value;
  begin
    if not isVar(current_expression) then
      exprCategory := category(current_expression);
      if exprCategory = MATCHOBJECT or exprCategory = CALLOBJECT then
        isConstantExpr := isConstantCall(current_expression);
      end if;
    end if;
    # writeln("isConstantExpr --> " <& isConstantExpr);
  end func;


const func reference: evaluate (in reference: current_expression,
    in ref_list: arguments) is func
  result
    var reference: evaluatedExpr is NIL;
  local
    var reference: currExpr is NIL;
  begin
    currExpr := alloc(current_expression);
    setValue(currExpr, arguments);
    block
      evaluatedExpr := evaluate(prog, currExpr);
    exception
      catch NUMERIC_ERROR:  noop;
      catch OVERFLOW_ERROR: noop;
      catch RANGE_ERROR:    noop;
      catch INDEX_ERROR:    noop;
      catch FILE_ERROR:     noop;
      catch DATABASE_ERROR: noop;
    end block;
  end func;


const func boolean: canEvaluateSpecialAction (in reference: current_expression,
    inout reference: evaluatedExpr) is func

  result
    var boolean: okay is FALSE;
  local
    var category: exprCategory is category.value;
    var ref_list: formal_params is ref_list.EMPTY;
    var ref_list: actual_params is ref_list.EMPTY;
    var ref_list: new_actual_params is ref_list.EMPTY;
    var reference: function is NIL;
    var integer: number is 0;
    var reference: formal_param is NIL;
    var reference: actual_param is NIL;
    var category: paramCategory is category.value;
    var boolean: inlineParamFound is FALSE;
  begin
    if not isVar(current_expression) then
      exprCategory := category(current_expression);
      if exprCategory = MATCHOBJECT or exprCategory = CALLOBJECT then
        actual_params := getValue(current_expression, ref_list);
        function := actual_params[1];
        actual_params := actual_params[2 ..];
        if category(function) = ACTOBJECT and
            str(getValue(function, ACTION)) in specialActions then
          formal_params := formalParams(function);
          new_actual_params &:= make_list(function);
          for number range 1 to length(actual_params) do
            formal_param := formal_params[number];
            actual_param := actual_params[number];
            paramCategory := category(formal_param);
            if paramCategory <> SYMBOLOBJECT and paramCategory <> TYPEOBJECT and
                not isConstant(actual_param) and actual_param in inlineParam and
                inlineParam[actual_param][1].paramValue <> NIL then
              inlineParamFound := TRUE;
              new_actual_params &:= make_list(inlineParam[actual_param][1].paramValue);
            else
              new_actual_params &:= make_list(actual_param);
            end if;
          end for;
          if inlineParamFound then
            evaluatedExpr := evaluate(current_expression, new_actual_params);
            if evaluatedExpr <> NIL then
              if category(evaluatedExpr) in basicExpressionCategories then
                incr(countEvaluations);
                okay := TRUE;
              end if;
            end if;
          end if;
        end if;
      end if;
    end if;
    # writeln("canEvaluateSpecialAction --> " <& okay);
  end func;


const func boolean: isFuncParamData (in reference: currExpr) is forward;


const func boolean: getConstant (in var reference: currExpr, in category: exprCategory,
    inout reference: evaluatedExpr) is func
  result
    var boolean: okay is FALSE;
  begin
    if evaluate_const_expr >= 1 and not isFuncParamData(currExpr) then
      if canEvaluateSpecialAction(currExpr, evaluatedExpr) then
        okay := TRUE;
      elsif currExpr in inlineParam and
            inlineParam[currExpr][1].paramValue <> NIL then
        evaluatedExpr := inlineParam[currExpr][1].paramValue;
        okay := TRUE;
      elsif category(currExpr) = exprCategory and
          not isVar(currExpr) then
        evaluatedExpr := currExpr;
        incr(countEvaluations);
        okay := TRUE;
      elsif evaluate_const_expr >= 2 and isConstant(currExpr) then
        block
          evaluatedExpr := evaluate(prog, currExpr);
          if evaluatedExpr <> NIL then
            if category(evaluatedExpr) = exprCategory then
              incr(countEvaluations);
              okay := TRUE;
            end if;
          end if;
        exception
          catch NUMERIC_ERROR:  noop;
          catch OVERFLOW_ERROR: noop;
          catch RANGE_ERROR:    noop;
          catch INDEX_ERROR:    noop;
          catch FILE_ERROR:     noop;
          catch DATABASE_ERROR: noop;
        end block;
      end if;
    end if;
  end func;


const func boolean: getConstant (in var reference: currExpr,
    inout reference: evaluatedExpr) is func
  result
      var boolean: okay is FALSE;
  begin
    if evaluate_const_expr >= 1 and not isFuncParamData(currExpr) then
      if canEvaluateSpecialAction(currExpr, evaluatedExpr) then
        okay := TRUE;
      elsif currExpr in inlineParam and
            inlineParam[currExpr][1].paramValue <> NIL then
        evaluatedExpr := inlineParam[currExpr][1].paramValue;
        okay := TRUE;
      elsif category(currExpr) in basicExpressionCategories and
          not isVar(currExpr) then
        evaluatedExpr := currExpr;
        incr(countEvaluations);
        okay := TRUE;
      elsif evaluate_const_expr >= 2 and isConstant(currExpr) then
        block
          evaluatedExpr := evaluate(prog, currExpr);
          if evaluatedExpr <> NIL then
            if category(evaluatedExpr) in basicExpressionCategories then
              incr(countEvaluations);
              okay := TRUE;
            end if;
          end if;
        exception
          catch NUMERIC_ERROR:  noop;
          catch OVERFLOW_ERROR: noop;
          catch RANGE_ERROR:    noop;
          catch INDEX_ERROR:    noop;
          catch FILE_ERROR:     noop;
          catch DATABASE_ERROR: noop;
        end block;
      end if;
    end if;
  end func;


const func boolean: isFunctionCallingSpecialAction (in reference: function) is func
  result
    var boolean: isFunctionCallingSpecialAction is FALSE;
  local
    var reference: calledFunction is NIL;
  begin
    if category(body(function)) = CALLOBJECT then
      calledFunction := getValue(body(function), ref_list)[1];
      if category(calledFunction) = ACTOBJECT and
          str(getValue(calledFunction, ACTION)) in specialActions then
        # writeln(str(getValue(calledFunction, ACTION)));
        isFunctionCallingSpecialAction := TRUE;
      end if;
    end if;
  end func;


const func boolean: isPureExpression (in reference: currExpr) is func
  result
    var boolean: isPureExpression is FALSE;
  local
    const set of category: localsAndParameters is
        {LOCALVOBJECT, VALUEPARAMOBJECT, REFPARAMOBJECT};
    var category: exprCategory is category.value;
    var ref_list: params is ref_list.EMPTY;
    var reference: function is NIL;
    var reference: obj is NIL;
  begin
    exprCategory := category(currExpr);
    if exprCategory in basicExpressionCategories then
      isPureExpression := TRUE;
    elsif exprCategory in localsAndParameters then
      isPureExpression := TRUE;
    elsif exprCategory = MATCHOBJECT or exprCategory = CALLOBJECT then
      params := getValue(currExpr, ref_list);
      function := params[1];
      params := params[2 ..];
      isPureExpression :=
          category(function) in basicExpressionCategories or
          isPureFunction(function);
      for obj range params until not isPureExpression do
        if not isPureExpression(obj) then
          isPureExpression := FALSE;
        end if;
      end for;
    end if;
  end func;


const func boolean: equalExpressions (in reference: expression1,
    in reference: expression2) is func
  result
    var boolean: isEqual is FALSE;
  local
    var category: exprCategory1 is category.value;
    var category: exprCategory2 is category.value;
    var ref_list: params1 is ref_list.EMPTY;
    var ref_list: params2 is ref_list.EMPTY;
    var reference: function1 is NIL;
    var reference: function2 is NIL;
    var integer: index is 0;
    var reference: obj1 is NIL;
    var reference: obj2 is NIL;
  begin
    if expression1 = expression2 then
      isEqual := TRUE;
    else
      exprCategory1 := category(expression1);
      exprCategory2 := category(expression2);
      if exprCategory1 = exprCategory2 then
        if exprCategory1 = INTOBJECT then
          isEqual := getValue(expression1, integer) = getValue(expression2, integer);
        elsif exprCategory1 = MATCHOBJECT or exprCategory1 = CALLOBJECT then
          params1 := getValue(expression1, ref_list);
          function1 := params1[1];
          params1 := params1[2 ..];
          params2 := getValue(expression2, ref_list);
          function2 := params2[1];
          params2 := params2[2 ..];
          if function1 = function2 and length(params1) = length(params2) then
            isEqual := TRUE;
            for index range 1 to length(params1) until not isEqual do
              if not equalExpressions(params1[index], params2[index]) then
                isEqual := FALSE;
              end if;
            end for;
          end if;
        end if;
      end if;
    end if;
  end func;