Changeset 4287


Ignore:
Timestamp:
10/10/03 17:02:46 (19 years ago)
Author:
piso
Message:

Work in progress.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/j/src/org/armedbear/lisp/defclass.lisp

    r4279 r4287  
    22;;;
    33;;; Copyright (C) 2003 Peter Graves
    4 ;;; $Id: defclass.lisp,v 1.2 2003-10-10 14:15:43 piso Exp $
     4;;; $Id: defclass.lisp,v 1.3 2003-10-10 17:02:46 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    5050
    5151(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)
    5258
    5359(defun canonicalize-direct-slots (direct-slots)
     
    186192  (setf (getf* slot ':allocation) new-value))
    187193
     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
    188331;;; Simple vectors are used for slot storage.
    189332
     
    192335
    193336;;; Standard instance allocation
     337
     338(defvar the-class-standard-class (find-class 'standard-class))
    194339
    195340(defparameter secret-unbound-value (list "slot unbound"))
     
    204349                          secret-unbound-value)))
    205350
    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)
    209353  (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)
    210357  (let ((class (std-allocate-instance (find-class 'standard-class))))
    211358    (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) ())
    214361    (std-after-initialization-for-classes class
    215362                                          :direct-slots direct-slots
     
    218365
    219366;; 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))
    221395
    222396(defun ensure-class (name &rest all-keys &allow-other-keys)
Note: See TracChangeset for help on using the changeset viewer.