class-star: Add original-class helper function.

libraries/class-star/class-star.lisp

@@ -34,6 +34,13 @@ The class is restored when exiting BODY."
          #-SBCL
          (deftype ,class-sym () ',class-sym)))))
 
+(defun original-class (class-sym)
+  "Return the parent class with the same name, or nil if there is none.
+This is useful to retrieve the original class of a class that was overridden,
+e.g. with (define-class foo (foo) ...)."
+  (find class-sym (mopu:superclasses (find-class class-sym))
+        :key #'class-name))
+
 (defun name-identity (name definition)
   (declare (ignore definition))
   name)

libraries/class-star/package.lisp

@@ -6,5 +6,6 @@
   (:import-from :hu.dwim.defclass-star)
   (:export #:with-class
            #:replace-class
+           #:original-class
            #:define-class
            #:name-identity))

libraries/class-star/tests/tests.lisp

@@ -48,6 +48,14 @@
                 (fboundp 'name-no-acc-of)))
             nil))
 
+(prove:subtest "Original class"
+  (defclass foo () ())
+  (defclass bar (foo) ())
+  (setf (find-class 'foo) (find-class 'bar))
+  (prove:isnt (class*:original-class 'foo) nil)
+  (prove:is (class-name (class*:original-class 'foo)) 'foo)
+  (prove:isnt (class*:original-class 'foo) (find-class 'foo)))
+
 ;; TODO: These cycle tests work if run at the top-level, but not within prove:subtest.
 
 ;; (prove:subtest "Cycle"