[bpt/guile.git] / libguile / objects.c

/*	Copyright (C) 1995,1996 Free Software Foundation, Inc.
 * 
 * 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, 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 software; see the file COPYING.  If not, write to
 * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
 * Boston, MA 02111-1307 USA
 *
 * As a special exception, the Free Software Foundation gives permission
 * for additional uses of the text contained in its release of GUILE.
 *
 * The exception is that, if you link the GUILE library with other files
 * to produce an executable, this does not by itself cause the
 * resulting executable to be covered by the GNU General Public License.
 * Your use of that executable is in no way restricted on account of
 * linking the GUILE library code into it.
 *
 * This exception does not however invalidate any other reasons why
 * the executable file might be covered by the GNU General Public License.
 *
 * This exception applies only to the code released by the
 * Free Software Foundation under the name GUILE.  If you copy
 * code from other Free Software Foundation releases into a copy of
 * GUILE, as the General Public License permits, the exception does
 * not apply to the code that you add in this way.  To avoid misleading
 * anyone as to the status of such modified files, you must delete
 * this exception notice from them.
 *
 * If you write modifications of your own for GUILE, it is your choice
 * whether to permit this exception to apply to your modifications.
 * If you do not wish that, delete this exception notice.  */
\f

/* This file and objects.h contains those minimal pieces of the Guile
 * Object Oriented Programming System which need to be included in
 * libguile.  See the comments in objects.h.
 */

#include "_scm.h"

#include "struct.h"
#include "procprop.h"
#include "chars.h"
#include "keywords.h"
#include "smob.h"

#include "objects.h"
\f

SCM scm_metaclass_standard;
SCM scm_metaclass_operator;

/* These variables are filled in by the object system when loaded. */
SCM scm_class_boolean, scm_class_char, scm_class_pair;
SCM scm_class_procedure, scm_class_string, scm_class_symbol;
SCM scm_class_procedure_with_setter;
SCM scm_class_vector, scm_class_null;
SCM scm_class_integer, scm_class_real, scm_class_complex;
SCM scm_class_unknown;

SCM *scm_port_class = 0;
SCM *scm_smob_class = 0;

SCM (*scm_make_extended_class) (char *type_name);
void (*scm_make_port_classes) (int ptobnum, char *type_name);
void (*scm_change_object_class) (SCM, SCM, SCM);

/* This function is used for efficient type dispatch.  */
SCM
scm_class_of (SCM x)
{
  switch (SCM_ITAG3 (x))
    {
    case scm_tc3_int_1:
    case scm_tc3_int_2:
      return scm_class_integer;

    case scm_tc3_imm24:
      if (SCM_ICHRP (x))
	return scm_class_char;
      else
	{
	  switch (SCM_ISYMNUM (x))
	    {
	    case SCM_ISYMNUM (SCM_BOOL_F):
	    case SCM_ISYMNUM (SCM_BOOL_T):
	      return scm_class_boolean;
	    case SCM_ISYMNUM (SCM_EOL):
	      return scm_class_null;
	    default:
	      return scm_class_unknown;
	    }
	}

    case scm_tc3_cons:
      switch (SCM_TYP7 (x))
	{
	case scm_tcs_cons_nimcar:
	  return scm_class_pair;
	case scm_tcs_closures:
	  return scm_class_procedure;
	case scm_tcs_symbols:
	  return scm_class_symbol;
	case scm_tc7_vector:
	case scm_tc7_wvect:
	case scm_tc7_bvect:
	case scm_tc7_byvect:
	case scm_tc7_svect:
	case scm_tc7_ivect:
	case scm_tc7_uvect:
	case scm_tc7_fvect:
	case scm_tc7_dvect:
	case scm_tc7_cvect:
	  return scm_class_vector;
	case scm_tc7_string:
	case scm_tc7_substring:
	  return scm_class_string;
	case scm_tc7_asubr:
	case scm_tc7_subr_0:
	case scm_tc7_subr_1:
	case scm_tc7_cxr:
	case scm_tc7_subr_3:
	case scm_tc7_subr_2:
	case scm_tc7_rpsubr:
	case scm_tc7_subr_1o:
	case scm_tc7_subr_2o:
	case scm_tc7_lsubr_2:
	case scm_tc7_lsubr:
	case scm_tc7_cclo:
	  return scm_class_procedure;
	case scm_tc7_pws:
	  return scm_class_procedure_with_setter;

	case scm_tc7_port:
	  return scm_port_class[(SCM_WRTNG & SCM_CAR (x)
				 ? (SCM_RDNG & SCM_CAR (x)
				    ? SCM_INOUT_PCLASS_INDEX | SCM_PTOBNUM (x)
				    : SCM_OUT_PCLASS_INDEX | SCM_PTOBNUM (x))
				 : SCM_IN_PCLASS_INDEX | SCM_PTOBNUM (x))];
	case scm_tc7_smob:
	  {
	    SCM type = SCM_TYP16 (x);
	    if (type == scm_tc16_flo)
	      {
		if (SCM_CAR (x) & SCM_IMAG_PART)
		  return scm_class_complex;
		else
		  return scm_class_real;
	      }
	    else
	      return scm_smob_class[SCM_TC2SMOBNUM (type)];
	  }
	case scm_tcs_cons_gloc:
	  /* must be a struct */
	  if (SCM_OBJ_CLASS_FLAGS (x) & SCM_CLASSF_GOOPS_VALID)
	    return SCM_CLASS_OF (x);
	  else if (SCM_OBJ_CLASS_FLAGS (x) & SCM_CLASSF_GOOPS)
	    {
	      /* Goops object */
	      if (SCM_OBJ_CLASS_REDEF (x) != SCM_BOOL_F)
		scm_change_object_class (x,
					 SCM_CLASS_OF (x),         /* old */
					 SCM_OBJ_CLASS_REDEF (x)); /* new */
	      return SCM_CLASS_OF (x);
	    }
	  else
	    {
	      /* ordinary struct */
	      SCM handle = scm_struct_create_handle (SCM_STRUCT_VTABLE (x));
	      if (SCM_NFALSEP (SCM_STRUCT_TABLE_CLASS (SCM_CDR (handle))))
		return SCM_STRUCT_TABLE_CLASS (SCM_CDR (handle));
	      else
		{
		  SCM name = SCM_STRUCT_TABLE_NAME (SCM_CDR (handle));
		  SCM class = scm_make_extended_class (SCM_NFALSEP (name)
						       ? SCM_ROCHARS (name)
						       : 0);
		  SCM_SET_STRUCT_TABLE_CLASS (handle, class);
		  return class;
		}
	    }
	default:
	  if (SCM_CONSP (x))
	    return scm_class_pair;
	  else
	    return scm_class_unknown;
	}

    case scm_tc3_cons_gloc:
    case scm_tc3_tc7_1:
    case scm_tc3_tc7_2:
    case scm_tc3_closure:
      /* Never reached */
      break;
    }
  return scm_class_unknown;
}

SCM_PROC (s_entity_p, "entity?", 1, 0, 0, scm_entity_p);

SCM
scm_entity_p (SCM obj)
{
  return (SCM_NIMP (obj) && SCM_STRUCTP (obj) && SCM_I_ENTITYP (obj)
	  ? SCM_BOOL_T
	  : SCM_BOOL_F);
}

SCM_PROC (s_set_object_procedure_x, "set-object-procedure!", 1, 0, 1, scm_set_object_procedure_x);

SCM
scm_set_object_procedure_x (SCM obj, SCM procs)
{
  SCM proc[4], *pp, p, setp, arity;
  int i, a, r;
  SCM_ASSERT (SCM_NIMP (obj) && SCM_STRUCTP (obj)
	      && ((SCM_CLASS_FLAGS (obj) & SCM_CLASSF_OPERATOR)
		  || SCM_I_ENTITYP (obj)),
	      obj,
	      SCM_ARG1,
	      s_set_object_procedure_x);
  for (i = 0; i < 4; ++i)
    proc[i] = SCM_BOOL_F;
  i = 0;
  while (SCM_NIMP (procs))
    {
      if (i == 4)
	scm_wrong_num_args (scm_makfrom0str (s_set_object_procedure_x));
      p = SCM_CAR (procs);
      setp = 0;
      SCM_ASSERT (SCM_NIMP (p), p, SCM_ARG2 + i, s_set_object_procedure_x);
      if (SCM_CLOSUREP (p))
	{
	  arity = scm_procedure_property (p, scm_sym_arity);
	  a = SCM_INUM (SCM_CAR (arity));
	  /* Closures have zero optional args */
	  r = SCM_NFALSEP (SCM_CADDR (arity));
	  if (a == 1 || (a <= 1 && r))
	    {
	      if (SCM_NFALSEP (proc[0]))
		goto ambiguous;
	      proc[0] = setp = p;
	    }
	  if (a == 2 || (a <= 2 && r))
	    {
	      if (SCM_NFALSEP (proc[1]))
		goto ambiguous;
	      proc[1] = setp = p;
	    }
	  if (a == 3 || (a <= 3 && r))
	    {
	      if (SCM_NFALSEP (proc[2]))
		goto ambiguous;
	      proc[2] = setp = p;
	    }
	  if (a <= 4 && r)
	    {
	      if (SCM_NFALSEP (proc[3]))
		goto ambiguous;
	      proc[3] = setp = p;
	    }
	}
      else if (SCM_TYP7 (p) == scm_tc7_subr_1)
	{
	  if (SCM_NFALSEP (proc[0]))
	    goto ambiguous;
	  proc[0] = setp = p;
	}
      else if (SCM_TYP7 (p) == scm_tc7_subr_2)
	{
	  if (SCM_NFALSEP (proc[1]))
	    goto ambiguous;
	  proc[1] = setp = p;
	}
      else if (SCM_TYP7 (p) == scm_tc7_subr_3)
	{
	  if (SCM_NFALSEP (proc[2]))
	    goto ambiguous;
	  proc[2] = setp = p;
	}
      else if (SCM_TYP7 (p) == scm_tc7_lsubr_2)
	{
	  if (SCM_NFALSEP (proc[3]))
	    {
	    ambiguous:
	      SCM_ASSERT (0, p, "Ambiguous procedure arities",
			  s_set_object_procedure_x);
	    }
	  proc[3] = setp = p;
	}
      SCM_ASSERT (setp, p, SCM_ARG2 + i, s_set_object_procedure_x);
      ++i;
      procs = SCM_CDR (procs);
    }
  pp = (SCM_I_ENTITYP (obj)
	? &SCM_ENTITY_PROC_0 (obj)
	: &SCM_OPERATOR_CLASS (obj)->proc0);
  for (i = 0; i < 4; ++i)
    *pp++ = proc[i];
  return SCM_UNSPECIFIED;
}

/* The following procedures are not a part of Goops but a minimal
 * object system built upon structs.  They are here for those who
 * want to implement their own object system.
 */

SCM
scm_i_make_class_object (SCM meta,
			 SCM layout_string,
			 unsigned long flags)
{
  SCM c;
  SCM layout = scm_make_struct_layout (layout_string);
  c = scm_make_struct (meta,
		       SCM_INUM0,
		       SCM_LIST4 (layout, SCM_BOOL_F, SCM_EOL, SCM_EOL));
  SCM_SET_CLASS_FLAGS (c, flags);
  return c;
}

SCM_PROC (s_make_class_object, "make-class-object", 2, 0, 0, scm_make_class_object);

SCM
scm_make_class_object (SCM metaclass, SCM layout)
{
  unsigned long flags = 0;
  SCM_ASSERT (SCM_NIMP (metaclass) && SCM_STRUCTP (metaclass),
	      metaclass, SCM_ARG1, s_make_class_object);
  SCM_ASSERT (SCM_NIMP (layout) && SCM_STRINGP (layout),
	      layout, SCM_ARG2, s_make_class_object);
  if (metaclass == scm_metaclass_operator)
    flags = SCM_CLASSF_OPERATOR;
  return scm_i_make_class_object (metaclass, layout, flags);
}

SCM_PROC (s_make_subclass_object, "make-subclass-object", 2, 0, 0, scm_make_subclass_object);

SCM
scm_make_subclass_object (SCM class, SCM layout)
{
  SCM pl;
  SCM_ASSERT (SCM_NIMP (class) && SCM_STRUCTP (class),
	      class,
	      SCM_ARG1,
	      s_make_subclass_object);
  SCM_ASSERT (SCM_NIMP (layout) && SCM_STRINGP (layout),
	      layout,
	      SCM_ARG2,
	      s_make_subclass_object);
  pl = SCM_STRUCT_DATA (class)[scm_vtable_index_layout];
  /* Convert symbol->string */
  pl = scm_makfromstr (SCM_CHARS (pl), (scm_sizet) SCM_LENGTH (pl), 0);
  return scm_i_make_class_object (SCM_STRUCT_VTABLE (class),
				  scm_string_append (SCM_LIST2 (pl, layout)),
				  SCM_CLASS_FLAGS (class));
}

void
scm_init_objects ()
{
  SCM ms = scm_makfrom0str (SCM_METACLASS_STANDARD_LAYOUT);
  SCM ml = scm_make_struct_layout (ms);
  SCM mt = scm_make_vtable_vtable (ml, SCM_INUM0,
				   SCM_LIST3 (SCM_BOOL_F, SCM_EOL, SCM_EOL));
  
  SCM os = scm_makfrom0str (SCM_METACLASS_OPERATOR_LAYOUT);
  SCM ol = scm_make_struct_layout (os);
  SCM ot = scm_make_vtable_vtable (ol, SCM_INUM0,
				   SCM_LIST3 (SCM_BOOL_F, SCM_EOL, SCM_EOL));
  
  SCM es = scm_makfrom0str (SCM_ENTITY_LAYOUT);
  SCM el = scm_make_struct_layout (es);
  SCM et = scm_make_struct (mt, SCM_INUM0,
			    SCM_LIST4 (el, SCM_BOOL_F, SCM_EOL, SCM_EOL));

  scm_sysintern ("<class>", mt);
  scm_metaclass_standard = mt;
  scm_sysintern ("<operator-class>", ot);
  scm_metaclass_operator = ot;
  SCM_SET_CLASS_FLAGS (et, SCM_CLASSF_OPERATOR | SCM_CLASSF_ENTITY);
  SCM_SET_CLASS_DESTRUCTOR (et, scm_struct_free_entity);
  scm_sysintern ("<entity>", et);

#include "objects.x"
}
Commit	Line	Data
1d9ee7c7 MD	1	/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
	2	*
	3	* This program is free software; you can redistribute it and/or modify
	4	* it under the terms of the GNU General Public License as published by
	5	* the Free Software Foundation; either version 2, or (at your option)
	6	* any later version.
	7	*
	8	* This program is distributed in the hope that it will be useful,
	9	* but WITHOUT ANY WARRANTY; without even the implied warranty of
	10	* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	11	* GNU General Public License for more details.
	12	*
	13	* You should have received a copy of the GNU General Public License
	14	* along with this software; see the file COPYING. If not, write to
	15	* the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
	16	* Boston, MA 02111-1307 USA
	17	*
	18	* As a special exception, the Free Software Foundation gives permission
	19	* for additional uses of the text contained in its release of GUILE.
	20	*
	21	* The exception is that, if you link the GUILE library with other files
	22	* to produce an executable, this does not by itself cause the
	23	* resulting executable to be covered by the GNU General Public License.
	24	* Your use of that executable is in no way restricted on account of
	25	* linking the GUILE library code into it.
	26	*
	27	* This exception does not however invalidate any other reasons why
	28	* the executable file might be covered by the GNU General Public License.
	29	*
	30	* This exception applies only to the code released by the
	31	* Free Software Foundation under the name GUILE. If you copy
	32	* code from other Free Software Foundation releases into a copy of
	33	* GUILE, as the General Public License permits, the exception does
	34	* not apply to the code that you add in this way. To avoid misleading
	35	* anyone as to the status of such modified files, you must delete
	36	* this exception notice from them.
	37	*
	38	* If you write modifications of your own for GUILE, it is your choice
	39	* whether to permit this exception to apply to your modifications.
	40	* If you do not wish that, delete this exception notice. */
	41	\f
	42
da7f71d7 MD	43	/* This file and objects.h contains those minimal pieces of the Guile
	44	* Object Oriented Programming System which need to be included in
	45	* libguile. See the comments in objects.h.
1d9ee7c7 MD	46	*/
	47
	48	#include "_scm.h"
	49
	50	#include "struct.h"
47b21050	51	#include "procprop.h"
ab7288bc	52	#include "chars.h"
547e65b5	53	#include "keywords.h"
ed6e0c83	54	#include "smob.h"
1d9ee7c7 MD	55
	56	#include "objects.h"
	57	\f
	58
	59	SCM scm_metaclass_standard;
da7f71d7	60	SCM scm_metaclass_operator;
1d9ee7c7	61
ab7288bc MD	62	/* These variables are filled in by the object system when loaded. */
	63	SCM scm_class_boolean, scm_class_char, scm_class_pair;
	64	SCM scm_class_procedure, scm_class_string, scm_class_symbol;
	65	SCM scm_class_procedure_with_setter;
	66	SCM scm_class_vector, scm_class_null;
ed6e0c83 MD	67	SCM scm_class_integer, scm_class_real, scm_class_complex;
ed6e0c83 MD	68	SCM scm_class_unknown;
ab7288bc	69
d0efbe61	70	SCM *scm_port_class = 0;
ed6e0c83 MD	71	SCM *scm_smob_class = 0;
	72
	73	SCM (scm_make_extended_class) (char type_name);
c1636627	74	void (scm_make_port_classes) (int ptobnum, char type_name);
ab7288bc MD	75	void (*scm_change_object_class) (SCM, SCM, SCM);
	76
	77	/* This function is used for efficient type dispatch. */
	78	SCM
	79	scm_class_of (SCM x)
	80	{
	81	switch (SCM_ITAG3 (x))
	82	{
	83	case scm_tc3_int_1:
	84	case scm_tc3_int_2:
	85	return scm_class_integer;
	86
	87	case scm_tc3_imm24:
	88	if (SCM_ICHRP (x))
	89	return scm_class_char;
	90	else
	91	{
	92	switch (SCM_ISYMNUM (x))
	93	{
	94	case SCM_ISYMNUM (SCM_BOOL_F):
	95	case SCM_ISYMNUM (SCM_BOOL_T):
	96	return scm_class_boolean;
	97	case SCM_ISYMNUM (SCM_EOL):
	98	return scm_class_null;
	99	default:
	100	return scm_class_unknown;
	101	}
	102	}
	103
	104	case scm_tc3_cons:
	105	switch (SCM_TYP7 (x))
	106	{
	107	case scm_tcs_cons_nimcar:
	108	return scm_class_pair;
	109	case scm_tcs_closures:
	110	return scm_class_procedure;
	111	case scm_tcs_symbols:
	112	return scm_class_symbol;
	113	case scm_tc7_vector:
	114	case scm_tc7_wvect:
	115	case scm_tc7_bvect:
	116	case scm_tc7_byvect:
	117	case scm_tc7_svect:
	118	case scm_tc7_ivect:
	119	case scm_tc7_uvect:
	120	case scm_tc7_fvect:
	121	case scm_tc7_dvect:
	122	case scm_tc7_cvect:
	123	return scm_class_vector;
	124	case scm_tc7_string:
	125	case scm_tc7_substring:
	126	return scm_class_string;
	127	case scm_tc7_asubr:
	128	case scm_tc7_subr_0:
	129	case scm_tc7_subr_1:
	130	case scm_tc7_cxr:
	131	case scm_tc7_subr_3:
	132	case scm_tc7_subr_2:
	133	case scm_tc7_rpsubr:
	134	case scm_tc7_subr_1o:
	135	case scm_tc7_subr_2o:
	136	case scm_tc7_lsubr_2:
	137	case scm_tc7_lsubr:
ed6e0c83	138	case scm_tc7_cclo:
ab7288bc MD	139	return scm_class_procedure;
	140	case scm_tc7_pws:
	141	return scm_class_procedure_with_setter;
	142
	143	case scm_tc7_port:
c1636627 MD	144	return scm_port_class[(SCM_WRTNG & SCM_CAR (x)
c1636627 MD	145	? (SCM_RDNG & SCM_CAR (x)
d0efbe61 MD	146	? SCM_INOUT_PCLASS_INDEX \| SCM_PTOBNUM (x)
	147	: SCM_OUT_PCLASS_INDEX \| SCM_PTOBNUM (x))
	148	: SCM_IN_PCLASS_INDEX \| SCM_PTOBNUM (x))];
ab7288bc MD	149	case scm_tc7_smob:
	150	{
	151	SCM type = SCM_TYP16 (x);
	152	if (type == scm_tc16_flo)
	153	{
	154	if (SCM_CAR (x) & SCM_IMAG_PART)
	155	return scm_class_complex;
	156	else
	157	return scm_class_real;
	158	}
ab7288bc	159	else
ed6e0c83	160	return scm_smob_class[SCM_TC2SMOBNUM (type)];
ab7288bc MD	161	}
	162	case scm_tcs_cons_gloc:
	163	/* must be a struct */
7151229d MD	164	if (SCM_OBJ_CLASS_FLAGS (x) & SCM_CLASSF_GOOPS_VALID)
	165	return SCM_CLASS_OF (x);
	166	else if (SCM_OBJ_CLASS_FLAGS (x) & SCM_CLASSF_GOOPS)
ed6e0c83 MD	167	{
	168	/* Goops object */
	169	if (SCM_OBJ_CLASS_REDEF (x) != SCM_BOOL_F)
	170	scm_change_object_class (x,
	171	SCM_CLASS_OF (x), /* old */
	172	SCM_OBJ_CLASS_REDEF (x)); /* new */
	173	return SCM_CLASS_OF (x);
	174	}
	175	else
	176	{
	177	/* ordinary struct */
	178	SCM handle = scm_struct_create_handle (SCM_STRUCT_VTABLE (x));
	179	if (SCM_NFALSEP (SCM_STRUCT_TABLE_CLASS (SCM_CDR (handle))))
	180	return SCM_STRUCT_TABLE_CLASS (SCM_CDR (handle));
	181	else
	182	{
	183	SCM name = SCM_STRUCT_TABLE_NAME (SCM_CDR (handle));
	184	SCM class = scm_make_extended_class (SCM_NFALSEP (name)
	185	? SCM_ROCHARS (name)
	186	: 0);
	187	SCM_SET_STRUCT_TABLE_CLASS (handle, class);
	188	return class;
	189	}
	190	}
ab7288bc MD	191	default:
	192	if (SCM_CONSP (x))
	193	return scm_class_pair;
	194	else
	195	return scm_class_unknown;
	196	}
	197
	198	case scm_tc3_cons_gloc:
	199	case scm_tc3_tc7_1:
	200	case scm_tc3_tc7_2:
	201	case scm_tc3_closure:
	202	/* Never reached */
	203	break;
	204	}
	205	return scm_class_unknown;
	206	}
	207
19c0dec2 MD	208	SCM_PROC (s_entity_p, "entity?", 1, 0, 0, scm_entity_p);
	209
	210	SCM
	211	scm_entity_p (SCM obj)
	212	{
	213	return (SCM_NIMP (obj) && SCM_STRUCTP (obj) && SCM_I_ENTITYP (obj)
	214	? SCM_BOOL_T
	215	: SCM_BOOL_F);
	216	}
	217
47b21050 MD	218	SCM_PROC (s_set_object_procedure_x, "set-object-procedure!", 1, 0, 1, scm_set_object_procedure_x);
	219
	220	SCM
	221	scm_set_object_procedure_x (SCM obj, SCM procs)
	222	{
	223	SCM proc[4], *pp, p, setp, arity;
	224	int i, a, r;
	225	SCM_ASSERT (SCM_NIMP (obj) && SCM_STRUCTP (obj)
3b7284cd	226	&& ((SCM_CLASS_FLAGS (obj) & SCM_CLASSF_OPERATOR)
47b21050 MD	227	\|\| SCM_I_ENTITYP (obj)),
	228	obj,
	229	SCM_ARG1,
	230	s_set_object_procedure_x);
	231	for (i = 0; i < 4; ++i)
	232	proc[i] = SCM_BOOL_F;
	233	i = 0;
	234	while (SCM_NIMP (procs))
	235	{
	236	if (i == 4)
	237	scm_wrong_num_args (scm_makfrom0str (s_set_object_procedure_x));
	238	p = SCM_CAR (procs);
	239	setp = 0;
	240	SCM_ASSERT (SCM_NIMP (p), p, SCM_ARG2 + i, s_set_object_procedure_x);
	241	if (SCM_CLOSUREP (p))
	242	{
	243	arity = scm_procedure_property (p, scm_sym_arity);
	244	a = SCM_INUM (SCM_CAR (arity));
	245	/* Closures have zero optional args */
	246	r = SCM_NFALSEP (SCM_CADDR (arity));
	247	if (a == 1 \|\| (a <= 1 && r))
	248	{
	249	if (SCM_NFALSEP (proc[0]))
	250	goto ambiguous;
	251	proc[0] = setp = p;
	252	}
	253	if (a == 2 \|\| (a <= 2 && r))
	254	{
	255	if (SCM_NFALSEP (proc[1]))
	256	goto ambiguous;
	257	proc[1] = setp = p;
	258	}
	259	if (a == 3 \|\| (a <= 3 && r))
	260	{
	261	if (SCM_NFALSEP (proc[2]))
	262	goto ambiguous;
	263	proc[2] = setp = p;
	264	}
	265	if (a <= 4 && r)
	266	{
	267	if (SCM_NFALSEP (proc[3]))
	268	goto ambiguous;
	269	proc[3] = setp = p;
	270	}
	271	}
	272	else if (SCM_TYP7 (p) == scm_tc7_subr_1)
	273	{
	274	if (SCM_NFALSEP (proc[0]))
	275	goto ambiguous;
	276	proc[0] = setp = p;
	277	}
	278	else if (SCM_TYP7 (p) == scm_tc7_subr_2)
	279	{
	280	if (SCM_NFALSEP (proc[1]))
	281	goto ambiguous;
	282	proc[1] = setp = p;
	283	}
	284	else if (SCM_TYP7 (p) == scm_tc7_subr_3)
	285	{
	286	if (SCM_NFALSEP (proc[2]))
	287	goto ambiguous;
	288	proc[2] = setp = p;
	289	}
	290	else if (SCM_TYP7 (p) == scm_tc7_lsubr_2)
291	{
292	if (SCM_NFALSEP (proc[3]))
293	{
294	ambiguous:
295	SCM_ASSERT (0, p, "Ambiguous procedure arities",
296	s_set_object_procedure_x);
297	}
298	proc[3] = setp = p;
299	}
300	SCM_ASSERT (setp, p, SCM_ARG2 + i, s_set_object_procedure_x);
301	++i;
302	procs = SCM_CDR (procs);
303	}
304	pp = (SCM_I_ENTITYP (obj)
305	? &SCM_ENTITY_PROC_0 (obj)
306	: &SCM_OPERATOR_CLASS (obj)->proc0);
307	for (i = 0; i < 4; ++i)
308	*pp++ = proc[i];
309	return SCM_UNSPECIFIED;
310	}
311
ed6e0c83 MD	312	/* The following procedures are not a part of Goops but a minimal
	313	* object system built upon structs. They are here for those who
	314	* want to implement their own object system.
	315	*/
	316
036737fc MD	317	SCM
	318	scm_i_make_class_object (SCM meta,
	319	SCM layout_string,
	320	unsigned long flags)
47b21050 MD	321	{
47b21050 MD	322	SCM c;
036737fc	323	SCM layout = scm_make_struct_layout (layout_string);
47b21050 MD	324	c = scm_make_struct (meta,
	325	SCM_INUM0,
	326	SCM_LIST4 (layout, SCM_BOOL_F, SCM_EOL, SCM_EOL));
	327	SCM_SET_CLASS_FLAGS (c, flags);
	328	return c;
	329	}
	330
	331	SCM_PROC (s_make_class_object, "make-class-object", 2, 0, 0, scm_make_class_object);
	332
	333	SCM
	334	scm_make_class_object (SCM metaclass, SCM layout)
	335	{
	336	unsigned long flags = 0;
036737fc MD	337	SCM_ASSERT (SCM_NIMP (metaclass) && SCM_STRUCTP (metaclass),
	338	metaclass, SCM_ARG1, s_make_class_object);
	339	SCM_ASSERT (SCM_NIMP (layout) && SCM_STRINGP (layout),
	340	layout, SCM_ARG2, s_make_class_object);
47b21050 MD	341	if (metaclass == scm_metaclass_operator)
47b21050 MD	342	flags = SCM_CLASSF_OPERATOR;
036737fc	343	return scm_i_make_class_object (metaclass, layout, flags);
47b21050 MD	344	}
	345
	346	SCM_PROC (s_make_subclass_object, "make-subclass-object", 2, 0, 0, scm_make_subclass_object);
	347
	348	SCM
	349	scm_make_subclass_object (SCM class, SCM layout)
	350	{
	351	SCM pl;
	352	SCM_ASSERT (SCM_NIMP (class) && SCM_STRUCTP (class),
	353	class,
	354	SCM_ARG1,
	355	s_make_subclass_object);
036737fc MD	356	SCM_ASSERT (SCM_NIMP (layout) && SCM_STRINGP (layout),
	357	layout,
	358	SCM_ARG2,
	359	s_make_subclass_object);
47b21050	360	pl = SCM_STRUCT_DATA (class)[scm_vtable_index_layout];
036737fc	361	/* Convert symbol->string */
47b21050	362	pl = scm_makfromstr (SCM_CHARS (pl), (scm_sizet) SCM_LENGTH (pl), 0);
036737fc MD	363	return scm_i_make_class_object (SCM_STRUCT_VTABLE (class),
	364	scm_string_append (SCM_LIST2 (pl, layout)),
	365	SCM_CLASS_FLAGS (class));
47b21050 MD	366	}
47b21050 MD	367
1d9ee7c7 MD	368	void
	369	scm_init_objects ()
	370	{
	371	SCM ms = scm_makfrom0str (SCM_METACLASS_STANDARD_LAYOUT);
	372	SCM ml = scm_make_struct_layout (ms);
	373	SCM mt = scm_make_vtable_vtable (ml, SCM_INUM0,
	374	SCM_LIST3 (SCM_BOOL_F, SCM_EOL, SCM_EOL));
	375
da7f71d7 MD	376	SCM os = scm_makfrom0str (SCM_METACLASS_OPERATOR_LAYOUT);
	377	SCM ol = scm_make_struct_layout (os);
	378	SCM ot = scm_make_vtable_vtable (ol, SCM_INUM0,
	379	SCM_LIST3 (SCM_BOOL_F, SCM_EOL, SCM_EOL));
	380
1d9ee7c7 MD	381	SCM es = scm_makfrom0str (SCM_ENTITY_LAYOUT);
	382	SCM el = scm_make_struct_layout (es);
	383	SCM et = scm_make_struct (mt, SCM_INUM0,
	384	SCM_LIST4 (el, SCM_BOOL_F, SCM_EOL, SCM_EOL));
	385
19c0dec2	386	scm_sysintern ("<class>", mt);
1d9ee7c7	387	scm_metaclass_standard = mt;
af3645c5	388	scm_sysintern ("<operator-class>", ot);
da7f71d7 MD	389	scm_metaclass_operator = ot;
da7f71d7 MD	390	SCM_SET_CLASS_FLAGS (et, SCM_CLASSF_OPERATOR \| SCM_CLASSF_ENTITY);
135e76f8	391	SCM_SET_CLASS_DESTRUCTOR (et, scm_struct_free_entity);
af3645c5	392	scm_sysintern ("<entity>", et);
47b21050 MD	393
47b21050 MD	394	#include "objects.x"
1d9ee7c7	395	}