(********************************************************************)
(*                                                                  *)
(*  destr.s7i     Generate code for the destructor functions.       *)
(*  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 boolean_type_hash: flist_declared is boolean_type_hash.EMPTY_HASH;
var typeReferenceHash: destrFunction is typeReferenceHash.EMPTY_HASH;
var boolean_type_hash: destr_declared is boolean_type_hash.EMPTY_HASH;
var boolean_type_hash: destr_prototype_declared is boolean_type_hash.EMPTY_HASH;
var string_type_hash: parametersOfHshDestr is string_type_hash.EMPTY_HASH;

const set of category: simpleValueType is {
    BOOLOBJECT, ENUMOBJECT, INTOBJECT, FLOATOBJECT, CHAROBJECT,
    SOCKETOBJECT, REFOBJECT, TYPEOBJECT, ACTOBJECT, BLOCKOBJECT};

const integer: ARRAY_FREELIST_LIMIT is 64;


const proc: process_destr_declaration (in type: object_type,
    inout expr_type: c_expr) is forward;


const proc: process_destr_call (in type: object_type,
    in string: param_b, inout string: expr) is forward;


const proc: declare_free_list (in type: object_type, in string: diagnosticLine,
    inout expr_type: c_expr) is func

  begin
    c_expr.expr &:= diagnosticLine;
    c_expr.expr &:= "static freeListElemType flist_";
    c_expr.expr &:= str(typeNumber(object_type));
    c_expr.expr &:= "=NULL;\n";
    c_expr.expr &:= diagnosticLine;
    c_expr.expr &:= "static unsigned int flist_allowed_";
    c_expr.expr &:= str(typeNumber(object_type));
    c_expr.expr &:= "=1;\n";
    c_expr.expr &:= diagnosticLine;
    c_expr.expr &:= "static boolType flist_was_full_";
    c_expr.expr &:= str(typeNumber(object_type));
    c_expr.expr &:= "=0;\n\n";
    flist_declared @:= [object_type] TRUE;
  end func;


const proc: define_array_size_variable (in type: object_type, inout expr_type: c_expr) is func

  begin
    c_expr.expr &:= "memSizeType size = (uintType)(";
    if object_type in array_minIdx then
      if object_type in array_maxIdx then
        c_expr.expr &:= integerLiteral(array_maxIdx[object_type] - array_minIdx[object_type] + 1);
      else
        c_expr.expr &:= "b->max_position - ";
        if array_minIdx[object_type] = integer.first then
          c_expr.expr &:= integerLiteral(array_minIdx[object_type]);
          c_expr.expr &:= " + 1";
        else
          c_expr.expr &:= integerLiteral(pred(array_minIdx[object_type]));
        end if;
      end if;
    else
      c_expr.expr &:= "b->max_position - b->min_position + 1";
    end if;
    c_expr.expr &:= ");\n";
  end func;


const func string: process_arr_free (in type: object_type, in string: variableName,
    in boolean: useFreelist, in string: diagnosticLine) is func

  result
    var string: freeExpr is "";
  begin
    if useFreelist then
      freeExpr &:= "if (flist_allowed_";
      freeExpr &:= str(typeNumber(object_type));
      freeExpr &:= ">0) {\n";
      freeExpr &:= diagnosticLine;
      freeExpr &:= "((freeListElemType)(";
      freeExpr &:= variableName;
      freeExpr &:= "))->next = flist_";
      freeExpr &:= str(typeNumber(object_type));
      freeExpr &:= ";\n";
      freeExpr &:= diagnosticLine;
      freeExpr &:= "flist_";
      freeExpr &:= str(typeNumber(object_type));
      freeExpr &:= " = (freeListElemType)(";
      freeExpr &:= variableName;
      freeExpr &:= ");\n";
      freeExpr &:= diagnosticLine;
      freeExpr &:= "flist_allowed_";
      freeExpr &:= str(typeNumber(object_type));
      freeExpr &:= "--;\n";
      freeExpr &:= diagnosticLine;
      freeExpr &:= "} else {\n";
      freeExpr &:= diagnosticLine;
      freeExpr &:= "arrFree((arrayType)(";
      freeExpr &:= variableName;
      freeExpr &:= "));\n";
      freeExpr &:= diagnosticLine;
      freeExpr &:= "flist_was_full_";
      freeExpr &:= str(typeNumber(object_type));
      freeExpr &:= "=1;\n";
      freeExpr &:= diagnosticLine;
      freeExpr &:= "}\n";
    else
      freeExpr &:= "arrFree((arrayType)(";
      freeExpr &:= variableName;
      freeExpr &:= "));\n";
    end if;
  end func;


const proc: process_arr_destr_declaration (in type: object_type,
    inout expr_type: c_expr) is func

  local
    var string: diagnosticLine is "";
    var string: select_value is "";
    var boolean: useFreelist is FALSE;
  begin
    if object_type in destrFunction then
      diagnosticLine := diagnosticLine(destrFunction[object_type]);
    end if;
    select_value := select_value_from_rtlObjectStruct(array_element[object_type]);
    process_destr_declaration(array_element[object_type], c_expr);
    if fixArrayFreelist and
        object_type in array_minIdx and object_type in array_maxIdx and
        array_maxIdx[object_type] -
        array_minIdx[object_type] < ARRAY_FREELIST_LIMIT then
      useFreelist := TRUE;
      if object_type not in flist_declared then
        # Free list might already be defined by the declaration of create_... .
        declare_free_list(object_type, diagnosticLine, c_expr);
      end if;
    end if;
    c_expr.expr &:= diagnosticLine;
    c_expr.expr &:= "static void destr_";
    c_expr.expr &:= str(typeNumber(object_type));
    c_expr.expr &:= " (const_";
    c_expr.expr &:= type_name(object_type);
    c_expr.expr &:= " b)\n";
    c_expr.expr &:= diagnosticLine;
    c_expr.expr &:= "{\n";
    c_expr.expr &:= diagnosticLine;
    c_expr.expr &:= "if (b != NULL) {\n";
    if array_element[object_type] not in typeCategory or
        typeCategory[array_element[object_type]] not in simpleValueType then
      c_expr.expr &:= diagnosticLine;
      define_array_size_variable(object_type, c_expr);
      c_expr.expr &:= diagnosticLine;
      c_expr.expr &:= "while (size != 0) {\n";
      c_expr.expr &:= diagnosticLine;
      c_expr.expr &:= "size--;\n";
      c_expr.expr &:= diagnosticLine;
      process_destr_call(array_element[object_type],
          "b->arr[size]" & select_value, c_expr.expr);
      c_expr.expr &:= diagnosticLine;
      c_expr.expr &:= "}\n";
    end if;
    c_expr.expr &:= diagnosticLine;
    c_expr.expr &:= process_arr_free(object_type, "b", useFreelist, diagnosticLine);
    c_expr.expr &:= diagnosticLine;
    c_expr.expr &:= "}\n";
    c_expr.expr &:= diagnosticLine;
    c_expr.expr &:= "}\n";
    c_expr.expr &:= noDiagnosticLine;
    c_expr.expr &:= "\n";
    destr_declared @:= [object_type] TRUE;
  end func;


const func string: process_sct_free (in type: object_type, in string: variableName,
    in string: diagnosticLine) is func

  result
    var string: freeExpr is "";
  begin
    if structFreelist then
      freeExpr &:= "if (flist_allowed_";
      freeExpr &:= str(typeNumber(object_type));
      freeExpr &:= ">0) {\n";
      freeExpr &:= diagnosticLine;
      freeExpr &:= "((freeListElemType)(";
      freeExpr &:= variableName;
      freeExpr &:= "))->next = flist_";
      freeExpr &:= str(typeNumber(object_type));
      freeExpr &:= ";\n";
      freeExpr &:= diagnosticLine;
      freeExpr &:= "flist_";
      freeExpr &:= str(typeNumber(object_type));
      freeExpr &:= " = (freeListElemType)(";
      freeExpr &:= variableName;
      freeExpr &:= ");\n";
      freeExpr &:= diagnosticLine;
      freeExpr &:= "flist_allowed_";
      freeExpr &:= str(typeNumber(object_type));
      freeExpr &:= "--;\n";
      freeExpr &:= diagnosticLine;
      freeExpr &:= "} else {\n";
      freeExpr &:= diagnosticLine;
      freeExpr &:= "free((void *)(";
      freeExpr &:= variableName;
      freeExpr &:= "));\n";
      freeExpr &:= diagnosticLine;
      freeExpr &:= "flist_was_full_";
      freeExpr &:= str(typeNumber(object_type));
      freeExpr &:= "=1;\n";
      freeExpr &:= diagnosticLine;
      freeExpr &:= "}\n";
    else
      freeExpr &:= "free((void *)(";
      freeExpr &:= variableName;
      freeExpr &:= "));\n";
    end if;
  end func;


const proc: process_sct_destr_declaration (in type: object_type,
    inout expr_type: c_expr) is func

  local
    var string: diagnosticLine is "";
    var integer: structSize is 0;
    var integer: elementIndex is 0;
    var string: select_value is "";
  begin
    if object_type in destrFunction then
      diagnosticLine := diagnosticLine(destrFunction[object_type]);
    end if;
    if object_type in struct_size then
      structSize := struct_size[object_type];
    end if;
    for elementIndex range 0 to pred(structSize) do
      process_destr_declaration(struct_element_type[object_type][elementIndex], c_expr);
    end for;
    if structFreelist and object_type not in flist_declared then
      # Free list might already be defined by the declaration of create_... .
      declare_free_list(object_type, diagnosticLine, c_expr);
    end if;
    c_expr.expr &:= diagnosticLine;
    c_expr.expr &:= "static void destr_";
    c_expr.expr &:= str(typeNumber(object_type));
    c_expr.expr &:= " (";
    c_expr.expr &:= type_name(object_type);
    c_expr.expr &:= " b)\n";
    c_expr.expr &:= diagnosticLine;
    c_expr.expr &:= "{\n";
    c_expr.expr &:= diagnosticLine;
    c_expr.expr &:= "if (b != NULL && b->usage_count != 0) {\n";
    c_expr.expr &:= diagnosticLine;
    c_expr.expr &:= "b->usage_count--;\n";
    c_expr.expr &:= diagnosticLine;
    c_expr.expr &:= "if (b->usage_count == 0) {\n";
    for elementIndex range 0 to pred(structSize) do
      select_value := select_value_from_rtlObjectStruct(struct_element_type[object_type][elementIndex]);
      c_expr.expr &:= diagnosticLine;
      process_destr_call(struct_element_type[object_type][elementIndex],
          "b->stru[" & str(elementIndex) & "]" & select_value, c_expr.expr);
    end for;
    c_expr.expr &:= diagnosticLine;
    c_expr.expr &:= process_sct_free(object_type, "b", diagnosticLine);
    c_expr.expr &:= diagnosticLine;
    c_expr.expr &:= "}}\n";
    c_expr.expr &:= diagnosticLine;
    c_expr.expr &:= "}\n";
    c_expr.expr &:= noDiagnosticLine;
    c_expr.expr &:= "\n";
    destr_declared @:= [object_type] TRUE;
  end func;


const proc: process_hsh_destr_declaration (in type: object_type,
    inout expr_type: c_expr) is func

  local
    var string: diagnosticLine is "";
  begin
    if object_type in destrFunction then
      diagnosticLine := diagnosticLine(destrFunction[object_type]);
    end if;
    c_expr.expr &:= diagnosticLine;
    c_expr.expr &:= "static void destr_";
    c_expr.expr &:= str(typeNumber(object_type));
    c_expr.expr &:= " (const_";
    c_expr.expr &:= type_name(object_type);
    c_expr.expr &:= " b)\n";
    c_expr.expr &:= diagnosticLine;
    c_expr.expr &:= "{\n";
    c_expr.expr &:= diagnosticLine;
    c_expr.expr &:= "hshDestr(b";
    c_expr.expr &:= parametersOfHshDestr[object_type];
    c_expr.expr &:= ");\n";
    c_expr.expr &:= diagnosticLine;
    c_expr.expr &:= "}\n";
    c_expr.expr &:= noDiagnosticLine;
    c_expr.expr &:= "\n";
    destr_declared @:= [object_type] TRUE;
  end func;


const proc: process_itf_destr_declaration (in type: object_type,
    inout expr_type: c_expr) is func

  local
    var string: diagnosticLine is "";
    var type: interfaceType is void;
    var type: implementationType is void;
    var boolean: isDerived is FALSE;
    var bitset: typeNumUsed is bitset.value;
  begin
    if object_type in destrFunction then
      diagnosticLine := diagnosticLine(destrFunction[object_type]);
    end if;
    c_expr.expr &:= diagnosticLine;
    c_expr.expr &:= "static void destr_";
    c_expr.expr &:= str(typeNumber(object_type));
    c_expr.expr &:= " (";
    c_expr.expr &:= type_name(object_type);
    c_expr.expr &:= " b)\n";
    c_expr.expr &:= diagnosticLine;
    c_expr.expr &:= "{\n";
    c_expr.expr &:= diagnosticLine;
    c_expr.expr &:= "if (b != NULL) {\n";
    c_expr.expr &:= diagnosticLine;
    c_expr.expr &:= "if (b->usage_count >= 2) {\n";
    c_expr.expr &:= diagnosticLine;
    c_expr.expr &:= "b->usage_count--;\n";
    c_expr.expr &:= diagnosticLine;
    c_expr.expr &:= "} else if (b->usage_count != 0) {\n";
    c_expr.expr &:= diagnosticLine;
    interfaceType := object_type;
    c_expr.expr &:= "switch (b->type_num) {\n";
    repeat
      if interfaceType in implements then
        for implementationType range implements[interfaceType] do
          if typeNumber(implementationType) not in typeNumUsed then
            c_expr.expr &:= "case ";
            c_expr.expr &:= str(typeNumber(implementationType));
            c_expr.expr &:= "/*";
            c_expr.expr &:= str(implementationType);
            c_expr.expr &:= "*/";
            c_expr.expr &:= ": ";
            c_expr.expr &:= diagnosticLine;
            process_destr_declaration(implementationType, global_c_expr);
            process_destr_call(implementationType, "b", c_expr.expr);
            c_expr.expr &:= diagnosticLine;
            c_expr.expr &:= "break;\n";
            incl(typeNumUsed, typeNumber(implementationType));
          end if;
        end for;
      end if;
      isDerived := isDerived(interfaceType);
      if isDerived then
        interfaceType := meta(interfaceType);
      end if;
    until not isDerived;
    c_expr.expr &:= "default:";
    c_expr.expr &:= diagnosticLine;
    c_expr.expr &:= "raiseError(ACTION_ERROR);\n";
    c_expr.expr &:= diagnosticLine;
    c_expr.expr &:= "}\n";
    c_expr.expr &:= diagnosticLine;
    c_expr.expr &:= "}\n";
    c_expr.expr &:= diagnosticLine;
    c_expr.expr &:= "}\n";
    c_expr.expr &:= diagnosticLine;
    c_expr.expr &:= "}\n";
    c_expr.expr &:= noDiagnosticLine;
    c_expr.expr &:= "\n";
    destr_declared @:= [object_type] TRUE;
  end func;


const proc: process_itf_destr_prototype (in type: object_type,
    inout expr_type: c_expr) is func

  begin
    if object_type not in destr_prototype_declared then
      c_expr.expr &:= "static void destr_";
      c_expr.expr &:= str(typeNumber(object_type));
      c_expr.expr &:= " (";
      c_expr.expr &:= type_name(object_type);
      c_expr.expr &:= ");\n\n";
      destr_prototype_declared @:= [object_type] TRUE;
    end if;
  end func;


const proc: declare_destr_prototype (in type: object_type,
    inout expr_type: c_expr) is func

  begin
    if object_type not in destr_prototype_declared then
      declare_type_if_necessary(object_type, c_expr);
      c_expr.expr &:= "static void destr_";
      c_expr.expr &:= str(typeNumber(object_type));
      c_expr.expr &:= " (const_";
      c_expr.expr &:= type_name(object_type);
      c_expr.expr &:= ");\n\n";
      destr_prototype_declared @:= [object_type] TRUE;
    end if;
  end func;


const proc: process_destr_declaration (in type: object_type,
    inout expr_type: c_expr) is func

  begin
    if object_type not in destr_declared then
      if object_type in typeCategory then
        case typeCategory[object_type] of
          when {ARRAYOBJECT}:
            if object_type in array_element then
              process_arr_destr_declaration(object_type, c_expr);
            else
              declare_destr_prototype(object_type, c_expr);
            end if;
          when {STRUCTOBJECT}:
            process_sct_destr_declaration(object_type, c_expr);
          when {HASHOBJECT}:
            if object_type in parametersOfHshDestr then
              process_hsh_destr_declaration(object_type, c_expr);
            else
              declare_destr_prototype(object_type, c_expr);
            end if;
          when {INTERFACEOBJECT}:
            process_itf_destr_prototype(object_type, c_expr);
          otherwise:
            destr_declared @:= [object_type] TRUE;
        end case;
      else
        declare_destr_prototype(object_type, c_expr);
      end if;
    end if;
  end func;


const proc: declare_missing_destr_declarations (inout expr_type: c_expr) is func

  local
    var type: object_type is void;
  begin
    for key object_type range destr_prototype_declared do
      process_destr_declaration(object_type, c_expr);
    end for;
    for key object_type range destr_prototype_declared do
      if object_type in typeCategory and typeCategory[object_type] = INTERFACEOBJECT then
        process_itf_destr_declaration(object_type, c_expr);
      end if;
    end for;
  end func;


const set of category: destrNecessary is {
    BIGINTOBJECT, STRIOBJECT, BSTRIOBJECT, FILEOBJECT, SETOBJECT,
    REFLISTOBJECT, WINOBJECT, POINTLISTOBJECT, PROCESSOBJECT, PROGOBJECT,
    DATABASEOBJECT, SQLSTMTOBJECT, ARRAYOBJECT, HASHOBJECT, STRUCTOBJECT};


const proc: process_destr_call (in type: object_type,
    in string: param_b, inout string: expr) is func

  begin
    if object_type in typeCategory then
      case typeCategory[object_type] of
        when simpleValueType:   noop;
        when {BIGINTOBJECT}:    expr &:= "bigDestr(" & param_b & ");\n";
        when {STRIOBJECT}:      expr &:= "strDestr(" & param_b & ");\n";
        when {BSTRIOBJECT}:     expr &:= "bstDestr(" & param_b & ");\n";
        when {FILEOBJECT}:      expr &:= "filDestr(" & param_b & ");\n";
        when {SETOBJECT}:       expr &:= "setDestr(" & param_b & ");\n";
        when {POLLOBJECT}:      expr &:= "polDestr(" & param_b & ");\n";
        when {REFLISTOBJECT}:   expr &:= "rflDestr(" & param_b & ");\n";
        when {WINOBJECT}:       expr &:= "drwDestr(" & param_b & ");\n";
        when {POINTLISTOBJECT}: expr &:= "bstDestr(" & param_b & ");\n";
        when {PROCESSOBJECT}:   expr &:= "pcsDestr(" & param_b & ");\n";
        when {PROGOBJECT}:      expr &:= "prgDestr(" & param_b & ");\n";
        when {DATABASEOBJECT}:  expr &:= "sqlDestrDb(" & param_b & ");\n";
        when {SQLSTMTOBJECT}:   expr &:= "sqlDestrStmt(" & param_b & ");\n";
        when {ARRAYOBJECT, HASHOBJECT, STRUCTOBJECT, INTERFACEOBJECT}:
          expr &:= "destr_";
          expr &:= str(typeNumber(object_type));
          expr &:= "(";
          expr &:= param_b;
          expr &:= ");\n";
      end case;
    else
      expr &:= "destr_";
      expr &:= str(typeNumber(object_type));
      expr &:= "((";
      expr &:= type_name(object_type);
      expr &:= ")(";
      expr &:= param_b;
      expr &:= "));\n";
    end if;
  end func;