Changeset 109


Ignore:
Timestamp:
Dec 12, 2003, 1:10:26 PM (21 years ago)
Author:
Gary Byers
Message:

New slot-value scheme.

Location:
trunk/ccl/level-1
Files:
2 edited

Legend:

Unmodified
Added
Removed

  • trunk/ccl/level-1/l1-clos-boot.lisp

    r102 r109  
    990990
    991991(defparameter dcode-proto-alist
    992   (list (cons #'%%reader-dcode-no-lexpr  *gf-proto-one-arg*)
    993         (cons #'%%writer-dcode-no-lexpr *gf-proto-two-arg*)
    994         (cons #'%%one-arg-dcode *gf-proto-one-arg*)
     992  (list (cons #'%%one-arg-dcode *gf-proto-one-arg*)
    995993        (cons #'%%1st-two-arg-dcode *gf-proto-two-arg*)))
    996994   
    … …  
    10081006                          (logbitp $lfbits-aok-bit bits)))
    10091007         multi-method-index
    1010          min-index
    1011          (only-readers t)
    1012          (only-writers t)
    1013          (can-optimize (if *compile-definitions* t nil))
    1014          )
     1008         min-index)
    10151009    (when methods
    10161010      (unless 0-args?
    10171011        (dolist (m methods)
    1018           (when can-optimize
    1019             (let ((method-class (class-of m)))
    1020               (unless (or (if (eq method-class *standard-reader-method-class*)
    1021                             (progn (setq only-writers nil)
    1022                                    t)
    1023                             (setq only-readers nil))
    1024                           (if (eq method-class *standard-writer-method-class*)
    1025                             t
    1026                             (setq only-writers nil)))
    1027                 (setq can-optimize nil))))
    10281012          (multiple-value-bind (mm-index index) (multi-method-index m)
    10291013            (when mm-index
    … …  
    10351019      (let ((dcode (if 0-args?
    10361020                     #'%%0-arg-dcode
    1037                      (or (and can-optimize
    1038                               (cond (only-readers #'%%reader-dcode-no-lexpr)
    1039                                     (only-writers #'%%writer-dcode-no-lexpr)))
    1040                          (if multi-method-index
     1021                     (or (if multi-method-index
    10411022                           #'%%nth-arg-dcode)
    10421023                         (if (null other-args?)
    … …  
    15341515))
    15351516
     1517(defvar *standard-effective-slot-definition-class-wrapper*
     1518  (%class.own-wrapper *standard-effective-slot-definition-class*))
    15361519
    15371520
    … …  
    19851968  (gvector :function
    19861969           (uvref *reader-method-function-proto* 0)
    1987            (%slot-definition-name dslotd)
    1988            'slot-value
     1970           (ensure-slot-id (%slot-definition-name dslotd))
     1971           'slot-id-value
    19891972           nil                          ;method-function name
    19901973           (dpb 1 $lfbits-numreq (ash 1 $lfbits-method-bit))))
    … …  
    19951978  (gvector :function
    19961979           (uvref *writer-method-function-proto* 0)
    1997            (%slot-definition-name dslotd)
    1998            'set-slot-value
     1980           (ensure-slot-id (%slot-definition-name dslotd))
     1981           'set-slot-id-value
    19991982           nil
    20001983           (dpb 2 $lfbits-numreq (ash 1 $lfbits-method-bit))))
    … …  
    21342117  (find name slots :key #'%slot-definition-name))
    21352118
     2119(defun %std-slot-value-using-class (instance slotd)
     2120  (let* ((loc (standard-effective-slot-definition.location slotd)))
     2121    (typecase loc
     2122      (fixnum
     2123       (standard-instance-instance-location-access instance loc))
     2124      (cons
     2125       (let* ((val (%cdr loc)))
     2126         (if (eq val (%slot-unbound-marker))
     2127           (slot-unbound (class-of instance) instance (standard-effective-slot-definition.name slotd))
     2128           val)))
     2129      (t
     2130       (error "Slot definition ~s has invalid location ~s (allocation ~s)."
     2131              slotd loc (slot-definition-allocation slotd))))))
     2132
    21362133(defmethod slot-value-using-class ((class standard-class)
    21372134                                   instance
    21382135                                   (slotd standard-effective-slot-definition))
    2139   (if (eql 0 (%wrapper-instance-slots (instance.class-wrapper instance)))
    2140     (progn
    2141       (update-obsolete-instance instance)
    2142       (slot-value instance (standard-effective-slot-definition.name slotd)))
    2143     (let* ((loc (standard-effective-slot-definition.location slotd)))
    2144       (typecase loc
    2145         (fixnum
    2146          (standard-instance-instance-location-access instance loc))
    2147         (cons
    2148          (let* ((val (%cdr loc)))
    2149            (if (eq val (%slot-unbound-marker))
    2150              (slot-unbound class instance (standard-effective-slot-definition.name slotd))
    2151              val)))
    2152         (t
    2153          (error "Slot definition ~s has invalid location ~s (allocation ~s)."
    2154                 slotd loc (slot-definition-allocation slotd)))))))
    2155 
    2156 
     2136  (%std-slot-value-using-class instance slotd))
     2137
     2138(defun %maybe-std-slot-value-using-class (class instance slotd)
     2139  (if (and (eql (typecode class) ppc32::subtag-instance)
     2140           (eql (typecode slotd) ppc32::subtag-instance)
     2141           (eq *standard-effective-slot-definition-class-wrapper*
     2142               (instance.class-wrapper slotd))
     2143           (eq *standard-class-wrapper* (instance.class-wrapper class)))
     2144    (%std-slot-value-using-class instance slotd)
     2145    (slot-value-using-class class instance slotd)))
     2146
     2147 
     2148
     2149(defun %std-setf-slot-value-using-class (instance slotd new)
     2150  (let* ((loc (standard-effective-slot-definition.location slotd))
     2151         (type (standard-effective-slot-definition.type slotd))
     2152         (type-predicate (standard-effective-slot-definition.type-predicate slotd)))
     2153    (unless (or (eq new (%slot-unbound-marker))
     2154                (funcall type-predicate new))
     2155      (setq new (require-type new type)))
     2156    (typecase loc
     2157      (fixnum
     2158       (setf
     2159        (standard-instance-instance-location-access instance loc) new))
     2160      (cons
     2161       (setf (%cdr loc) new))
     2162      (t
     2163       (error "Slot definition ~s has invalid location ~s (allocation ~s)."
     2164              slotd loc (slot-definition-allocation slotd))))))
     2165 
    21572166(defmethod (setf slot-value-using-class)
    21582167    (new
    … …  
    21602169     instance
    21612170     (slotd standard-effective-slot-definition))
    2162   (if (eql 0 (%wrapper-instance-slots (instance.class-wrapper instance)))
    2163     (progn
    2164       (update-obsolete-instance instance)
    2165       (setf (slot-value instance (standard-effective-slot-definition.name slotd)) new))
    2166     (let* ((loc (standard-effective-slot-definition.location slotd))
    2167            (type (standard-effective-slot-definition.type slotd)))
    2168       (if (and type (not (eq type t)))
    2169         (unless (or (eq new (%slot-unbound-marker))
    2170                     (typep new type))
    2171           (setq new (require-type new type))))
    2172       (typecase loc
    2173         (fixnum
    2174          (setf
    2175           (standard-instance-instance-location-access instance loc) new))
    2176         (cons
    2177          (setf (%cdr loc) new))
    2178         (t
    2179          (error "Slot definition ~s has invalid location ~s (allocation ~s)."
    2180                 slotd loc (slot-definition-allocation slotd)))))))
     2171  (%std-setf-slot-value-using-class instance slotd new))
     2172
     2173
     2174(defun %maybe-std-setf-slot-value-using-class (class instance slotd new)
     2175  (if (and (eql (typecode class) ppc32::subtag-instance)
     2176           (eql (typecode slotd) ppc32::subtag-instance)
     2177           (eq *standard-effective-slot-definition-class-wrapper*
     2178               (instance.class-wrapper slotd))
     2179           (eq *standard-class-wrapper* (instance.class-wrapper class)))
     2180    (%std-setf-slot-value-using-class instance slotd new)
     2181    (setf (slot-value-using-class class instance slotd) new)))
    21812182
    21822183(defmethod slot-value-using-class ((class funcallable-standard-class)
    21832184                                   instance
    21842185                                   (slotd standard-effective-slot-definition))
    2185   (if (eql 0 (%wrapper-instance-slots (gf.instance.class-wrapper instance)))
    2186     (progn
    2187       (update-obsolete-instance instance)
    2188       (slot-value instance (standard-effective-slot-definition.name slotd)))
    2189     (let* ((loc (standard-effective-slot-definition.location slotd)))
     2186  (let* ((loc (standard-effective-slot-definition.location slotd)))
    21902187      (typecase loc
    21912188        (fixnum
    … …  
    21982195        (t
    21992196         (error "Slot definition ~s has invalid location ~s (allocation ~s)."
    2200                 slotd loc (slot-definition-allocation slotd)))))))
     2197                slotd loc (slot-definition-allocation slotd))))))
    22012198
    22022199(defmethod (setf slot-value-using-class)
    … …  
    22052202     instance
    22062203     (slotd standard-effective-slot-definition))
    2207   (if (eql 0 (%wrapper-instance-slots (gf.instance.class-wrapper instance)))
    2208     (progn
    2209       (update-obsolete-instance instance)
    2210       (setf (slot-value instance (standard-effective-slot-definition.name slotd)) new))
    2211     (let* ((loc (standard-effective-slot-definition.location slotd))
     2204  (let* ((loc (standard-effective-slot-definition.location slotd))
    22122205           (type (standard-effective-slot-definition.type slotd)))
    22132206      (if (and type (not (eq type t)))
    … …  
    22222215        (t
    22232216         (error "Slot definition ~s has invalid location ~s (allocation ~s)."
    2224                 slotd loc (slot-definition-allocation slotd)))))))
     2217                slotd loc (slot-definition-allocation slotd))))))
    22252218
    22262219
    … …  
    24152408             (%wrapper-instance-slots wrapper) 0
    24162409             (%wrapper-forwarding-info wrapper) forwarding-info
    2417              #| (%wrapper-slot-mapping-tables wrapper) 0 |#
     2410             (%wrapper-slot-id->slotd wrapper) #'%slot-id-lookup-obsolete
     2411             (%wrapper-slot-id-value wrapper) #'%slot-id-ref-obsolete
     2412             (%wrapper-set-slot-id-value wrapper) #'%slot-id-set-obsolete
    24182413             ))))
    24192414  wrapper)

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

    r103 r109  
    7272          (declare (ignore ignore))
    7373          (if foundp
    74             (if (consp loc)
    75               (rplacd loc new-value)
    76               (setf (standard-instance-instance-location-access instance loc) new-value))
     74            (progn
     75              (unless (funcall (standard-effective-slot-definition.type-predicate slotd) new-value)
     76                (report-bad-arg new-value (%slot-definition-type slotd)))
     77              (if (consp loc)
     78                (rplacd loc new-value)
     79                (setf (standard-instance-instance-location-access instance loc)
     80                      new-value)))
    7781            (if (or (eq slot-names t)
    7882                    (member (%slot-definition-name slotd)
    … …  
    8791                    (if initfunction
    8892                      (let* ((newval (funcall initfunction)))
     93                        (unless (funcall (standard-effective-slot-definition.type-predicate slotd) new-value)
     94                          (report-bad-arg new-value (%slot-definition-type slotd)))
    8995                        (if (consp loc)
    9096                          (rplacd loc newval)
    … …  
    128134           (%class.own-wrapper *standard-effective-slot-definition-class*)
    129135           name type initfunction initform initargs allocation
    130            documentation class nil (ensure-slot-id name))))
     136           documentation class nil (ensure-slot-id name) #'true)))
    131137
    132138(defmethod class-slots ((class class)))
    … …  
    182188     :initargs initargs
    183189     :initfunction (if initer (%slot-definition-initfunction initer))
    184      :initform (if initer (%slot-definition-initform initer)))))
     190     :initform (if initer (%slot-definition-initform initer))
     191     :type (or (%slot-definition-type first) t))))
    185192
    186193(defmethod compute-slots ((class slots-class))
    … …  
    326333                                   (ash -1 $lfbits-noname-bit))))
    327334           (class (%wrapper-class wrapper))
    328            (get-cell (list #'slot-value-using-class))
    329335           (get-f (gvector :function
    330336                           (%svref (if small
    … …  
    334340                           table
    335341                           class
    336                            get-cell
    337                            '%slot-id-ref-missing
     342                           #'%maybe-std-slot-value-using-class
     343                           #'%slot-id-ref-missing
    338344                           (dpb 2 $lfbits-numreq
    339345                                (ash -1 $lfbits-noname-bit))))
    340            (set-cell (list #'(setf slot-value-using-class)))
    341346           (set-f (gvector :function
    342347                           (%svref (if small
    … …  
    346351                           table
    347352                           class
    348                            set-cell
    349                            '%slot-id-set-missing
    350                            (dpb 2 $lfbits-numreq
     353                           #'%maybe-std-setf-slot-value-using-class
     354                           #'%slot-id-set-missing
     355                           (dpb 3 $lfbits-numreq
    351356                                (ash -1 $lfbits-noname-bit)))))
    352357      (setf (%wrapper-slot-id->slotd wrapper) lookup-f
    353             (%wrapper-class-svuc-effective-method-function wrapper) get-cell
    354             (%wrapper-class-ssvuc-effective-method-function wrapper) set-cell
    355358            (%wrapper-slot-id-value wrapper) get-f
    356359            (%wrapper-set-slot-id-value wrapper) set-f
    … …  
    987990                  :readers (slot-definition-location))
    988991                 (:name slot-id :initform nil :initfunction ,#'false
    989                   :readers (slot-definition-slot-id)))
     992                  :readers (slot-definition-slot-id))
     993                 (:name type-predicate :initform #'true
     994                  :initfunction ,#'(lambda () #'true)
     995                  :readers (slot-definition-predicate))
     996                 )
    990997 
    991998 :primary-p t)
    … …  
    9951002 :direct-superclasses '(slot-definition)
    9961003)
     1004
     1005
     1006
     1007
    9971008
    9981009
Note: See TracChangeset for help on using the changeset viewer.