*
* 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
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
*/
\f
#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"
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.
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_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);
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
{
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_is_eq (obj, key))
return SCM_CADR (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));
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,
* 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 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;
}
}
+ if (len >= BUFFSIZE)
+ scm_array_handle_release (&handle);
+
if (count == 0)
{
if (find_method_p)
return SCM_BOOL_F;
}
- scm_remember_upto_here_1 (tmp);
return (count == 1
? applicable
: sort_applicable_methods (applicable, count, types));
"")
#define FUNC_NAME s_scm_sys_method_more_specific_p
{
- SCM l, v;
+ 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_is_null (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
HCoop / bpt / guile.git / blobdiff