From e7cacdceac073983507fe41a3838ec1219354692 Mon Sep 17 00:00:00 2001
From: Guilherme Affonso <guilherme.c.affonso@gmail.com>
Date: Sun, 25 Dec 2022 12:22:12 +0900
Subject: [PATCH] Add comp::dump-method and fix class reference when compiling
 parent methods

---
 lisp/comp/comp.l | 66 +++++++++++++++++++++++++++---------------------
 1 file changed, 37 insertions(+), 29 deletions(-)

diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l
index f604263fe..3eb880760 100644
--- a/lisp/comp/comp.l
+++ b/lisp/comp/comp.l
@@ -2044,14 +2044,34 @@
 (eval-when (load eval)
 
 (defun dump-function (file &rest names)
-   (with-open-file (f file :direction :output)
+  (let (acc)
+    (with-open-file (f file :direction :output)
       (dolist (funmac names)
 	 (let ((def (symbol-function funmac)) dump)
-	   (setq dump
-	    (case (car def)
-		(lambda `(defun ,funmac . ,(cdr def)))
-		(macro  `(defmacro ,funmac . ,(cdr def)))))
-	  (pprint dump f) ))) )
+           (when (consp def)
+             (setq dump
+                   (case (car def)
+                     (lambda `(defun ,funmac . ,(cdr def)))
+                     (macro  `(defmacro ,funmac . ,(cdr def)))
+                     (t (error value-error "unknown function type: ~A" (car def)))))
+             (pprint dump f)
+             (push funmac acc)))))
+    (nreverse acc)))
+
+(defun dump-method (file obj &rest methods)
+  (let (acc)
+    (with-open-file (f file :direction :output)
+      (dolist (meth methods)
+        (let ((def (if (classp obj)
+                       (let ((body (assoc meth (send obj :methods))))
+                         (if body (list obj body)))
+                       (find-method obj meth))))
+          (when def
+            (multiple-value-bind (cls body) def
+              (when (and (consp body) (not (compiled-function-p (second body))))
+                (pprint `(defmethod ,(send cls :name) ,body) f)
+                (push meth acc)))))))
+    (nreverse acc)))
 
 (defun comfile (&rest files) (dolist (f files) (send comp :compile-file f)))
 (defun compile-file (file &rest keys)
@@ -2077,32 +2097,20 @@
     pname))
 
 (defun compile (&rest funcs)
-    (let ((fname (format nil "eus~d~A.l" (unix:getpid)
-			(symbol-name (gensym "C")))))
-      (setq funcs (remove-if #'compiled-function-p funcs :key #'symbol-function))
-      (apply #'dump-function fname funcs)
+  (let* ((fname (format nil "eus~d~A.l" (unix:getpid)
+                        (symbol-name (gensym "C"))))
+         (res (apply #'dump-function fname funcs)))
+    (when res
       (compile-tmp fname)
-      funcs))
+      res)))
 
 (defun compile-method (obj &rest meths)
-  (let ((fname (format nil "eus~d~A.l" (unix:getpid)
-                       (symbol-name (gensym "C"))))
-        (kls (if (classp obj) obj (class obj)))
-        body)
-    (labels ((get-method (meth)
-               (if (classp obj)
-                   (assoc meth (send obj :methods))
-                   (cadr (find-method obj meth))))
-             (to-compile (def)
-               (and (consp def) (not (compiled-function-p (second def))))))
-
-      (setq body (mapcar #'get-method meths))
-      (setq body (remove-if-not #'to-compile body))
-      (when body
-        (with-open-file (f fname :direction :output)
-          (format f "~S~%" `(defmethod ,(send kls :name) ,@body)))
-        (compile-tmp fname)
-        (mapcar #'car body)))))
+  (let* ((fname (format nil "eus~d~A.l" (unix:getpid)
+                        (symbol-name (gensym "C"))))
+         (res (apply #'dump-method fname obj meths)))
+    (when res
+      (compile-tmp fname)
+      res)))
 
 (defun compile-file-if-src-newer (srcfile &optional (objdir "./")
 					  &rest args)