Code coverage for profil_block.li

///////////////////////////////////////////////////////////////////////////////
//                             Lisaac Compiler                               //
//                                                                           //
//                   LSIIT - ULP - CNRS - INRIA - FRANCE                     //
//                                                                           //
//   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 3 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, see <http://www.gnu.org/licenses/>.   //
//                                                                           //
//                     http://isaacproject.u-strasbg.fr/                     //
///////////////////////////////////////////////////////////////////////////////
Section Header

  + name    := PROFIL_BLOCK;

  - copyright   := "2003-2007 Benoit Sonntag";


  - author  := "Sonntag Benoit (bsonntag@loria.fr)";
  - comment := "Method with costumization";

Section Inherit

  + parent_profil:Expanded PROFIL;

  + parent_type:Expanded TYPE;

Section Public

  - parameter_to_type p:ITM_TYPE_PARAMETER :TYPE_FULL <-
  ( + result:TYPE_FULL;
    result := profil_slot.parameter_to_type p;
    (result = NULL).if {
      warning_error (position,"ICI Je suis dans la merde!!");
    };
    result
  );

  - slot:SLOT <-
  (
    //crash_with_message "PROFIL_BLOCK.slot";
    NULL
  );

  - type_c:STRING_CONSTANT <- type_block.intern_name;

  + to_type_block:TYPE_BLOCK;

  + slot_self:SLOT_DATA;
  + slot_value:SLOT_DATA;

  - inc_id <-
  (
    slot_value.set_ensure_count (slot_value.ensure_count + 1);
  );

  - dec_id <-
  (
    slot_value.set_ensure_count (slot_value.ensure_count - 1);
    ? {slot_value.ensure_count >= 0};
  );

  + context_extern:LOCAL;

  + profil_list:FAST_ARRAY(PROFIL_SLOT);
  + node_list:LINKED_LIST(NODE_TYPE);

  - is_context_sensitive:BOOLEAN <- context_extern != NULL;

  //
  // Creation.
  //

  - create base:ITM_BLOCK :SELF <-
  ( + result:SELF;

    result := clone;
    result.make base;
    result
  );

  - make base:ITM_BLOCK <-
  ( + list:ITM_LIST;
    + old_node_list:LINKED_LIST(NODE_TYPE);
    + var:LOCAL;
    + old_list:LIST;
    + old_profil:PROFIL;
    + result:EXPR;
    + mul:EXPR_MULTIPLE;
    + rd:READ_LOCAL;
    + a_list:FAST_ARRAY(TYPE_FULL);
    + r_list:FAST_ARRAY(TYPE_FULL);
    + old_stack_top,old_bottom_index:INTEGER;
    + old_context:LOCAL;

    (is_graph).if {
      set_call := HASHED_DICTIONARY(INTEGER,PROFIL).create;
      set_back := HASHED_SET(PROFIL).create;
    };

    list := base.list;
    position := list.position;
    //stack_top := stack_local .upper + 1;

    PROFIL_LIST.add Self;
    type_self   := ITM_TYPE_SIMPLE.type_self.to_run_for profil_slot;
    default := TYPE_FULL.create Self with (
      TYPE_FULL.expanded_bit | TYPE_FULL.default_expanded_bit
    );
    //
    slot_self  := SLOT_DATA.clone;
    slot_self.make position name (ALIAS_STR.slot_self) style '+' base NULL type type_self;
    slot_self.set_intern_name (ALIAS_STR.slot_self);
    //
    slot_value := SLOT_DATA.clone;
    slot_value.make position name (ALIAS_STR.slot_id) style '+' base NULL type default;
    slot_value.set_intern_name (ALIAS_STR.slot_id);
    //
    profil_list := FAST_ARRAY(PROFIL_SLOT).create_with_capacity 2;
    node_list   := LINKED_LIST(NODE_TYPE).create;
    old_node_list := NODE.node_list;
    NODE.set_node_list node_list;

    // index TYPE
    index       := index_count;
    index_count := index_count + 1;

    // Name : value
    name := ALIAS_STR.get_intern (ALIAS_STR.slot_value);

    // Create code.
    old_profil := profil_current;
    old_list   := list_current;
    profil_current := Self;
    list_current := LIST.create position;

    (old_stack_top,old_bottom_index,old_context) := ITM_OBJECT.push_context;
    // Add context debug.
    (debug_level_option != 0).if {
      context := TYPE_CONTEXT.default.new_local position
      name (ALIAS_STR.variable_context) style '+';
      context.set_ensure_count 1;
      list_current.add_last (PUSH.create position context context first TRUE);
    };

    // Append arguments.
    a_list := ALIAS_ARRAY(TYPE_FULL).new;
    (base.argument != NULL).if {
      //arg_type_tmp :=
      argument_list := FAST_ARRAY(LOCAL).create_with_capacity (base.argument.count+1);
      argument_list.add_last NULL;
      base.argument.to_run_in argument_list for Self;
      1.to (argument_list.upper) do { j:INTEGER;
        a_list.add_last (argument_list.item j.type);
      };
    } else {
      argument_list := FAST_ARRAY(LOCAL).create 1;
    };
    var := LOCAL.create position name (ALIAS_STR.variable_self) style ' ' type type_self;

    argument_list.put var to 0;
    (argument_list.lower).to (argument_list.upper) do { j:INTEGER;
      stack_local.add_last (argument_list.item j);
    };
    a_list := ALIAS_ARRAY(TYPE_FULL).alias a_list;
    //
    code := list_current;
    //
    result := list.to_run_expr;
    // Result.
    r_list := ALIAS_ARRAY(TYPE_FULL).new;
    (result.static_type.raw != TYPE_VOID).if {
      mul ?= result;
      (mul != NULL).if {
        result_list.make_with_capacity (mul.count);
        (mul.lower).to (mul.upper) do { j:INTEGER;
          rd ?= mul.item j;
          var := rd.local;
          result_list.add_last var;
          r_list.add_last (var.type);
        };
      } else {
        rd ?= result;
        var := rd.local;
        result_list.add_last var;
        r_list.add_last (var.type);
      };
    };
    result.remove; // BSBS: Il y a un petit gachi...
    r_list := ALIAS_ARRAY(TYPE_FULL).alias r_list;
    //
    context_extern := ITM_OBJECT.context_extern;
    to_type_block  := TYPE_BLOCK.get_direct a_list and_result r_list;
    ITM_OBJECT.pop_context (old_stack_top,old_bottom_index,old_context);
    //
    NODE.set_node_list old_node_list;
    profil_current := old_profil;
    list_current := old_list;
  );

  //
  // Genere Profil.
  //

  - is_static:BOOLEAN <- TRUE;

  - genere_handler_intern buffer:STRING <-
  (
    (is_context_sensitive).if {
      warning_error (code.position,
	"Compiler limit : This block is context sensitive, and \
	\evaluation too far away from the context."
      );
    };
    parent_profil.genere_handler_intern buffer;
  );

  //
  // TYPE BLOCK.
  //

  - intern_name:STRING_CONSTANT <- name;

  - write_argument args:FAST_ARRAY(EXPR) :FAST_ARRAY(WRITE) <-
  ( + rd:READ;
    + rec:EXPR;

    rec := args.first;
    rd := slot_self.read (rec.position) with rec;
    args.put rd to 0;
    parent_profil.write_argument args
  );

  - set_late_binding <-
  (
    type_block.set_late_binding;
  );

  - link call:CALL_SLOT <-
  (
    (link_count = 0).if {
      NODE.node_list.append_collection node_list;
    };
    link_count := link_count + 1;
  );

  - get_expr_result:EXPR <-
  ( + result:EXPR;
    + lst:FAST_ARRAY(EXPR);
    + loc:LOCAL;

    (result_list.count > 1).if {
      lst := FAST_ARRAY(EXPR).create_with_capacity (result_list.count);
      (result_list.lower).to (result_list.upper) do { k:INTEGER;
	loc := result_list.item k;
	lst.add_last (loc.type.get_temporary_expr (loc.position));
      };
      result := EXPR_MULTIPLE.create lst;
    }.elseif {result_list.count = 1} then {
      loc := result_list.first;
      result := loc.type.get_temporary_expr (loc.position);
    } else {
      result := PROTOTYPE_CST.create (code.position) type (TYPE_VOID.default); //BSBS: Alias.
    };
    result
  );

  - is_block:BOOLEAN := TRUE;

  - Self:SELF '~=' Right 60 other:TYPE :BOOLEAN <-
  (
    other = to_type_block
  );

  - append_name_in buf:STRING <-
  (
    buf.add_last '{';
    (argument_list.count > 1).if {
      (argument_list.count > 2).if {
        buf.add_last '(';
        (argument_list.lower+1).to (argument_list.upper-1) do { j:INTEGER;
          argument_list.item j.type.display buf;
          buf.add_last ',';
        };
        argument_list.last.type.display buf;
        buf.add_last ')';
      } else {
        argument_list.last.type.display buf;
      };
      buf.add_last ';';
      buf.add_last ' ';
    };
    (result_list.lower).to (result_list.upper-1) do { j:INTEGER;
      result_list.item j.type.display buf;
      buf.add_last ',';
    };
    (result_list.is_empty).if_false {
      result_list.last.type.display buf;
    };
    buf.add_last '}';
    // Debug
    buf.append "(PROFIL_BLOCK)";
  );

  - prototype:PROTOTYPE <- type_block.prototype;

  - subtype_list:HASHED_SET(TYPE) <- type_block.subtype_list;
  - add_subtype t:TYPE <- type_block.add_subtype t;

  - get_slot n:STRING_CONSTANT :SLOT <-
  (
    type_block.get_slot n
  );

  - get_local_slot n:STRING_CONSTANT :SLOT <-
  (
    type_block.get_local_slot n
  );

  - get_path_slot n:STRING_CONSTANT :SLOT <-
  (
    type_block.get_path_slot n
  );

  - genere_struct <-
  (
    to_type_block.genere_struct;
  );

  //
  // Code source generation.
  //

  - put_id buffer:STRING <- index.append_in buffer;

  - put_access_id e:EXPR in buffer:STRING <-
  (
    e.genere buffer;
    buffer.append ".__id";
  );

  - put_value buffer:STRING <-
  (
    index.append_in buffer;
  );

  - put_expanded_declaration buffer:STRING <-
  (
    // BSBS: A revoir car c'est un gros bordel entre PROFIL_BLOCK et TYPE_BLOCK!
    buffer.append "__";
    buffer.append type_c;
  );

Section Public

  - is_sub_type other:TYPE :BOOLEAN <-
  ( + result:BOOLEAN;
    + t:TYPE_BLOCK;

    result := Self ~= other;
    (result).if_false {
      t ?= other;
      result := (
        (t != NULL)   
        {t.argument_list = to_type_block.argument_list}   
        {to_type_block.is_sub_type_result t}
      );
    };
    result
  );

  //
  // Display.
  //

  - display buffer:STRING <-
  (
    buffer.append "BLOCK SEND ";
    append_type buffer;
  );