Changeset 10426 for trunk/source/level-1/l1-clos-boot.lisp
- Timestamp:
- Aug 11, 2008, 3:49:48 AM (13 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/source/level-1/l1-clos-boot.lisp
r10424 r10426 41 41 (t (%non-standard-instance-slots instance typecode))))) 42 42 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 43 49 (defun %class-name (class) 44 (%class.name class)) 50 (if (native-class-p class) 51 (%class.name class) 52 (class-name class))) 45 53 46 54 (defun %class-info (class) 47 (%class.info class)) 48 55 (if (native-class-p class) 56 (%class.info class) 57 (class-info class))) 58 49 59 50 60 (defun %class-kernel-p (class) … … 62 72 63 73 (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))) 65 77 66 78 (defun (setf %class-own-wrapper) (new class) … … 68 80 69 81 (defun %class-alist (class) 70 (if (typep class 'slots-class) 71 (%class.alist class))) 82 (%class.alist class)) 72 83 73 84 (defun (setf %class-alist) (new class) … … 77 88 78 89 (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))) 81 93 82 94 (defun (setf %class-slots) (new class) 83 (if ( typep class 'slots-class)95 (if (native-class-p class) 84 96 (setf (%class.slots class) new) 85 new))97 (setf (class-slots class) new))) 86 98 87 99 (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))) 90 103 91 104 (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 96 114 (defun %class-direct-superclasses (class) 97 115 (%class.local-supers class)) … … 229 247 next-slot-index)) 230 248 ) 249 250 231 251 232 252 … … 342 362 (when aokp (setq bits (%ilogior (%ilsl $lfbits-aok-bit 1) bits))) 343 363 (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))))) 346 366 347 367 (defun pair-arg-p (thing &optional lambda-list-ok supplied-p-ok keyword-nesting-ok) … … 574 594 nil)) 575 595 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 576 601 (let* ((class-wrapper-random-state (make-random-state)) 577 602 (class-wrapper-random-state-lock (make-lock))) … … 701 726 (mapcar #'canonicalize-specializer specializers)))) 702 727 728 (defparameter *sealed-clos-world* nil "When true, class and method definition -at least - are disallowed.") 729 703 730 (defun ensure-method (name specializers &rest keys &key (documentation nil doc-p) qualifiers 704 731 &allow-other-keys) 705 732 (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)))) 723 753 724 754 … … 841 871 (%add-standard-method-to-standard-gf gf method)) 842 872 873 ;; Redefined in l1-clos.lisp 874 (defun maybe-remove-make-instance-optimization (gfn method) 875 (declare (ignore gfn method)) 876 nil) 877 843 878 (defun %add-standard-method-to-standard-gf (gfn method) 844 879 (when (%method-gf method) … … 850 885 (qualifiers (%method-qualifiers method))) 851 886 (remove-obsoleted-combined-methods method dt specializers) 887 (maybe-remove-make-instance-optimization gfn method) 852 888 (apply #'invalidate-initargs-vector-for-gf gfn specializers) 853 889 (dolist (m methods) … … 923 959 (loop 924 960 (multiple-value-bind (found name cell) (m) 925 (declare ( listcell))961 (declare (type class-cell cell)) 926 962 (unless found (return)) 927 (when (cdr cell)963 (when cell 928 964 (funcall function name (class-cell-class cell))))))) 929 965 … … 968 1004 (when dt 969 1005 (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))))))) 989 1026 (setf (%gf-dispatch-table-ref dt 1) nil))))) ; clear 0-arg gf cm 990 1027 … … 995 1032 (defun invalidate-initargs-vector-for-gf (gf &optional first-specializer &rest other-specializers) 996 1033 (declare (ignore other-specializers)) 997 (when (and first-specializer (typep first-specializer 'class)) 1034 (when (and first-specializer (typep first-specializer 'class)) ; no eql methods or gfs with no specializers need apply 998 1035 (let ((indices (cdr (assq gf *initialization-invalidation-alist*)))) 999 1036 (when indices 1000 1037 (labels ((invalidate (class indices) 1001 (when (std-class-p class); catch the class named T1002 1003 1004 1005 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)))) 1006 1043 (invalidate first-specializer indices)))))) 1007 1044 … … 1011 1048 ;;; 2) the index of the first non-T specializer 1012 1049 (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)) 1014 1051 (unless (eq s *t-class*) 1015 1052 (unless index (setq index i)) … … 1044 1081 1045 1082 1046 1047 1048 1083 (defvar *writer-method-function-proto* 1049 1084 #'(lambda (new instance) 1050 1085 (set-slot-value instance 'x new))) 1051 1086 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)) 1052 1093 1053 1094 (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.") … … 1058 1099 (when dcode (return dcode))))) 1059 1100 1060 1061 1101 (defun compute-dcode (gf &optional dt) 1062 1102 (setq gf (require-type gf 'standard-generic-function)) … … 1184 1224 (let* ((typecode (typecode instance))) 1185 1225 (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) 1187 1230 (istruct-cell-info (%svref instance 0))) 1188 1231 ((eql typecode target::subtag-basic-stream) … … 1190 1233 ((typep instance 'funcallable-standard-object) 1191 1234 (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)) 1194 1236 (t (%class.own-wrapper (class-of instance)))))) 1195 1237 1196 1238 (defun instance-class-wrapper (instance) 1197 (if (= (typecode instance) target::subtag-instance)1239 (if (= (typecode instance) target::subtag-instance) 1198 1240 (instance.class-wrapper instance) 1199 1241 (non-standard-instance-class-wrapper instance))) 1200 1242 1201 1243 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))))))))))) 1202 1273 1203 1274 (defun class-cell-typep (form class-cell) 1204 1275 (locally (declare (type class-cell class-cell)) 1276 (loop 1205 1277 (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)))))))))) 1217 1296 1218 1297 … … 1222 1301 arg 1223 1302 (%kernel-restart $xwrongtype arg (car class-cell)))) 1224 1225 1226 1303 1227 1304 … … 1242 1319 (find-class name errorp environment))))) 1243 1320 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 1244 1330 (defun set-find-class (name class) 1245 1331 (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) 1252 1339 class)) 1253 1340 … … 1297 1384 (defun set-find-class (name class) 1298 1385 (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))) 1300 1388 (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))) 1308 1395 (when (null class) 1309 1396 (when cell 1310 1397 (setf (class-cell-class cell) nil)) 1398 (update-class-proper-names name old-class class) 1311 1399 (return-from set-find-class nil)) 1312 1400 (setq class (require-type class 'class)) … … 1321 1409 (%deftype name nil nil)) 1322 1410 (setf (info-type-kind name) :instance)) 1411 (update-class-proper-names name old-class class) 1323 1412 (setf (class-cell-class cell) class))) 1324 1413 ) ; end of queue-fixup … … 1339 1428 ||# 1340 1429 1341 1342 1430 (defglobal *next-class-ordinal* 0) 1343 1431 … … 1366 1454 (unless no-error 1367 1455 (error "Can't set ordinal of class ~s to ~s" class new))))) 1456 1368 1457 1369 1458 (defvar *t-class* (let* ((class (%cons-built-in-class 't))) … … 1428 1517 (setf (sbit bits ordinal) 1))))))) 1429 1518 1430 1519 1431 1520 (defun make-built-in-class (name &rest supers) 1432 1521 (if (null supers) … … 1451 1540 (setf (%class.cpl class) cpl) 1452 1541 (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))) 1454 1545 (setf (%class.ctype class) (make-class-ctype class)) 1455 1546 (setf (find-class name) class) … … 1462 1553 (let* ((class (apply #'make-built-in-class name supers)) 1463 1554 (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)) 1465 1556 class)) 1466 1557 … … 1496 1587 (%cons-wrapper class)))) 1497 1588 (setf (%class.cpl class) cpl 1498 (%wrapper-instance-slots wrapper) (vector) 1589 (%wrapper-instance-slots wrapper) (vector) 1499 1590 (%class.own-wrapper class) wrapper 1500 1591 (%class.ctype class) (make-class-ctype class) 1501 1592 (%class.slots class) nil 1593 (%wrapper-class-ordinal wrapper) (%class-ordinal class) 1502 1594 (%wrapper-cpl wrapper) cpl 1503 (find-class name) class) 1595 (%wrapper-cpl-bits wrapper) (make-cpl-bits cpl) 1596 (find-class name) class 1597 ) 1504 1598 (dolist (sup supers) 1505 1599 (setf (%class.subclasses sup) (cons class (%class.subclasses sup)))) … … 1578 1672 (setf (%class.own-wrapper *standard-class-class*) *standard-class-wrapper* 1579 1673 (%wrapper-class *standard-class-wrapper*) *standard-class-class* 1674 (%wrapper-class-ordinal *standard-class-wrapper*) (%class-ordinal *standard-class-class*) 1580 1675 (%wrapper-instance-slots *standard-class-wrapper*) (vector)) 1581 1676 … … 1650 1745 *slot-definition-class*)) 1651 1746 (defstatic *standard-slot-definition-class* (make-standard-class 'standard-slot-definition 1652 *slot-definition-class*))1747 *slot-definition-class*)) 1653 1748 (defstatic *standard-direct-slot-definition-class* (make-class 1654 'standard-direct-slot-definition1655 *standard-class-wrapper*1656 (list1657 *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))) 1659 1754 1660 1755 (defstatic *standard-effective-slot-definition-class* (make-class … … 1671 1766 1672 1767 1768 1769 1770 1673 1771 1674 1772 (let ((*dont-find-class-optimize* t) … … 1763 1861 (make-istruct-class 'external-entry-point *istruct-class*) 1764 1862 (make-istruct-class 'shlib *istruct-class*) 1765 1863 1766 1864 (make-built-in-class 'complex (find-class 'number)) 1767 1865 (make-built-in-class 'real (find-class 'number)) … … 2358 2456 2359 2457 2360 ;;; Can't use typep at bootstrapping time. 2458 2361 2459 (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)))) 2368 2463 2369 2464 (set-type-predicate 'class 'classp) … … 2619 2714 (declaim (inline find-slotd)) 2620 2715 (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)))) 2622 2719 2623 2720 (declaim (inline %std-slot-vector-value)) … … 2653 2750 (eq *standard-class-wrapper* (instance.class-wrapper class))) 2654 2751 (%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)))) 2656 2755 2657 2756 … … 2697 2796 ;; Not safe to use instance.slots here, since the instance is not 2698 2797 ;; definitely of type SUBTAG-INSTANCE. (Anyway, INSTANCE-SLOTS 2699 ;; should be inlined here. 2798 ;; should be inlined here.) 2700 2799 (%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)))) 2702 2804 2703 2805 (defmethod slot-value-using-class ((class funcallable-standard-class) … … 2714 2816 2715 2817 (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)) 2722 2832 (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)) 2725 2835 (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))))) 2732 2842 2733 2843 … … 2756 2866 2757 2867 (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))))) 2765 2884 2766 2885 (defsetf slot-value set-slot-value) … … 2785 2904 slotd loc (slot-definition-allocation slotd)))))) 2786 2905 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 2787 2916 (defmethod slot-boundp-using-class ((class standard-class) 2788 2917 instance … … 2800 2929 2801 2930 (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))))) 2804 2940 (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))))) 2807 2945 2808 2946 (defun slot-value-if-bound (instance name &optional default) … … 2818 2956 2819 2957 (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))) 2822 2959 (funcall (%wrapper-slot-id-value wrapper) instance slot-id))) 2823 2960 2824 2961 (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))) 2827 2963 (funcall (%wrapper-set-slot-id-value wrapper) instance slot-id value))) 2828 2964 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 2829 2973 ;;; returns nil if (apply gf args) wil cause an error because of the 2830 2974 ;;; non-existance of a method (or if GF is not a generic function or the name … … 2909 3053 (setf (%wrapper-hash-index wrapper) 0 2910 3054 (%wrapper-cpl wrapper) nil 3055 (%wrapper-cpl-bits wrapper) nil 2911 3056 (%wrapper-instance-slots wrapper) 0 2912 3057 (%wrapper-forwarding-info wrapper) forwarding-info … … 3200 3345 (let ((wrapper (standard-object-p instance))) 3201 3346 (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))) 3206 3349 3207 3350 (unless wrapper 3208 (report-bad-arg instance '(or standard-object standard-generic-function))))3351 (report-bad-arg instance '(or standard-object funcallable-standard-object)))) 3209 3352 (when (eql 0 (%wrapper-hash-index wrapper)) 3210 3353 (update-obsolete-instance instance))) … … 3232 3375 (%change-class instance new-class initargs)) 3233 3376 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 3240 3377 3241 3378 (defun %change-class (object new-class initargs) … … 3435 3572 (defmethod no-applicable-method (gf &rest args) 3436 3573 (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) 3438 3575 (apply gf args)) 3439 3576 … … 3612 3749 3613 3750 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 3618 3756 3619 3757 (defvar *make-load-form-saving-slots-hash* (make-hash-table :test 'eq)) … … 3672 3810 (error "Can't find structure named ~s" class-name))) 3673 3811 (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))) 3675 3814 res)) 3676 3815
Note: See TracChangeset
for help on using the changeset viewer.