chiark - git - mdw - clg/blob - glib/pcl.lisp

   1 ;;; *************************************************************************
   2 ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
   3 ;;; All rights reserved.
   4 ;;;
   5 ;;; Use and copying of this software and preparation of derivative works
   6 ;;; based upon this software are permitted.  Any distribution of this
   7 ;;; software or derivative works must comply with all applicable United
   8 ;;; States export control laws.
   9 ;;;
  10 ;;; This software is made available AS IS, and Xerox Corporation makes no
  11 ;;; warranty about the software, its performance or its conformity to any
  12 ;;; specification.
  13 ;;;
  14 ;;; Any person obtaining a copy of this software is requested to send their
  15 ;;; name and post office or electronic mail address to:
  16 ;;;   CommonLoops Coordinator
  17 ;;;   Xerox PARC
  18 ;;;   3333 Coyote Hill Rd.
  19 ;;;   Palo Alto, CA 94304
  20 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  21 ;;;
  22 ;;; Suggestions, comments and requests for improvements are also welcome.
  23 ;;; *************************************************************************
  24 ;;;
  25
  26 ;;; Modifications for better AMOP conformance
  27 ;;; Copyright (C) 2001 Espen S. Johnsen <esj@stud.cs.uit.no>
  28
  29 (in-package "PCL")
  30
  31 ;;;; Adding initargs parameter to change-class
  32
  33 (defun change-class-internal (instance new-class initargs)
  34   (let* ((old-class (class-of instance))
  35          (copy (allocate-instance new-class))
  36          (new-wrapper (get-wrapper copy))
  37          (old-wrapper (class-wrapper old-class))
  38          (old-layout (wrapper-instance-slots-layout old-wrapper))
  39          (new-layout (wrapper-instance-slots-layout new-wrapper))
  40          (old-slots (get-slots instance))
  41          (new-slots (get-slots copy))
  42          (old-class-slots (wrapper-class-slots old-wrapper)))
  43
  44     ;;
  45     ;; "The values of local slots specified by both the class Cto and
  46     ;; Cfrom are retained.  If such a local slot was unbound, it remains
  47     ;; unbound."
  48     ;;
  49     (iterate ((new-slot (list-elements new-layout))
  50               (new-position (interval :from 0)))
  51       (let ((old-position (posq new-slot old-layout)))
  52         (when old-position
  53           (setf (instance-ref new-slots new-position)
  54                 (instance-ref old-slots old-position)))))
  55
  56     ;;
  57     ;; "The values of slots specified as shared in the class Cfrom and
  58     ;; as local in the class Cto are retained."
  59     ;;
  60     (iterate ((slot-and-val (list-elements old-class-slots)))
  61       (let ((position (posq (car slot-and-val) new-layout)))
  62         (when position
  63           (setf (instance-ref new-slots position) (cdr slot-and-val)))))
  64
  65     ;; Make the copy point to the old instance's storage, and make the
  66     ;; old instance point to the new storage.
  67     (swap-wrappers-and-slots instance copy)
  68
  69     (apply #'update-instance-for-different-class copy instance initargs)
  70     instance))
  71
  72
  73 (fmakunbound 'change-class)
  74 (defgeneric change-class (instance new-class &rest initargs))
  75
  76 (defmethod change-class ((instance standard-object)
  77                          (new-class standard-class)
  78                          &rest initargs)
  79   (change-class-internal instance new-class initargs))
  80
  81 (defmethod change-class ((instance funcallable-standard-object)
  82                          (new-class funcallable-standard-class)
  83                          &rest initargs)
  84   (change-class-internal instance new-class initargs))
  85
  86 (defmethod change-class ((instance standard-object)
  87                          (new-class funcallable-standard-class)
  88                          &rest initargs)
  89   (error "Can't change the class of ~S to ~S~@
  90           because it isn't already an instance with metaclass ~S."
  91          instance new-class 'standard-class))
  92
  93 (defmethod change-class ((instance funcallable-standard-object)
  94                          (new-class standard-class)
  95                          &rest initargs)
  96   (error "Can't change the class of ~S to ~S~@
  97           because it isn't already an instance with metaclass ~S."
  98          instance new-class 'funcallable-standard-class))
  99
 100 (defmethod change-class ((instance t) (new-class symbol) &rest initargs)
 101   (change-class instance (find-class new-class) initargs))
 102
 103
 104 ;;;; Make the class finalization protocol behave as specified in AMOP
 105
 106 (defmethod ensure-class-using-class (name (class pcl-class) &rest args &key)
 107   (multiple-value-bind (meta initargs)
 108       (ensure-class-values class args)
 109     (if (eq (class-of class) meta)
 110         (apply #'reinitialize-instance class initargs)
 111       (apply #'change-class class meta initargs))
 112     (setf (find-class name) class)
 113     (inform-type-system-about-class class name)
 114     class))
 115
 116 (defmethod finalize-inheritance ((class std-class))
 117   (dolist (super (class-direct-superclasses class))
 118     (unless (class-finalized-p super) (finalize-inheritance super)))
 119   (update-cpl class (compute-class-precedence-list class))
 120   (update-slots class (compute-slots class))
 121   (update-gfs-of-class class)
 122   (update-inits class (compute-default-initargs class))
 123   (update-make-instance-function-table class))
 124
 125 (defmethod finalize-inheritance ((class forward-referenced-class))
 126   (error "~A can't be finalized" class))
 127
 128 (defun update-class (class &optional finalizep)
 129   (declare (ignore finalizep))
 130   (unless (class-has-a-forward-referenced-superclass-p class)
 131     (finalize-inheritance class)
 132     (dolist (sub (class-direct-subclasses class))
 133       (update-class sub))))
 134