Changeset 12757


Ignore:
Timestamp:
06/18/10 22:48:30 (12 years ago)
Author:
astalla
Message:

User-defined slot definition support: fixed slot-definition initialization.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/abcl/src/org/armedbear/lisp/clos.lisp

    r12756 r12757  
    164164            (readers ())
    165165            (writers ())
    166             (other-options ()))
     166            (other-options ())
     167      (non-std-options ()))
    167168        (do ((olist (cdr spec) (cddr olist)))
    168169            ((null olist))
     
    209210             (push-on-end `(setf ,(cadr olist)) writers))
    210211            (t
    211              (error 'program-error
    212                     "invalid initialization argument ~S for slot named ~S"
    213                     (car olist) name))))
     212       (push-on-end (car olist) non-std-options)
     213             (push-on-end (cadr olist) non-std-options))))
     214;     (error 'program-error
     215;                    "invalid initialization argument ~S for slot named ~S"
     216;                    (car olist) name))
    214217        `(list
    215218          :name ',name
     
    220223          ,@(when readers `(:readers ',readers))
    221224          ,@(when writers `(:writers ',writers))
    222           ,@other-options))))
     225          ,@other-options
     226    ,@non-std-options))))
    223227
    224228(defun maybe-note-name-defined (name)
     
    267271  (%slot-definition-allocation slot-definition))
    268272
     273(declaim (notinline (setf slot-definition-allocation)))
    269274(defun (setf slot-definition-allocation) (value slot-definition)
    270275  (set-slot-definition-allocation slot-definition value))
     
    273278  (%slot-definition-initargs slot-definition))
    274279
     280(declaim (notinline (setf slot-definition-initargs)))
    275281(defun (setf slot-definition-initargs) (value slot-definition)
    276282  (set-slot-definition-initargs slot-definition value))
     
    279285  (%slot-definition-initform slot-definition))
    280286
     287(declaim (notinline (setf slot-definition-initform)))
    281288(defun (setf slot-definition-initform) (value slot-definition)
    282289  (set-slot-definition-initform slot-definition value))
     
    285292  (%slot-definition-initfunction slot-definition))
    286293
     294(declaim (notinline (setf slot-definition-initfunction)))
    287295(defun (setf slot-definition-initfunction) (value slot-definition)
    288296  (set-slot-definition-initfunction slot-definition value))
     
    291299  (%slot-definition-name slot-definition))
    292300
     301(declaim (notinline (setf slot-definition-name)))
    293302(defun (setf slot-definition-name) (value slot-definition)
    294303  (set-slot-definition-name slot-definition value))
     
    297306  (%slot-definition-readers slot-definition))
    298307
     308(declaim (notinline (setf slot-definition-readers)))
    299309(defun (setf slot-definition-readers) (value slot-definition)
    300310  (set-slot-definition-readers slot-definition value))
     
    303313  (%slot-definition-writers slot-definition))
    304314
     315(declaim (notinline (setf slot-definition-writers)))
    305316(defun (setf slot-definition-writers) (value slot-definition)
    306317  (set-slot-definition-writers slot-definition value))
     
    309320  (%slot-definition-allocation-class slot-definition))
    310321
     322(declaim (notinline (setf slot-definition-allocation-class)))
    311323(defun (setf slot-definition-allocation-class) (value slot-definition)
    312324  (set-slot-definition-allocation-class slot-definition value))
     
    385397        (:class
    386398         (unless (%slot-definition-location slot)
    387            (let ((allocation-class (%slot-definition-allocation-class slot)))
     399           (let ((allocation-class (slot-definition-allocation-class slot)))
    388400             (set-slot-definition-location slot
    389401                                           (if (eq allocation-class class)
     
    397409               (old-location (layout-slot-location old-layout slot-name)))
    398410          (unless old-location
    399             (let* ((slot-definition (find slot-name (class-slots class) :key #'slot-definition-name))
     411            (let* ((slot-definition (find slot-name (class-slots class) :key 'slot-definition-name))
    400412                   (initfunction (slot-definition-initfunction slot-definition)))
    401413              (when initfunction
     
    500512                               (class-precedence-list class)))
    501513         (all-names (remove-duplicates
    502                      (mapcar #'slot-definition-name all-slots))))
     514                     (mapcar 'slot-definition-name all-slots))))
    503515    (mapcar #'(lambda (name)
    504516               (funcall
     
    508520                class
    509521                (remove name all-slots
    510                         :key #'slot-definition-name
     522                        :key 'slot-definition-name
    511523                        :test-not #'eq)))
    512524            all-names)))
     
    514526(defun std-compute-effective-slot-definition (class direct-slots)
    515527  (let ((initer (find-if-not #'null direct-slots
    516                              :key #'slot-definition-initfunction)))
     528                             :key 'slot-definition-initfunction)))
    517529    (make-effective-slot-definition
    518530     class
     
    525537                       nil)
    526538     :initargs (remove-duplicates
    527                 (mapappend #'slot-definition-initargs
     539                (mapappend 'slot-definition-initargs
    528540                           direct-slots))
    529541     :allocation (slot-definition-allocation (car direct-slots))
    530      :allocation-class (%slot-definition-allocation-class (car direct-slots)))))
     542     :allocation-class (when (slot-boundp (car direct-slots)
     543            'sys::allocation-class)
     544       ;;for some classes created in Java
     545       ;;(e.g. SimpleCondition) this slot is unbound
     546       (slot-definition-allocation-class (car direct-slots))))))
    531547
    532548;;; Standard instance slot access
     
    590606(defun std-slot-exists-p (instance slot-name)
    591607  (not (null (find slot-name (class-slots (class-of instance))
    592                    :key #'slot-definition-name))))
     608                   :key 'slot-definition-name))))
    593609
    594610(defun slot-exists-p (object slot-name)
     
    639655    (setf (class-direct-slots class) slots)
    640656    (dolist (direct-slot slots)
    641       (dolist (reader (%slot-definition-readers direct-slot))
     657      (dolist (reader (slot-definition-readers direct-slot))
    642658        (add-reader-method class reader (slot-definition-name direct-slot)))
    643       (dolist (writer (%slot-definition-writers direct-slot))
     659      (dolist (writer (slot-definition-writers direct-slot))
    644660        (add-writer-method class writer (slot-definition-name direct-slot)))))
    645661  (setf (class-direct-default-initargs class) direct-default-initargs)
     
    23162332  (declare (ignore slot-names)) ;;TODO?
    23172333  (declare (ignore name initargs initform initfunction readers writers allocation))
    2318   (apply #'init-slot-definition slot args))
     2334  ;;For built-in slots
     2335  (apply #'init-slot-definition slot args)
     2336  ;;For user-defined slots
     2337  (call-next-method))
    23192338
    23202339;;; change-class
     
    23332352      (when (instance-slot-p new-slot)
    23342353        (let* ((slot-name (slot-definition-name new-slot))
    2335                (old-slot (find slot-name old-slots :key #'slot-definition-name)))
     2354               (old-slot (find slot-name old-slots :key 'slot-definition-name)))
    23362355          ;; "The values of slots specified as shared in the class CFROM and as
    23372356          ;; local in the class CTO are retained."
     
    23562375         (remove-if #'(lambda (slot-name)
    23572376                       (slot-exists-p old slot-name))
    2358                     (mapcar #'slot-definition-name
     2377                    (mapcar 'slot-definition-name
    23592378                            (class-slots (class-of new))))))
    23602379    (check-initargs new added-slots initargs)
Note: See TracChangeset for help on using the changeset viewer.