Changeset 11120 for trunk/source/level-1


Ignore:
Timestamp:
Oct 17, 2008, 12:31:46 PM (11 years ago)
Author:
gz
Message:

From working-0711 branch:

in make-instantiate-lambda-for-class-cell, don't bind class slot definitions if don't need 'em (avoids unref var warnings).

make the lambda-lists recorded for accessor methods use class name as the arg name

record-source-file for accessor methods (so at least can get to the right file)

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/level-1/l1-clos.lisp

    r10942 r11120  
    643643  (dolist (dslotd dslotds)
    644644    (dolist (reader (%slot-definition-readers dslotd))
    645       (add-reader-method class                     
    646                         (ensure-generic-function reader)
    647                         dslotd))
     645      (add-reader-method class
     646                        (ensure-generic-function reader)
     647                        dslotd))
    648648    (dolist (writer (%slot-definition-writers dslotd))
    649649      (add-writer-method class
     
    909909          `(:qualifiers nil
    910910            :specializers ,(list class)
    911             :lambda-list (instance)
     911            :lambda-list (,(or (%class-name class) 'instance))
    912912            :name ,(function-name gf)
    913913            :slot-definition ,dslotd))
     
    920920                        initargs)))
    921921    (declare (dynamic-extent initargs))
     922    (record-source-file method 'reader-method)
    922923    (add-method gf method)))
    923924
     
    943944          `(:qualifiers nil
    944945            :specializers ,(list *t-class* class)
    945             :lambda-list (new-value instance)
     946            :lambda-list (new-value ,(or (%class-name class) 'instance))
    946947            :name ,(function-name gf)
    947948            :slot-definition ,dslotd))
     
    956957                 initargs)))
    957958    (declare (dynamic-extent initargs))
     959    (record-source-file method 'writer-method)
    958960    (add-method gf method)))
    959961
     
    22042206                     (location (slot-definition-location slot))
    22052207                     (location-var nil)
     2208                     (class-init-p nil)
    22062209                     (one-initarg-p (null (cdr initargs)))
    22072210                     (name (slot-definition-name slot))
    22082211                     (type (slot-definition-type slot)))
    22092212                (when (consp location)
    2210                   (setq location-var (gensym "LOCATION"))
    2211                   (class-binds `(,location-var
    2212                                  (load-time-value
    2213                                   (slot-definition-location ',slot)))))
     2213                  (setq location-var (gensym "LOCATION")))
    22142214                (when initfunction
    22152215                  (setq initform
     
    22222222                                  (generate-type-check initform type)
    22232223                                  `(%slot-unbound-marker))))
    2224                          (if (consp location)
     2224                         (if location-var
    22252225                             (when initfunction
    2226                                  (class-slot-inits
    2227                                   `(when (eq (%slot-unbound-marker) (cdr ,location-var))
    2228                                      (setf (cdr ,location-var) ,initial-value-form))))
     2226                               (setq class-init-p t)
     2227                               (class-slot-inits
     2228                                `(when (eq (%slot-unbound-marker) (cdr ,location-var))
     2229                                   (setf (cdr ,location-var) ,initial-value-form))))
    22292230                             (forms initial-value-form))))
    22302231                      (t (collect ((cond-clauses))
     
    22382239                                       (if (and initfunction
    22392240                                                one-initarg-p
    2240                                                 (atom location))
     2241                                                (null location-var))
    22412242                                           initform
    22422243                                           (progn
     
    22482249                                                             "-P"))))
    22492250                                             (and one-initarg-p
    2250                                                   (atom location)
     2251                                                  (null location-var)
    22512252                                                  (if initfunction
    22522253                                                      initform
     
    22632264                                 (keys (list*
    22642265                                        (list initarg name)
    2265                                         (if (and default one-initarg-p (atom location))
     2266                                        (if (and default one-initarg-p (null location-var))
    22662267                                            default
    22672268                                            initial-value-form)
    22682269                                        (if spvar (list spvar))))
    22692270                                 (if one-initarg-p
    2270                                      (if (consp location)
    2271                                          (class-slot-inits
    2272                                           `(if ,spvar
    2273                                                (setf (cdr ,location-var)
     2271                                   (if location-var
     2272                                     (progn
     2273                                       (setq class-init-p t)
     2274                                       (class-slot-inits
     2275                                        `(if ,spvar
     2276                                           (setf (cdr ,location-var)
     2277                                                 ,(generate-type-check
     2278                                                   name type))
     2279                                           ,(if default
     2280                                              `(setf (cdr ,location-var)
    22742281                                                     ,(generate-type-check
    2275                                                        name type))
    2276                                                ,(if default
    2277                                                     `(setf (cdr ,location-var)
    2278                                                            ,(generate-type-check
    2279                                                              default type))
    2280                                                     (when initfunction
    2281                                                       `(when (eq (%slot-unbound-marker)
    2282                                                                  (cdr ,location-var))
    2283                                                          (setf (cdr ,location-var)
    2284                                                                ,(generate-type-check
    2285                                                                  initform type)))))))
    2286                                          (forms `,(generate-type-check name type spvar)))
     2282                                                       default type))
     2283                                              (when initfunction
     2284                                                `(when (eq (%slot-unbound-marker)
     2285                                                           (cdr ,location-var))
     2286                                                   (setf (cdr ,location-var)
     2287                                                         ,(generate-type-check
     2288                                                           initform type))))))))
     2289                                     (forms `,(generate-type-check name type spvar)))
    22872290                                     (progn (cond-clauses `(,spvar ,name))
    22882291                                            (when (and default (null last-cond-clause))
     
    22922295                               (when last-cond-clause
    22932296                                 (cond-clauses last-cond-clause))
    2294                                (cond ((atom location)
     2297                               (cond ((null location-var)
    22952298                                      (unless last-cond-clause
    22962299                                        (cond-clauses `(t ,initform)))
     
    23092312                                                    initform
    23102313                                                    `(%slot-unbound-marker)))))
     2314                                        (setq class-init-p t)
    23112315                                        (class-slot-inits
    23122316                                         `(let* (,@(and initform-p-var
     
    23232327                                                                        (%slot-unbound-marker)))))
    23242328                                                     t)
    2325                                                 (setf (cdr ,location-var) ,value-var)))))))))))))))
     2329                                                (setf (cdr ,location-var) ,value-var))))))))))))
     2330                (when class-init-p
     2331                  (class-binds `(,location-var
     2332                                 (load-time-value
     2333                                  (slot-definition-location ',slot))))))))
    23262334          (let* ((cell (make-symbol "CLASS-CELL"))
    23272335                 (args (make-symbol "ARGS"))
Note: See TracChangeset for help on using the changeset viewer.