Ignore:
Timestamp:
Aug 11, 2008, 3:49:48 AM (11 years ago)
Author:
gb
Message:

Merge a lot of the CLOS/type-system changes from working-0711 branch
into trunk. Todo: compiler-macros for those changes.

Have -not- yet merged source-tracking changes, new record-source file
from working-0711, but this stuff seems to bootstrap in one swell foop.

File:
1 edited

Legend:

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

    r10424 r10426  
    4141          (t (%non-standard-instance-slots instance typecode)))))
    4242
     43
     44;;; True if X is a class but not a foreign-class.
     45(defun native-class-p (x)
     46  (if (%standard-instance-p x)
     47    (< (the fixnum (instance.hash x)) max-class-ordinal)))
     48
    4349(defun %class-name (class)
    44   (%class.name class))
     50  (if (native-class-p class)
     51    (%class.name class)
     52    (class-name class)))
    4553
    4654(defun %class-info (class)
    47   (%class.info class))
    48 
     55  (if (native-class-p class)
     56    (%class.info class)
     57    (class-info class)))
     58 
    4959
    5060(defun %class-kernel-p (class)
     
    6272
    6373(defun %class-own-wrapper (class)
    64   (%class.own-wrapper class))
     74  (if (native-class-p class)
     75    (%class.own-wrapper class)
     76   (class-own-wrapper class)))
    6577
    6678(defun (setf %class-own-wrapper) (new class)
     
    6880
    6981(defun %class-alist (class)
    70   (if (typep class 'slots-class)
    71     (%class.alist class)))
     82  (%class.alist class))
    7283
    7384(defun (setf %class-alist) (new class)
     
    7788
    7889(defun %class-slots (class)
    79   (if (typep class 'slots-class)
    80     (%class.slots class)))
     90  (if (native-class-p class)
     91    (%class.slots class)
     92    (class-slots class)))
    8193
    8294(defun (setf %class-slots) (new class)
    83   (if (typep class 'slots-class)
     95  (if (native-class-p class)
    8496    (setf (%class.slots class) new)
    85     new))
     97    (setf (class-slots class) new)))
    8698
    8799(defun %class-direct-slots (class)
    88   (if (typep class 'slots-class)
    89     (%class.direct-slots class)))
     100  (if (native-class-p class)
     101    (%class.direct-slots class)
     102    (class-direct-slots class)))
    90103
    91104(defun (setf %class-direct-slots) (new class)
    92   (if (typep class 'slots-class)
    93     (setf (%class.direct-slots class) new))
    94   new)
    95  
     105  (if (native-class-p class)
     106    (setf (%class.direct-slots class) new)
     107    (setf (class-direct-slots class) new)))
     108
     109
     110
     111
     112
     113
    96114(defun %class-direct-superclasses (class)
    97115  (%class.local-supers class))
     
    229247                                 next-slot-index))
    230248  )
     249
     250
    231251
    232252
     
    342362        (when aokp (setq bits (%ilogior (%ilsl $lfbits-aok-bit 1) bits)))
    343363        (if return-keys?
    344           (values bits (if key-list (apply #'vector (nreverse key-list)) #()))
    345           (values bits nil))))))
     364          (values bits (apply #'vector (nreverse key-list)))
     365          bits)))))
    346366
    347367(defun pair-arg-p (thing &optional lambda-list-ok supplied-p-ok keyword-nesting-ok)
     
    574594          nil))
    575595
     596(defparameter *uniquify-dcode* #+unique-dcode t #-unique-dcode nil
     597  "If true, each gf will get its own unique copy of its dcode.  Not recommended for
     598   real use (for one thing, it's known to break gf tracing), but may be helpful for
     599   profiling")
     600
    576601(let* ((class-wrapper-random-state (make-random-state))
    577602       (class-wrapper-random-state-lock (make-lock)))
     
    701726      (mapcar #'canonicalize-specializer specializers))))
    702727
     728(defparameter *sealed-clos-world* nil "When true, class and method definition -at least - are disallowed.")
     729
    703730(defun ensure-method (name specializers &rest keys &key (documentation nil doc-p) qualifiers
    704731                           &allow-other-keys)
    705732  (declare (dynamic-extent keys))
    706   (setq specializers (canonicalize-specializers specializers))
    707   (let* ((gf (ensure-generic-function name))
    708          (method (apply #'%make-method-instance
    709                         (%gf-method-class gf)
    710                         :name name
    711                         :specializers specializers
    712                         keys))
    713          (old-method (when (%gf-methods gf)
    714                        (ignore-errors
    715                          (find-method gf qualifiers specializers nil)))))
    716 
    717     (%add-method gf method)
    718     (when (and doc-p *save-doc-strings*)
    719       (set-documentation method t documentation))
    720     (record-source-file method 'method)
    721     (when old-method (%move-method-encapsulations-maybe old-method method))
    722     method))
     733  (if *sealed-clos-world*
     734    (error "Method (re)definition is not allowed in this environment.")
     735    (progn
     736      (setq specializers (canonicalize-specializers specializers))
     737      (let* ((gf (ensure-generic-function name))
     738             (method (apply #'%make-method-instance
     739                            (%gf-method-class gf)
     740                            :name name
     741                            :specializers specializers
     742                            keys))
     743             (old-method (when (%gf-methods gf)
     744                           (ignore-errors
     745                             (find-method gf qualifiers specializers nil)))))
     746
     747        (%add-method gf method)
     748        (when (and doc-p *save-doc-strings*)
     749          (set-documentation method t documentation))
     750        (record-source-file method 'method)
     751        (when old-method (%move-method-encapsulations-maybe old-method method))
     752        method))))
    723753       
    724754
     
    841871  (%add-standard-method-to-standard-gf gf method))
    842872
     873;; Redefined in l1-clos.lisp
     874(defun maybe-remove-make-instance-optimization (gfn method)
     875  (declare (ignore gfn method))
     876  nil)
     877
    843878(defun %add-standard-method-to-standard-gf (gfn method)
    844879  (when (%method-gf method)
     
    850885         (qualifiers (%method-qualifiers method)))
    851886    (remove-obsoleted-combined-methods method dt specializers)
     887    (maybe-remove-make-instance-optimization gfn method)
    852888    (apply #'invalidate-initargs-vector-for-gf gfn specializers)
    853889    (dolist (m methods)
     
    923959    (loop
    924960      (multiple-value-bind (found name cell) (m)
    925         (declare (list cell))
     961        (declare (type class-cell cell))
    926962        (unless found (return))
    927         (when (cdr cell)
     963        (when cell
    928964          (funcall function name (class-cell-class cell)))))))
    929965
     
    9681004   (when dt
    9691005     (if specializers
    970        (let* ((argnum (%gf-dispatch-table-argnum dt))
    971               (class (nth argnum specializers))
    972               (size (%gf-dispatch-table-size dt))
    973               (index 0))
    974          (clear-accessor-method-offsets (%gf-dispatch-table-gf dt) method)
    975          (if (typep class 'eql-specializer)
    976            (setq class (class-of (eql-specializer-object class))))
    977          (while (%i< index size)
    978            (let* ((wrapper (%gf-dispatch-table-ref dt index))
    979                   hash-index-0?
    980                   (cpl (and wrapper
    981                             (not (setq hash-index-0?
    982                                        (eql 0 (%wrapper-hash-index wrapper))))
    983                             (%inited-class-cpl
    984                              (require-type (%wrapper-class wrapper) 'class)))))
    985              (when (or hash-index-0? (and cpl (cpl-index class cpl)))
    986                (setf (%gf-dispatch-table-ref dt index) *obsolete-wrapper*
    987                      (%gf-dispatch-table-ref dt (%i+ index 1)) *gf-dispatch-bug*))
    988              (setq index (%i+ index 2)))))
     1006       (let* ((argnum (%gf-dispatch-table-argnum dt)))
     1007         (when (>= argnum 0)
     1008           (let ((class (nth argnum specializers))
     1009                 (size (%gf-dispatch-table-size dt))
     1010                 (index 0))
     1011             (clear-accessor-method-offsets (%gf-dispatch-table-gf dt) method)
     1012             (if (typep class 'eql-specializer)
     1013                 (setq class (class-of (eql-specializer-object class))))
     1014             (while (%i< index size)
     1015               (let* ((wrapper (%gf-dispatch-table-ref dt index))
     1016                      hash-index-0?
     1017                      (cpl (and wrapper
     1018                                (not (setq hash-index-0?
     1019                                           (eql 0 (%wrapper-hash-index wrapper))))
     1020                                (%inited-class-cpl
     1021                                 (require-type (%wrapper-class wrapper) 'class)))))
     1022                 (when (or hash-index-0? (and cpl (cpl-index class cpl)))
     1023                   (setf (%gf-dispatch-table-ref dt index) *obsolete-wrapper*
     1024                         (%gf-dispatch-table-ref dt (%i+ index 1)) *gf-dispatch-bug*))
     1025                 (setq index (%i+ index 2)))))))
    9891026       (setf (%gf-dispatch-table-ref dt 1) nil)))))   ; clear 0-arg gf cm
    9901027
     
    9951032(defun invalidate-initargs-vector-for-gf (gf &optional first-specializer &rest other-specializers)
    9961033  (declare (ignore other-specializers))
    997   (when (and first-specializer (typep first-specializer 'class))        ; no eql methods or gfs with no specializers need apply
     1034  (when (and first-specializer (typep first-specializer 'class)) ; no eql methods or gfs with no specializers need apply
    9981035    (let ((indices (cdr (assq gf *initialization-invalidation-alist*))))
    9991036      (when indices
    10001037        (labels ((invalidate (class indices)
    1001                              (when (std-class-p class)  ; catch the class named T
    1002                                (dolist (index indices)
    1003                                  (setf (standard-instance-instance-location-access class index) nil)))
    1004                              (dolist (subclass (%class.subclasses class))
    1005                                (invalidate subclass indices))))
     1038                   (when (std-class-p class) ; catch the class named T
     1039                     (dolist (index indices)
     1040                       (setf (standard-instance-instance-location-access class index) nil)))
     1041                   (dolist (subclass (%class.subclasses class))
     1042                     (invalidate subclass indices))))
    10061043          (invalidate first-specializer indices))))))
    10071044
     
    10111048;;; 2) the index of the first non-T specializer
    10121049(defun multi-method-index (method &aux (i 0) index)
    1013   (dolist (s (%method-specializers method) (values nil index))
     1050  (dolist (s (%method.specializers method) (values nil index))
    10141051    (unless (eq s *t-class*)
    10151052      (unless index (setq index i))
     
    10441081
    10451082
    1046            
    1047  
    10481083(defvar *writer-method-function-proto*
    10491084  #'(lambda (new instance)
    10501085      (set-slot-value instance 'x new)))
    10511086
     1087(defun dcode-for-gf (gf dcode)
     1088  (if *uniquify-dcode*
     1089    (let ((new-dcode (%copy-function dcode)))
     1090      (lfun-name new-dcode (list (lfun-name dcode) (lfun-name gf)))
     1091      new-dcode)
     1092    dcode))
    10521093
    10531094(defstatic *non-dt-dcode-functions* () "List of functions which return a dcode function for the GF which is their argument.  The dcode functions will be caled with all of the incoming arguments.")
     
    10581099      (when dcode (return dcode)))))
    10591100
    1060            
    10611101(defun compute-dcode (gf &optional dt)
    10621102  (setq gf (require-type gf 'standard-generic-function))
     
    11841224  (let* ((typecode (typecode instance)))
    11851225    (declare (type (unsigned-byte 8) typecode))
    1186     (cond ((eql typecode target::subtag-istruct)
     1226    (cond ((eql typecode target::subtag-struct)
     1227           (%class.own-wrapper
     1228            (class-cell-class (car (%svref instance 0)))))
     1229          ((eql typecode target::subtag-istruct)
    11871230           (istruct-cell-info (%svref instance 0)))
    11881231          ((eql typecode target::subtag-basic-stream)
     
    11901233          ((typep instance 'funcallable-standard-object)
    11911234           (gf.instance.class-wrapper instance))
    1192           ((eql typecode target::subtag-macptr)
    1193            (foreign-instance-class-wrapper instance))
     1235          ((eql typecode target::subtag-macptr) (foreign-instance-class-wrapper instance))
    11941236          (t (%class.own-wrapper (class-of instance))))))
    11951237
    11961238(defun instance-class-wrapper (instance)
    1197   (if (= (typecode instance) target::subtag-instance)
     1239  (if (= (typecode instance)  target::subtag-instance)
    11981240    (instance.class-wrapper instance)
    11991241    (non-standard-instance-class-wrapper instance)))
    12001242
    12011243
     1244(defun std-instance-class-cell-typep (form class-cell)
     1245  (declare (type class-cell  class-cell))
     1246  (let* ((typecode (typecode form))
     1247         (wrapper (cond ((= typecode target::subtag-instance)
     1248                         (instance.class-wrapper form))
     1249                        ((= typecode target::subtag-basic-stream)
     1250                         (basic-stream.wrapper form))
     1251                        (t nil))))
     1252    (declare (type (unsigned-byte 8) typecode))
     1253    (when wrapper
     1254      (loop
     1255        (let ((class (class-cell-class class-cell)))
     1256          (if class
     1257            (let* ((ordinal (%class-ordinal class))
     1258                   (bits (or (%wrapper-cpl-bits wrapper)
     1259                             (make-cpl-bits (%inited-class-cpl (%wrapper-class wrapper))))))
     1260              (declare (fixnum ordinal))
     1261              (return
     1262                (if bits
     1263                  (locally (declare (simple-bit-vector bits)
     1264                                    (optimize (speed 3) (safety 0)))
     1265                    (if (< ordinal (length bits))
     1266                      (not (eql 0 (sbit bits ordinal))))))))
     1267            (let* ((name (class-cell-name class-cell))
     1268                   (new-cell (find-class-cell name nil)))
     1269              (unless
     1270                  (if (and new-cell (not (eq class-cell new-cell)))
     1271                    (setq class-cell new-cell class (class-cell-class class-cell))
     1272                    (return (typep form name)))))))))))
    12021273
    12031274(defun class-cell-typep (form class-cell)
    12041275  (locally (declare (type class-cell  class-cell))
     1276    (loop
    12051277    (let ((class (class-cell-class class-cell)))
    1206       (loop
    1207         (if class
    1208           (let* ((wrapper (if (%standard-instance-p form)
    1209                             (instance.class-wrapper form)
    1210                             (instance-class-wrapper form))))
    1211             (return
    1212               (not (null (memq class (or (%wrapper-cpl wrapper)
    1213                                          (%inited-class-cpl (%wrapper-class wrapper))))))))
    1214           (if (setq class (find-class (class-cell-name class-cell) nil))
    1215             (setf (class-cell-class class-cell) class)
    1216             (return (typep form (class-cell-name class-cell)))))))))
     1278      (if class
     1279        (let* ((ordinal (%class-ordinal class))
     1280               (wrapper (instance-class-wrapper form))
     1281               (bits (or (%wrapper-cpl-bits wrapper)
     1282                         (make-cpl-bits (%inited-class-cpl (%wrapper-class wrapper))))))
     1283          (declare (fixnum ordinal))
     1284          (return
     1285            (if bits
     1286              (locally (declare (simple-bit-vector bits)
     1287                                (optimize (speed 3) (safety 0)))
     1288                  (if (< ordinal (length bits))
     1289                    (not (eql 0 (sbit bits ordinal))))))))
     1290        (let* ((name (class-cell-name class-cell))
     1291               (new-cell (find-class-cell name nil)))
     1292          (unless
     1293              (if (and new-cell (not (eq class-cell new-cell)))
     1294                (setq class-cell new-cell class (class-cell-class class-cell))
     1295                (return (typep form name))))))))))
    12171296
    12181297
     
    12221301    arg
    12231302    (%kernel-restart $xwrongtype arg (car class-cell))))
    1224 
    1225 
    12261303
    12271304
     
    12421319          (find-class name errorp environment)))))
    12431320
     1321(defun update-class-proper-names (name old-class new-class)
     1322  (when (and old-class
     1323             (not (eq old-class new-class))
     1324             (eq (%class-proper-name old-class) name))
     1325    (setf (%class-proper-name old-class) nil))
     1326  (when (and new-class (eq (%class-name new-class) name))
     1327    (setf (%class-proper-name new-class) name)))
     1328
     1329
    12441330(defun set-find-class (name class)
    12451331  (clear-type-cache)
    1246   (let ((cell (find-class-cell name class)))
    1247     (when cell
    1248       (when class
    1249         (if (eq name (%class.name class))
    1250           (setf (info-type-kind name) :instance)))
    1251       (setf (class-cell-class cell) class))
     1332  (let* ((cell (find-class-cell name t))
     1333         (old-class (class-cell-class cell)))
     1334    (when class
     1335      (if (eq name (%class.name class))
     1336        (setf (info-type-kind name) :instance)))
     1337    (setf (class-cell-class cell) class)
     1338    (update-class-proper-names name old-class class)
    12521339    class))
    12531340
     
    12971384 (defun set-find-class (name class)
    12981385   (setq name (require-type name 'symbol))
    1299    (let ((cell (find-class-cell name t)))
     1386   (let* ((cell (find-class-cell name t))
     1387          (old-class (class-cell-class cell)))
    13001388     (declare (type class-cell cell))
    1301        (let ((old-class (class-cell-class cell)))
    1302          (when old-class
    1303            (when (eq (%class.name old-class) name)
    1304              (setf (info-type-kind name) nil)
    1305              (clear-type-cache))
    1306            (when *warn-if-redefine-kernel*
    1307              (check-setf-find-class-protected-class old-class class name))))
     1389     (when old-class
     1390       (when (eq (%class.name old-class) name)
     1391         (setf (info-type-kind name) nil)
     1392         (clear-type-cache))
     1393       (when *warn-if-redefine-kernel*
     1394         (check-setf-find-class-protected-class old-class class name)))
    13081395     (when (null class)
    13091396       (when cell
    13101397         (setf (class-cell-class cell) nil))
     1398       (update-class-proper-names name old-class class)
    13111399       (return-from set-find-class nil))
    13121400     (setq class (require-type class 'class))
     
    13211409         (%deftype name nil nil))
    13221410       (setf (info-type-kind name) :instance))
     1411     (update-class-proper-names name old-class class)
    13231412     (setf (class-cell-class cell) class)))
    13241413 )                                      ; end of queue-fixup
     
    13391428||#
    13401429
    1341 
    13421430(defglobal *next-class-ordinal* 0)
    13431431
     
    13661454      (unless no-error
    13671455        (error "Can't set ordinal of class ~s to ~s" class new)))))
     1456
    13681457
    13691458(defvar *t-class* (let* ((class (%cons-built-in-class 't)))
     
    14281517            (setf (sbit bits ordinal) 1)))))))
    14291518
    1430 
     1519         
    14311520(defun make-built-in-class (name &rest supers)
    14321521  (if (null supers)
     
    14511540      (setf (%class.cpl class) cpl)
    14521541      (setf (%class.own-wrapper class) wrapper)
    1453       (setf (%wrapper-cpl wrapper) cpl))
     1542      (setf (%wrapper-cpl wrapper) cpl
     1543            (%wrapper-cpl-bits wrapper) (make-cpl-bits cpl)
     1544            (%wrapper-class-ordinal wrapper) (%class-ordinal class)))
    14541545    (setf (%class.ctype class)  (make-class-ctype class))
    14551546    (setf (find-class name) class)
     
    14621553  (let* ((class (apply #'make-built-in-class name supers))
    14631554         (cell (register-istruct-cell name)))
    1464     (set-istruct-cell-info cell (%class.own-wrapper class))
     1555    (setf (istruct-cell-info cell) (%class.own-wrapper class))
    14651556    class))
    14661557
     
    14961587                     (%cons-wrapper class))))
    14971588      (setf (%class.cpl class) cpl
    1498             (%wrapper-instance-slots wrapper) (vector)           
     1589            (%wrapper-instance-slots wrapper) (vector)
    14991590            (%class.own-wrapper class) wrapper
    15001591            (%class.ctype class) (make-class-ctype class)
    15011592            (%class.slots class) nil
     1593            (%wrapper-class-ordinal wrapper) (%class-ordinal class)
    15021594            (%wrapper-cpl wrapper) cpl
    1503             (find-class name) class)
     1595            (%wrapper-cpl-bits wrapper) (make-cpl-bits cpl)
     1596            (find-class name) class
     1597            )
    15041598      (dolist (sup supers)
    15051599        (setf (%class.subclasses sup) (cons class (%class.subclasses sup))))
     
    15781672(setf (%class.own-wrapper *standard-class-class*) *standard-class-wrapper*
    15791673      (%wrapper-class *standard-class-wrapper*) *standard-class-class*
     1674      (%wrapper-class-ordinal *standard-class-wrapper*) (%class-ordinal *standard-class-class*)
    15801675      (%wrapper-instance-slots *standard-class-wrapper*) (vector))
    15811676
     
    16501745                                                              *slot-definition-class*))
    16511746(defstatic *standard-slot-definition-class* (make-standard-class 'standard-slot-definition
    1652                                                               *slot-definition-class*))
     1747                                                                 *slot-definition-class*))
    16531748(defstatic *standard-direct-slot-definition-class* (make-class
    1654                                                  'standard-direct-slot-definition
    1655                                                  *standard-class-wrapper*
    1656                                                  (list
    1657                                                   *standard-slot-definition-class*
    1658                                                   direct-slot-definition-class)))
     1749                                                    'standard-direct-slot-definition
     1750                                                    *standard-class-wrapper*
     1751                                                    (list
     1752                                                     *standard-slot-definition-class*
     1753                                                     direct-slot-definition-class)))
    16591754
    16601755(defstatic *standard-effective-slot-definition-class* (make-class
     
    16711766
    16721767
     1768
     1769
     1770 
    16731771
    16741772(let ((*dont-find-class-optimize* t)
     
    17631861  (make-istruct-class 'external-entry-point *istruct-class*)
    17641862  (make-istruct-class 'shlib *istruct-class*)
    1765                      
     1863
    17661864  (make-built-in-class 'complex (find-class 'number))
    17671865  (make-built-in-class 'real (find-class 'number))
     
    23582456
    23592457
    2360 ;;; Can't use typep at bootstrapping time.
     2458
    23612459(defun classp (x)
    2362   (or (and (typep x 'macptr) (foreign-classp x))                ; often faster
    2363       (let ((wrapper (standard-object-p x)))
    2364         (or
    2365          (and wrapper
    2366               (let ((super (%wrapper-class wrapper)))
    2367                 (memq *class-class* (%inited-class-cpl super t))))))))
     2460  (if (%standard-instance-p x)
     2461    (< (the fixnum (instance.hash x)) max-class-ordinal)
     2462    (and (typep x 'macptr) (foreign-classp x))))
    23682463
    23692464(set-type-predicate 'class 'classp)
     
    26192714(declaim (inline find-slotd))
    26202715(defun find-slotd (name slots)
    2621   (find name slots :key #'%slot-definition-name))
     2716  (dolist (slotd slots)
     2717    (when (eq name (standard-slot-definition.name slotd))
     2718      (return slotd))))
    26222719
    26232720(declaim (inline %std-slot-vector-value))
     
    26532750           (eq *standard-class-wrapper* (instance.class-wrapper class)))
    26542751    (%std-slot-vector-value (instance-slots instance) slotd)
    2655     (slot-value-using-class class instance slotd)))
     2752    (if (= (the fixnum (typecode instance)) target::subtag-struct)
     2753      (struct-ref instance (standard-effective-slot-definition.location slotd))
     2754      (slot-value-using-class class instance slotd))))
    26562755
    26572756
     
    26972796    ;; Not safe to use instance.slots here, since the instance is not
    26982797    ;; definitely of type SUBTAG-INSTANCE.  (Anyway, INSTANCE-SLOTS
    2699     ;; should be inlined here.
     2798    ;; should be inlined here.)
    27002799    (%set-std-slot-vector-value (instance-slots instance) slotd new)
    2701     (setf (slot-value-using-class class instance slotd) new)))
     2800    (if (structurep instance)
     2801      (setf (struct-ref instance (standard-effective-slot-definition.location slotd))
     2802            new)
     2803      (setf (slot-value-using-class class instance slotd) new))))
    27022804
    27032805(defmethod slot-value-using-class ((class funcallable-standard-class)
     
    27142816
    27152817(defun slot-value (instance slot-name)
    2716   (let* ((class (class-of instance))
    2717            (slotd (find-slotd slot-name (%class-slots class))))
    2718       (if slotd
    2719        (slot-value-using-class class instance slotd)
    2720        (restart-case
    2721            (values (slot-missing class instance slot-name 'slot-value))
     2818  (let* ((wrapper
     2819          (let* ((w (instance-class-wrapper instance)))
     2820            (if (eql 0 (%wrapper-hash-index w))
     2821              (instance.class-wrapper (update-obsolete-instance instance))
     2822              w)))
     2823         (class (%wrapper-class wrapper))
     2824         (slotd (find-slotd slot-name (if (%standard-instance-p class)
     2825                                        (%class.slots class)
     2826                                        (class-slots class)))))
     2827    (if slotd
     2828      (%maybe-std-slot-value-using-class class instance slotd)
     2829      (if (typep slot-name 'symbol)
     2830        (restart-case
     2831         (values (slot-missing class instance slot-name 'slot-value))
    27222832         (continue ()
    2723            :report "Try accessing the slot again"
    2724            (slot-value instance slot-name))
     2833                   :report "Try accessing the slot again"
     2834                   (slot-value instance slot-name))
    27252835         (use-value (value)
    2726            :report "Return a value"
    2727            :interactive (lambda ()
    2728                           (format *query-io* "~&Value to use: ")
    2729                           (list (read *query-io*)))
    2730            value)))))
    2731    
     2836                    :report "Return a value"
     2837                    :interactive (lambda ()
     2838                                   (format *query-io* "~&Value to use: ")
     2839                                   (list (read *query-io*)))
     2840                    value))
     2841        (report-bad-arg slot-name 'symbol)))))
    27322842
    27332843
     
    27562866
    27572867(defun set-slot-value (instance name value)
    2758   (let* ((class (class-of instance))
    2759              (slotd (find-slotd  name (%class-slots class))))
    2760         (if slotd
    2761           (setf (slot-value-using-class class instance slotd) value)
    2762           (progn           
    2763             (slot-missing class instance name 'setf value)
    2764             value))))
     2868  (let* ((wrapper
     2869          (let* ((w (instance-class-wrapper instance)))
     2870            (if (eql 0 (%wrapper-hash-index w))
     2871              (instance.class-wrapper (update-obsolete-instance instance))
     2872              w)))
     2873         (class (%wrapper-class wrapper))
     2874         (slotd (find-slotd name (if (%standard-instance-p class)
     2875                                   (%class.slots class)
     2876                                   (class-slots class)))))
     2877    (if slotd
     2878      (%maybe-std-setf-slot-value-using-class class instance slotd value)
     2879      (if (typep name 'symbol)
     2880        (progn     
     2881          (slot-missing class instance name 'setf value)
     2882          value)
     2883        (report-bad-arg name 'symbol)))))
    27652884
    27662885(defsetf slot-value set-slot-value)
     
    27852904                slotd loc (slot-definition-allocation slotd))))))
    27862905
     2906(defun %maybe-std-slot-boundp-using-class (class instance slotd)
     2907  (if (and (eql (typecode class) target::subtag-instance)
     2908           (eql (typecode slotd) target::subtag-instance)
     2909           (eq *standard-effective-slot-definition-class-wrapper*
     2910               (instance.class-wrapper slotd))
     2911           (eq *standard-class-wrapper* (instance.class-wrapper class)))
     2912    (%std-slot-vector-boundp (instance-slots instance) slotd)
     2913    (slot-boundp-using-class class instance slotd)))
     2914
     2915
    27872916(defmethod slot-boundp-using-class ((class standard-class)
    27882917                                    instance
     
    28002929
    28012930(defun slot-boundp (instance name)
    2802   (let* ((class (class-of instance))
    2803          (slotd (find-slotd name (%class-slots class))))
     2931  (let* ((wrapper
     2932          (let* ((w (instance-class-wrapper instance)))
     2933            (if (eql 0 (%wrapper-hash-index w))
     2934              (instance.class-wrapper (update-obsolete-instance instance))
     2935              w)))
     2936         (class (%wrapper-class wrapper))
     2937         (slotd (find-slotd name (if (%standard-instance-p class)
     2938                                   (%class.slots class)
     2939                                   (class-slots class)))))
    28042940    (if slotd
    2805       (slot-boundp-using-class class instance slotd)
    2806       (values (slot-missing class instance name 'slot-boundp)))))
     2941      (%maybe-std-slot-boundp-using-class class instance slotd)
     2942      (if (typep name 'symbol)
     2943        (values (slot-missing class instance name 'slot-boundp))
     2944        (report-bad-arg name 'symbol)))))
    28072945
    28082946(defun slot-value-if-bound (instance name &optional default)
     
    28182956
    28192957(defun slot-id-value (instance slot-id)
    2820   (let* ((wrapper (or (standard-object-p instance)
    2821                     (%class-own-wrapper (class-of instance)))))
     2958  (let* ((wrapper (instance-class-wrapper instance)))
    28222959    (funcall (%wrapper-slot-id-value wrapper) instance slot-id)))
    28232960
    28242961(defun set-slot-id-value (instance slot-id value)
    2825   (let* ((wrapper (or (standard-object-p instance)
    2826                     (%class-own-wrapper (class-of instance)))))
     2962  (let* ((wrapper (instance-class-wrapper instance)))
    28272963    (funcall (%wrapper-set-slot-id-value wrapper) instance slot-id value)))
    28282964
     2965(defun slot-id-boundp (instance slot-id)
     2966  (let* ((wrapper (instance-class-wrapper instance))
     2967         (class (%wrapper-class wrapper))
     2968         (slotd (funcall (%wrapper-slot-id->slotd wrapper) instance slot-id)))
     2969    (if slotd
     2970      (%maybe-std-slot-boundp-using-class class instance slotd)
     2971      (values (slot-missing class instance (slot-id.name slot-id) 'slot-boundp)))))
     2972 
    28292973;;; returns nil if (apply gf args) wil cause an error because of the
    28302974;;; non-existance of a method (or if GF is not a generic function or the name
     
    29093053       (setf (%wrapper-hash-index wrapper) 0
    29103054             (%wrapper-cpl wrapper) nil
     3055             (%wrapper-cpl-bits wrapper) nil
    29113056             (%wrapper-instance-slots wrapper) 0
    29123057             (%wrapper-forwarding-info wrapper) forwarding-info
     
    32003345  (let ((wrapper (standard-object-p instance)))
    32013346    (unless wrapper
    3202       (if (standard-generic-function-p instance)
    3203         (setq wrapper (generic-function-wrapper instance))
    3204         (when (typep instance 'funcallable-standard-object)
    3205           (setq wrapper (gf.instance.class-wrapper instance))))
     3347              (when (typep instance 'funcallable-standard-object)
     3348          (setq wrapper (gf.instance.class-wrapper instance)))
    32063349     
    32073350      (unless wrapper
    3208         (report-bad-arg instance '(or standard-object standard-generic-function))))
     3351        (report-bad-arg instance '(or standard-object funcallable-standard-object))))
    32093352    (when (eql 0 (%wrapper-hash-index wrapper))
    32103353      (update-obsolete-instance instance)))
     
    32323375  (%change-class instance new-class initargs))
    32333376
    3234 (defmethod change-class ((instance funcallable-standard-object)
    3235                          (new-class funcallable-standard-class)
    3236                          &rest initargs &key &allow-other-keys)
    3237   (declare (dynamic-extent initargs))
    3238   (%change-class instance new-class initargs))
    3239  
    32403377
    32413378(defun %change-class (object new-class initargs)
     
    34353572(defmethod no-applicable-method (gf &rest args)
    34363573  (cerror "Try calling it again"
    3437           "No applicable method for args:~% ~s~% to ~s" args gf)
     3574          "There is no applicable method for the generic function:~%  ~s~%when called with arguments:~%  ~s" gf args)
    34383575  (apply gf args))
    34393576
     
    36123749
    36133750
    3614 (defun generic-function-wrapper (gf)
    3615   (unless (inherits-from-standard-generic-function-p (class-of gf))
    3616     (%badarg gf 'standard-generic-function))
    3617   (gf.instance.class-wrapper gf))
     3751
     3752
     3753                                   
     3754
     3755
    36183756
    36193757(defvar *make-load-form-saving-slots-hash* (make-hash-table :test 'eq))
     
    36723810                 (error "Can't find structure named ~s" class-name)))
    36733811         (res (make-structure-vector (sd-size sd))))
    3674     (setf (%svref res 0) (sd-superclasses sd))
     3812    (setf (%svref res 0) (mapcar (lambda (x)
     3813                                   (find-class-cell x t)) (sd-superclasses sd)))
    36753814    res))
    36763815
Note: See TracChangeset for help on using the changeset viewer.