Changeset 11989 for trunk/source/level-1

May 1, 2009, 4:48:55 AM (11 years ago)

Try to make MAKE-INSTANCE work with structure classes.

  • initargs are based on structure slot names, interned in the keyword package.
  • there's a primary SHARED-INITIALIZE method on STRUCTURE-OBJECT that only tries to handle the case where the SLOT-NAMES argument is T.
  • no structure slot is ever SLOT-UNBOUND, so that primary method always initializes all slots (has no way of knowing whether a slot has been initialized earlier, e.g., by a :BEFORE method somewhere.)
1 edited


  • trunk/source/level-1/l1-clos.lisp

    r11666 r11989  
    12801280                 (initform (cadr ssd))
    12811281                 (initfunction (constantly initform)))
    1282             (push `(:name ,name :type ,type :initform ,initform :initfunction ,initfunction) dslots)))))
     1282            (push `(:name ,name :type ,type :initform ,initform :initfunction ,initfunction :initargs ,(list (make-keyword name))) dslots)))))
    12831283    (ensure-class (sd-name sd)
    12841284                  :metaclass 'structure-class
    18281828                             newval))))))))))
    18291829  instance)
     1831(defmethod shared-initialize ((struct structure-object) slot-names &rest initargs)
     1832  (unless (eq slot-names t)
     1833    (error "Structure instance ~s can't be reinitialized." struct))
     1834  (dolist (slotd (class-slots (class-cell-class (car (%svref struct 0)))))
     1835    (let* ((predicate (slot-definition-predicate slotd))
     1836           (location (slot-definition-location slotd)))
     1837      (declare (fixnum location))
     1838      (multiple-value-bind (ignore new-value foundp)
     1839          (get-properties initargs (slot-definition-initargs slotd))
     1840        (declare (ignore ignore))
     1841        (cond (foundp
     1842               ;; an initarg for the slot was passed to this function
     1843               ;; Typecheck the new-value, then call
     1844               ;; (SETF SLOT-VALUE-USING-CLASS)
     1845               (unless (or (null predicate)
     1846                           (funcall predicate new-value))
     1847                 (error 'bad-slot-type-from-initarg
     1848                        :slot-definition slotd
     1849                        :instance struct
     1850                        :datum new-value
     1851                        :expected-type  (slot-definition-type slotd)
     1852                          :initarg-name (car foundp)))
     1853                 (setf (struct-ref struct location) new-value))
     1854                (t
     1855                 ;; If the slot name is among the specified slot names, or
     1856                 ;; we're reinitializing all slots, and the slot is currently
     1857                 ;; unbound in the instance, set the slot's value based
     1858                 ;; on the initfunction (which captures the :INITFORM).
     1859                 (let* ((initfunction (slot-definition-initfunction slotd)))
     1860                   (if initfunction
     1861                     (let* ((newval (funcall initfunction)))
     1862                       (unless (or (null predicate)
     1863                                   (funcall predicate newval))
     1864                         (error 'bad-slot-type-from-initform
     1865                                :slot-definition slotd
     1866                                :expected-type (slot-definition-type slotd)
     1867                                :datum newval
     1868                                :instance struct))
     1869                       (setf (struct-ref struct location) newval)))))))))
     1870  struct)
     1872(defmethod initialize-instance ((struct structure-object) &rest initargs &key &allow-other-keys)
     1873  (declare (dynamic-extent initargs))
     1874  (apply #'shared-initialize struct t initargs))
     1876(defmethod make-instance ((class structure-class)  &rest initargs &key &allow-other-keys)
     1877  (declare (dynamic-extent initargs))
     1878  (let* ((struct (apply #'allocate-instance class initargs)))
     1879    (apply #'initialize-instance struct initargs)))
    18311883;;; Sometimes you can do a lot better at generic function dispatch than the
Note: See TracChangeset for help on using the changeset viewer.