1193 |
(lambda () init))))) |
(lambda () init))))) |
1194 |
|
|
1195 |
(define (verify-accessors slot l) |
(define (verify-accessors slot l) |
1196 |
(if (pair? l) |
(cond ((integer? l)) |
1197 |
(let ((get (car l)) |
((not (and (list? l) (= (length l) 2))) |
1198 |
(set (cadr l))) |
(goops-error "Bad getter and setter for slot `~S' in ~S: ~S" |
1199 |
(if (not (and (closure? get) |
slot class l)) |
1200 |
(= (car (procedure-property get 'arity)) 1))) |
(else |
1201 |
(goops-error "Bad getter closure for slot `~S' in ~S: ~S" |
(let ((get (car l)) |
1202 |
slot class get)) |
(set (cadr l))) |
1203 |
(if (not (and (closure? set) |
(if (not (and (closure? get) |
1204 |
(= (car (procedure-property set 'arity)) 2))) |
(= (car (procedure-property get 'arity)) 1))) |
1205 |
(goops-error "Bad setter closure for slot `~S' in ~S: ~S" |
(goops-error "Bad getter closure for slot `~S' in ~S: ~S" |
1206 |
slot class set))))) |
slot class get)) |
1207 |
|
(if (not (and (closure? set) |
1208 |
|
(= (car (procedure-property set 'arity)) 2))) |
1209 |
|
(goops-error "Bad setter closure for slot `~S' in ~S: ~S" |
1210 |
|
slot class set)))))) |
1211 |
|
|
1212 |
(map (lambda (s) |
(map (lambda (s) |
1213 |
(let* ((g-n-s (compute-get-n-set class s)) |
;; The strange treatment of nfields is due to backward compatibility. |
1214 |
|
(let* ((index (slot-ref class 'nfields)) |
1215 |
|
(g-n-s (compute-get-n-set class s)) |
1216 |
|
(size (- (slot-ref class 'nfields) index)) |
1217 |
(name (slot-definition-name s))) |
(name (slot-definition-name s))) |
1218 |
; For each slot we have '(name init-function getter setter) |
;; NOTE: The following is interdependent with C macros |
1219 |
; If slot, we have the simplest form '(name init-function . index) |
;; defined above goops.c:scm_sys_prep_layout_x. |
1220 |
|
;; |
1221 |
|
;; For simple instance slots, we have the simplest form |
1222 |
|
;; '(name init-function . index) |
1223 |
|
;; For other slots we have |
1224 |
|
;; '(name init-function getter setter . alloc) |
1225 |
|
;; where alloc is: |
1226 |
|
;; '(index size) for instance allocated slots |
1227 |
|
;; '() for other slots |
1228 |
(verify-accessors name g-n-s) |
(verify-accessors name g-n-s) |
1229 |
(cons name |
(cons name |
1230 |
(cons (compute-slot-init-function s) |
(cons (compute-slot-init-function s) |
1231 |
g-n-s)))) |
(if (or (integer? g-n-s) |
1232 |
|
(zero? size)) |
1233 |
|
g-n-s |
1234 |
|
(append g-n-s index size)))))) |
1235 |
slots)) |
slots)) |
1236 |
|
|
1237 |
;;; compute-cpl |
;;; compute-cpl |