mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-01 04:10:18 +02:00
* Goops does not provide its own version of logand any more.
* Removed use of deprecated stuff from goops.
This commit is contained in:
Dirk Herrmann
parent
379b35daaa
commit
ca83b028dc
6 changed files with 48 additions and 67 deletions
|
|
@ -1,3 +1,19 @@
|
|||
2000-11-24 Dirk Herrmann <D.Herrmann@tu-bs.de>
|
||||
|
||||
* goops.c: Include validate.h.
|
||||
|
||||
(DEFVAR, scm_add_method): Don't use deprecated scm_eval2.
|
||||
|
||||
(scm_sys_fast_slot_ref, scm_sys_fast_slot_set_x,
|
||||
scm_m_atdispatch): Provide FUNC_NAME definition. Don't use
|
||||
deprecated SCM_OUTOFRANGE macro.
|
||||
|
||||
(scm_sloppy_num2ulong, scm_sys_logand): Removed. Guile's logand
|
||||
function now provides the desired behaviour.
|
||||
|
||||
* goops.c (filter_cpl, remove_duplicate_slots), goops.h
|
||||
(SCM_SUBCLASSP): Don't use deprecated scm_sloppy_memq.
|
||||
|
||||
2000-11-23 Dirk Herrmann <D.Herrmann@tu-bs.de>
|
||||
|
||||
* symbols.h (SCM_LENGTH_MAX): Deprecated.
|
||||
|
|
|
|||
|
|
@ -69,6 +69,7 @@
|
|||
#include "libguile/vectors.h"
|
||||
#include "libguile/weaks.h"
|
||||
|
||||
#include "libguile/validate.h"
|
||||
#include "libguile/goops.h"
|
||||
|
||||
#define CLASSP(x) (SCM_STRUCTP (x) \
|
||||
|
|
@ -81,8 +82,8 @@
|
|||
|
||||
|
||||
#define DEFVAR(v,val) \
|
||||
{ scm_eval2 (SCM_LIST3 (scm_sym_define_public, (v), (val)), \
|
||||
scm_goops_lookup_closure); }
|
||||
{ scm_i_eval (SCM_LIST3 (scm_sym_define_public, (v), (val)), \
|
||||
scm_top_level_env (scm_goops_lookup_closure)); }
|
||||
/* Temporary hack until we get the new module system */
|
||||
/*fixme* Should optimize by keeping track of the variable object itself */
|
||||
#define GETVAR(v) (SCM_CDDR (scm_apply (scm_goops_lookup_closure, \
|
||||
|
|
@ -217,7 +218,7 @@ filter_cpl (SCM ls)
|
|||
while (SCM_NIMP (ls))
|
||||
{
|
||||
SCM el = SCM_CAR (ls);
|
||||
if (SCM_IMP (scm_sloppy_memq (el, res)))
|
||||
if (SCM_IMP (scm_memq (el, res)))
|
||||
res = scm_cons (el, res);
|
||||
ls = SCM_CDR (ls);
|
||||
}
|
||||
|
|
@ -258,7 +259,7 @@ remove_duplicate_slots (SCM l, SCM res, SCM slots_already_seen)
|
|||
"bad slot name ~S",
|
||||
SCM_LIST1 (tmp));
|
||||
|
||||
if (SCM_NULLP (scm_sloppy_memq (tmp, slots_already_seen))) {
|
||||
if (SCM_NULLP (scm_memq (tmp, slots_already_seen))) {
|
||||
res = scm_cons (SCM_CAR (l), res);
|
||||
slots_already_seen = scm_cons (tmp, slots_already_seen);
|
||||
}
|
||||
|
|
@ -991,6 +992,7 @@ SCM_PROC (s_sys_fast_slot_ref, "%fast-slot-ref", 2, 0, 0, scm_sys_fast_slot_ref)
|
|||
|
||||
SCM
|
||||
scm_sys_fast_slot_ref (SCM obj, SCM index)
|
||||
#define FUNC_NAME s_sys_fast_slot_ref
|
||||
{
|
||||
register long i;
|
||||
|
||||
|
|
@ -998,15 +1000,18 @@ scm_sys_fast_slot_ref (SCM obj, SCM index)
|
|||
obj, SCM_ARG1, s_sys_fast_slot_ref);
|
||||
SCM_ASSERT (SCM_INUMP (index), index, SCM_ARG2, s_sys_fast_slot_ref);
|
||||
i = SCM_INUM (index);
|
||||
SCM_ASSERT (i >= 0 && i < SCM_NUMBER_OF_SLOTS (obj),
|
||||
index, SCM_OUTOFRANGE, s_sys_fast_slot_ref);
|
||||
|
||||
SCM_ASSERT_RANGE (2, index, i >= 0 && i < SCM_NUMBER_OF_SLOTS (obj));
|
||||
return scm_at_assert_bound_ref (obj, index);
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
|
||||
SCM_PROC (s_sys_fast_slot_set_x, "%fast-slot-set!", 3, 0, 0, scm_sys_fast_slot_set_x);
|
||||
|
||||
SCM
|
||||
scm_sys_fast_slot_set_x (SCM obj, SCM index, SCM value)
|
||||
#define FUNC_NAME s_sys_fast_slot_set_x
|
||||
{
|
||||
register long i;
|
||||
|
||||
|
|
@ -1014,12 +1019,13 @@ scm_sys_fast_slot_set_x (SCM obj, SCM index, SCM value)
|
|||
obj, SCM_ARG1, s_sys_fast_slot_set_x);
|
||||
SCM_ASSERT (SCM_INUMP (index), index, SCM_ARG2, s_sys_fast_slot_set_x);
|
||||
i = SCM_INUM (index);
|
||||
SCM_ASSERT (i >= 0 && i < SCM_NUMBER_OF_SLOTS (obj),
|
||||
index, SCM_OUTOFRANGE, s_sys_fast_slot_set_x);
|
||||
|
||||
SCM_ASSERT_RANGE (2, index, i >= 0 && i < SCM_NUMBER_OF_SLOTS (obj));
|
||||
SCM_SLOT (obj, i) = value;
|
||||
|
||||
return SCM_UNSPECIFIED;
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
|
||||
/** Utilities **/
|
||||
|
||||
|
|
@ -1129,56 +1135,6 @@ test_slot_existence (SCM class, SCM obj, SCM slot_name)
|
|||
return SCM_BOOL_F;
|
||||
}
|
||||
|
||||
/* The current libguile logand doesn't handle bignums.
|
||||
* This (primitive) version handles them up to 32 bits.
|
||||
*/
|
||||
|
||||
SCM_PROC1 (s_sys_logand, "%logand", scm_tc7_asubr, scm_sys_logand);
|
||||
|
||||
static unsigned long
|
||||
scm_sloppy_num2ulong (SCM num, char *pos, const char *s_caller)
|
||||
{
|
||||
unsigned long res;
|
||||
|
||||
if (SCM_INUMP (num))
|
||||
{
|
||||
if (SCM_INUM (num) < 0)
|
||||
goto out_of_range;
|
||||
res = SCM_INUM (num);
|
||||
return res;
|
||||
}
|
||||
SCM_ASRTGO (SCM_NIMP (num), wrong_type_arg);
|
||||
if (SCM_BIGP (num))
|
||||
{
|
||||
scm_sizet l;
|
||||
|
||||
res = 0;
|
||||
for (l = SCM_NUMDIGS (num); l--;)
|
||||
res = SCM_BIGUP (res) + SCM_BDIGITS (num)[l];
|
||||
return res;
|
||||
}
|
||||
wrong_type_arg:
|
||||
scm_wrong_type_arg (s_caller, (int) pos, num);
|
||||
out_of_range:
|
||||
scm_out_of_range (s_caller, num);
|
||||
}
|
||||
|
||||
static SCM
|
||||
scm_sys_logand (SCM n1, SCM n2)
|
||||
{
|
||||
if (SCM_UNBNDP (n2))
|
||||
{
|
||||
if (SCM_UNBNDP (n1))
|
||||
return SCM_MAKINUM (-1);
|
||||
return n1;
|
||||
}
|
||||
{
|
||||
unsigned long u1 = scm_sloppy_num2ulong (n1, (char *) 1, s_sys_logand);
|
||||
unsigned long u2 = scm_sloppy_num2ulong (n2, (char *) 2, s_sys_logand);
|
||||
return scm_ulong2num (u1 & u2);
|
||||
}
|
||||
}
|
||||
|
||||
/* ======================================== */
|
||||
|
||||
SCM_PROC (s_slot_ref_using_class, "slot-ref-using-class", 3, 0, 0, scm_slot_ref_using_class);
|
||||
|
|
@ -1951,6 +1907,7 @@ 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, xorig, scm_s_expression, s_atdispatch);
|
||||
|
|
@ -1960,7 +1917,7 @@ scm_m_atdispatch (SCM xorig, SCM env)
|
|||
x = SCM_CDR (x);
|
||||
n = SCM_XEVALCAR (x, env);
|
||||
SCM_ASSYNT (SCM_INUMP (n), n, SCM_ARG2, s_atdispatch);
|
||||
SCM_ASSYNT (SCM_INUM (n) >= 1, n, SCM_OUTOFRANGE, s_atdispatch);
|
||||
SCM_ASSERT_RANGE (0, n, SCM_INUM (n) >= 1);
|
||||
x = SCM_CDR (x);
|
||||
v = SCM_XEVALCAR (x, env);
|
||||
SCM_ASSYNT (SCM_NIMP (v) && SCM_VECTORP (v), v, SCM_ARG3, s_atdispatch);
|
||||
|
|
@ -1970,6 +1927,8 @@ scm_m_atdispatch (SCM xorig, SCM env)
|
|||
gf, SCM_ARG4, s_atdispatch);
|
||||
return SCM_LIST5 (SCM_IM_DISPATCH, args, n, v, gf);
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
|
||||
#ifdef USE_THREADS
|
||||
static void
|
||||
|
|
@ -2663,8 +2622,8 @@ SCM_SYMBOL (sym_internal_add_method_x, "internal-add-method!");
|
|||
void
|
||||
scm_add_method (SCM gf, SCM m)
|
||||
{
|
||||
scm_eval2 (SCM_LIST3 (sym_internal_add_method_x, gf, m),
|
||||
scm_goops_lookup_closure);
|
||||
scm_i_eval (SCM_LIST3 (sym_internal_add_method_x, gf, m),
|
||||
scm_top_level_env (scm_goops_lookup_closure));
|
||||
}
|
||||
|
||||
#ifdef GUILE_DEBUG
|
||||
|
|
|
|||
|
|
@ -134,7 +134,7 @@ typedef struct scm_method_t {
|
|||
| SCM_CLASSF_SIMPLE_METHOD))
|
||||
|
||||
#define SCM_SLOT(x, i) (SCM_INST(x)[i])
|
||||
#define SCM_SUBCLASSP(c1, c2) SCM_NNULLP (scm_sloppy_memq (c2, SCM_SLOT (c1, scm_si_cpl)))
|
||||
#define SCM_SUBCLASSP(c1, c2) SCM_NNULLP (scm_memq (c2, SCM_SLOT (c1, scm_si_cpl)))
|
||||
#define SCM_IS_A_P(x, c) (SCM_NIMP (x) \
|
||||
&& SCM_INSTANCEP (x) \
|
||||
&& SCM_SUBCLASSP (SCM_CLASS_OF (x), c))
|
||||
|
|
|
|||
|
|
@ -1,3 +1,10 @@
|
|||
2000-11-24 Dirk Herrmann <D.Herrmann@tu-bs.de>
|
||||
|
||||
* goops.scm: Don't export removed %logand any more.
|
||||
|
||||
* goops/dispatch.scm (cache-try-hash!): Use logand instead of
|
||||
%logand.
|
||||
|
||||
2000-11-06 Mikael Djurfeldt <mdj@linnaeus.mit.edu>
|
||||
|
||||
* goops.scm (internal-add-method!): Set n-specialized of a generic
|
||||
|
|
|
|||
|
|
@ -77,8 +77,7 @@
|
|||
generic-function-methods method-generic-function method-specializers
|
||||
primitive-generic-generic enable-primitive-generic!
|
||||
method-procedure accessor-method-slot-definition
|
||||
slot-exists? make find-method get-keyword
|
||||
%logand)
|
||||
slot-exists? make find-method get-keyword)
|
||||
|
||||
|
||||
(define min-fixnum (- (expt 2 29)))
|
||||
|
|
|
|||
|
|
@ -191,8 +191,8 @@
|
|||
(do ((ls entries (cdr ls))
|
||||
(misses 0 0))
|
||||
((null? ls) max-misses)
|
||||
(do ((i (%logand mask (cache-hashval hashset (car ls)))
|
||||
(%logand mask (+ i 1))))
|
||||
(do ((i (logand mask (cache-hashval hashset (car ls)))
|
||||
(logand mask (+ i 1))))
|
||||
((not (struct? (car (vector-ref cache i))))
|
||||
(vector-set! cache i (car ls)))
|
||||
(set! misses (+ 1 misses))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue