chiark / gitweb /
Fix compilation for Gtk with the new, stricter inheritance
[clg] / 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*)