| 1 | ;;;-*- Mode: Lisp; Package: (WOOD) -*-
|
|---|
| 2 |
|
|---|
| 3 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|---|
| 4 | ;;
|
|---|
| 5 | ;; persistent-clos.lisp
|
|---|
| 6 | ;; Support for saving/restoring CLOS instances to/from Wood persistent heaps.
|
|---|
| 7 | ;;
|
|---|
| 8 | ;; Portions Copyright © 2006 Clozure Associates and Anvita eReference (www.Anvita.info)
|
|---|
| 9 | ;; Copyright © 1996 Digitool, Inc.
|
|---|
| 10 | ;; Copyright © 1992-1995 Apple Computer, Inc.
|
|---|
| 11 | ;; All rights reserved.
|
|---|
| 12 | ;; Permission is given to use, copy, and modify this software provided
|
|---|
| 13 | ;; that Digitool is given credit in all derivative works.
|
|---|
| 14 | ;; This software is provided "as is". Digitool makes no warranty or
|
|---|
| 15 | ;; representation, either express or implied, with respect to this software,
|
|---|
| 16 | ;; its quality, accuracy, merchantability, or fitness for a particular
|
|---|
| 17 | ;; purpose.
|
|---|
| 18 | ;;
|
|---|
| 19 |
|
|---|
| 20 | ;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|---|
| 21 | ;;
|
|---|
| 22 | ;; Modification History
|
|---|
| 23 | ;;
|
|---|
| 24 | ;; 02/01/06 gz LispWorks port
|
|---|
| 25 | ;; 08/28/98 akh add dc-shared-initialize - fixes case of change class in memory, then write a slot-value to pheap
|
|---|
| 26 | ;; left us with the class updated on disk but not the instance-slots with initforms
|
|---|
| 27 | ;; ------------- 0.96
|
|---|
| 28 | ;; ------------- 0.95
|
|---|
| 29 | ;; ------------- 0.94
|
|---|
| 30 | ;; ------------- 0.93
|
|---|
| 31 | ;; ------------- 0.9
|
|---|
| 32 | ;; 11/02/94 bill (method %p-store-object (t standard-object t)) no longer
|
|---|
| 33 | ;; handles p-make-load-function-using-pheap. It has moved
|
|---|
| 34 | ;; into %p-store-internal now.
|
|---|
| 35 | ;; 10/28/94 Moon Change without-interrupts to with-databases-locked
|
|---|
| 36 | ;; 10/25/94 bill p-load-instance calls wood-disk-resident-slot-names,
|
|---|
| 37 | ;; a new GF that users can specialize.
|
|---|
| 38 | ;; define-disk-resident-slot-names macro to aid generation
|
|---|
| 39 | ;; of wood-disk-resident-slot-names methods and accessor
|
|---|
| 40 | ;; methods that will swap disk resident slots in when
|
|---|
| 41 | ;; necessary.
|
|---|
| 42 | ;; 09/21/94 bill without-interrupts as necessary for interlocking
|
|---|
| 43 | ;; -------------- 0.8
|
|---|
| 44 | ;; 10/25/93 bill initialize-persistent-instance
|
|---|
| 45 | ;; -------------- 0.6
|
|---|
| 46 | ;; 02/16/93 bill p-load-instance now calls shared-initialize to initialize
|
|---|
| 47 | ;; any new slots (slots that have been added since the instance
|
|---|
| 48 | ;; was saved to the pheap file).
|
|---|
| 49 | ;; 11/16/92 bill pheap-class-hash, p-class-instance-slot-names
|
|---|
| 50 | ;; 11/09/92 bill Make it work correctly to create two instances, p-store them,
|
|---|
| 51 | ;; redefine the class adding a slot, p-store the first instance,
|
|---|
| 52 | ;; close and reopen the pheap, then p-load the second instance.
|
|---|
| 53 | ;; chung@ils.nwu.edu found that this used to result in an instance all
|
|---|
| 54 | ;; of whose slots were unbound.
|
|---|
| 55 | ;; 08/27/92 bill in %p-store-object: call p-make-load-function
|
|---|
| 56 | ;; 08/13/92 bill (setf p-slot-value) now does the right thing if instance
|
|---|
| 57 | ;; is not a PPTR.
|
|---|
| 58 | ;; -------------- 0.5
|
|---|
| 59 | ;; 06/23/92 bill New file
|
|---|
| 60 | ;;
|
|---|
| 61 |
|
|---|
| 62 | (in-package :wood)
|
|---|
| 63 |
|
|---|
| 64 | (defun pheap-class-hash (pheap)
|
|---|
| 65 | (let ((hash (dc-class-hash (pheap-disk-cache pheap))))
|
|---|
| 66 | (when hash
|
|---|
| 67 | (pptr pheap hash))))
|
|---|
| 68 |
|
|---|
| 69 | (defun dc-class-hash (disk-cache &optional create?)
|
|---|
| 70 | (with-databases-locked
|
|---|
| 71 | (let ((res (dc-%svref disk-cache $root-vector $pheap.class-hash)))
|
|---|
| 72 | (if (eql res $pheap-nil)
|
|---|
| 73 | (if create?
|
|---|
| 74 | (setf (dc-%svref disk-cache $root-vector $pheap.class-hash)
|
|---|
| 75 | (dc-make-hash-table disk-cache)))
|
|---|
| 76 | res))))
|
|---|
| 77 |
|
|---|
| 78 | (defun p-find-class (pheap name &optional (errorp t))
|
|---|
| 79 | (multiple-value-bind (pointer imm?) (%p-store-hash-key pheap name)
|
|---|
| 80 | (when pointer
|
|---|
| 81 | (let ((res (dc-find-class (pheap-disk-cache pheap) pointer imm? errorp)))
|
|---|
| 82 | (when res (pptr pheap res))))))
|
|---|
| 83 |
|
|---|
| 84 | (defun dc-find-class (disk-cache pointer immediate? &optional (errorp t))
|
|---|
| 85 | (let ((hash (dc-class-hash disk-cache)))
|
|---|
| 86 | (or (and hash
|
|---|
| 87 | (dc-gethash disk-cache pointer immediate? hash))
|
|---|
| 88 | (when errorp
|
|---|
| 89 | (error "Class named ~s not found."
|
|---|
| 90 | (dc-pointer-load disk-cache pointer immediate?))))))
|
|---|
| 91 |
|
|---|
| 92 | ; Will overwrite an existing class
|
|---|
| 93 | (defun p-make-class (pheap name slots)
|
|---|
| 94 | (unless (and (vectorp slots) (every 'symbolp slots))
|
|---|
| 95 | (error "~s is not a vector of slot names" slots))
|
|---|
| 96 | (multiple-value-bind (pointer imm?) (%p-store pheap name)
|
|---|
| 97 | (pptr pheap
|
|---|
| 98 | (dc-make-class (pheap-disk-cache pheap)
|
|---|
| 99 | pointer
|
|---|
| 100 | (%p-store pheap slots)
|
|---|
| 101 | imm?
|
|---|
| 102 | slots
|
|---|
| 103 | pheap))))
|
|---|
| 104 |
|
|---|
| 105 | (defun dc-make-class (disk-cache name slots &optional name-imm? slots-object pheap)
|
|---|
| 106 | (let* ((class (dc-make-uvector disk-cache $class-size $v_class))
|
|---|
| 107 | (hash (dc-class-hash disk-cache t))
|
|---|
| 108 | (wrapper (dc-make-class-wrapper disk-cache class slots slots-object pheap)))
|
|---|
| 109 | (dc-%svfill disk-cache class
|
|---|
| 110 | ($class.name name-imm?) name
|
|---|
| 111 | $class.own-wrapper wrapper)
|
|---|
| 112 | (dc-puthash disk-cache name name-imm? hash class)))
|
|---|
| 113 |
|
|---|
| 114 | (defun dc-make-class-wrapper (disk-cache class slots &optional slots-object pheap)
|
|---|
| 115 | (let ((wrapper (dc-make-vector disk-cache $wrapper-size)))
|
|---|
| 116 | (dc-%svfill disk-cache wrapper
|
|---|
| 117 | $wrapper.class class
|
|---|
| 118 | $wrapper.slots slots)
|
|---|
| 119 | (when slots-object
|
|---|
| 120 | (setf (gethash slots-object
|
|---|
| 121 | (wrapper-hash (or pheap (disk-cache-pheap disk-cache))))
|
|---|
| 122 | wrapper))
|
|---|
| 123 | wrapper))
|
|---|
| 124 |
|
|---|
| 125 | ; Access a (disk) class'es wrapper. Update it to agree with the
|
|---|
| 126 | ; class in memory, if there is one.
|
|---|
| 127 | ; Returns 2 value:
|
|---|
| 128 | ; 1) the (possibly new) wrapper
|
|---|
| 129 | ; 2) the in-memory class, or NIL if there isn't one.
|
|---|
| 130 | ; 3) the vector of slot names for the in-memory class, or NIL
|
|---|
| 131 | ; 4) true if the class'es was obsolete.
|
|---|
| 132 | (defun dc-update-class-wrapper (disk-cache class &optional pheap memory-class dont-update)
|
|---|
| 133 | (unless pheap (setq pheap (disk-cache-pheap disk-cache)))
|
|---|
| 134 | (if (eq memory-class :none)
|
|---|
| 135 | (setq memory-class nil)
|
|---|
| 136 | (let* ((name (pointer-load pheap (dc-%svref disk-cache class $class.name) :default disk-cache)))
|
|---|
| 137 | (setq memory-class (find-class name nil))))
|
|---|
| 138 | (with-databases-locked
|
|---|
| 139 | (let ((wrapper (dc-%svref disk-cache class $class.own-wrapper))
|
|---|
| 140 | (obsolete? nil)
|
|---|
| 141 | slot-names)
|
|---|
| 142 | (when memory-class
|
|---|
| 143 | (let ((wrapper-hash (wrapper-hash pheap)))
|
|---|
| 144 | (setq slot-names (wood-slot-names-vector
|
|---|
| 145 | (c2mop:class-prototype memory-class)))
|
|---|
| 146 | (unless (eql wrapper (gethash slot-names wrapper-hash))
|
|---|
| 147 | (let ((old-slot-names (pointer-load pheap (dc-%svref disk-cache wrapper $wrapper.slots)
|
|---|
| 148 | :default disk-cache)))
|
|---|
| 149 | (if (equalp old-slot-names slot-names)
|
|---|
| 150 | (setf (gethash slot-names wrapper-hash) wrapper)
|
|---|
| 151 | (progn
|
|---|
| 152 | (setq obsolete? t)
|
|---|
| 153 | (unless dont-update
|
|---|
| 154 | (setf wrapper (dc-make-class-wrapper
|
|---|
| 155 | disk-cache class
|
|---|
| 156 | (%p-store pheap slot-names) slot-names pheap)
|
|---|
| 157 | (dc-%svref disk-cache class $class.own-wrapper) wrapper))))))))
|
|---|
| 158 | (values wrapper memory-class slot-names obsolete?))))
|
|---|
| 159 |
|
|---|
| 160 |
|
|---|
| 161 | #+LispWorks
|
|---|
| 162 | (defparameter $wrapper-names-index
|
|---|
| 163 | (or (loop with wrapper = (progn
|
|---|
| 164 | (make-instance 'simple-error)
|
|---|
| 165 | (clos::class-wrapper (find-class 'simple-error)))
|
|---|
| 166 | for i in '(0 1 2 -1 -2 -3)
|
|---|
| 167 | as val = (%svref wrapper i)
|
|---|
| 168 | when (and (consp val)
|
|---|
| 169 | (consp (cdr val))
|
|---|
| 170 | (null (cddr val))
|
|---|
| 171 | (equal val '(conditions::format-string conditions::format-arguments)))
|
|---|
| 172 | return i)
|
|---|
| 173 | (error "Couldn't find wrapper names index")))
|
|---|
| 174 |
|
|---|
| 175 |
|
|---|
| 176 |
|
|---|
| 177 |
|
|---|
| 178 | ;; In lispworks, the names are in a list not a vector, but seems to work ok.
|
|---|
| 179 | (defun-inline %wrapper-instance-slots (wrapper)
|
|---|
| 180 | #+ccl (ccl::%wrapper-instance-slots wrapper)
|
|---|
| 181 | #-ccl (%svref wrapper $wrapper-names-index))
|
|---|
| 182 |
|
|---|
| 183 | (defun class-own-wrapper (class)
|
|---|
| 184 | #+LispWorks
|
|---|
| 185 | (clos::class-wrapper class)
|
|---|
| 186 | #+ccl
|
|---|
| 187 | (or (ccl:class-own-wrapper class)
|
|---|
| 188 | (progn (c2mop:class-prototype class)
|
|---|
| 189 | (ccl:class-own-wrapper class))))
|
|---|
| 190 |
|
|---|
| 191 | ; This knows internals of MCL's CLOS implementation
|
|---|
| 192 | (defun class-slots-vector (class)
|
|---|
| 193 | (%wrapper-instance-slots (class-own-wrapper class)))
|
|---|
| 194 |
|
|---|
| 195 | (defun dc-make-class-slots-vector (disk-cache class &optional
|
|---|
| 196 | (pheap (disk-cache-pheap disk-cache)))
|
|---|
| 197 | (%p-store pheap (wood-slot-names-vector (c2mop:class-prototype class))))
|
|---|
| 198 |
|
|---|
| 199 | (def-predicate classp (p disk-cache pointer)
|
|---|
| 200 | (dc-vector-subtype-p disk-cache pointer $v_class))
|
|---|
| 201 |
|
|---|
| 202 | (def-accessor class-name (p) (disk-cache pointer)
|
|---|
| 203 | (require-satisfies dc-classp disk-cache pointer)
|
|---|
| 204 | (dc-%svref disk-cache pointer $class.name))
|
|---|
| 205 |
|
|---|
| 206 | (defun (setf dc-class-name) (value disk-cache class &optional value-imm?)
|
|---|
| 207 | (require-satisfies dc-classp disk-cache class)
|
|---|
| 208 | (setf (dc-%svref disk-cache class $class.name value-imm?) value)
|
|---|
| 209 | (values value value-imm?))
|
|---|
| 210 |
|
|---|
| 211 | (def-accessor class-own-wrapper (p) (disk-cache pointer)
|
|---|
| 212 | (require-satisfies dc-classp disk-cache pointer)
|
|---|
| 213 | (dc-%svref disk-cache pointer $class.own-wrapper))
|
|---|
| 214 |
|
|---|
| 215 | (defun (setf dc-class-own-wrapper) (value disk-cache class &optional value-imm?)
|
|---|
| 216 | (require-satisfies dc-classp disk-cache class)
|
|---|
| 217 | (setf (dc-%svref disk-cache class $class.own-wrapper value-imm?) value)
|
|---|
| 218 | (values value value-imm?))
|
|---|
| 219 |
|
|---|
| 220 | (defmacro dc-wrapper-class (disk-cache wrapper)
|
|---|
| 221 | `(dc-uvref ,disk-cache ,wrapper $wrapper.class))
|
|---|
| 222 |
|
|---|
| 223 | (defmacro dc-wrapper-slots (disk-cache wrapper)
|
|---|
| 224 | `(dc-uvref ,disk-cache ,wrapper $wrapper.slots))
|
|---|
| 225 |
|
|---|
| 226 | (def-accessor class-instance-slot-names (p) (disk-cache pointer)
|
|---|
| 227 | (require-satisfies dc-classp disk-cache pointer)
|
|---|
| 228 | (dc-wrapper-slots disk-cache (dc-class-own-wrapper disk-cache pointer)))
|
|---|
| 229 |
|
|---|
| 230 | (defun class-instance-slots (class)
|
|---|
| 231 | "Return the slot-definition instances of CLASS with :instance allocation."
|
|---|
| 232 | (let ((slots (c2mop:class-slots class)))
|
|---|
| 233 | (dolist (slot slots slots)
|
|---|
| 234 | (unless (eq (c2mop:slot-definition-allocation slot) :instance)
|
|---|
| 235 | (return
|
|---|
| 236 | (remove-if-not
|
|---|
| 237 | (lambda (slotd)
|
|---|
| 238 | (eq (c2mop:slot-definition-allocation slotd) :instance))
|
|---|
| 239 | slots))))))
|
|---|
| 240 |
|
|---|
| 241 | #+ccl
|
|---|
| 242 | (defun class-instance-slot-names (class)
|
|---|
| 243 | "Return a vector of the names of the instance slots of CLASS."
|
|---|
| 244 | (let ((wrapper (class-own-wrapper class)))
|
|---|
| 245 | (unless wrapper
|
|---|
| 246 | (c2mop:class-prototype class)
|
|---|
| 247 | (setq wrapper (ccl:class-own-wrapper class))
|
|---|
| 248 | (unless wrapper (error "Can't find class-own-wrapper for ~s" class)))
|
|---|
| 249 | (ccl::%wrapper-instance-slots wrapper)))
|
|---|
| 250 |
|
|---|
| 251 | #-ccl
|
|---|
| 252 | (defun class-instance-slot-names (class)
|
|---|
| 253 | "Return a vector of the names of the instance slots of CLASS."
|
|---|
| 254 | (let ((slots (class-instance-slots class)))
|
|---|
| 255 | (map 'vector #'c2mop:slot-definition-name slots)))
|
|---|
| 256 |
|
|---|
| 257 | (defun p-instance-class (instance)
|
|---|
| 258 | (if (pptr-p instance)
|
|---|
| 259 | (let* ((pheap (pptr-pheap instance))
|
|---|
| 260 | (disk-cache (pheap-disk-cache pheap))
|
|---|
| 261 | (pointer (pptr-pointer instance)))
|
|---|
| 262 | (pointer-load
|
|---|
| 263 | pheap
|
|---|
| 264 | (dc-wrapper-class disk-cache (dc-instance-class-wrapper disk-cache pointer))))
|
|---|
| 265 | (class-of instance)))
|
|---|
| 266 |
|
|---|
| 267 | (defmethod %p-store-object (pheap (object standard-class) descend)
|
|---|
| 268 | (let* ((disk-cache (pheap-disk-cache pheap))
|
|---|
| 269 | (descend (eq descend t))
|
|---|
| 270 | name imm?
|
|---|
| 271 | (address (maybe-cached-address pheap object
|
|---|
| 272 | (multiple-value-setq (name imm?)
|
|---|
| 273 | (%p-store pheap (class-name object)))
|
|---|
| 274 | (or (dc-find-class disk-cache name imm? nil)
|
|---|
| 275 | (progn
|
|---|
| 276 | (setq descend nil)
|
|---|
| 277 | (dc-make-class disk-cache
|
|---|
| 278 | name
|
|---|
| 279 | (dc-make-class-slots-vector
|
|---|
| 280 | disk-cache object pheap)
|
|---|
| 281 | imm?))))))
|
|---|
| 282 | (when descend
|
|---|
| 283 | (unless name
|
|---|
| 284 | (multiple-value-setq (name imm?) (%p-store pheap (class-name object))))
|
|---|
| 285 | (setf (dc-class-name disk-cache address imm?) name)
|
|---|
| 286 | (setf (dc-wrapper-slots disk-cache (dc-class-own-wrapper disk-cache address))
|
|---|
| 287 | (dc-make-class-slots-vector disk-cache object pheap)))
|
|---|
| 288 | address))
|
|---|
| 289 |
|
|---|
| 290 | (defun p-load-class (pheap disk-cache pointer depth subtype)
|
|---|
| 291 | (declare (ignore depth subtype))
|
|---|
| 292 | (maybe-cached-value pheap pointer
|
|---|
| 293 | (multiple-value-bind (name-pointer imm?) (dc-class-name disk-cache pointer)
|
|---|
| 294 | (let ((name (dc-pointer-load disk-cache name-pointer imm? pheap)))
|
|---|
| 295 | (or (find-class name nil)
|
|---|
| 296 | (let ((slots (pointer-load pheap
|
|---|
| 297 | (dc-wrapper-slots
|
|---|
| 298 | disk-cache
|
|---|
| 299 | (dc-class-own-wrapper disk-cache pointer))
|
|---|
| 300 | :default
|
|---|
| 301 | disk-cache)))
|
|---|
| 302 | ;; this is wrong - lose initargs, initforms
|
|---|
| 303 | (eval `(defclass ,name () ,(coerce slots 'list)))))))))
|
|---|
| 304 |
|
|---|
| 305 | (defmethod p-allocate-instance (pheap (class symbol))
|
|---|
| 306 | (p-allocate-instance pheap (or (p-find-class pheap class nil)
|
|---|
| 307 | (p-store pheap (find-class class)))))
|
|---|
| 308 |
|
|---|
| 309 | (defmethod p-allocate-instance (pheap (class standard-class))
|
|---|
| 310 | (p-%allocate-instance pheap (p-store pheap class) class))
|
|---|
| 311 |
|
|---|
| 312 | (defmethod p-allocate-instance (pheap (class pptr))
|
|---|
| 313 | (require-satisfies p-classp class)
|
|---|
| 314 | (p-%allocate-instance pheap class nil))
|
|---|
| 315 |
|
|---|
| 316 | (defun p-%allocate-instance (pheap class memory-class)
|
|---|
| 317 | (pptr pheap (dc-%allocate-instance (pheap-disk-cache pheap) (pptr-pointer class) memory-class)))
|
|---|
| 318 |
|
|---|
| 319 | (defun dc-%allocate-instance (disk-cache class &optional memory-class)
|
|---|
| 320 | (let* ((wrapper (dc-update-class-wrapper disk-cache class nil memory-class))
|
|---|
| 321 | (slots (dc-make-vector
|
|---|
| 322 | disk-cache
|
|---|
| 323 | (dc-length disk-cache (dc-wrapper-slots disk-cache wrapper))
|
|---|
| 324 | nil (%unbound-marker) t))
|
|---|
| 325 | (res (dc-make-uvector disk-cache $instance-size $v_instance)))
|
|---|
| 326 | (dc-%svfill disk-cache res
|
|---|
| 327 | $instance.wrapper wrapper
|
|---|
| 328 | $instance.slots slots)
|
|---|
| 329 | res))
|
|---|
| 330 |
|
|---|
| 331 | (def-accessor instance-class-wrapper (p) (disk-cache pointer)
|
|---|
| 332 | (require-satisfies dc-standard-instance-p disk-cache pointer)
|
|---|
| 333 | (dc-%svref disk-cache pointer $instance.wrapper))
|
|---|
| 334 |
|
|---|
| 335 | ; This is the wrong name. Check the MOP
|
|---|
| 336 | (def-accessor instance-access (p index) (disk-cache pointer)
|
|---|
| 337 | (require-satisfies dc-standard-instance-p disk-cache pointer)
|
|---|
| 338 | (dc-uvref disk-cache (dc-%svref disk-cache pointer $instance.slots) index))
|
|---|
| 339 |
|
|---|
| 340 | (defun (setf p-instance-access) (value p index)
|
|---|
| 341 | (setq index (require-type index 'fixnum))
|
|---|
| 342 | (if (pptr-p p)
|
|---|
| 343 | (let ((pheap (pptr-pheap p)))
|
|---|
| 344 | (multiple-value-bind (v imm?) (%p-store pheap value)
|
|---|
| 345 | (setf (dc-instance-access
|
|---|
| 346 | (pheap-disk-cache pheap) (pptr-pointer p) index imm?)
|
|---|
| 347 | v)
|
|---|
| 348 | (if imm? v (pptr pheap v))))
|
|---|
| 349 | (error "~s is defined only for Wood instances" '(setf p-instance-access))))
|
|---|
| 350 |
|
|---|
| 351 | (defun (setf dc-instance-access) (value disk-cache pointer index value-imm?)
|
|---|
| 352 | (require-satisfies dc-standard-instance-p disk-cache pointer)
|
|---|
| 353 | (setf (dc-uvref disk-cache (dc-%svref disk-cache pointer $instance.slots)
|
|---|
| 354 | index value-imm?)
|
|---|
| 355 | value))
|
|---|
| 356 |
|
|---|
| 357 | (defun instance-access (thing index)
|
|---|
| 358 | (declare (ignore thing index))
|
|---|
| 359 | (error "~s is defined only for Wood instances" 'instance-access))
|
|---|
| 360 |
|
|---|
| 361 | ; Instance is an on-disk address.
|
|---|
| 362 | ; class is an in-memory class or NIL.
|
|---|
| 363 | ; Returns three values:
|
|---|
| 364 | ; 1) The slots vector on disk
|
|---|
| 365 | ; 2) The slot names vector in memory.
|
|---|
| 366 | ; 3) slot-names vector if the instance was obsolete.
|
|---|
| 367 | ; This will be different from the second value if the
|
|---|
| 368 | ; dont-update arg is true.
|
|---|
| 369 | ;
|
|---|
| 370 | ; This is hairy because it has to deal with a lot of possibilities:
|
|---|
| 371 | ;
|
|---|
| 372 | ; 1) Class exists in memory, but hasn't been associated with PHEAP yet.
|
|---|
| 373 | ; 2) Class exists in memeory and has been associated with PHEAP.
|
|---|
| 374 | ; 3) Class does not exist in memory.
|
|---|
| 375 | ; 4) 1 or 2 and the class has been redefined since the instance was stored in the PHEAP.
|
|---|
| 376 | (defun dc-updated-instance-slots (disk-cache instance memory-class pheap &optional
|
|---|
| 377 | dont-update)
|
|---|
| 378 | ;(assert (dc-vector-subtype-p disk-cache instance $v_instance))
|
|---|
| 379 | (with-databases-locked
|
|---|
| 380 | (let ((old-wrapper (dc-%svref disk-cache instance $instance.wrapper))
|
|---|
| 381 | (instance-slots (dc-%svref disk-cache instance $instance.slots))
|
|---|
| 382 | class wrapper slot-names old-slot-names obsolete?)
|
|---|
| 383 | (if memory-class
|
|---|
| 384 | (progn
|
|---|
| 385 | (setq slot-names (wood-slot-names-vector
|
|---|
| 386 | (c2mop:class-prototype memory-class)))
|
|---|
| 387 | (setq wrapper (gethash slot-names (wrapper-hash pheap))))
|
|---|
| 388 | (progn
|
|---|
| 389 | (setq class (dc-%svref disk-cache old-wrapper $wrapper.class))
|
|---|
| 390 | (multiple-value-setq (wrapper memory-class slot-names obsolete?)
|
|---|
| 391 | (dc-update-class-wrapper disk-cache class pheap nil dont-update))
|
|---|
| 392 | (unless slot-names
|
|---|
| 393 | (setq slot-names (pointer-load pheap (dc-%svref disk-cache old-wrapper $wrapper.slots)
|
|---|
| 394 | :default disk-cache)
|
|---|
| 395 | wrapper old-wrapper))))
|
|---|
| 396 | (if (if (and wrapper (not obsolete?))
|
|---|
| 397 | (eql wrapper old-wrapper)
|
|---|
| 398 | (when (equalp slot-names
|
|---|
| 399 | (setq old-slot-names
|
|---|
| 400 | (pointer-load pheap (dc-%svref disk-cache old-wrapper $wrapper.slots)
|
|---|
| 401 | :default disk-cache)))
|
|---|
| 402 | (setq wrapper (setf (gethash slot-names (wrapper-hash pheap)) old-wrapper))))
|
|---|
| 403 | ; Wrapper is current
|
|---|
| 404 | (values instance-slots slot-names)
|
|---|
| 405 | ; Wrapper needs updating.
|
|---|
| 406 | (progn
|
|---|
| 407 | (unless old-slot-names
|
|---|
| 408 | (setq old-slot-names (pointer-load
|
|---|
| 409 | pheap
|
|---|
| 410 | (dc-%svref disk-cache old-wrapper $wrapper.slots)
|
|---|
| 411 | :default disk-cache)))
|
|---|
| 412 | (if dont-update
|
|---|
| 413 | (values instance-slots old-slot-names slot-names)
|
|---|
| 414 | (let* ((slot-count (length slot-names))
|
|---|
| 415 | (slot-values (make-array slot-count))
|
|---|
| 416 | (slot-imms (make-array slot-count)))
|
|---|
| 417 | (declare (fixnum slot-count))
|
|---|
| 418 | ;(dynamic-extent slot-values slot-imms))
|
|---|
| 419 | (unless wrapper
|
|---|
| 420 | (let ((class (dc-%svref disk-cache old-wrapper $wrapper.class)))
|
|---|
| 421 | (setq wrapper (dc-update-class-wrapper disk-cache class pheap memory-class dont-update))))
|
|---|
| 422 | (dotimes (i slot-count)
|
|---|
| 423 | (let ((index (position (svref slot-names i) old-slot-names :test 'eq)))
|
|---|
| 424 | (if index
|
|---|
| 425 | (multiple-value-bind (value imm?) (dc-uvref disk-cache instance-slots index)
|
|---|
| 426 | (setf (svref slot-values i) value
|
|---|
| 427 | (svref slot-imms i) imm?))
|
|---|
| 428 | (setf (svref slot-values i) (%unbound-marker)
|
|---|
| 429 | (svref slot-imms i) t))))
|
|---|
| 430 | (let* ((old-instance-length (dc-length disk-cache instance-slots))
|
|---|
| 431 | (new-instance-slots (if (>= old-instance-length slot-count)
|
|---|
| 432 | (let ((index slot-count))
|
|---|
| 433 | (dotimes (i (- old-instance-length slot-count))
|
|---|
| 434 | (setf (dc-uvref disk-cache instance-slots index t)
|
|---|
| 435 | (%unbound-marker)))
|
|---|
| 436 | instance-slots)
|
|---|
| 437 | (dc-make-vector
|
|---|
| 438 | disk-cache slot-count
|
|---|
| 439 | (dc-area disk-cache instance-slots)
|
|---|
| 440 | (%unbound-marker) t))))
|
|---|
| 441 | (dotimes (i slot-count)
|
|---|
| 442 | (let ((value (svref slot-values i))
|
|---|
| 443 | (imm? (svref slot-imms i)))
|
|---|
| 444 | (unless (and imm? (eq value (%unbound-marker)))
|
|---|
| 445 | (setf (dc-%svref disk-cache new-instance-slots i imm?) value))))
|
|---|
| 446 | (dc-shared-initialize disk-cache pheap slot-values new-instance-slots memory-class)
|
|---|
| 447 | (setf (dc-%svref disk-cache instance $instance.wrapper) wrapper
|
|---|
| 448 | (dc-%svref disk-cache instance $instance.slots) new-instance-slots)
|
|---|
| 449 | (values new-instance-slots slot-names)))))))))
|
|---|
| 450 |
|
|---|
| 451 |
|
|---|
| 452 | ;;; *** TODO: Need Lispworks version.
|
|---|
| 453 | #+CCL
|
|---|
| 454 | (defun dc-shared-initialize (disk-cache pheap slot-values new-instance-slots class &optional (slot-names t))
|
|---|
| 455 | ;; I don't know how to find all this stuff in the disk version - I don't think it's there.
|
|---|
| 456 | ;; copied from %shared-initialize
|
|---|
| 457 | (when class
|
|---|
| 458 | (loop :for slotd :in (class-instance-slots class)
|
|---|
| 459 | :for index :from 0
|
|---|
| 460 | :for initform = (c2mop:slot-definition-initform slotd) :do
|
|---|
| 461 | (when (and initform
|
|---|
| 462 | (eq (elt slot-values index) (ccl::%unbound-marker))
|
|---|
| 463 | (or (eq slot-names t)
|
|---|
| 464 | (memq (c2mop:slot-definition-name slotd) slot-names)))
|
|---|
| 465 | (let ((value
|
|---|
| 466 | (if (listp initform) ;(value)
|
|---|
| 467 | (car initform)
|
|---|
| 468 | (funcall initform))))
|
|---|
| 469 | (multiple-value-bind (v imm?) (%p-store pheap value)
|
|---|
| 470 | (setf (dc-%svref disk-cache new-instance-slots index imm?) v)))))))
|
|---|
| 471 |
|
|---|
| 472 | (def-predicate standard-instance-p (p disk-cache pointer)
|
|---|
| 473 | (and (dc-uvectorp disk-cache pointer)
|
|---|
| 474 | (dc-vector-subtype-p disk-cache pointer $v_instance)))
|
|---|
| 475 |
|
|---|
| 476 | (def-accessor slot-value (p slot-name) (disk-cache pointer)
|
|---|
| 477 | (require-satisfies dc-standard-instance-p disk-cache pointer)
|
|---|
| 478 | (multiple-value-bind (value imm?)
|
|---|
| 479 | (dc-%slot-value disk-cache pointer slot-name)
|
|---|
| 480 | (if (and imm? (eq value (%unbound-marker)))
|
|---|
| 481 | (dc-slot-unbound disk-cache pointer slot-name)
|
|---|
| 482 | (values value imm?))))
|
|---|
| 483 |
|
|---|
| 484 | (defun dc-%slot-value (disk-cache pointer slot-name)
|
|---|
| 485 | (multiple-value-bind (slots index)
|
|---|
| 486 | (dc-%slot-vector-and-index disk-cache pointer slot-name t)
|
|---|
| 487 | (if slots
|
|---|
| 488 | (if (eq slots (%unbound-marker))
|
|---|
| 489 | (values slots t)
|
|---|
| 490 | (dc-%svref disk-cache slots index))
|
|---|
| 491 | (dc-slot-missing disk-cache pointer slot-name 'slot-value))))
|
|---|
| 492 |
|
|---|
| 493 | (defun dc-slot-missing (disk-cache pointer slot-name operation &optional new-value)
|
|---|
| 494 | (declare (ignore operation new-value))
|
|---|
| 495 | (error "~s has no slot named ~s"
|
|---|
| 496 | (pptr (disk-cache-pheap disk-cache) pointer) slot-name))
|
|---|
| 497 |
|
|---|
| 498 | (defun dc-slot-unbound (disk-cache pointer slot-name)
|
|---|
| 499 | (error "Slot ~s is unbound in ~s"
|
|---|
| 500 | slot-name (pptr (disk-cache-pheap disk-cache) pointer)))
|
|---|
| 501 |
|
|---|
| 502 | ; Returns two values:
|
|---|
| 503 | ; 1) disk-cache vector of slots
|
|---|
| 504 | ; 2) index in the vector
|
|---|
| 505 | ;
|
|---|
| 506 | ; If the slot doesn't exist, returns NIL.
|
|---|
| 507 | ; If the slot exists, but only after the instance is updated and dont-update
|
|---|
| 508 | ; is true, returns (%unbound-marker).
|
|---|
| 509 | (defun dc-%slot-vector-and-index (disk-cache pointer slot-name &optional dont-update)
|
|---|
| 510 | (let* ((pheap (disk-cache-pheap disk-cache))
|
|---|
| 511 | (wrapper (dc-%svref disk-cache pointer $instance.wrapper))
|
|---|
| 512 | (memory-class (pointer-load
|
|---|
| 513 | pheap
|
|---|
| 514 | (dc-%svref disk-cache
|
|---|
| 515 | (dc-%svref disk-cache wrapper $wrapper.class)
|
|---|
| 516 | $class.name)
|
|---|
| 517 | :default disk-cache)))
|
|---|
| 518 | (multiple-value-bind (slots slot-names real-slot-names)
|
|---|
| 519 | (dc-updated-instance-slots
|
|---|
| 520 | disk-cache pointer
|
|---|
| 521 | (find-class
|
|---|
| 522 | memory-class
|
|---|
| 523 | nil)
|
|---|
| 524 | pheap
|
|---|
| 525 | dont-update)
|
|---|
| 526 | (let ((index (position slot-name slot-names :test 'eq))
|
|---|
| 527 | (real-index (and dont-update
|
|---|
| 528 | real-slot-names
|
|---|
| 529 | (position slot-name real-slot-names))))
|
|---|
| 530 | (if (and index (or (not dont-update) (not real-slot-names) real-index))
|
|---|
| 531 | (values slots index)
|
|---|
| 532 | (if real-index
|
|---|
| 533 | (%unbound-marker)
|
|---|
| 534 | nil))))))
|
|---|
| 535 |
|
|---|
| 536 | (defun (setf p-slot-value) (value p slot-name)
|
|---|
| 537 | (if (pptr-p p)
|
|---|
| 538 | (let* ((pheap (pptr-pheap p))
|
|---|
| 539 | (disk-cache (pheap-disk-cache pheap))
|
|---|
| 540 | (pointer (pptr-pointer p)))
|
|---|
| 541 | (multiple-value-bind (slots index)
|
|---|
| 542 | (dc-%slot-vector-and-index disk-cache pointer slot-name)
|
|---|
| 543 | (unless slots
|
|---|
| 544 | (dc-slot-missing disk-cache pointer slot-name '(setf p-slot-value)))
|
|---|
| 545 | (multiple-value-bind (v imm?) (%p-store pheap value)
|
|---|
| 546 | (setf (dc-%svref disk-cache slots index imm?) v)
|
|---|
| 547 | (if imm?
|
|---|
| 548 | v
|
|---|
| 549 | (pptr pheap v)))))
|
|---|
| 550 | (setf (slot-value p slot-name) value)))
|
|---|
| 551 |
|
|---|
| 552 | (def-accessor slot-boundp (p slot-name) (disk-cache pointer)
|
|---|
| 553 | (values (not (eq (dc-%slot-value disk-cache pointer slot-name)
|
|---|
| 554 | (%unbound-marker)))
|
|---|
| 555 | t))
|
|---|
| 556 |
|
|---|
| 557 | (def-accessor slot-makunbound (p slot-name) (disk-cache pointer)
|
|---|
| 558 | (multiple-value-bind (slots index)
|
|---|
| 559 | (dc-%slot-vector-and-index disk-cache pointer slot-name t)
|
|---|
| 560 | (unless slots
|
|---|
| 561 | (dc-slot-missing disk-cache pointer slot-name 'p-slot-makunbound))
|
|---|
| 562 | (unless (eq slots (%unbound-marker))
|
|---|
| 563 | (setf (dc-%svref disk-cache slots index t) (%unbound-marker)))
|
|---|
| 564 | pointer))
|
|---|
| 565 |
|
|---|
| 566 | #+CCL
|
|---|
| 567 | (defmethod %p-store-object (pheap (object ccl::funcallable-standard-object) descend)
|
|---|
| 568 | (declare (ignore pheap descend))
|
|---|
| 569 | (error "Can't save generic functions yet. Maybe never."))
|
|---|
| 570 |
|
|---|
| 571 | ; this will do the wrong thing if anyone redefines the class
|
|---|
| 572 | ; of the object while it is running.
|
|---|
| 573 | (defmethod %p-store-object (pheap (object standard-object) descend)
|
|---|
| 574 | (let* ((class (class-of object))
|
|---|
| 575 | (consed? nil))
|
|---|
| 576 | (%p-store-object-body (pheap object descend disk-cache address)
|
|---|
| 577 | (progn
|
|---|
| 578 | (setq consed? t)
|
|---|
| 579 | (dc-%allocate-instance disk-cache (%p-store pheap class)))
|
|---|
| 580 | (progn
|
|---|
| 581 | (unless consed?
|
|---|
| 582 | ; Ensure that p-make-load-function-using-pheap method didn't change too much to handle
|
|---|
| 583 | (require-satisfies dc-vector-subtype-p disk-cache address $v_instance))
|
|---|
| 584 | (multiple-value-bind (slots slot-names)
|
|---|
| 585 | (dc-updated-instance-slots disk-cache address class pheap)
|
|---|
| 586 | (dotimes (i (length slot-names))
|
|---|
| 587 | (let ((slot-name (elt slot-names i)))
|
|---|
| 588 | (multiple-value-bind (value imm?)
|
|---|
| 589 | (if (slot-boundp object slot-name)
|
|---|
| 590 | (%p-store pheap (wood-slot-value object slot-name) descend)
|
|---|
| 591 | (values (%unbound-marker) t))
|
|---|
| 592 | (setf (dc-uvref disk-cache slots i imm?) value)))))))))
|
|---|
| 593 |
|
|---|
| 594 | ; New functions
|
|---|
| 595 | ; Allows a p-make-load-function-using-pheap method to save slots for an object
|
|---|
| 596 | ; and do something else as well.
|
|---|
| 597 |
|
|---|
| 598 | (defmethod instance-slot-names ((instance structure-object))
|
|---|
| 599 | #+ccl
|
|---|
| 600 | (let ((sd (gethash (car (%svref instance 0)) ccl::%defstructs%))
|
|---|
| 601 | (res nil))
|
|---|
| 602 | (dolist (slot (%svref sd 1)) ;; sd-slots
|
|---|
| 603 | (let ((name (car slot)))
|
|---|
| 604 | (when (symbolp name)
|
|---|
| 605 | (push name res))))
|
|---|
| 606 | (nreverse res))
|
|---|
| 607 | #+LispWorks
|
|---|
| 608 | (structure:structure-class-slot-names (class-of instance)))
|
|---|
| 609 |
|
|---|
| 610 | (defmethod instance-slot-names ((instance standard-object))
|
|---|
| 611 | (mapcar #'c2mop:slot-definition-name (class-instance-slots (class-of instance))))
|
|---|
| 612 |
|
|---|
| 613 | (defmethod p-make-load-function-saving-slots ((object standard-object) &optional (slots nil slots-p))
|
|---|
| 614 | (%p-make-load-function-saving-slots object slots slots-p))
|
|---|
| 615 |
|
|---|
| 616 | (defmethod p-make-load-function-saving-slots ((object structure-object) &optional (slots nil slots-p))
|
|---|
| 617 | (%p-make-load-function-saving-slots object slots slots-p))
|
|---|
| 618 |
|
|---|
| 619 | (defun %p-make-load-function-saving-slots (object slots slots-p)
|
|---|
| 620 | (let* ((slot-names (if slots-p slots (instance-slot-names object)))
|
|---|
| 621 | (mapper #'(lambda (slot)
|
|---|
| 622 | (if (slot-boundp object slot)
|
|---|
| 623 | (slot-value object slot)
|
|---|
| 624 | (%unbound-marker))))
|
|---|
| 625 | (slot-values (mapcar mapper slot-names)))
|
|---|
| 626 | (declare (dynamic-extent mapper))
|
|---|
| 627 | (values `(allocate-instance-of-class ,(class-name (class-of object)))
|
|---|
| 628 | (when slot-names
|
|---|
| 629 | `(%set-slot-values ,object ,slot-names ,slot-values)))))
|
|---|
| 630 |
|
|---|
| 631 | (defun allocate-instance-of-class (class-name)
|
|---|
| 632 | (allocate-instance (find-class class-name)))
|
|---|
| 633 |
|
|---|
| 634 | (defun progn-load-functions (&rest load-functions)
|
|---|
| 635 | (declare (dynamic-extent load-functions))
|
|---|
| 636 | (when load-functions
|
|---|
| 637 | (do* ((this load-functions next)
|
|---|
| 638 | (next (cdr this) (cdr this)))
|
|---|
| 639 | ((null next) (apply 'funcall (car this)))
|
|---|
| 640 | (apply 'funcall (car this)))))
|
|---|
| 641 |
|
|---|
| 642 | (defun progn-init-functions (object &rest init-functions)
|
|---|
| 643 | (declare (dynamic-extent init-functions))
|
|---|
| 644 | (dolist (f.args init-functions)
|
|---|
| 645 | (apply (car f.args) object (cdr f.args))))
|
|---|
| 646 |
|
|---|
| 647 | (defun p-load-instance (pheap disk-cache pointer depth subtype)
|
|---|
| 648 | (declare (ignore subtype))
|
|---|
| 649 | (let* ((cached? t)
|
|---|
| 650 | class
|
|---|
| 651 | (instance (maybe-cached-value pheap pointer
|
|---|
| 652 | (setq cached? nil)
|
|---|
| 653 | (if (null depth)
|
|---|
| 654 | (return-from p-load-instance (pptr pheap pointer)))
|
|---|
| 655 | (setq class (pointer-load pheap
|
|---|
| 656 | (dc-%svref disk-cache
|
|---|
| 657 | (dc-instance-class-wrapper
|
|---|
| 658 | disk-cache pointer)
|
|---|
| 659 | $wrapper.class)
|
|---|
| 660 | :default
|
|---|
| 661 | disk-cache))
|
|---|
| 662 | (allocate-instance class))))
|
|---|
| 663 | (when (or (not cached?)
|
|---|
| 664 | (and (eq depth t)
|
|---|
| 665 | (let ((p-load-hash (p-load-hash pheap)))
|
|---|
| 666 | (unless (gethash instance p-load-hash)
|
|---|
| 667 | (setf (gethash instance p-load-hash) instance)))))
|
|---|
| 668 | (let ((next-level-depth (cond ((or (eq depth :single) (fixnump depth)) nil)
|
|---|
| 669 | (t depth)))
|
|---|
| 670 | (disk-resident-slots (wood-disk-resident-slot-names instance)))
|
|---|
| 671 | (multiple-value-bind (slot-vector slot-names real-slot-names)
|
|---|
| 672 | (dc-updated-instance-slots
|
|---|
| 673 | disk-cache pointer class pheap t)
|
|---|
| 674 | (dotimes (i (length slot-names))
|
|---|
| 675 | (let ((slot-name (elt slot-names i)))
|
|---|
| 676 | (when (or (null real-slot-names) (position slot-name real-slot-names))
|
|---|
| 677 | (multiple-value-bind (pointer immediate?)
|
|---|
| 678 | (dc-%svref disk-cache slot-vector i)
|
|---|
| 679 | (if immediate?
|
|---|
| 680 | (if (eq pointer (%unbound-marker))
|
|---|
| 681 | (slot-makunbound instance slot-name)
|
|---|
| 682 | (setf (wood-slot-value instance slot-name) pointer))
|
|---|
| 683 | (setf (wood-slot-value instance slot-name)
|
|---|
| 684 | (if (member slot-name disk-resident-slots :test #'eq)
|
|---|
| 685 | (pptr pheap pointer)
|
|---|
| 686 | (pointer-load pheap pointer next-level-depth disk-cache))))))))
|
|---|
| 687 | (when real-slot-names
|
|---|
| 688 | (let (new-slot-names)
|
|---|
| 689 | (dotimes (i (length real-slot-names))
|
|---|
| 690 | (let ((slot-name (svref real-slot-names i)))
|
|---|
| 691 | (unless (position slot-name slot-names)
|
|---|
| 692 | (push slot-name new-slot-names))))
|
|---|
| 693 | (when new-slot-names
|
|---|
| 694 | (shared-initialize instance new-slot-names))))))
|
|---|
| 695 | (unless cached?
|
|---|
| 696 | (initialize-persistent-instance instance)))
|
|---|
| 697 | instance))
|
|---|
| 698 |
|
|---|
| 699 |
|
|---|
| 700 | ; These methods allow users to specialize the way that CLOS instances are saved.
|
|---|
| 701 |
|
|---|
| 702 | ; Return a vector of the names of the slots to be saved for an instance.
|
|---|
| 703 | ; The instance saving code assumes that multiple calls to this
|
|---|
| 704 | ; method will return the same (EQ) vector unless the class has been redefined.
|
|---|
| 705 | ; May be called with a CLASS-PROTOTYPE, so don't expect any of the slots
|
|---|
| 706 | ; to contain useful information.
|
|---|
| 707 | (defmethod wood-slot-names-vector ((object standard-object))
|
|---|
| 708 | (class-slots-vector (class-of object)))
|
|---|
| 709 |
|
|---|
| 710 | ; These allow specialization of slot-value.
|
|---|
| 711 | ; Some slots may want to be saved in a different format,
|
|---|
| 712 | ; or interned on the way back in.
|
|---|
| 713 | (defmethod wood-slot-value ((object standard-object) slot-name)
|
|---|
| 714 | (slot-value object slot-name))
|
|---|
| 715 |
|
|---|
| 716 | (defmethod (setf wood-slot-value) (value (object standard-object) slot-name)
|
|---|
| 717 | (setf (slot-value object slot-name) value))
|
|---|
| 718 |
|
|---|
| 719 |
|
|---|
| 720 | ; This generic function is called on a newly loaded CLOS instance
|
|---|
| 721 | (defmethod initialize-persistent-instance (instance)
|
|---|
| 722 | (declare (ignore instance))
|
|---|
| 723 | nil)
|
|---|
| 724 |
|
|---|
| 725 |
|
|---|
| 726 | ; This generic function is called when an instance is p-load'ed to
|
|---|
| 727 | ; determine which slots should remain disk resident and have pptr's
|
|---|
| 728 | ; put in the instance.
|
|---|
| 729 | (defgeneric wood-disk-resident-slot-names (instance)
|
|---|
| 730 | (:method ((instance t))
|
|---|
| 731 | nil))
|
|---|
| 732 |
|
|---|
| 733 | (declaim (inline default-slot-value-processor))
|
|---|
| 734 |
|
|---|
| 735 | (defun default-slot-value-processor (instance slot-name value sticky p-loader pass-instance-to-p-loader)
|
|---|
| 736 | (if (pptr-p value)
|
|---|
| 737 | (let ((loaded-value
|
|---|
| 738 | (if pass-instance-to-p-loader
|
|---|
| 739 | (funcall p-loader instance value)
|
|---|
| 740 | (funcall p-loader value))))
|
|---|
| 741 | (when sticky
|
|---|
| 742 | (setf (slot-value instance slot-name) loaded-value))
|
|---|
| 743 | loaded-value)
|
|---|
| 744 | value))
|
|---|
| 745 |
|
|---|
| 746 | ; An easy way to define a wood-disk-resident-slot-names method
|
|---|
| 747 | ; and some :around methods on slot accessors to swap the slots
|
|---|
| 748 | ; in on demand.
|
|---|
| 749 | (defmacro define-disk-resident-slots ((class-name
|
|---|
| 750 | &key sticky
|
|---|
| 751 | (p-loader ''p-load)
|
|---|
| 752 | pass-instance-to-p-loader
|
|---|
| 753 | (slot-value-processor '#'default-slot-value-processor))
|
|---|
| 754 | &body slots-and-accessors)
|
|---|
| 755 | (let* ((sticky-p #'(lambda (slot-and-accessor)
|
|---|
| 756 | (let ((cell (and (listp slot-and-accessor) (cddr slot-and-accessor))))
|
|---|
| 757 | (if cell (car cell) sticky))))
|
|---|
| 758 | (slots (mapcar #'(lambda (x) (if (listp x) (first x) x)) slots-and-accessors))
|
|---|
| 759 | (accessors (mapcar #'(lambda (x) (if (listp x) (second x) x)) slots-and-accessors))
|
|---|
| 760 | (stickies (mapcar sticky-p slots-and-accessors))
|
|---|
| 761 | (class (find-class class-name nil))
|
|---|
| 762 | (instance (make-symbol (symbol-name class-name))))
|
|---|
| 763 | (declare (dynamic-extent sticky-p))
|
|---|
| 764 | (flet ((require-symbol (x) (require-type x 'symbol)))
|
|---|
| 765 | (mapc #'require-symbol slots)
|
|---|
| 766 | (mapc #'require-symbol accessors))
|
|---|
| 767 | (when class
|
|---|
| 768 | (let* ((class-slots (mapcar #'c2mop:slot-definition-name
|
|---|
| 769 | (c2mop:class-slots class))))
|
|---|
| 770 | (flet ((require-slot (slot)
|
|---|
| 771 | (unless (member slot class-slots :test 'eq)
|
|---|
| 772 | (warn "~s is not an instance slot of ~s" slot class))))
|
|---|
| 773 | (declare (dynamic-extent #'require-slot))
|
|---|
| 774 | (mapc #'require-slot slots))))
|
|---|
| 775 | `(progn
|
|---|
| 776 | ,@(loop for slot in slots
|
|---|
| 777 | for accessor in accessors
|
|---|
| 778 | for sticky in stickies
|
|---|
| 779 | collect
|
|---|
| 780 | `(defmethod ,accessor :around ((,instance ,class-name))
|
|---|
| 781 | (funcall ,slot-value-processor
|
|---|
| 782 | ,instance
|
|---|
| 783 | ',slot
|
|---|
| 784 | (call-next-method)
|
|---|
| 785 | ,(not (null sticky))
|
|---|
| 786 | ,p-loader
|
|---|
| 787 | ,(not (null pass-instance-to-p-loader)))))
|
|---|
| 788 | (defmethod wood-disk-resident-slot-names ((,class-name ,class-name))
|
|---|
| 789 | ',slots)
|
|---|
| 790 | (record-source-file ',class-name :disk-resident-slots)
|
|---|
| 791 | ',class-name)))
|
|---|
| 792 |
|
|---|
| 793 |
|
|---|
| 794 |
|
|---|
| 795 | ;;; 1 3/10/94 bill 1.8d247
|
|---|
| 796 | ;;; 2 7/26/94 Derek 1.9d027
|
|---|
| 797 | ;;; 3 10/04/94 bill 1.9d071
|
|---|
| 798 | ;;; 4 11/01/94 Derek 1.9d085 Bill's Saving Library Task
|
|---|
| 799 | ;;; 5 11/03/94 Moon 1.9d086
|
|---|
| 800 | ;;; 6 11/05/94 kab 1.9d087
|
|---|
| 801 | ;;; 2 3/23/95 bill 1.11d010
|
|---|
![(please configure the [header_logo] section in trac.ini)](/wood/chrome/site/your_project_logo.png){kind=logo}
