Changeset 889
- Timestamp:
- Sep 25, 2004, 5:38:18 PM (20 years ago)
- File:
-
- 1 edited
-
trunk/ccl/level-1/l1-clos.lisp (modified) (11 diffs)
Legend:
- Unmodified
- Added
- Removed
-
trunk/ccl/level-1/l1-clos.lisp
r858 r889 55 55 (extract-instance-and-class-slotds (%class-slots class))) 56 56 57 (defun % shared-initialize (instance slot-names initargs)57 (defun %early-shared-initialize (instance slot-names initargs) 58 58 (unless (or (listp slot-names) (eq slot-names t)) 59 59 (report-bad-arg slot-names '(or list (eql t)))) … … 111 111 instance) 112 112 113 (setf (fdefinition '%shared-initialize) #'%early-shared-initialize) 114 113 115 ;;; This is redefined (to call MAKE-INSTANCE) below. 114 116 (setf (fdefinition '%make-direct-slotd) … … 280 282 281 283 (defun update-slots (class eslotds) 282 (multiple-value-bind (instance-slots class-slots) 283 (extract-instance-and-class-slotds eslotds) 284 (let* ((new-ordering 285 (let* ((v (make-array (the fixnum (length instance-slots)))) 286 (i 0)) 287 (declare (simple-vector v) (fixnum i)) 288 (dolist (e instance-slots v) 289 (setf (svref v i) 290 (%slot-definition-name e)) 291 (incf i)))) 292 (old-wrapper (%class-own-wrapper class)) 293 (old-ordering (if old-wrapper (%wrapper-instance-slots old-wrapper))) 294 (new-wrapper 295 (cond ((null old-wrapper) 296 (%cons-wrapper class)) 297 ((and old-wrapper *update-slots-preserve-existing-wrapper*) 298 old-wrapper) 299 ((and (equalp old-ordering new-ordering) 300 (null class-slots)) 301 old-wrapper) 302 (t 303 (make-instances-obsolete class) 304 ;;; Is this right ? 305 #|(%class.own-wrapper class)|# 306 (%cons-wrapper class))))) 307 (setf (%class-slots class) eslotds) 308 (setf (%wrapper-instance-slots new-wrapper) new-ordering 309 (%wrapper-class-slots new-wrapper) (%class-get class :class-slots) 310 (%class-own-wrapper class) new-wrapper) 311 (setup-slot-lookup new-wrapper eslotds)))) 284 (let* ((instance-slots (extract-slotds-with-allocation :instance eslotds)) 285 (new-ordering 286 (let* ((v (make-array (the fixnum (length instance-slots)))) 287 (i 0)) 288 (declare (simple-vector v) (fixnum i)) 289 (dolist (e instance-slots v) 290 (setf (svref v i) 291 (%slot-definition-name e)) 292 (incf i)))) 293 (old-wrapper (%class-own-wrapper class)) 294 (new-wrapper 295 (cond ((null old-wrapper) 296 (%cons-wrapper class)) 297 ((and old-wrapper *update-slots-preserve-existing-wrapper*) 298 old-wrapper) 299 (t 300 (make-instances-obsolete class) 301 (%cons-wrapper class))))) 302 (setf (%class-slots class) eslotds) 303 (setf (%wrapper-instance-slots new-wrapper) new-ordering 304 (%wrapper-class-slots new-wrapper) (%class-get class :class-slots) 305 (%class-own-wrapper class) new-wrapper) 306 (setup-slot-lookup new-wrapper eslotds))) 312 307 313 308 … … 590 585 (if direct-superclasses-p 591 586 (progn 592 (setq direct-superclasses (or direct-superclasses 593 (list *standard-object-class*))) 587 (setq direct-superclasses 588 (or direct-superclasses 589 (list (if (typep class 'funcallable-standard-class) 590 *funcallable-standard-object-class* 591 *standard-object-class*)))) 594 592 (dolist (superclass direct-superclasses) 595 593 (unless (validate-superclass class superclass) … … 905 903 `((:name prototype :initform nil :initfunction ,#'false) 906 904 (:name name :initargs (:name) :initform nil :initfunction ,#'false :readers (class-name)) 907 (:name precedence-list :init args (:precedence-list) :initform nil :initfunction ,#'false)908 (:name own-wrapper :init args (:own-wrapper) :initform nil :initfunction ,#'false :readers (class-own-wrapper) :writers ((setf class-own-wrapper)))909 (:name direct-superclasses :initargs (:direct-superclasses):initform nil :initfunction ,#'false :readers (class-direct-superclasses))910 (:name direct-subclasses :initargs (:direct-subclasses):initform nil :initfunction ,#'false :readers (class-direct-subclasses))905 (:name precedence-list :initform nil :initfunction ,#'false) 906 (:name own-wrapper :initform nil :initfunction ,#'false :readers (class-own-wrapper) :writers ((setf class-own-wrapper))) 907 (:name direct-superclasses :initform nil :initfunction ,#'false :readers (class-direct-superclasses)) 908 (:name direct-subclasses :initform nil :initfunction ,#'false :readers (class-direct-subclasses)) 911 909 (:name dependents :initform nil :initfunction ,#'false) 912 910 (:name class-ctype :initform nil :initfunction ,#'false)) … … 929 927 :direct-superclasses '(class) 930 928 :direct-slots `((:name direct-slots :initform nil :initfunction ,#'false 931 :initargs (:direct-slots):readers (class-direct-slots)929 :readers (class-direct-slots) 932 930 :writers ((setf class-direct-slots))) 933 931 (:name slots :initform nil :initfunction ,#'false 934 932 :readers (class-slots)) 935 933 (:name kernel-p :initform nil :initfunction ,#'false) 936 (:name direct-default-initargs :initargs (:direct-default-initargs):initform nil :initfunction ,#'false :readers (class-direct-default-initargs))934 (:name direct-default-initargs :initform nil :initfunction ,#'false :readers (class-direct-default-initargs)) 937 935 (:name default-initargs :initform nil :initfunction ,#'false :readers (class-default-initargs)) 938 936 (:name alist :initform nil :initfunction ,#'false)) … … 965 963 'generic-function 966 964 :direct-superclasses '(metaobject funcallable-standard-object) 967 :metaclass 'funcallable-standard-class)968 969 (%ensure-class-preserving-wrapper970 'standard-generic-function971 :direct-superclasses '(generic-function)972 965 :direct-slots `((:name name :initargs (:name) :readers (generic-function-name)) 973 966 (:name method-combination :initargs (:method-combination) … … 990 983 :initfunction ,(constantly :unspecified)) 991 984 (:name dependents 992 :initform nil :initfunction ,#'false)) 985 :initform nil :initfunction ,#'false)) 986 :metaclass 'funcallable-standard-class) 987 988 (%ensure-class-preserving-wrapper 989 'standard-generic-function 990 :direct-superclasses '(generic-function) 991 993 992 :metaclass 'funcallable-standard-class 994 993 :primary-p t) … … 1336 1335 (apply #'reinitialize-instance gf initargs))) 1337 1336 1337 1338 (defmethod initialize-instance :before ((instance generic-function) 1339 &key &allow-other-keys) 1340 (setf (gf.code-vector instance) *gf-proto-code* 1341 (gf.dcode instance) #'%%0-arg-dcode)) 1342 1343 1344 1338 1345 (defmethod initialize-instance :after ((gf standard-generic-function) 1339 1346 &key … … 1472 1479 (slots (allocate-typed-vector :slot-vector (1+ len) (%slot-unbound-marker))) 1473 1480 (fn (gvector :function 1474 * gf-proto-code*1481 *unset-fin-code* 1475 1482 wrapper 1476 1483 slots 1477 1484 dt 1478 #' %%0-arg-dcode1485 #'false 1479 1486 0 1480 1487 (logior (ash 1 $lfbits-gfn-bit) 1481 1488 (ash 1 $lfbits-aok-bit))))) 1482 1489 (setf (gf.hash fn) (strip-tag-to-fixnum fn) 1483 1490 (slot-vector.instance slots) fn 1484 1491 (%gf-dispatch-table-gf dt) fn) 1485 (push fn (population.data %all-gfs%)) 1492 (if (typep fn 'generic-function) 1493 (push fn (population.data %all-gfs%))) 1486 1494 fn)) 1495 1487 1496 1488 1497 (defmethod slot-value-using-class ((class structure-class) … … 1533 1542 1534 1543 1544 ;;; From Tim Moore, as part of a set of patches to support funcallable 1545 ;;; instances. 1546 1547 ;;; Support for objects with metaclass funcallable-instance-class that are not 1548 ;;; standard-generic-function. The objects still look a lot like generic 1549 ;;; functions, complete with vestigial dispatch 1550 ;;; tables. set-funcallable-instance-function will work on generic functions, 1551 ;;; though after that it won't be much of a generic function. 1552 1553 1554 1555 (defmethod instance-class-wrapper ((instance funcallable-standard-object)) 1556 (gf.instance.class-wrapper instance)) 1557 1558 (defun set-funcallable-instance-function (funcallable-instance function) 1559 (unless (typep funcallable-instance 'funcallable-standard-object) 1560 (error "~S is not a funcallable instance" funcallable-instance)) 1561 (unless (functionp function) 1562 (error "~S is not a function" function)) 1563 (setf (uvref funcallable-instance gf.code-vector) *fi-trampoline-code*) 1564 (setf (uvref funcallable-instance gf.dcode) function)) 1565 1566 ;;; Are we CLOS yet ? 1567 1568 (defun %shared-initialize (instance slot-names initargs) 1569 (unless (or (listp slot-names) (eq slot-names t)) 1570 (report-bad-arg slot-names '(or list (eql t)))) 1571 ;; Check that initargs contains valid key/value pairs, 1572 ;; signal a PROGRAM-ERROR otherwise. (Yes, this is 1573 ;; an obscure way to do so.) 1574 (destructuring-bind (&key &allow-other-keys) initargs) 1575 ;; I'm not sure if there's a more portable way of detecting 1576 ;; obsolete instances. This'll eventually call 1577 ;; UPDATE-INSTANCE-FOR-REDEFINED-CLASS if it needs to. 1578 (let* ((wrapper (instance-class-wrapper instance)) 1579 (class (%wrapper-class wrapper))) 1580 (when (eql 0 (%wrapper-hash-index wrapper)) ; obsolete 1581 (update-obsolete-instance instance)) 1582 ;; Now loop over all of the class's effective slot definitions. 1583 (dolist (slotd (class-slots class)) 1584 ;; Anything that inherits from STANDARD-EFFECTIVE-SLOT-DEFINITION 1585 ;; in OpenMCL will have a CCL::TYPE-PREDICATE slot. It's not 1586 ;; well-defined to inherit from EFFECTIVE-SLOT-DEFINITION without 1587 ;; also inheriting from STANDARD-EFFECTIVE-SLOT-DEFINITION, 1588 ;; and I'd rather not check here. If you really want to 1589 ;; create that kind of slot definition, write your own SHARED-INITIALIZE 1590 ;; method for classes that use such slot definitions ... 1591 (let* ((predicate (standard-effective-slot-definition.type-predicate slotd))) 1592 (multiple-value-bind (ignore new-value foundp) 1593 (get-properties initargs (slot-definition-initargs slotd)) 1594 (declare (ignore ignore)) 1595 (cond (foundp 1596 ;; an initarg for the slot was passed to this function 1597 ;; Typecheck the new-value, then call 1598 ;; (SETF SLOT-VALUE-USING-CLASS) 1599 (unless (funcall predicate new-value) 1600 (error 'bad-slot-type-from-initarg 1601 :slot-definition slotd 1602 :instance instance 1603 :datum new-value 1604 :expected-type (slot-definition-type slotd) 1605 :initarg-name (car foundp))) 1606 (setf (slot-value-using-class class instance slotd) new-value)) 1607 ((and (or (eq slot-names t) 1608 (member (slot-definition-name slotd) 1609 slot-names 1610 :test #'eq)) 1611 (not (slot-boundp-using-class class instance slotd))) 1612 ;; If the slot name is among the specified slot names, or 1613 ;; we're reinitializing all slots, and the slot is currently 1614 ;; unbound in the instance, set the slot's value based 1615 ;; on the initfunction (which captures the :INITFORM). 1616 (let* ((initfunction (slot-definition-initfunction slotd))) 1617 (if initfunction 1618 (let* ((newval (funcall initfunction))) 1619 (unless (funcall predicate newval) 1620 (error 'bad-slot-type-from-initform 1621 :slot-definition slotd 1622 :expected-type (slot-definition-type slotd) 1623 :datum newval 1624 :instance instance)) 1625 (setf (slot-value-using-class class instance slotd) 1626 newval)))))))))) 1627 instance)
Note:
See TracChangeset
for help on using the changeset viewer.
