[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.1-17-gf3c6a0
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.1-17-gf3c6a02 |
|
Date: |
Sun, 01 May 2011 21:13:52 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=f3c6a02c885ad29f6af0d786e14e34c81d49470f
The branch, stable-2.0 has been updated
via f3c6a02c885ad29f6af0d786e14e34c81d49470f (commit)
via 1d9c2e6271105ee0f728127d9b544432b7cc0f4f (commit)
via 8bee35bc536eebd3d223c23990a65b1341e760ac (commit)
via eceee4efe35fc2c128faf362c71a617585124324 (commit)
via 1ad9fdb727ef4e49f8d624b655cfc38c2f757e22 (commit)
via 4466db75daa6ebee48a889f79046b1f4fb22c75a (commit)
via d1c4720ca382c5588a52108326343eaaab9063ca (commit)
via ecc9d1b547b21830f5ce4f1eaceb6b9dde44e5dc (commit)
from b735d33b2b636f457c8ca0740c99169e20b377b3 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit f3c6a02c885ad29f6af0d786e14e34c81d49470f
Author: Andy Wingo <address@hidden>
Date: Sun May 1 23:00:55 2011 +0200
deprecate scm_struct_table
* libguile/goops.h:
* libguile/goops.c (scm_i_define_class_for_vtable): New internal helper,
defines a class for a vtable, relying on the name slot being set
correctly.
(scm_class_of, create_struct_classes): Use the local vtable-to-class
map instead of scm_struct_table.
* libguile/struct.h (SCM_STRUCT_TABLE_NAME, SCM_SET_STRUCT_TABLE_NAME)
(SCM_STRUCT_TABLE_CLASS, SCM_SET_STRUCT_TABLE_CLASS, scm_struct_table)
(scm_struct_create_handle): Deprecate these internals of the map
between structs and classes.
* libguile/deprecated.h:
* libguile/deprecated.c (scm_struct_create_handle): Deprecated code over
here now.
commit 1d9c2e6271105ee0f728127d9b544432b7cc0f4f
Author: Andy Wingo <address@hidden>
Date: Sun May 1 20:34:47 2011 +0200
disallow get-handle / create-handle! of weak hash tables
* libguile/hashtab.c (scm_hashq_get_handle, scm_hashq_create_handle_x)
(scm_hashv_get_handle, scm_hashv_create_handle_x)
(scm_hash_get_handle, scm_hash_create_handle_x)
(scm_hashx_get_handle, scm_hashx_create_handle_x): Don't allow these
functions to be called on weak hash tables, as we have no idea when
the GC will null out fields of the handle, and set-cdr! won't register
disappearing links, and set-car! would never work of course.
commit 8bee35bc536eebd3d223c23990a65b1341e760ac
Author: Andy Wingo <address@hidden>
Date: Sun May 1 21:43:04 2011 +0200
(ice-9 poe) does not get handles from weak hash tables
* module/ice-9/poe.scm (pure-funcq, perfect-funcq): Reimplement to not
use get-handle.
commit eceee4efe35fc2c128faf362c71a617585124324
Author: Andy Wingo <address@hidden>
Date: Sun May 1 21:01:29 2011 +0200
boot-9 fixme note
* module/ice-9/boot-9.scm (module-replace!): Add a fixme about using
something other than object properties here.
commit 1ad9fdb727ef4e49f8d624b655cfc38c2f757e22
Author: Andy Wingo <address@hidden>
Date: Sun May 1 21:00:54 2011 +0200
fix scm_object_property_set_x for handles and weak tables
* libguile/objprop.c (scm_object_property_set_x): Use ref and set!
instead of create-handle and set-cdr!, as it is a weak hash table.
(scm_set_object_properties_x): Likewise.
commit 4466db75daa6ebee48a889f79046b1f4fb22c75a
Author: Andy Wingo <address@hidden>
Date: Sun May 1 20:32:28 2011 +0200
deprecated primitive-properties don't get handles from weak hash tables
* libguile/deprecated.c (scm_primitive_property_ref)
(scm_primitive_property_set_x): Avoid getting handles to elements in a
weak hash table, as that's not going to work very well.
commit d1c4720ca382c5588a52108326343eaaab9063ca
Author: Andy Wingo <address@hidden>
Date: Sun May 1 20:30:54 2011 +0200
deprecate scm_whash API
* libguile/deprecated.h:
* libguile/deprecated.c (scm_whash_get_handle, SCM_WHASHFOUNDP)
(SCM_WHASHREF, SCM_WHASHSET, scm_whash_create_handle)
(scm_whash_lookup, scm_whash_insert): Deprecate this API.
* libguile/srcprop.c:
* libguile/srcprop.h:
* libguile/read.c (scm_read_sexp): Use the hashq API instead of the
whash API.
commit ecc9d1b547b21830f5ce4f1eaceb6b9dde44e5dc
Author: Andy Wingo <address@hidden>
Date: Sun May 1 18:01:42 2011 +0200
fix hash-set! in weak-value table from non-immediate to immediate
* libguile/hashtab.c (set_weak_cdr, scm_hash_fn_set_x): If we have a
weak-value hash table with a previous non-immediate value for a given
key, and we are setting an immediate as the new value, we were not
unregistering the disappearing link. Fixed.
-----------------------------------------------------------------------
Summary of changes:
libguile/deprecated.c | 113 +++++++++++++++++++++++++++++++++++++++--------
libguile/deprecated.h | 31 +++++++++++++
libguile/goops.c | 73 +++++++++++++++++-------------
libguile/goops.h | 4 +-
libguile/hashtab.c | 78 +++++++++++++++++++++++++++++---
libguile/objprop.c | 18 +++-----
libguile/read.c | 68 ++++++++++++++--------------
libguile/srcprop.c | 38 ++++++----------
libguile/srcprop.h | 26 +----------
libguile/struct.c | 26 +++--------
libguile/struct.h | 9 +---
module/ice-9/boot-9.scm | 2 +
module/ice-9/poe.scm | 36 ++++++---------
13 files changed, 321 insertions(+), 201 deletions(-)
diff --git a/libguile/deprecated.c b/libguile/deprecated.c
index 4d6027c..41e4dbc 100644
--- a/libguile/deprecated.c
+++ b/libguile/deprecated.c
@@ -2425,17 +2425,17 @@ SCM_DEFINE (scm_primitive_property_ref,
"primitive-property-ref", 2, 0, 0,
"property value.")
#define FUNC_NAME s_scm_primitive_property_ref
{
- SCM h;
+ SCM alist;
scm_c_issue_deprecation_warning
("`primitive-property-ref' is deprecated. Use object properties.");
SCM_VALIDATE_CONS (SCM_ARG1, prop);
- h = scm_hashq_get_handle (properties_whash, obj);
- if (scm_is_true (h))
+ alist = scm_hashq_ref (properties_whash, obj, SCM_EOL);
+ if (scm_is_pair (alist))
{
- SCM assoc = scm_assq (prop, SCM_CDR (h));
+ SCM assoc = scm_assq (prop, alist);
if (scm_is_true (assoc))
return SCM_CDR (assoc);
}
@@ -2445,9 +2445,8 @@ SCM_DEFINE (scm_primitive_property_ref,
"primitive-property-ref", 2, 0, 0,
else
{
SCM val = scm_call_2 (SCM_CAR (prop), prop, obj);
- if (scm_is_false (h))
- h = scm_hashq_create_handle_x (properties_whash, obj, SCM_EOL);
- SCM_SETCDR (h, scm_acons (prop, val, SCM_CDR (h)));
+ scm_hashq_set_x (properties_whash, obj,
+ scm_acons (prop, val, alist));
return val;
}
}
@@ -2459,21 +2458,19 @@ SCM_DEFINE (scm_primitive_property_set_x,
"primitive-property-set!", 3, 0, 0,
"Set the property @var{prop} of @var{obj} to @var{val}.")
#define FUNC_NAME s_scm_primitive_property_set_x
{
- SCM h, assoc;
+ SCM alist, assoc;
scm_c_issue_deprecation_warning
("`primitive-property-set!' is deprecated. Use object properties.");
SCM_VALIDATE_CONS (SCM_ARG1, prop);
- h = scm_hashq_create_handle_x (properties_whash, obj, SCM_EOL);
- assoc = scm_assq (prop, SCM_CDR (h));
- if (SCM_NIMP (assoc))
+ alist = scm_hashq_ref (properties_whash, obj, SCM_EOL);
+ assoc = scm_assq (prop, alist);
+ if (scm_is_pair (assoc))
SCM_SETCDR (assoc, val);
else
- {
- assoc = scm_acons (prop, val, SCM_CDR (h));
- SCM_SETCDR (h, assoc);
- }
+ scm_hashq_set_x (properties_whash, obj,
+ scm_acons (prop, val, alist));
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
@@ -2484,26 +2481,104 @@ SCM_DEFINE (scm_primitive_property_del_x,
"primitive-property-del!", 2, 0, 0,
"Remove any value associated with @var{prop} and @var{obj}.")
#define FUNC_NAME s_scm_primitive_property_del_x
{
- SCM h;
+ SCM alist;
scm_c_issue_deprecation_warning
("`primitive-property-del!' is deprecated. Use object properties.");
SCM_VALIDATE_CONS (SCM_ARG1, prop);
- h = scm_hashq_get_handle (properties_whash, obj);
- if (scm_is_true (h))
- SCM_SETCDR (h, scm_assq_remove_x (SCM_CDR (h), prop));
+ alist = scm_hashq_ref (properties_whash, obj, SCM_EOL);
+ if (scm_is_pair (alist))
+ scm_hashq_set_x (properties_whash, obj, scm_assq_remove_x (alist, prop));
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
+SCM
+scm_whash_get_handle (SCM whash, SCM key)
+{
+ scm_c_issue_deprecation_warning
+ ("The `scm_whash' API is deprecated. Use the `scm_hashq' API instead.");
+
+ return scm_hashq_get_handle (whash, key);
+}
+
+int
+SCM_WHASHFOUNDP (SCM h)
+{
+ scm_c_issue_deprecation_warning
+ ("The `scm_whash' API is deprecated. Use the `scm_hashq' API instead.");
+
+ return scm_is_true (h);
+}
+
+SCM
+SCM_WHASHREF (SCM whash, SCM handle)
+{
+ scm_c_issue_deprecation_warning
+ ("The `scm_whash' API is deprecated. Use the `scm_hashq' API instead.");
+
+ return SCM_CDR (handle);
+}
+
+void
+SCM_WHASHSET (SCM whash, SCM handle, SCM obj)
+{
+ scm_c_issue_deprecation_warning
+ ("The `scm_whash' API is deprecated. Use the `scm_hashq' API instead.");
+
+ SCM_SETCDR (handle, obj);
+}
+
+SCM
+scm_whash_create_handle (SCM whash, SCM key)
+{
+ scm_c_issue_deprecation_warning
+ ("The `scm_whash' API is deprecated. Use the `scm_hashq' API instead.");
+
+ return scm_hashq_create_handle_x (whash, key, SCM_UNSPECIFIED);
+}
+
+SCM
+scm_whash_lookup (SCM whash, SCM obj)
+{
+ scm_c_issue_deprecation_warning
+ ("The `scm_whash' API is deprecated. Use the `scm_hashq' API instead.");
+
+ return scm_hashq_ref (whash, obj, SCM_BOOL_F);
+}
+
+void
+scm_whash_insert (SCM whash, SCM key, SCM obj)
+{
+ scm_c_issue_deprecation_warning
+ ("The `scm_whash' API is deprecated. Use the `scm_hashq' API instead.");
+
+ scm_hashq_set_x (whash, key, 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 7deee35..6693c6c 100644
--- a/libguile/deprecated.h
+++ b/libguile/deprecated.h
@@ -752,6 +752,37 @@ SCM_DEPRECATED SCM scm_primitive_property_del_x (SCM prop,
SCM obj);
+/* {The old whash table interface}
+ * Deprecated, as the hash table interface is sufficient, and accessing
+ * handles of weak hash tables is no longer supported.
+ */
+
+#define scm_whash_handle SCM
+
+SCM_DEPRECATED SCM scm_whash_get_handle (SCM whash, SCM key);
+SCM_DEPRECATED int SCM_WHASHFOUNDP (SCM h);
+SCM_DEPRECATED SCM SCM_WHASHREF (SCM whash, SCM handle);
+SCM_DEPRECATED void SCM_WHASHSET (SCM whash, SCM handle, SCM obj);
+SCM_DEPRECATED SCM scm_whash_create_handle (SCM whash, SCM key);
+SCM_DEPRECATED SCM scm_whash_lookup (SCM whash, SCM obj);
+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 f610208..2747490 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 06ade43..47a6e4e 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/hashtab.c b/libguile/hashtab.c
index 48660d7..37d168c 100644
--- a/libguile/hashtab.c
+++ b/libguile/hashtab.c
@@ -761,21 +761,56 @@ scm_hash_fn_ref (SCM table, SCM obj, SCM dflt,
+struct set_weak_cdr_data
+{
+ SCM pair;
+ SCM new_val;
+};
+
+static void*
+set_weak_cdr (void *data)
+{
+ struct set_weak_cdr_data *d = data;
+
+ if (SCM_NIMP (SCM_WEAK_PAIR_CDR (d->pair)) && !SCM_NIMP (d->new_val))
+ {
+ GC_unregister_disappearing_link ((void *) SCM_CDRLOC (d->pair));
+ SCM_SETCDR (d->pair, d->new_val);
+ }
+ else
+ {
+ SCM_SETCDR (d->pair, d->new_val);
+ SCM_I_REGISTER_DISAPPEARING_LINK ((void *) SCM_CDRLOC (d->pair),
+ SCM2PTR (d->new_val));
+ }
+ return NULL;
+}
+
SCM
scm_hash_fn_set_x (SCM table, SCM obj, SCM val,
scm_t_hash_fn hash_fn, scm_t_assoc_fn assoc_fn,
void *closure)
{
- SCM it;
+ SCM pair;
- it = scm_hash_fn_create_handle_x (table, obj, SCM_BOOL_F, hash_fn, assoc_fn,
closure);
- SCM_SETCDR (it, val);
+ pair = scm_hash_fn_create_handle_x (table, obj, val,
+ hash_fn, assoc_fn, closure);
- if (SCM_HASHTABLE_WEAK_VALUE_P (table) && SCM_NIMP (val))
- /* IT is a weak-cdr pair. Register a disappearing link from IT's
- cdr to VAL like `scm_weak_cdr_pair' does. */
- SCM_I_REGISTER_DISAPPEARING_LINK ((void *) SCM_CDRLOC (it), SCM2PTR (val));
+ if (SCM_UNLIKELY (!scm_is_eq (SCM_CDR (pair), val)))
+ {
+ if (SCM_UNLIKELY (SCM_HASHTABLE_WEAK_VALUE_P (table)))
+ {
+ struct set_weak_cdr_data data;
+ data.pair = pair;
+ data.new_val = val;
+
+ GC_call_with_alloc_lock (set_weak_cdr, &data);
+ }
+ else
+ SCM_SETCDR (pair, val);
+ }
+
return val;
}
@@ -843,6 +878,9 @@ SCM_DEFINE (scm_hashq_get_handle, "hashq-get-handle", 2, 0,
0,
"Uses @code{eq?} for equality testing.")
#define FUNC_NAME s_scm_hashq_get_handle
{
+ if (SCM_UNLIKELY (SCM_HASHTABLE_P (table) && SCM_HASHTABLE_WEAK_P (table)))
+ SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL);
+
return scm_hash_fn_get_handle (table, key,
(scm_t_hash_fn) scm_ihashq,
(scm_t_assoc_fn) scm_sloppy_assq,
@@ -858,6 +896,9 @@ SCM_DEFINE (scm_hashq_create_handle_x,
"hashq-create-handle!", 3, 0, 0,
"associates @var{key} with @var{init}.")
#define FUNC_NAME s_scm_hashq_create_handle_x
{
+ if (SCM_UNLIKELY (SCM_HASHTABLE_P (table) && SCM_HASHTABLE_WEAK_P (table)))
+ SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL);
+
return scm_hash_fn_create_handle_x (table, key, init,
(scm_t_hash_fn) scm_ihashq,
(scm_t_assoc_fn) scm_sloppy_assq,
@@ -924,6 +965,9 @@ SCM_DEFINE (scm_hashv_get_handle, "hashv-get-handle", 2, 0,
0,
"Uses @code{eqv?} for equality testing.")
#define FUNC_NAME s_scm_hashv_get_handle
{
+ if (SCM_UNLIKELY (SCM_HASHTABLE_P (table) && SCM_HASHTABLE_WEAK_P (table)))
+ SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL);
+
return scm_hash_fn_get_handle (table, key,
(scm_t_hash_fn) scm_ihashv,
(scm_t_assoc_fn) scm_sloppy_assv,
@@ -939,6 +983,9 @@ SCM_DEFINE (scm_hashv_create_handle_x,
"hashv-create-handle!", 3, 0, 0,
"associates @var{key} with @var{init}.")
#define FUNC_NAME s_scm_hashv_create_handle_x
{
+ if (SCM_UNLIKELY (SCM_HASHTABLE_P (table) && SCM_HASHTABLE_WEAK_P (table)))
+ SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL);
+
return scm_hash_fn_create_handle_x (table, key, init,
(scm_t_hash_fn) scm_ihashv,
(scm_t_assoc_fn) scm_sloppy_assv,
@@ -1003,6 +1050,9 @@ SCM_DEFINE (scm_hash_get_handle, "hash-get-handle", 2, 0,
0,
"Uses @code{equal?} for equality testing.")
#define FUNC_NAME s_scm_hash_get_handle
{
+ if (SCM_UNLIKELY (SCM_HASHTABLE_P (table) && SCM_HASHTABLE_WEAK_P (table)))
+ SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL);
+
return scm_hash_fn_get_handle (table, key,
(scm_t_hash_fn) scm_ihash,
(scm_t_assoc_fn) scm_sloppy_assoc,
@@ -1018,6 +1068,9 @@ SCM_DEFINE (scm_hash_create_handle_x,
"hash-create-handle!", 3, 0, 0,
"associates @var{key} with @var{init}.")
#define FUNC_NAME s_scm_hash_create_handle_x
{
+ if (SCM_UNLIKELY (SCM_HASHTABLE_P (table) && SCM_HASHTABLE_WEAK_P (table)))
+ SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL);
+
return scm_hash_fn_create_handle_x (table, key, init,
(scm_t_hash_fn) scm_ihash,
(scm_t_assoc_fn) scm_sloppy_assoc,
@@ -1117,6 +1170,10 @@ SCM_DEFINE (scm_hashx_get_handle, "hashx-get-handle", 4,
0, 0,
scm_t_ihashx_closure closure;
closure.hash = hash;
closure.assoc = assoc;
+
+ if (SCM_UNLIKELY (SCM_HASHTABLE_P (table) && SCM_HASHTABLE_WEAK_P (table)))
+ SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL);
+
return scm_hash_fn_get_handle (table, key, scm_ihashx, scm_sloppy_assx,
(void *) &closure);
}
@@ -1136,6 +1193,10 @@ SCM_DEFINE (scm_hashx_create_handle_x,
"hashx-create-handle!", 5, 0, 0,
scm_t_ihashx_closure closure;
closure.hash = hash;
closure.assoc = assoc;
+
+ if (SCM_UNLIKELY (SCM_HASHTABLE_P (table) && SCM_HASHTABLE_WEAK_P (table)))
+ SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL);
+
return scm_hash_fn_create_handle_x (table, key, init, scm_ihashx,
scm_sloppy_assx, (void *)&closure);
}
@@ -1265,6 +1326,9 @@ SCM_DEFINE (scm_hash_for_each_handle,
"hash-for-each-handle", 2, 0, 0,
SCM_ASSERT (scm_is_true (scm_procedure_p (proc)), proc, 1, FUNC_NAME);
SCM_VALIDATE_HASHTABLE (2, table);
+ if (SCM_UNLIKELY (SCM_HASHTABLE_WEAK_P (table)))
+ SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL);
+
scm_internal_hash_for_each_handle ((scm_t_hash_handle_fn) scm_call_1,
(void *) SCM_UNPACK (proc),
table);
diff --git a/libguile/objprop.c b/libguile/objprop.c
index dfa8494..7b50d71 100644
--- a/libguile/objprop.c
+++ b/libguile/objprop.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996, 2000, 2001, 2003, 2006, 2008, 2009, 2010 Free
Software Foundation, Inc.
+/* Copyright (C) 1995,1996, 2000, 2001, 2003, 2006, 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
@@ -59,11 +59,8 @@ SCM_DEFINE (scm_set_object_properties_x,
"set-object-properties!", 2, 0, 0,
"Set @var{obj}'s property list to @var{alist}.")
#define FUNC_NAME s_scm_set_object_properties_x
{
- SCM handle;
-
scm_i_pthread_mutex_lock (&whash_mutex);
- handle = scm_hashq_create_handle_x (object_whash, obj, alist);
- SCM_SETCDR (handle, alist);
+ scm_hashq_set_x (object_whash, obj, alist);
scm_i_pthread_mutex_unlock (&whash_mutex);
return alist;
@@ -87,19 +84,16 @@ SCM_DEFINE (scm_set_object_property_x,
"set-object-property!", 3, 0, 0,
"to @var{value}.")
#define FUNC_NAME s_scm_set_object_property_x
{
- SCM h;
+ SCM alist;
SCM assoc;
scm_i_pthread_mutex_lock (&whash_mutex);
- h = scm_hashq_create_handle_x (object_whash, obj, SCM_EOL);
- assoc = scm_assq (key, SCM_CDR (h));
+ alist = scm_hashq_ref (object_whash, obj, SCM_EOL);
+ assoc = scm_assq (key, alist);
if (SCM_NIMP (assoc))
SCM_SETCDR (assoc, value);
else
- {
- assoc = scm_acons (key, value, SCM_CDR (h));
- SCM_SETCDR (h, assoc);
- }
+ scm_hashq_set_x (object_whash, obj, scm_acons (key, value, alist));
scm_i_pthread_mutex_unlock (&whash_mutex);
return value;
diff --git a/libguile/read.c b/libguile/read.c
index 4b6828b..b36c27c 100644
--- a/libguile/read.c
+++ b/libguile/read.c
@@ -442,14 +442,14 @@ scm_read_sexp (scm_t_wchar chr, SCM port)
exit:
if (SCM_RECORD_POSITIONS_P)
- scm_whash_insert (scm_source_whash,
- ans,
- scm_make_srcprops (line, column,
- SCM_FILENAME (port),
- SCM_COPY_SOURCE_P
- ? ans2
- : SCM_UNDEFINED,
- SCM_EOL));
+ scm_hashq_set_x (scm_source_whash,
+ ans,
+ scm_make_srcprops (line, column,
+ SCM_FILENAME (port),
+ SCM_COPY_SOURCE_P
+ ? ans2
+ : SCM_UNDEFINED,
+ SCM_EOL));
return ans;
}
#undef FUNC_NAME
@@ -805,15 +805,15 @@ scm_read_quote (int chr, SCM port)
p = scm_cons2 (p, scm_read_expression (port), SCM_EOL);
if (SCM_RECORD_POSITIONS_P)
- scm_whash_insert (scm_source_whash, p,
- scm_make_srcprops (line, column,
- SCM_FILENAME (port),
- SCM_COPY_SOURCE_P
- ? (scm_cons2 (SCM_CAR (p),
- SCM_CAR (SCM_CDR (p)),
- SCM_EOL))
- : SCM_UNDEFINED,
- SCM_EOL));
+ scm_hashq_set_x (scm_source_whash, p,
+ scm_make_srcprops (line, column,
+ SCM_FILENAME (port),
+ SCM_COPY_SOURCE_P
+ ? (scm_cons2 (SCM_CAR (p),
+ SCM_CAR (SCM_CDR (p)),
+ SCM_EOL))
+ : SCM_UNDEFINED,
+ SCM_EOL));
return p;
@@ -864,15 +864,15 @@ scm_read_syntax (int chr, SCM port)
p = scm_cons2 (p, scm_read_expression (port), SCM_EOL);
if (SCM_RECORD_POSITIONS_P)
- scm_whash_insert (scm_source_whash, p,
- scm_make_srcprops (line, column,
- SCM_FILENAME (port),
- SCM_COPY_SOURCE_P
- ? (scm_cons2 (SCM_CAR (p),
- SCM_CAR (SCM_CDR (p)),
- SCM_EOL))
- : SCM_UNDEFINED,
- SCM_EOL));
+ scm_hashq_set_x (scm_source_whash, p,
+ scm_make_srcprops (line, column,
+ SCM_FILENAME (port),
+ SCM_COPY_SOURCE_P
+ ? (scm_cons2 (SCM_CAR (p),
+ SCM_CAR (SCM_CDR (p)),
+ SCM_EOL))
+ : SCM_UNDEFINED,
+ SCM_EOL));
return p;
@@ -1561,7 +1561,7 @@ recsexpr (SCM obj, long line, int column, SCM filename)
/* If this sexpr is visible in the read:sharp source, we want to
keep that information, so only record non-constant cons cells
which haven't previously been read by the reader. */
- if (scm_is_false (scm_whash_lookup (scm_source_whash, obj)))
+ if (scm_is_false (scm_hashq_ref (scm_source_whash, obj, SCM_BOOL_F)))
{
if (SCM_COPY_SOURCE_P)
{
@@ -1585,13 +1585,13 @@ recsexpr (SCM obj, long line, int column, SCM filename)
recsexpr (SCM_CAR (tmp), line, column, filename);
copy = SCM_UNDEFINED;
}
- scm_whash_insert (scm_source_whash,
- obj,
- scm_make_srcprops (line,
- column,
- filename,
- copy,
- SCM_EOL));
+ scm_hashq_set_x (scm_source_whash,
+ obj,
+ scm_make_srcprops (line,
+ column,
+ filename,
+ copy,
+ SCM_EOL));
}
return obj;
}
diff --git a/libguile/srcprop.c b/libguile/srcprop.c
index 003abc5..f9b000c 100644
--- a/libguile/srcprop.c
+++ b/libguile/srcprop.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002, 2006, 2008, 2009,
2010 Free Software Foundation
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002, 2006, 2008, 2009,
2010, 2011 Free Software Foundation
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -180,10 +180,8 @@ SCM_DEFINE (scm_set_source_properties_x,
"set-source-properties!", 2, 0, 0,
"list for @var{obj}.")
#define FUNC_NAME s_scm_set_source_properties_x
{
- SCM handle;
SCM_VALIDATE_NIM (1, obj);
- handle = scm_hashq_create_handle_x (scm_source_whash, obj, alist);
- SCM_SETCDR (handle, alist);
+ scm_hashq_set_x (scm_source_whash, obj, alist);
return alist;
}
#undef FUNC_NAME
@@ -222,49 +220,43 @@ SCM_DEFINE (scm_set_source_property_x,
"set-source-property!", 3, 0, 0,
"@var{key} to @var{datum}. Normally, the key will be a symbol.")
#define FUNC_NAME s_scm_set_source_property_x
{
- scm_whash_handle h;
SCM p;
SCM_VALIDATE_NIM (1, obj);
- h = scm_whash_get_handle (scm_source_whash, obj);
- if (SCM_WHASHFOUNDP (h))
- p = SCM_WHASHREF (scm_source_whash, h);
- else
- {
- h = scm_whash_create_handle (scm_source_whash, obj);
- p = SCM_EOL;
- }
+ p = scm_hashq_ref (scm_source_whash, obj, SCM_EOL);
if (scm_is_eq (scm_sym_line, key))
{
if (SRCPROPSP (p))
SETSRCPROPLINE (p, scm_to_int (datum));
else
- SCM_WHASHSET (scm_source_whash, h,
- scm_make_srcprops (scm_to_int (datum), 0,
- SCM_UNDEFINED, SCM_UNDEFINED, p));
+ scm_hashq_set_x (scm_source_whash, obj,
+ scm_make_srcprops (scm_to_int (datum), 0,
+ SCM_UNDEFINED, SCM_UNDEFINED, p));
}
else if (scm_is_eq (scm_sym_column, key))
{
if (SRCPROPSP (p))
SETSRCPROPCOL (p, scm_to_int (datum));
else
- SCM_WHASHSET (scm_source_whash, h,
- scm_make_srcprops (0, scm_to_int (datum),
- SCM_UNDEFINED, SCM_UNDEFINED, p));
+ scm_hashq_set_x (scm_source_whash, obj,
+ scm_make_srcprops (0, scm_to_int (datum),
+ SCM_UNDEFINED, SCM_UNDEFINED, p));
}
else if (scm_is_eq (scm_sym_copy, key))
{
if (SRCPROPSP (p))
SETSRCPROPCOPY (p, datum);
else
- SCM_WHASHSET (scm_source_whash, h, scm_make_srcprops (0, 0,
SCM_UNDEFINED, datum, p));
+ scm_hashq_set_x (scm_source_whash, obj,
+ scm_make_srcprops (0, 0, SCM_UNDEFINED, datum, p));
}
else
{
if (SRCPROPSP (p))
SETSRCPROPALIST (p, scm_acons (key, datum, SRCPROPALIST (p)));
else
- SCM_WHASHSET (scm_source_whash, h, scm_acons (key, datum, p));
+ scm_hashq_set_x (scm_source_whash, obj,
+ scm_acons (key, datum, p));
}
return SCM_UNSPECIFIED;
}
@@ -281,9 +273,9 @@ SCM_DEFINE (scm_cons_source, "cons-source", 3, 0, 0,
SCM p, z;
z = scm_cons (x, y);
/* Copy source properties possibly associated with xorig. */
- p = scm_whash_lookup (scm_source_whash, xorig);
+ p = scm_hashq_ref (scm_source_whash, xorig, SCM_BOOL_F);
if (scm_is_true (p))
- scm_whash_insert (scm_source_whash, z, p);
+ scm_hashq_set_x (scm_source_whash, z, p);
return z;
}
#undef FUNC_NAME
diff --git a/libguile/srcprop.h b/libguile/srcprop.h
index 99b8482..5c9ccb9 100644
--- a/libguile/srcprop.h
+++ b/libguile/srcprop.h
@@ -3,7 +3,7 @@
#ifndef SCM_SRCPROP_H
#define SCM_SRCPROP_H
-/* Copyright (C) 1995,1996,2000,2001, 2006, 2008, 2009, 2010 Free Software
Foundation, Inc.
+/* Copyright (C) 1995,1996,2000,2001, 2006, 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
@@ -27,30 +27,6 @@
-/* {The old whash table interface}
- * *fixme* This is a temporary solution until weak hash table access
- * has been optimized for speed (which is quite necessary, if they are
- * used for recording of source code positions...)
- */
-
-#define scm_whash_handle SCM
-
-#define scm_whash_get_handle(whash, key) \
- scm_hashq_get_handle ((whash), (key))
-#define SCM_WHASHFOUNDP(h) (scm_is_true (h))
-#define SCM_WHASHREF(whash, handle) SCM_CDR (handle)
-#define SCM_WHASHSET(whash, handle, obj) SCM_SETCDR (handle, obj)
-#define scm_whash_create_handle(whash, key) \
- scm_hashq_create_handle_x ((whash), (key), SCM_UNSPECIFIED)
-#define scm_whash_lookup(whash, obj) \
- scm_hashq_ref ((whash), (obj), SCM_BOOL_F)
-#define scm_whash_insert(whash, key, obj) \
-do { \
- register SCM w = (whash); \
- SCM_WHASHSET (w, scm_whash_create_handle (w, key), obj); \
-} while (0)
-
-
/* {Source properties}
*/
#define SCM_PROCTRACEP(x) (scm_is_true (scm_procedure_property (x,
scm_sym_trace)))
diff --git a/libguile/struct.c b/libguile/struct.c
index e5ecc1a..4a2a9d7 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 7a4d635..c3c7d8f 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 *);
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 401d904..294b915 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -3048,6 +3048,8 @@ module '(ice-9 q) '(make-q q-length))}."
(let* ((internal-name (if (pair? name) (car name) name))
(external-name (if (pair? name) (cdr name) name))
(var (module-ensure-local-variable! m internal-name)))
+ ;; FIXME: use a bit on variables instead of object
+ ;; properties.
(set-object-property! var 'replace #t)
(module-add! public-i external-name var)))
names)))
diff --git a/module/ice-9/poe.scm b/module/ice-9/poe.scm
index e7b6e3a..c19a760 100644
--- a/module/ice-9/poe.scm
+++ b/module/ice-9/poe.scm
@@ -1,6 +1,6 @@
;;; installed-scm-file
-;;;; Copyright (C) 1996, 2001, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 1996, 2001, 2006, 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
@@ -74,17 +74,19 @@
(funcq-assoc arg-list (cdr alist)))))
+(define not-found (list 'not-found))
+
(define (pure-funcq base-func)
(lambda args
- (let ((cached (hashx-get-handle funcq-hash funcq-assoc funcq-memo (cons
base-func args))))
- (if cached
+ (let* ((key (cons base-func args))
+ (cached (hashx-ref funcq-hash funcq-assoc funcq-memo key
not-found)))
+ (if (not (eq? cached not-found))
(begin
- (funcq-buffer (car cached))
- (cdr cached))
+ (funcq-buffer key)
+ cached)
- (let ((val (apply base-func args))
- (key (cons base-func args)))
+ (let ((val (apply base-func args)))
(funcq-buffer key)
(hashx-set! funcq-hash funcq-assoc funcq-memo key val)
val)))))
@@ -101,22 +103,14 @@
(define funcq-memo (make-hash-table size))
(lambda args
- (let ((cached (hashx-get-handle funcq-hash funcq-assoc funcq-memo (cons
base-func args))))
- (if cached
+ (let* ((key (cons base-func args))
+ (cached (hashx-ref funcq-hash funcq-assoc funcq-memo key
not-found)))
+ (if (not (eq? cached not-found))
(begin
- (funcq-buffer (car cached))
- (cdr cached))
+ (funcq-buffer key)
+ cached)
- (let ((val (apply base-func args))
- (key (cons base-func args)))
+ (let ((val (apply base-func args)))
(funcq-buffer key)
(hashx-set! funcq-hash funcq-assoc funcq-memo key val)
val)))))
-
-
-
-
-
-
-
-
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.1-17-gf3c6a02,
Andy Wingo <=