Changeset 8028


Ignore:
Timestamp:
Jan 8, 2008, 8:16:40 PM (12 years ago)
Author:
wws
Message:

make-instantiate-lambda-for-class-cell, the function that generates
the code for optimize-make-instnace-for-class-name, now generates
proper code for slots with multiple initargs and for class slots. It
used to process only the first initarg, and it used to initialize
class slots only if they were unbound. Class slots are supposed to be
set from the :initial-value form only if they are unbound, but the
CLOS specification says to set them from initargs unconditionally.

File:
1 edited

Legend:

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

    r7992 r8028  
    20552055                          t))
    20562056                      (null (cdr (compute-applicable-methods #'shared-initialize (list proto t)))))))
    2057       (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))
     2057      (let* ((slotds (sort (copy-list (class-slots class))
     2058                           #'(lambda (x y)
     2059                               (if (consp x) x (if (consp y) y (< x y))))
     2060                           :key #'slot-definition-location))
    20582061             (default-initargs (class-default-initargs class)))
    20592062        (collect ((keys)
    20602063                  (binds)
     2064                  (class-binds)
    20612065                  (ignorable)
    20622066                  (class-slot-inits)
     
    20652069          (flet ((generate-type-check (form type &optional spvar)
    20662070                   (if (or (null *typecheck-slots-in-optimized-make-instance*)
    2067                            (eq form t))
     2071                           (eq type t))
    20682072                     form
    20692073                     (if spvar
     
    20732077                       `(require-type ,form ',type)))))
    20742078            (dolist (slot slotds)
    2075               (let* ((initarg (car (slot-definition-initargs slot)))
     2079              (let* ((initargs (slot-definition-initargs slot))
    20762080                     (initfunction (slot-definition-initfunction slot))
    20772081                     (initform (slot-definition-initform slot))
    20782082                     (location (slot-definition-location slot))
     2083                     (location-var nil)
     2084                     (one-initarg-p (null (cdr initargs)))
    20792085                     (name (slot-definition-name slot))
    2080                      (spvar nil)
    2081                      (type (slot-definition-type slot))
    2082                      (initial-value-form (if initfunction
    2083                                            (if (self-evaluating-p initform)
    2084                                              initform
    2085                                              `(funcall ,initfunction))
     2086                     (type (slot-definition-type slot)))
     2087                (when initfunction
     2088                  (when (consp location)
     2089                    (setq location-var (gensym "LOCATION"))
     2090                    (class-binds `(,location-var
     2091                                   (load-time-value
     2092                                    (slot-definition-location ',slot)))))
     2093                  (setq initform
     2094                        (if (self-evaluating-p initform)
     2095                            initform
     2096                            `(funcall ,initfunction))))
     2097                (cond ((null initargs)
     2098                       (let ((initial-value-form
     2099                              (if initfunction
     2100                                  (generate-type-check initform type)
     2101                                  `(%slot-unbound-marker))))
     2102                         (if (consp location)
     2103                             (when initfunction
     2104                                 (class-slot-inits
     2105                                  `(when (eq (%slot-unbound-marker) (cdr ,location-var))
     2106                                     (setf (cdr ,location-var) ,initial-value-form))))
     2107                             (forms initial-value-form))))
     2108                      (t (collect ((cond-clauses))
     2109                           (let ((last-cond-clause nil))
     2110                             (dolist (initarg initargs)
     2111                               (let* ((spvar nil)
     2112                                      (name (if one-initarg-p
     2113                                                name
     2114                                                (gensym (string name))))
     2115                                      (initial-value-form
     2116                                       (if (and initfunction
     2117                                                one-initarg-p
     2118                                                (atom location))
     2119                                           initform
    20862120                                           (progn
    20872121                                             (when initarg
     
    20892123                                                            (concatenate
    20902124                                                             'string
    2091                                                              (string name)
     2125                                                             (string initarg)
    20922126                                                             "-P"))))
    2093                                              `(%slot-unbound-marker)))))
    2094                 (when spvar (ignorable spvar))
    2095                 (if initarg
    2096                   (progn
    2097                     (keys (list*
    2098                            (list initarg name)
    2099                            (let* ((default (assq initarg default-initargs)))
    2100                              (if default
    2101                                (destructuring-bind (form function)
    2102                                    (cdr default)
    2103                                  (if (self-evaluating-p form)
    2104                                    form
    2105                                    `(funcall ,function)))
    2106                                initial-value-form))
    2107                            (if spvar (list spvar))))
    2108                     (if (consp location)
    2109                       (class-slot-inits `(unless (eq ,name (%slot-unbound-marker)) (when (eq (%slot-unbound-marker) (cdr ',location))(setf (cdr ',location) ,(generate-type-check name type)))))
    2110                       (forms `,(generate-type-check name type spvar))))
    2111                   (progn
    2112                     (when initfunction
    2113                       (setq initial-value-form (generate-type-check initial-value-form type)))
    2114                     (if (consp location)
    2115                       (if initfunction
    2116                         (class-slot-inits `(when (eq (%slot-unbound-marker) (cdr ',location))(setf (cdr ',location) ,initial-value-form))))
    2117                    
    2118                       (forms initial-value-form)))))))
     2127                                             (and one-initarg-p
     2128                                                  (atom location)
     2129                                                  (if initfunction
     2130                                                      initform
     2131                                                      `(%slot-unbound-marker))))))
     2132                                      (default (assq initarg default-initargs)))
     2133                                 (when spvar (ignorable spvar))
     2134                                 (when default
     2135                                   (destructuring-bind (form function)
     2136                                       (cdr default)
     2137                                     (setq default
     2138                                           (if (self-evaluating-p form)
     2139                                               form
     2140                                               `(funcall ,function)))))
     2141                                 (keys (list*
     2142                                        (list initarg name)
     2143                                        (if (and default one-initarg-p (atom location))
     2144                                            default
     2145                                            initial-value-form)
     2146                                        (if spvar (list spvar))))
     2147                                 (if one-initarg-p
     2148                                     (if (consp location)
     2149                                         (class-slot-inits
     2150                                          `(if ,spvar
     2151                                               (setf (cdr ,location-var)
     2152                                                     ,(generate-type-check
     2153                                                       name type))
     2154                                               ,(if default
     2155                                                    `(setf (cdr ,location-var)
     2156                                                           ,(generate-type-check
     2157                                                             default type))
     2158                                                    (when initfunction
     2159                                                      `(when (eq (%slot-unbound-marker)
     2160                                                                 (cdr ,location-var))
     2161                                                         (setf (cdr ,location-var)
     2162                                                               ,(generate-type-check
     2163                                                                 initform type)))))))
     2164                                         (forms `,(generate-type-check name type spvar)))
     2165                                     (progn (cond-clauses `(,spvar ,name))
     2166                                            (when (and default (null last-cond-clause))
     2167                                              (setq last-cond-clause
     2168                                                    `(t ,default)))))))
     2169                             (when (cond-clauses)
     2170                               (when last-cond-clause
     2171                                 (cond-clauses last-cond-clause))
     2172                               (cond ((atom location)
     2173                                      (unless last-cond-clause
     2174                                        (cond-clauses `(t ,initform)))
     2175                                      (forms (generate-type-check
     2176                                              `(cond ,@(cond-clauses))
     2177                                              type)))
     2178                                     (t
     2179                                      (let ((initform-p-var
     2180                                             (unless last-cond-clause
     2181                                               (make-symbol "INITFORM-P")))
     2182                                            (value-var (make-symbol "VALUE")))
     2183                                        (unless last-cond-clause
     2184                                          (cond-clauses
     2185                                           `(t (setq ,initform-p-var t)
     2186                                               ,(if initfunction
     2187                                                    initform
     2188                                                    `(%slot-unbound-marker)))))
     2189                                        (class-slot-inits
     2190                                         `(let* (,@(and initform-p-var
     2191                                                        (list `(,initform-p-var nil)))
     2192                                                 (,value-var
     2193                                                  ,(generate-type-check
     2194                                                    `(cond ,@(cond-clauses)) type)))
     2195                                            (when
     2196                                                ,(if initform-p-var
     2197                                                     `(or (null ,initform-p-var)
     2198                                                          (and (eq (cdr ,location-var)
     2199                                                                   (%slot-unbound-marker))
     2200                                                               (not (eq ,value-var
     2201                                                                        (%slot-unbound-marker)))))
     2202                                                     t)
     2203                                                (setf (cdr ,location-var) ,value-var)))))))))))))))
    21192204          (let* ((cell (make-symbol "CLASS-CELL"))
    21202205                 (args (make-symbol "ARGS"))
     
    21302215              (declare (ignorable ,@(ignorable)))
    21312216              ,@(when after-methods `((declare (dynamic-extent ,args))))
    2132               ,@(class-slot-inits)
     2217              (let (,@(class-binds))
     2218                ,@(class-slot-inits))
    21332219              (let* (,@(binds))
    21342220                (setf (instance.hash ,instance) (strip-tag-to-fixnum ,instance)
Note: See TracChangeset for help on using the changeset viewer.