Changeset 18340 in project


Ignore:
Timestamp:
06/04/10 13:54:39 (11 years ago)
Author:
felix winkelmann
Message:

more coops tweaks

Location:
release/4/coops/trunk
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • release/4/coops/trunk/coops-module.scm

    r18317 r18340  
    2929               class-name
    3030               initialize-instance
    31                define-class
     31               (define-class set-slot-value!)
    3232               define-generic
    3333               define-method
  • release/4/coops/trunk/coops.scm

    r18337 r18340  
    9999(define uninitialized (list 'uninitialized-slot))
    100100
     101(define (set-slot-value! obj f v)
     102  (let* ((obj
     103          (if (procedure? obj)
     104              (generic-procedure-instance obj)
     105              obj))
     106         (i (slot-lookup obj f)))
     107    (if i
     108        (##sys#setslot (coops-instance-slots obj) i v)
     109        (error 'slot-value "slot not found" f obj))))
     110
    101111(define slot-value
    102112  (getter-with-setter
     
    108118            (i (slot-lookup obj f)))
    109119       (if i
    110            (let ((val (vector-ref (coops-instance-slots obj) i)))
     120           (let ((val (##sys#slot (coops-instance-slots obj) i)))
    111121             (if (eq? val uninitialized)
    112122                 (error 'slot-value "reference to uninitialized slot" f obj)
    113123                 val))
    114124           (error 'slot-value "slot not found" f obj))))
    115    (lambda (obj f v)
    116      (let* ((obj
    117              (if (procedure? obj)
    118                  (generic-procedure-instance obj)
    119                  obj))
    120             (i (slot-lookup obj f)))
    121        (if i
    122            (vector-set! (coops-instance-slots obj) i v)
    123            (error 'slot-value "slot not found" f obj))))))
     125   set-slot-value!))
    124126
    125127(define slot-ref slot-value)            ; OBSOLETE (for instance-of foreign type in older chickens)
     
    128130  (let ((i (slot-lookup obj slotname)))
    129131    (if i
    130         (not (eq? (vector-ref (coops-instance-slots obj) i) uninitialized))
     132        (not (eq? (##sys#slot (coops-instance-slots obj) i) uninitialized))
    131133        (error "slot not found" slotname obj))))
    132134
     
    144146  (lambda (c . svsv)
    145147    (let* ((slotnames
    146             (vector-ref
     148            (##sys#slot
    147149             (coops-instance-slots c)
    148150             +standard-class-slotnames-slot+))
     
    157159               i)
    158160              ((null? (cdr svsv))
    159                (error "missing slot value" (car svsv) i))
     161               (error 'make "missing slot value" (car svsv) i))
    160162              (else
    161                (vector-set! sv (slot-index (car svsv)) (cadr svsv))
     163               (##sys#setslot sv (slot-index (car svsv)) (cadr svsv))
    162164               (loop (cddr svsv))))))))
    163165
     
    646648       (lambda (slot init)
    647649         (when (and init (not (slot-initialized? obj slot)))
    648            (set! (slot-value obj slot) (init))))
     650           (set-slot-value! obj slot (init))))
    649651       (slot-value class 'slots)
    650652       (slot-value class 'initthunks)))))
     
    664666        (%setter (r 'setter))
    665667        (%<standard-object> (r '<standard-object>))
    666         (%slot-value (r 'slot-value)))
     668        (%slot-value (r 'slot-value))
     669        (%set-slot-value! (r 'set-slot-value!)))
    667670    (define (genclass name supers slotnames meta)
    668671      `(,%define
     
    701704             (,%define-method
    702705              (,name (x ,classname) y)
    703               (,%set! (,%slot-value x ',slotname) y))
     706              (,%set-slot-value! x ',slotname y))
    704707             ,(loop more)))
    705708          (('accessor: name . more)
     
    710713             (,%define-method
    711714              ((,%setter ,name) (x ,classname) y)
    712               (,%set! (,%slot-value x ',slotname) y))
     715              (,%set-slot-value! x ',slotname y))
    713716             ,(loop more)))
    714717          (('initform: form . more)
Note: See TracChangeset for help on using the changeset viewer.