Changeset 7810


Ignore:
Timestamp:
Dec 3, 2007, 9:53:40 PM (13 years ago)
Author:
gb
Message:

Handle class slots in MAKE-INSTANTIATE-LAMBDA-FOR-CLASS-CELL.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/working-0711/ccl/level-1/l1-clos.lisp

    r7789 r7810  
    18781878                 (and (null (cdr (compute-applicable-methods #'initialize-instance (list proto))))
    18791879                      (null (cdr (compute-applicable-methods #'shared-initialize (list proto t)))))))
    1880       (let* ((slotds (sort (copy-list (class-slots class)) #'< :key #'slot-definition-location))
     1880      (let* ((slotds (sort (copy-list (class-slots class)) #'(lambda (x y) (if (consp x) x (if (consp y) y (< x y)))) :key #'slot-definition-location))
    18811881             (default-initargs (class-default-initargs class)))
    18821882        ;; Punt if any slot has multiple initargs
     
    18861886          (collect ((keys)
    18871887                    (binds)
     1888                    (class-slot-inits)
    18881889                    (forms))
    18891890            (dolist (slot slotds)
     
    18911892                     (initfunction (slot-definition-initfunction slot))
    18921893                     (initform (slot-definition-initform slot))
     1894                     (location (slot-definition-location slot))
    18931895                     (name (slot-definition-name slot))
    18941896                     (initial-value-form (if initfunction
     
    19101912                                   `(funcall ,function)))
    19111913                               initial-value-form))))
    1912                     (if (eq type t)
    1913                       (forms name)
     1914                    (if (consp location)
     1915                      (class-slot-inits `(when (eq (%slot-unbound-marker) (cdr ',location))(setf (cdr ',location) (require-type ,name ',type))))
    19141916                      (forms `(require-type ,name ',type))))
    1915                   (if (eq type t)
    1916                     (forms initial-value-form)
     1917                  (if (consp location)
     1918                    (class-slot-inits `(when (eq (%slot-unbound-marker) (cdr ',location))(setf (cdr ',location) (require-type ,initial-value-form ',type))))
     1919                   
    19171920                    (forms `(require-type ,initial-value-form ',type))))))
    19181921            (let* ((cell (make-symbol "CLASS-CELL"))
     
    19221925              (binds `(,instance (gvector :instance 0 (class-cell-extra ,cell) ,slots)))
    19231926              `(lambda (,cell &key ,@(keys))
     1927                ,@(class-slot-inits)
    19241928                (let* (,@(binds))
    19251929                  (setf (instance.hash ,instance) (strip-tag-to-fixnum ,instance)
Note: See TracChangeset for help on using the changeset viewer.