>From 1dbd917a36154ab22bf0ddf58b6d5b7ba50603b4 Mon Sep 17 00:00:00 2001
From: Olof-Joachim Frahm <olof@macrolet.net>
Date: Fri, 20 Nov 2015 18:50:05 +0100
Subject: [PATCH 3/5] Add multiple disassembler selector.

Which allows for different disassembler backends to be used, choosing
the "best" one available by default.
---
 src/org/armedbear/lisp/disassemble.lisp | 94 ++++++++++++++++++++++++++++-----
 1 file changed, 82 insertions(+), 12 deletions(-)

diff --git a/src/org/armedbear/lisp/disassemble.lisp b/src/org/armedbear/lisp/disassemble.lisp
index ec67d75..c75dfaf 100644
--- a/src/org/armedbear/lisp/disassemble.lisp
+++ b/src/org/armedbear/lisp/disassemble.lisp
@@ -33,6 +33,51 @@
 
 (require '#:clos)
 
+(defvar *disassembler-function* NIL)
+
+(defvar *disassemblers*
+  `((:objectweb . objectweb-test)
+    (:external . external-test)))
+
+(defun choose-disassembler (&optional name)
+  (setf *disassembler-function*
+        (if name
+            (or (funcall (cdr (assoc name *disassemblers*)))
+                (error "Can't find suitable disassembler."))
+            (loop
+              for (NIL . test) in *disassemblers*
+              for result = (funcall test)
+              when result
+                do (return result)
+              finally (warn "Can't find suitable disassembler.")))))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defmacro with-open ((name value) &body body)
+    `(let ((,name ,value))
+       (unwind-protect
+           (progn ,@body)
+         (java:jcall-raw "close" ,name)))))
+
+(defun read-byte-array-from-stream (stream)
+  (let ((buffer (java:jnew-array (java:jclass "byte") 4096)))
+    (with-open (output (java:jnew "java.io.ByteArrayOutputStream"))
+      (loop
+        for length = (java:jcall "read" stream buffer)
+        until (eql length -1)
+        do (java:jcall-raw "write" output buffer 0 length))
+      (java:jcall-raw "flush" output)
+      (java:jcall-raw "toByteArray" output))))
+
+(defun class-resource-path (class)
+  (format NIL "~A.class" (substitute #\/ #\. (java:jcall "getName" class))))
+
+(defun class-bytes (class)
+  (with-open (stream (java:jcall-raw
+                      "getResourceAsStream"
+                      (java:jcall-raw "getClassLoader" class)
+                      (class-resource-path class)))
+    (read-byte-array-from-stream stream)))
+
 (defun disassemble (arg)
   (require-type arg '(OR FUNCTION
                       SYMBOL
@@ -47,15 +92,40 @@ (defun disassemble (arg)
     (when (functionp function)
       (unless (compiled-function-p function)
         (setf function (compile nil function)))
-      (let ((class-bytes (function-class-bytes function)))
-	(when class-bytes
-	  (with-input-from-string
-	      (stream (disassemble-class-bytes class-bytes))
-	    (loop
-	       (let ((line (read-line stream nil)))
-		 (unless line (return))
-		 (write-string "; ")
-		 (write-string line)
-		 (terpri))))
-	  (return-from disassemble)))
-      (%format t "; Disassembly is not available.~%"))))
+      (let ((class-bytes (or (function-class-bytes function)
+                             (class-bytes (java:jcall-raw "getClass" function)))))
+        (if class-bytes
+            (let ((disassembler (or *disassembler-function*
+                                    (choose-disassembler))))
+              (and disassembler (funcall disassembler class-bytes)))
+            (%format t "; Disassembly is not available.~%"))))))
+
+(defun print-lines-with-prefix (string)
+  (with-input-from-string (stream string)
+    (loop
+      (let ((line (read-line stream nil)))
+        (unless line (return))
+        (write-string "; ")
+        (write-string line)
+        (terpri)))))
+
+(defun external-disassemble (object)
+  (print-lines-with-prefix (disassemble-class-bytes object)))
+
+(defun external-test ()
+  (ignore-errors
+    (and (disassemble-class-bytes #'cons) #'external-disassemble)))
+
+(defun objectweb-disassemble (object)
+  (let* ((reader (java:jnew "org.objectweb.asm.ClassReader" object))
+         (writer (java:jnew "java.io.StringWriter"))
+         (printer (java:jnew "java.io.PrintWriter" writer))
+         (tracer (java:jnew "org.objectweb.asm.util.TraceClassVisitor" java:+null+ printer))
+         ;; this is to support both the 1.X and subsequent releases
+         (flags (ignore-errors (java:jfield "org.objectweb.asm.ClassReader" "SKIP_DEBUG"))))
+    (java:jcall-raw "accept" reader tracer (or flags java:+false+))
+    (print-lines-with-prefix (java:jcall "toString" writer))))
+
+(defun objectweb-test ()
+  (ignore-errors
+    (and (java:jclass "org.objectweb.asm.ClassReader") #'objectweb-disassemble)))
-- 
2.8.1