X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/ed6e0c83f585a684f23758d2fa54f267056272e6..eb7e1603ad497d0efff686e26e23af987c567721:/libguile/objects.c diff --git a/libguile/objects.c b/libguile/objects.c dissimilarity index 64% index 44547dd76..f655470da 100644 --- a/libguile/objects.c +++ b/libguile/objects.c @@ -1,386 +1,510 @@ -/* 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. */ - - -/* 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 "kw.h" -#include "smob.h" - -#include "objects.h" - - -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_smob_class = 0; - -SCM (*scm_make_extended_class) (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_class_unknown; - 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) - { - /* 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 ("", mt); - scm_metaclass_standard = mt; - scm_sysintern ("", ot); - scm_metaclass_operator = ot; - SCM_SET_CLASS_FLAGS (et, SCM_CLASSF_OPERATOR | SCM_CLASSF_ENTITY); - scm_sysintern ("", et); - -#include "objects.x" -} +/* Copyright (C) 1995,1996,1999,2000,2001, 2003 Free Software Foundation, Inc. + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public + * License as published by the Free Software Foundation; either + * version 2.1 of the License, or (at your option) any later version. + * + * This library 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 + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + + + + +/* 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 "libguile/_scm.h" + +#include "libguile/struct.h" +#include "libguile/procprop.h" +#include "libguile/chars.h" +#include "libguile/keywords.h" +#include "libguile/smob.h" +#include "libguile/eval.h" +#include "libguile/alist.h" +#include "libguile/ports.h" +#include "libguile/strings.h" +#include "libguile/vectors.h" + +#include "libguile/validate.h" +#include "libguile/objects.h" + + +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_class_primitive_generic; +SCM scm_class_vector, scm_class_null; +SCM scm_class_integer, scm_class_real, scm_class_complex, scm_class_fraction; +SCM scm_class_unknown; + +SCM *scm_port_class = 0; +SCM *scm_smob_class = 0; + +SCM scm_no_applicable_method; + +/* This function is used for efficient type dispatch. */ +SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0, + (SCM x), + "Return the class of @var{x}.") +#define FUNC_NAME s_scm_class_of +{ + switch (SCM_ITAG3 (x)) + { + case scm_tc3_int_1: + case scm_tc3_int_2: + return scm_class_integer; + + case scm_tc3_imm24: + if (SCM_CHARP (x)) + return scm_class_char; + else if (SCM_BOOLP (x)) + return scm_class_boolean; + else if (SCM_NULLP (x)) + return scm_class_null; + else + 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_tc7_symbol: + return scm_class_symbol; + case scm_tc7_vector: + case scm_tc7_wvect: +#if SCM_HAVE_ARRAYS + 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: +#endif + return scm_class_vector; + case scm_tc7_string: + return scm_class_string; + case scm_tc7_number: + switch SCM_TYP16 (x) { + case scm_tc16_big: + return scm_class_integer; + case scm_tc16_real: + return scm_class_real; + case scm_tc16_complex: + return scm_class_complex; + case scm_tc16_fraction: + return scm_class_fraction; + } + case scm_tc7_asubr: + case scm_tc7_subr_0: + case scm_tc7_subr_1: + case scm_tc7_dsubr: + 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: + if (SCM_SUBR_GENERIC (x) && *SCM_SUBR_GENERIC (x)) + return scm_class_primitive_generic; + else + return scm_class_procedure; + case scm_tc7_cclo: + return scm_class_procedure; + case scm_tc7_pws: + return scm_class_procedure_with_setter; + + case scm_tc7_smob: + { + scm_t_bits type = SCM_TYP16 (x); + if (type != scm_tc16_port_with_ps) + return scm_smob_class[SCM_TC2SMOBNUM (type)]; + x = SCM_PORT_WITH_PS_PORT (x); + /* fall through to ports */ + } + case scm_tc7_port: + return scm_port_class[(SCM_WRTNG & SCM_CELL_WORD_0 (x) + ? (SCM_RDNG & SCM_CELL_WORD_0 (x) + ? SCM_INOUT_PCLASS_INDEX | SCM_PTOBNUM (x) + : SCM_OUT_PCLASS_INDEX | SCM_PTOBNUM (x)) + : SCM_IN_PCLASS_INDEX | SCM_PTOBNUM (x))]; + case scm_tcs_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_FALSEP (SCM_OBJ_CLASS_REDEF (x))) + 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_FALSEP (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_FALSEP (name) + ? SCM_SYMBOL_CHARS (name) + : 0, + SCM_I_OPERATORP (x)); + SCM_SET_STRUCT_TABLE_CLASS (SCM_CDR (handle), class); + return class; + } + } + default: + if (SCM_CONSP (x)) + return scm_class_pair; + else + return scm_class_unknown; + } + + case scm_tc3_struct: + case scm_tc3_tc7_1: + case scm_tc3_tc7_2: + case scm_tc3_closure: + /* Never reached */ + break; + } + return scm_class_unknown; +} +#undef FUNC_NAME + +/* The cache argument for scm_mcache_lookup_cmethod has one of two possible + * formats: + * + * Format #1: + * (SCM_IM_DISPATCH ARGS N-SPECIALIZED + * #((TYPE1 ... ENV FORMALS FORM ...) ...) + * GF) + * + * Format #2: + * (SCM_IM_HASH_DISPATCH ARGS N-SPECIALIZED HASHSET MASK + * #((TYPE1 ... ENV FORMALS FORM ...) ...) + * GF) + * + * ARGS is either a list of expressions, in which case they + * are interpreted as the arguments of an application, or + * a non-pair, which is interpreted as a single expression + * yielding all arguments. + * + * SCM_IM_DISPATCH expressions in generic functions always + * have ARGS = the symbol `args' or the iloc #@0-0. + * + * Need FORMALS in order to support varying arity. This + * also avoids the need for renaming of bindings. + * + * We should probably not complicate this mechanism by + * introducing "optimizations" for getters and setters or + * primitive methods. Getters and setter will normally be + * compiled into @slot-[ref|set!] or a procedure call. + * They rely on the dispatch performed before executing + * the code which contains them. + * + * We might want to use a more efficient representation of + * this form in the future, perhaps after we have introduced + * low-level support for syntax-case macros. + */ + +SCM +scm_mcache_lookup_cmethod (SCM cache, SCM args) +{ + long i, n, end, mask; + SCM ls, methods, z = SCM_CDDR (cache); + n = SCM_INUM (SCM_CAR (z)); /* maximum number of specializers */ + methods = SCM_CADR (z); + + if (SCM_INUMP (methods)) + { + /* cache format #2: compute a hash value */ + long hashset = SCM_INUM (methods); + long j = n; + z = SCM_CDDR (z); + mask = SCM_INUM (SCM_CAR (z)); + methods = SCM_CADR (z); + i = 0; + ls = args; + if (!SCM_NULLP (ls)) + do + { + i += SCM_STRUCT_DATA (scm_class_of (SCM_CAR (ls))) + [scm_si_hashsets + hashset]; + ls = SCM_CDR (ls); + } + while (j-- && !SCM_NULLP (ls)); + i &= mask; + end = i; + } + else /* SCM_VECTORP (methods) */ + { + /* cache format #1: prepare for linear search */ + mask = -1; + i = 0; + end = SCM_VECTOR_LENGTH (methods); + } + + /* Search for match */ + do + { + long j = n; + z = SCM_VELTS (methods)[i]; + ls = args; /* list of arguments */ + if (!SCM_NULLP (ls)) + do + { + /* More arguments than specifiers => CLASS != ENV */ + if (! SCM_EQ_P (scm_class_of (SCM_CAR (ls)), SCM_CAR (z))) + goto next_method; + ls = SCM_CDR (ls); + z = SCM_CDR (z); + } + while (j-- && !SCM_NULLP (ls)); + /* Fewer arguments than specifiers => CAR != ENV */ + if (SCM_NULLP (SCM_CAR (z)) || SCM_CONSP (SCM_CAR (z))) + return z; + next_method: + i = (i + 1) & mask; + } while (i != end); + return SCM_BOOL_F; +} + +SCM +scm_mcache_compute_cmethod (SCM cache, SCM args) +{ + SCM cmethod = scm_mcache_lookup_cmethod (cache, args); + if (SCM_FALSEP (cmethod)) + /* No match - memoize */ + return scm_memoize_method (cache, args); + return cmethod; +} + +SCM +scm_apply_generic (SCM gf, SCM args) +{ + SCM cmethod = scm_mcache_compute_cmethod (SCM_ENTITY_PROCEDURE (gf), args); + return scm_eval_body (SCM_CDR (SCM_CMETHOD_CODE (cmethod)), + SCM_EXTEND_ENV (SCM_CAR (SCM_CMETHOD_CODE (cmethod)), + args, + SCM_CMETHOD_ENV (cmethod))); +} + +SCM +scm_call_generic_0 (SCM gf) +{ + return scm_apply_generic (gf, SCM_EOL); +} + +SCM +scm_call_generic_1 (SCM gf, SCM a1) +{ + return scm_apply_generic (gf, scm_list_1 (a1)); +} + +SCM +scm_call_generic_2 (SCM gf, SCM a1, SCM a2) +{ + return scm_apply_generic (gf, scm_list_2 (a1, a2)); +} + +SCM +scm_call_generic_3 (SCM gf, SCM a1, SCM a2, SCM a3) +{ + return scm_apply_generic (gf, scm_list_3 (a1, a2, a3)); +} + +SCM_DEFINE (scm_entity_p, "entity?", 1, 0, 0, + (SCM obj), + "Return @code{#t} if @var{obj} is an entity.") +#define FUNC_NAME s_scm_entity_p +{ + return SCM_BOOL(SCM_STRUCTP (obj) && SCM_I_ENTITYP (obj)); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_operator_p, "operator?", 1, 0, 0, + (SCM obj), + "Return @code{#t} if @var{obj} is an operator.") +#define FUNC_NAME s_scm_operator_p +{ + return SCM_BOOL(SCM_STRUCTP (obj) + && SCM_I_OPERATORP (obj) + && !SCM_I_ENTITYP (obj)); +} +#undef FUNC_NAME + +/* XXX - What code requires the object procedure to be only of certain + types? */ + +SCM_DEFINE (scm_valid_object_procedure_p, "valid-object-procedure?", 1, 0, 0, + (SCM proc), + "Return @code{#t} iff @var{proc} is a procedure that can be used " + "with @code{set-object-procedure}. It is always valid to use " + "a closure constructed by @code{lambda}.") +#define FUNC_NAME s_scm_valid_object_procedure_p +{ + if (SCM_IMP (proc)) + return SCM_BOOL_F; + switch (SCM_TYP7 (proc)) + { + default: + return SCM_BOOL_F; + case scm_tcs_closures: + case scm_tc7_subr_1: + case scm_tc7_subr_2: + case scm_tc7_subr_3: + case scm_tc7_lsubr_2: + return SCM_BOOL_T; + } +} +#undef FUNC_NAME + +SCM_DEFINE (scm_set_object_procedure_x, "set-object-procedure!", 2, 0, 0, + (SCM obj, SCM proc), + "Set the object procedure of @var{obj} to @var{proc}.\n" + "@var{obj} must be either an entity or an operator.") +#define FUNC_NAME s_scm_set_object_procedure_x +{ + SCM_ASSERT (SCM_STRUCTP (obj) + && ((SCM_CLASS_FLAGS (obj) & SCM_CLASSF_OPERATOR) + || (SCM_I_ENTITYP (obj) + && !(SCM_OBJ_CLASS_FLAGS (obj) + & SCM_CLASSF_PURE_GENERIC))), + obj, + SCM_ARG1, + FUNC_NAME); + SCM_ASSERT (scm_valid_object_procedure_p (proc), proc, SCM_ARG2, FUNC_NAME); + if (SCM_I_ENTITYP (obj)) + SCM_SET_ENTITY_PROCEDURE (obj, proc); + else + SCM_OPERATOR_CLASS (obj)->procedure = proc; + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + +#ifdef GUILE_DEBUG +SCM_DEFINE (scm_object_procedure, "object-procedure", 1, 0, 0, + (SCM obj), + "Return the object procedure of @var{obj}. @var{obj} must be\n" + "an entity or an operator.") +#define FUNC_NAME s_scm_object_procedure +{ + SCM_ASSERT (SCM_STRUCTP (obj) + && ((SCM_CLASS_FLAGS (obj) & SCM_CLASSF_OPERATOR) + || SCM_I_ENTITYP (obj)), + obj, SCM_ARG1, FUNC_NAME); + return (SCM_I_ENTITYP (obj) + ? SCM_ENTITY_PROCEDURE (obj) + : SCM_OPERATOR_CLASS (obj)->procedure); +} +#undef FUNC_NAME +#endif /* GUILE_DEBUG */ + +/* 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_list_4 (layout, SCM_BOOL_F, SCM_EOL, SCM_EOL)); + SCM_SET_CLASS_FLAGS (c, flags); + return c; +} + +SCM_DEFINE (scm_make_class_object, "make-class-object", 2, 0, 0, + (SCM metaclass, SCM layout), + "Create a new class object of class @var{metaclass}, with the\n" + "slot layout specified by @var{layout}.") +#define FUNC_NAME s_scm_make_class_object +{ + unsigned long flags = 0; + SCM_VALIDATE_STRUCT (1, metaclass); + SCM_VALIDATE_STRING (2, layout); + if (SCM_EQ_P (metaclass, scm_metaclass_operator)) + flags = SCM_CLASSF_OPERATOR; + return scm_i_make_class_object (metaclass, layout, flags); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_make_subclass_object, "make-subclass-object", 2, 0, 0, + (SCM class, SCM layout), + "Create a subclass object of @var{class}, with the slot layout\n" + "specified by @var{layout}.") +#define FUNC_NAME s_scm_make_subclass_object +{ + SCM pl; + SCM_VALIDATE_STRUCT (1, class); + SCM_VALIDATE_STRING (2, layout); + pl = SCM_PACK (SCM_STRUCT_DATA (class) [scm_vtable_index_layout]); + /* Convert symbol->string */ + pl = scm_mem2string (SCM_SYMBOL_CHARS (pl), SCM_SYMBOL_LENGTH (pl)); + return scm_i_make_class_object (SCM_STRUCT_VTABLE (class), + scm_string_append (scm_list_2 (pl, layout)), + SCM_CLASS_FLAGS (class)); +} +#undef FUNC_NAME + +void +scm_init_objects () +{ + SCM ms = scm_makfrom0str (SCM_METACLASS_STANDARD_LAYOUT); + SCM mt = scm_make_vtable_vtable (ms, SCM_INUM0, + scm_list_3 (SCM_BOOL_F, SCM_EOL, SCM_EOL)); + + SCM os = scm_makfrom0str (SCM_METACLASS_OPERATOR_LAYOUT); + SCM ot = scm_make_vtable_vtable (os, SCM_INUM0, + scm_list_3 (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_list_4 (el, SCM_BOOL_F, SCM_EOL, SCM_EOL)); + + scm_c_define ("", mt); + scm_metaclass_standard = mt; + scm_c_define ("", 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_c_define ("", et); + +#include "libguile/objects.x" +} + +/* + Local Variables: + c-file-style: "gnu" + End: +*/