}
#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");
"")
#define FUNC_NAME s_scm_sys_prep_layout_x
{
- SCM slots, nfields;
+ 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",
scm_list_1 (nfields));
s = n > 0 ? scm_malloc (n) : 0;
- for (i = 0; i < n; i += 2)
+ i = 0;
+ while (SCM_CONSP (getters_n_setters))
{
- long len;
- SCM type, allocation;
- char p, a;
-
- if (!SCM_CONSP (slots))
- SCM_MISC_ERROR ("too 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);
+ SCM type;
+ int len, index, size;
+ char p, a;
+
+ if (i >= n || !SCM_CONSP (slots))
+ goto inconsistent;
+
+ /* extract slot type */
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_FALSEP (type))
- {
- p = 'p';
- a = 'w';
- }
- else
- {
- if (!SCM_CLASSP (type))
- SCM_MISC_ERROR ("bad slot class", SCM_EOL);
- else if (SCM_SUBCLASSP (type, scm_class_foreign_slot))
+ 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))
{
- 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';
+ p = 'p';
+ a = 'w';
}
else
{
- p = 'p';
- 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;
}
}
- 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)
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_method,
k_specializers,
scm_list_1 (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
(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
HCoop / bpt / guile.git / commitdiff