X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/86d31dfe7d0754b863863f6544c75097ef68fe8c..4e047c3e4686a7fa47e2fb6d5eba63fd93cad288:/libguile/goops.c diff --git a/libguile/goops.c b/libguile/goops.c index f108d1407..86d486abc 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -1,43 +1,20 @@ -/* Copyright (C) 1998,1999,2000,2001 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. +/* Copyright (C) 1998,1999,2000,2001,2002,2003,2004 + * Free Software Foundation, Inc. * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. + * 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 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. + * 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. * - * 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. */ + * 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 software is a derivative work of other copyrighted softwares; the @@ -51,6 +28,8 @@ #include "libguile/_scm.h" #include "libguile/alist.h" +#include "libguile/async.h" +#include "libguile/chars.h" #include "libguile/debug.h" #include "libguile/dynl.h" #include "libguile/dynwind.h" @@ -63,6 +42,7 @@ #include "libguile/ports.h" #include "libguile/procprop.h" #include "libguile/random.h" +#include "libguile/root.h" #include "libguile/smob.h" #include "libguile/strings.h" #include "libguile/strports.h" @@ -74,24 +54,24 @@ #define SPEC_OF(x) SCM_SLOT (x, scm_si_specializers) -#define DEFVAR(v,val) \ -{ scm_eval (SCM_LIST3 (scm_sym_define_public, (v), (val)), \ - scm_module_goops); } +#define DEFVAR(v, val) \ +{ scm_eval (scm_list_3 (scm_sym_define_public, (v), (val)), \ + scm_module_goops); } /* Temporary hack until we get the new module system */ /*fixme* Should optimize by keeping track of the variable object itself */ -#define GETVAR(v) (SCM_VARIABLE_REF (scm_apply (scm_goops_lookup_closure, \ - SCM_LIST2 ((v), SCM_BOOL_F), \ - SCM_EOL))) +#define GETVAR(v) (SCM_VARIABLE_REF (scm_call_2 (scm_goops_lookup_closure, \ + (v), SCM_BOOL_F))) /* Fixme: Should use already interned symbols */ -#define CALL_GF1(name,a) (scm_apply (GETVAR (scm_str2symbol (name)), \ - SCM_LIST1 (a), SCM_EOL)) -#define CALL_GF2(name,a,b) (scm_apply (GETVAR (scm_str2symbol (name)), \ - SCM_LIST2 (a, b), SCM_EOL)) -#define CALL_GF3(name,a,b,c) (scm_apply (GETVAR (scm_str2symbol (name)), \ - SCM_LIST3 (a, b, c), SCM_EOL)) -#define CALL_GF4(name,a,b,c,d) (scm_apply (GETVAR (scm_str2symbol (name)), \ - SCM_LIST4 (a, b, c, d), SCM_EOL)) + +#define CALL_GF1(name, a) (scm_call_1 (GETVAR (scm_from_locale_symbol (name)), \ + a)) +#define CALL_GF2(name, a, b) (scm_call_2 (GETVAR (scm_from_locale_symbol (name)), \ + a, b)) +#define CALL_GF3(name, a, b, c) (scm_call_3 (GETVAR (scm_from_locale_symbol (name)), \ + a, b, c)) +#define CALL_GF4(name, a, b, c, d) (scm_call_4 (GETVAR (scm_from_locale_symbol (name)), \ + a, b, c, d)) /* Class redefinition protocol: @@ -111,17 +91,18 @@ h1. */ -#define SCM_CLASS_REDEF(c) SCM_SLOT (c, scm_si_redefined) /* The following definition is located in libguile/objects.h: #define SCM_OBJ_CLASS_REDEF(x) (SCM_STRUCT_VTABLE_DATA(x)[scm_si_redefined]) */ -#define TEST_CHANGE_CLASS(obj, class) \ - { \ - class = SCM_CLASS_OF (obj); \ - if (SCM_OBJ_CLASS_REDEF (obj) != SCM_BOOL_F) \ - CALL_GF3 ("change-object-class", \ - obj, class, SCM_OBJ_CLASS_REDEF (obj)); \ +#define TEST_CHANGE_CLASS(obj, class) \ + { \ + class = SCM_CLASS_OF (obj); \ + if (scm_is_true (SCM_OBJ_CLASS_REDEF (obj))) \ + { \ + scm_change_object_class (obj, class, SCM_OBJ_CLASS_REDEF (obj));\ + class = SCM_CLASS_OF (obj); \ + } \ } #define NXT_MTHD_METHODS(m) (SCM_VELTS (m)[1]) @@ -131,15 +112,26 @@ #define SCM_GOOPS_UNBOUNDP(x) ((x) == SCM_GOOPS_UNBOUND) static int goops_loaded_p = 0; -static scm_rstate *goops_rstate; +static scm_t_rstate *goops_rstate; static SCM scm_goops_lookup_closure; -/* Some classes are defined in libguile/objects.c. */ +/* 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_class_top, scm_class_object, scm_class_class; +SCM scm_class_applicable; SCM scm_class_entity, scm_class_entity_with_setter; -SCM scm_class_generic, scm_class_generic_with_setter, scm_class_method; -SCM scm_class_simple_method, scm_class_accessor; +SCM scm_class_generic, scm_class_generic_with_setter; +SCM scm_class_accessor; +SCM scm_class_extended_generic, scm_class_extended_generic_with_setter; +SCM scm_class_extended_accessor; +SCM scm_class_method; +SCM scm_class_simple_method, scm_class_accessor_method; SCM scm_class_procedure_class; SCM scm_class_operator_class, scm_class_operator_with_setter_class; SCM scm_class_entity_class; @@ -155,6 +147,11 @@ SCM scm_class_protected_opaque, scm_class_protected_read_only; SCM scm_class_scm; SCM scm_class_int, scm_class_float, scm_class_double; +SCM *scm_port_class = 0; +SCM *scm_smob_class = 0; + +SCM scm_no_applicable_method; + SCM_SYMBOL (scm_sym_define_public, "define-public"); static SCM scm_make_unbound (void); @@ -163,53 +160,172 @@ static SCM scm_assert_bound (SCM value, SCM obj); static SCM scm_at_assert_bound_ref (SCM obj, SCM index); static SCM scm_sys_goops_loaded (void); +/* 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_is_bool (x)) + return scm_class_boolean; + else if (scm_is_null (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: + 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_is_false (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_is_true (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_is_true (name) + ? scm_i_symbol_chars (name) + : 0, + SCM_I_OPERATORP (x)); + SCM_SET_STRUCT_TABLE_CLASS (SCM_CDR (handle), class); + return class; + } + } + default: + if (scm_is_pair (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 + /****************************************************************************** * * Compute-cpl * - * This version doesn't handle multiple-inheritance. It serves only for - * booting classes and will be overaloaded in Scheme + * This version doesn't fully handle multiple-inheritance. It serves + * only for booting classes and will be overloaded in Scheme * ******************************************************************************/ -#if 0 -static SCM -compute_cpl (SCM supers, SCM res) -{ - return (SCM_NULLP (supers) - ? scm_reverse (res) - : compute_cpl (SCM_SLOT (SCM_CAR (supers), scm_si_direct_supers), - scm_cons (SCM_CAR (supers), res))); -} -#endif - static SCM map (SCM (*proc) (SCM), SCM ls) { - if (SCM_IMP (ls)) + if (scm_is_null (ls)) return ls; - { - SCM res = scm_cons (proc (SCM_CAR (ls)), SCM_EOL); - SCM h = res; - ls = SCM_CDR (ls); - while (SCM_NIMP (ls)) - { - SCM_SETCDR (h, scm_cons (proc (SCM_CAR (ls)), SCM_EOL)); - h = SCM_CDR (h); - ls = SCM_CDR (ls); - } - return res; - } + else + { + SCM res = scm_cons (proc (SCM_CAR (ls)), SCM_EOL); + SCM h = res; + ls = SCM_CDR (ls); + while (!scm_is_null (ls)) + { + SCM_SETCDR (h, scm_cons (proc (SCM_CAR (ls)), SCM_EOL)); + h = SCM_CDR (h); + ls = SCM_CDR (ls); + } + return res; + } } static SCM filter_cpl (SCM ls) { SCM res = SCM_EOL; - while (SCM_NIMP (ls)) + while (!scm_is_null (ls)) { SCM el = SCM_CAR (ls); - if (SCM_FALSEP (scm_c_memq (el, res))) + if (scm_is_false (scm_c_memq (el, res))) res = scm_cons (el, res); ls = SCM_CDR (ls); } @@ -241,18 +357,18 @@ remove_duplicate_slots (SCM l, SCM res, SCM slots_already_seen) { SCM tmp; - if (SCM_NULLP (l)) + if (scm_is_null (l)) return res; tmp = SCM_CAAR (l); - if (!SCM_SYMBOLP (tmp)) - scm_misc_error ("%compute-slots", "bad slot name ~S", SCM_LIST1 (tmp)); - - if (SCM_FALSEP (scm_c_memq (tmp, slots_already_seen))) { + if (!scm_is_symbol (tmp)) + scm_misc_error ("%compute-slots", "bad slot name ~S", scm_list_1 (tmp)); + + if (scm_is_false (scm_c_memq (tmp, slots_already_seen))) { res = scm_cons (SCM_CAR (l), res); slots_already_seen = scm_cons (tmp, slots_already_seen); } - + return remove_duplicate_slots (SCM_CDR (l), res, slots_already_seen); } @@ -261,9 +377,10 @@ build_slots_list (SCM dslots, SCM cpl) { register SCM res = dslots; - for (cpl = SCM_CDR(cpl); SCM_NNULLP(cpl); cpl = SCM_CDR(cpl)) - res = scm_append (SCM_LIST2 (SCM_SLOT (SCM_CAR (cpl), scm_si_direct_slots), - res)); + for (cpl = SCM_CDR (cpl); !scm_is_null (cpl); cpl = SCM_CDR (cpl)) + res = scm_append (scm_list_2 (SCM_SLOT (SCM_CAR (cpl), + scm_si_direct_slots), + res)); /* res contains a list of slots. Remove slots which appears more than once */ return remove_duplicate_slots (scm_reverse (res), SCM_EOL, SCM_EOL); @@ -273,9 +390,9 @@ static SCM maplist (SCM ls) { SCM orig = ls; - while (SCM_NIMP (ls)) + while (!scm_is_null (ls)) { - if (!SCM_CONSP (SCM_CAR (ls))) + if (!scm_is_pair (SCM_CAR (ls))) SCM_SETCAR (ls, scm_cons (SCM_CAR (ls), SCM_EOL)); ls = SCM_CDR (ls); } @@ -287,7 +404,7 @@ SCM_DEFINE (scm_sys_compute_slots, "%compute-slots", 1, 0, 0, (SCM class), "Return a list consisting of the names of all slots belonging to\n" "class @var{class}, i. e. the slots of @var{class} and of all of\n" - "its superclasses.") + "its superclasses.") #define FUNC_NAME s_scm_sys_compute_slots { SCM_VALIDATE_CLASS (1, class); @@ -300,9 +417,9 @@ SCM_DEFINE (scm_sys_compute_slots, "%compute-slots", 1, 0, 0, /****************************************************************************** * * compute-getters-n-setters - * - * This version doesn't handle slot options. It serves only for booting - * classes and will be overaloaded in Scheme. + * + * This version doesn't handle slot options. It serves only for booting + * classes and will be overloaded in Scheme. * ******************************************************************************/ @@ -316,21 +433,27 @@ compute_getters_n_setters (SCM slots) SCM *cdrloc = &res; long i = 0; - for ( ; SCM_NNULLP(slots); slots = SCM_CDR(slots)) + for ( ; !scm_is_null (slots); slots = SCM_CDR (slots)) { SCM init = SCM_BOOL_F; SCM options = SCM_CDAR (slots); - if (SCM_NNULLP (options)) + if (!scm_is_null (options)) { init = scm_get_keyword (k_init_value, options, 0); if (init) - init = scm_closure (SCM_LIST2 (SCM_EOL, init), SCM_EOL); + { + init = scm_i_eval_x (scm_list_3 (scm_sym_lambda, + SCM_EOL, + scm_list_2 (scm_sym_quote, + init)), + SCM_EOL); + } else init = scm_get_keyword (k_init_thunk, options, SCM_BOOL_F); } *cdrloc = scm_cons (scm_cons (SCM_CAAR (slots), scm_cons (init, - SCM_MAKINUM (i++))), + scm_from_int (i++))), SCM_EOL); cdrloc = SCM_CDRLOC (*cdrloc); } @@ -345,17 +468,17 @@ compute_getters_n_setters (SCM slots) /*fixme* Manufacture keywords in advance */ SCM -scm_i_get_keyword (SCM key, SCM l, int len, SCM default_value, const char *subr) +scm_i_get_keyword (SCM key, SCM l, long len, SCM default_value, const char *subr) { - unsigned int i; + long i; for (i = 0; i != len; i += 2) { SCM obj = SCM_CAR (l); - if (!SCM_KEYWORDP (obj)) - scm_misc_error (subr, "bad keyword: ~S", SCM_LIST1 (obj)); - else if (SCM_EQ_P (obj, key)) + if (!scm_is_keyword (obj)) + scm_misc_error (subr, "bad keyword: ~S", scm_list_1 (obj)); + else if (scm_is_eq (obj, key)) return SCM_CADR (l); else l = SCM_CDDR (l); @@ -375,12 +498,12 @@ SCM_DEFINE (scm_get_keyword, "get-keyword", 3, 0, 0, "@var{default_value} is returned.") #define FUNC_NAME s_scm_get_keyword { - int len; + long len; - SCM_ASSERT (SCM_KEYWORDP (key), key, SCM_ARG1, FUNC_NAME); + SCM_ASSERT (scm_is_keyword (key), key, SCM_ARG1, FUNC_NAME); len = scm_ilength (l); if (len < 0 || len % 2 == 1) - scm_misc_error (FUNC_NAME, "Bad keyword-value list: ~S", SCM_LIST1 (l)); + scm_misc_error (FUNC_NAME, "Bad keyword-value list: ~S", scm_list_1 (l)); return scm_i_get_keyword (key, l, len, default_value, FUNC_NAME); } @@ -400,30 +523,30 @@ SCM_DEFINE (scm_sys_initialize_object, "%initialize-object", 2, 0, 0, { SCM tmp, get_n_set, slots; SCM class = SCM_CLASS_OF (obj); - int n_initargs; + long n_initargs; SCM_VALIDATE_INSTANCE (1, obj); n_initargs = scm_ilength (initargs); SCM_ASSERT ((n_initargs & 1) == 0, initargs, SCM_ARG2, FUNC_NAME); - + get_n_set = SCM_SLOT (class, scm_si_getters_n_setters); slots = SCM_SLOT (class, scm_si_slots); - + /* See for each slot how it must be initialized */ for (; - SCM_NNULLP (slots); + !scm_is_null (slots); get_n_set = SCM_CDR (get_n_set), slots = SCM_CDR (slots)) { SCM slot_name = SCM_CAR (slots); SCM slot_value = 0; - - if (SCM_NIMP (SCM_CDR (slot_name))) + + if (!scm_is_null (SCM_CDR (slot_name))) { /* This slot admits (perhaps) to be initialized at creation time */ - int n = scm_ilength (SCM_CDR (slot_name)); + long n = scm_ilength (SCM_CDR (slot_name)); if (n & 1) /* odd or -1 */ SCM_MISC_ERROR ("class contains bogus slot definition: ~S", - SCM_LIST1 (slot_name)); + scm_list_1 (slot_name)); tmp = scm_i_get_keyword (k_init_keyword, SCM_CDR (slot_name), n, @@ -433,9 +556,9 @@ SCM_DEFINE (scm_sys_initialize_object, "%initialize-object", 2, 0, 0, if (tmp) { /* an initarg was provided for this slot */ - if (!SCM_KEYWORDP (tmp)) + if (!scm_is_keyword (tmp)) SCM_MISC_ERROR ("initarg must be a keyword. It was ~S", - SCM_LIST1 (tmp)); + scm_list_1 (tmp)); slot_value = scm_i_get_keyword (tmp, initargs, n_initargs, @@ -451,7 +574,7 @@ SCM_DEFINE (scm_sys_initialize_object, "%initialize-object", 2, 0, 0, { /* set slot to its :init-form if it exists */ tmp = SCM_CADAR (get_n_set); - if (tmp != SCM_BOOL_F) + if (scm_is_true (tmp)) { slot_value = get_slot_value (class, obj, SCM_CAR (get_n_set)); if (SCM_GOOPS_UNBOUNDP (slot_value)) @@ -460,77 +583,130 @@ SCM_DEFINE (scm_sys_initialize_object, "%initialize-object", 2, 0, 0, set_slot_value (class, obj, SCM_CAR (get_n_set), - scm_eval_body (SCM_CDR (SCM_CODE (tmp)), - env)); + scm_eval_body (SCM_CLOSURE_BODY (tmp), env)); } } } } - + return obj; } #undef FUNC_NAME +/* NOTE: The following macros are interdependent with code + * in goops.scm:compute-getters-n-setters + */ +#define SCM_GNS_INSTANCE_ALLOCATED_P(gns) \ + (SCM_I_INUMP (SCM_CDDR (gns)) \ + || (scm_is_pair (SCM_CDDR (gns)) \ + && scm_is_pair (SCM_CDDDR (gns)) \ + && scm_is_pair (SCM_CDDDDR (gns)))) +#define SCM_GNS_INDEX(gns) \ + (SCM_I_INUMP (SCM_CDDR (gns)) \ + ? SCM_I_INUM (SCM_CDDR (gns)) \ + : scm_to_long (SCM_CAR (SCM_CDDDDR (gns)))) +#define SCM_GNS_SIZE(gns) \ + (SCM_I_INUMP (SCM_CDDR (gns)) \ + ? 1 \ + : scm_to_long (SCM_CADR (SCM_CDDDDR (gns)))) SCM_KEYWORD (k_class, "class"); +SCM_KEYWORD (k_allocation, "allocation"); +SCM_KEYWORD (k_instance, "instance"); SCM_DEFINE (scm_sys_prep_layout_x, "%prep-layout!", 1, 0, 0, (SCM class), "") #define FUNC_NAME s_scm_sys_prep_layout_x { - int i, n, len; - char *s, p, a; - SCM nfields, slots, type; + SCM slots, getters_n_setters, nfields; + unsigned long int n, i; + char *s; + SCM layout; SCM_VALIDATE_INSTANCE (1, class); slots = SCM_SLOT (class, scm_si_slots); + getters_n_setters = SCM_SLOT (class, scm_si_getters_n_setters); nfields = SCM_SLOT (class, scm_si_nfields); - if (!SCM_INUMP (nfields) || SCM_INUM (nfields) < 0) + if (!SCM_I_INUMP (nfields) || SCM_I_INUM (nfields) < 0) SCM_MISC_ERROR ("bad value in nfields slot: ~S", - SCM_LIST1 (nfields)); - n = 2 * SCM_INUM (nfields); + scm_list_1 (nfields)); + n = 2 * SCM_I_INUM (nfields); if (n < sizeof (SCM_CLASS_CLASS_LAYOUT) - 1 && SCM_SUBCLASSP (class, scm_class_class)) SCM_MISC_ERROR ("class object doesn't have enough fields: ~S", - SCM_LIST1 (nfields)); - - s = n > 0 ? scm_must_malloc (n, FUNC_NAME) : 0; - for (i = 0; i < n; i += 2) + scm_list_1 (nfields)); + + layout = scm_i_make_string (n, &s); + i = 0; + while (scm_is_pair (getters_n_setters)) { - if (!SCM_CONSP (slots)) - SCM_MISC_ERROR ("to few slot definitions", SCM_EOL); - len = scm_ilength (SCM_CDAR (slots)); - type = scm_i_get_keyword (k_class, SCM_CDAR (slots), len, SCM_BOOL_F, - FUNC_NAME); - if (SCM_NIMP (type) && SCM_SUBCLASSP (type, scm_class_foreign_slot)) + if (SCM_GNS_INSTANCE_ALLOCATED_P (SCM_CAR (getters_n_setters))) { - if (SCM_SUBCLASSP (type, scm_class_self)) - p = 's'; - else if (SCM_SUBCLASSP (type, scm_class_protected)) - p = 'p'; - else - p = 'u'; + SCM type; + int len, index, size; + char p, a; + + if (i >= n || !scm_is_pair (slots)) + goto inconsistent; - if (SCM_SUBCLASSP (type, scm_class_opaque)) - a = 'o'; - else if (SCM_SUBCLASSP (type, scm_class_read_only)) - a = 'r'; + /* extract slot type */ + len = scm_ilength (SCM_CDAR (slots)); + type = scm_i_get_keyword (k_class, SCM_CDAR (slots), + len, SCM_BOOL_F, FUNC_NAME); + /* determine slot GC protection and access mode */ + if (scm_is_false (type)) + { + p = 'p'; + a = 'w'; + } else - a = 'w'; - } - else - { - p = 'p'; - a = 'w'; + { + if (!SCM_CLASSP (type)) + SCM_MISC_ERROR ("bad slot class", SCM_EOL); + else if (SCM_SUBCLASSP (type, scm_class_foreign_slot)) + { + if (SCM_SUBCLASSP (type, scm_class_self)) + p = 's'; + else if (SCM_SUBCLASSP (type, scm_class_protected)) + p = 'p'; + else + p = 'u'; + + if (SCM_SUBCLASSP (type, scm_class_opaque)) + a = 'o'; + else if (SCM_SUBCLASSP (type, scm_class_read_only)) + a = 'r'; + else + a = 'w'; + } + else + { + p = 'p'; + a = 'w'; + } + } + + index = SCM_GNS_INDEX (SCM_CAR (getters_n_setters)); + if (index != (i >> 1)) + goto inconsistent; + size = SCM_GNS_SIZE (SCM_CAR (getters_n_setters)); + while (size) + { + s[i++] = p; + s[i++] = a; + --size; + } } - s[i] = p; - s[i + 1] = a; slots = SCM_CDR (slots); + getters_n_setters = SCM_CDR (getters_n_setters); + } + if (!scm_is_null (slots)) + { + inconsistent: + SCM_MISC_ERROR ("inconsistent getters-n-setters", SCM_EOL); } - SCM_SLOT (class, scm_si_layout) = scm_mem2symbol (s, n); - if (s) - scm_must_free (s); + SCM_SET_SLOT (class, scm_si_layout, scm_string_to_symbol (layout)); return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -545,9 +721,9 @@ SCM_DEFINE (scm_sys_inherit_magic_x, "%inherit-magic!", 2, 0, 0, SCM ls = dsupers; long flags = 0; SCM_VALIDATE_INSTANCE (1, class); - while (SCM_NNULLP (ls)) + while (!scm_is_null (ls)) { - SCM_ASSERT (SCM_CONSP (ls) + SCM_ASSERT (scm_is_pair (ls) && SCM_INSTANCEP (SCM_CAR (ls)), dsupers, SCM_ARG2, @@ -560,10 +736,10 @@ SCM_DEFINE (scm_sys_inherit_magic_x, "%inherit-magic!", 2, 0, 0, SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_entity); else { - int n = SCM_INUM (SCM_SLOT (class, scm_si_nfields)); + long n = SCM_I_INUM (SCM_SLOT (class, scm_si_nfields)); #if 0 /* - * We could avoid calling scm_must_malloc in the allocation code + * We could avoid calling scm_gc_malloc in the allocation code * (in which case the following two lines are needed). Instead * we make 0-slot instances non-light, so that the light case * can be handled without special cases. @@ -581,19 +757,18 @@ SCM_DEFINE (scm_sys_inherit_magic_x, "%inherit-magic!", 2, 0, 0, SCM_SET_CLASS_FLAGS (class, flags); prep_hashsets (class); - + return SCM_UNSPECIFIED; } #undef FUNC_NAME -void +static void prep_hashsets (SCM class) { - int i; + unsigned int i; for (i = 0; i < 7; ++i) - SCM_SLOT (class, scm_si_hashsets + i) - = SCM_PACK (scm_c_uniform32 (goops_rstate)); + SCM_SET_HASHSET (class, i, scm_c_uniform32 (goops_rstate)); } /******************************************************************************/ @@ -607,33 +782,31 @@ scm_basic_basic_make_class (SCM class, SCM name, SCM dsupers, SCM dslots) z = scm_make_struct (class, SCM_INUM0, SCM_EOL); /* Initialize its slots */ -#if 0 - cpl = compute_cpl (dsupers, SCM_LIST1(z)); -#endif - SCM_SLOT (z, scm_si_direct_supers) = dsupers; + SCM_SET_SLOT (z, scm_si_direct_supers, dsupers); cpl = compute_cpl (z); slots = build_slots_list (maplist (dslots), cpl); - nfields = SCM_MAKINUM (scm_ilength (slots)); + nfields = scm_from_int (scm_ilength (slots)); g_n_s = compute_getters_n_setters (slots); - SCM_SLOT(z, scm_si_name) = name; - SCM_SLOT(z, scm_si_direct_slots) = dslots; - SCM_SLOT(z, scm_si_direct_subclasses) = SCM_EOL; - SCM_SLOT(z, scm_si_direct_methods) = SCM_EOL; - SCM_SLOT(z, scm_si_cpl) = cpl; - SCM_SLOT(z, scm_si_slots) = slots; - SCM_SLOT(z, scm_si_nfields) = nfields; - SCM_SLOT(z, scm_si_getters_n_setters) = g_n_s; - SCM_SLOT(z, scm_si_redefined) = SCM_BOOL_F; - SCM_SLOT(z, scm_si_environment) - = scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE); + SCM_SET_SLOT (z, scm_si_name, name); + SCM_SET_SLOT (z, scm_si_direct_slots, dslots); + SCM_SET_SLOT (z, scm_si_direct_subclasses, SCM_EOL); + SCM_SET_SLOT (z, scm_si_direct_methods, SCM_EOL); + SCM_SET_SLOT (z, scm_si_cpl, cpl); + SCM_SET_SLOT (z, scm_si_slots, slots); + SCM_SET_SLOT (z, scm_si_nfields, nfields); + SCM_SET_SLOT (z, scm_si_getters_n_setters, g_n_s); + SCM_SET_SLOT (z, scm_si_redefined, SCM_BOOL_F); + SCM_SET_SLOT (z, scm_si_environment, + scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE)); /* Add this class in the direct-subclasses slot of dsupers */ { SCM tmp; - for (tmp = dsupers; SCM_NNULLP(tmp); tmp = SCM_CDR(tmp)) - SCM_SLOT(SCM_CAR(tmp), scm_si_direct_subclasses) - = scm_cons(z, SCM_SLOT(SCM_CAR(tmp), scm_si_direct_subclasses)); + for (tmp = dsupers; !scm_is_null (tmp); tmp = SCM_CDR (tmp)) + SCM_SET_SLOT (SCM_CAR (tmp), scm_si_direct_subclasses, + scm_cons (z, SCM_SLOT (SCM_CAR (tmp), + scm_si_direct_subclasses))); } /* Support for the underlying structs: */ @@ -658,64 +831,66 @@ scm_basic_make_class (SCM class, SCM name, SCM dsupers, SCM dslots) /******************************************************************************/ +SCM_SYMBOL (sym_layout, "layout"); +SCM_SYMBOL (sym_vcell, "vcell"); +SCM_SYMBOL (sym_vtable, "vtable"); +SCM_SYMBOL (sym_print, "print"); +SCM_SYMBOL (sym_procedure, "procedure"); +SCM_SYMBOL (sym_setter, "setter"); +SCM_SYMBOL (sym_redefined, "redefined"); +SCM_SYMBOL (sym_h0, "h0"); +SCM_SYMBOL (sym_h1, "h1"); +SCM_SYMBOL (sym_h2, "h2"); +SCM_SYMBOL (sym_h3, "h3"); +SCM_SYMBOL (sym_h4, "h4"); +SCM_SYMBOL (sym_h5, "h5"); +SCM_SYMBOL (sym_h6, "h6"); +SCM_SYMBOL (sym_h7, "h7"); +SCM_SYMBOL (sym_name, "name"); +SCM_SYMBOL (sym_direct_supers, "direct-supers"); +SCM_SYMBOL (sym_direct_slots, "direct-slots"); +SCM_SYMBOL (sym_direct_subclasses, "direct-subclasses"); +SCM_SYMBOL (sym_direct_methods, "direct-methods"); +SCM_SYMBOL (sym_cpl, "cpl"); +SCM_SYMBOL (sym_default_slot_definition_class, "default-slot-definition-class"); +SCM_SYMBOL (sym_slots, "slots"); +SCM_SYMBOL (sym_getters_n_setters, "getters-n-setters"); +SCM_SYMBOL (sym_keyword_access, "keyword-access"); +SCM_SYMBOL (sym_nfields, "nfields"); +SCM_SYMBOL (sym_environment, "environment"); + + static SCM build_class_class_slots () { - return maplist ( - scm_cons (SCM_LIST3 (scm_str2symbol ("layout"), - k_class, - scm_class_protected_read_only), - scm_cons (SCM_LIST3 (scm_str2symbol ("vcell"), - k_class, - scm_class_opaque), - scm_cons (SCM_LIST3 (scm_str2symbol ("vtable"), - k_class, - scm_class_self), - scm_cons (scm_str2symbol ("print"), - scm_cons (SCM_LIST3 (scm_str2symbol ("procedure"), - k_class, - scm_class_protected_opaque), - scm_cons (SCM_LIST3 (scm_str2symbol ("setter"), - k_class, - scm_class_protected_opaque), - scm_cons (scm_str2symbol ("redefined"), - scm_cons (SCM_LIST3 (scm_str2symbol ("h0"), - k_class, - scm_class_int), - scm_cons (SCM_LIST3 (scm_str2symbol ("h1"), - k_class, - scm_class_int), - scm_cons (SCM_LIST3 (scm_str2symbol ("h2"), - k_class, - scm_class_int), - scm_cons (SCM_LIST3 (scm_str2symbol ("h3"), - k_class, - scm_class_int), - scm_cons (SCM_LIST3 (scm_str2symbol ("h4"), - k_class, - scm_class_int), - scm_cons (SCM_LIST3 (scm_str2symbol ("h5"), - k_class, - scm_class_int), - scm_cons (SCM_LIST3 (scm_str2symbol ("h6"), - k_class, - scm_class_int), - scm_cons (SCM_LIST3 (scm_str2symbol ("h7"), - k_class, - scm_class_int), - scm_cons (scm_str2symbol ("name"), - scm_cons (scm_str2symbol ("direct-supers"), - scm_cons (scm_str2symbol ("direct-slots"), - scm_cons (scm_str2symbol ("direct-subclasses"), - scm_cons (scm_str2symbol ("direct-methods"), - scm_cons (scm_str2symbol ("cpl"), - scm_cons (scm_str2symbol ("default-slot-definition-class"), - scm_cons (scm_str2symbol ("slots"), - scm_cons (scm_str2symbol ("getters-n-setters"), /* name-access */ - scm_cons (scm_str2symbol ("keyword-access"), - scm_cons (scm_str2symbol ("nfields"), - scm_cons (scm_str2symbol ("environment"), - SCM_EOL)))))))))))))))))))))))))))); + return scm_list_n ( + scm_list_3 (sym_layout, k_class, scm_class_protected_read_only), + scm_list_3 (sym_vtable, k_class, scm_class_self), + scm_list_1 (sym_print), + scm_list_3 (sym_procedure, k_class, scm_class_protected_opaque), + scm_list_3 (sym_setter, k_class, scm_class_protected_opaque), + scm_list_1 (sym_redefined), + scm_list_3 (sym_h0, k_class, scm_class_int), + scm_list_3 (sym_h1, k_class, scm_class_int), + scm_list_3 (sym_h2, k_class, scm_class_int), + scm_list_3 (sym_h3, k_class, scm_class_int), + scm_list_3 (sym_h4, k_class, scm_class_int), + scm_list_3 (sym_h5, k_class, scm_class_int), + scm_list_3 (sym_h6, k_class, scm_class_int), + scm_list_3 (sym_h7, k_class, scm_class_int), + scm_list_1 (sym_name), + scm_list_1 (sym_direct_supers), + scm_list_1 (sym_direct_slots), + scm_list_1 (sym_direct_subclasses), + scm_list_1 (sym_direct_methods), + scm_list_1 (sym_cpl), + scm_list_1 (sym_default_slot_definition_class), + scm_list_1 (sym_slots), + scm_list_1 (sym_getters_n_setters), + scm_list_1 (sym_keyword_access), + scm_list_1 (sym_nfields), + scm_list_1 (sym_environment), + SCM_UNDEFINED); } static void @@ -724,56 +899,56 @@ create_basic_classes (void) /* SCM slots_of_class = build_class_class_slots (); */ /**** ****/ - SCM cs = scm_makfrom0str (SCM_CLASS_CLASS_LAYOUT - + 2 * scm_vtable_offset_user); - SCM name = scm_str2symbol (""); + SCM cs = scm_from_locale_string (SCM_CLASS_CLASS_LAYOUT + + 2 * scm_vtable_offset_user); + SCM name = scm_from_locale_symbol (""); scm_class_class = scm_permanent_object (scm_make_vtable_vtable (cs, SCM_INUM0, SCM_EOL)); SCM_SET_CLASS_FLAGS (scm_class_class, (SCM_CLASSF_GOOPS_OR_VALID | SCM_CLASSF_METACLASS)); - SCM_SLOT(scm_class_class, scm_si_name) = name; - SCM_SLOT(scm_class_class, scm_si_direct_supers) = SCM_EOL; /* will be changed */ - /* SCM_SLOT(scm_class_class, scm_si_direct_slots) = slots_of_class; */ - SCM_SLOT(scm_class_class, scm_si_direct_subclasses)= SCM_EOL; - SCM_SLOT(scm_class_class, scm_si_direct_methods) = SCM_EOL; - SCM_SLOT(scm_class_class, scm_si_cpl) = SCM_EOL; /* will be changed */ - /* SCM_SLOT(scm_class_class, scm_si_slots) = slots_of_class; */ - SCM_SLOT(scm_class_class, scm_si_nfields) = SCM_MAKINUM (SCM_N_CLASS_SLOTS); - /* SCM_SLOT(scm_class_class, scm_si_getters_n_setters) - = compute_getters_n_setters (slots_of_class); */ - SCM_SLOT(scm_class_class, scm_si_redefined) = SCM_BOOL_F; - SCM_SLOT(scm_class_class, scm_si_environment) - = scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE); + SCM_SET_SLOT (scm_class_class, scm_si_name, name); + SCM_SET_SLOT (scm_class_class, scm_si_direct_supers, SCM_EOL); /* will be changed */ + /* SCM_SET_SLOT (scm_class_class, scm_si_direct_slots, slots_of_class); */ + SCM_SET_SLOT (scm_class_class, scm_si_direct_subclasses, SCM_EOL); + SCM_SET_SLOT (scm_class_class, scm_si_direct_methods, SCM_EOL); + SCM_SET_SLOT (scm_class_class, scm_si_cpl, SCM_EOL); /* will be changed */ + /* SCM_SET_SLOT (scm_class_class, scm_si_slots, slots_of_class); */ + SCM_SET_SLOT (scm_class_class, scm_si_nfields, scm_from_int (SCM_N_CLASS_SLOTS)); + /* SCM_SET_SLOT (scm_class_class, scm_si_getters_n_setters, + compute_getters_n_setters (slots_of_class)); */ + SCM_SET_SLOT (scm_class_class, scm_si_redefined, SCM_BOOL_F); + SCM_SET_SLOT (scm_class_class, scm_si_environment, + scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE)); prep_hashsets (scm_class_class); DEFVAR(name, scm_class_class); /**** ****/ - name = scm_str2symbol (""); + name = scm_from_locale_symbol (""); scm_class_top = scm_permanent_object (scm_basic_make_class (scm_class_class, name, SCM_EOL, SCM_EOL)); DEFVAR(name, scm_class_top); - + /**** ****/ - name = scm_str2symbol (""); + name = scm_from_locale_symbol (""); scm_class_object = scm_permanent_object (scm_basic_make_class (scm_class_class, name, - SCM_LIST1 (scm_class_top), + scm_list_1 (scm_class_top), SCM_EOL)); DEFVAR (name, scm_class_object); /* and were partially initialized. Correct them here */ - SCM_SLOT (scm_class_object, scm_si_direct_subclasses) = SCM_LIST1 (scm_class_class); + SCM_SET_SLOT (scm_class_object, scm_si_direct_subclasses, scm_list_1 (scm_class_class)); - SCM_SLOT (scm_class_class, scm_si_direct_supers) = SCM_LIST1 (scm_class_object); - SCM_SLOT (scm_class_class, scm_si_cpl) = SCM_LIST3 (scm_class_class, scm_class_object, scm_class_top); + SCM_SET_SLOT (scm_class_class, scm_si_direct_supers, scm_list_1 (scm_class_object)); + SCM_SET_SLOT (scm_class_class, scm_si_cpl, scm_list_3 (scm_class_class, scm_class_object, scm_class_top)); } /******************************************************************************/ @@ -783,13 +958,13 @@ SCM_DEFINE (scm_instance_p, "instance?", 1, 0, 0, "Return @code{#t} if @var{obj} is an instance.") #define FUNC_NAME s_scm_instance_p { - return SCM_BOOL (SCM_INSTANCEP (obj)); + return scm_from_bool (SCM_INSTANCEP (obj)); } #undef FUNC_NAME /****************************************************************************** - * + * * Meta object accessors * ******************************************************************************/ @@ -799,7 +974,7 @@ SCM_DEFINE (scm_class_name, "class-name", 1, 0, 0, #define FUNC_NAME s_scm_class_name { SCM_VALIDATE_CLASS (1, obj); - return scm_slot_ref (obj, scm_str2symbol ("name")); + return scm_slot_ref (obj, sym_name); } #undef FUNC_NAME @@ -809,7 +984,7 @@ SCM_DEFINE (scm_class_direct_supers, "class-direct-supers", 1, 0, 0, #define FUNC_NAME s_scm_class_direct_supers { SCM_VALIDATE_CLASS (1, obj); - return scm_slot_ref (obj, scm_str2symbol ("direct-supers")); + return scm_slot_ref (obj, sym_direct_supers); } #undef FUNC_NAME @@ -819,7 +994,7 @@ SCM_DEFINE (scm_class_direct_slots, "class-direct-slots", 1, 0, 0, #define FUNC_NAME s_scm_class_direct_slots { SCM_VALIDATE_CLASS (1, obj); - return scm_slot_ref (obj, scm_str2symbol ("direct-slots")); + return scm_slot_ref (obj, sym_direct_slots); } #undef FUNC_NAME @@ -829,7 +1004,7 @@ SCM_DEFINE (scm_class_direct_subclasses, "class-direct-subclasses", 1, 0, 0, #define FUNC_NAME s_scm_class_direct_subclasses { SCM_VALIDATE_CLASS (1, obj); - return scm_slot_ref(obj, scm_str2symbol ("direct-subclasses")); + return scm_slot_ref(obj, sym_direct_subclasses); } #undef FUNC_NAME @@ -839,7 +1014,7 @@ SCM_DEFINE (scm_class_direct_methods, "class-direct-methods", 1, 0, 0, #define FUNC_NAME s_scm_class_direct_methods { SCM_VALIDATE_CLASS (1, obj); - return scm_slot_ref (obj, scm_str2symbol ("direct-methods")); + return scm_slot_ref (obj, sym_direct_methods); } #undef FUNC_NAME @@ -849,7 +1024,7 @@ SCM_DEFINE (scm_class_precedence_list, "class-precedence-list", 1, 0, 0, #define FUNC_NAME s_scm_class_precedence_list { SCM_VALIDATE_CLASS (1, obj); - return scm_slot_ref (obj, scm_str2symbol ("cpl")); + return scm_slot_ref (obj, sym_cpl); } #undef FUNC_NAME @@ -859,7 +1034,7 @@ SCM_DEFINE (scm_class_slots, "class-slots", 1, 0, 0, #define FUNC_NAME s_scm_class_slots { SCM_VALIDATE_CLASS (1, obj); - return scm_slot_ref (obj, scm_str2symbol ("slots")); + return scm_slot_ref (obj, sym_slots); } #undef FUNC_NAME @@ -869,7 +1044,7 @@ SCM_DEFINE (scm_class_environment, "class-environment", 1, 0, 0, #define FUNC_NAME s_scm_class_environment { SCM_VALIDATE_CLASS (1, obj); - return scm_slot_ref(obj, scm_str2symbol ("environment")); + return scm_slot_ref(obj, sym_environment); } #undef FUNC_NAME @@ -884,24 +1059,61 @@ SCM_DEFINE (scm_generic_function_name, "generic-function-name", 1, 0, 0, } #undef FUNC_NAME +SCM_SYMBOL (sym_methods, "methods"); +SCM_SYMBOL (sym_extended_by, "extended-by"); +SCM_SYMBOL (sym_extends, "extends"); + +static +SCM fold_downward_gf_methods (SCM method_lists, SCM gf) +{ + SCM gfs = scm_slot_ref (gf, sym_extended_by); + method_lists = scm_cons (scm_slot_ref (gf, sym_methods), method_lists); + while (!scm_is_null (gfs)) + { + method_lists = fold_downward_gf_methods (method_lists, SCM_CAR (gfs)); + gfs = SCM_CDR (gfs); + } + return method_lists; +} + +static +SCM fold_upward_gf_methods (SCM method_lists, SCM gf) +{ + if (SCM_IS_A_P (gf, scm_class_extended_generic)) + { + SCM gfs = scm_slot_ref (gf, sym_extends); + while (!scm_is_null (gfs)) + { + SCM methods = scm_slot_ref (SCM_CAR (gfs), sym_methods); + method_lists = fold_upward_gf_methods (scm_cons (methods, + method_lists), + SCM_CAR (gfs)); + gfs = SCM_CDR (gfs); + } + } + return method_lists; +} + SCM_DEFINE (scm_generic_function_methods, "generic-function-methods", 1, 0, 0, (SCM obj), "Return the methods of the generic function @var{obj}.") #define FUNC_NAME s_scm_generic_function_methods { + SCM methods; SCM_VALIDATE_GENERIC (1, obj); - return scm_slot_ref (obj, scm_str2symbol ("methods")); + methods = fold_upward_gf_methods (SCM_EOL, obj); + methods = fold_downward_gf_methods (methods, obj); + return scm_append (methods); } #undef FUNC_NAME - SCM_DEFINE (scm_method_generic_function, "method-generic-function", 1, 0, 0, (SCM obj), - "Return the generic function fot the method @var{obj}.") + "Return the generic function for the method @var{obj}.") #define FUNC_NAME s_scm_method_generic_function { SCM_VALIDATE_METHOD (1, obj); - return scm_slot_ref (obj, scm_str2symbol ("generic-function")); + return scm_slot_ref (obj, scm_from_locale_symbol ("generic-function")); } #undef FUNC_NAME @@ -911,7 +1123,7 @@ SCM_DEFINE (scm_method_specializers, "method-specializers", 1, 0, 0, #define FUNC_NAME s_scm_method_specializers { SCM_VALIDATE_METHOD (1, obj); - return scm_slot_ref (obj, scm_str2symbol ("specializers")); + return scm_slot_ref (obj, scm_from_locale_symbol ("specializers")); } #undef FUNC_NAME @@ -921,7 +1133,7 @@ SCM_DEFINE (scm_method_procedure, "method-procedure", 1, 0, 0, #define FUNC_NAME s_scm_method_procedure { SCM_VALIDATE_METHOD (1, obj); - return scm_slot_ref (obj, scm_str2symbol ("procedure")); + return scm_slot_ref (obj, sym_procedure); } #undef FUNC_NAME @@ -931,7 +1143,7 @@ SCM_DEFINE (scm_accessor_method_slot_definition, "accessor-method-slot-definitio #define FUNC_NAME s_scm_accessor_method_slot_definition { SCM_VALIDATE_ACCESSOR (1, obj); - return scm_slot_ref (obj, scm_str2symbol ("slot-definition")); + return scm_slot_ref (obj, scm_from_locale_symbol ("slot-definition")); } #undef FUNC_NAME @@ -986,7 +1198,7 @@ SCM_DEFINE (scm_at_assert_bound_ref, "@assert-bound-ref", 2, 0, 0, "the value from @var{obj}.") #define FUNC_NAME s_scm_at_assert_bound_ref { - SCM value = SCM_SLOT (obj, SCM_INUM (index)); + SCM value = SCM_SLOT (obj, scm_to_int (index)); if (SCM_GOOPS_UNBOUNDP (value)) return CALL_GF1 ("slot-unbound", obj); return value; @@ -998,14 +1210,11 @@ SCM_DEFINE (scm_sys_fast_slot_ref, "%fast-slot-ref", 2, 0, 0, "Return the slot value with index @var{index} from @var{obj}.") #define FUNC_NAME s_scm_sys_fast_slot_ref { - register long i; + unsigned long int i; SCM_VALIDATE_INSTANCE (1, obj); - SCM_VALIDATE_INUM (2, index); - i = SCM_INUM (index); - - SCM_ASSERT_RANGE (2, index, i >= 0 && i < SCM_NUMBER_OF_SLOTS (obj)); - return scm_at_assert_bound_ref (obj, index); + i = scm_to_unsigned_integer (index, 0, SCM_NUMBER_OF_SLOTS(obj)-1); + return SCM_SLOT (obj, i); } #undef FUNC_NAME @@ -1015,19 +1224,22 @@ SCM_DEFINE (scm_sys_fast_slot_set_x, "%fast-slot-set!", 3, 0, 0, "@var{value}.") #define FUNC_NAME s_scm_sys_fast_slot_set_x { - register long i; + unsigned long int i; SCM_VALIDATE_INSTANCE (1, obj); - SCM_VALIDATE_INUM (2, index); - i = SCM_INUM (index); - SCM_ASSERT_RANGE (2, index, i >= 0 && i < SCM_NUMBER_OF_SLOTS (obj)); - SCM_SLOT (obj, i) = value; + i = scm_to_unsigned_integer (index, 0, SCM_NUMBER_OF_SLOTS(obj)-1); + + SCM_SET_SLOT (obj, i, value); return SCM_UNSPECIFIED; } #undef FUNC_NAME +SCM_SYNTAX (s_atslot_ref, "@slot-ref", scm_i_makbimacro, scm_m_atslot_ref); +SCM_SYNTAX (s_atslot_set_x, "@slot-set!", scm_i_makbimacro, scm_m_atslot_set_x); + + /** Utilities **/ /* In the future, this function will return the effective slot @@ -1040,25 +1252,28 @@ static SCM slot_definition_using_name (SCM class, SCM slot_name) { register SCM slots = SCM_SLOT (class, scm_si_getters_n_setters); - for (; SCM_NIMP (slots); slots = SCM_CDR (slots)) + for (; !scm_is_null (slots); slots = SCM_CDR (slots)) if (SCM_CAAR (slots) == slot_name) return SCM_CAR (slots); return SCM_BOOL_F; } static SCM -get_slot_value (SCM class, SCM obj, SCM slotdef) +get_slot_value (SCM class SCM_UNUSED, SCM obj, SCM slotdef) { SCM access = SCM_CDDR (slotdef); /* Two cases here: * - access is an integer (the offset of this slot in the slots vector) * - otherwise (car access) is the getter function to apply + * + * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so + * we can just assume fixnums here. */ - if (SCM_INUMP (access)) - return SCM_SLOT (obj, SCM_INUM (access)); + if (SCM_I_INUMP (access)) + return SCM_SLOT (obj, SCM_I_INUM (access)); else { - /* We must evaluate (apply (car access) (list obj)) + /* We must evaluate (apply (car access) (list obj)) * where (car access) is known to be a closure of arity 1 */ register SCM code, env; @@ -1066,10 +1281,10 @@ get_slot_value (SCM class, SCM obj, SCM slotdef) if (!SCM_CLOSUREP (code)) return SCM_SUBRF (code) (obj); env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code), - SCM_LIST1 (obj), + scm_list_1 (obj), SCM_ENV (code)); /* Evaluate the closure body */ - return scm_eval_body (SCM_CDR (SCM_CODE (code)), env); + return scm_eval_body (SCM_CLOSURE_BODY (code), env); } } @@ -1077,22 +1292,25 @@ static SCM get_slot_value_using_name (SCM class, SCM obj, SCM slot_name) { SCM slotdef = slot_definition_using_name (class, slot_name); - if (SCM_NFALSEP (slotdef)) + if (scm_is_true (slotdef)) return get_slot_value (class, obj, slotdef); else return CALL_GF3 ("slot-missing", class, obj, slot_name); } static SCM -set_slot_value (SCM class, SCM obj, SCM slotdef, SCM value) +set_slot_value (SCM class SCM_UNUSED, SCM obj, SCM slotdef, SCM value) { SCM access = SCM_CDDR (slotdef); /* Two cases here: * - access is an integer (the offset of this slot in the slots vector) * - otherwise (cadr access) is the setter function to apply + * + * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so + * we can just assume fixnums here. */ - if (SCM_INUMP (access)) - SCM_SLOT (obj, SCM_INUM (access)) = value; + if (SCM_I_INUMP (access)) + SCM_SET_SLOT (obj, SCM_I_INUM (access), value); else { /* We must evaluate (apply (cadr l) (list obj value)) @@ -1105,10 +1323,10 @@ set_slot_value (SCM class, SCM obj, SCM slotdef, SCM value) else { env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code), - SCM_LIST2 (obj, value), + scm_list_2 (obj, value), SCM_ENV (code)); /* Evaluate the closure body */ - scm_eval_body (SCM_CDR (SCM_CODE (code)), env); + scm_eval_body (SCM_CLOSURE_BODY (code), env); } } return SCM_UNSPECIFIED; @@ -1118,19 +1336,19 @@ static SCM set_slot_value_using_name (SCM class, SCM obj, SCM slot_name, SCM value) { SCM slotdef = slot_definition_using_name (class, slot_name); - if (SCM_NFALSEP (slotdef)) + if (scm_is_true (slotdef)) return set_slot_value (class, obj, slotdef, value); else return CALL_GF4 ("slot-missing", class, obj, slot_name, value); } static SCM -test_slot_existence (SCM class, SCM obj, SCM slot_name) +test_slot_existence (SCM class SCM_UNUSED, SCM obj, SCM slot_name) { register SCM l; - for (l = SCM_ACCESSORS_OF (obj); SCM_NNULLP (l); l = SCM_CDR (l)) - if (SCM_CAAR (l) == slot_name) + for (l = SCM_ACCESSORS_OF (obj); !scm_is_null (l); l = SCM_CDR (l)) + if (scm_is_eq (SCM_CAAR (l), slot_name)) return SCM_BOOL_T; return SCM_BOOL_F; @@ -1254,10 +1472,10 @@ SCM_DEFINE (scm_slot_bound_p, "slot-bound?", 2, 0, 0, } #undef FUNC_NAME -SCM_DEFINE (scm_slots_exists_p, "slot-exists?", 2, 0, 0, +SCM_DEFINE (scm_slot_exists_p, "slot-exists?", 2, 0, 0, (SCM obj, SCM slot_name), "Return @code{#t} if @var{obj} has a slot named @var{slot_name}.") -#define FUNC_NAME s_scm_slots_exists_p +#define FUNC_NAME s_scm_slot_exists_p { SCM class; @@ -1279,21 +1497,17 @@ SCM_DEFINE (scm_slots_exists_p, "slot-exists?", 2, 0, 0, static void clear_method_cache (SCM); static SCM -wrap_init (SCM class, SCM *m, int n) +wrap_init (SCM class, SCM *m, long n) { - SCM z; - int i; - + long i; + /* Set all slots to unbound */ for (i = 0; i < n; i++) m[i] = SCM_GOOPS_UNBOUND; - SCM_NEWCELL2 (z); - SCM_SETCDR (z, (SCM) m); - SCM_SET_STRUCT_GC_CHAIN (z, 0); - SCM_SETCAR (z, (scm_bits_t) SCM_STRUCT_DATA (class) | scm_tc3_cons_gloc); - - return z; + return scm_double_cell ((((scm_t_bits) SCM_STRUCT_DATA (class)) + | scm_tc3_struct), + (scm_t_bits) m, 0, 0); } SCM_DEFINE (scm_sys_allocate_instance, "%allocate-instance", 2, 0, 0, @@ -1303,30 +1517,29 @@ SCM_DEFINE (scm_sys_allocate_instance, "%allocate-instance", 2, 0, 0, #define FUNC_NAME s_scm_sys_allocate_instance { SCM *m; - int n; + long n; SCM_VALIDATE_CLASS (1, class); /* Most instances */ if (SCM_CLASS_FLAGS (class) & SCM_STRUCTF_LIGHT) { - n = SCM_INUM (SCM_SLOT (class, scm_si_nfields)); - m = (SCM *) scm_must_malloc (n * sizeof (SCM), "instance"); + n = SCM_I_INUM (SCM_SLOT (class, scm_si_nfields)); + m = (SCM *) scm_gc_malloc (n * sizeof (SCM), "struct"); return wrap_init (class, m, n); } - + /* Foreign objects */ if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_FOREIGN) return scm_make_foreign_object (class, initargs); - n = SCM_INUM (SCM_SLOT (class, scm_si_nfields)); - + n = SCM_I_INUM (SCM_SLOT (class, scm_si_nfields)); + /* Entities */ if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_ENTITY) { - m = (SCM *) scm_alloc_struct (n, - scm_struct_entity_n_extra_words, - "entity"); + m = (SCM *) scm_alloc_struct (n, scm_struct_entity_n_extra_words, + "entity struct"); m[scm_struct_i_setter] = SCM_BOOL_F; m[scm_struct_i_procedure] = SCM_BOOL_F; /* Generic functions */ @@ -1339,18 +1552,18 @@ SCM_DEFINE (scm_sys_allocate_instance, "%allocate-instance", 2, 0, 0, else return wrap_init (class, m, n); } - + /* Class objects */ if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_METACLASS) { - int i; + long i; /* allocate class object */ SCM z = scm_make_struct (class, SCM_INUM0, SCM_EOL); - SCM_SLOT (z, scm_si_print) = SCM_GOOPS_UNBOUND; + SCM_SET_SLOT (z, scm_si_print, SCM_GOOPS_UNBOUND); for (i = scm_si_goops_fields; i < n; i++) - SCM_SLOT (z, i) = SCM_GOOPS_UNBOUND; + SCM_SET_SLOT (z, i, SCM_GOOPS_UNBOUND); if (SCM_SUBCLASSP (class, scm_class_entity_class)) SCM_SET_CLASS_FLAGS (z, SCM_CLASSF_OPERATOR | SCM_CLASSF_ENTITY); @@ -1359,12 +1572,10 @@ SCM_DEFINE (scm_sys_allocate_instance, "%allocate-instance", 2, 0, 0, return z; } - + /* Non-light instances */ { - m = (SCM *) scm_alloc_struct (n, - scm_struct_n_extra_words, - "heavy instance"); + m = (SCM *) scm_alloc_struct (n, scm_struct_n_extra_words, "heavy struct"); return wrap_init (class, m, n); } } @@ -1392,7 +1603,7 @@ SCM_DEFINE (scm_sys_set_object_setter_x, "%set-object-setter!", 2, 0, 0, /****************************************************************************** * * %modify-instance (used by change-class to modify in place) - * + * ******************************************************************************/ SCM_DEFINE (scm_sys_modify_instance, "%modify-instance", 2, 0, 0, @@ -1403,11 +1614,11 @@ SCM_DEFINE (scm_sys_modify_instance, "%modify-instance", 2, 0, 0, SCM_VALIDATE_INSTANCE (1, old); SCM_VALIDATE_INSTANCE (2, new); - /* Exchange the data contained in old and new. We exchange rather than + /* Exchange the data contained in old and new. We exchange rather than * scratch the old value with new to be correct with GC. * See "Class redefinition protocol above". */ - SCM_REDEFER_INTS; + SCM_CRITICAL_SECTION_START; { SCM car = SCM_CAR (old); SCM cdr = SCM_CDR (old); @@ -1416,7 +1627,7 @@ SCM_DEFINE (scm_sys_modify_instance, "%modify-instance", 2, 0, 0, SCM_SETCAR (new, car); SCM_SETCDR (new, cdr); } - SCM_REALLOW_INTS; + SCM_CRITICAL_SECTION_END; return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -1429,18 +1640,18 @@ SCM_DEFINE (scm_sys_modify_class, "%modify-class", 2, 0, 0, SCM_VALIDATE_CLASS (1, old); SCM_VALIDATE_CLASS (2, new); - SCM_REDEFER_INTS; + SCM_CRITICAL_SECTION_START; { SCM car = SCM_CAR (old); SCM cdr = SCM_CDR (old); SCM_SETCAR (old, SCM_CAR (new)); SCM_SETCDR (old, SCM_CDR (new)); - SCM_STRUCT_DATA (old)[scm_vtable_index_vtable] = old; + SCM_STRUCT_DATA (old)[scm_vtable_index_vtable] = SCM_UNPACK (old); SCM_SETCAR (new, car); SCM_SETCDR (new, cdr); - SCM_STRUCT_DATA (new)[scm_vtable_index_vtable] = new; + SCM_STRUCT_DATA (new)[scm_vtable_index_vtable] = SCM_UNPACK (new); } - SCM_REALLOW_INTS; + SCM_CRITICAL_SECTION_END; return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -1462,19 +1673,17 @@ SCM_DEFINE (scm_sys_invalidate_class, "%invalidate-class", 1, 0, 0, * infinite recursions. */ -static SCM **hell; -static int n_hell = 1; /* one place for the evil one himself */ -static int hell_size = 4; -#ifdef USE_THREADS -static scm_mutex_t hell_mutex; -#endif +static scm_t_bits **hell; +static long n_hell = 1; /* one place for the evil one himself */ +static long hell_size = 4; +static SCM hell_mutex; -static int +static long burnin (SCM o) { - int i; + long i; for (i = 1; i < n_hell; ++i) - if (SCM_INST (o) == hell[i]) + if (SCM_STRUCT_DATA (o) == hell[i]) return i; return 0; } @@ -1482,61 +1691,61 @@ burnin (SCM o) static void go_to_hell (void *o) { - SCM obj = (SCM) o; -#ifdef USE_THREADS - scm_mutex_lock (&hell_mutex); -#endif + SCM obj = SCM_PACK ((scm_t_bits) o); + scm_lock_mutex (hell_mutex); if (n_hell == hell_size) { - int new_size = 2 * hell_size; - hell = scm_must_realloc (hell, hell_size, new_size, "hell"); + long new_size = 2 * hell_size; + hell = scm_realloc (hell, new_size); hell_size = new_size; } - hell[n_hell++] = SCM_INST (obj); -#ifdef USE_THREADS - scm_mutex_unlock (&hell_mutex); -#endif + hell[n_hell++] = SCM_STRUCT_DATA (obj); + scm_unlock_mutex (hell_mutex); } static void go_to_heaven (void *o) { -#ifdef USE_THREADS - scm_mutex_lock (&hell_mutex); -#endif - hell[burnin ((SCM) o)] = hell[--n_hell]; -#ifdef USE_THREADS - scm_mutex_unlock (&hell_mutex); -#endif + scm_lock_mutex (hell_mutex); + hell[burnin (SCM_PACK ((scm_t_bits) o))] = hell[--n_hell]; + scm_unlock_mutex (hell_mutex); } + +SCM_SYMBOL (scm_sym_change_class, "change-class"); + static SCM purgatory (void *args) { - return scm_apply (GETVAR (scm_str2symbol ("change-class")), (SCM) args, SCM_EOL); + return scm_apply_0 (GETVAR (scm_sym_change_class), + SCM_PACK ((scm_t_bits) args)); } +/* This function calls the generic function change-class for all + * instances which aren't currently undergoing class change. + */ + void -scm_change_object_class (SCM obj, SCM old_class, SCM new_class) +scm_change_object_class (SCM obj, SCM old_class SCM_UNUSED, SCM new_class) { if (!burnin (obj)) scm_internal_dynamic_wind (go_to_hell, purgatory, go_to_heaven, - (void *) SCM_LIST2 (obj, new_class), - (void *) obj); + (void *) SCM_UNPACK (scm_list_2 (obj, new_class)), + (void *) SCM_UNPACK (obj)); } /****************************************************************************** * - * GGGG FFFFF - * G F - * G GG FFF - * G G F + * GGGG FFFFF + * G F + * G GG FFF + * G G F * GGG E N E R I C F U N C T I O N S * * This implementation provides * - generic functions (with class specializers) * - multi-methods - * - next-method + * - next-method * - a hard-coded MOP for standard gf, which can be overloaded for non-std gf * ******************************************************************************/ @@ -1547,15 +1756,18 @@ SCM_SYMBOL (sym_no_method, "no-method"); static SCM list_of_no_method; -SCM_SYMBOL (scm_sym_args, "args"); +SCM_GLOBAL_SYMBOL (scm_sym_args, "args"); + SCM scm_make_method_cache (SCM gf) { - return SCM_LIST5 (SCM_IM_DISPATCH, scm_sym_args, SCM_MAKINUM (1), - scm_c_make_vector (SCM_INITIAL_MCACHE_SIZE, - list_of_no_method), - gf); + return scm_list_5 (SCM_IM_DISPATCH, + scm_sym_args, + scm_from_int (1), + scm_c_make_vector (SCM_INITIAL_MCACHE_SIZE, + list_of_no_method), + gf); } static void @@ -1563,7 +1775,7 @@ clear_method_cache (SCM gf) { SCM cache = scm_make_method_cache (gf); SCM_SET_ENTITY_PROCEDURE (gf, cache); - SCM_SLOT (gf, scm_si_used_by) = SCM_BOOL_F; + SCM_SET_SLOT (gf, scm_si_used_by, SCM_BOOL_F); } SCM_DEFINE (scm_sys_invalidate_method_cache_x, "%invalidate-method-cache!", 1, 0, 0, @@ -1574,14 +1786,14 @@ SCM_DEFINE (scm_sys_invalidate_method_cache_x, "%invalidate-method-cache!", 1, 0 SCM used_by; SCM_ASSERT (SCM_PUREGENERICP (gf), gf, SCM_ARG1, FUNC_NAME); used_by = SCM_SLOT (gf, scm_si_used_by); - if (SCM_NFALSEP (used_by)) + if (scm_is_true (used_by)) { SCM methods = SCM_SLOT (gf, scm_si_methods); - for (; SCM_CONSP (used_by); used_by = SCM_CDR (used_by)) + for (; scm_is_pair (used_by); used_by = SCM_CDR (used_by)) scm_sys_invalidate_method_cache_x (SCM_CAR (used_by)); clear_method_cache (gf); - for (; SCM_CONSP (methods); methods = SCM_CDR (methods)) - SCM_SLOT (SCM_CAR (methods), scm_si_code_table) = SCM_EOL; + for (; scm_is_pair (methods); methods = SCM_CDR (methods)) + SCM_SET_SLOT (SCM_CAR (methods), scm_si_code_table, SCM_EOL); } { SCM n = SCM_SLOT (gf, scm_si_n_specialized); @@ -1597,7 +1809,7 @@ SCM_DEFINE (scm_generic_capability_p, "generic-capability?", 1, 0, 0, "") #define FUNC_NAME s_scm_generic_capability_p { - SCM_ASSERT (SCM_NFALSEP (scm_procedure_p (proc)), + SCM_ASSERT (scm_is_true (scm_procedure_p (proc)), proc, SCM_ARG1, FUNC_NAME); return (scm_subr_p (proc) && SCM_SUBR_GENERIC (proc) ? SCM_BOOL_T @@ -1610,15 +1822,16 @@ SCM_DEFINE (scm_enable_primitive_generic_x, "enable-primitive-generic!", 0, 0, 1 "") #define FUNC_NAME s_scm_enable_primitive_generic_x { - while (SCM_NIMP (subrs)) + SCM_VALIDATE_REST_ARGUMENT (subrs); + while (!scm_is_null (subrs)) { SCM subr = SCM_CAR (subrs); SCM_ASSERT (scm_subr_p (subr) && SCM_SUBR_GENERIC (subr), subr, SCM_ARGn, FUNC_NAME); *SCM_SUBR_GENERIC (subr) - = scm_make (SCM_LIST3 (scm_class_generic, - k_name, - SCM_SNAME (subr))); + = scm_make (scm_list_3 (scm_class_generic, + k_name, + SCM_SNAME (subr))); subrs = SCM_CDR (subrs); } return SCM_UNSPECIFIED; @@ -1632,26 +1845,79 @@ SCM_DEFINE (scm_primitive_generic_generic, "primitive-generic-generic", 1, 0, 0, { if (scm_subr_p (subr) && SCM_SUBR_GENERIC (subr)) { - SCM gf = *SCM_SUBR_GENERIC (subr); - if (gf) - return gf; + if (!*SCM_SUBR_GENERIC (subr)) + scm_enable_primitive_generic_x (scm_list_1 (subr)); + return *SCM_SUBR_GENERIC (subr); } SCM_WRONG_TYPE_ARG (SCM_ARG1, subr); } #undef FUNC_NAME +typedef struct t_extension { + struct t_extension *next; + SCM extended; + SCM extension; +} t_extension; + +static t_extension *extensions = 0; + +SCM_VARIABLE (scm_var_make_extended_generic, "make-extended-generic"); + +void +scm_c_extend_primitive_generic (SCM extended, SCM extension) +{ + if (goops_loaded_p) + { + SCM gf, gext; + if (!*SCM_SUBR_GENERIC (extended)) + scm_enable_primitive_generic_x (scm_list_1 (extended)); + gf = *SCM_SUBR_GENERIC (extended); + gext = scm_call_2 (SCM_VARIABLE_REF (scm_var_make_extended_generic), + gf, + SCM_SNAME (extension)); + *SCM_SUBR_GENERIC (extension) = gext; + } + else + { + t_extension *e = scm_malloc (sizeof (t_extension)); + t_extension **loc = &extensions; + /* Make sure that extensions are placed before their own + * extensions in the extensions list. O(N^2) algorithm, but + * extensions of primitive generics are rare. + */ + while (*loc && extension != (*loc)->extended) + loc = &(*loc)->next; + e->next = *loc; + e->extended = extended; + e->extension = extension; + *loc = e; + } +} + +static void +setup_extended_primitive_generics () +{ + while (extensions) + { + t_extension *e = extensions; + scm_c_extend_primitive_generic (e->extended, e->extension); + extensions = e->next; + free (e); + } +} + /****************************************************************************** - * + * * Protocol for calling a generic fumction - * This protocol is roughly equivalent to (parameter are a little bit different + * This protocol is roughly equivalent to (parameter are a little bit different * for efficiency reasons): * * + apply-generic (gf args) * + compute-applicable-methods (gf args ...) * + sort-applicable-methods (methods args) * + apply-methods (gf methods args) - * - * apply-methods calls make-next-method to build the "continuation" of a a + * + * apply-methods calls make-next-method to build the "continuation" of a a * method. Applying a next-method will call apply-next-method which in * turn will call apply again to call effectively the following method. * @@ -1661,22 +1927,22 @@ static int applicablep (SCM actual, SCM formal) { /* We already know that the cpl is well formed. */ - return !SCM_FALSEP (scm_c_memq (formal, SCM_SLOT (actual, scm_si_cpl))); + return scm_is_true (scm_c_memq (formal, SCM_SLOT (actual, scm_si_cpl))); } static int -more_specificp (SCM m1, SCM m2, SCM *targs) +more_specificp (SCM m1, SCM m2, SCM const *targs) { register SCM s1, s2; - register int i; - /* - * Note: - * m1 and m2 can have != length (i.e. one can be one element longer than the + register long i; + /* + * 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) ....) + * (define-method M (a) ....) * * we consider that the second method is more specific. * @@ -1685,13 +1951,13 @@ more_specificp (SCM m1, SCM m2, SCM *targs) * the end of this array). * */ - for (i=0,s1=SPEC_OF(m1),s2=SPEC_OF(m2); ; i++,s1=SCM_CDR(s1),s2=SCM_CDR(s2)) { - if (SCM_NULLP(s1)) return 1; - if (SCM_NULLP(s2)) return 0; + for (i=0, s1=SPEC_OF(m1), s2=SPEC_OF(m2); ; i++, s1=SCM_CDR(s1), s2=SCM_CDR(s2)) { + if (scm_is_null(s1)) return 1; + if (scm_is_null(s2)) return 0; if (SCM_CAR(s1) != SCM_CAR(s2)) { register SCM l, cs1 = SCM_CAR(s1), cs2 = SCM_CAR(s2); - - for (l = SCM_SLOT(targs[i], scm_si_cpl); ; l = SCM_CDR(l)) { + + for (l = SCM_SLOT (targs[i], scm_si_cpl); ; l = SCM_CDR(l)) { if (cs1 == SCM_CAR(l)) return 1; if (cs2 == SCM_CAR(l)) @@ -1706,24 +1972,25 @@ more_specificp (SCM m1, SCM m2, SCM *targs) #define BUFFSIZE 32 /* big enough for most uses */ static SCM -scm_i_vector2list (SCM l, int len) +scm_i_vector2list (SCM l, long len) { - int j; + long j; SCM z = scm_c_make_vector (len, SCM_UNDEFINED); - + for (j = 0; j < len; j++, l = SCM_CDR (l)) { - SCM_VELTS (z)[j] = SCM_CAR (l); + SCM_SIMPLE_VECTOR_SET (z, j, SCM_CAR (l)); } return z; } static SCM -sort_applicable_methods (SCM method_list, int size, SCM *targs) +sort_applicable_methods (SCM method_list, long size, SCM const *targs) { - int i, j, incr; + long i, j, incr; SCM *v, vector = SCM_EOL; SCM buffer[BUFFSIZE]; SCM save = method_list; + scm_t_array_handle handle; /* For reasonably sized method_lists we can try to avoid all the * consing and reorder the list in place... @@ -1737,15 +2004,15 @@ sort_applicable_methods (SCM method_list, int size, SCM *targs) method_list = SCM_CDR (method_list); } v = buffer; - } + } else { /* Too many elements in method_list to keep everything locally */ vector = scm_i_vector2list (save, size); - v = SCM_VELTS (vector); + v = scm_vector_writable_elements (vector, &handle, NULL, NULL); } - /* Use a simple shell sort since it is generally faster than qsort on + /* 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). */ @@ -1777,59 +2044,71 @@ sort_applicable_methods (SCM method_list, int size, SCM *targs) } return save; } - /* If we are here, that's that we did it the hard way... */ + + /* If we are here, that's that we did it the hard way... */ + scm_array_handle_release (&handle); return scm_vector_to_list (vector); } SCM -scm_compute_applicable_methods (SCM gf, SCM args, int len, int find_method_p) +scm_compute_applicable_methods (SCM gf, SCM args, long len, int find_method_p) { - register int i; - int count = 0; + register long i; + long count = 0; SCM l, fl, applicable = SCM_EOL; SCM save = args; - SCM buffer[BUFFSIZE], *types, *p; - SCM tmp; - + SCM buffer[BUFFSIZE]; + SCM const *types; + SCM *p; + SCM tmp = SCM_EOL; + scm_t_array_handle handle; + /* Build the list of arguments types */ - if (len >= BUFFSIZE) { - tmp = scm_c_make_vector (len, SCM_UNDEFINED); - /* NOTE: Using pointers to malloced memory won't work if we - 1. have preemtive threading, and, - 2. have a GC which moves objects. */ - types = p = SCM_VELTS(tmp); - } + if (len >= BUFFSIZE) + { + tmp = scm_c_make_vector (len, SCM_UNDEFINED); + types = p = scm_vector_writable_elements (tmp, &handle, NULL, NULL); + + /* + note that we don't have to work to reset the generation + count. TMP is a new vector anyway, and it is found + conservatively. + */ + } else types = p = buffer; - - for ( ; SCM_NNULLP (args); args = SCM_CDR (args)) + + for ( ; !scm_is_null (args); args = SCM_CDR (args)) *p++ = scm_class_of (SCM_CAR (args)); - + /* Build a list of all applicable methods */ - for (l = SCM_SLOT (gf, scm_si_methods); SCM_NNULLP (l); l = SCM_CDR (l)) + for (l = scm_generic_function_methods (gf); !scm_is_null (l); l = SCM_CDR (l)) { fl = SPEC_OF (SCM_CAR (l)); /* Only accept accessors which match exactly in first arg. */ if (SCM_ACCESSORP (SCM_CAR (l)) - && (SCM_IMP (fl) || types[0] != SCM_CAR (fl))) + && (scm_is_null (fl) || types[0] != SCM_CAR (fl))) continue; for (i = 0; ; i++, fl = SCM_CDR (fl)) { if (SCM_INSTANCEP (fl) /* We have a dotted argument list */ - || (i >= len && SCM_NULLP (fl))) + || (i >= len && scm_is_null (fl))) { /* both list exhausted */ applicable = scm_cons (SCM_CAR (l), applicable); count += 1; break; } if (i >= len - || SCM_NULLP (fl) + || scm_is_null (fl) || !applicablep (types[i], SCM_CAR (fl))) break; } } + if (len >= BUFFSIZE) + scm_array_handle_release (&handle); + if (count == 0) { if (find_method_p) @@ -1838,6 +2117,7 @@ scm_compute_applicable_methods (SCM gf, SCM args, int len, int find_method_p) /* if we are here, it's because no-applicable-method hasn't signaled an error */ return SCM_BOOL_F; } + return (count == 1 ? applicable : sort_applicable_methods (applicable, count, types)); @@ -1853,7 +2133,7 @@ SCM scm_sys_compute_applicable_methods (SCM gf, SCM args) #define FUNC_NAME s_sys_compute_applicable_methods { - int n; + long n; SCM_VALIDATE_GENERIC (1, gf); n = scm_ilength (args); SCM_ASSERT (n >= 0, args, SCM_ARG2, FUNC_NAME); @@ -1862,91 +2142,33 @@ scm_sys_compute_applicable_methods (SCM gf, SCM args) #undef FUNC_NAME SCM_SYMBOL (sym_compute_applicable_methods, "compute-applicable-methods"); -SCM_VARIABLE_INIT (var_compute_applicable_methods, "compute-applicable-methods", scm_make_gsubr (s_sys_compute_applicable_methods, 2, 0, 0, scm_sys_compute_applicable_methods)); - -SCM_SYNTAX (s_atslot_ref, "@slot-ref", scm_makmmacro, scm_m_atslot_ref); - -SCM -scm_m_atslot_ref (SCM xorig, SCM env) -#define FUNC_NAME s_atslot_ref -{ - SCM x = SCM_CDR (xorig); - SCM_ASSYNT (scm_ilength (x) == 2, scm_s_expression, FUNC_NAME); - SCM_VALIDATE_INUM (SCM_ARG2, SCM_CADR (x)); - return scm_cons (SCM_IM_SLOT_REF, x); -} -#undef FUNC_NAME - - -SCM_SYNTAX (s_atslot_set_x, "@slot-set!", scm_makmmacro, scm_m_atslot_set_x); - -SCM -scm_m_atslot_set_x (SCM xorig, SCM env) -#define FUNC_NAME s_atslot_set_x -{ - SCM x = SCM_CDR (xorig); - SCM_ASSYNT (scm_ilength (x) == 3, scm_s_expression, FUNC_NAME); - SCM_VALIDATE_INUM (SCM_ARG2, SCM_CADR (x)); - return scm_cons (SCM_IM_SLOT_SET_X, x); -} -#undef FUNC_NAME - - -SCM_SYNTAX (s_atdispatch, "@dispatch", scm_makmmacro, scm_m_atdispatch); - -SCM_SYMBOL (sym_atdispatch, s_atdispatch); - -SCM -scm_m_atdispatch (SCM xorig, SCM env) -#define FUNC_NAME s_atdispatch -{ - SCM args, n, v, gf, x = SCM_CDR (xorig); - SCM_ASSYNT (scm_ilength (x) == 4, scm_s_expression, FUNC_NAME); - args = SCM_CAR (x); - if (!SCM_CONSP (args) && !SCM_SYMBOLP (args)) - SCM_WRONG_TYPE_ARG (SCM_ARG1, args); - x = SCM_CDR (x); - n = SCM_XEVALCAR (x, env); - SCM_VALIDATE_INUM (SCM_ARG2, n); - SCM_ASSERT_RANGE (0, n, SCM_INUM (n) >= 1); - x = SCM_CDR (x); - v = SCM_XEVALCAR (x, env); - SCM_VALIDATE_VECTOR (SCM_ARG3, v); - x = SCM_CDR (x); - gf = SCM_XEVALCAR (x, env); - SCM_VALIDATE_PUREGENERIC (SCM_ARG4, gf); - return SCM_LIST5 (SCM_IM_DISPATCH, args, n, v, gf); -} -#undef FUNC_NAME - +SCM_VARIABLE_INIT (var_compute_applicable_methods, "compute-applicable-methods", scm_c_define_gsubr (s_sys_compute_applicable_methods, 2, 0, 0, scm_sys_compute_applicable_methods)); -#ifdef USE_THREADS static void lock_cache_mutex (void *m) { - SCM mutex = (SCM) m; + SCM mutex = SCM_PACK ((scm_t_bits) m); scm_lock_mutex (mutex); } static void unlock_cache_mutex (void *m) { - SCM mutex = (SCM) m; + SCM mutex = SCM_PACK ((scm_t_bits) m); scm_unlock_mutex (mutex); } -#endif static SCM call_memoize_method (void *a) { - SCM args = (SCM) a; + SCM args = SCM_PACK ((scm_t_bits) a); SCM gf = SCM_CAR (args); SCM x = SCM_CADR (args); /* First check if another thread has inserted a method between * the cache miss and locking the mutex. */ SCM cmethod = scm_mcache_lookup_cmethod (x, SCM_CDDR (args)); - if (SCM_NIMP (cmethod)) + if (scm_is_true (cmethod)) return cmethod; /*fixme* Use scm_apply */ return CALL_GF3 ("memoize-method!", gf, SCM_CDDR (args), x); @@ -1956,15 +2178,12 @@ SCM scm_memoize_method (SCM x, SCM args) { SCM gf = SCM_CAR (scm_last_pair (x)); -#ifdef USE_THREADS - return scm_internal_dynamic_wind (lock_cache_mutex, - call_memoize_method, - unlock_cache_mutex, - (void *) scm_cons2 (gf, x, args), - (void *) SCM_SLOT (gf, scm_si_cache_mutex)); -#else - return call_memoize_method ((void *) scm_cons2 (gf, x, args)); -#endif + return scm_internal_dynamic_wind ( + lock_cache_mutex, + call_memoize_method, + unlock_cache_mutex, + (void *) SCM_UNPACK (scm_cons2 (gf, x, args)), + (void *) SCM_UNPACK (SCM_SLOT (gf, scm_si_cache_mutex))); } /****************************************************************************** @@ -1972,7 +2191,7 @@ scm_memoize_method (SCM x, SCM args) * 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 Goops will be fully booted, + * Since this code will disappear when Goops will be fully booted, * no precaution is taken to be efficient. * ******************************************************************************/ @@ -1991,7 +2210,7 @@ SCM_DEFINE (scm_make, "make", 0, 0, 1, #define FUNC_NAME s_scm_make { SCM class, z; - int len = scm_ilength (args); + long len = scm_ilength (args); if (len <= 0 || (len & 1) == 0) SCM_WRONG_NUM_ARGS (); @@ -1999,27 +2218,23 @@ SCM_DEFINE (scm_make, "make", 0, 0, 1, class = SCM_CAR(args); args = SCM_CDR(args); - if (class == scm_class_generic || class == scm_class_generic_with_setter) + if (class == scm_class_generic || class == scm_class_accessor) { -#ifdef USE_THREADS - z = scm_make_struct (class, SCM_INUM0, - SCM_LIST4 (SCM_EOL, - SCM_INUM0, - SCM_BOOL_F, - scm_make_mutex ())); -#else z = scm_make_struct (class, SCM_INUM0, - SCM_LIST3 (SCM_EOL, SCM_INUM0, SCM_BOOL_F)); -#endif + scm_list_5 (SCM_EOL, + SCM_INUM0, + SCM_BOOL_F, + scm_make_mutex (), + SCM_EOL)); scm_set_procedure_property_x (z, scm_sym_name, scm_get_keyword (k_name, args, SCM_BOOL_F)); clear_method_cache (z); - if (class == scm_class_generic_with_setter) + if (class == scm_class_accessor) { SCM setter = scm_get_keyword (k_setter, args, SCM_BOOL_F); - if (SCM_NIMP (setter)) + if (scm_is_true (setter)) scm_sys_set_object_setter_x (z, setter); } } @@ -2029,49 +2244,49 @@ SCM_DEFINE (scm_make, "make", 0, 0, 1, if (class == scm_class_method || class == scm_class_simple_method - || class == scm_class_accessor) + || class == scm_class_accessor_method) { - SCM_SLOT (z, scm_si_generic_function) = + SCM_SET_SLOT (z, scm_si_generic_function, scm_i_get_keyword (k_gf, args, len - 1, SCM_BOOL_F, - FUNC_NAME); - SCM_SLOT (z, scm_si_specializers) = + FUNC_NAME)); + SCM_SET_SLOT (z, scm_si_specializers, scm_i_get_keyword (k_specializers, args, len - 1, SCM_EOL, - FUNC_NAME); - SCM_SLOT (z, scm_si_procedure) = + FUNC_NAME)); + SCM_SET_SLOT (z, scm_si_procedure, scm_i_get_keyword (k_procedure, args, len - 1, SCM_EOL, - FUNC_NAME); - SCM_SLOT (z, scm_si_code_table) = SCM_EOL; + FUNC_NAME)); + SCM_SET_SLOT (z, scm_si_code_table, SCM_EOL); } else { /* In all the others case, make a new class .... No instance here */ - SCM_SLOT (z, scm_si_name) = + SCM_SET_SLOT (z, scm_si_name, scm_i_get_keyword (k_name, args, len - 1, - scm_str2symbol ("???"), - FUNC_NAME); - SCM_SLOT (z, scm_si_direct_supers) = + scm_from_locale_symbol ("???"), + FUNC_NAME)); + SCM_SET_SLOT (z, scm_si_direct_supers, scm_i_get_keyword (k_dsupers, args, len - 1, SCM_EOL, - FUNC_NAME); - SCM_SLOT (z, scm_si_direct_slots) = + FUNC_NAME)); + SCM_SET_SLOT (z, scm_si_direct_slots, scm_i_get_keyword (k_slots, args, len - 1, SCM_EOL, - FUNC_NAME); + FUNC_NAME)); } } return z; @@ -2084,15 +2299,15 @@ SCM_DEFINE (scm_find_method, "find-method", 0, 0, 1, #define FUNC_NAME s_scm_find_method { SCM gf; - int len = scm_ilength (l); + long len = scm_ilength (l); if (len == 0) SCM_WRONG_NUM_ARGS (); gf = SCM_CAR(l); l = SCM_CDR(l); SCM_VALIDATE_GENERIC (1, gf); - if (SCM_NULLP (SCM_SLOT (gf, scm_si_methods))) - SCM_MISC_ERROR ("no methods for generic ~S", SCM_LIST1 (gf)); + if (scm_is_null (SCM_SLOT (gf, scm_si_methods))) + SCM_MISC_ERROR ("no methods for generic ~S", scm_list_1 (gf)); return scm_compute_applicable_methods (gf, l, len - 1, 1); } @@ -2103,43 +2318,74 @@ SCM_DEFINE (scm_sys_method_more_specific_p, "%method-more-specific?", 3, 0, 0, "") #define FUNC_NAME s_scm_sys_method_more_specific_p { - SCM l, v; - int i, len; + SCM l, v, result; + SCM *v_elts; + long i, len; + scm_t_array_handle handle; SCM_VALIDATE_METHOD (1, m1); SCM_VALIDATE_METHOD (2, m2); SCM_ASSERT ((len = scm_ilength (targs)) != -1, targs, SCM_ARG3, FUNC_NAME); - /* Verify that all the arguments of targs are classes and place them in a vector*/ + /* Verify that all the arguments of targs are classes and place them + in a vector + */ + v = scm_c_make_vector (len, SCM_EOL); + v_elts = scm_vector_writable_elements (v, &handle, NULL, NULL); - for (i=0, l=targs; SCM_NNULLP(l); i++, l=SCM_CDR(l)) { - SCM_ASSERT (SCM_CLASSP (SCM_CAR (l)), targs, SCM_ARG3, FUNC_NAME); - SCM_VELTS(v)[i] = SCM_CAR(l); - } - return more_specificp (m1, m2, SCM_VELTS(v)) ? SCM_BOOL_T: SCM_BOOL_F; + for (i = 0, l = targs; i < len && scm_is_pair (l); i++, l = SCM_CDR (l)) + { + SCM_ASSERT (SCM_CLASSP (SCM_CAR (l)), targs, SCM_ARG3, FUNC_NAME); + v_elts[i] = SCM_CAR(l); + } + result = more_specificp (m1, m2, v_elts) ? SCM_BOOL_T: SCM_BOOL_F; + + scm_array_handle_release (&handle); + + return result; } #undef FUNC_NAME - - + + /****************************************************************************** * - * Initializations + * Initializations * ******************************************************************************/ +static void +fix_cpl (SCM c, SCM before, SCM after) +{ + SCM cpl = SCM_SLOT (c, scm_si_cpl); + SCM ls = scm_c_memq (after, cpl); + SCM tail = scm_delq1_x (before, SCM_CDR (ls)); + if (scm_is_false (ls)) + /* if this condition occurs, fix_cpl should not be applied this way */ + abort (); + SCM_SETCAR (ls, before); + SCM_SETCDR (ls, scm_cons (after, tail)); + { + SCM dslots = SCM_SLOT (c, scm_si_direct_slots); + SCM slots = build_slots_list (maplist (dslots), cpl); + SCM g_n_s = compute_getters_n_setters (slots); + SCM_SET_SLOT (c, scm_si_slots, slots); + SCM_SET_SLOT (c, scm_si_getters_n_setters, g_n_s); + } +} + static void make_stdcls (SCM *var, char *name, SCM meta, SCM super, SCM slots) { - SCM tmp = scm_str2symbol (name); - + SCM tmp = scm_from_locale_symbol (name); + *var = scm_permanent_object (scm_basic_make_class (meta, tmp, - SCM_CONSP (super) + scm_is_pair (super) ? super - : SCM_LIST1 (super), + : scm_list_1 (super), slots)); DEFVAR(tmp, *var); } @@ -2151,31 +2397,34 @@ static void create_standard_classes (void) { SCM slots; - SCM method_slots = SCM_LIST4 (scm_str2symbol ("generic-function"), - scm_str2symbol ("specializers"), - scm_str2symbol ("procedure"), - scm_str2symbol ("code-table")); - SCM amethod_slots = SCM_LIST1 (SCM_LIST3 (scm_str2symbol ("slot-definition"), - k_init_keyword, - k_slot_definition)); -#ifdef USE_THREADS - SCM mutex_slot = SCM_LIST1 (scm_str2symbol ("make-mutex")); -#else - SCM mutex_slot = SCM_BOOL_F; -#endif - SCM gf_slots = SCM_LIST4 (scm_str2symbol ("methods"), - SCM_LIST3 (scm_str2symbol ("n-specialized"), - k_init_value, - SCM_INUM0), - SCM_LIST3 (scm_str2symbol ("used-by"), - k_init_value, - SCM_BOOL_F), - SCM_LIST3 (scm_str2symbol ("cache-mutex"), - k_init_thunk, - scm_closure (SCM_LIST2 (SCM_EOL, - mutex_slot), - SCM_EOL))); - + SCM method_slots = scm_list_4 (scm_from_locale_symbol ("generic-function"), + scm_from_locale_symbol ("specializers"), + sym_procedure, + scm_from_locale_symbol ("code-table")); + SCM amethod_slots = scm_list_1 (scm_list_3 (scm_from_locale_symbol ("slot-definition"), + k_init_keyword, + k_slot_definition)); + SCM mutex_slot = scm_list_1 (scm_from_locale_symbol ("make-mutex")); + SCM mutex_closure = scm_i_eval_x (scm_list_3 (scm_sym_lambda, + SCM_EOL, + mutex_slot), + SCM_EOL); + SCM gf_slots = scm_list_5 (scm_from_locale_symbol ("methods"), + scm_list_3 (scm_from_locale_symbol ("n-specialized"), + k_init_value, + SCM_INUM0), + scm_list_3 (scm_from_locale_symbol ("used-by"), + k_init_value, + SCM_BOOL_F), + scm_list_3 (scm_from_locale_symbol ("cache-mutex"), + k_init_thunk, + mutex_closure), + scm_list_3 (scm_from_locale_symbol ("extended-by"), + k_init_value, + SCM_EOL)); + SCM egf_slots = scm_list_1 (scm_list_3 (scm_from_locale_symbol ("extends"), + k_init_value, + SCM_EOL)); /* Foreign class slot classes */ make_stdcls (&scm_class_foreign_slot, "", scm_class_class, scm_class_top, SCM_EOL); @@ -2187,15 +2436,15 @@ create_standard_classes (void) scm_class_class, scm_class_foreign_slot, SCM_EOL); make_stdcls (&scm_class_self, "", scm_class_class, - SCM_LIST2 (scm_class_foreign_slot, scm_class_read_only), + scm_class_read_only, SCM_EOL); make_stdcls (&scm_class_protected_opaque, "", scm_class_class, - SCM_LIST2 (scm_class_protected, scm_class_opaque), + scm_list_2 (scm_class_protected, scm_class_opaque), SCM_EOL); make_stdcls (&scm_class_protected_read_only, "", scm_class_class, - SCM_LIST2 (scm_class_protected, scm_class_read_only), + scm_list_2 (scm_class_protected, scm_class_read_only), SCM_EOL); make_stdcls (&scm_class_scm, "", scm_class_class, scm_class_protected, SCM_EOL); @@ -2207,21 +2456,21 @@ create_standard_classes (void) scm_class_class, scm_class_foreign_slot, SCM_EOL); /* Continue initialization of class */ - + slots = build_class_class_slots (); - SCM_SLOT (scm_class_class, scm_si_direct_slots) = slots; - SCM_SLOT (scm_class_class, scm_si_slots) = slots; - SCM_SLOT (scm_class_class, scm_si_getters_n_setters) - = compute_getters_n_setters (slots); - + SCM_SET_SLOT (scm_class_class, scm_si_direct_slots, slots); + SCM_SET_SLOT (scm_class_class, scm_si_slots, slots); + SCM_SET_SLOT (scm_class_class, scm_si_getters_n_setters, + compute_getters_n_setters (slots)); + make_stdcls (&scm_class_foreign_class, "", scm_class_class, scm_class_class, - SCM_LIST2 (SCM_LIST3 (scm_str2symbol ("constructor"), - k_class, - scm_class_opaque), - SCM_LIST3 (scm_str2symbol ("destructor"), - k_class, - scm_class_opaque))); + scm_list_2 (scm_list_3 (scm_from_locale_symbol ("constructor"), + k_class, + scm_class_opaque), + scm_list_3 (scm_from_locale_symbol ("destructor"), + k_class, + scm_class_opaque))); make_stdcls (&scm_class_foreign_object, "", scm_class_foreign_class, scm_class_object, SCM_EOL); SCM_SET_CLASS_FLAGS (scm_class_foreign_object, SCM_CLASSF_FOREIGN); @@ -2241,30 +2490,47 @@ create_standard_classes (void) make_stdcls (&scm_class_simple_method, "", scm_class_class, scm_class_method, SCM_EOL); SCM_SET_CLASS_FLAGS (scm_class_simple_method, SCM_CLASSF_SIMPLE_METHOD); - make_stdcls (&scm_class_accessor, "", + make_stdcls (&scm_class_accessor_method, "", scm_class_class, scm_class_simple_method, amethod_slots); - SCM_SET_CLASS_FLAGS (scm_class_accessor, SCM_CLASSF_ACCESSOR_METHOD); + SCM_SET_CLASS_FLAGS (scm_class_accessor_method, SCM_CLASSF_ACCESSOR_METHOD); + make_stdcls (&scm_class_applicable, "", + scm_class_class, scm_class_top, SCM_EOL); make_stdcls (&scm_class_entity, "", - scm_class_entity_class, scm_class_object, SCM_EOL); + scm_class_entity_class, + scm_list_2 (scm_class_object, scm_class_applicable), + SCM_EOL); make_stdcls (&scm_class_entity_with_setter, "", scm_class_entity_class, scm_class_entity, SCM_EOL); make_stdcls (&scm_class_generic, "", scm_class_entity_class, scm_class_entity, gf_slots); SCM_SET_CLASS_FLAGS (scm_class_generic, SCM_CLASSF_PURE_GENERIC); + make_stdcls (&scm_class_extended_generic, "", + scm_class_entity_class, scm_class_generic, egf_slots); + SCM_SET_CLASS_FLAGS (scm_class_extended_generic, SCM_CLASSF_PURE_GENERIC); make_stdcls (&scm_class_generic_with_setter, "", scm_class_entity_class, - SCM_LIST2 (scm_class_generic, scm_class_entity_with_setter), + scm_list_2 (scm_class_generic, scm_class_entity_with_setter), SCM_EOL); -#if 0 - /* Patch cpl since compute_cpl doesn't support multiple inheritance. */ - SCM_SLOT (scm_class_generic_with_setter, scm_si_cpl) = - scm_append (SCM_LIST3 (SCM_LIST2 (scm_class_generic_with_setter, - scm_class_generic), - SCM_SLOT (scm_class_entity_with_setter, - scm_si_cpl), - SCM_EOL)); -#endif SCM_SET_CLASS_FLAGS (scm_class_generic_with_setter, SCM_CLASSF_PURE_GENERIC); + make_stdcls (&scm_class_accessor, "", + scm_class_entity_class, scm_class_generic_with_setter, SCM_EOL); + SCM_SET_CLASS_FLAGS (scm_class_accessor, SCM_CLASSF_PURE_GENERIC); + make_stdcls (&scm_class_extended_generic_with_setter, + "", + scm_class_entity_class, + scm_list_2 (scm_class_generic_with_setter, + scm_class_extended_generic), + SCM_EOL); + SCM_SET_CLASS_FLAGS (scm_class_extended_generic_with_setter, + SCM_CLASSF_PURE_GENERIC); + make_stdcls (&scm_class_extended_accessor, "", + scm_class_entity_class, + scm_list_2 (scm_class_accessor, + scm_class_extended_generic_with_setter), + SCM_EOL); + fix_cpl (scm_class_extended_accessor, + scm_class_extended_generic, scm_class_generic); + SCM_SET_CLASS_FLAGS (scm_class_extended_accessor, SCM_CLASSF_PURE_GENERIC); /* Primitive types classes */ make_stdcls (&scm_class_boolean, "", @@ -2291,12 +2557,14 @@ create_standard_classes (void) scm_class_class, scm_class_complex, SCM_EOL); make_stdcls (&scm_class_integer, "", scm_class_class, scm_class_real, SCM_EOL); + make_stdcls (&scm_class_fraction, "", + scm_class_class, scm_class_real, SCM_EOL); make_stdcls (&scm_class_keyword, "", scm_class_class, scm_class_top, SCM_EOL); make_stdcls (&scm_class_unknown, "", scm_class_class, scm_class_top, SCM_EOL); make_stdcls (&scm_class_procedure, "", - scm_class_procedure_class, scm_class_top, SCM_EOL); + scm_class_procedure_class, scm_class_applicable, SCM_EOL); make_stdcls (&scm_class_procedure_with_setter, "", scm_class_procedure_class, scm_class_procedure, SCM_EOL); make_stdcls (&scm_class_primitive_generic, "", @@ -2309,7 +2577,7 @@ create_standard_classes (void) scm_class_class, scm_class_port, SCM_EOL); make_stdcls (&scm_class_input_output_port, "", scm_class_class, - SCM_LIST2 (scm_class_input_port, scm_class_output_port), + scm_list_2 (scm_class_input_port, scm_class_output_port), SCM_EOL); } @@ -2320,90 +2588,129 @@ create_standard_classes (void) **********************************************************************/ static SCM -make_class_from_template (char *template, char *type_name, SCM supers) +make_class_from_template (char const *template, char const *type_name, SCM supers, int applicablep) { SCM class, name; if (type_name) { char buffer[100]; sprintf (buffer, template, type_name); - name = scm_str2symbol (buffer); + name = scm_from_locale_symbol (buffer); } else name = SCM_GOOPS_UNBOUND; - class = scm_permanent_object (scm_basic_make_class (scm_class_class, + class = scm_permanent_object (scm_basic_make_class (applicablep + ? scm_class_procedure_class + : scm_class_class, name, supers, SCM_EOL)); /* Only define name if doesn't already exist. */ if (!SCM_GOOPS_UNBOUNDP (name) - && SCM_FALSEP (scm_apply (scm_goops_lookup_closure, - SCM_LIST2 (name, SCM_BOOL_F), - SCM_EOL))) + && scm_is_false (scm_call_2 (scm_goops_lookup_closure, name, SCM_BOOL_F))) DEFVAR (name, class); return class; } SCM -scm_make_extended_class (char *type_name) +scm_make_extended_class (char const *type_name, int applicablep) { return make_class_from_template ("<%s>", type_name, - SCM_LIST1 (scm_class_top)); + scm_list_1 (applicablep + ? scm_class_applicable + : scm_class_top), + applicablep); +} + +void +scm_i_inherit_applicable (SCM c) +{ + if (!SCM_SUBCLASSP (c, scm_class_applicable)) + { + SCM dsupers = SCM_SLOT (c, scm_si_direct_supers); + SCM cpl = SCM_SLOT (c, scm_si_cpl); + /* patch scm_class_applicable into direct-supers */ + SCM top = scm_c_memq (scm_class_top, dsupers); + if (scm_is_false (top)) + dsupers = scm_append (scm_list_2 (dsupers, + scm_list_1 (scm_class_applicable))); + else + { + SCM_SETCAR (top, scm_class_applicable); + SCM_SETCDR (top, scm_cons (scm_class_top, SCM_CDR (top))); + } + SCM_SET_SLOT (c, scm_si_direct_supers, dsupers); + /* patch scm_class_applicable into cpl */ + top = scm_c_memq (scm_class_top, cpl); + if (scm_is_false (top)) + abort (); + else + { + SCM_SETCAR (top, scm_class_applicable); + SCM_SETCDR (top, scm_cons (scm_class_top, SCM_CDR (top))); + } + /* add class to direct-subclasses of scm_class_applicable */ + SCM_SET_SLOT (scm_class_applicable, + scm_si_direct_subclasses, + scm_cons (c, SCM_SLOT (scm_class_applicable, + scm_si_direct_subclasses))); + } } static void create_smob_classes (void) { - int i; + long i; - scm_smob_class = (SCM *) malloc (255 * sizeof (SCM)); + scm_smob_class = (SCM *) scm_malloc (255 * sizeof (SCM)); for (i = 0; i < 255; ++i) scm_smob_class[i] = 0; - scm_smob_class[SCM_TC2SMOBNUM (scm_tc16_big)] = scm_class_integer; - scm_smob_class[SCM_TC2SMOBNUM (scm_tc16_real)] = scm_class_real; - scm_smob_class[SCM_TC2SMOBNUM (scm_tc16_complex)] = scm_class_complex; scm_smob_class[SCM_TC2SMOBNUM (scm_tc16_keyword)] = scm_class_keyword; - + for (i = 0; i < scm_numsmob; ++i) if (!scm_smob_class[i]) - scm_smob_class[i] = scm_make_extended_class (SCM_SMOBNAME (i)); + scm_smob_class[i] = scm_make_extended_class (SCM_SMOBNAME (i), + scm_smobs[i].apply != 0); } void -scm_make_port_classes (int ptobnum, char *type_name) +scm_make_port_classes (long ptobnum, char *type_name) { SCM c, class = make_class_from_template ("<%s-port>", type_name, - SCM_LIST1 (scm_class_port)); + scm_list_1 (scm_class_port), + 0); scm_port_class[SCM_IN_PCLASS_INDEX + ptobnum] = make_class_from_template ("<%s-input-port>", type_name, - SCM_LIST2 (class, scm_class_input_port)); + scm_list_2 (class, scm_class_input_port), + 0); scm_port_class[SCM_OUT_PCLASS_INDEX + ptobnum] = make_class_from_template ("<%s-output-port>", type_name, - SCM_LIST2 (class, scm_class_output_port)); + scm_list_2 (class, scm_class_output_port), + 0); scm_port_class[SCM_INOUT_PCLASS_INDEX + ptobnum] = c = make_class_from_template ("<%s-input-output-port>", type_name, - SCM_LIST2 (class, - scm_class_input_output_port)); + scm_list_2 (class, scm_class_input_output_port), + 0); /* Patch cpl (since this tree is too complex for the C level compute-cpl) */ - SCM_SLOT (c, scm_si_cpl) - = scm_cons2 (c, class, SCM_SLOT (scm_class_input_output_port, scm_si_cpl)); + SCM_SET_SLOT (c, scm_si_cpl, + scm_cons2 (c, class, SCM_SLOT (scm_class_input_output_port, scm_si_cpl))); } static void create_port_classes (void) { - int i; + long i; - scm_port_class = (SCM *) malloc (3 * 256 * sizeof (SCM)); + scm_port_class = (SCM *) scm_malloc (3 * 256 * sizeof (SCM)); for (i = 0; i < 3 * 256; ++i) scm_port_class[i] = 0; @@ -2412,12 +2719,14 @@ create_port_classes (void) } static SCM -make_struct_class (void *closure, SCM key, SCM data, SCM prev) +make_struct_class (void *closure SCM_UNUSED, + SCM vtable, SCM data, SCM prev SCM_UNUSED) { - if (SCM_NFALSEP (SCM_STRUCT_TABLE_NAME (data))) + if (scm_is_true (SCM_STRUCT_TABLE_NAME (data))) SCM_SET_STRUCT_TABLE_CLASS (data, scm_make_extended_class - (SCM_SYMBOL_CHARS (SCM_STRUCT_TABLE_NAME (data)))); + (scm_i_symbol_chars (SCM_STRUCT_TABLE_NAME (data)), + SCM_CLASS_FLAGS (vtable) & SCM_CLASSF_OPERATOR)); return SCM_UNSPECIFIED; } @@ -2437,7 +2746,7 @@ void scm_load_goops () { if (!goops_loaded_p) - scm_resolve_module (scm_read_0str ("(oop goops)")); + scm_c_resolve_module ("oop goops"); } @@ -2448,7 +2757,7 @@ scm_make_foreign_object (SCM class, SCM initargs) void * (*constructor) (SCM) = (void * (*) (SCM)) SCM_SLOT (class, scm_si_constructor); if (constructor == 0) - SCM_MISC_ERROR ("Can't make instances of class ~S", SCM_LIST1 (class)); + SCM_MISC_ERROR ("Can't make instances of class ~S", scm_list_1 (class)); return scm_wrap_object (class, constructor (initargs)); } #undef FUNC_NAME @@ -2468,15 +2777,15 @@ scm_make_class (SCM meta, char *s_name, SCM supers, size_t size, size_t (*destructor) (void *)) { SCM name, class; - name = scm_str2symbol (s_name); - if (SCM_IMP (supers)) - supers = SCM_LIST1 (scm_class_foreign_object); + name = scm_from_locale_symbol (s_name); + if (scm_is_null (supers)) + supers = scm_list_1 (scm_class_foreign_object); class = scm_basic_basic_make_class (meta, name, supers, SCM_EOL); scm_sys_inherit_magic_x (class, supers); if (destructor != 0) { - SCM_SLOT (class, scm_si_destructor) = (SCM) destructor; + SCM_SET_SLOT (class, scm_si_destructor, (SCM) destructor); SCM_SET_CLASS_DESTRUCTOR (class, scm_free_foreign_object); } else if (size > 0) @@ -2484,9 +2793,9 @@ scm_make_class (SCM meta, char *s_name, SCM supers, size_t size, SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_light); SCM_SET_CLASS_INSTANCE_SIZE (class, size); } - - SCM_SLOT (class, scm_si_layout) = scm_str2symbol (""); - SCM_SLOT (class, scm_si_constructor) = (SCM) constructor; + + SCM_SET_SLOT (class, scm_si_layout, scm_from_locale_symbol ("")); + SCM_SET_SLOT (class, scm_si_constructor, (SCM) constructor); return class; } @@ -2498,7 +2807,7 @@ SCM_KEYWORD (k_accessor, "accessor"); SCM_KEYWORD (k_getter, "getter"); static SCM -default_setter (SCM obj, SCM c) +default_setter (SCM obj SCM_UNUSED, SCM c SCM_UNUSED) { scm_misc_error ("slot-set!", "read-only slot", SCM_EOL); return 0; @@ -2511,62 +2820,65 @@ scm_add_slot (SCM class, char *slot_name, SCM slot_class, char *accessor_name) { { - SCM get = scm_make_subr_opt ("goops:get", scm_tc7_subr_1, getter, 0); - SCM set = scm_make_subr_opt ("goops:set", scm_tc7_subr_2, - setter ? setter : default_setter, 0); - SCM getm = scm_closure (SCM_LIST2 (SCM_LIST1 (sym_o), - SCM_LIST2 (get, sym_o)), - SCM_EOL); - SCM setm = scm_closure (SCM_LIST2 (SCM_LIST2 (sym_o, sym_x), - SCM_LIST3 (set, sym_o, sym_x)), - SCM_EOL); + SCM get = scm_c_make_subr ("goops:get", scm_tc7_subr_1, getter); + SCM set = scm_c_make_subr ("goops:set", scm_tc7_subr_2, + setter ? setter : default_setter); + + /* Dirk:FIXME:: The following two expressions make use of the fact that + * the memoizer will accept a subr-object in the place of a function. + * This is not guaranteed to stay this way. */ + SCM getm = scm_i_eval_x (scm_list_3 (scm_sym_lambda, + scm_list_1 (sym_o), + scm_list_2 (get, sym_o)), + SCM_EOL); + SCM setm = scm_i_eval_x (scm_list_3 (scm_sym_lambda, + scm_list_2 (sym_o, sym_x), + scm_list_3 (set, sym_o, sym_x)), + SCM_EOL); + { - SCM name = scm_str2symbol (slot_name); - SCM aname = scm_str2symbol (accessor_name); + SCM name = scm_from_locale_symbol (slot_name); + SCM aname = scm_from_locale_symbol (accessor_name); SCM gf = scm_ensure_accessor (aname); - SCM slot = SCM_LIST5 (name, - k_class, slot_class, - setter ? k_accessor : k_getter, - gf); - SCM gns = SCM_LIST4 (name, SCM_BOOL_F, get, set); - - scm_add_method (gf, scm_make (SCM_LIST5 (scm_class_accessor, - k_specializers, - SCM_LIST1 (class), - k_procedure, getm))); + SCM slot = scm_list_5 (name, + k_class, + slot_class, + setter ? k_accessor : k_getter, + gf); + scm_add_method (gf, scm_make (scm_list_5 (scm_class_accessor_method, + k_specializers, + scm_list_1 (class), + k_procedure, + getm))); scm_add_method (scm_setter (gf), - scm_make (SCM_LIST5 (scm_class_accessor, - k_specializers, - SCM_LIST2 (class, - scm_class_top), - k_procedure, setm))); + scm_make (scm_list_5 (scm_class_accessor_method, + k_specializers, + scm_list_2 (class, scm_class_top), + k_procedure, + setm))); DEFVAR (aname, gf); - - SCM_SLOT (class, scm_si_slots) - = scm_append_x (SCM_LIST2 (SCM_SLOT (class, scm_si_slots), - SCM_LIST1 (slot))); - SCM_SLOT (class, scm_si_getters_n_setters) - = scm_append_x (SCM_LIST2 (SCM_SLOT (class, scm_si_getters_n_setters), - SCM_LIST1 (gns))); - } - } - { - int n = SCM_INUM (SCM_SLOT (class, scm_si_nfields)); - SCM_SLOT (class, scm_si_nfields) - = SCM_MAKINUM (n + 1); + SCM_SET_SLOT (class, scm_si_slots, + scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_slots), + scm_list_1 (slot)))); + { + SCM n = SCM_SLOT (class, scm_si_nfields); + SCM gns = scm_list_n (name, SCM_BOOL_F, get, set, n, scm_from_int (1)); + SCM_SET_SLOT (class, scm_si_getters_n_setters, + scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_getters_n_setters), + scm_list_1 (gns)))); + SCM_SET_SLOT (class, scm_si_nfields, scm_sum (n, scm_from_int (1))); + } + } } } SCM scm_wrap_object (SCM class, void *data) { - SCM z; - SCM_NEWCELL2 (z); - SCM_SETCDR (z, (SCM) data); - SCM_SET_STRUCT_GC_CHAIN (z, 0); - SCM_SETCAR (z, SCM_UNPACK (SCM_CDR (class)) | scm_tc3_cons_gloc); - return z; + return scm_double_cell (SCM_UNPACK (SCM_CDR (class)) | scm_tc3_struct, + (scm_t_bits) data, + 0, 0); } SCM scm_components; @@ -2588,15 +2900,12 @@ scm_wrap_component (SCM class, SCM container, void *data) SCM scm_ensure_accessor (SCM name) { - SCM gf = scm_apply (SCM_TOP_LEVEL_LOOKUP_CLOSURE, - SCM_LIST2 (name, SCM_BOOL_F), - SCM_EOL); - if (!SCM_IS_A_P (gf, scm_class_generic_with_setter)) + SCM gf = scm_call_2 (SCM_TOP_LEVEL_LOOKUP_CLOSURE, name, SCM_BOOL_F); + if (!SCM_IS_A_P (gf, scm_class_accessor)) { - gf = scm_make (SCM_LIST3 (scm_class_generic, k_name, name)); - gf = scm_make (SCM_LIST5 (scm_class_generic_with_setter, - k_name, name, - k_setter, gf)); + gf = scm_make (scm_list_3 (scm_class_generic, k_name, name)); + gf = scm_make (scm_list_5 (scm_class_accessor, + k_name, name, k_setter, gf)); } return gf; } @@ -2606,7 +2915,7 @@ SCM_SYMBOL (sym_internal_add_method_x, "internal-add-method!"); void scm_add_method (SCM gf, SCM m) { - scm_eval (SCM_LIST3 (sym_internal_add_method_x, gf, m), scm_module_goops); + scm_eval (scm_list_3 (sym_internal_add_method_x, gf, m), scm_module_goops); } #ifdef GUILE_DEBUG @@ -2619,7 +2928,7 @@ SCM_DEFINE (scm_pure_generic_p, "pure-generic?", 1, 0, 0, "Return @code{#t} if @var{obj} is a pure generic.") #define FUNC_NAME s_scm_pure_generic_p { - return SCM_BOOL (SCM_PUREGENERICP (obj)); + return scm_from_bool (SCM_PUREGENERICP (obj)); } #undef FUNC_NAME @@ -2639,41 +2948,35 @@ SCM_DEFINE (scm_sys_goops_loaded, "%goops-loaded", 0, 0, 0, var_compute_applicable_methods = scm_sym2var (sym_compute_applicable_methods, scm_goops_lookup_closure, SCM_BOOL_F); + setup_extended_primitive_generics (); return SCM_UNSPECIFIED; } #undef FUNC_NAME SCM scm_module_goops; -void -scm_init_goops (void) +SCM +scm_init_goops_builtins (void) { - SCM old_module; - scm_module_goops = scm_make_module (scm_read_0str ("(oop goops)")); - old_module = scm_set_current_module (scm_module_goops); - + scm_module_goops = scm_current_module (); scm_goops_lookup_closure = scm_module_lookup_closure (scm_module_goops); - /* Not really necessary right now, but who knows... + /* Not really necessary right now, but who knows... */ scm_permanent_object (scm_module_goops); scm_permanent_object (scm_goops_lookup_closure); scm_components = scm_permanent_object (scm_make_weak_key_hash_table - (SCM_MAKINUM (37))); + (scm_from_int (37))); goops_rstate = scm_c_make_rstate ("GOOPS", 5); -#ifndef SCM_MAGIC_SNARFER #include "libguile/goops.x" -#endif - list_of_no_method = scm_permanent_object (SCM_LIST1 (sym_no_method)); + list_of_no_method = scm_permanent_object (scm_list_1 (sym_no_method)); - hell = scm_must_malloc (hell_size, "hell"); -#ifdef USE_THREADS - scm_mutex_init (&hell_mutex); -#endif + hell = scm_malloc (hell_size); + hell_mutex = scm_permanent_object (scm_make_mutex ()); create_basic_classes (); create_standard_classes (); @@ -2682,21 +2985,22 @@ scm_init_goops (void) create_port_classes (); { - SCM name = scm_str2symbol ("no-applicable-method"); + SCM name = scm_from_locale_symbol ("no-applicable-method"); scm_no_applicable_method - = scm_permanent_object (scm_make (SCM_LIST3 (scm_class_generic, - k_name, - name))); + = scm_permanent_object (scm_make (scm_list_3 (scm_class_generic, + k_name, + name))); DEFVAR (name, scm_no_applicable_method); } - - scm_set_current_module (old_module); + + return SCM_UNSPECIFIED; } void -scm_init_oop_goops_goopscore_module () +scm_init_goops () { - scm_register_module_xxx ("oop goops goopscore", (void *) scm_init_goops); + scm_c_define_gsubr ("%init-goops-builtins", 0, 0, 0, + scm_init_goops_builtins); } /*