;;;-*-Mode:LISP; Package:(PCL Lisp 1000); Base:10; Syntax:Common-lisp -*-
;;;
;;; *************************************************************************
;;; Copyright (c) 1985, 1986, 1987 Xerox Corporation. All rights reserved.
;;;
;;; Use and copying of this software and preparation of derivative works
;;; based upon this software are permitted. Any distribution of this
;;; software or derivative works must comply with all applicable United
;;; States export control laws.
;;;
;;; This software is made available AS IS, and Xerox Corporation makes no
;;; warranty about the software, its performance or its conformity to any
;;; specification.
;;;
;;; Any person obtaining a copy of this software is requested to send their
;;; name and post office or electronic mail address to:
;;; CommonLoops Coordinator
;;; Xerox Artifical Intelligence Systems
;;; 2400 Hanover St.
;;; Palo Alto, CA 94303
;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
;;;
;;; Suggestions, comments and requests for improvements are also welcome.
;;; *************************************************************************
;;;
(in-package 'pcl)
(defmethod class-prototype ((c basic-class))
(or (slot-value--class c 'prototype)
(put-slot--class c 'prototype (make-instance c))))
(defmethod class-slots ((class class))
(append (class-non-instance-slots class)
(class-instance-slots class)))
(defmethod class-direct-methods ((class essential-class))
(slot-value--class class 'direct-methods))
(defmethod-setf class-direct-methods ((class essential-class)) (nv)
(let ((direct-generic-functions
(slot-value--class class 'direct-generic-functions)))
(dolist (m nv)
(pushnew (method-generic-function m) direct-generic-functions))
(put-slot--class class 'direct-generic-functions direct-generic-functions)
(put-slot--class class 'direct-methods nv)))
#|
A class is 'fully defined' iff its class precedence list can be computed. This
is true when it and all of its superclasses are defined.
A class is 'defined' when a defclass form which defines that class has been
defined.
A class is 'undefined' when no class by that name exists.
(defclass forward-referenced-standard-class (class) ())
(defmethod make-instance ..
(defmethod compute-class-precedence-list ..
(defmethod compatible..
(defmethod class-for-redefinition ..
when something changes, we walk down the tree passing the following information
where the changes actually happened and what it was,
whether the class at this point in the tree is fully defined,
whether the class at this point in the tree used to be fully defined
|#
;;; There are 6 cases:
;;; F -- F | + 2 cases because a fully defined class can
;;; F -- NF | either have instances or not have instances
;;; NF -- NF
;;; NF -- F
;;;
;;;
;; n cases
;;; 1 a fully-defined class changes, all its subclasses are also fully
;;; defined. Just have to propagate info.
;;; 2 fully defined class with instances is changed to become not
;;; fully defined.
;;; 3 a class which is not fully defined becomes fully defined because
;;; some other class far above it becomes fully defined.
;;; 4 a not fully defined class with some defined subclasses is changed.
;;;
(defmethod PROPAGATE-CLASS-UPDATE ((class class)
new-fully-defined-p
old-fully-defined-p
changed-class
&rest key-arguments ;hidden argument
&key (its-direct-superclasses () supers-p)
(its-options () options-p)
(its-direct-slots () slots-p))
(declare (ignore its-direct-superclasses its-options its-direct-slots))
(when new-fully-defined-p
(cond (supers-p
(let ((cpl (compute-class-precedence-list class)))
(setf (class-precedence-list class) cpl)
(update-slots--class class)
(update-constructors--class class)))
((or options-p slots-p)
(update-slots--class class)
(update-constructors--class class))))
;; Propagate all the change information down through our subclasses.
;; For each subclass we also compute its new and old fully-defined-p
;; status. The details of this computation are specific to PCL.
(dolist (subclass (class-direct-subclasses class))
(let ((sub-forward-referenced-supers
(class-forward-referenced-supers subclass))
sub-newly-defined-p
sub-oldly-defined-p)
(cond ((null sub-forward-referenced-supers)
;; The subclass used to be fully defined. By definition,
;; that means that we used to be fully defined. It also
;; means that if we just became not-fully-defined this
;; subclass must now become not fully defined.
(setq sub-newly-defined-p new-fully-defined-p
sub-oldly-defined-p 't)
(when (not new-fully-defined-p)
(setf (class-forward-referenced-supers subclass) (list class))))
((and (eq (car sub-forward-referenced-supers) class)
(null (cdr sub-forward-referenced-supers)))
;; The only reason this subclass used to be not fully defined
;; is because we used to be not fully defined. That means
;; that if we are still not fully defined so is this subclass
;; and if we just became fully defined so does this subclass.
(setq sub-newly-defined-p new-fully-defined-p
sub-oldly-defined-p old-fully-defined-p)
(when new-fully-defined-p
(setf (class-forward-referenced-supers subclass) ())))
(t
;; The general case is where there were multiple reasons
;; why this subclass used to be not-fully-defined. That
;; means it stays not fully defined, but we may add or
;; remove ourselves as a reason.
(setq sub-newly-defined-p nil
sub-oldly-defined-p nil)
(setf (class-forward-referenced-supers subclass)
(if new-fully-defined-p
(delete class sub-forward-referenced-supers)
(pushnew class sub-forward-referenced-supers)))))
(apply #'propagate-class-update subclass
sub-newly-defined-p
sub-oldly-defined-p
changed-class
key-arguments)))
(when new-fully-defined-p
(cond (supers-p
(when (eq class changed-class)
(update-method-inheritance class)))))
)
;(defmethod supers-changed ((class basic-class)
; old-local-supers
; old-local-slots
; extra
; top-p)
; (declare (ignore old-local-slots))
; (let ((cpl (compute-class-precedence-list class)))
; (setf (class-class-precedence-list class) cpl)
; (update-slots--class class cpl) ;This is NOT part of
; ;the essential-class
; ;protocol.
; (dolist (sub-class (class-direct-subclasses class))
; (supers-changed sub-class
; (class-local-supers sub-class)
; (class-local-slots sub-class)
; extra
; nil))
; (when top-p ;This is NOT part of
; (update-method-inheritance class old-local-supers));the essential-class
; ;protocol.
; ))
;
;
;
;(defmethod slots-changed ((class basic-class)
; old-local-slots
; extra
; top-p)
; (declare (ignore top-p old-local-slots))
; ;; When this is called, class should have its local-supers and
; ;; local-slots slots filled in properly.
; (update-slots--class class (class-class-precedence-list class))
; (dolist (sub-class (class-direct-subclasses class))
; (slots-changed sub-class (class-local-slots sub-class) extra nil)))
(defun update-slots--class (class)
(let* ((cpl (class-precedence-list class))
(obsolete-class nil)
(local-slots (class-local-slots class))
(slots ())
(instance-slots ())
(non-instance-slots ()))
;; If I saved accessor/reader prefixes somewhere, I could save time
;; here. Also, if merge actually kept track of whether something
;; changed that would save time.
(merge-accessor/reader-prefixes local-slots (class-options class))
(check-accessor/reader-compatibility local-slots)
(setq slots (order-slotds class
(collect-slotds class local-slots cpl)
cpl))
(dolist (slot slots)
(if (eq (slotd-allocation slot) ':instance)
(push slot instance-slots)
(push slot non-instance-slots)))
(setq instance-slots (reverse instance-slots)
non-instance-slots (reverse non-instance-slots))
(update-slot-accessors--class class instance-slots non-instance-slots)
;; If there is a change in the shape of the instances then the
;; old class is now obsolete. Make a copy of it, then fill
;; ourselves in properly and obsolete it.
(when (and (class-has-instances-p class)
(not (same-shape-slots-p (class-instance-slots class)
instance-slots)))
(setq obsolete-class (copy-class class)))
(setf (class-no-of-instance-slots class) (length instance-slots))
(setf (class-instance-slots class) instance-slots)
(setf (class-non-instance-slots class) non-instance-slots)
(when obsolete-class
(flush-class-caches class)
(make-class-obsolete class (copy-class class)))))
(defun update-slot-accessors--class (class instance-slots non-instance-slots)
(update-slot-accessors--class-1 class
instance-slots
(class-instance-slots class))
(update-slot-accessors--class-1 class
non-instance-slots
(class-non-instance-slots class)))
(defun update-slot-accessors--class-1 (class slotds old-slotds)
(dolist (slotd slotds)
(let* ((slot-name (slotd-name slotd))
(old-slotd (dolist (o old-slotds)
(when (eq slot-name (slotd-name o)) (return o))))
(forcep (and old-slotd
(neq (slotd-type old-slotd)
(slotd-type slotd))))
(old-accessors (and old-slotd (slotd-accessors old-slotd)))
(old-readers (and old-slotd (slotd-readers old-slotd))))
(update-slot-accessors--class-2
class slotd forcep (slotd-accessors slotd) old-accessors :accessor)
(update-slot-accessors--class-2
class slotd forcep (slotd-readers slotd) old-readers :reader))))
(defun update-slot-accessors--class-2 (class slotd forcep new old acc/rea)
(flet ((get-gf (name) (ensure-generic-function name)))
(dolist (gf-name new)
(when (or forcep (not (memq gf-name old)))
(ecase acc/rea
(:accessor
(add-reader-method class slotd (get-gf gf-name))
(add-writer-method class slotd (get-gf `(setf ,gf-name)))
(do-defmethod-setf-defsetf gf-name
(list (or (class-name class) 'x))))
(:reader
(add-reader-method class slotd (get-gf gf-name))))))
(dolist (gf-name old)
(when (or forcep (not (memq gf-name new)))
(ecase acc/rea
(:accessor
(remove-reader-method class slotd (get-gf gf-name))
(remove-writer-method class slotd (get-gf `(setf ,gf-name))))
(:reader
(remove-reader-method class slotd (get-gf gf-name))))))))
(defun update-constructors--class (class)
(let ((options (class-options class))
(old-constructors (class-constructors class))
(new-constructors ()))
(dolist (option options)
(when (and (listp option) (eq (car option) ':constructor))
(push (cdr option) new-constructors)))
;; First get rid of any constructors which don't appear in the new
;; constructors. Don't need to compare the old and new definitions
;; of this constructor, just get rid of it if it shouldn't have a
;; definition according to the new options.
(dolist (old old-constructors)
(unless (assq (car old) new-constructors)
(fmakunbound (car old))))
;; Now define all the new constructors. As an optimization (and
;; an important one for that matter) check to see if there was an
;; old definition of this constructor which was the same as the
;; new definition and if so don't bother doing the new definition.
(dolist (new new-constructors)
(unless (equal new (assq (car new) old-constructors))
(let ((constructor (apply #'make-constructor class (cdr new))))
(setq constructor (set-function-name constructor (car new)))
(setf (symbol-function (car new)) constructor))))
(setf (class-constructors class) new-constructors)))
;;;
;;; CLASS-FOR-REDEFINITION old-class proto-class name ds-options slotds
;;; protocol: class definition
;;;
;;; When a class is being defined, and a class with that name already exists
;;; a decision must be made as to what to use for the new class object, and
;;; whether to update the old class object. For this, class-for-redefinition
;;; is called with the old class object, the prototype of the new class, and
;;; the name ds-options and slotds corresponding to the new definition.
;;; It should return the class object to use as the new definition. It is
;;; OK for this to be old-class if that is appropriate.
;;;
(defmethod class-for-redefinition ((old-class class)
(proto-class class)
name
local-supers
local-slot-slotds
extra)
(declare (ignore proto-class name local-supers local-slot-slotds extra))
old-class)
(defmethod update-method-inheritance ((class basic-class))
;; In the absence of method combination, we have to flush all the
;; generic-functions which we used to inherit and all the generic-functions
;; which we now inherit.
(let ((old-mil
(compute-method-inheritance-list class nil)) ;*** FIX THIS BUG!!
(new-mil
(compute-method-inheritance-list class
(class-local-supers class)))
(generic-functions ())
(combined-generic-functions ()))
(dolist (old-donor old-mil)
(when (setq generic-functions (class-direct-generic-functions old-donor))
(dolist (old-generic-function generic-functions)
(flush-generic-function-caches old-generic-function)
(when (methods-combine-p old-generic-function)
(pushnew old-generic-function combined-generic-functions)))))
(dolist (new-donor new-mil)
(when (setq generic-functions (class-direct-generic-functions new-donor))
(unless (memq new-donor old-mil)
(dolist (new-generic-function generic-functions)
(when (methods-combine-p new-generic-function)
(pushnew new-generic-function combined-generic-functions))
(flush-generic-function-caches new-generic-function)))))
(when (fboundp 'combine-methods) ;***
(COMBINE-METHODS CLASS COMBINED-GENERIC-FUNCTIONS)))) ;***
(defmethod generic-function-changed ((generic-function generic-function)
method
added-p)
(declare (ignore method added-p))
(update-discriminator-code generic-function)
(flush-generic-function-caches generic-function))
(defun make-class-obsolete (class obsolete-class)
(setf (class-wrapper-class (class-wrapper obsolete-class)) obsolete-class)
(setf (class-wrapper class) nil)
(setf (class-local-supers obsolete-class) (list class))
(setf (class-class-precedence-list obsolete-class)
(cons obsolete-class (class-class-precedence-list class)))
(setf (class-name obsolete-class)
(symbol-append "obsolete-" (class-name class)))
(setf (iwmc-class-class-wrapper obsolete-class)
(wrapper-of (class-named 'obsolete-class)))
obsolete-class)
(defun copy-class (class)
(let* ((no-of-instance-slots (class-no-of-instance-slots (class-of class)))
(new-class (%allocate-instance--class no-of-instance-slots)))
(setf (iwmc-class-class-wrapper new-class)
(iwmc-class-class-wrapper class))
(iterate ((i from 0 below no-of-instance-slots))
(let ((index (%convert-slotd-position-to-slot-index i)))
(setf (get-static-slot--class new-class index)
(get-static-slot--class class index))))
(setf (iwmc-class-dynamic-slots new-class)
(copy-list (iwmc-class-dynamic-slots class)))
new-class))
(defun wrapper-of (class)
(or (class-wrapper class)
(setf (class-wrapper class) (make-class-wrapper class))))
(defmethod collect-slotds ((class basic-class) local-slots cpl)
(let ((slots ()))
(labels ((collect-one-class (local-slots pos)
(setq local-slots (copy-list local-slots))
;; For each of the slots we have already found, get the
;; slot description this class has for a slot by that
;; name or NIL if this class has no direct-slot by that
;; name.
(dolist (slot slots)
(let ((hit (dolist (ls local-slots)
(when (eq (slotd-name ls) (car slot))
(return ls)))))
(when hit (setq local-slots (delq hit local-slots)))
(push hit (cdr slot))))
;; For any remaining direct-slots this class has, create
;; a new entry in slots. Add a bunch of trailing NILs
;; to the entry to represent the classes that didn't
;; have direct slots for this slot.
(dolist (ls local-slots)
(push (list* (slotd-name ls)
ls
(make-list pos :initial-element nil))
slots)))
(collect-cpl (cpl-tail)
(cond ((null cpl-tail) 0)
(t
(let ((pos (1+ (collect-cpl (cdr cpl-tail)))))
(collect-one-class (class-local-slots (car cpl-tail))
pos)
pos)))))
(collect-one-class local-slots (collect-cpl (cdr cpl)))
;; Now use compute-effective-slotd to condense all the slot
;; descriptions for slots of the same name into one slot
;; description for that slot.
(mapcar #'(lambda (descriptions)
(compute-effective-slotd class (cdr descriptions)))
slots))))
(defmethod order-slotds ((class class) slotds cpl)
(declare (ignore class))
(let ((superclass-slots (reverse (mapcar #'class-slots (cdr cpl)))))
(flet ((superclass-slot-ordering (slotd)
;; If a slot with this name appears in one of our supers,
;; return two values:
;; 1 the class-slots of the most general class this
;; slot appears in
;; 2 a tail of the first value such that the its
;; first element is the relevant slotd
;;
;; The way to think of these two values is that they specify
;; the first class which included this slot AND the position
;; within instances of that class the slot appeared.
;;
(dolist (order superclass-slots)
(let ((p (member slotd order
:test #'(lambda (a b)
(and (eq (slotd-name a)
(slotd-name b))
(eq (slotd-allocation a)
(slotd-allocation b)))))))
(when p (return (values order p)))))))
(sort slotds
#'(lambda (x y)
(cond ((eq (slotd-allocation x) (slotd-allocation y))
(let (x-class-slots x-tail y-class-slots y-tail)
(multiple-value-setq (x-class-slots x-tail)
(superclass-slot-ordering x))
(multiple-value-setq (y-class-slots y-tail)
(superclass-slot-ordering y))
(cond ((null y-class-slots) 't)
((null x-class-slots) 'nil)
((eq x-class-slots y-class-slots)
(tailp y-tail x-tail))
(t
(memq y-class-slots
(memq x-class-slots
superclass-slots))))))
((eq (slotd-allocation x) ':instance) 't)
(t nil)))))))
(defmethod COMPUTE-EFFECTIVE-SLOTD ((class class) slotds)
(let* ((first-real-slotd (dolist (s slotds) (when s (return s))))
(slotd (make-slotd class :name (slotd-name first-real-slotd)
:keyword (slotd-keyword first-real-slotd)
:initform *slotd-unsupplied*
:type *slotd-unsupplied*
:allocation *slotd-unsupplied*)))
;; First deal with the accessors and readers. They are
;; special since they don't get inherited really.
(when (car slotds)
(setf (slotd-accessors slotd) (slotd-accessors (car slotds))
(slotd-readers slotd) (slotd-readers (car slotds))))
;; Now deal with the other attributes which really get inherited.
(labels ((merge-values (default type allocation)
(macrolet ((merge-value (name value)
`(when (eq (,name slotd) *slotd-unsupplied*)
(setf (,name slotd) ,value))))
(merge-value slotd-initform default)
(merge-value slotd-allocation allocation)
(let ((old-type (slotd-type slotd)))
(setf (slotd-type slotd)
(cond ((eq old-type *slotd-unsupplied*) type)
((subtypep old-type type) old-type)
(t `(and ,old-type ,type))))))))
(dolist (s slotds)
(when s
(merge-values (slotd-initform s)
(slotd-type s)
(slotd-allocation s))))
(merge-values 'nil ;default value -- for now
't ;type
:instance) ;allocation
slotd)))
(defmethod compute-class-precedence-list ((root class))
(let ((*cpl* ())
(*root* root)
(*must-precede-alist* ()))
(declare (special *cpl* *root* *must-precede-alist*))
;; We start by computing two values.
;; CPL
;; The depth-first left-to-right up to joins walk of the supers tree.
;; This is equivalent to breadth-first left-to-right walk of the
;; tree with all but the last occurence of a class removed from
;; the resulting list. This is in fact how the walk is implemented.
;;
;; MUST-PRECEDE-ALIST
;; An alist of the must-precede relations. The car of each element
;; of the must-precede-alist is a class, the cdr is all the classes
;; which either:
;; have this class as a local super
;; or
;; appear before this class in some other class's local-supers.
;;
;; Thus, the must-precede-alist reflects the two constraints that:
;; 1. A class must appear in the CPL before its local supers.
;; 2. Order of local supers is preserved in the CPL.
;;
(labels
((must-move-p (element list &aux move)
(dolist (must-precede (cdr (assq element *must-precede-alist*)))
(when (setq move (memq must-precede (cdr list)))
(return move))))
(find-farthest-move (element move)
(let ((closure (compute-must-precedes-closure element)))
(dolist (must-precede closure)
(setq move (or (memq must-precede move) move)))
move))
(compute-must-precedes-closure (class)
(let ((closure ()))
(labels ((walk (element path)
(when (memq element path)
(class-ordering-error
*root* element path *must-precede-alist*))
(dolist (precede
(cdr (assq element
*must-precede-alist*)))
(unless (memq precede closure)
(pushnew precede closure)
(walk precede (cons element path))))))
(walk class nil)
closure))))
(walk-supers *root*) ;Do the walk
;; For each class in the cpl, make sure that there are no classes after
;; it which should be before it. We do this by cdring down the list,
;; making sure that for each element of the list, none of its
;; must-precedes come after it in the list. If we find one, we use the
;; transitive closure of the must-precedes (call find-farthest-move) to
;; see where the class must really be moved. We use a hand-coded loop
;; so that we can splice things in and out of the CPL as we go.
(let ((tail *cpl*)
(element nil)
(move nil))
(loop (when (null tail) (return))
(setq element (car tail)
move (must-move-p element tail))
(cond (move
(setq move (find-farthest-move element move))
(setf (cdr move) (cons element (cdr move)))
(setf (car tail) (cadr tail)) ;Interlisp delete is OK
(setf (cdr tail) (cddr tail)) ;since it will never be
;last element of list.
)
(t
(setq tail (cdr tail)))))
(copy-list *cpl*)))))
(defun walk-supers (class &optional precedence)
(declare (special *cpl* *root* *must-precede-alist*))
(let ((elem (assq class *must-precede-alist*)))
(if elem
(setf (cdr elem) (union (cdr elem) precedence))
(push (cons class precedence) *must-precede-alist*)))
(let ((rsupers (reverse (cons class (class-local-supers class)))))
(iterate ((sup in rsupers)
(pre on (cdr rsupers))
(temp = nil))
;; Make sure this element of supers is OK.
;; Actually, there is an important design decision hidden in
;; here. Namely, at what time should symbols in a class's
;; local-supers be changed to the class objects they are
;; forward referencing.
;; 1. At first allocate-instance (compute-class-precedence-list)?
;; 2. When the forward referenced class is first defined?
;; This code does #1.
(cond ((classp sup))
((and (symbolp sup)
(setq temp (class-named sup t)))
;; This is a forward reference to a class which is
;; now defined. Replace the symbol in the local
;; supers with the actual class object, and set sup.
(nsubst temp sup (class-local-supers class))
(setq sup temp))
((symbolp sup)
(error "While computing the class-precedence-list for ~
the class ~S.~%~
The class ~S (from the local supers of ~S) ~
is undefined."
(class-name *root*) sup (class-name class)))
(t
(error "INTERNAL ERROR --~%~
While computing the class-precedence-list for ~
the class ~S,~%~
~S appeared in the local supers of ~S."
*root* sup class)))
(walk-supers sup pre))
(unless (memq class *cpl*) (push class *cpl*))))
(defun class-ordering-error (root element path must-precede-alist)
(setq path (cons element (reverse (memq element (reverse path)))))
(flet ((pretty (class) (or (class-name class) class)))
(let ((explanations ()))
(do ((tail path (cdr tail)))
((null (cdr tail)))
(let ((after (cadr tail))
(before (car tail)))
(if (memq after (class-local-supers before))
(push (format nil
"~% ~A must precede ~A -- ~
~A is in the local supers of ~A."
(pretty before) (pretty after)
(pretty after) (pretty before))
explanations)
(dolist (common-precede
(intersection
(cdr (assq after must-precede-alist))
(cdr (assq before must-precede-alist))))
(when (memq after (memq before
(class-local-supers common-precede)))
(push (format nil
"~% ~A must precede ~A -- ~
~A has local supers ~S."
(pretty before) (pretty after)
(pretty common-precede)
(mapcar #'pretty
(class-local-supers common-precede)))
explanations))))))
(error "While computing the class-precedence-list for the class ~A:~%~
There is a circular constraint through the classes:~{ ~A~}.~%~
This arises because:~{~A~}"
(pretty root)
(mapcar #'pretty path)
(reverse explanations)))))
(defmethod compute-method-inheritance-list ((class essential-class)
local-supers)
(declare (ignore local-supers))
(compute-class-precedence-list class))
(defmethod compatible-meta-class-change-p (class proto-new-class)
(eq (class-of class) (class-of proto-new-class)))
(defmethod check-super-metaclass-compatibility (class new-super)
(unless (eq (class-of class) (class-of new-super))
(error "The class ~S was specified as a~%super-class of the class ~S;~%~
but the meta-classes ~S and~%~S are incompatible."
new-super class (class-of new-super) (class-of class))))
(defun classp (x)
(and (iwmc-class-p x) (typep--class x 'essential-class)))
(defmethod flush-class-caches ((class basic-class))
(let ((wrapper (class-wrapper class)))
(and wrapper (flush-class-wrapper-cache wrapper))
(iterate ((subclass in (class-direct-subclasses class)))
(flush-class-caches subclass))))
;;
;;;;;; CHANGE-CLASS
;;
(defun change-class (object new-class)
(or (classp new-class)
(setq new-class (class-named new-class)))
(let ((new-object (make-instance new-class)))
;; Call change-class-internal so that a user-defined method
;; (or the default method) can copy the information from the
;; old instance to the dummy instance of the new class.
(change-class-internal object new-object)
;; Now that the dummy new-object has the right information,
;; move all that stuff into the old-instance.
(setf (iwmc-class-class-wrapper object)
(wrapper-of new-class))
(setf (iwmc-class-static-slots object)
(iwmc-class-static-slots new-object))
(setf (iwmc-class-dynamic-slots object)
(iwmc-class-dynamic-slots new-object))
object))
(defmethod change-class-internal ((old object) (new object))
(let ((all-slots (all-slots old)))
(iterate ((name in all-slots by cddr)
(value in (cdr all-slots) by cddr))
(put-slot-always new name value))))
;;
;;;;;; WITH-SLOTS
;;
(define-method-body-macro with-slots (instance-forms-and-options
&body body
&environment env)
:global (expand-with-slots nil instance-forms-and-options env body)
:method (expand-with-slots (macroexpand-time-method
macroexpand-time-environment)
instance-forms-and-options
env
body))
(defun expand-with-slots (proto-method first-arg env body)
(setq first-arg (iterate ((arg in first-arg))
(collect (if (listp arg) arg (list arg)))))
(let ((entries (expand-with-make-entries proto-method first-arg))
(gensyms ()))
(dolist (arg first-arg)
(push (list (if (listp arg) (car arg) arg)
(gensym))
gensyms))
`(let ,(mapcar #'reverse gensyms)
,(walk-form (cons 'progn body)
:environment env
:walk-function
#'(lambda (form context &aux temp)
(cond ((and (symbolp form)
(eq context ':eval)
(null (variable-lexical-p form))
(null (variable-special-p form))
(setq temp (assq form entries)))
(if (or (car (cddddr temp)) ;use slot-value?
(null (slotd-accessors (cadddr temp))))
(let ((slot-value
`(slot-value ,(cadr (assq (cadr temp) gensyms))
',(slotd-name (cadddr temp)))))
(optimize-slot-value (caddr temp)
slot-value))
`(,(car (slotd-accessors (cadddr temp)))
,(cadr (assq (cadr temp) gensyms)))))
((and (listp form)
(or (eq (car form) 'setq)
(eq (car form) 'setf)))
(cond ((cdddr form)
(cons 'progn
(iterate ((pair on (cdr form) by cddr))
(collect (list (car form)
(car pair)
(cadr pair))))))
((and (symbolp (cadr form))
(null (variable-lexical-p (cadr form)))
(null (variable-special-p (cadr form)))
(setq temp (assq (cadr form) entries)))
(if (or (car (cddddr temp))
(null (slotd-accessors (cadddr temp))))
(let ((slot-value
`(setf-of-slot-value
,(cadr (assq (cadr temp) gensyms))
',(slotd-name (cadddr temp))
,(caddr form))))
(optimize-setf-of-slot-value (caddr temp)
slot-value))
`(setf (,(car (slotd-accessors (cadddr temp)))
,(cadr (assq (cadr temp) gensyms)))
,(caddr form))))
(t form)))
(t form)))))))
;;; Returns an alist of the form:
;;;
;;; (<prefix+slot-name> <instance-form> <class> <slotd> <use-slot-value-p>)
;;;
(defmethod expand-with-make-entries (method first-arg)
(let* ((entries ())
(method-arguments
(when (method-p method)
(iterate ((arg in (method-arglist method))
(spec in (method-type-specifiers method)))
(when (classp spec) (collect (cons arg spec)))))))
(iterate ((instance-and-keys in first-arg))
(keyword-bind ((use-slot-value nil use-slot-value-p)
(use-accessors t use-accessors-p)
(class nil class-specified-p)
(prefix nil prefix-specified-p))
(cdr instance-and-keys)
(when (and use-slot-value-p use-accessors-p)
(error "Can't use both the :use-slot-value and :use-accessors~%~
options. :use-slot-value is obsolete, get rid of it."))
(when use-slot-value-p
(warn "The :use-slot-value option is obsolete. You may want to
use the :use-accessors option instead.")
(setq use-accessors (not use-slot-value)))
(let ((instance (car instance-and-keys)))
(setq class
(or (and class-specified-p
(or (class-named class t)
(error "In WITH-SLOTS the class specified for ~
~S, ~S ~%~
is not the name of a defined class."
instance class)))
(cdr (assq instance method-arguments))
(error "The class of (the value of) ~S was not given in ~
in the call to with-slots and could not be ~
inferred automatically."
instance)))
(iterate ((slotd in (class-slots class)))
(push (list (if (null prefix-specified-p)
(slotd-name slotd)
(intern (string-append prefix
(slotd-name slotd))
(symbol-package
(if (symbolp prefix)
prefix
(slotd-name slotd)))))
instance
class
slotd
(not use-accessors))
entries)))))
entries))
(defun named-object-print-function (instance stream depth
&optional (extra nil extra-p))
(declare (ignore depth))
(printing-random-thing (instance stream)
;; I know I don't have to do this this way. I know I
;; could use ~[~;~], but how many Common Lisps do you
;; think have that completely debugged?
(if extra-p
(format stream "~A ~S ~:S"
(capitalize-words (class-name (class-of instance)))
(slot-value instance 'name)
extra)
(format stream "~A ~S"
(capitalize-words (class-name (class-of instance)))
(slot-value instance 'name)))))