home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 October / usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso / unix / volume10 / comobj.lisp / part08 / class-prot.l next >
Encoding:
Text File  |  1987-08-01  |  26.0 KB  |  692 lines
  1. ;;;-*-Mode:LISP; Package:(PCL Lisp 1000); Base:10; Syntax:Common-lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985 Xerox Corporation.  All rights reserved.
  5. ;;;
  6. ;;; Use and copying of this software and preparation of derivative works
  7. ;;; based upon this software are permitted.  Any distribution of this
  8. ;;; software or derivative works must comply with all applicable United
  9. ;;; States export control laws.
  10. ;;; 
  11. ;;; This software is made available AS IS, and Xerox Corporation makes no
  12. ;;; warranty about the software, its performance or its conformity to any
  13. ;;; specification.
  14. ;;; 
  15. ;;; Any person obtaining a copy of this software is requested to send their
  16. ;;; name and post office or electronic mail address to:
  17. ;;;   CommonLoops Coordinator
  18. ;;;   Xerox Artifical Intelligence Systems
  19. ;;;   2400 Hanover St.
  20. ;;;   Palo Alto, CA 94303
  21. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  22. ;;;
  23. ;;; Suggestions, comments and requests for improvements are also welcome.
  24. ;;; *************************************************************************
  25. ;;;
  26.  
  27. (in-package 'pcl)
  28.  
  29. ;;;
  30. ;;; ADD-NAMED-CLASS  proto-class name local-supers local-slot-slotds extra
  31. ;;; protocol: class-definition
  32. ;;;
  33. ;;; Creates or updates the definition of a class with a named class.  If
  34. ;;; there is already a class named name, calls class-for-redefinition to
  35. ;;; find out which class to use for the redefinition.  Once it has a class
  36. ;;; object to use it stores the relevant information from the ds-options in
  37. ;;; the class and calls add-class to add the class to the class
  38. ;;; lattice.
  39. ;;; 
  40. (defmeth add-named-class ((proto-class basic-class) name
  41.                             local-supers
  42.                             local-slot-slotds
  43.                             extra)
  44.   ;; First find out if there is already a class with this name.
  45.   ;; If there is, call class-for-redefinition to get the class
  46.   ;; object to use for the new definition.  If there is no exisiting
  47.   ;; class we just make a new instance.
  48.   (let* ((existing (class-named name t))
  49.      (class (if existing
  50.             (class-for-redefinition existing proto-class name 
  51.                         local-supers local-slot-slotds
  52.                         extra)
  53.             (make (class-of proto-class)))))
  54.  
  55.     (setq local-supers
  56.       (mapcar
  57.         #'(lambda (ls)
  58.         (or (class-named ls t)
  59.             (error "~S was specified as the name of a local-super~%~
  60.                             for the class named ~S.  But there is no class~%~
  61.                             class named ~S." ls name ls)))
  62.         local-supers))
  63.     
  64.     (setf (class-name class) name)
  65.     (setf (class-ds-options class) extra)    ;This is NOT part of the
  66.                         ;standard protocol.
  67.    
  68.     (add-class class local-supers local-slot-slotds extra)
  69.     
  70.     (setf (class-named name) class)
  71.     name))
  72.  
  73. (defmeth add-class
  74.      ((class essential-class) new-local-supers new-local-slots extra)
  75.   (ignore extra)
  76.   (let ((old-local-supers (class-local-supers class))
  77.     (old-local-slots (class-local-slots class)))
  78.     
  79.     (setf (class-local-supers class) new-local-supers)
  80.     (setf (class-local-slots class) new-local-slots)
  81.  
  82.     (if (and old-local-supers            ;*** YUCH!! There is a bug
  83.          new-local-supers            ;*** when old and new are ()
  84.          (equal old-local-supers new-local-supers))
  85.     (if (and old-local-slots
  86.          new-local-slots
  87.          (equal old-local-slots new-local-slots))
  88.         ;; If the supers haven't changed, and the slots haven't changed
  89.         ;; then not much has changed and we don't have to do anything.
  90.         ()
  91.         ;; If only the slots have changed call slots-changed.
  92.         (slots-changed class old-local-slots extra t))
  93.     ;; If the supers have changed, first update local-supers and
  94.     ;; direct-subclasses of all the people involved.  Then call
  95.     ;; supers-changed.
  96.     (progn
  97.       (dolist (nls new-local-supers)
  98.         (unless (memq nls old-local-supers)
  99.           (check-super-metaclass-compatibility class nls)
  100.           (push class (class-direct-subclasses nls))))
  101.       (dolist (ols old-local-supers)
  102.         (unless (memq ols new-local-supers)
  103.           (setf (class-direct-subclasses ols)
  104.             (delq class (class-direct-subclasses ols)))))
  105.       (supers-changed class old-local-supers old-local-slots extra t)))))
  106.  
  107.  
  108. (defmeth supers-changed ((class basic-class)
  109.              old-local-supers
  110.              old-local-slots
  111.              extra
  112.              top-p)
  113.   (ignore old-local-slots)
  114.   (let ((cpl (compute-class-precedence-list class)))
  115.     (setf (class-class-precedence-list class) cpl)
  116.     (update-slots--class class cpl)                 ;This is NOT part of
  117.                                  ;the essential-class
  118.                                  ;protocol.
  119.     (dolist (sub-class (class-direct-subclasses class))
  120.       (supers-changed sub-class
  121.               (class-local-supers sub-class)
  122.               (class-local-slots sub-class)
  123.               extra
  124.               nil))
  125.     (when top-p                                          ;This is NOT part of
  126.       (update-method-inheritance class old-local-supers));the essential-class
  127.                                  ;protocol.
  128.     ))
  129.  
  130. (defmeth slots-changed ((class basic-class)
  131.             old-local-slots
  132.             extra
  133.             top-p)
  134.   (ignore top-p old-local-slots)
  135.   ;; When this is called, class should have its local-supers and
  136.   ;; local-slots slots filled in properly.
  137.   (update-slots--class class (class-class-precedence-list class))
  138.   (dolist (sub-class (class-direct-subclasses class))
  139.     (slots-changed sub-class (class-local-slots sub-class) extra nil)))
  140.  
  141. (defun update-slots--class (class cpl)
  142.   (let ((obsolete-class nil))
  143.     (multiple-value-bind (instance-slots non-instance-slots)
  144.     (collect-slotds class (class-local-slots class) cpl)
  145.       ;; If there is a change in the shape of the instances then the
  146.       ;; old class is now obsolete.  Make a copy of it, then fill
  147.       ;; ourselves in properly and obsolete it.
  148.       (when (and (class-has-instances-p class)
  149.          (not (same-shape-slots-p (class-instance-slots class)
  150.                       instance-slots)))
  151.     (setq obsolete-class (copy-class class)))
  152.       (setf (class-no-of-instance-slots class) (length instance-slots))
  153.       (setf (class-instance-slots class) instance-slots)
  154.       (setf (class-non-instance-slots class) non-instance-slots)
  155.       (when obsolete-class
  156.     (flush-class-caches class)
  157.     (make-class-obsolete class (copy-class class))))))
  158.  
  159. ;;;
  160. ;;; CLASS-FOR-REDEFINITION old-class proto-class name ds-options slotds
  161. ;;; protocol: class definition
  162. ;;; 
  163. ;;; When a class is being defined, and a class with that name already exists
  164. ;;; a decision must be made as to what to use for the new class object, and
  165. ;;; whether to update the old class object.  For this, class-for-redefinition
  166. ;;; is called with the old class object, the prototype of the new class, and
  167. ;;; the name ds-options and slotds corresponding to the new definition.
  168. ;;; It should return the class object to use as the new definition.  It is
  169. ;;; OK for this to be old-class if that is appropriate.
  170. ;;; 
  171. (defmeth class-for-redefinition ((old-class essential-class)
  172.                  proto-class
  173.                  name
  174.                  local-supers
  175.                  local-slot-slotds
  176.                  extra)
  177.   (ignore local-supers local-slot-slotds extra)
  178.   (cond ((not (compatible-meta-class-change-p old-class proto-class))
  179.      (error "The class ~A already exists; its class is ~A.~%~
  180.          The :class argument in the defstruct is ~A.
  181.          This is an incompatible meta-class change.~%"
  182.         name
  183.         (class-name (class-of old-class))
  184.         (class-name (class-of proto-class))))
  185.     (t (values old-class (copy-class old-class)))))
  186.  
  187. (defmeth update-method-inheritance ((class basic-class) old-local-supers)
  188.   ;; In the absence of method combination, we have to flush all the
  189.   ;; discriminators which we used to inherit and all the discriminators
  190.   ;; which we now inherit.
  191.   (let ((old-mil
  192.       (compute-method-inheritance-list class old-local-supers))
  193.     (new-mil
  194.       (compute-method-inheritance-list class
  195.                        (class-local-supers class)))
  196.     (discriminators ())
  197.     (combined-discriminators ()))
  198.     (dolist (old-donor old-mil)
  199.       (when (setq discriminators (class-direct-discriminators old-donor))
  200.     (dolist (old-discriminator discriminators)      
  201.       (flush-discriminator-caches old-discriminator)
  202.       (when (methods-combine-p old-discriminator)
  203.         (pushnew old-discriminator combined-discriminators)))))
  204.     (dolist (new-donor new-mil)
  205.       (when (setq discriminators (class-direct-discriminators new-donor))
  206.     (unless (memq new-donor old-mil)
  207.       (dolist (new-discriminator discriminators)
  208.         (when (methods-combine-p new-discriminator)
  209.           (pushnew new-discriminator combined-discriminators))
  210.         (flush-discriminator-caches new-discriminator)))))
  211.     (when (fboundp 'combine-methods)                 ;***
  212.       (COMBINE-METHODS CLASS COMBINED-DISCRIMINATORS)))) ;***
  213.  
  214.  
  215. (defmeth discriminator-changed ((discriminator essential-discriminator)
  216.                 method
  217.                 added-p)
  218.   (ignore method added-p)
  219.   (make-discriminating-function discriminator)
  220.   (flush-discriminator-caches discriminator))
  221.  
  222.  
  223. (defun make-class-obsolete (class obsolete-class)
  224.   (setf (class-wrapper-class (class-wrapper obsolete-class)) obsolete-class)
  225.   (setf (class-wrapper class) nil)
  226.   (setf (class-local-supers obsolete-class) (list class))
  227.   (setf (class-class-precedence-list obsolete-class)
  228.         (cons obsolete-class (class-class-precedence-list class)))
  229.   (setf (class-name obsolete-class)
  230.     (symbol-append "obsolete-" (class-name class)))
  231.   (setf (iwmc-class-class-wrapper obsolete-class)
  232.         (wrapper-of (class-named 'obsolete-class)))
  233.   obsolete-class)
  234.  
  235. (defun copy-class (class) 
  236.   (let* ((no-of-instance-slots (class-no-of-instance-slots (class-of class)))
  237.          (new-class (%allocate-instance--class no-of-instance-slots)))
  238.     (setf (iwmc-class-class-wrapper new-class)
  239.       (iwmc-class-class-wrapper class))
  240.     (iterate ((i from 0 below no-of-instance-slots))
  241.       (let ((index (%convert-slotd-position-to-slot-index i)))
  242.     (setf (get-static-slot--class new-class index)            
  243.           (get-static-slot--class class index))))
  244.     (setf (iwmc-class-dynamic-slots new-class)
  245.           (copy-list (iwmc-class-dynamic-slots class)))
  246.     new-class))
  247.  
  248. (defun wrapper-of (class)
  249.   (or (class-wrapper class)
  250.       (setf (class-wrapper class) (make-class-wrapper class))))
  251.  
  252. (defmeth collect-slotds ((class basic-class) local-slots cpl)
  253.   (let ((slots ()))
  254.     (flet ((add-slotd (slotd)
  255.          (let ((entry
  256.              (or (assq (slotd-name slotd) slots)
  257.              (progn (push (list (slotd-name slotd)) slots)
  258.                 (car slots)))))
  259.            (push slotd (cdr entry)))))
  260.       (dolist (super (reverse (cdr cpl)))    ;fix this consing later
  261.     (dolist (super-slotd (class-local-slots super))
  262.       (add-slotd super-slotd)))
  263.  
  264.       (dolist (local-slotd local-slots)
  265.     (add-slotd local-slotd)))
  266.       
  267.     ;; Now use compute-effective-slotd to condense all the
  268.     ;; inherited slotds into the one effective slotd.
  269.     (dolist (slot slots)
  270.       (setf (car slot)
  271.         (compute-effective-slotd class (cdr slot))))
  272.     ;; Now we need to separate it back out into instance and non-instance
  273.     ;; slots.
  274.     (let ((instance ())
  275.       (non-instance ()))
  276.       (dolist (slot slots)
  277.     (setq slot (car slot))
  278.     (if (eq (slotd-allocation slot) ':instance)
  279.         (push slot instance)
  280.         (push slot non-instance)))
  281.       (values instance non-instance slots))))
  282.  
  283. (defmethod compute-effective-slotd ((class class) slotds)
  284.   (ignore class)
  285.   (let ((slotd  (if (null (cdr slotds))
  286.             (car slotds)
  287.             (copy-slotd (car slotds)))))
  288.     (flet ((merge-values (default type read-only accessor allocation)
  289.          (macrolet ((merge-value (name value)
  290.               `(when (eq (,name slotd) *slotd-unsupplied*)
  291.                  (setf (,name slotd) ,value))))
  292.            (merge-value slotd-default default)
  293.            (merge-value slotd-type type)
  294.            (merge-value slotd-read-only read-only)
  295.            (merge-value slotd-accessor accessor)
  296.            (merge-value slotd-allocation allocation))))
  297.       (dolist (s (cdr slotds))
  298.     (merge-values (slotd-default s)
  299.               (slotd-type s)
  300.               (slotd-read-only s)
  301.               (slotd-accessor s)
  302.               (slotd-allocation s)))
  303.       (merge-values 'nil      ;default value -- for now
  304.             't        ;type
  305.             'nil      ;read-only
  306.             'nil      ;accessor
  307.           :instance)) ;allocation
  308.     slotd))
  309.  
  310. (defmethod compute-class-precedence-list ((root class))
  311.   #+Lucid (declare (optimize (speed 0) (safety 3)))
  312.   (let ((*cpl* ())
  313.     (*root* root)
  314.     (*must-precede-alist* ()))
  315.     (declare (special *cpl* *root* *must-precede-alist*))
  316.     ;; We start by computing two values.
  317.     ;;   CPL
  318.     ;;     The depth-first left-to-right up to joins walk of the supers tree.
  319.     ;;     This is equivalent to breadth-first left-to-right walk of the
  320.     ;;     tree with all but the last occurence of a class removed from
  321.     ;;     the resulting list.  This is in fact how the walk is implemented.
  322.     ;;
  323.     ;;   MUST-PRECEDE-ALIST
  324.     ;;     An alist of the must-precede relations. The car of each element
  325.     ;;     of the must-precede-alist is a class, the cdr is all the classes
  326.     ;;     which either:
  327.     ;;       have this class as a local super
  328.     ;;      or
  329.     ;;       appear before this class in some other class's local-supers.
  330.     ;;
  331.     ;;     Thus, the must-precede-alist reflects the two constraints that:
  332.     ;;       1. A class must appear in the CPL before its local supers.
  333.     ;;       2. Order of local supers is preserved in the CPL.
  334.     ;;
  335.     (labels
  336.    ;(flet
  337.        (
  338. ;    (walk-supers (class &optional precedence)
  339. ;      (let ((elem (assq class must-precede-alist)))
  340. ;        (if elem
  341. ;        (setf (cdr elem) (union (cdr elem) precedence))
  342. ;        (push (cons class precedence) must-precede-alist)))
  343. ;      (let ((rsupers (reverse (cons class (class-local-supers class)))))
  344. ;        (iterate ((sup in rsupers)
  345. ;              (pre on (cdr rsupers))
  346. ;              (temp = nil))
  347. ;          ;; Make sure this element of supers is OK.
  348. ;          ;;  Actually, there is an important design decision hidden in
  349. ;          ;;  here.  Namely, at what time should symbols in a class's
  350. ;          ;;  local-supers be changed to the class objects they are
  351. ;          ;;  forward referencing.
  352. ;          ;;   1. At first make-instance (compute-class-precedence-list)?
  353. ;          ;;   2. When the forward referenced class is first defined?
  354. ;          ;;  This code does #1.
  355. ;          (cond ((classp sup))
  356. ;            ((and (symbolp sup)
  357. ;              (setq temp (class-named sup t)))
  358. ;             ;; This is a forward reference to a class which is
  359. ;             ;; now defined.  Replace the symbol in the local
  360. ;             ;; supers with the actual class object, and set sup.
  361. ;             (nsubst temp sup (class-local-supers class))
  362. ;             (setq sup temp))
  363. ;            ((symbolp sup)
  364. ;             (error "While computing the class-precedence-list for ~
  365. ;                             the class ~S.~%~
  366. ;                             The class ~S (from the local supers of ~S) ~
  367. ;                             is undefined."
  368. ;                (class-name root) sup (class-name class)))
  369. ;            (t
  370. ;             (error "INTERNAL ERROR --~%~
  371. ;                             While computing the class-precedence-list for ~
  372. ;                             the class ~S,~%~
  373. ;                             ~S appeared in the local supers of ~S."
  374. ;                root sup class)))
  375. ;          (walk-supers sup pre))
  376. ;        (unless (memq class cpl) (push class cpl))))
  377.     (must-move-p (element list &aux move)
  378.       (dolist (must-precede (cdr (assq element *must-precede-alist*)))
  379.         (when (setq move (memq must-precede (cdr list)))
  380.           (return move))))
  381.     (find-farthest-move (element move)
  382.       (let ((closure (compute-must-precedes-closure element)))
  383.         (dolist (must-precede closure)
  384.           (setq move (or (memq must-precede move) move)))
  385.         move))
  386.     (compute-must-precedes-closure (class)
  387.       (let ((closure ()))
  388.         (labels ((walk (element path)
  389.                (when (memq element path)
  390.              (class-ordering-error
  391.                *root* element path *must-precede-alist*))
  392.                (dolist (precede
  393.                  (cdr (assq element
  394.                         *must-precede-alist*)))
  395.              (unless (memq precede closure)
  396.                (pushnew precede closure)
  397.                (walk precede (cons element path))))))
  398.           (walk class nil)
  399.           closure))))
  400.       
  401.       (walk-supers *root*)            ;Do the walk
  402.       ;; For each class in the cpl, make sure that there are no classes after
  403.       ;; it which should be before it.  We do this by cdring down the list,
  404.       ;; making sure that for each element of the list, none of its
  405.       ;; must-precedes come after it in the list. If we find one, we use the
  406.       ;; transitive closure of the must-precedes (call find-farthest-move) to
  407.       ;; see where the class must really be moved. We use a hand-coded loop
  408.       ;; so that we can splice things in and out of the CPL as we go.
  409.       (let ((tail *cpl*)
  410.         (element nil)
  411.         (move nil))
  412.     (loop (when (null tail) (return))
  413.           (setq element (car tail)
  414.             move (must-move-p element tail))
  415.           (cond (move
  416.              (setq move (find-farthest-move element move))
  417.              (setf (cdr move) (cons element (cdr move)))
  418.              (setf (car tail) (cadr tail)) ;Interlisp delete is OK
  419.              (setf (cdr tail) (cddr tail)) ;since it will never be
  420.                            ;last element of list.
  421.              )
  422.             (t
  423.              (setq tail (cdr tail)))))
  424.     (copy-list *cpl*)))))
  425.  
  426. (defun walk-supers (class &optional precedence)
  427.   (declare (special *cpl* *root* *must-precede-alist*))
  428.   (let ((elem (assq class *must-precede-alist*)))
  429.     (if elem
  430.     (setf (cdr elem) (union (cdr elem) precedence))
  431.     (push (cons class precedence) *must-precede-alist*)))
  432.   (let ((rsupers (reverse (cons class (class-local-supers class)))))
  433.     (iterate ((sup in rsupers)
  434.           (pre on (cdr rsupers))
  435.           (temp = nil))
  436.       ;; Make sure this element of supers is OK.
  437.       ;;  Actually, there is an important design decision hidden in
  438.       ;;  here.  Namely, at what time should symbols in a class's
  439.       ;;  local-supers be changed to the class objects they are
  440.       ;;  forward referencing.
  441.       ;;   1. At first make-instance (compute-class-precedence-list)?
  442.       ;;   2. When the forward referenced class is first defined?
  443.       ;;  This code does #1.
  444.       (cond ((classp sup))
  445.         ((and (symbolp sup)
  446.           (setq temp (class-named sup t)))
  447.          ;; This is a forward reference to a class which is
  448.          ;; now defined.  Replace the symbol in the local
  449.          ;; supers with the actual class object, and set sup.
  450.          (nsubst temp sup (class-local-supers class))
  451.          (setq sup temp))
  452.         ((symbolp sup)
  453.          (error "While computing the class-precedence-list for ~
  454.                              the class ~S.~%~
  455.                              The class ~S (from the local supers of ~S) ~
  456.                              is undefined."
  457.             (class-name *root*) sup (class-name class)))
  458.         (t
  459.          (error "INTERNAL ERROR --~%~
  460.                              While computing the class-precedence-list for ~
  461.                              the class ~S,~%~
  462.                              ~S appeared in the local supers of ~S."
  463.             *root* sup class)))
  464.       (walk-supers sup pre))
  465.     (unless (memq class *cpl*) (push class *cpl*))))
  466.  
  467. (defun class-ordering-error (root element path must-precede-alist)
  468.   (ignore root)
  469.   (setq path (cons element (reverse (memq element (reverse path)))))
  470.   (flet ((pretty (class) (or (class-name class) class)))
  471.     (let ((explanations ()))
  472.       (do ((tail path (cdr tail)))
  473.       ((null (cdr tail)))
  474.     (let ((after (cadr tail))
  475.           (before (car tail)))
  476.       (if (memq after (class-local-supers before))
  477.           (push (format nil
  478.                 "~% ~A must precede ~A -- ~
  479.                               ~A is in the local supers of ~A."
  480.                 (pretty before) (pretty after)
  481.                 (pretty after) (pretty before))
  482.             explanations)
  483.           (dolist (common-precede
  484.             (intersection
  485.               (cdr (assq after must-precede-alist))
  486.               (cdr (assq before must-precede-alist))))
  487.         (when (memq after (memq before
  488.                     (class-local-supers common-precede)))
  489.           (push (format nil
  490.                 "~% ~A must precede ~A -- ~
  491.                                   ~A has local supers ~S."
  492.                 (pretty before) (pretty after)
  493.                 (pretty common-precede)
  494.                 (mapcar #'pretty
  495.                     (class-local-supers common-precede)))
  496.             explanations))))))
  497.       (error "While computing the class-precedence-list for the class ~A:~%~
  498.               There is a circular constraint through the classes:~{ ~A~}.~%~
  499.               This arises because:~{~A~}"
  500.          (pretty root)
  501.          (mapcar #'pretty path)
  502.          (reverse explanations)))))
  503.  
  504. (defmeth compute-method-inheritance-list ((class essential-class)
  505.                       local-supers)
  506.   (compute-class-precedence-list class))
  507.  
  508. (defmeth compatible-meta-class-change-p (class proto-new-class)
  509.   (eq (class-of class) (class-of proto-new-class)))
  510.  
  511. (defmeth check-super-metaclass-compatibility (class new-super)
  512.   (unless (eq (class-of class) (class-of new-super))
  513.     (error "The class ~S was specified as a~%super-class of the class ~S;~%~
  514.             but the meta-classes ~S and~%~S are incompatible."
  515.        new-super class (class-of new-super) (class-of class))))
  516.  
  517. (defun classp (x)
  518.   (and (iwmc-class-p x) (typep--class x 'essential-class)))
  519.  
  520.  
  521.  
  522. (defmeth class-standard-constructor ((class basic-class))
  523.   (dolist (constructor (ds-options-constructors (class-ds-options class)))
  524.     (when (null (cdr constructor)) (return (car constructor)))))
  525.  
  526.  
  527. (defmeth flush-class-caches ((class basic-class))
  528.   (let ((wrapper (class-wrapper class)))
  529.     (and wrapper (flush-class-wrapper-cache wrapper))
  530.     (iterate ((subclass in (class-direct-subclasses class)))
  531.       (flush-class-caches subclass))))
  532.  
  533.  
  534.   ;;   
  535. ;;;;;; CHANGE-CLASS
  536.   ;;   
  537.  
  538. (defun change-class (object new-class)
  539.   (or (classp new-class)
  540.       (setq new-class (class-named new-class)))
  541.   (let ((new-object (make new-class)))
  542.     ;; Call change-class-internal so that a user-defined method
  543.     ;; (or the default method) can copy the information from the
  544.     ;; old instance to the dummy instance of the new class.
  545.     (change-class-internal object new-object)
  546.     ;; Now that the dummy new-object has the right information,
  547.     ;; move all that stuff into the old-instance.
  548.     (setf (iwmc-class-class-wrapper object)
  549.       (wrapper-of new-class))
  550.     (setf (iwmc-class-static-slots object)
  551.       (iwmc-class-static-slots new-object))
  552.     (setf (iwmc-class-dynamic-slots object)
  553.       (iwmc-class-dynamic-slots new-object))
  554.     object))
  555.  
  556. (defmeth change-class-internal ((old object) (new object))
  557.   (let ((all-slots (all-slots old)))
  558.     (iterate ((name in all-slots by cddr)
  559.               (value in (cdr all-slots) by cddr))
  560.       (put-slot-always new name value))))
  561.  
  562.   ;;   
  563. ;;;;;; WITH-SLOTS
  564.   ;;
  565.  
  566. (define-method-body-macro with-slots (instance-forms-and-options
  567.                        &body body
  568.                        &environment env)
  569.   :global (expand-with-slots nil nil instance-forms-and-options env body)
  570.   :method (expand-with-slots (macroexpand-time-generic-function
  571.                    macroexpand-time-environment)
  572.                  (macroexpand-time-method
  573.                    macroexpand-time-environment)
  574.                  instance-forms-and-options
  575.                  env
  576.                  body))
  577.  
  578. (defun expand-with-slots (proto-discriminator proto-method first-arg env body)
  579.   (ignore proto-discriminator)
  580.   (setq first-arg (iterate ((arg in first-arg))
  581.             (collect (if (listp arg) arg (list arg)))))
  582.   (let ((entries (expand-with-make-entries proto-method first-arg))
  583.     (gensyms ()))
  584.     (dolist (arg first-arg)
  585.       (push (list (if (listp arg) (car arg) arg)
  586.           (gensym))
  587.         gensyms))
  588.     `(let ,(mapcar #'reverse gensyms)
  589.        ,(walk-form (cons 'progn body)
  590.       :environment env
  591.       :walk-function
  592.       #'(lambda (form context &aux temp)
  593.           (cond ((and (symbolp form)
  594.               (eq context ':eval)
  595.               (null (variable-lexical-p form))
  596.               (null (variable-special-p form))
  597.               (setq temp (assq form entries)))
  598.              (if (car (cddddr temp))    ;use slot-value?
  599.              (let ((get-slot 
  600.                  `(get-slot ,(cadr (assq (cadr temp) gensyms))
  601.                         ',(slotd-name (cadddr temp)))))
  602.                (optimize-get-slot (caddr temp)
  603.                           get-slot))
  604.              `(,(slotd-accessor (cadddr temp))
  605.                ,(cadr (assq (cadr temp) gensyms)))))
  606.             ((and (listp form)
  607.               (or (eq (car form) 'setq)
  608.                   (eq (car form) 'setf)))
  609.              (cond ((cdddr form)
  610.                 (cons 'progn
  611.                   (iterate ((pair on (cdr form) by cddr))
  612.                     (collect (list (car form)
  613.                            (car pair)
  614.                            (cadr pair))))))
  615.                ((setq temp (assq (cadr form) entries))
  616.                 (if (car (cddddr temp))
  617.                 (let ((get-slot 
  618.                     `(setf-of-get-slot
  619.                        ,(cadr (assq (cadr temp) gensyms))
  620.                        ',(slotd-name (cadddr temp))
  621.                        ,(caddr form))))
  622.                   (optimize-setf-of-get-slot (caddr temp)
  623.                                  get-slot))
  624.                 `(setf (,(slotd-accessor (cadddr temp))
  625.                     ,(cadr (assq (cadr temp) gensyms)))
  626.                        ,(caddr form))))
  627.                (t form)))
  628.             (t form)))))))
  629.  
  630. ;;; Returns an alist of the form:
  631. ;;; 
  632. ;;;   (<prefix+slot-name> <instance-form> <class> <slotd> <use-slot-value-p>)
  633. ;;;
  634. (defmeth expand-with-make-entries (method first-arg)
  635.   (let* ((entries ())
  636.          (method-arguments
  637.        (when (method-p method)
  638.          (iterate ((arg in (method-arglist method))
  639.                (spec in (method-type-specifiers method)))
  640.            (when (classp spec) (collect (cons arg spec)))))))
  641.     (iterate ((instance-and-keys in first-arg))
  642.       (keyword-bind ((use-slot-value nil)
  643.              (class nil class-specified-p)
  644.              (prefix nil prefix-specified-p))
  645.             (cdr instance-and-keys)
  646.     (let ((instance (car instance-and-keys)))
  647.       (setq class
  648.         (or (and class-specified-p
  649.              (or (class-named class t)
  650.                  (error "In WITH-SLOTS the class specified for ~
  651.                                      ~S, ~S ~%~
  652.                                      is not the name of a defined class."
  653.                     instance class)))
  654.             (cdr (assq instance method-arguments))
  655.             (error "The class of (the value of) ~S was not given in ~
  656.                            in the call to with-slots and could not be ~
  657.                            inferred automatically."
  658.               instance)))
  659.       (iterate ((slotd in (class-slots class)))
  660.         (push (list (if (null prefix-specified-p)
  661.                 (slotd-name slotd)
  662.                 (intern (string-append prefix
  663.                            (slotd-name slotd))
  664.                     (symbol-package
  665.                       (if (symbolp prefix)
  666.                       prefix
  667.                       (slotd-name slotd)))))
  668.             instance
  669.             class
  670.             slotd
  671.             use-slot-value)
  672.           entries)))))
  673.     entries))
  674.  
  675.  
  676. (defun named-object-print-function (instance stream depth
  677.                          &optional (extra nil extra-p))
  678.   (ignore depth)
  679.   (printing-random-thing (instance stream)
  680.     ;; I know I don't have to do this this way.  I know I
  681.     ;; could use ~[~;~], but how many Common Lisps do you
  682.     ;; think have that completely debugged?
  683.     (if extra-p                    
  684.     (format stream "~A ~S ~:S"
  685.         (capitalize-words (class-name (class-of instance)))
  686.         (get-slot instance 'name)
  687.         extra)
  688.     (format stream "~A ~S"
  689.         (capitalize-words (class-name (class-of instance)))
  690.         (get-slot instance 'name)))))
  691.  
  692.