mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-03 05:20:16 +02:00
Code Activity

* goops.scm (compute-getters-n-setters/verify-accessors): Better

Browse source 
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 2003-04-13 15:05:05 +00:00
parent 5735d351cf
commit 55ccbd3545
5 changed files with 144 additions and 62 deletions
Download patch file Download diff file Expand all files Collapse all files

8
oop/ChangeLog
View file

@ -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.

48
oop/goops.scm
View file

@ -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