/*
 *
 *  s t k l o s . c			-- STklos support
 *
 * 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:  1-May-1995 18:50 
 */

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

int STk_tc_instance;		/* The type field of an instance */

static char k_initform[]     = ":initform";     /* In a var so it can be */
static char k_init_keyword[] = ":init-keyword"; /* patched by STk_makekey */

static SCM Top, Object, Class;
static SCM Boolean, Char, Pair, Procedure, String, Symbol, Vector, Number, 
	   List, Null, Real, Integer, Keyword, Unknown;

/* 
 * Following var is initialized even if no Tk support is provided. 
 * In this case, it will never accessed.
 * No #ifdef is used here to have the same stklos.so, on system which
 * support it, for stk and snow
 */
static SCM Widget;

static void slot_set_if_unbound(SCM obj, SCM slot_name, SCM value);

/******************************************************************************
 *
 * STk_tc_instance type definition
 *
 ******************************************************************************/

SCM STk_make_instance(SCM clath, long  size, int type)
{
  SCM z;
  SCM slots;

  /* Allocate slots before the instance itself to avoid to have a partially
   * unfilled instance if a GC occurs during vector creation. 
   * Bug signaled by Rob Deline
   */
  slots = STk_makevect(size, UNBOUND);

  NEWCELL(z, STk_tc_instance);
  EXTDATA(z) =  must_malloc(sizeof(Instance));

  CLASS_OF(z)     = clath;
  SLOTS_OF(z) 	  = slots;
  INST_TYPE(z)	  = type;
  ACCESSORS_OF(z) = clath? THE_SLOT_OF(clath, S_getters_n_setters) : NIL;
  return z;
}

static void mark_instance(SCM instance)
{
  STk_gc_mark(CLASS_OF(instance));
  STk_gc_mark(SLOTS_OF(instance));
  STk_gc_mark(ACCESSORS_OF(instance));
}

static void free_instance(SCM instance)
{
  free(INST(instance));
}

static void display_instance(SCM instance, SCM port, int type)
{
  char *fct_name;

  if (type == DSP_MODE)   fct_name = "display-object"; else
  if (type == WRT_MODE)   fct_name = "write-object";   else
  /* (type == TK_MODE) */ fct_name = "tk-write-object";

  STk_apply_generic(VCELL(STk_intern(fct_name)), LIST2(instance, port), NIL);
}

static STk_extended_scheme_type instance_type = {
  "instance",			/* name */
  EXT_EVALPARAM,		/* flags */
  mark_instance,		/* gc_mark_fct */
  free_instance,		/* gc_sweep_fct */
  STk_apply_generic,		/* apply_fct   ---- defined in gf.c */		
  display_instance		/* display_fct */
};


/******************************************************************************
 *
 * compute-cpl
 *
 *   This version doesn't handle multiple-inheritance. It serves only for
 * booting classes and will be overaloaded in Scheme
 *
 ******************************************************************************/

static SCM compute_cpl(SCM supers, SCM res)
{
  return NULLP(supers)? Reverse(res)
    		      : compute_cpl(THE_SLOT_OF(CAR(supers), S_direct_supers),
					 Cons(CAR(supers), res));
}

/******************************************************************************
 *
 * compute-slots
 *
 ******************************************************************************/

static SCM remove_duplicate_slots(SCM l, SCM res, SCM slots_already_seen)
{
  SCM tmp;

  if (NULLP(l)) return res;

  tmp = CONSP(CAR(l)) ? CAR(CAR(l)) : CAR(l);
  if (NSYMBOLP(tmp)) Err("%compute-slots: bad slot name", tmp);
  
  if (STk_memq(tmp, slots_already_seen) == Ntruth) {
    res 	       = Cons(CAR(l), res);
    slots_already_seen = Cons(tmp, slots_already_seen);
  }
  
  return remove_duplicate_slots(CDR(l), res, slots_already_seen);
}

static SCM build_slots_list(SCM dslots, SCM cpl)
{
  register SCM res = dslots;

  for (cpl = CDR(cpl); NNULLP(cpl); cpl = CDR(cpl))
    res = STk_append(LIST2(THE_SLOT_OF(CAR(cpl), S_direct_slots), res), 2);

  /* res contains a list of slots. Remove slots which appears more than once */
  return remove_duplicate_slots(Reverse(res), NIL, NIL);
}


static PRIMITIVE compute_slots(SCM clath)
{
  if (NCLASSP(clath)) Err("compute-class: bad class", clath);
  return build_slots_list(THE_SLOT_OF(clath, S_direct_slots),
			  THE_SLOT_OF(clath, S_cpl));
}

/******************************************************************************
 *
 * compute-getters-n-setters
 *  
 *   This version doesn't handle slot options. It serves only for booting 
 * classes and will be overaloaded in Scheme.
 *
 ******************************************************************************/

static SCM compute_getters_n_setters(SCM slots)
{
  SCM  res = NIL;
  long i   = 0;

  for (  ; NNULLP(slots); slots = CDR(slots)) 
    res = Cons(Cons(CAR(slots),STk_makeinteger(i++)), res);

  return res;
}


/******************************************************************************
 *
 * compute-initializers
 *
 ******************************************************************************/

static SCM build_initializers(SCM slots)
{
  SCM initform, tmp, curr_slot, res = NIL;

  for ( ; NNULLP(slots); slots = CDR(slots)) {
    tmp       = NIL;
    curr_slot = CAR(slots);

    if (CONSP(curr_slot)) {	
      /* slot is a pair. See if an :initform is provided */
      if (STk_llength(curr_slot) > 1) {
	initform = STk_get_keyword(STk_makekey(k_initform),CDR(curr_slot),NULL);
	if (initform)
	  tmp = STk_eval(LIST3(Sym_lambda, NIL, initform), NIL);
      }
    }
    res = Cons(tmp, res);
  }
  return Reverse(res);
}


/******************************************************************************
 *
 * initialize-object
 *
 ******************************************************************************/

static PRIMITIVE initialize_object(SCM obj, SCM initargs)
{
  SCM tmp, initializers, slots;

  if (NINSTANCEP(obj))
    Err("%initialize-object: bad instance", obj);
  if (NCONSP(initargs) && NNULLP(initargs)) 
    Err("%initialize-object: bad init list", initargs);
  
  initializers = THE_SLOT_OF(CLASS_OF(obj), S_initializers);
  slots        = THE_SLOT_OF(CLASS_OF(obj), S_slots);
  
  /* See for each slot how it must be initialized */
  for ( ; NNULLP(initializers); initializers=CDR(initializers), slots=CDR(slots)) {
    SCM slot_name  = CAR(slots);
    SCM slot_value = NULL;
    
    if (CONSP(slot_name)) {
      /* This slot admits (perhaps) to be initialized at creation time */
      tmp 	= STk_get_keyword(STk_makekey(k_init_keyword),CDR(slot_name), NULL);
      slot_name = CAR(slot_name);
      if (tmp) {
	/* an initarg was provided for this slot */
	if (NKEYWORDP(tmp))
	  Err("%initialize-object: initarg must be a keyword. It was", tmp);
	slot_value = STk_get_keyword(tmp, initargs, NULL);
      }
    }

    if (slot_value)
      /* set slot to provided value */
      STk_slot_set(obj, slot_name, slot_value);
    else 
      /* set slot to its :initform if it exists */
      if (NNULLP(CAR(initializers)))
	slot_set_if_unbound(obj, slot_name, Apply(CAR(initializers), NIL));
  }
  
  return obj;
}

/******************************************************************************/

SCM STk_basic_make_class(SCM clath, SCM name, SCM dsupers, SCM dslots)
{
  SCM z, cpl, slots, g_n_s;

  /* Allocate one instance */
  z     = STk_make_instance(clath, NUMBER_OF_CLASS_SLOTS, TYPE_INSTANCE);

  /* Initialize its slots */
  cpl   = compute_cpl(dsupers, LIST1(z));
  slots = build_slots_list(dslots, cpl);
  g_n_s = compute_getters_n_setters(slots);

  THE_SLOT_OF(z, S_name)	      = name;
  THE_SLOT_OF(z, S_direct_supers)     = dsupers;
  THE_SLOT_OF(z, S_direct_slots)      = dslots;
  THE_SLOT_OF(z, S_cpl)		      = cpl;
  THE_SLOT_OF(z, S_slots)	      = slots;
  THE_SLOT_OF(z, S_nfields)	      = STk_makeinteger(STk_llength(slots));
  THE_SLOT_OF(z, S_getters_n_setters) = g_n_s;
  THE_SLOT_OF(z, S_initializers)      = build_initializers(slots);

  /* Don't forget to set the accessors list of the object */
  ACCESSORS_OF(z) = THE_SLOT_OF(clath, S_getters_n_setters);
  
  return z;
}

/******************************************************************************/

static void create_Top_Object_Class(void)
{
  SCM tmp, slots_of_class = LIST8(Intern("name"), 
				  Intern("direct-supers"),
				  Intern("direct-slots"),
				  Intern("cpl"),
				  Intern("slots"),
				  Intern("nfields"),
				  Intern("initializers"),
				  Intern("getters-n-setters"));

  /**** <Class> ****/
  tmp 	= Intern("<class>");
  Class = STk_make_instance(NULL, NUMBER_OF_CLASS_SLOTS, TYPE_INSTANCE);

  CLASS_OF(Class)     = Class;
  ACCESSORS_OF(Class) = compute_getters_n_setters(slots_of_class);

  THE_SLOT_OF(Class, S_name) 		  = tmp;
  THE_SLOT_OF(Class, S_direct_supers)	  = NIL; /* will be changed */
  THE_SLOT_OF(Class, S_direct_slots)	  = slots_of_class;
  THE_SLOT_OF(Class, S_cpl)		  = NIL;  /* will be changed */
  THE_SLOT_OF(Class, S_slots)		  = slots_of_class;
  THE_SLOT_OF(Class, S_nfields)		  = STk_makeinteger(NUMBER_OF_CLASS_SLOTS);
  THE_SLOT_OF(Class, S_initializers)      = build_initializers(slots_of_class);
  THE_SLOT_OF(Class, S_getters_n_setters) = ACCESSORS_OF(Class);

  VCELL(tmp) = Class;

  /**** <Top> ****/
  tmp = Intern("<top>");
  Top = STk_basic_make_class(Class, tmp, NIL, NIL);

  VCELL(tmp) = Top;
  
  /**** <Object> ****/
  tmp	 = Intern("<object>");
  Object = STk_basic_make_class(Class, tmp, LIST1(Top), NIL);

  VCELL(tmp) = Object;

  /* <top> <object> and <class> were partly uninitialized. Correct them here */
  THE_SLOT_OF(Class, S_direct_supers)   = LIST1(Object);
  THE_SLOT_OF(Class, S_cpl)		= LIST3(Class, Object, Top);

  /* protect Top, Object and Class  against garbage collection */
  STk_gc_protect(&Top);
  STk_gc_protect(&Object);
  STk_gc_protect(&Class);
}


static void make_prim_type(SCM *var, char *name, SCM meta, SCM super)
{
   SCM tmp = Intern(name);
   
   *var = STk_basic_make_class(meta, tmp, LIST1(super), NIL);
   STk_gc_protect(var);
   VCELL(tmp) = *var;
}

static void make_primitive_classes(void)
{
  SCM tmp = VCELL(Intern("<procedure-class>"));

  make_prim_type(&Boolean, 	"<boolean>",	Class, Top);
  make_prim_type(&Char,		"<char>",	Class, Top);
  make_prim_type(&List,		"<list>",	Class, Top);
  make_prim_type(&Pair,		"<pair>",	Class, List);
  make_prim_type(&Null,		"<null>", 	Class, List);
  make_prim_type(&String,	"<string>",	Class, Top);
  make_prim_type(&Symbol,	"<symbol>",	Class, Top);
  make_prim_type(&Vector,	"<vector>",	Class, Top);
  make_prim_type(&Number,	"<number>",	Class, Top);
  make_prim_type(&Real,		"<real>",	Class, Number);
  make_prim_type(&Integer,	"<integer>",	Class, Real);
  make_prim_type(&Keyword,	"<keyword>",	Class, Top);
  make_prim_type(&Unknown,	"<unknown>",	Class, Top);
  make_prim_type(&Procedure,	"<procedure>",	tmp,   Top);
  make_prim_type(&Widget,	"<widget>",	Class, Top);
}  


/******************************************************************************/

static PRIMITIVE instancep(SCM obj)
{
  return INSTANCEP(obj)? Truth: Ntruth;
}

PRIMITIVE STk_class_of(SCM obj)
{
  if (INSTANCEP(obj)) return CLASS_OF(obj);

  switch (TYPE(obj)) {
    case tc_boolean:	return Boolean;
    case tc_char:	return Char;
    case tc_cons:	return Pair;
    case tc_nil:	return Null;
    case tc_string:	return String;
    case tc_symbol:	return Symbol;
    case tc_vector:	return Vector;
    case tc_flonum:	return Real;
    case tc_integer:
    case tc_bignum:	return Integer;
    case tc_keyword:	return Keyword;
    case tc_tkcommand:	return Widget;
    default: 		return (STk_procedurep(obj) == Truth)? Procedure: Unknown;
  }
}
static PRIMITIVE class_name(SCM obj)
{
  if (NINSTANCEP(obj)) Err("class-name: bad class", obj);
  return STk_slot_ref(obj, Intern("name"));
}
static PRIMITIVE class_direct_supers(SCM obj)
{
  if (NINSTANCEP(obj)) Err("class-direct-supers: bad class", obj);
  return STk_slot_ref(obj, Intern("direct-supers"));
}
static PRIMITIVE class_direct_slots(SCM obj)
{
  if (NINSTANCEP(obj)) Err("class-direct-slots: bad class", obj);
  return STk_slot_ref(obj, Intern("direct-slots"));
}
static PRIMITIVE class_cpl(SCM obj)
{
  if (NINSTANCEP(obj)) Err("class-recedence-list: bad class", obj);
  return STk_slot_ref(obj, Intern("cpl"));
}
static PRIMITIVE class_slots(SCM obj)
{
  if (NINSTANCEP(obj)) Err("class-slots: bad class", obj);
  return STk_slot_ref(obj, Intern("slots"));
}

static PRIMITIVE slot_existsp(SCM obj, SCM slot_name)
{
  if (NSYMBOLP(slot_name)) Err("slot-exists?: bad slot name", slot_name);
  if (NINSTANCEP(obj))     Err("slot-exists?: bad object", obj);
  return STk_assq(slot_name, ACCESSORS_OF(obj)) == Ntruth ? Ntruth : Truth;
}


/******************************************************************************
 *
 * slot-ref, slot-set! and slot-bound?
 *
 ******************************************************************************/

PRIMITIVE STk_slot_ref(SCM obj, SCM slot_name)
{
  register SCM entry;
  SCM res;

  if (NINSTANCEP(obj)) Err("slot-ref: bad instance", obj);
  
  entry = STk_assq(slot_name, ACCESSORS_OF(obj));
  if (entry == Ntruth) 
    Err("slot-ref: no slot with name", slot_name);

  /* Two cases here:
   *	- if (cdr entry) is an integer (the offset of this slot in the slots vector
   *	- otherwise (cadr entry) is the reader function to apply
   */
  res = INTEGERP(CDR(entry)) ? THE_SLOT_OF(obj, INTEGER(CDR(entry)))
    			     : Apply(STk_cadr(entry), LIST1(obj));
  if (res == UNBOUND) Err("slot-ref: slot unbound", slot_name);

  return res;
}

PRIMITIVE STk_slot_set(SCM obj, SCM slot_name, SCM value)
{
  register SCM entry;

  if (NINSTANCEP(obj)) Err("slot-set!: bad instance", obj);
  
  entry = STk_assq(slot_name, ACCESSORS_OF(obj));
  if (entry == Ntruth) 
    Err("slot-set!: no slot with name", slot_name);

  /* Two cases here:
   *	- if (cdr entry) is an integer (the offset of this slot in the slots vector)
   *	- otherwise (caddr entry) is the writer function to apply
   */
  if (INTEGERP(CDR(entry)))
    THE_SLOT_OF(obj, INTEGER(CDR(entry))) = value;
  else
    Apply(STk_caddr(entry), LIST2(obj, value));

  return UNDEFINED;
}

static void slot_set_if_unbound(SCM obj, SCM slot_name, SCM value)
{
  register SCM entry;

  if ((entry = STk_assq(slot_name, ACCESSORS_OF(obj))) == Ntruth) return;

  if (INTEGERP(CDR(entry))) {
    if (THE_SLOT_OF(obj, INTEGER(CDR(entry))) == UNBOUND)
      THE_SLOT_OF(obj, INTEGER(CDR(entry))) = value;
  }
  else {
    if (Apply(STk_cadr(entry), LIST1(obj)) == UNBOUND)
      Apply(STk_caddr(entry), LIST2(obj, value));
  }
}


static PRIMITIVE slot_boundp(SCM obj, SCM slot_name)
{
  register SCM entry;
  SCM res;

  if (NINSTANCEP(obj)) Err("slot-bound?: bad instance", obj);
  
  entry = STk_assq(slot_name, ACCESSORS_OF(obj));
  if (entry == Ntruth) 
    Err("slot-bound?: no slot with name", slot_name);

  res = INTEGERP(CDR(entry)) ? THE_SLOT_OF(obj, INTEGER(CDR(entry)))
    			     : Apply(STk_cadr(entry), LIST1(obj));

  return (res == UNBOUND) ? Ntruth : Truth;
}

/******************************************************************************
 *
 * %allocate-instance (the low level instance allocation primitive)
 *
 ******************************************************************************/
 
PRIMITIVE STk_allocate_instance(SCM clath)
{
  int kind;

  if (NCLASSP(clath)) Err("%allocate-instance: bad class", clath);
  
  kind = SUBCLASSP(clath, VCELL(Intern("<generic>"))) ? TYPE_GENERIC: TYPE_INSTANCE;

  return STk_make_instance(clath, 
			   STk_integer_value(THE_SLOT_OF(clath, S_nfields)),
			   kind);
}

/******************************************************************************
 *
 * %modify-instance (used by change-class to modify in place)
 * 
 ******************************************************************************/
static PRIMITIVE modify_instance(SCM old, SCM new)
{
  void *old_data;

  if (NINSTANCEP(old) || NINSTANCEP(new)) 
	Err("%modify-instance: both parameters must be instances", NIL);

  /* Exchange the data contained in old and new */
  old_data     = (void *) EXTDATA(old);
  EXTDATA(old) = EXTDATA(new);
  EXTDATA(new) = old_data;
    
  return old;
}

static PRIMITIVE stklos_version(void)
{
  return STk_makestring(STKLOS_VERSION);
}

/******************************************************************************/

PRIMITIVE STk_init_stklos(void)
{
  long flag;
  int old_Error_context = Error_context;
  
  /* Define new types */
  STk_tc_instance = STk_add_new_type(&instance_type);

  /* Bootstrap system. Bootstrap phase is non interruptible */
  Error_context = ERR_FATAL;  flag = No_interrupt(1);

  create_Top_Object_Class();
  STk_init_gf();
  make_primitive_classes();

  Error_context = old_Error_context;  No_interrupt(flag);
  
  
  /* Define new primitives */
  STk_add_new_primitive("stklos-version",	 tc_subr_0, stklos_version);
  STk_add_new_primitive("instance?", 	         tc_subr_1, instancep);
  STk_add_new_primitive("slot-ref",		 tc_subr_2, STk_slot_ref);
  STk_add_new_primitive("slot-set!",	         tc_subr_3, STk_slot_set);
  STk_add_new_primitive("slot-bound?",	         tc_subr_2, slot_boundp);

  STk_add_new_primitive("class-of",		 tc_subr_1, STk_class_of); 
  STk_add_new_primitive("class-name",	         tc_subr_1, class_name);
  STk_add_new_primitive("class-direct-supers",   tc_subr_1, class_direct_supers);
  STk_add_new_primitive("class-direct-slots",    tc_subr_1, class_direct_slots);
  STk_add_new_primitive("class-precedence-list", tc_subr_1, class_cpl);
  STk_add_new_primitive("class-slots",	         tc_subr_1, class_slots);
  STk_add_new_primitive("slot-exists?",	         tc_subr_2, slot_existsp);

  STk_add_new_primitive("%allocate-instance",    tc_subr_1, STk_allocate_instance);
  STk_add_new_primitive("%initialize-object",    tc_subr_2, initialize_object);
  STk_add_new_primitive("%compute-slots",	 tc_subr_1, compute_slots);
  STk_add_new_primitive("%compute-initializers", tc_subr_1, build_initializers);
  STk_add_new_primitive("%modify-instance",	 tc_subr_2, modify_instance);
  return UNDEFINED;
}