Changeset 9510


Ignore:
Timestamp:
May 16, 2008, 1:17:02 AM (11 years ago)
Author:
gb
Message:

Try to exploit the fact that more "standard" slots are now present in
CLASS and BUILT-IN-CLASS, so we can use simpler accessors in some cases.

Except for the OBJC-BRIDGE, CLASSP is a standard-instance whose
instance.hash slot contains an integer less than MAX-CLASS-ORDINAL.
(1M) (This currently assumes that non-class instances - whose
instance.hash slots contain a fixnum derived from the instance's
address - are never allocated in the low 1MB of the address space,
and that there will never be more than 1M classes; both seem to
be safe assumptions at the moment.

SET-FIND-CLASS tries to keep the class's notion of whether or not
it's "properly named" in synch. (See also (SETF CLASS-NAME)).

ISTRUCT-based classes are made by a new primitive, which arranges
to ensure that the unique CONS used to map istruct instances to
their class info is registered (and references the class wrapper.)

The CLASS-OF method for ISTRUCTs explots this.

The functions that we get to via SLOT-ID-VALUE - and which try
to decide whether or not to call [SETF] SLOT-VALUE-USING-CLASS -
recognize structure instances.

Provide runtime support for doing SLOT-BOUNDP via a SLOT-ID.

Try to speed up slot lookup for runtime calls to SLOT-VALUE and friend;
FIND-SLOTD is just a loop.

In ALLOCATE-INSTANCE on a sructure, put list of class-cells (not
class-names) in 0th element of structure.

File:
1 edited

Legend:

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

    r9421 r9510  
    4343
    4444(defun %class-name (class)
    45   (%class.name class))
     45  (if (native-class-p class)
     46    (%class.name class)
     47    (class-name class)))
     48
     49(defun %class-info (class)
     50  (if (native-class-p class)
     51    (%class.info class)
     52    (class-info class)))
     53 
     54
     55(defun %class-kernel-p (class)
     56  (car (%class-info class)))
     57
     58(defun (setf %class-kernel-p) (new class)
     59  (setf (car (%class-info class)) new))
     60
     61(defun %class-proper-name (class)
     62  (cdr (%class-info class)))
     63
     64(defun (setf %class-proper-name) (new class)
     65  (setf (cdr (%class-info class)) new))
     66
    4667
    4768(defun %class-own-wrapper (class)
    48   (%class.own-wrapper class))
     69  (if (native-class-p class)
     70    (%class.own-wrapper class)
     71   (class-own-wrapper class)))
    4972
    5073(defun (setf %class-own-wrapper) (new class)
     
    5275
    5376(defun %class-alist (class)
    54   (if (typep class 'slots-class)
    55     (%class.alist class)))
     77  (%class.alist class))
    5678
    5779(defun (setf %class-alist) (new class)
     
    6183
    6284(defun %class-slots (class)
    63   (if (typep class 'slots-class)
    64     (%class.slots class)))
     85  (if (native-class-p class)
     86    (%class.slots class)
     87    (class-slots class)))
    6588
    6689(defun (setf %class-slots) (new class)
    67   (if (typep class 'slots-class)
     90  (if (native-class-p class)
    6891    (setf (%class.slots class) new)
    69     new))
     92    (setf (class-slots class) new)))
    7093
    7194(defun %class-direct-slots (class)
    72   (if (typep class 'slots-class)
    73     (%class.direct-slots class)))
     95  (if (native-class-p class)
     96    (%class.direct-slots class)
     97    (class-direct-slots class)))
    7498
    7599(defun (setf %class-direct-slots) (new class)
    76   (if (typep class 'slots-class)
    77     (setf (%class.direct-slots class) new))
    78   new)
    79  
     100  (if (native-class-p class)
     101    (setf (%class.direct-slots class) new)
     102    (setf (class-direct-slots class) new)))
     103
     104
     105
     106
     107
     108
    80109(defun %class-direct-superclasses (class)
    81110  (%class.local-supers class))
     
    213242                                 next-slot-index))
    214243  )
     244
     245
    215246
    216247
     
    938969    (loop
    939970      (multiple-value-bind (found name cell) (m)
    940         (declare (list cell))
     971        (declare (type class-cell cell))
    941972        (unless found (return))
    942         (when (cdr cell)
     973        (when cell
    943974          (funcall function name (class-cell-class cell)))))))
    944975
     
    10111042(defun invalidate-initargs-vector-for-gf (gf &optional first-specializer &rest other-specializers)
    10121043  (declare (ignore other-specializers))
    1013   (when (and first-specializer (typep first-specializer 'class))        ; no eql methods or gfs with no specializers need apply
     1044  (when (and first-specializer (typep first-specializer 'class)) ; no eql methods or gfs with no specializers need apply
    10141045    (let ((indices (cdr (assq gf *initialization-invalidation-alist*))))
    10151046      (when indices
    10161047        (labels ((invalidate (class indices)
    1017                              (when (std-class-p class)  ; catch the class named T
    1018                                (dolist (index indices)
    1019                                  (setf (standard-instance-instance-location-access class index) nil)))
    1020                              (dolist (subclass (%class.subclasses class))
    1021                                (invalidate subclass indices))))
     1048                   (when (std-class-p class) ; catch the class named T
     1049                     (dolist (index indices)
     1050                       (setf (standard-instance-instance-location-access class index) nil)))
     1051                   (dolist (subclass (%class.subclasses class))
     1052                     (invalidate subclass indices))))
    10221053          (invalidate first-specializer indices))))))
    10231054
     
    12101241;;;;;;;;;;;;;;;;;;;;;;;;  Instances and classes ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    12111242
    1212 (defvar %find-classes% (make-hash-table :test 'eq))
    1213 
     1243
     1244(defun instance-class-wrapper (instance)
     1245  (cond ((%standard-instance-p instance) (instance.class-wrapper instance))
     1246        ((structurep instance) (%class.own-wrapper
     1247                                (class-cell-class (car (%svref instance 0)))))
     1248        ((eql (typecode instance) target::subtag-istruct)
     1249         (istruct-cell-info (%svref instance 0)))
     1250        ((typep instance 'funcallable-standard-object)
     1251         (gf.instance.class-wrapper instance))
     1252        ((typep instance 'macptr) (foreign-instance-class-wrapper instance))
     1253        (t (%class.own-wrapper (class-of instance)))))
    12141254
    12151255(defun class-cell-typep (form class-cell)
     
    12451285
    12461286
    1247 (defun find-class-cell (name create?)
    1248   (let ((cell (gethash name %find-classes%)))
    1249     (or cell
    1250         (and create?
    1251              (setf (gethash name %find-classes%) (make-class-cell name))))))
    1252 
    12531287
    12541288(defun find-class (name &optional (errorp t) environment)
     
    12661300          (find-class name errorp environment)))))
    12671301
     1302(defun update-class-proper-names (name old-class new-class)
     1303  (when (and old-class
     1304             (not (eq old-class new-class))
     1305             (eq (%class-proper-name old-class) name))
     1306    (setf (%class-proper-name old-class) nil))
     1307  (when (and new-class (eq (%class-name new-class) name))
     1308    (setf (%class-proper-name new-class) name)))
     1309
     1310
    12681311(defun set-find-class (name class)
    12691312  (clear-type-cache)
    1270   (let ((cell (find-class-cell name class)))
    1271     (when cell
    1272       (when class
    1273         (if (eq name (%class.name class))
    1274           (setf (info-type-kind name) :instance)))
    1275       (setf (class-cell-class cell) class))
     1313  (let* ((cell (find-class-cell name t))
     1314         (old-class (class-cell-class cell)))
     1315    (when class
     1316      (if (eq name (%class.name class))
     1317        (setf (info-type-kind name) :instance)))
     1318    (setf (class-cell-class cell) class)
     1319    (update-class-proper-names name old-class class)
    12761320    class))
    12771321
     
    13071351(defun check-setf-find-class-protected-class (old-class new-class name)
    13081352  (when (and (standard-instance-p old-class)
    1309              (%class.kernel-p old-class)
     1353             (%class-kernel-p old-class)
    13101354             *warn-if-redefine-kernel*
    13111355             ;; EQL might be necessary on foreign classes
     
    13151359marked as being a critical part of the system; an attempt is being made
    13161360to replace that class with ~s" name old-class new-class)
    1317     (setf (%class.kernel-p old-class) nil)))
     1361    (setf (%class-kernel-p old-class) nil)))
    13181362
    13191363
     
    13211365 (defun set-find-class (name class)
    13221366   (setq name (require-type name 'symbol))
    1323    (let ((cell (find-class-cell name t)))
     1367   (let* ((cell (find-class-cell name t))
     1368          (old-class (class-cell-class cell)))
    13241369     (declare (type class-cell cell))
    1325        (let ((old-class (class-cell-class cell)))
    1326          (when old-class
    1327            (when (eq (%class.name old-class) name)
    1328              (setf (info-type-kind name) nil)
    1329              (clear-type-cache))
    1330            (when *warn-if-redefine-kernel*
    1331              (check-setf-find-class-protected-class old-class class name))))
     1370     (when old-class
     1371       (when (eq (%class.name old-class) name)
     1372         (setf (info-type-kind name) nil)
     1373         (clear-type-cache))
     1374       (when *warn-if-redefine-kernel*
     1375         (check-setf-find-class-protected-class old-class class name)))
    13321376     (when (null class)
    13331377       (when cell
    13341378         (setf (class-cell-class cell) nil))
     1379       (update-class-proper-names name old-class class)
    13351380       (return-from set-find-class nil))
    13361381     (setq class (require-type class 'class))
     
    13451390         (%deftype name nil nil))
    13461391       (setf (info-type-kind name) :instance))
     1392     (update-class-proper-names name old-class class)
    13471393     (setf (class-cell-class cell) class)))
    13481394 )                                      ; end of queue-fixup
     
    14931539    class))
    14941540
     1541(defun make-istruct-class (name &rest supers)
     1542  (let* ((class (apply #'make-built-in-class name supers))
     1543         (cell (register-istruct-cell name)))
     1544    (setf (istruct-cell-info cell) (%class.own-wrapper class))
     1545    class))
     1546
    14951547;;; This will be filled in below.  Need it defined now as it goes in
    14961548;;; the instance.class-wrapper of all the classes that STANDARD-CLASS
     
    17411793  (defstatic *read-write-lock-class* (make-built-in-class 'read-write-lock *lock-class*))
    17421794 
    1743   (make-built-in-class 'lock-acquisition *istruct-class*)
    1744   (make-built-in-class 'semaphore-notification *istruct-class*)
    1745   (make-built-in-class 'class-wrapper *istruct-class*)
     1795  (make-istruct-class 'lock-acquisition *istruct-class*)
     1796  (make-istruct-class 'semaphore-notification *istruct-class*)
     1797  (make-istruct-class 'class-wrapper *istruct-class*)
    17461798  ;; Compiler stuff, mostly
    1747   (make-built-in-class 'faslapi *istruct-class*)
    1748   (make-built-in-class 'var *istruct-class*)
    1749   (make-built-in-class 'afunc *istruct-class*)
    1750   (make-built-in-class 'lexical-environment *istruct-class*)
    1751   (make-built-in-class 'definition-environment *istruct-class*)
    1752   (make-built-in-class 'compiler-policy *istruct-class*)
    1753   (make-built-in-class 'deferred-warnings *istruct-class*)
    1754   (make-built-in-class 'ptaskstate *istruct-class*)
    1755   (make-built-in-class 'entry *istruct-class*)
    1756   (make-built-in-class 'foreign-object-domain *istruct-class*)
     1799  (make-istruct-class 'faslapi *istruct-class*)
     1800  (make-istruct-class 'faslstate *istruct-class*)
     1801  (make-istruct-class 'var *istruct-class*)
     1802  (make-istruct-class 'afunc *istruct-class*)
     1803  (make-istruct-class 'lexical-environment *istruct-class*)
     1804  (make-istruct-class 'definition-environment *istruct-class*)
     1805  (make-istruct-class 'compiler-policy *istruct-class*)
     1806  (make-istruct-class 'deferred-warnings *istruct-class*)
     1807  (make-istruct-class 'ptaskstate *istruct-class*)
     1808  (make-istruct-class 'entry *istruct-class*)
     1809  (make-istruct-class 'foreign-object-domain *istruct-class*)
    17571810
    17581811 
    1759   (make-built-in-class 'slot-id *istruct-class*)
     1812  (make-istruct-class 'slot-id *istruct-class*)
    17601813  (make-built-in-class 'value-cell)
    1761   (make-built-in-class 'restart *istruct-class*)
    1762   (make-built-in-class 'hash-table *istruct-class*)
    1763   (make-built-in-class 'readtable *istruct-class*)
    1764   (make-built-in-class 'pathname *istruct-class*)
    1765   (make-built-in-class 'random-state *istruct-class*)
    1766   (make-built-in-class 'xp-structure *istruct-class*)
    1767   (make-built-in-class 'lisp-thread *istruct-class*)
    1768   (make-built-in-class 'resource *istruct-class*)
    1769   (make-built-in-class 'periodic-task *istruct-class*)
    1770   (make-built-in-class 'semaphore *istruct-class*)
     1814  (make-istruct-class 'restart *istruct-class*)
     1815  (make-istruct-class 'hash-table *istruct-class*)
     1816  (make-istruct-class 'readtable *istruct-class*)
     1817  (make-istruct-class 'pathname *istruct-class*)
     1818  (make-istruct-class 'random-state *istruct-class*)
     1819  (make-istruct-class 'xp-structure *istruct-class*)
     1820  (make-istruct-class 'lisp-thread *istruct-class*)
     1821  (make-istruct-class 'resource *istruct-class*)
     1822  (make-istruct-class 'periodic-task *istruct-class*)
     1823  (make-istruct-class 'semaphore *istruct-class*)
    17711824 
    1772   (make-built-in-class 'type-class *istruct-class*)
     1825  (make-istruct-class 'type-class *istruct-class*)
    17731826 
    1774   (defstatic *ctype-class* (make-built-in-class 'ctype *istruct-class*))
    1775   (make-built-in-class 'key-info *istruct-class*)
    1776   (defstatic *args-ctype* (make-built-in-class 'args-ctype *ctype-class*))
    1777   (make-built-in-class 'values-ctype *args-ctype*)
    1778   (make-built-in-class 'function-ctype *args-ctype*)
    1779   (make-built-in-class 'constant-ctype *ctype-class*)
    1780   (make-built-in-class 'named-ctype *ctype-class*)
    1781   (make-built-in-class 'cons-ctype *ctype-class*)
    1782   (make-built-in-class 'unknown-ctype (make-built-in-class 'hairy-ctype *ctype-class*))
    1783   (make-built-in-class 'numeric-ctype *ctype-class*)
    1784   (make-built-in-class 'array-ctype *ctype-class*)
    1785   (make-built-in-class 'member-ctype *ctype-class*)
    1786   (make-built-in-class 'union-ctype *ctype-class*)
    1787   (make-built-in-class 'foreign-ctype *ctype-class*)
    1788   (make-built-in-class 'class-ctype *ctype-class*)
    1789   (make-built-in-class 'negation-ctype *ctype-class*)
    1790   (make-built-in-class 'intersection-ctype *ctype-class*)
     1827  (defstatic *ctype-class* (make-istruct-class 'ctype *istruct-class*))
     1828  (make-istruct-class 'key-info *istruct-class*)
     1829  (defstatic *args-ctype* (make-istruct-class 'args-ctype *ctype-class*))
     1830  (make-istruct-class 'values-ctype *args-ctype*)
     1831  (make-istruct-class 'function-ctype *args-ctype*)
     1832  (make-istruct-class 'constant-ctype *ctype-class*)
     1833  (make-istruct-class 'named-ctype *ctype-class*)
     1834  (make-istruct-class 'cons-ctype *ctype-class*)
     1835  (make-istruct-class 'unknown-ctype (make-istruct-class 'hairy-ctype *ctype-class*))
     1836  (make-istruct-class 'numeric-ctype *ctype-class*)
     1837  (make-istruct-class 'array-ctype *ctype-class*)
     1838  (make-istruct-class 'member-ctype *ctype-class*)
     1839  (make-istruct-class 'union-ctype *ctype-class*)
     1840  (make-istruct-class 'foreign-ctype *ctype-class*)
     1841  (make-istruct-class 'class-ctype *ctype-class*)
     1842  (make-istruct-class 'negation-ctype *ctype-class*)
     1843  (make-istruct-class 'intersection-ctype *ctype-class*)
    17911844 
    1792   (make-built-in-class 'class-cell *istruct-class*)
    1793   (make-built-in-class 'type-cell *istruct-class*)
    1794   (make-built-in-class 'package-ref *istruct-class*)
     1845  (make-istruct-class 'class-cell *istruct-class*)
     1846  (make-istruct-class 'type-cell *istruct-class*)
     1847  (make-istruct-class 'package-ref *istruct-class*)
     1848
     1849  (make-istruct-class 'foreign-variable *istruct-class*)
     1850  (make-istruct-class 'external-entry-point *istruct-class*)
     1851  (make-istruct-class 'shlib *istruct-class*)
     1852
    17951853  (make-built-in-class 'complex (find-class 'number))
    17961854  (make-built-in-class 'real (find-class 'number))
     
    18151873
    18161874
    1817   (make-built-in-class 'logical-pathname (find-class 'pathname))
     1875  (make-istruct-class 'logical-pathname (find-class 'pathname))
     1876
     1877  (make-istruct-class 'destructure-state *istruct-class*)
    18181878 
    18191879  (defstatic *base-char-class* (alias-class 'base-char *character-class*))
     
    22642324              #'(lambda (s) (%structure-class-of s))) ; need DEFSTRUCT
    22652325        (setf (%svref v target::subtag-istruct)
    2266               #'(lambda (i) (or (find-class (%svref i 0) nil) *istruct-class*)))
     2326              #'(lambda (i)
     2327                  (let* ((cell (%svref i 0))
     2328                         (wrapper (istruct-cell-info  cell)))
     2329                    (if wrapper
     2330                      (%wrapper-class wrapper)
     2331                      (or (find-class (istruct-cell-name cell) nil)
     2332                          *istruct-class*)))))
    22672333        (setf (%svref v target::subtag-basic-stream)
    22682334              #'(lambda (b) (basic-stream.class b)))
     
    23352401
    23362402
    2337 ;;; Can't use typep at bootstrapping time.
     2403;;; True if X is a class but not a foreign-class.
     2404(defun native-class-p (x)
     2405  (if (%standard-instance-p x)
     2406    (< (the fixnum (instance.hash x)) max-class-ordinal)))
     2407
    23382408(defun classp (x)
    2339   (or (and (typep x 'macptr) (foreign-classp x))                ; often faster
    2340       (let ((wrapper (standard-object-p x)))
    2341         (or
    2342          (and wrapper
    2343               (let ((super (%wrapper-class wrapper)))
    2344                 (memq *class-class* (%inited-class-cpl super t))))))))
     2409  (if (%standard-instance-p x)
     2410    (< (the fixnum (instance.hash x)) max-class-ordinal)
     2411    (and (typep x 'macptr) (foreign-classp x))))
    23452412
    23462413(set-type-predicate 'class 'classp)
     
    25962663(declaim (inline find-slotd))
    25972664(defun find-slotd (name slots)
    2598   (find name slots :key #'%slot-definition-name))
     2665  (dolist (slotd slots)
     2666    (when (eq name (standard-slot-definition.name slotd))
     2667      (return slotd))))
    25992668
    26002669(declaim (inline %std-slot-vector-value))
     
    26302699           (eq *standard-class-wrapper* (instance.class-wrapper class)))
    26312700    (%std-slot-vector-value (instance-slots instance) slotd)
    2632     (slot-value-using-class class instance slotd)))
     2701    (if (= (the fixnum (typecode instance)) target::subtag-struct)
     2702      (struct-ref instance (standard-effective-slot-definition.location slotd))
     2703      (slot-value-using-class class instance slotd))))
    26332704
    26342705
     
    26742745    ;; Not safe to use instance.slots here, since the instance is not
    26752746    ;; definitely of type SUBTAG-INSTANCE.  (Anyway, INSTANCE-SLOTS
    2676     ;; should be inlined here.
     2747    ;; should be inlined here.)
    26772748    (%set-std-slot-vector-value (instance-slots instance) slotd new)
    2678     (setf (slot-value-using-class class instance slotd) new)))
     2749    (if (structurep instance)
     2750      (setf (struct-ref instance (standard-effective-slot-definition.location slotd))
     2751            new)
     2752      (setf (slot-value-using-class class instance slotd) new))))
    26792753
    26802754(defmethod slot-value-using-class ((class funcallable-standard-class)
     
    26912765
    26922766(defun slot-value (instance slot-name)
    2693   (let* ((class (class-of instance))
    2694            (slotd (find-slotd slot-name (%class-slots class))))
    2695       (if slotd
    2696        (slot-value-using-class class instance slotd)
    2697        (restart-case
    2698            (values (slot-missing class instance slot-name 'slot-value))
     2767  (let* ((wrapper
     2768          (let* ((w (instance-class-wrapper instance)))
     2769            (if (eql 0 (%wrapper-hash-index w))
     2770              (instance.class-wrapper (update-obsolete-instance instance))
     2771              w)))
     2772         (class (%wrapper-class wrapper))
     2773         (slotd (find-slotd slot-name (if (%standard-instance-p class)
     2774                                        (%class.slots class)
     2775                                        (class-slots class)))))
     2776    (if slotd
     2777      (%maybe-std-slot-value-using-class class instance slotd)
     2778      (if (typep slot-name 'symbol)
     2779        (restart-case
     2780         (values (slot-missing class instance slot-name 'slot-value))
    26992781         (continue ()
    2700            :report "Try accessing the slot again"
    2701            (slot-value instance slot-name))
     2782                   :report "Try accessing the slot again"
     2783                   (slot-value instance slot-name))
    27022784         (use-value (value)
    2703            :report "Return a value"
    2704            :interactive (lambda ()
    2705                           (format *query-io* "~&Value to use: ")
    2706                           (list (read *query-io*)))
    2707            value)))))
    2708    
     2785                    :report "Return a value"
     2786                    :interactive (lambda ()
     2787                                   (format *query-io* "~&Value to use: ")
     2788                                   (list (read *query-io*)))
     2789                    value))
     2790        (report-bad-arg slot-name 'symbol)))))
    27092791
    27102792
     
    27332815
    27342816(defun set-slot-value (instance name value)
    2735   (let* ((class (class-of instance))
    2736              (slotd (find-slotd  name (%class-slots class))))
    2737         (if slotd
    2738           (setf (slot-value-using-class class instance slotd) value)
    2739           (progn           
    2740             (slot-missing class instance name 'setf value)
    2741             value))))
     2817  (let* ((wrapper
     2818          (let* ((w (instance-class-wrapper instance)))
     2819            (if (eql 0 (%wrapper-hash-index w))
     2820              (instance.class-wrapper (update-obsolete-instance instance))
     2821              w)))
     2822         (class (%wrapper-class wrapper))
     2823         (slotd (find-slotd name (if (%standard-instance-p class)
     2824                                   (%class.slots class)
     2825                                   (class-slots class)))))
     2826    (if slotd
     2827      (%maybe-std-setf-slot-value-using-class class instance slotd value)
     2828      (if (typep name 'symbol)
     2829        (progn     
     2830          (slot-missing class instance name 'setf value)
     2831          value)
     2832        (report-bad-arg name 'symbol)))))
    27422833
    27432834(defsetf slot-value set-slot-value)
     
    27622853                slotd loc (slot-definition-allocation slotd))))))
    27632854
     2855(defun %maybe-std-slot-boundp-using-class (class instance slotd)
     2856  (if (and (eql (typecode class) target::subtag-instance)
     2857           (eql (typecode slotd) target::subtag-instance)
     2858           (eq *standard-effective-slot-definition-class-wrapper*
     2859               (instance.class-wrapper slotd))
     2860           (eq *standard-class-wrapper* (instance.class-wrapper class)))
     2861    (%std-slot-vector-boundp (instance-slots instance) slotd)
     2862    (slot-boundp-using-class class instance slotd)))
     2863
     2864
    27642865(defmethod slot-boundp-using-class ((class standard-class)
    27652866                                    instance
     
    27772878
    27782879(defun slot-boundp (instance name)
    2779   (let* ((class (class-of instance))
    2780          (slotd (find-slotd name (%class-slots class))))
     2880  (let* ((wrapper
     2881          (let* ((w (instance-class-wrapper instance)))
     2882            (if (eql 0 (%wrapper-hash-index w))
     2883              (instance.class-wrapper (update-obsolete-instance instance))
     2884              w)))
     2885         (class (%wrapper-class wrapper))
     2886         (slotd (find-slotd name (if (%standard-instance-p class)
     2887                                   (%class.slots class)
     2888                                   (class-slots class)))))
    27812889    (if slotd
    2782       (slot-boundp-using-class class instance slotd)
    2783       (values (slot-missing class instance name 'slot-boundp)))))
     2890      (%maybe-std-slot-boundp-using-class class instance slotd)
     2891      (if (typep name 'symbol)
     2892        (values (slot-missing class instance name 'slot-boundp))
     2893        (report-bad-arg name 'symbol)))))
    27842894
    27852895(defun slot-value-if-bound (instance name &optional default)
     
    27952905
    27962906(defun slot-id-value (instance slot-id)
    2797   (let* ((wrapper (or (standard-object-p instance)
    2798                     (%class-own-wrapper (class-of instance)))))
     2907  (let* ((wrapper (instance-class-wrapper instance)))
    27992908    (funcall (%wrapper-slot-id-value wrapper) instance slot-id)))
    28002909
    28012910(defun set-slot-id-value (instance slot-id value)
    2802   (let* ((wrapper (or (standard-object-p instance)
    2803                     (%class-own-wrapper (class-of instance)))))
     2911  (let* ((wrapper (instance-class-wrapper instance)))
    28042912    (funcall (%wrapper-set-slot-id-value wrapper) instance slot-id value)))
    28052913
     2914(defun slot-id-boundp (instance slot-id)
     2915  (let* ((wrapper (instance-class-wrapper instance))
     2916         (class (%wrapper-class wrapper))
     2917         (slotd (funcall (%wrapper-slot-id->slotd wrapper) slot-id)))
     2918    (if slotd
     2919      (%maybe-std-slot-boundp-using-class class instance slotd)
     2920      (values (slot-missing class instance (slot-id.name slot-id) 'slot-boundp)))))
     2921 
    28062922;;; returns nil if (apply gf args) wil cause an error because of the
    28072923;;; non-existance of a method (or if GF is not a generic function or the name
     
    35813697
    35823698
    3583 (defun instance-class-wrapper (instance)
    3584   (cond ((%standard-instance-p instance) (instance.class-wrapper instance))
    3585         ((typep instance 'funcallable-standard-object)
    3586          (gf.instance.class-wrapper instance))
    3587         ((typep instance 'macptr) (foreign-instance-class-wrapper instance))
    3588         (t (%class.own-wrapper (class-of instance)))))
     3699
    35893700
    35903701
     
    36483759                 (error "Can't find structure named ~s" class-name)))
    36493760         (res (make-structure-vector (sd-size sd))))
    3650     (setf (%svref res 0) (sd-superclasses sd))
     3761    (setf (%svref res 0) (mapcar (lambda (x)
     3762                                   (find-class-cell x t)) (sd-superclasses sd)))
    36513763    res))
    36523764
Note: See TracChangeset for help on using the changeset viewer.