Define functions for patching impure method functions.

ska80 · Sep 17, 2020 · 901f9af · 901f9af
1 parent 56a5108
commit 901f9af
Showing 1 changed file with 29 additions and 0 deletions.
diff --git a/Code/Boot/Phase-8/patch-environment.lisp b/Code/Boot/Phase-8/patch-environment.lisp
@@ -51,3 +51,32 @@
             (process-function (sicl-genv:fdefinition symbol environment)))
           (when (sicl-genv:fboundp `(setf ,symbol) environment)
             (process-function (sicl-genv:fdefinition `(setf ,symbol) environment))))))))
+
+(defun maybe-patch-generic-function-other-methods (generic-function e5)
+  (loop for method in (funcall (sicl-genv:fdefinition 'sicl-clos:generic-function-methods e5) generic-function)
+        for function = (funcall (sicl-genv:fdefinition 'sicl-clos:method-function e5) method)
+        unless (typep (slot-value function 'sicl-boot::%class) 'sicl-boot::header)
+          do (setf (slot-value function 'sicl-boot::%class)
+                   (sicl-genv:find-class 'sicl-clos:simple-function e5))
+             (let* ((static-environment
+                      (funcall (sicl-genv:fdefinition 'sicl-clos::environment e5) function))
+                    (code-object (aref static-environment 0)))
+               (setf (slot-value code-object 'sicl-boot::%class)
+                     (sicl-genv:find-class 'sicl-compiler:code-object e5)))))
+
+(defun patch-other-methods (environment)
+  (flet ((process-function (function)
+           (when (and (typep function 'sicl-boot::header)
+                      (eq (slot-value function 'sicl-boot::%class)
+                          (sicl-genv:find-class 'standard-generic-function environment)))
+             (maybe-patch-generic-function-other-methods function environment))))
+    (let ((table (make-hash-table :test #'eq)))
+      (do-all-symbols (symbol)
+        (unless (gethash symbol table)
+          (setf (gethash symbol table) t)
+          (when (and (sicl-genv:fboundp symbol environment)
+                     (not (sicl-genv:special-operator symbol environment))
+                     (null (sicl-genv:macro-function symbol environment)))
+            (process-function (sicl-genv:fdefinition symbol environment)))
+          (when (sicl-genv:fboundp `(setf ,symbol) environment)
+            (process-function (sicl-genv:fdefinition `(setf ,symbol) environment))))))))