mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-02 04:40:29 +02:00
* goops.scm (compute-getters-n-setters/verify-accessors): Better
check of format of value returned by compute-get-n-set. (compute-getters-n-setters): Extended format of slot getters-n-setters to indicate position and size of slot memory allocated in instances. * goops.c (scm_sys_prep_layout_x): Instance allocation is now indicated through extra fields in getters-n-setters. (scm_add_slot): Adapted to new format of getters_n_setters slot. (Thanks to Andy Wingo.)
This commit is contained in:
Mikael Djurfeldt
parent
5735d351cf
commit
55ccbd3545
5 changed files with 144 additions and 62 deletions
1
THANKS
1
THANKS
|
|
@ -80,4 +80,5 @@ For fixes or providing information which led to a fix:
|
|||
Panagiotis Vossos
|
||||
Thomas Wawrzinek
|
||||
Florian Weimer
|
||||
Andy Wingo
|
||||
Keith Wright
|
||||
|
|
|
|||
|
|
@ -1,3 +1,10 @@
|
|||
2003-04-13 Mikael Djurfeldt <djurfeldt@nada.kth.se>
|
||||
|
||||
* goops.c (scm_sys_prep_layout_x): Instance allocation is now
|
||||
indicated through extra fields in getters-n-setters.
|
||||
(scm_add_slot): Adapted to new format of getters_n_setters slot.
|
||||
(Thanks to Andy Wingo.)
|
||||
|
||||
2003-04-12 Rob Browning <rlb@defaultvalue.org>
|
||||
|
||||
* backtrace.c (display_backtrace_file): correct a couple of
|
||||
|
|
|
|||
142
libguile/goops.c
142
libguile/goops.c
|
|
@ -471,6 +471,22 @@ SCM_DEFINE (scm_sys_initialize_object, "%initialize-object", 2, 0, 0,
|
|||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
/* NOTE: The following macros are interdependent with code
|
||||
* in goops.scm:compute-getters-n-setters
|
||||
*/
|
||||
#define SCM_GNS_INSTANCE_ALLOCATED_P(gns) \
|
||||
(SCM_INUMP (SCM_CDDR (gns)) \
|
||||
|| (SCM_CONSP (SCM_CDDR (gns)) \
|
||||
&& SCM_CONSP (SCM_CDDDR (gns)) \
|
||||
&& SCM_CONSP (SCM_CDDDDR (gns))))
|
||||
#define SCM_GNS_INDEX(gns) \
|
||||
(SCM_INUMP (SCM_CDDR (gns)) \
|
||||
? SCM_INUM (SCM_CDDR (gns)) \
|
||||
: SCM_INUM (SCM_CAR (SCM_CDDDDR (gns))))
|
||||
#define SCM_GNS_SIZE(gns) \
|
||||
(SCM_INUMP (SCM_CDDR (gns)) \
|
||||
? 1 \
|
||||
: SCM_INUM (SCM_CADR (SCM_CDDDDR (gns))))
|
||||
|
||||
SCM_KEYWORD (k_class, "class");
|
||||
SCM_KEYWORD (k_allocation, "allocation");
|
||||
|
|
@ -481,12 +497,13 @@ SCM_DEFINE (scm_sys_prep_layout_x, "%prep-layout!", 1, 0, 0,
|
|||
"")
|
||||
#define FUNC_NAME s_scm_sys_prep_layout_x
|
||||
{
|
||||
long i, n, len;
|
||||
char *s, p, a;
|
||||
SCM nfields, slots, type, allocation;
|
||||
SCM slots, getters_n_setters, nfields;
|
||||
unsigned long int n, i;
|
||||
char *s;
|
||||
|
||||
SCM_VALIDATE_INSTANCE (1, class);
|
||||
slots = SCM_SLOT (class, scm_si_slots);
|
||||
getters_n_setters = SCM_SLOT (class, scm_si_getters_n_setters);
|
||||
nfields = SCM_SLOT (class, scm_si_nfields);
|
||||
if (!SCM_INUMP (nfields) || SCM_INUM (nfields) < 0)
|
||||
SCM_MISC_ERROR ("bad value in nfields slot: ~S",
|
||||
|
|
@ -498,46 +515,79 @@ SCM_DEFINE (scm_sys_prep_layout_x, "%prep-layout!", 1, 0, 0,
|
|||
scm_list_1 (nfields));
|
||||
|
||||
s = n > 0 ? scm_must_malloc (n, FUNC_NAME) : 0;
|
||||
for (i = 0; i < n; i += 2)
|
||||
i = 0;
|
||||
while (SCM_CONSP (getters_n_setters))
|
||||
{
|
||||
if (!SCM_CONSP (slots))
|
||||
SCM_MISC_ERROR ("to few slot definitions", SCM_EOL);
|
||||
len = scm_ilength (SCM_CDAR (slots));
|
||||
allocation = scm_i_get_keyword (k_allocation, SCM_CDAR (slots),
|
||||
len, k_instance, FUNC_NAME);
|
||||
while (!SCM_EQ_P (allocation, k_instance))
|
||||
if (SCM_GNS_INSTANCE_ALLOCATED_P (SCM_CAR (getters_n_setters)))
|
||||
{
|
||||
slots = SCM_CDR (slots);
|
||||
len = scm_ilength (SCM_CDAR (slots));
|
||||
allocation = scm_i_get_keyword (k_allocation, SCM_CDAR (slots),
|
||||
len, k_instance, FUNC_NAME);
|
||||
}
|
||||
type = scm_i_get_keyword (k_class, SCM_CDAR (slots),
|
||||
len, SCM_BOOL_F, FUNC_NAME);
|
||||
if (SCM_NIMP (type) && SCM_SUBCLASSP (type, scm_class_foreign_slot))
|
||||
{
|
||||
if (SCM_SUBCLASSP (type, scm_class_self))
|
||||
p = 's';
|
||||
else if (SCM_SUBCLASSP (type, scm_class_protected))
|
||||
p = 'p';
|
||||
else
|
||||
p = 'u';
|
||||
SCM type;
|
||||
int len, index, size;
|
||||
char p, a;
|
||||
|
||||
if (SCM_SUBCLASSP (type, scm_class_opaque))
|
||||
a = 'o';
|
||||
else if (SCM_SUBCLASSP (type, scm_class_read_only))
|
||||
a = 'r';
|
||||
if (i >= n || !SCM_CONSP (slots))
|
||||
goto inconsistent;
|
||||
|
||||
/* extract slot type */
|
||||
len = scm_ilength (SCM_CDAR (slots));
|
||||
type = scm_i_get_keyword (k_class, SCM_CDAR (slots),
|
||||
len, SCM_BOOL_F, FUNC_NAME);
|
||||
/* determine slot GC protection and access mode */
|
||||
if (SCM_FALSEP (type))
|
||||
{
|
||||
p = 'p';
|
||||
a = 'w';
|
||||
}
|
||||
else
|
||||
a = 'w';
|
||||
{
|
||||
if (!SCM_CLASSP (type))
|
||||
{
|
||||
if (s)
|
||||
free (s);
|
||||
SCM_MISC_ERROR ("bad slot class", SCM_EOL);
|
||||
}
|
||||
else if (SCM_SUBCLASSP (type, scm_class_foreign_slot))
|
||||
{
|
||||
if (SCM_SUBCLASSP (type, scm_class_self))
|
||||
p = 's';
|
||||
else if (SCM_SUBCLASSP (type, scm_class_protected))
|
||||
p = 'p';
|
||||
else
|
||||
p = 'u';
|
||||
|
||||
if (SCM_SUBCLASSP (type, scm_class_opaque))
|
||||
a = 'o';
|
||||
else if (SCM_SUBCLASSP (type, scm_class_read_only))
|
||||
a = 'r';
|
||||
else
|
||||
a = 'w';
|
||||
}
|
||||
else
|
||||
{
|
||||
p = 'p';
|
||||
a = 'w';
|
||||
}
|
||||
}
|
||||
|
||||
index = SCM_GNS_INDEX (SCM_CAR (getters_n_setters));
|
||||
if (index != (i >> 1))
|
||||
goto inconsistent;
|
||||
size = SCM_GNS_SIZE (SCM_CAR (getters_n_setters));
|
||||
while (size)
|
||||
{
|
||||
s[i++] = p;
|
||||
s[i++] = a;
|
||||
--size;
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
p = 'p';
|
||||
a = 'w';
|
||||
}
|
||||
s[i] = p;
|
||||
s[i + 1] = a;
|
||||
slots = SCM_CDR (slots);
|
||||
getters_n_setters = SCM_CDR (getters_n_setters);
|
||||
}
|
||||
if (!SCM_NULLP (slots))
|
||||
{
|
||||
inconsistent:
|
||||
if (s)
|
||||
free (s);
|
||||
SCM_MISC_ERROR ("inconsistent getters-n-setters", SCM_EOL);
|
||||
}
|
||||
SCM_SET_SLOT (class, scm_si_layout, scm_mem2symbol (s, n));
|
||||
if (s)
|
||||
|
|
@ -2541,8 +2591,6 @@ scm_add_slot (SCM class, char *slot_name, SCM slot_class,
|
|||
slot_class,
|
||||
setter ? k_accessor : k_getter,
|
||||
gf);
|
||||
SCM gns = scm_list_4 (name, SCM_BOOL_F, get, set);
|
||||
|
||||
scm_add_method (gf, scm_make (scm_list_5 (scm_class_accessor,
|
||||
k_specializers,
|
||||
scm_list_1 (class),
|
||||
|
|
@ -2559,16 +2607,16 @@ scm_add_slot (SCM class, char *slot_name, SCM slot_class,
|
|||
SCM_SET_SLOT (class, scm_si_slots,
|
||||
scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_slots),
|
||||
scm_list_1 (slot))));
|
||||
SCM_SET_SLOT (class, scm_si_getters_n_setters,
|
||||
scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_getters_n_setters),
|
||||
scm_list_1 (gns))));
|
||||
{
|
||||
SCM n = SCM_SLOT (class, scm_si_nfields);
|
||||
SCM gns = scm_list_n (name, SCM_BOOL_F, get, set, n, SCM_MAKINUM (1));
|
||||
SCM_SET_SLOT (class, scm_si_getters_n_setters,
|
||||
scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_getters_n_setters),
|
||||
scm_list_1 (gns))));
|
||||
SCM_SET_SLOT (class, scm_si_nfields, SCM_MAKINUM (SCM_INUM (n) + 1));
|
||||
}
|
||||
}
|
||||
}
|
||||
{
|
||||
long n = SCM_INUM (SCM_SLOT (class, scm_si_nfields));
|
||||
|
||||
SCM_SET_SLOT (class, scm_si_nfields, SCM_MAKINUM (n + 1));
|
||||
}
|
||||
}
|
||||
|
||||
SCM
|
||||
|
|
|
|||
|
|
@ -1,3 +1,11 @@
|
|||
2003-04-13 Mikael Djurfeldt <djurfeldt@nada.kth.se>
|
||||
|
||||
* goops.scm (compute-getters-n-setters/verify-accessors): Better
|
||||
check of format of value returned by compute-get-n-set.
|
||||
(compute-getters-n-setters): Extended format of slot
|
||||
getters-n-setters to indicate position and size of slot memory
|
||||
allocated in instances.
|
||||
|
||||
2002-12-08 Rob Browning <rlb@defaultvalue.org>
|
||||
|
||||
* Makefile.am (subpkgdatadir): VERSION -> GUILE_EFFECTIVE_VERSION.
|
||||
|
|
|
|||
|
|
@ -1043,27 +1043,45 @@
|
|||
(lambda () init)))))
|
||||
|
||||
(define (verify-accessors slot l)
|
||||
(if (pair? l)
|
||||
(let ((get (car l))
|
||||
(set (cadr l)))
|
||||
(if (not (and (closure? get)
|
||||
(= (car (procedure-property get 'arity)) 1)))
|
||||
(goops-error "Bad getter closure for slot `~S' in ~S: ~S"
|
||||
slot class get))
|
||||
(if (not (and (closure? set)
|
||||
(= (car (procedure-property set 'arity)) 2)))
|
||||
(goops-error "Bad setter closure for slot `~S' in ~S: ~S"
|
||||
slot class set)))))
|
||||
(cond ((integer? l))
|
||||
((not (and (list? l) (= (length l) 2)))
|
||||
(goops-error "Bad getter and setter for slot `~S' in ~S: ~S"
|
||||
slot class l))
|
||||
(else
|
||||
(let ((get (car l))
|
||||
(set (cadr l)))
|
||||
(if (not (and (closure? get)
|
||||
(= (car (procedure-property get 'arity)) 1)))
|
||||
(goops-error "Bad getter closure for slot `~S' in ~S: ~S"
|
||||
slot class get))
|
||||
(if (not (and (closure? set)
|
||||
(= (car (procedure-property set 'arity)) 2)))
|
||||
(goops-error "Bad setter closure for slot `~S' in ~S: ~S"
|
||||
slot class set))))))
|
||||
|
||||
(map (lambda (s)
|
||||
(let* ((g-n-s (compute-get-n-set class s))
|
||||
;; The strange treatment of nfields is due to backward compatibility.
|
||||
(let* ((index (slot-ref class 'nfields))
|
||||
(g-n-s (compute-get-n-set class s))
|
||||
(size (- (slot-ref class 'nfields) index))
|
||||
(name (slot-definition-name s)))
|
||||
; For each slot we have '(name init-function getter setter)
|
||||
; If slot, we have the simplest form '(name init-function . index)
|
||||
;; NOTE: The following is interdependent with C macros
|
||||
;; defined above goops.c:scm_sys_prep_layout_x.
|
||||
;;
|
||||
;; For simple instance slots, we have the simplest form
|
||||
;; '(name init-function . index)
|
||||
;; For other slots we have
|
||||
;; '(name init-function getter setter . alloc)
|
||||
;; where alloc is:
|
||||
;; '(index size) for instance allocated slots
|
||||
;; '() for other slots
|
||||
(verify-accessors name g-n-s)
|
||||
(cons name
|
||||
(cons (compute-slot-init-function s)
|
||||
g-n-s))))
|
||||
(if (or (integer? g-n-s)
|
||||
(zero? size))
|
||||
g-n-s
|
||||
(append g-n-s index size))))))
|
||||
slots))
|
||||
|
||||
;;; compute-cpl
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue