mdw@git.distorted.org.uk Git - clg/blob - gffi/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 ;;; by Espen S. Johnsen <espen@users.sf.net>
  28
  29
  30 (eval-when (:compile-toplevel :load-toplevel :execute)
  31   (setf (ext:package-lock (find-package "PCL")) nil))
  32
  33 (in-package "PCL")
  34
  35 (defstruct slot-info
  36   (name nil :type symbol)
  37   ;;
  38   ;; Specified slot allocation.or :INSTANCE.
  39   (allocation :instance :type (or (member :class :instance) t))
  40   ;;
  41   ;; Specified slot type or T.
  42   (type t :type (or symbol list)))
  43
  44
  45 (defmethod compute-slots :around ((class standard-class))
  46   (loop with slotds = (call-next-method) and location = -1
  47         for slot in slotds do
  48           (setf (slot-definition-location slot)
  49                 (case (slot-definition-allocation slot)
  50                   (:instance
  51                    (incf location))
  52                   (:class
  53                    (let* ((name (slot-definition-name slot))
  54                           (from-class (slot-definition-allocation-class slot))
  55                           (cell (assq name (class-slot-cells from-class))))
  56                      (assert (consp cell))
  57                      cell))))
  58           (initialize-internal-slot-functions slot)
  59         finally
  60           (return slotds)))
  61
  62
  63
  64 (defun update-slots (class eslotds)
  65   (collect ((instance-slots) (class-slots))
  66     (dolist (eslotd eslotds)
  67       (case (slot-definition-allocation eslotd)
  68         (:instance (instance-slots eslotd))
  69         (:class (class-slots eslotd))))
  70     ;;
  71     ;; If there is a change in the shape of the instances then the
  72     ;; old class is now obsolete.
  73     (let* ((nlayout (mapcar #'slot-definition-name
  74                             (sort (instance-slots) #'<
  75                                   :key #'slot-definition-location)))
  76            (nslots (length nlayout))
  77            (nwrapper-class-slots (compute-class-slots (class-slots)))
  78            (owrapper (when (class-finalized-p class)
  79                        (class-wrapper class)))
  80            (olayout (when owrapper
  81                       (wrapper-instance-slots-layout owrapper)))
  82            (nwrapper
  83             (cond ((null owrapper)
  84                    (make-wrapper nslots class))
  85                   ;;
  86                   ;; We cannot reuse the old wrapper easily when it
  87                   ;; has class slot cells, even if these cells are
  88                   ;; EQUAL to the ones used in the new wrapper.  The
  89                   ;; class slot cells of OWRAPPER may be referenced
  90                   ;; from caches, and if we don't change the wrapper,
  91                   ;; the caches won't notice that something has
  92                   ;; changed.  We could do something here manually,
  93                   ;; but I don't think it's worth it.
  94                   ((and (equal nlayout olayout)
  95                         (null (wrapper-class-slots owrapper)))
  96                    owrapper)
  97                   (t
  98                    ;;
  99                    ;; This will initialize the new wrapper to have the same
 100                    ;; state as the old wrapper.  We will then have to change
 101                    ;; that.  This may seem like wasted work (it is), but the
 102                    ;; spec requires that we call make-instances-obsolete.
 103                    (make-instances-obsolete class)
 104                    (class-wrapper class)))))
 105
 106       (with-slots (wrapper slots finalized-p) class
 107         (update-lisp-class-layout class nwrapper)
 108         (setf slots eslotds
 109               (wrapper-instance-slots-layout nwrapper) nlayout
 110               (wrapper-class-slots nwrapper) nwrapper-class-slots
 111               (wrapper-no-of-instance-slots nwrapper) nslots
 112               wrapper nwrapper
 113               finalized-p t))
 114
 115       (unless (eq owrapper nwrapper)
 116         (update-inline-access class)
 117         (update-pv-table-cache-info class)
 118         (maybe-update-standard-class-locations class)))))
 119
 120
 121 (pushnew :non-broken-pcl *features*)