/[guile]/guile/guile-core/oop/goops.scm
ViewVC logotype

Diff of /guile/guile-core/oop/goops.scm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.29 by mvo, Sat Apr 5 19:13:56 2003 UTC revision 1.30 by mdj, Sun Apr 13 14:48:35 2003 UTC
# Line 1193  Line 1193 
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

Legend:
Removed from v.1.29  
changed lines
  Added in v.1.30

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26