///////////////////////////////////////////////////////////////////////////////
//                             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    := CALL_SLOT;

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

  
  - author  := "Sonntag Benoit (bsonntag@loria.fr)";
  - comment := "Call slot method.";
  
Section Inherit
  
  + parent_expr:Expanded EXPR;
  
Section Public
  
  - count_no_recursive:INTEGER;
  - count_context_sensitive:INTEGER;
  
  - reset_count_no_recursive <-
  (
    count_no_recursive := 0;
  );

  - reset_count_context_sensitive <-
  (
    count_context_sensitive := 0;
  );
    
  + profil:PROFIL;
  
  - set_profil p:PROFIL <-
  (
    profil := p;
  );
  
  - source:LIST <- profil.code;
  
  - is_interrupt:BOOLEAN <- profil.is_interrupt;
  
  - is_external:BOOLEAN  <- profil.is_external;
  
  //
  // Type
  //
    
  - static_type:TYPE_FULL <-
  ( + result:TYPE_FULL;
    + loc:LOCAL;
    
    is_interrupt.if {
      result := type_pointer.default;     
    } else {
      loc := profil.result_last;
      (loc != NULL).if {
	result := loc.type;	
      } else {
	result := TYPE_VOID.default;
      };
    };
    result
  );

  - get_type t:TYPES_TMP <-
  (
    is_interrupt.if {
      t.add type_pointer;
    } else {
      source.get_type t;
    };
  );

  //
  // Argument.
  //
  
  + argument_list:FAST_ARRAY[WRITE];
  
  + result_list:FAST_ARRAY[WRITE];
  
  - set_args args:FAST_ARRAY[WRITE] and_results res:FAST_ARRAY[WRITE] <-
  (
    argument_list := args;
    result_list   := res;
  );
    
  //
  // Creation.
  //
  
  - create p:POSITION profil prof:PROFIL with l_arg:FAST_ARRAY[WRITE] :SELF <-
  ( + result:SELF;
    result := clone;
    result.make p profil prof with l_arg;
    result
  );
  
  - make p:POSITION profil prof:PROFIL with l_arg:FAST_ARRAY[WRITE] <-
  (     
    position := p;    
    
    // Choice profil.
    profil := prof;
    argument_list := l_arg;
    profil.link;            
    (profil.result_list != NULL).if {
      result_list := FAST_ARRAY[WRITE].create_with_capacity (profil.result_list.count);
    };
  );
  
  - my_copy:SELF <-
  ( + result:SELF;
    + wrt:WRITE;
    + new_arg:FAST_ARRAY[WRITE];
    + new_res:FAST_ARRAY[WRITE];
    
    result := clone;
    
    new_arg := FAST_ARRAY[WRITE].create_with_capacity (argument_list.count);
    (argument_list.lower).to (argument_list.upper) do { j:INTEGER;
      (argument_list.item j = NULL).if {
	wrt := NULL;
      } else {
	wrt := argument_list.item j;
	wrt := wrt.variable.write_direct (wrt.position) with NULL value (wrt.value.my_copy); 
	//wrt := argument_list.item j.my_copy;
      };
      new_arg.add_last wrt;
    };
    (result_list != NULL).if {
      new_res := FAST_ARRAY[WRITE].create_with_capacity (result_list.count);
      (result_list.lower).to (result_list.upper) do { j:INTEGER;
	(result_list.item j = NULL).if {
	  wrt := NULL;
	} else {
	  wrt := result_list.item j.my_copy;
	};
	new_res.add_last wrt;
      };
    };
    result.set_args new_arg and_results new_res;
    result.profil.link;

    result
  );

  //
  // Generation.
  //

  - remove <-
  ( + e:WRITE;
    
    (profil.link_count = 0).if {
      debug_display;
    };
    
    profil.unlink;
    (argument_list.lower).to (argument_list.upper) do { j:INTEGER;
      e := argument_list.item j;
      (e != NULL).if {
	e.remove;
      };
    };
    // BSBS: Pourquoi tu nettoi pas les results ?
  );
  
Section Private  
  
  - execute_inline:EXPR <- 
  // Simple inlining
  ( + result:EXPR;
    + new_src:LIST;
    + wrt:WRITE;
    + old_val:EXPR;
    + loc:LOCAL;
    + prof_block:PROFIL_BLOCK;
        
    (source = list_current).if {
      POSITION.put_error semantic text "Recursivity without end (call_slot).";
      source.position.put_position;
      position.put_position;
      POSITION.send_error;
    };
        
    ((! is_interrupt) && {! is_external}).if {
      (profil.link_count = 1).if {      
	// 
	// Inlining simple.
	//	  	  	  	  
	(list_current.old_seq_or_and = seq_or_and).if {
	  argument_to_assignment source index 1 alias FALSE;
	  (result_list != NULL).if {
	    (result_list.lower).to (result_list.upper) do { j:INTEGER;
	      source.add (result_list.item j) to (source.upper);
	    };
	  };		  	  
	  result := source.execute_link;
	  profil.remove_inline;	  	  
	  new_execute_pass;
	};
      }.elseif {profil.is_inlinable /*&& {FALSE}*/} then {
	//
	// Inline by copy:	  
	//
	(list_current.old_seq_or_and = seq_or_and).if {	    	    	    
	  profil.unlink;	  	  	    	    
	  prof_block ?= profil;
	  (prof_block != NULL).if {	    
	    (profil.argument_list.lower).to (profil.argument_list.upper) do { j:INTEGER;
	      loc := profil.argument_list.item j;
	      (loc != NULL).if {
		loc.set_my_alias (loc.my_copy);
	      };
	    };
	  } else {
	    LOCAL.alias_on;
	  };
	  
	  new_src := source.my_copy;	  
	  argument_to_assignment new_src index 1 alias TRUE;	  
	  (result_list != NULL).if {
	    (result_list.lower).to (result_list.upper) do { j:INTEGER;
	      wrt := result_list.item j;
	      old_val := wrt.value;
	      wrt.set_value (old_val.my_copy);	      	      
	      old_val.remove;
	      new_src.add wrt to (new_src.upper);
	    };
	  };		  	  
	  
	  (prof_block != NULL).if {
	    (profil.argument_list.lower).to (profil.argument_list.upper) do { j:INTEGER;
	      loc := profil.argument_list.item j;
	      (loc != NULL).if {
		loc.set_my_alias NULL;
	      };
	    };
	  } else {
	    LOCAL.alias_off;
	  };
	  
	  result := new_src.execute_link;	  
	  
	  ? {result != NULL};
	  new_execute_pass;	  	  
	};
      };
    };
    result
  );  
  
  - execute_normal <-
  ( + wrt:WRITE_LOCAL;
        
    // Pour l'instant ne change pas le profil
    // il faut faire une copie de l'ancien !!
    
    //profil := profil.update self link FALSE;
          
    (argument_list.lower).to (argument_list.upper) do { j:INTEGER;      
      wrt ?= argument_list.item j;	            
      (wrt != NULL).if {			
	(wrt.execute_argument).if {
	  new_execute_pass;
	  argument_list.put NULL to j;
	  (wrt.ensure_count = 0).if {
	    profil.argument_list.put NULL to j;
	  };
	};
      };
    };            	          
    
    (profil.is_context_sensitive).if {
      seq_call_local_and_loop := seq_call_local_and_loop + 1;
    };
    seq_call_and_loop   := seq_call_and_loop + 1;
    seq_inline := seq_inline + 1;
        
    //
    // Counter.
    //    
    (! profil.is_recursive).if {
      count_no_recursive := count_no_recursive + 1;
    };
    (profil.is_context_sensitive).if {
      count_context_sensitive := count_context_sensitive + 1;
    };
  );
      
Section Public
  
  - execute_unlink:INSTR <-
  ( + result:INSTR;
    
    (profil.search_tail_recursive).if {
      //
      // Inline Tail recursive:
      //	  
      profil.remove_inline;		
      result := to_tail_recursive;
      result.execute;
      new_execute_pass;
    } else {      
      result := execute_inline;
      (result = NULL).if {      
	execute_normal;
	(source.is_empty).if {
	  // Suppression.	
	  profil.unlink;	
	  new_execute_pass;
	} else {
	  result := Self;
	  profil.set_life;
	};
      };
    };
    
    result
  );

  - execute_link:EXPR <-
  ( + result:EXPR;
        
    result := execute_inline;
    (result = NULL).if {
      execute_normal;    
      profil.set_life;
      result := Self;
    };
           
    result
  );
  
  //
  // Display.
  //

  - display_style buffer:STRING <-
  ( + t:HASHED_SET[TYPE];
    buffer.append (profil.name);
    buffer.add_last '(';
      
    type_list.lower.to (type_list.upper) do {	 j:INTEGER;
      t := type_list.item j;
      t.lower.to (t.upper - 1) do { k:INTEGER;
	buffer.append (t.item k.name);
	buffer.add_last 'x';
      };
      buffer.append (t.last.name);
      (j != type_list.upper).if {
	buffer.add_last ',';
      };
    };
    buffer.add_last ')';
  );

  - display buffer:STRING <-
  ( + arg:WRITE;

    buffer.append (profil.name);
    display_ref buffer;
    argument_list.is_empty.if {
      buffer.append "()";
    } else {
      buffer.append "(";		
      argument_list.lower.to (argument_list.upper) do { j:INTEGER;
	arg := argument_list.item j;
	(arg = NULL).if {
	  buffer.append "<>"
	} else {
	  arg.value.display buffer;
	};
	buffer.add_last ',';
      };		        
      buffer.put ')' to (buffer.upper);	
    };
  );

  - display_light <-
  (
    string_tmp.copy "CALL '";
    string_tmp.append (profil.name);
    string_tmp.append "' ";
    string_tmp.append (position.prototype.intern_name);
    //position.put_light_position_in(string_tmp);
    string_tmp.append " --> ";
    string_tmp.append (source.position.prototype.intern_name);
    //source.position.put_light_position_in(string_tmp);
    string_tmp.append " (Version ";
 //   string_tmp.append (proto_self_current.intern_name);
    string_tmp.append ")\n";
    string_tmp.print;
  );
  
  //////////////////////////////////////////////////////////////////////////
  // CODE SLOT
  //////////////////////////////////////////////////////////////////////////

  //
  // Generation.
  //
  
  - genere buffer:STRING <-
  ( + val:WRITE;
    + arg:LOCAL;
        
    buffer.append (profil.name);
    (is_interrupt ||{is_external}).if {
      (argument_list.first != NULL).if {
	semantic_error (argument_list.first.position,
	"Impossible `Self' argument for External or Interrupt slot.");
      };
    };
    (! is_interrupt).if {
      buffer.add_last '(';	
      (argument_list.lower).to (argument_list.upper) do { j:INTEGER; 
	val := argument_list.item j;
	arg := profil.argument_list.item j;
	(val != NULL).if {
	  //var := val.variable;
	  //t := var.type;
	  val.genere_value buffer;
	  buffer.add_last ',';
	}.elseif {arg != NULL} then {  // BSBS: Bizarre, ca sert a quoi ?
	  buffer.append (arg.intern_name);
	  buffer.add_last ',';
	};
      };
      (result_list != NULL).if {
	(result_list.lower).to (result_list.upper) do { j:INTEGER;
	  result_list.item j.genere_argument_result buffer;
	  buffer.add_last ',';
	};
      };
      (buffer.last = ',').if {
	buffer.remove_last 1;
      };
      buffer.add_last ')';
    };
  );
    
  //
  // Intern routine.
  //
  
Section Private  
      
  - to_tail_recursive:LOOP <-
  ( + switch:SWITCH;
    + msg_slot:CALL_SLOT;    
    + body:LIST;    
    + idx:INTEGER;
    + wrt:WRITE;
    + new_val:EXPR;
    + new_wrt:INSTR;
    + result:LOOP;
    
    result := LOOP.create position name (profil.name) body source;
    
    //
    // Main List.
    //
            
    // Argument -> Affectation.              
    wrt := argument_list.first;
    (wrt != NULL).if {
      argument_list.put NULL to 0;	
      (! wrt.value.static_type.is_expanded).if {	
	new_val := CAST.create (wrt.static_type) value (wrt.value);
	wrt.set_value new_val;
      };      
      wrt.variable.set_style '+';
      new_wrt := wrt.execute;
      (new_wrt != NULL).if {	
	list_current.insert new_wrt to (list_current.index);	
      };
    };
    (argument_list.lower + 1).to (argument_list.upper) do { k:INTEGER;
      wrt := argument_list.item k;
      (wrt != NULL).if {	
	argument_list.put NULL to k;	
	wrt.variable.set_style '+';
	new_wrt := wrt.execute;
	(new_wrt != NULL).if {	  
	  list_current.insert new_wrt to (list_current.index);
	};
      };
    };
        
    (debug_level_option != 0).if {      
      ? { + push:PUSH;      
	push ?= source.first;
	(push != NULL) && {push.is_first}
      };
      list_current.insert (source.first) to (list_current.index);      
      source.put NOP to (source.lower);
    };
    
    // Extract Switch/body:
    switch ?= source.item (source.upper-1);    
    (switch.list.lower).to (switch.list.upper) do { k:INTEGER;
      body := switch.list.item k.code;
      (body.count > 1).if {
	idx := body.upper-1;
	msg_slot ?= body.item idx;
	(msg_slot != NULL).if {	  
	  // DEBUG
	  (msg_slot = Self).if {
	    semantic_error (position,"CALL_SLOT : BUG!!!!");
	  };
	  (msg_slot.profil != profil).if {
	    semantic_error (position,"CALL_SLOT : BUG2!!!!");
	  };
	  // FIN DEBUG
	  msg_slot.argument_to_assignment body index idx alias FALSE;
	  body.put (LOOP_END.create (msg_slot.position) loop result) to (body.upper - 1);
	};	
      };
    };
    result
  );
  
  - argument_to_assignment lst:LIST index idx:INTEGER alias is_alias:BOOLEAN <-
  ( + val,new_wrt:WRITE;    
    + new_val:EXPR;
    + loc:LOCAL;
    
    // Argument -> Affectation.
    (argument_list.upper).downto (argument_list.lower + 1) do { k:INTEGER;
      val   := argument_list.item k;
      (val != NULL).if {	
	argument_list.put NULL to k;
	(is_alias).if {
	  loc ?= val.variable;	  
	  new_wrt := loc.write (val.position) value (val.value);	  	  
	  loc.unwrite val;	  
	} else {
	  new_wrt := val;	  
	};
	lst.insert new_wrt to idx;
	new_wrt.variable.set_style '+';
      };
    };
    (! argument_list.is_empty).if {
      val := argument_list.first;
      (val != NULL).if {
	argument_list.put NULL to 0;	
	(! val.value.static_type.is_expanded).if {	
	  new_val := CAST.create (val.static_type) value (val.value);
	  val.set_value new_val;
	};
	(is_alias).if {
	  loc ?= val.variable;	  	
	  new_wrt := loc.write (val.position) value (val.value);	
	  loc.unwrite val;	  
	} else {
	  new_wrt := val;	  
	};
	lst.insert new_wrt to idx;
	new_wrt.variable.set_style '+';
      };
    };
  );
