-/* Copyright (C) 1998,1999,2000,2001, 2002, 2003 Free Software Foundation, Inc.
+/* Copyright (C) 1998,1999,2000,2001,2002,2003,2004,2008
+ * 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 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 program is distributed in the hope that it will be useful,
+ * 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 General Public License for more details.
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
*
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice. */
+ * 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
\f
/* This software is a derivative work of other copyrighted softwares; the
* Erick Gallesio <eg@unice.fr>.
*/
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
#include <stdio.h>
+#include <assert.h>
#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"
#define SPEC_OF(x) SCM_SLOT (x, scm_si_specializers)
-#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_call_2 (scm_goops_lookup_closure, \
- (v), SCM_BOOL_F)))
-
-/* Fixme: Should use already interned symbols */
-#define CALL_GF1(name, a) (scm_call_1 (GETVAR (scm_str2symbol (name)), \
- a))
-#define CALL_GF2(name, a, b) (scm_call_2 (GETVAR (scm_str2symbol (name)), \
- a, b))
-#define CALL_GF3(name, a, b, c) (scm_call_3 (GETVAR (scm_str2symbol (name)), \
- a, b, c))
-#define CALL_GF4(name, a, b, c, d) (scm_call_4 (GETVAR (scm_str2symbol (name)), \
- a, b, c, d))
+/* this file is a mess. in theory, though, we shouldn't have many SCM references
+ -- most of the references should be to vars. */
+
+static SCM var_slot_unbound = SCM_BOOL_F;
+static SCM var_slot_missing = SCM_BOOL_F;
+static SCM var_compute_cpl = SCM_BOOL_F;
+static SCM var_no_applicable_method = SCM_BOOL_F;
+static SCM var_memoize_method_x = SCM_BOOL_F;
+static SCM var_change_class = SCM_BOOL_F;
+
+SCM_SYMBOL (sym_slot_unbound, "slot-unbound");
+SCM_SYMBOL (sym_slot_missing, "slot-missing");
+SCM_SYMBOL (sym_compute_cpl, "compute-cpl");
+SCM_SYMBOL (sym_no_applicable_method, "no-applicable-method");
+SCM_SYMBOL (sym_memoize_method_x, "memoize-method!");
+SCM_SYMBOL (sym_change_class, "change-class");
+
+SCM_VARIABLE (scm_var_make_extended_generic, "make-extended-generic");
+
+
+/* FIXME, exports should come from the scm file only */
+#define DEFVAR(v, val) \
+ { scm_module_define (scm_module_goops, (v), (val)); \
+ scm_module_export (scm_module_goops, scm_list_1 ((v))); \
+ }
+
/* Class redefinition protocol:
memory block m2 are allocated. The headers h1 and h2 then switch
pointers so that h1 refers to m2 and h2 to m1. In this way, names
bound to h1 will point to the new class at the same time as h2 will
- be a handle which the GC will us to free m1.
+ be a handle which the GC will use to free m1.
The `redefined' slot of m1 will be set to point to h1. An old
- instance will have it's class pointer (the CAR of the heap header)
+ instance will have its class pointer (the CAR of the heap header)
pointing to m1. The non-immediate `redefined'-slot in m1 indicates
the class modification and the new class pointer can be found via
h1.
#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])
static int goops_loaded_p = 0;
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 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;
+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;
SCM scm_class_scm;
SCM scm_class_int, scm_class_float, scm_class_double;
+/* Port classes. Allocate 3 times the maximum number of port types so that
+ input ports, output ports, and in/out ports can be stored at different
+ offsets. See `SCM_IN_PCLASS_INDEX' et al. */
+SCM scm_port_class[3 * SCM_I_MAX_PORT_TYPE_COUNT];
+
+/* SMOB classes. */
+SCM scm_smob_class[SCM_I_MAX_SMOB_TYPE_COUNT];
+
+SCM scm_no_applicable_method;
+
SCM_SYMBOL (scm_sym_define_public, "define-public");
static SCM scm_make_unbound (void);
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
static SCM
map (SCM (*proc) (SCM), SCM ls)
{
- if (SCM_NULLP (ls))
+ if (scm_is_null (ls))
return ls;
else
{
SCM res = scm_cons (proc (SCM_CAR (ls)), SCM_EOL);
SCM h = res;
ls = SCM_CDR (ls);
- while (!SCM_NULLP (ls))
+ while (!scm_is_null (ls))
{
SCM_SETCDR (h, scm_cons (proc (SCM_CAR (ls)), SCM_EOL));
h = SCM_CDR (h);
filter_cpl (SCM ls)
{
SCM res = SCM_EOL;
- while (!SCM_NULLP (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);
}
compute_cpl (SCM class)
{
if (goops_loaded_p)
- return CALL_GF1 ("compute-cpl", class);
+ return scm_call_1 (SCM_VARIABLE_REF (var_compute_cpl), class);
else
{
SCM supers = SCM_SLOT (class, scm_si_direct_supers);
{
SCM tmp;
- if (SCM_NULLP (l))
+ if (scm_is_null (l))
return res;
tmp = SCM_CAAR (l);
- if (!SCM_SYMBOLP (tmp))
+ if (!scm_is_symbol (tmp))
scm_misc_error ("%compute-slots", "bad slot name ~S", scm_list_1 (tmp));
- if (SCM_FALSEP (scm_c_memq (tmp, slots_already_seen))) {
+ 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);
}
{
register SCM res = dslots;
- for (cpl = SCM_CDR (cpl); !SCM_NULLP (cpl); cpl = SCM_CDR (cpl))
+ 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));
maplist (SCM ls)
{
SCM orig = ls;
- while (!SCM_NULLP (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);
}
SCM *cdrloc = &res;
long i = 0;
- for ( ; !SCM_NULLP (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_NULLP (options))
+ if (!scm_is_null (options))
{
init = scm_get_keyword (k_init_value, options, 0);
if (init)
- init = scm_closure (scm_list_2 (SCM_EOL,
- scm_list_2 (scm_sym_quote, 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);
}
{
SCM obj = SCM_CAR (l);
- if (!SCM_KEYWORDP (obj))
+ if (!scm_is_keyword (obj))
scm_misc_error (subr, "bad keyword: ~S", scm_list_1 (obj));
- else if (SCM_EQ_P (obj, key))
+ else if (scm_is_eq (obj, key))
return SCM_CADR (l);
else
l = SCM_CDDR (l);
{
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_list_1 (l));
/* See for each slot how it must be initialized */
for (;
- !SCM_NULLP (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_NULLP (SCM_CDR (slot_name)))
+ if (!scm_is_null (SCM_CDR (slot_name)))
{
/* This slot admits (perhaps) to be initialized at creation time */
long n = scm_ilength (SCM_CDR (slot_name));
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_list_1 (tmp));
slot_value = scm_i_get_keyword (tmp,
{
/* 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))
- {
- SCM env = SCM_EXTEND_ENV (SCM_EOL, SCM_EOL, SCM_ENV (tmp));
- set_slot_value (class,
- obj,
- SCM_CAR (get_n_set),
- scm_eval_body (SCM_CLOSURE_BODY (tmp), env));
- }
+ set_slot_value (class,
+ obj,
+ SCM_CAR (get_n_set),
+ scm_call_0 (tmp));
}
}
}
}
#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");
"")
#define FUNC_NAME s_scm_sys_prep_layout_x
{
- SCM slots, nfields;
+ 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_list_1 (nfields));
- n = 2 * SCM_INUM (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_list_1 (nfields));
- s = n > 0 ? scm_malloc (n) : 0;
- for (i = 0; i < n; i += 2)
+ layout = scm_i_make_string (n, &s);
+ i = 0;
+ while (scm_is_pair (getters_n_setters))
{
- long len;
- SCM type, allocation;
- char p, a;
-
- if (!SCM_CONSP (slots))
- SCM_MISC_ERROR ("too few slot definitions", SCM_EOL);
- len = scm_ilength (SCM_CDAR (slots));
- allocation = scm_i_get_keyword (k_allocation, SCM_CDAR (slots),
- len, k_instance, FUNC_NAME);
- while (!SCM_EQ_P (allocation, k_instance))
+ if (SCM_GNS_INSTANCE_ALLOCATED_P (SCM_CAR (getters_n_setters)))
{
- slots = SCM_CDR (slots);
+ SCM type;
+ int len, index, size;
+ char p, a;
+
+ if (i >= n || !scm_is_pair (slots))
+ goto inconsistent;
+
+ /* extract slot type */
len = scm_ilength (SCM_CDAR (slots));
- allocation = scm_i_get_keyword (k_allocation, SCM_CDAR (slots),
- len, k_instance, FUNC_NAME);
- }
- type = scm_i_get_keyword (k_class, SCM_CDAR (slots),
- len, SCM_BOOL_F, FUNC_NAME);
- if (SCM_FALSEP (type))
- {
- p = 'p';
- a = 'w';
- }
- else
- {
- if (!SCM_CLASSP (type))
- SCM_MISC_ERROR ("bad slot class", SCM_EOL);
- else if (SCM_SUBCLASSP (type, scm_class_foreign_slot))
+ 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))
{
- 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';
+ p = 'p';
+ 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);
}
- SCM_SET_SLOT (class, scm_si_layout, scm_mem2symbol (s, n));
- if (s)
- free (s);
+ if (!scm_is_null (slots))
+ {
+ inconsistent:
+ SCM_MISC_ERROR ("inconsistent getters-n-setters", SCM_EOL);
+ }
+ SCM_SET_SLOT (class, scm_si_layout, scm_string_to_symbol (layout));
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM ls = dsupers;
long flags = 0;
SCM_VALIDATE_INSTANCE (1, class);
- while (!SCM_NULLP (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,
SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_entity);
else
{
- long 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_gc_malloc in the allocation code
}
#undef FUNC_NAME
-void
+static void
prep_hashsets (SCM class)
{
unsigned int i;
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_SET_SLOT (z, scm_si_name, name);
/* Add this class in the direct-subclasses slot of dsupers */
{
SCM tmp;
- for (tmp = dsupers; !SCM_NULLP (tmp); tmp = SCM_CDR (tmp))
+ 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)));
/* SCM slots_of_class = build_class_class_slots (); */
/**** <scm_class_class> ****/
- SCM cs = scm_makfrom0str (SCM_CLASS_CLASS_LAYOUT
- + 2 * scm_vtable_offset_user);
- SCM name = scm_str2symbol ("<class>");
+ SCM cs = scm_from_locale_string (SCM_CLASS_CLASS_LAYOUT
+ + 2 * scm_vtable_offset_user);
+ SCM name = scm_from_locale_symbol ("<class>");
scm_class_class = scm_permanent_object (scm_make_vtable_vtable (cs,
SCM_INUM0,
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_MAKINUM (SCM_N_CLASS_SLOTS));
+ 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);
DEFVAR(name, scm_class_class);
/**** <scm_class_top> ****/
- name = scm_str2symbol ("<top>");
+ name = scm_from_locale_symbol ("<top>");
scm_class_top = scm_permanent_object (scm_basic_make_class (scm_class_class,
name,
SCM_EOL,
DEFVAR(name, scm_class_top);
/**** <scm_class_object> ****/
- name = scm_str2symbol ("<object>");
+ name = scm_from_locale_symbol ("<object>");
scm_class_object = scm_permanent_object (scm_basic_make_class (scm_class_class,
name,
scm_list_1 (scm_class_top),
"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
{
SCM gfs = scm_slot_ref (gf, sym_extended_by);
method_lists = scm_cons (scm_slot_ref (gf, sym_methods), method_lists);
- while (!SCM_NULLP (gfs))
+ while (!scm_is_null (gfs))
{
method_lists = fold_downward_gf_methods (method_lists, SCM_CAR (gfs));
gfs = SCM_CDR (gfs);
if (SCM_IS_A_P (gf, scm_class_extended_generic))
{
SCM gfs = scm_slot_ref (gf, sym_extends);
- while (!SCM_NULLP (gfs))
+ while (!scm_is_null (gfs))
{
SCM methods = scm_slot_ref (SCM_CAR (gfs), sym_methods);
method_lists = fold_upward_gf_methods (scm_cons (methods,
#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
#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
#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
#define FUNC_NAME s_scm_assert_bound
{
if (SCM_GOOPS_UNBOUNDP (value))
- return CALL_GF1 ("slot-unbound", obj);
+ return scm_call_1 (SCM_VARIABLE_REF (var_slot_unbound), obj);
return value;
}
#undef FUNC_NAME
"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 scm_call_1 (SCM_VARIABLE_REF (var_slot_unbound), obj);
return value;
}
#undef FUNC_NAME
unsigned long int i;
SCM_VALIDATE_INSTANCE (1, obj);
- SCM_VALIDATE_INUM (2, index);
- SCM_ASSERT_RANGE (2, index, SCM_INUM (index) >= 0);
- i = SCM_INUM (index);
- SCM_ASSERT_RANGE (2, index, i < SCM_NUMBER_OF_SLOTS (obj));
-
- return scm_at_assert_bound_ref (obj, index);
+ i = scm_to_unsigned_integer (index, 0,
+ SCM_I_INUM (SCM_SLOT (SCM_CLASS_OF (obj),
+ scm_si_nfields))
+ - 1);
+ return SCM_SLOT (obj, i);
}
#undef FUNC_NAME
unsigned long int i;
SCM_VALIDATE_INSTANCE (1, obj);
- SCM_VALIDATE_INUM (2, index);
- SCM_ASSERT_RANGE (2, index, SCM_INUM (index) >= 0);
- i = SCM_INUM (index);
- SCM_ASSERT_RANGE (2, index, i < SCM_NUMBER_OF_SLOTS (obj));
+ i = scm_to_unsigned_integer (index, 0,
+ SCM_I_INUM (SCM_SLOT (SCM_CLASS_OF (obj),
+ scm_si_nfields))
+ - 1);
SCM_SET_SLOT (obj, i, value);
#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
slot_definition_using_name (SCM class, SCM slot_name)
{
register SCM slots = SCM_SLOT (class, scm_si_getters_n_setters);
- for (; !SCM_NULLP (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_UNUSED, SCM obj, SCM slotdef)
+#define FUNC_NAME "%get-slot-value"
{
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))
+ /* Don't poke at the slots directly, because scm_struct_ref handles the
+ access bits for us. */
+ return scm_struct_ref (obj, access);
else
{
/* We must evaluate (apply (car access) (list obj))
code = SCM_CAR (access);
if (!SCM_CLOSUREP (code))
- return SCM_SUBRF (code) (obj);
+ return scm_call_1 (code, obj);
env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code),
scm_list_1 (obj),
SCM_ENV (code));
return scm_eval_body (SCM_CLOSURE_BODY (code), env);
}
}
+#undef FUNC_NAME
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_FALSEP (slotdef))
+ if (scm_is_true (slotdef))
return get_slot_value (class, obj, slotdef);
else
- return CALL_GF3 ("slot-missing", class, obj, slot_name);
+ return scm_call_3 (SCM_VARIABLE_REF (var_slot_missing), class, obj, slot_name);
}
static SCM
set_slot_value (SCM class SCM_UNUSED, SCM obj, SCM slotdef, SCM value)
+#define FUNC_NAME "%set-slot-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_SET_SLOT (obj, SCM_INUM (access), value);
+ if (SCM_I_INUMP (access))
+ /* obey permissions bits via going through struct-set! */
+ scm_struct_set_x (obj, access, value);
else
{
/* We must evaluate (apply (cadr l) (list obj value))
code = SCM_CADR (access);
if (!SCM_CLOSUREP (code))
- SCM_SUBRF (code) (obj, value);
+ scm_call_2 (code, obj, value);
else
{
env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code),
}
return SCM_UNSPECIFIED;
}
+#undef FUNC_NAME
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_FALSEP (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);
+ return scm_call_4 (SCM_VARIABLE_REF (var_slot_missing), class, obj, slot_name, value);
}
static SCM
{
register SCM l;
- for (l = SCM_ACCESSORS_OF (obj); !SCM_NULLP (l); l = SCM_CDR (l))
- if (SCM_EQ_P (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;
res = get_slot_value_using_name (class, obj, slot_name);
if (SCM_GOOPS_UNBOUNDP (res))
- return CALL_GF3 ("slot-unbound", class, obj, slot_name);
+ return scm_call_3 (SCM_VARIABLE_REF (var_slot_unbound), class, obj, slot_name);
return res;
}
#undef FUNC_NAME
res = get_slot_value_using_name (class, obj, slot_name);
if (SCM_GOOPS_UNBOUNDP (res))
- return CALL_GF3 ("slot-unbound", class, obj, slot_name);
+ return scm_call_3 (SCM_VARIABLE_REF (var_slot_unbound), class, obj, slot_name);
return res;
}
#undef FUNC_NAME
wrap_init (SCM class, SCM *m, long n)
{
long i;
+ scm_t_bits slayout = SCM_STRUCT_DATA (class)[scm_vtable_index_layout];
+ const char *layout = scm_i_symbol_chars (SCM_PACK (slayout));
- /* Set all slots to unbound */
+ /* Set all SCM-holding slots to unbound */
for (i = 0; i < n; i++)
- m[i] = SCM_GOOPS_UNBOUND;
+ if (layout[i*2] == 'p')
+ m[i] = SCM_GOOPS_UNBOUND;
+ else
+ m[i] = 0;
return scm_double_cell ((((scm_t_bits) SCM_STRUCT_DATA (class))
| scm_tc3_struct),
/* Most instances */
if (SCM_CLASS_FLAGS (class) & SCM_STRUCTF_LIGHT)
{
- n = SCM_INUM (SCM_SLOT (class, scm_si_nfields));
+ 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);
}
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)
* 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);
SCM_SETCAR (new, car);
SCM_SETCDR (new, cdr);
}
- SCM_REALLOW_INTS;
+ SCM_CRITICAL_SECTION_END;
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
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_SETCDR (new, cdr);
SCM_STRUCT_DATA (new)[scm_vtable_index_vtable] = SCM_UNPACK (new);
}
- SCM_REALLOW_INTS;
+ SCM_CRITICAL_SECTION_END;
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
{
SCM obj = SCM_PACK ((scm_t_bits) o);
scm_lock_mutex (hell_mutex);
- if (n_hell == hell_size)
+ if (n_hell >= hell_size)
{
- long new_size = 2 * hell_size;
- hell = scm_realloc (hell, new_size);
- hell_size = new_size;
+ hell_size *= 2;
+ hell = scm_realloc (hell, hell_size * sizeof(*hell));
}
hell[n_hell++] = SCM_STRUCT_DATA (obj);
scm_unlock_mutex (hell_mutex);
static SCM
purgatory (void *args)
{
- return scm_apply_0 (GETVAR (scm_sym_change_class),
+ return scm_apply_0 (SCM_VARIABLE_REF (var_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_UNUSED, SCM new_class)
{
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_list_5 (SCM_IM_DISPATCH,
scm_sym_args,
- SCM_MAKINUM (1),
+ scm_from_int (1),
scm_c_make_vector (SCM_INITIAL_MCACHE_SIZE,
list_of_no_method),
gf);
SCM used_by;
SCM_ASSERT (SCM_PUREGENERICP (gf), gf, SCM_ARG1, FUNC_NAME);
used_by = SCM_SLOT (gf, scm_si_used_by);
- if (!SCM_FALSEP (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))
+ for (; scm_is_pair (methods); methods = SCM_CDR (methods))
SCM_SET_SLOT (SCM_CAR (methods), scm_si_code_table, SCM_EOL);
}
{
"")
#define FUNC_NAME s_scm_generic_capability_p
{
- SCM_ASSERT (!SCM_FALSEP (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
#define FUNC_NAME s_scm_enable_primitive_generic_x
{
SCM_VALIDATE_REST_ARGUMENT (subrs);
- while (!SCM_NULLP (subrs))
+ while (!scm_is_null (subrs))
{
SCM subr = SCM_CAR (subrs);
SCM_ASSERT (scm_subr_p (subr) && SCM_SUBR_GENERIC (subr),
{
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_SET_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
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
*
*/
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;
+ 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);
SCM z = scm_c_make_vector (len, SCM_UNDEFINED);
for (j = 0; j < len; j++, l = SCM_CDR (l)) {
- SCM_VECTOR_SET (z, j, SCM_CAR (l));
+ SCM_SIMPLE_VECTOR_SET (z, j, SCM_CAR (l));
}
return z;
}
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...
{
/* Too many elements in method_list to keep everything locally */
vector = scm_i_vector2list (save, size);
-
- /*
- This is a new vector. Don't worry about the write barrier.
- We're not allocating elements in this routine, so this should
- pose no problem.
- */
- v = SCM_WRITABLE_VELTS (vector);
+ v = scm_vector_writable_elements (vector, &handle, NULL, NULL);
}
/* Use a simple shell sort since it is generally faster than qsort on
}
return save;
}
+
/* 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 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_WRITABLE_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_NULLP (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_generic_function_methods (gf); !SCM_NULLP (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_NULLP (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)
return SCM_BOOL_F;
- CALL_GF2 ("no-applicable-method", gf, save);
+ scm_call_2 (SCM_VARIABLE_REF (var_no_applicable_method), gf, save);
/* if we are here, it's because no-applicable-method hasn't signaled an error */
return SCM_BOOL_F;
}
- scm_remember_upto_here_1 (tmp);
return (count == 1
? applicable
: sort_applicable_methods (applicable, count, types));
SCM_SYMBOL (sym_compute_applicable_methods, "compute-applicable-methods");
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));
-SCM_SYNTAX (s_atslot_ref, "@slot-ref", scm_makmmacro, scm_m_atslot_ref);
-
-SCM
-scm_m_atslot_ref (SCM xorig, SCM env SCM_UNUSED)
-#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 SCM_UNUSED)
-#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_list_5 (SCM_IM_DISPATCH, args, n, v, gf);
-}
-#undef FUNC_NAME
-
-
static void
lock_cache_mutex (void *m)
{
* the cache miss and locking the mutex.
*/
SCM cmethod = scm_mcache_lookup_cmethod (x, SCM_CDDR (args));
- if (!SCM_FALSEP (cmethod))
+ if (scm_is_true (cmethod))
return cmethod;
- /*fixme* Use scm_apply */
- return CALL_GF3 ("memoize-method!", gf, SCM_CDDR (args), x);
+
+ if (SCM_UNLIKELY (scm_is_false (var_memoize_method_x)))
+ var_memoize_method_x =
+ scm_permanent_object
+ (scm_module_variable (scm_module_goops, sym_memoize_method_x));
+
+ return scm_call_3 (SCM_VARIABLE_REF (var_memoize_method_x), gf, SCM_CDDR (args), x);
}
SCM
SCM_KEYWORD (k_setter, "setter");
SCM_KEYWORD (k_specializers, "specializers");
SCM_KEYWORD (k_procedure, "procedure");
+SCM_KEYWORD (k_formals, "formals");
+SCM_KEYWORD (k_body, "body");
+SCM_KEYWORD (k_make_procedure, "make-procedure");
SCM_KEYWORD (k_dsupers, "dsupers");
SCM_KEYWORD (k_slots, "slots");
SCM_KEYWORD (k_gf, "generic-function");
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)
{
z = scm_make_struct (class, SCM_INUM0,
scm_list_5 (SCM_EOL,
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_FALSEP (setter))
+ if (scm_is_true (setter))
scm_sys_set_object_setter_x (z, setter);
}
}
if (class == scm_class_method
|| class == scm_class_simple_method
- || class == scm_class_accessor)
+ || class == scm_class_accessor_method)
{
SCM_SET_SLOT (z, scm_si_generic_function,
scm_i_get_keyword (k_gf,
scm_i_get_keyword (k_procedure,
args,
len - 1,
- SCM_EOL,
+ SCM_BOOL_F,
FUNC_NAME));
SCM_SET_SLOT (z, scm_si_code_table, SCM_EOL);
+ SCM_SET_SLOT (z, scm_si_formals,
+ scm_i_get_keyword (k_formals,
+ args,
+ len - 1,
+ SCM_EOL,
+ FUNC_NAME));
+ SCM_SET_SLOT (z, scm_si_body,
+ scm_i_get_keyword (k_body,
+ args,
+ len - 1,
+ SCM_EOL,
+ FUNC_NAME));
+ SCM_SET_SLOT (z, scm_si_make_procedure,
+ scm_i_get_keyword (k_make_procedure,
+ args,
+ len - 1,
+ SCM_BOOL_F,
+ FUNC_NAME));
}
else
{
scm_i_get_keyword (k_name,
args,
len - 1,
- scm_str2symbol ("???"),
+ scm_from_locale_symbol ("???"),
FUNC_NAME));
SCM_SET_SLOT (z, scm_si_direct_supers,
scm_i_get_keyword (k_dsupers,
gf = SCM_CAR(l); l = SCM_CDR(l);
SCM_VALIDATE_GENERIC (1, gf);
- if (SCM_NULLP (SCM_SLOT (gf, scm_si_methods)))
+ 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);
SCM_DEFINE (scm_sys_method_more_specific_p, "%method-more-specific?", 3, 0, 0,
(SCM m1, SCM m2, SCM targs),
- "")
+ "Return true if method @var{m1} is more specific than @var{m2} "
+ "given the argument types (classes) listed in @var{targs}.")
#define FUNC_NAME s_scm_sys_method_more_specific_p
{
- SCM l, v;
- long i, len;
+ SCM l, v, result;
+ SCM *v_elts;
+ long i, len, m1_specs, m2_specs;
+ 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*/
+ len = scm_ilength (targs);
+ m1_specs = scm_ilength (SPEC_OF (m1));
+ m2_specs = scm_ilength (SPEC_OF (m2));
+ SCM_ASSERT ((len >= m1_specs) || (len >= m2_specs),
+ targs, SCM_ARG3, FUNC_NAME);
+
+ /* 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_NULLP (l); i++, l = SCM_CDR (l)) {
- SCM_ASSERT (SCM_CLASSP (SCM_CAR (l)), targs, SCM_ARG3, FUNC_NAME);
- SCM_VECTOR_SET (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
*
******************************************************************************/
+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_list_1 (super),
slots));
create_standard_classes (void)
{
SCM slots;
- SCM method_slots = scm_list_4 (scm_str2symbol ("generic-function"),
- scm_str2symbol ("specializers"),
+ SCM method_slots = scm_list_n (scm_from_locale_symbol ("generic-function"),
+ scm_from_locale_symbol ("specializers"),
sym_procedure,
- scm_str2symbol ("code-table"));
- SCM amethod_slots = scm_list_1 (scm_list_3 (scm_str2symbol ("slot-definition"),
+ scm_from_locale_symbol ("code-table"),
+ scm_from_locale_symbol ("formals"),
+ scm_from_locale_symbol ("body"),
+ scm_from_locale_symbol ("make-procedure"),
+ SCM_UNDEFINED);
+ 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_str2symbol ("make-mutex"));
- SCM gf_slots = scm_list_5 (scm_str2symbol ("methods"),
- scm_list_3 (scm_str2symbol ("n-specialized"),
+ 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_str2symbol ("used-by"),
+ scm_list_3 (scm_from_locale_symbol ("used-by"),
k_init_value,
SCM_BOOL_F),
- scm_list_3 (scm_str2symbol ("cache-mutex"),
+ scm_list_3 (scm_from_locale_symbol ("cache-mutex"),
k_init_thunk,
- scm_closure (scm_list_2 (SCM_EOL,
- mutex_slot),
- SCM_EOL)),
- scm_list_3 (scm_str2symbol ("extended-by"),
+ 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_str2symbol ("extends"),
+ SCM egf_slots = scm_list_1 (scm_list_3 (scm_from_locale_symbol ("extends"),
k_init_value,
SCM_EOL));
/* Foreign class slot classes */
scm_class_class, scm_class_foreign_slot, SCM_EOL);
make_stdcls (&scm_class_self, "<self-slot>",
scm_class_class,
- scm_list_2 (scm_class_foreign_slot, scm_class_read_only),
+ scm_class_read_only,
SCM_EOL);
make_stdcls (&scm_class_protected_opaque, "<protected-opaque-slot>",
scm_class_class,
make_stdcls (&scm_class_foreign_class, "<foreign-class>",
scm_class_class, scm_class_class,
- scm_list_2 (scm_list_3 (scm_str2symbol ("constructor"),
+ scm_list_2 (scm_list_3 (scm_from_locale_symbol ("constructor"),
k_class,
scm_class_opaque),
- scm_list_3 (scm_str2symbol ("destructor"),
+ scm_list_3 (scm_from_locale_symbol ("destructor"),
k_class,
scm_class_opaque)));
make_stdcls (&scm_class_foreign_object, "<foreign-object>",
make_stdcls (&scm_class_simple_method, "<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
, "<accessor-method>",
+ make_stdcls (&scm_class_accessor
_method, "<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, "<applicable>",
+ scm_class_class, scm_class_top, SCM_EOL);
make_stdcls (&scm_class_entity, "<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, "<entity-with-setter>",
scm_class_entity_class, scm_class_entity, SCM_EOL);
make_stdcls (&scm_class_generic, "<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, "<extended-generic>",
- scm_class_entity_class,
- scm_list_1 (scm_class_generic),
- egf_slots);
+ 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, "<generic-with-setter>",
scm_class_entity_class,
scm_list_2 (scm_class_generic, scm_class_entity_with_setter),
SCM_EOL);
SCM_SET_CLASS_FLAGS (scm_class_generic_with_setter, SCM_CLASSF_PURE_GENERIC);
+ make_stdcls (&scm_class_accessor, "<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,
"<extended-generic-with-setter>",
scm_class_entity_class,
- scm_list_2 (scm_class_extended_generic,
- scm_class_entity_with_setter),
+ 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, "<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, "<boolean>",
scm_class_class, scm_class_complex, SCM_EOL);
make_stdcls (&scm_class_integer, "<integer>",
scm_class_class, scm_class_real, SCM_EOL);
+ make_stdcls (&scm_class_fraction, "<fraction>",
+ scm_class_class, scm_class_real, SCM_EOL);
make_stdcls (&scm_class_keyword, "<keyword>",
scm_class_class, scm_class_top, SCM_EOL);
make_stdcls (&scm_class_unknown, "<unknown>",
scm_class_class, scm_class_top, SCM_EOL);
make_stdcls (&scm_class_procedure, "<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, "<procedure-with-setter>",
scm_class_procedure_class, scm_class_procedure, SCM_EOL);
make_stdcls (&scm_class_primitive_generic, "<primitive-generic>",
**********************************************************************/
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_call_2 (scm_goops_lookup_closure, name, SCM_BOOL_F)))
+ && scm_is_false (scm_module_variable (scm_module_goops, name)))
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_list_1 (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
{
long i;
- scm_smob_class = (SCM *) scm_malloc (255 * sizeof (SCM));
- for (i = 0; i < 255; ++i)
+ for (i = 0; i < SCM_I_MAX_SMOB_TYPE_COUNT; ++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 c, class = make_class_from_template ("<%s-port>",
type_name,
- scm_list_1 (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_list_2 (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_list_2 (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_list_2 (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_SET_SLOT (c, scm_si_cpl,
scm_cons2 (c, class, SCM_SLOT (scm_class_input_output_port, scm_si_cpl)));
{
long i;
- scm_port_class = (SCM *) scm_malloc (3 * 256 * sizeof (SCM));
- for (i = 0; i < 3 * 256; ++i)
- scm_port_class[i] = 0;
-
for (i = 0; i < scm_numptob; ++i)
scm_make_port_classes (i, SCM_PTOBNAME (i));
}
static SCM
-make_struct_class (void *closure SCM_UNUSED, SCM key SCM_UNUSED,
- SCM data, SCM prev SCM_UNUSED)
+make_struct_class (void *closure SCM_UNUSED,
+ SCM vtable, SCM data, SCM prev SCM_UNUSED)
{
- if (!SCM_FALSEP (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;
}
size_t (*destructor) (void *))
{
SCM name, class;
- name = scm_str2symbol (s_name);
- if (SCM_NULLP (supers))
+ 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);
SCM_SET_CLASS_INSTANCE_SIZE (class, size);
}
- SCM_SET_SLOT (class, scm_si_layout, scm_str2symbol (""));
+ SCM_SET_SLOT (class, scm_si_layout, scm_from_locale_symbol (""));
SCM_SET_SLOT (class, scm_si_constructor, (SCM) constructor);
return class;
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);
- SCM getm = scm_closure (scm_list_2 (scm_list_1 (sym_o),
- scm_list_2 (get, sym_o)),
- SCM_EOL);
- SCM setm = scm_closure (scm_list_2 (scm_list_2 (sym_o, sym_x),
- scm_list_3 (set, sym_o, sym_x)),
- SCM_EOL);
+
+ /* 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_list_5 (name,
k_class,
slot_class,
setter ? k_accessor : k_getter,
gf);
- SCM gns = scm_list_4 (name, SCM_BOOL_F, get, set);
-
- scm_add_method (gf, scm_make (scm_list_5 (scm_class_accessor,
+ 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_list_5 (scm_class_accessor,
+ scm_make (scm_list_5 (scm_class_accessor_method,
k_specializers,
scm_list_2 (class, scm_class_top),
k_procedure,
SCM_SET_SLOT (class, scm_si_slots,
scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_slots),
scm_list_1 (slot))));
- 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 n = SCM_SLOT (class, scm_si_nfields);
+ SCM gns = scm_list_n (name, SCM_BOOL_F, get, set, n, scm_from_int (1),
+ SCM_UNDEFINED);
+ 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)));
+ }
}
}
- {
- long n = SCM_INUM (SCM_SLOT (class, scm_si_nfields));
-
- SCM_SET_SLOT (class, scm_si_nfields, SCM_MAKINUM (n + 1));
- }
}
SCM
scm_ensure_accessor (SCM name)
{
SCM gf = scm_call_2 (SCM_TOP_LEVEL_LOOKUP_CLOSURE, name, SCM_BOOL_F);
- if (!SCM_IS_A_P (gf, scm_class_generic_with_setter))
+ if (!SCM_IS_A_P (gf, scm_class_accessor))
{
gf = scm_make (scm_list_3 (scm_class_generic, k_name, name));
- gf = scm_make (scm_list_5 (scm_class_generic_with_setter,
+ gf = scm_make (scm_list_5 (scm_class_accessor,
k_name, name, k_setter, gf));
}
return gf;
"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
{
goops_loaded_p = 1;
var_compute_applicable_methods =
- scm_sym2var (sym_compute_applicable_methods, scm_goops_lookup_closure,
- SCM_BOOL_F);
+ scm_permanent_object
+ (scm_module_variable (scm_module_goops, sym_compute_applicable_methods));
+ var_slot_unbound =
+ scm_permanent_object
+ (scm_module_variable (scm_module_goops, sym_slot_unbound));
+ var_slot_missing =
+ scm_permanent_object
+ (scm_module_variable (scm_module_goops, sym_slot_missing));
+ var_compute_cpl =
+ scm_permanent_object
+ (scm_module_variable (scm_module_goops, sym_compute_cpl));
+ var_no_applicable_method =
+ scm_permanent_object
+ (scm_module_variable (scm_module_goops, sym_no_applicable_method));
+ var_change_class =
+ scm_permanent_object
+ (scm_module_variable (scm_module_goops, sym_change_class));
+ setup_extended_primitive_generics ();
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
scm_init_goops_builtins (void)
{
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...
*/
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);
list_of_no_method = scm_permanent_object (scm_list_1 (sym_no_method));
- hell = scm_malloc (hell_size);
+ hell = scm_calloc (hell_size * sizeof (*hell));
hell_mutex = scm_permanent_object (scm_make_mutex ());
create_basic_classes ();
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_list_3 (scm_class_generic,
k_name,
HCoop / bpt / guile.git / blobdiff