diff --git a/THANKS b/THANKS index bfebcb52c..019c3e7ff 100644 --- a/THANKS +++ b/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 diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 7bb5c6761..e75f3eeb3 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,10 @@ +2003-04-13 Mikael Djurfeldt + + * 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 * backtrace.c (display_backtrace_file): correct a couple of diff --git a/libguile/goops.c b/libguile/goops.c index 04db9131f..5ef1e2d22 100644 --- a/libguile/goops.c +++ b/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 diff --git a/oop/ChangeLog b/oop/ChangeLog index 0f97cf936..325c8206f 100644 --- a/oop/ChangeLog +++ b/oop/ChangeLog @@ -1,3 +1,11 @@ +2003-04-13 Mikael Djurfeldt + + * 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 * Makefile.am (subpkgdatadir): VERSION -> GUILE_EFFECTIVE_VERSION. diff --git a/oop/goops.scm b/oop/goops.scm index b8f63ff27..0a130601d 100644 --- a/oop/goops.scm +++ b/oop/goops.scm @@ -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