Changeset 4287
- Timestamp:
- 10/10/03 17:02:46 (19 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/j/src/org/armedbear/lisp/defclass.lisp
r4279 r4287 2 2 ;;; 3 3 ;;; Copyright (C) 2003 Peter Graves 4 ;;; $Id: defclass.lisp,v 1. 2 2003-10-10 14:15:43piso Exp $4 ;;; $Id: defclass.lisp,v 1.3 2003-10-10 17:02:46 piso Exp $ 5 5 ;;; 6 6 ;;; This program is free software; you can redistribute it and/or … … 50 50 51 51 (defsetf class-name %set-class-name) 52 (defsetf class-direct-superclasses %set-class-direct-superclasses) 53 (defsetf class-direct-subclasses %set-class-direct-subclasses) 54 (defsetf class-direct-methods %set-class-direct-methods) 55 (defsetf class-direct-slots %set-class-direct-slots) 56 (defsetf class-precedence-list %set-class-precedence-list) 57 (defsetf class-slots %set-class-slots) 52 58 53 59 (defun canonicalize-direct-slots (direct-slots) … … 186 192 (setf (getf* slot ':allocation) new-value)) 187 193 194 ;;; finalize-inheritance 195 196 (defun std-finalize-inheritance (class) 197 (setf (class-precedence-list class) 198 (funcall (if (eq (class-of class) the-class-standard-class) 199 #'std-compute-class-precedence-list 200 #'compute-class-precedence-list) 201 class)) 202 (setf (class-slots class) 203 (funcall (if (eq (class-of class) the-class-standard-class) 204 #'std-compute-slots 205 #'compute-slots) 206 class)) 207 (values)) 208 209 ;;; Class precedence lists 210 211 (defun std-compute-class-precedence-list (class) 212 (let ((classes-to-order (collect-superclasses* class))) 213 (topological-sort classes-to-order 214 (remove-duplicates 215 (mapappend #'local-precedence-ordering 216 classes-to-order)) 217 #'std-tie-breaker-rule))) 218 219 ;;; topological-sort implements the standard algorithm for topologically 220 ;;; sorting an arbitrary set of elements while honoring the precedence 221 ;;; constraints given by a set of (X,Y) pairs that indicate that element 222 ;;; X must precede element Y. The tie-breaker procedure is called when it 223 ;;; is necessary to choose from multiple minimal elements; both a list of 224 ;;; candidates and the ordering so far are provided as arguments. 225 226 (defun topological-sort (elements constraints tie-breaker) 227 (let ((remaining-constraints constraints) 228 (remaining-elements elements) 229 (result ())) 230 (loop 231 (let ((minimal-elements 232 (remove-if 233 #'(lambda (class) 234 (member class remaining-constraints 235 :key #'cadr)) 236 remaining-elements))) 237 (when (null minimal-elements) 238 (if (null remaining-elements) 239 (return-from topological-sort result) 240 (error "Inconsistent precedence graph."))) 241 (let ((choice (if (null (cdr minimal-elements)) 242 (car minimal-elements) 243 (funcall tie-breaker 244 minimal-elements 245 result)))) 246 (setq result (append result (list choice))) 247 (setq remaining-elements 248 (remove choice remaining-elements)) 249 (setq remaining-constraints 250 (remove choice 251 remaining-constraints 252 :test #'member))))))) 253 254 ;;; In the event of a tie while topologically sorting class precedence lists, 255 ;;; the CLOS Specification says to "select the one that has a direct subclass 256 ;;; rightmost in the class precedence list computed so far." The same result 257 ;;; is obtained by inspecting the partially constructed class precedence list 258 ;;; from right to left, looking for the first minimal element to show up among 259 ;;; the direct superclasses of the class precedence list constituent. 260 ;;; (There's a lemma that shows that this rule yields a unique result.) 261 262 (defun std-tie-breaker-rule (minimal-elements cpl-so-far) 263 (dolist (cpl-constituent (reverse cpl-so-far)) 264 (let* ((supers (class-direct-superclasses cpl-constituent)) 265 (common (intersection minimal-elements supers))) 266 (when (not (null common)) 267 (return-from std-tie-breaker-rule (car common)))))) 268 269 ;;; This version of collect-superclasses* isn't bothered by cycles in the class 270 ;;; hierarchy, which sometimes happen by accident. 271 272 (defun collect-superclasses* (class) 273 (labels ((all-superclasses-loop (seen superclasses) 274 (let ((to-be-processed 275 (set-difference superclasses seen))) 276 (if (null to-be-processed) 277 superclasses 278 (let ((class-to-process 279 (car to-be-processed))) 280 (all-superclasses-loop 281 (cons class-to-process seen) 282 (union (class-direct-superclasses 283 class-to-process) 284 superclasses))))))) 285 (all-superclasses-loop () (list class)))) 286 287 ;;; The local precedence ordering of a class C with direct superclasses C_1, 288 ;;; C_2, ..., C_n is the set ((C C_1) (C_1 C_2) ...(C_n-1 C_n)). 289 290 (defun local-precedence-ordering (class) 291 (mapcar #'list 292 (cons class 293 (butlast (class-direct-superclasses class))) 294 (class-direct-superclasses class))) 295 296 ;;; Slot inheritance 297 298 (defun std-compute-slots (class) 299 (let* ((all-slots (mapappend #'class-direct-slots 300 (class-precedence-list class))) 301 (all-names (remove-duplicates 302 (mapcar #'slot-definition-name all-slots)))) 303 (mapcar #'(lambda (name) 304 (funcall 305 (if (eq (class-of class) the-class-standard-class) 306 #'std-compute-effective-slot-definition 307 #'compute-effective-slot-definition) 308 class 309 (remove name all-slots 310 :key #'slot-definition-name 311 :test-not #'eq))) 312 all-names))) 313 314 (defun std-compute-effective-slot-definition (class direct-slots) 315 (declare (ignore class)) 316 (let ((initer (find-if-not #'null direct-slots 317 :key #'slot-definition-initfunction))) 318 (make-effective-slot-definition 319 :name (slot-definition-name (car direct-slots)) 320 :initform (if initer 321 (slot-definition-initform initer) 322 nil) 323 :initfunction (if initer 324 (slot-definition-initfunction initer) 325 nil) 326 :initargs (remove-duplicates 327 (mapappend #'slot-definition-initargs 328 direct-slots)) 329 :allocation (slot-definition-allocation (car direct-slots))))) 330 188 331 ;;; Simple vectors are used for slot storage. 189 332 … … 192 335 193 336 ;;; Standard instance allocation 337 338 (defvar the-class-standard-class (find-class 'standard-class)) 194 339 195 340 (defparameter secret-unbound-value (list "slot unbound")) … … 204 349 secret-unbound-value))) 205 350 206 (defun make-instance-standard-class 207 (metaclass &key name direct-superclasses direct-slots 208 &allow-other-keys) 351 (defun make-instance-standard-class (metaclass &key name direct-superclasses direct-slots 352 &allow-other-keys) 209 353 (declare (ignore metaclass)) 354 ;; (format t "name = ~S~%" name) 355 ;; (format t "direct-superclasses = ~S~%" direct-superclasses) 356 ;; (format t "direct-slots = ~S~%" direct-slots) 210 357 (let ((class (std-allocate-instance (find-class 'standard-class)))) 211 358 (setf (class-name class) name) 212 ;;(setf (class-direct-subclasses class) ())213 ;;(setf (class-direct-methods class) ())359 (setf (class-direct-subclasses class) ()) 360 (setf (class-direct-methods class) ()) 214 361 (std-after-initialization-for-classes class 215 362 :direct-slots direct-slots … … 218 365 219 366 ;; FIXME 220 (defun std-after-initialization-for-classes (&rest args) ) 367 (defun std-after-initialization-for-classes (class 368 &key direct-superclasses direct-slots 369 &allow-other-keys) 370 (let ((supers 371 (or direct-superclasses 372 (list (find-class 'standard-object))))) 373 (setf (class-direct-superclasses class) supers) 374 (dolist (superclass supers) 375 (push class (class-direct-subclasses superclass)))) 376 (let ((slots 377 (mapcar #'(lambda (slot-properties) 378 (apply #'make-direct-slot-definition 379 slot-properties)) 380 direct-slots))) 381 (setf (class-direct-slots class) slots) 382 ;; (dolist (direct-slot slots) 383 ;; (dolist (reader (slot-definition-readers direct-slot)) 384 ;; (add-reader-method 385 ;; class reader (slot-definition-name direct-slot))) 386 ;; (dolist (writer (slot-definition-writers direct-slot)) 387 ;; (add-writer-method 388 ;; class writer (slot-definition-name direct-slot)))) 389 ) 390 (funcall (if (eq (class-of class) (find-class 'standard-class)) 391 #'std-finalize-inheritance 392 #'finalize-inheritance) 393 class) 394 (values)) 221 395 222 396 (defun ensure-class (name &rest all-keys &allow-other-keys)
Note: See TracChangeset
for help on using the changeset viewer.