/*
 *
 *  g f . c			-- STklos support (generic functions)
 *
 * Copyright (C) 1993,1994,1995 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
 * 
 *
 * Permission to use, copy, and/or distribute this software and its
 * documentation for any purpose and without fee is hereby granted, provided
 * that both the above copyright notice and this permission notice appear in
 * all copies and derived works.  Fees for distribution or use of this
 * software or derived works may only be charged with express written
 * permission of the copyright holder.  
 * This software is provided ``as is'' without express or implied warranty.
 *
 * This software is a derivative work of other copyrighted softwares; the
 * copyright notices of these softwares are placed in the file COPYRIGHTS
 *
 *
 *            Author: Erick Gallesio [eg@unice.fr]
 *    Creation date:  9-Feb-1994 15:56
 * Last file update:  2-Jun-1995 22:18 
 */

#include <stk.h>
#include "stklos.h"
#include "gf.h"

/* 
 * This file is a kind of "sub-module" of STklos implementation.
 * It implement what is necessary to the Clos-like generic functions
 * This implementation provides
 *	- generic functions (with class specializers)
 *	- multi-methods
 *	- next-method 
 *	- a simple MOP
 *
 * Next-methods use a new type of scheme object. This object memoizes the
 * original arguments list and the list of sorted next-methods. This is,
 * of course, a applyable object.
 *
 */

#define SPEC_OF(x)		THE_SLOT_OF(x, S_specializers)

static SCM apply_method(SCM m, SCM args, SCM other_methods);


/******************************************************************************
  *
  * next_method type definition 
  *
  ******************************************************************************/

static int tc_next_method;	/* The type field of a next method */

static SCM make_next_method(SCM methods, SCM args)
{
  register SCM z;

  NEWCELL(z, tc_next_method);
  CAR(z) = methods;
  CDR(z) = args;
  return z;
}

static void mark_next_method(SCM next)
{
  STk_gc_mark(CAR(next));
  STk_gc_mark(CDR(next));
}


static SCM apply_next_method(SCM next, SCM provided_args, SCM env)
{
  SCM methods = CAR(next);
  SCM args    = NULLP(provided_args)? CDR(next) : provided_args;

  if (NULLP(methods)) Err("apply: no next method", NIL);
  return apply_method(CAR(methods), args, CDR(methods));
}

static STk_extended_scheme_type next_method_type = {
  "next-method",	/* name */
  EXT_EVALPARAM,	/* flags */
  mark_next_method,	/* gc_mark_fct */
  NULL,			/* gc_sweep_fct */
  apply_next_method,	/* apply_fct */
  NULL			/* display_fct */
};


/******************************************************************************
 * 
 * Protocol for calling a generic fumction
 *
 * 	+ apply-generic (gf args env)
 *		+ compute-applicable-methods (gf args)
 *		+ apply-methods (methods args)
 *			+ apply-method (method args next-methods)
 *				
 * apply-method calls make-next-method to build the "continuation" of a a method
 * Calling a next-method will call apply-next-method which in turn will call 
 * apply-method again to call effectively the following method.
 *
 ******************************************************************************/

static SCM applicablep(SCM actual, SCM formal)
{
  return STk_memq(formal, THE_SLOT_OF(actual, S_cpl));
}

static int more_specificp(SCM m1, SCM m2, SCM targs)
{
  register SCM s1, s2, a;

  /* 
   * Note: 
   *   m1 and m2 can have != length (i.e. one can be one element longer than the 
   * other when we have a dotted parameter list). For instance, with the call
   *   (M 1)
   * with
   *   (define-method M (a . l) ....)
   *   (define-method M (a) ....) 
   *
   * we consider that the second method is more specific.
   *
   */
  for (a=targs,s1=SPEC_OF(m1),s2=SPEC_OF(m2); ; s1=CDR(s1),s2=CDR(s2),a=CDR(a)) {
    if (NULLP(s1)) return 1;
    if (NULLP(s2)) return 0;
    if (CAR(s1) != CAR(s2)) {
      register SCM l, cs1 = CAR(s1), cs2 = CAR(s2);
      
      for (l = THE_SLOT_OF(CAR(a), S_cpl);   ; l = CDR(l)) {
	if (EQ(cs1, CAR(l))) return 1;
	if (EQ(cs2, CAR(l))) return 0;
      }
      return 0;/* should not occur! */
    }
  }
  return 0; /* should not occur! */
}


static SCM sort_applicable_methods(SCM method_list, SCM targs)
{
  SCM *v, vector;
  int i, j, incr, size;

  vector = STk_vector(method_list, STk_llength(method_list));
  size   = VECTSIZE(vector);
  v      = VECT(vector);

  /* Use a simple shell sort since it is generally faster than qsort on 
   * small vectors (which is probably mostly the case when we have to
   * sort a list of applicable methods).
   */

  for (incr = size / 2; incr; incr /= 2) {
    for (i = incr; i < size; i++) {
      for (j = i-incr ;j >= 0; j -= incr) {
	if (more_specificp(v[j], v[j+incr], targs)) break;
	else {
	  SCM tmp   = v[j+incr];
	  v[j+incr] = v[j];
	  v[j]	    = tmp;
	}
      }
    }
  }
  return STk_vector2list(vector);
}

static SCM compute_applicable_methods(SCM gf, SCM args, int find_method)
{
  SCM l, al, fl, applicable = NIL;
  SCM arg_types = NIL;
  SCM save = args;

  /* Build the list of arguments types */
  for ( ; NNULLP(args); args = CDR(args)) {
    arg_types = Cons(STk_class_of(CAR(args)), arg_types);
  }
  arg_types = Reverse(arg_types);

  /* Build a list of all applicable methods */
  for (l= THE_SLOT_OF(gf, S_methods); NNULLP(l); l = CDR(l)) {

    for (al=arg_types, fl=SPEC_OF(CAR(l));    ;  al=CDR(al), fl=CDR(fl)) {
      if (INSTANCEP(fl) || 	  	/* We have a dotted argument list */
	  (NULLP(al) && NULLP(fl))) {	/* both list exhausted */
	applicable = Cons(CAR(l), applicable);
	break;
      }
      if (NULLP(al) || NULLP(fl) || applicablep(CAR(al), CAR(fl))==Ntruth) break;
    }
  }

  if (NULLP(applicable)) {
    if (find_method) return Ntruth;
    STk_apply_generic(VCELL(Intern("no-applicable-method")), LIST2(gf, save), NIL);
    /* if we are here, it's because no-applicable-method hasn't signaled an error */
    return NIL;
  }
  return (NULLP(CDR(applicable))) ? applicable :
    				    sort_applicable_methods(applicable, arg_types);
}

static SCM apply_method(SCM m, SCM args, SCM next_methods)
{
  return Apply(THE_SLOT_OF(m, S_procedure),
	       Cons(make_next_method(next_methods, args), args));
}

static SCM apply_methods(SCM methods, SCM args)
{
  if (NULLP(methods)) {
    /* 
     * methods can be NIL if we have a no-applicable-method handler which 
     * doesn't signal an error (or dont ends with a call to next-method)
     * In this case return an undefined value
     */
    return UNDEFINED;
  }

  return apply_method(CAR(methods), args, CDR(methods));
}

SCM STk_apply_generic(SCM gf, SCM args, SCM env)
{
  if (NGENERICP(gf)) Err("apply: bad generic function", gf);
  if (NULLP(THE_SLOT_OF(gf, S_methods))) 
    Err("apply: no methods for generic", gf);
  
  return apply_methods(compute_applicable_methods(gf, args, FALSE), args);
}


/******************************************************************************
  *
  * add-method
  *
  *******************************************************************************/

static SCM compute_new_list_of_methods(SCM gf, SCM new)
{
  SCM l1, l2, l;
  SCM new_spec = SPEC_OF(new);
  SCM methods  = THE_SLOT_OF(gf, S_methods);

  for (l = methods; NNULLP(l); l = CDR(l)) {
    for (l1=new_spec, l2=SPEC_OF(CAR(l));    ; l1=CDR(l1), l2=CDR(l2)) {
      if (NULLP(l1) && NULLP(l2)) {
	/* The spec. list of new method already exists in the gf mehods list */	
	CAR(l) = new;
	return methods;
      }
      if (NULLP(l1) || NULLP(l2) || NEQ(CAR(l1), CAR(l2))) break;
    }
  }

  /* If we are here, we have not encountered a method with same specializers */
  return Cons(new, methods);
}


static PRIMITIVE add_method(SCM gf, SCM method)
{
  if (NGENERICP(gf))    Err("add-method: bad generic function", gf); 
  if (NMETHODP(method)) Err("add-method: bad method", method);
  
  THE_SLOT_OF(gf, S_methods) = compute_new_list_of_methods(gf, method); 
  return method;
}

/******************************************************************************
 *
 * A simple make (which will be redefined later in Scheme)
 * This version handles only creation of gf, methods and classes (no instances)
 *
 * Since this code will disappear when Stklos will be fully booted, 
 * no precaution is taken to be efficient.
 *
 ******************************************************************************/

static char k_name[] 	     = ":name";		/* Use vars since makekey patches */
static char k_specializers[] = ":specializers"; /* its argument. This avoids the */
static char k_procedure[]    = ":procedure";	/* -fwritable_string */
static char k_dsupers[]	     = ":dsupers";
static char k_slots[]	     = ":slots";

static PRIMITIVE lmake(SCM args, int len)
{
  SCM clath, z;

  if (len == 0) Err("make: parameter list is null", NIL);

  clath = CAR(args); args  = CDR(args); 
  
  if (clath == VCELL(Intern("<generic>"))) {
    z = STk_make_instance(clath,
			  STk_llength(THE_SLOT_OF(clath, S_slots)), 
			  TYPE_GENERIC);

    THE_SLOT_OF(z, S_name)    = STk_get_keyword(STk_makekey(k_name),
						args,Intern("???"));
    THE_SLOT_OF(z, S_methods) = NIL;
  }
  else {
    z = STk_make_instance(clath, 
			  STk_llength(THE_SLOT_OF(clath, S_slots)), TYPE_INSTANCE);

    if (clath == VCELL(Intern("<method>"))) {
      THE_SLOT_OF(z, S_name) =  
			STk_get_keyword(STk_makekey(k_name), args, Intern("???"));
      THE_SLOT_OF(z, S_specializers) =  
			STk_get_keyword(STk_makekey(k_specializers), args, NIL);
      THE_SLOT_OF(z, S_procedure) =
			STk_get_keyword(STk_makekey(k_procedure), args, NIL);
    }
    else {
      /* In all the others case, make a new class .... No instance here */
      THE_SLOT_OF(z, S_name) = 
			STk_get_keyword(STk_makekey(k_name), args, Intern("???"));
      THE_SLOT_OF(z, S_direct_supers) = 
			STk_get_keyword(STk_makekey(k_dsupers), args, NIL);
      THE_SLOT_OF(z, S_direct_slots)  = 
			STk_get_keyword(STk_makekey(k_slots), args, NIL);
    }
  }
  return z;
}

static PRIMITIVE find_method(SCM l, int len)
{
  SCM gf;
  
  if (len == 0) Err("find-method: no parameter list", NIL);

  gf = CAR(l); l = CDR(l);
  if (NGENERICP(gf)) Err("find-method: bad generic function", gf);
  if (NULLP(THE_SLOT_OF(gf, S_methods))) 
    Err("find-method: no methods for generic", gf);

  return compute_applicable_methods(gf, l, TRUE);
}

/******************************************************************************
 *
 * Initializations 
 *
 ******************************************************************************/

static void create_classes_for_gf(void)
{
  SCM proc, ent, meth, gen;
  SCM Class  = VCELL(Intern("<class>"));
  SCM Object = VCELL(Intern("<object>"));


  proc 	      = Intern("<procedure-class>");
  VCELL(proc) = STk_basic_make_class(Class, proc, LIST1(Class), NIL);

  ent	      = Intern("<entity-class>");
  VCELL(ent)  = STk_basic_make_class(Class, ent, LIST1(VCELL(proc)), NIL);

  meth        = Intern("<method>");
  VCELL(meth) = STk_basic_make_class(Class, meth, LIST1(Object),
				     LIST3(Intern("name"), 
					   Intern("specializers"),
					   Intern("procedure")));
  
  gen 	      = Intern("<generic>");
  VCELL(gen)  = STk_basic_make_class(VCELL(ent), gen, LIST1(Object),
				     LIST2(Intern("name"), Intern("methods")));
}

static void create_generic(void)
{
  SCM Generic = VCELL(Intern("<generic>"));

  VCELL(Intern("no-applicable-method")) = lmake(LIST1(Generic),1);
}

void STk_init_gf(void)
{
  tc_next_method = STk_add_new_type(&next_method_type);
  create_classes_for_gf();
  create_generic();

  STk_add_new_primitive("add-method", 	tc_subr_2,	 add_method);
  STk_add_new_primitive("make",	  	tc_lsubr,	 lmake);
  STk_add_new_primitive("find-method",	tc_lsubr,	 find_method);
}