Changeset 7821


Ignore:
Timestamp:
Dec 5, 2007, 1:44:24 PM (13 years ago)
Author:
gb
Message:

Try to straighten out type-checking in optimized MAKE-INSTANCE; try
to handle the case where there are :AFTER methods on INITIALIZE-INSTANCE.

File:
1 edited

Legend:

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

    r7810 r7821  
    18661866                             (gf.dcode f) #'reader-variable-location-dcode)))))))))))                       
    18671867
     1868;;; Return a list of :after methods for INITIALIZE-INSTANCE on the
     1869;;; class's prototype, and a boolean that's true if no other qualified
     1870;;; methods are defined.
     1871(defun initialize-instance-after-methods (proto class)
     1872  (let* ((method-list (compute-method-list (sort-methods
     1873                            (compute-applicable-methods #'initialize-instance (list proto))
     1874                            (list (class-precedence-list class))))))
     1875    (if (atom method-list)
     1876      (values nil t)
     1877      (if (null (car method-list))
     1878        (values (cadr method-list) t)
     1879        ;; :around or :before methods, give up
     1880        (values nil nil)))))
     1881             
    18681882
    18691883;;; Return a lambda form or NIL.
    18701884(defun make-instantiate-lambda-for-class-cell (cell)
    1871   (let* ((class (class-cell-class cell)))   
     1885  (let* ((class (class-cell-class cell))
     1886         (after-methods nil))
    18721887    (when (and (typep class 'standard-class)
    18731888               (progn (unless (class-finalized-p class)
     
    18761891               (null (cdr (compute-applicable-methods #'allocate-instance (list class))))
    18771892               (let* ((proto (class-prototype class)))
    1878                  (and (null (cdr (compute-applicable-methods #'initialize-instance (list proto))))
     1893                 (and (multiple-value-bind (afters ok)
     1894                          (initialize-instance-after-methods proto class)
     1895                        (when ok
     1896                          (setq after-methods afters)
     1897                          t))
    18791898                      (null (cdr (compute-applicable-methods #'shared-initialize (list proto t)))))))
    18801899      (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))
    18811900             (default-initargs (class-default-initargs class)))
    1882         ;; Punt if any slot has multiple initargs
    1883         (when (dolist (slot slotds t)
    1884                 (when (cdr (slot-definition-initargs slot))
    1885                   (return nil)))
    1886           (collect ((keys)
    1887                     (binds)
    1888                     (class-slot-inits)
    1889                     (forms))
     1901        (collect ((keys)
     1902                  (binds)
     1903                  (ignorable)
     1904                  (class-slot-inits)
     1905                  (after-method-forms)
     1906                  (forms))
     1907          (flet ((generate-type-check (form type &optional spvar)
     1908                   (let* ((ctype (ignore-errors (specifier-type type))))
     1909                     (if (or (null ctype)
     1910                             (eq ctype *universal-type*)
     1911                             (typep ctype 'unknown-ctype))
     1912                       form
     1913                       (if spvar
     1914                         `(if ,spvar
     1915                           (require-type .form ',type)
     1916                           (%slot-unbound-marker))
     1917                         `(require-type ,form ',type))))))
    18901918            (dolist (slot slotds)
    18911919              (let* ((initarg (car (slot-definition-initargs slot)))
     
    18941922                     (location (slot-definition-location slot))
    18951923                     (name (slot-definition-name slot))
     1924                     (spvar nil)
     1925                     (type (slot-definition-type slot))
    18961926                     (initial-value-form (if initfunction
    18971927                                           (if (self-evaluating-p initform)
    18981928                                             initform
    18991929                                             `(funcall ,initfunction))
    1900                                            `(%slot-unbound-marker)))
    1901                      (type (slot-definition-type slot)))
     1930                                           (progn
     1931                                             (when initarg
     1932                                               (setq spvar (make-symbol
     1933                                                            (concatenate
     1934                                                             'string
     1935                                                             (string name)
     1936                                                             "-P"))))
     1937                                             `(%slot-unbound-marker)))))
     1938                (when spvar (ignorable spvar))
    19021939                (if initarg
    19031940                  (progn
    1904                     (keys (list
     1941                    (keys (list*
    19051942                           (list initarg name)
    19061943                           (let* ((default (assq initarg default-initargs)))
     
    19111948                                   form
    19121949                                   `(funcall ,function)))
    1913                                initial-value-form))))
     1950                               initial-value-form))
     1951                           (if spvar (list spvar))))
    19141952                    (if (consp location)
    1915                       (class-slot-inits `(when (eq (%slot-unbound-marker) (cdr ',location))(setf (cdr ',location) (require-type ,name ',type))))
    1916                       (forms `(require-type ,name ',type))))
    1917                   (if (consp location)
    1918                     (class-slot-inits `(when (eq (%slot-unbound-marker) (cdr ',location))(setf (cdr ',location) (require-type ,initial-value-form ',type))))
     1953                      (class-slot-inits `(unless (eq ,name (%slot-unbound-marker)) (when (eq (%slot-unbound-marker) (cdr ',location))(setf (cdr ',location) ,(generate-type-check name type)))))
     1954                      (forms `,(generate-type-check name type spvar))))
     1955                  (progn
     1956                    (when initfunction
     1957                      (setq initial-value-form (generate-type-check initial-value-form type)))
     1958                    (if (consp location)
     1959                      (if initfunction
     1960                        (class-slot-inits `(when (eq (%slot-unbound-marker) (cdr ',location))(setf (cdr ',location) ,initial-value-form))))
    19191961                   
    1920                     (forms `(require-type ,initial-value-form ',type))))))
    1921             (let* ((cell (make-symbol "CLASS-CELL"))
    1922                    (slots (make-symbol "SLOTS"))
    1923                    (instance (make-symbol "INSTANCE")))
    1924               (binds `(,slots (gvector :slot-vector nil ,@(forms))))
    1925               (binds `(,instance (gvector :instance 0 (class-cell-extra ,cell) ,slots)))
    1926               `(lambda (,cell &key ,@(keys))
    1927                 ,@(class-slot-inits)
    1928                 (let* (,@(binds))
    1929                   (setf (instance.hash ,instance) (strip-tag-to-fixnum ,instance)
    1930                         (%svref ,slots 0) ,instance))))))))))
     1962                      (forms initial-value-form)))))))
     1963          (let* ((cell (make-symbol "CLASS-CELL"))
     1964                 (args (make-symbol "ARGS"))
     1965                 (slots (make-symbol "SLOTS"))
     1966                 (instance (make-symbol "INSTANCE")))
     1967            (dolist (after after-methods)
     1968              (after-method-forms `(apply ,(method-function after) ,instance ,args)))
     1969            (when after-methods
     1970              (after-method-forms instance))
     1971            (binds `(,slots (gvector :slot-vector nil ,@(forms))))
     1972            (binds `(,instance (gvector :instance 0 (class-cell-extra ,cell) ,slots)))
     1973            `(lambda (,cell ,@(when after-methods `(&rest ,args)) &key ,@(keys) ,@(when after-methods '(&allow-other-keys)))
     1974              (declare (ignorable ,@(ignorable)))
     1975              ,@(when after-methods `((declare (dynamic-extent ,args))))
     1976              ,@(class-slot-inits)
     1977              (let* (,@(binds))
     1978                (setf (instance.hash ,instance) (strip-tag-to-fixnum ,instance)
     1979                      (%svref ,slots 0) ,instance)
     1980                ,@(after-method-forms)))))))))
    19311981
    19321982(defun optimize-make-instance-for-class-cell (cell)
Note: See TracChangeset for help on using the changeset viewer.