From 0ec144c682f69d87486b00f82c8338ddf8a1d58e Mon Sep 17 00:00:00 2001 From: pfdietz Date: Wed, 9 Apr 2003 02:24:05 +0000 Subject: [PATCH] Added routine to compute class precedence list. Added more defclass tests. --- ansi-tests/defclass-aux.lsp | 82 +++++++++++++++++++++++++++++++++---- ansi-tests/defclass.lsp | 2 + 2 files changed, 77 insertions(+), 7 deletions(-) diff --git a/ansi-tests/defclass-aux.lsp b/ansi-tests/defclass-aux.lsp index 1bb4c69..961b7df 100644 --- a/ansi-tests/defclass-aux.lsp +++ b/ansi-tests/defclass-aux.lsp @@ -20,6 +20,12 @@ (default-initargs nil :type list) (metaclass 'standard-class :type symbol) (documentation nil :type (or null string)) + ;; Internal fields + (preds nil :type list) + (succs nil :type list) + (count 0 :type integer) + (index nil) + (min-pred-index 1000000) ) (defstruct my-slot @@ -42,6 +48,10 @@ (defun find-my-class (class-name) (gethash class-name *my-classes*)) +;;; This macro will assume that all the superclasses have already +;;; been defined. Tests will be written with defclass itself +;;; to test forward referenced superclasses + (defmacro defclass-with-tests (&whole args class-name superclasses slot-specifiers @@ -224,14 +234,72 @@ '(,sym)))) nil)))) -#| - (defun compute-class-precedence-list (class-name) "Compute the class precdence list for classes defined using DEFCLASS-WITH-TESTS." - (let ((classes nil) - (classes-to-consider class-name)) + (let ((class-names nil) + (class-names-to-consider (list class-name)) + classes) ;; Find all classes - -|# - \ No newline at end of file + (loop + while class-names-to-consider + do (let ((name (pop class-names-to-consider))) + (unless (member name class-names) + (push name class-names) + (let ((my-class (find-my-class name))) + (assert my-class) + (setq class-names-to-consider + (append (my-class-direct-superclass-names my-class) + class-names-to-consider)))))) + (setq class-names (reverse class-names)) + (assert (eq class-name (first class-names))) + ;; class-names now contains class-name (which occurs first) and + ;; the names of all its superclasses except T + (setq classes (mapcar #'find-my-class class-names)) + ;; Walk the classes and set the predecessor links in the + ;; class precedence DAG + (loop for c in classes + for dsns = (my-class-direct-superclass-names c) + do (let ((pred c)) + (loop for superclass-name in dsns + for superclass = (find-my-class superclass-name) + do (push pred (my-class-preds superclass)) + do (pushnew superclass (my-class-succs pred)) + do (incf (my-class-count superclass)) + do (setq pred superclass)))) + ;; The list candidates will contain all the classes + ;; for which the count is zero. These are the candidates + ;; for selection as the next class in the class precedence list + (let ((candidates (loop for c in classes + when (zerop (my-class-count c)) + collect c)) + (n 0) + (result nil)) + (assert (equal candidates (list (first classes)))) + (loop + while candidates + do (let* ((next (first candidates)) + (min-pred-index (my-class-min-pred-index next))) + (loop + for c in (rest candidates) + for c-min-pred-index = (my-class-min-pred-index c) + do + (cond + ((< c-min-pred-index min-pred-index) + (setq next c + min-pred-index c-min-pred-index)) + (t (assert (not (= c-min-pred-index min-pred-index)))))) + (setq candidates (remove next candidates)) + (setf (my-class-index next) (incf n)) + (push next result) + (loop + for succ in (my-class-succs next) + do (decf (my-class-count succ)) + do (setf (my-class-min-pred-index succ) + (min (my-class-min-pred-index succ) + n)) + do (when (zerop (my-class-count succ)) + (push succ candidates))))) + (assert (eql (length result) (length classes))) + (setq result (reverse result)) + (mapcar #'my-class-name result)))) diff --git a/ansi-tests/defclass.lsp b/ansi-tests/defclass.lsp index 29a5e5c..1b5b816 100644 --- a/ansi-tests/defclass.lsp +++ b/ansi-tests/defclass.lsp @@ -72,6 +72,8 @@ (defclass-with-tests defclass-1 nil nil) (defclass-with-tests defclass-2 nil (slot1 slot2 slot3)) +(defclass-with-tests defclass-3 (defclass-1) nil) +(defclass-with-tests defclass-4 (defclass-1 defclass-2) (slot1 slot4)) ;;; At end, generate slot tests -- GitLab