X-Git-Url: https://git.hcoop.net/bpt/guile.git/blobdiff_plain/a002f1a2cbdc39b2a52e6d1e100791f106fd34bb..f92e85f7352174c9fe0ac0e67e6c38cfce923300:/libguile/objects.c diff --git a/libguile/objects.c b/libguile/objects.c index bc976a7d4..f655470da 100644 --- a/libguile/objects.c +++ b/libguile/objects.c @@ -1,46 +1,20 @@ -/* Copyright (C) 1995, 1996, 1999, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1999,2000,2001, 2003 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. + * 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. * - * 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. + * 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 + */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ @@ -74,7 +48,7 @@ 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 scm_class_integer, scm_class_real, scm_class_complex, scm_class_fraction; SCM scm_class_unknown; SCM *scm_port_class = 0; @@ -82,13 +56,11 @@ SCM *scm_smob_class = 0; SCM scm_no_applicable_method; -SCM (*scm_make_extended_class) (char *type_name); -void (*scm_make_port_classes) (int ptobnum, char *type_name); -void (*scm_change_object_class) (SCM, SCM, SCM); - /* This function is used for efficient type dispatch. */ -SCM -scm_class_of (SCM x) +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)) { @@ -99,19 +71,12 @@ scm_class_of (SCM x) case scm_tc3_imm24: if (SCM_CHARP (x)) return scm_class_char; + else if (SCM_BOOLP (x)) + return scm_class_boolean; + else if (SCM_NULLP (x)) + return scm_class_null; else - { - switch (SCM_ISYMNUM (x)) - { - case SCM_ISYMNUM (SCM_BOOL_F): - case SCM_ISYMNUM (SCM_BOOL_T): - return scm_class_boolean; - case SCM_ISYMNUM (SCM_EOL): - return scm_class_null; - default: - return scm_class_unknown; - } - } + return scm_class_unknown; case scm_tc3_cons: switch (SCM_TYP7 (x)) @@ -124,7 +89,7 @@ scm_class_of (SCM x) return scm_class_symbol; case scm_tc7_vector: case scm_tc7_wvect: -#ifdef HAVE_ARRAYS +#if SCM_HAVE_ARRAYS case scm_tc7_bvect: case scm_tc7_byvect: case scm_tc7_svect: @@ -136,11 +101,22 @@ scm_class_of (SCM x) #endif return scm_class_vector; case scm_tc7_string: - case scm_tc7_substring: 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: @@ -160,7 +136,7 @@ scm_class_of (SCM x) case scm_tc7_smob: { - long type = SCM_TYP16 (x); + 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); @@ -172,8 +148,7 @@ scm_class_of (SCM 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_cons_gloc: - /* must be a struct */ + 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) @@ -189,14 +164,15 @@ scm_class_of (SCM x) { /* ordinary struct */ SCM handle = scm_struct_create_handle (SCM_STRUCT_VTABLE (x)); - if (SCM_NFALSEP (SCM_STRUCT_TABLE_CLASS (SCM_CDR (handle)))) + if (!SCM_FALSEP (SCM_STRUCT_TABLE_CLASS (SCM_CDR (handle)))) return SCM_STRUCT_TABLE_CLASS (SCM_CDR (handle)); else { SCM name = SCM_STRUCT_TABLE_NAME (SCM_CDR (handle)); - SCM class = scm_make_extended_class (SCM_NFALSEP (name) - ? SCM_ROCHARS (name) - : 0); + SCM class = scm_make_extended_class (!SCM_FALSEP (name) + ? SCM_SYMBOL_CHARS (name) + : 0, + SCM_I_OPERATORP (x)); SCM_SET_STRUCT_TABLE_CLASS (SCM_CDR (handle), class); return class; } @@ -208,7 +184,7 @@ scm_class_of (SCM x) return scm_class_unknown; } - case scm_tc3_cons_gloc: + case scm_tc3_struct: case scm_tc3_tc7_1: case scm_tc3_tc7_2: case scm_tc3_closure: @@ -217,11 +193,17 @@ scm_class_of (SCM x) } return scm_class_unknown; } +#undef FUNC_NAME -/* (SCM_IM_DISPATCH ARGS N-SPECIALIZED +/* The cache argument for scm_mcache_lookup_cmethod has one of two possible + * formats: + * + * Format #1: + * (SCM_IM_DISPATCH ARGS N-SPECIALIZED * #((TYPE1 ... ENV FORMALS FORM ...) ...) * GF) * + * Format #2: * (SCM_IM_HASH_DISPATCH ARGS N-SPECIALIZED HASHSET MASK * #((TYPE1 ... ENV FORMALS FORM ...) ...) * GF) @@ -252,46 +234,47 @@ scm_class_of (SCM x) SCM scm_mcache_lookup_cmethod (SCM cache, SCM args) { - int i, n, end, mask; + long i, n, end, mask; SCM ls, methods, z = SCM_CDDR (cache); n = SCM_INUM (SCM_CAR (z)); /* maximum number of specializers */ methods = SCM_CADR (z); - if (SCM_NIMP (methods)) + if (SCM_INUMP (methods)) { - /* Prepare for linear search */ - mask = -1; - i = 0; - end = SCM_LENGTH (methods); - } - else - { - /* Compute a hash value */ - int hashset = SCM_INUM (methods); - int j = n; - mask = SCM_INUM (SCM_CAR (z = SCM_CDDR (z))); + /* cache format #2: compute a hash value */ + long hashset = SCM_INUM (methods); + long j = n; + z = SCM_CDDR (z); + mask = SCM_INUM (SCM_CAR (z)); methods = SCM_CADR (z); i = 0; ls = args; - if (SCM_NIMP (ls)) + if (!SCM_NULLP (ls)) do { i += SCM_STRUCT_DATA (scm_class_of (SCM_CAR (ls))) [scm_si_hashsets + hashset]; ls = SCM_CDR (ls); } - while (--j && SCM_NIMP (ls)); + while (j-- && !SCM_NULLP (ls)); i &= mask; end = i; } + else /* SCM_VECTORP (methods) */ + { + /* cache format #1: prepare for linear search */ + mask = -1; + i = 0; + end = SCM_VECTOR_LENGTH (methods); + } /* Search for match */ do { - int j = n; + long j = n; z = SCM_VELTS (methods)[i]; ls = args; /* list of arguments */ - if (SCM_NIMP (ls)) + if (!SCM_NULLP (ls)) do { /* More arguments than specifiers => CLASS != ENV */ @@ -300,11 +283,10 @@ scm_mcache_lookup_cmethod (SCM cache, SCM args) ls = SCM_CDR (ls); z = SCM_CDR (z); } - while (--j && SCM_NIMP (ls)); + while (j-- && !SCM_NULLP (ls)); /* Fewer arguments than specifiers => CAR != ENV */ - if (!(SCM_IMP (SCM_CAR (z)) || SCM_CONSP (SCM_CAR (z)))) - goto next_method; - return z; + if (SCM_NULLP (SCM_CAR (z)) || SCM_CONSP (SCM_CAR (z))) + return z; next_method: i = (i + 1) & mask; } while (i != end); @@ -315,7 +297,7 @@ SCM scm_mcache_compute_cmethod (SCM cache, SCM args) { SCM cmethod = scm_mcache_lookup_cmethod (cache, args); - if (SCM_IMP (cmethod)) + if (SCM_FALSEP (cmethod)) /* No match - memoize */ return scm_memoize_method (cache, args); return cmethod; @@ -340,24 +322,24 @@ scm_call_generic_0 (SCM gf) SCM scm_call_generic_1 (SCM gf, SCM a1) { - return scm_apply_generic (gf, SCM_LIST1 (a1)); + return scm_apply_generic (gf, scm_list_1 (a1)); } SCM scm_call_generic_2 (SCM gf, SCM a1, SCM a2) { - return scm_apply_generic (gf, SCM_LIST2 (a1, a2)); + return scm_apply_generic (gf, scm_list_2 (a1, a2)); } SCM scm_call_generic_3 (SCM gf, SCM a1, SCM a2, SCM a3) { - return scm_apply_generic (gf, SCM_LIST3 (a1, a2, a3)); + return scm_apply_generic (gf, scm_list_3 (a1, a2, a3)); } SCM_DEFINE (scm_entity_p, "entity?", 1, 0, 0, (SCM obj), -"") + "Return @code{#t} if @var{obj} is an entity.") #define FUNC_NAME s_scm_entity_p { return SCM_BOOL(SCM_STRUCTP (obj) && SCM_I_ENTITYP (obj)); @@ -366,7 +348,7 @@ SCM_DEFINE (scm_entity_p, "entity?", 1, 0, 0, SCM_DEFINE (scm_operator_p, "operator?", 1, 0, 0, (SCM obj), -"") + "Return @code{#t} if @var{obj} is an operator.") #define FUNC_NAME s_scm_operator_p { return SCM_BOOL(SCM_STRUCTP (obj) @@ -375,9 +357,36 @@ SCM_DEFINE (scm_operator_p, "operator?", 1, 0, 0, } #undef FUNC_NAME +/* XXX - What code requires the object procedure to be only of certain + types? */ + +SCM_DEFINE (scm_valid_object_procedure_p, "valid-object-procedure?", 1, 0, 0, + (SCM proc), + "Return @code{#t} iff @var{proc} is a procedure that can be used " + "with @code{set-object-procedure}. It is always valid to use " + "a closure constructed by @code{lambda}.") +#define FUNC_NAME s_scm_valid_object_procedure_p +{ + if (SCM_IMP (proc)) + return SCM_BOOL_F; + switch (SCM_TYP7 (proc)) + { + default: + return SCM_BOOL_F; + case scm_tcs_closures: + case scm_tc7_subr_1: + case scm_tc7_subr_2: + case scm_tc7_subr_3: + case scm_tc7_lsubr_2: + return SCM_BOOL_T; + } +} +#undef FUNC_NAME + SCM_DEFINE (scm_set_object_procedure_x, "set-object-procedure!", 2, 0, 0, (SCM obj, SCM proc), -"") + "Set the object procedure of @var{obj} to @var{proc}.\n" + "@var{obj} must be either an entity or an operator.") #define FUNC_NAME s_scm_set_object_procedure_x { SCM_ASSERT (SCM_STRUCTP (obj) @@ -388,7 +397,7 @@ SCM_DEFINE (scm_set_object_procedure_x, "set-object-procedure!", 2, 0, 0, obj, SCM_ARG1, FUNC_NAME); - SCM_VALIDATE_PROC (2,proc); + SCM_ASSERT (scm_valid_object_procedure_p (proc), proc, SCM_ARG2, FUNC_NAME); if (SCM_I_ENTITYP (obj)) SCM_SET_ENTITY_PROCEDURE (obj, proc); else @@ -400,7 +409,8 @@ SCM_DEFINE (scm_set_object_procedure_x, "set-object-procedure!", 2, 0, 0, #ifdef GUILE_DEBUG SCM_DEFINE (scm_object_procedure, "object-procedure", 1, 0, 0, (SCM obj), -"") + "Return the object procedure of @var{obj}. @var{obj} must be\n" + "an entity or an operator.") #define FUNC_NAME s_scm_object_procedure { SCM_ASSERT (SCM_STRUCTP (obj) @@ -428,19 +438,20 @@ scm_i_make_class_object (SCM meta, SCM layout = scm_make_struct_layout (layout_string); c = scm_make_struct (meta, SCM_INUM0, - SCM_LIST4 (layout, SCM_BOOL_F, SCM_EOL, SCM_EOL)); + scm_list_4 (layout, SCM_BOOL_F, SCM_EOL, SCM_EOL)); SCM_SET_CLASS_FLAGS (c, flags); return c; } SCM_DEFINE (scm_make_class_object, "make-class-object", 2, 0, 0, (SCM metaclass, SCM layout), -"") + "Create a new class object of class @var{metaclass}, with the\n" + "slot layout specified by @var{layout}.") #define FUNC_NAME s_scm_make_class_object { unsigned long flags = 0; - SCM_VALIDATE_STRUCT (1,metaclass); - SCM_VALIDATE_STRING (2,layout); + SCM_VALIDATE_STRUCT (1, metaclass); + SCM_VALIDATE_STRING (2, layout); if (SCM_EQ_P (metaclass, scm_metaclass_operator)) flags = SCM_CLASSF_OPERATOR; return scm_i_make_class_object (metaclass, layout, flags); @@ -449,17 +460,18 @@ SCM_DEFINE (scm_make_class_object, "make-class-object", 2, 0, 0, SCM_DEFINE (scm_make_subclass_object, "make-subclass-object", 2, 0, 0, (SCM class, SCM layout), -"") + "Create a subclass object of @var{class}, with the slot layout\n" + "specified by @var{layout}.") #define FUNC_NAME s_scm_make_subclass_object { SCM pl; - SCM_VALIDATE_STRUCT (1,class); - SCM_VALIDATE_STRING (2,layout); + SCM_VALIDATE_STRUCT (1, class); + SCM_VALIDATE_STRING (2, layout); pl = SCM_PACK (SCM_STRUCT_DATA (class) [scm_vtable_index_layout]); /* Convert symbol->string */ - pl = scm_makfromstr (SCM_SYMBOL_CHARS (pl), (scm_sizet) SCM_LENGTH (pl), 0); + pl = scm_mem2string (SCM_SYMBOL_CHARS (pl), SCM_SYMBOL_LENGTH (pl)); return scm_i_make_class_object (SCM_STRUCT_VTABLE (class), - scm_string_append (SCM_LIST2 (pl, layout)), + scm_string_append (scm_list_2 (pl, layout)), SCM_CLASS_FLAGS (class)); } #undef FUNC_NAME @@ -469,24 +481,24 @@ scm_init_objects () { SCM ms = scm_makfrom0str (SCM_METACLASS_STANDARD_LAYOUT); SCM mt = scm_make_vtable_vtable (ms, SCM_INUM0, - SCM_LIST3 (SCM_BOOL_F, SCM_EOL, SCM_EOL)); + scm_list_3 (SCM_BOOL_F, SCM_EOL, SCM_EOL)); SCM os = scm_makfrom0str (SCM_METACLASS_OPERATOR_LAYOUT); SCM ot = scm_make_vtable_vtable (os, SCM_INUM0, - SCM_LIST3 (SCM_BOOL_F, SCM_EOL, SCM_EOL)); + scm_list_3 (SCM_BOOL_F, SCM_EOL, SCM_EOL)); SCM es = scm_makfrom0str (SCM_ENTITY_LAYOUT); SCM el = scm_make_struct_layout (es); SCM et = scm_make_struct (mt, SCM_INUM0, - SCM_LIST4 (el, SCM_BOOL_F, SCM_EOL, SCM_EOL)); + scm_list_4 (el, SCM_BOOL_F, SCM_EOL, SCM_EOL)); - scm_sysintern ("", mt); + scm_c_define ("", mt); scm_metaclass_standard = mt; - scm_sysintern ("", ot); + scm_c_define ("", ot); scm_metaclass_operator = ot; SCM_SET_CLASS_FLAGS (et, SCM_CLASSF_OPERATOR | SCM_CLASSF_ENTITY); SCM_SET_CLASS_DESTRUCTOR (et, scm_struct_free_entity); - scm_sysintern ("", et); + scm_c_define ("", et); #include "libguile/objects.x" }