summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--libguile/deprecated.c14
-rw-r--r--libguile/deprecated.h13
-rw-r--r--libguile/goops.c73
-rw-r--r--libguile/goops.h4
-rw-r--r--libguile/struct.c26
-rw-r--r--libguile/struct.h9
6 files changed, 79 insertions, 60 deletions
diff --git a/libguile/deprecated.c b/libguile/deprecated.c
index 049807a99..41e4dbcd3 100644
--- a/libguile/deprecated.c
+++ b/libguile/deprecated.c
@@ -2561,10 +2561,24 @@ scm_whash_insert (SCM whash, SCM key, SCM obj)
+SCM scm_struct_table = SCM_BOOL_F;
+
+SCM
+scm_struct_create_handle (SCM obj)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_struct_create_handle' is deprecated, and has no effect.");
+
+ return scm_cons (obj, scm_cons (SCM_BOOL_F, SCM_BOOL_F));
+}
+
+
+
void
scm_i_init_deprecated ()
{
properties_whash = scm_make_weak_key_hash_table (SCM_UNDEFINED);
+ scm_struct_table = scm_make_hash_table (SCM_UNDEFINED);
#include "libguile/deprecated.x"
}
diff --git a/libguile/deprecated.h b/libguile/deprecated.h
index e0b13e375..6693c6c73 100644
--- a/libguile/deprecated.h
+++ b/libguile/deprecated.h
@@ -770,6 +770,19 @@ SCM_DEPRECATED void scm_whash_insert (SCM whash, SCM key, SCM obj);
+/* No need for a table for names, and the struct->class mapping is
+ maintained by GOOPS now. */
+#define SCM_STRUCT_TABLE_NAME(X) SCM_CAR (X)
+#define SCM_SET_STRUCT_TABLE_NAME(X, NAME) SCM_SETCAR (X, NAME)
+#define SCM_STRUCT_TABLE_CLASS(X) SCM_CDR (X)
+#define SCM_SET_STRUCT_TABLE_CLASS(X, CLASS) SCM_SETCDR (X, CLASS)
+
+SCM_DEPRECATED SCM scm_struct_table;
+SCM_DEPRECATED SCM scm_struct_create_handle (SCM obj);
+
+
+
+
void scm_i_init_deprecated (void);
#endif
diff --git a/libguile/goops.c b/libguile/goops.c
index f6102085f..274749048 100644
--- a/libguile/goops.c
+++ b/libguile/goops.c
@@ -169,6 +169,8 @@ static SCM class_vm_cont;
static SCM class_bytevector;
static SCM class_uvec;
+static SCM vtable_class_map = SCM_BOOL_F;
+
/* 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. */
@@ -189,6 +191,41 @@ static SCM scm_sys_goops_loaded (void);
static SCM scm_make_extended_class_from_symbol (SCM type_name_sym,
int applicablep);
+
+SCM
+scm_i_define_class_for_vtable (SCM vtable)
+{
+ SCM class;
+
+ if (scm_is_false (vtable_class_map))
+ vtable_class_map = scm_make_weak_key_hash_table (SCM_UNDEFINED);
+
+ if (scm_is_false (scm_struct_vtable_p (vtable)))
+ abort ();
+
+ class = scm_hashq_ref (vtable_class_map, vtable, SCM_BOOL_F);
+
+ if (scm_is_false (class))
+ {
+ if (SCM_UNPACK (scm_class_class))
+ {
+ SCM name = SCM_VTABLE_NAME (vtable);
+ if (!scm_is_symbol (name))
+ name = scm_string_to_symbol (scm_nullstr);
+
+ class = scm_make_extended_class_from_symbol
+ (name, SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_APPLICABLE));
+ }
+ else
+ /* `create_struct_classes' will fill this in later. */
+ class = SCM_BOOL_F;
+
+ scm_hashq_set_x (vtable_class_map, vtable, class);
+ }
+
+ return class;
+}
+
/* This function is used for efficient type dispatch. */
SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
(SCM x),
@@ -288,26 +325,7 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
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 class, name;
-
- name = SCM_STRUCT_TABLE_NAME (SCM_CDR (handle));
- if (!scm_is_symbol (name))
- name = scm_string_to_symbol (scm_nullstr);
-
- class =
- scm_make_extended_class_from_symbol (name,
- SCM_STRUCT_APPLICABLE_P (x));
- SCM_SET_STRUCT_TABLE_CLASS (SCM_CDR (handle), class);
- return class;
- }
- }
+ return scm_i_define_class_for_vtable (SCM_CLASS_OF (x));
default:
if (scm_is_pair (x))
return scm_class_pair;
@@ -2628,23 +2646,16 @@ static SCM
make_struct_class (void *closure SCM_UNUSED,
SCM vtable, SCM data, SCM prev SCM_UNUSED)
{
- SCM sym = SCM_STRUCT_TABLE_NAME (data);
- if (scm_is_true (sym))
- {
- int applicablep = SCM_CLASS_FLAGS (vtable) & SCM_VTABLE_FLAG_APPLICABLE;
-
- SCM_SET_STRUCT_TABLE_CLASS (data,
- scm_make_extended_class_from_symbol (sym, applicablep));
- }
-
- scm_remember_upto_here_2 (data, vtable);
+ if (scm_is_false (data))
+ scm_i_define_class_for_vtable (vtable);
return SCM_UNSPECIFIED;
}
static void
create_struct_classes (void)
{
- scm_internal_hash_fold (make_struct_class, 0, SCM_BOOL_F, scm_struct_table);
+ scm_internal_hash_fold (make_struct_class, 0, SCM_BOOL_F,
+ vtable_class_map);
}
/**********************************************************************
diff --git a/libguile/goops.h b/libguile/goops.h
index 06ade43a4..47a6e4eca 100644
--- a/libguile/goops.h
+++ b/libguile/goops.h
@@ -3,7 +3,7 @@
#ifndef SCM_GOOPS_H
#define SCM_GOOPS_H
-/* Copyright (C) 1998,1999,2000,2001,2002,2003, 2006, 2008, 2009 Free Software Foundation, Inc.
+/* Copyright (C) 1998,1999,2000,2001,2002,2003, 2006, 2008, 2009, 2011 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -307,6 +307,8 @@ SCM_API SCM scm_apply_generic (SCM gf, SCM args);
*/
SCM_API SCM scm_call_generic_3 (SCM gf, SCM a1, SCM a2, SCM a3);
+SCM_INTERNAL SCM scm_i_define_class_for_vtable (SCM vtable);
+
SCM_INTERNAL SCM scm_init_goops_builtins (void);
SCM_INTERNAL void scm_init_goops (void);
diff --git a/libguile/struct.c b/libguile/struct.c
index e5ecc1aaf..4a2a9d750 100644
--- a/libguile/struct.c
+++ b/libguile/struct.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+/* Copyright (C) 1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -54,7 +54,6 @@
static SCM required_vtable_fields = SCM_BOOL_F;
static SCM required_applicable_fields = SCM_BOOL_F;
static SCM required_applicable_with_setter_fields = SCM_BOOL_F;
-SCM scm_struct_table = SCM_BOOL_F;
SCM scm_applicable_struct_vtable_vtable;
SCM scm_applicable_struct_with_setter_vtable_vtable;
SCM scm_standard_vtable_vtable;
@@ -946,27 +945,13 @@ scm_struct_ihashq (SCM obj, unsigned long n, void *closure)
return SCM_UNPACK (obj) % n;
}
-SCM
-scm_struct_create_handle (SCM obj)
-{
- SCM handle = scm_hash_fn_create_handle_x (scm_struct_table,
- obj,
- SCM_BOOL_F,
- scm_struct_ihashq,
- (scm_t_assoc_fn) scm_sloppy_assq,
- 0);
- if (scm_is_false (SCM_CDR (handle)))
- SCM_SETCDR (handle, scm_cons (SCM_BOOL_F, SCM_BOOL_F));
- return handle;
-}
-
SCM_DEFINE (scm_struct_vtable_name, "struct-vtable-name", 1, 0, 0,
(SCM vtable),
"Return the name of the vtable @var{vtable}.")
#define FUNC_NAME s_scm_struct_vtable_name
{
SCM_VALIDATE_VTABLE (1, vtable);
- return SCM_STRUCT_TABLE_NAME (SCM_CDR (scm_struct_create_handle (vtable)));
+ return SCM_VTABLE_NAME (vtable);
}
#undef FUNC_NAME
@@ -977,8 +962,10 @@ SCM_DEFINE (scm_set_struct_vtable_name_x, "set-struct-vtable-name!", 2, 0, 0,
{
SCM_VALIDATE_VTABLE (1, vtable);
SCM_VALIDATE_SYMBOL (2, name);
- SCM_SET_STRUCT_TABLE_NAME (SCM_CDR (scm_struct_create_handle (vtable)),
- name);
+ SCM_SET_VTABLE_NAME (vtable, name);
+ /* FIXME: remove this, and implement proper struct classes instead.
+ (Vtables *are* classes.) */
+ scm_i_define_class_for_vtable (vtable);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
@@ -1047,7 +1034,6 @@ scm_init_struct ()
OBJ once OBJ has undergone class redefinition. */
GC_REGISTER_DISPLACEMENT (2 * sizeof (scm_t_bits));
- scm_struct_table = scm_make_weak_key_hash_table (scm_from_int (31));
required_vtable_fields = scm_from_locale_string (SCM_VTABLE_BASE_LAYOUT);
required_applicable_fields = scm_from_locale_string (SCM_APPLICABLE_BASE_LAYOUT);
required_applicable_with_setter_fields = scm_from_locale_string (SCM_APPLICABLE_WITH_SETTER_BASE_LAYOUT);
diff --git a/libguile/struct.h b/libguile/struct.h
index 7a4d63521..c3c7d8f12 100644
--- a/libguile/struct.h
+++ b/libguile/struct.h
@@ -3,7 +3,7 @@
#ifndef SCM_STRUCT_H
#define SCM_STRUCT_H
-/* Copyright (C) 1995,1997,1999,2000,2001, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1997,1999,2000,2001, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -165,12 +165,6 @@ typedef void (*scm_t_struct_finalize) (SCM obj);
#define SCM_STRUCT_SETTER(X) (SCM_STRUCT_SLOT_REF (X, scm_applicable_struct_index_setter))
#define SCM_SET_STRUCT_SETTER(X,P) (SCM_STRUCT_SLOT_SET (X, scm_applicable_struct_index_setter, P))
-#define SCM_STRUCT_TABLE_NAME(X) SCM_CAR (X)
-#define SCM_SET_STRUCT_TABLE_NAME(X, NAME) SCM_SETCAR (X, NAME)
-#define SCM_STRUCT_TABLE_CLASS(X) SCM_CDR (X)
-#define SCM_SET_STRUCT_TABLE_CLASS(X, CLASS) SCM_SETCDR (X, CLASS)
-SCM_API SCM scm_struct_table;
-
SCM_API SCM scm_standard_vtable_vtable;
SCM_API SCM scm_applicable_struct_vtable_vtable;
SCM_API SCM scm_applicable_struct_with_setter_vtable_vtable;
@@ -191,7 +185,6 @@ SCM_API SCM scm_struct_ref (SCM handle, SCM pos);
SCM_API SCM scm_struct_set_x (SCM handle, SCM pos, SCM val);
SCM_API SCM scm_struct_vtable (SCM handle);
SCM_API SCM scm_struct_vtable_tag (SCM handle);
-SCM_API SCM scm_struct_create_handle (SCM obj);
SCM_API SCM scm_struct_vtable_name (SCM vtable);
SCM_API SCM scm_set_struct_vtable_name_x (SCM vtable, SCM name);
SCM_API void scm_print_struct (SCM exp, SCM port, scm_print_state *);