1 ;;; disass.el --- disassembler for compiled Emacs Lisp code
3 ;;; Copyright (C) 1986, 1991 Free Software Foundation, Inc.
5 ;; Author: Doug Cutting <doug@csli.stanford.edu>
6 ;; Jamie Zawinski <jwz@lucid.com>
7 ;; Maintainer: Jamie Zawinski <jwz@lucid.com>
10 ;; This file is part of GNU Emacs.
12 ;; GNU Emacs is free software; you can redistribute it and/or modify
13 ;; it under the terms of the GNU General Public License as published by
14 ;; the Free Software Foundation; either version 2, or (at your option)
17 ;; GNU Emacs is distributed in the hope that it will be useful,
18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20 ;; GNU General Public License for more details.
22 ;; You should have received a copy of the GNU General Public License
23 ;; along with GNU Emacs; see the file COPYING. If not, write to
24 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
28 ;;; Original version by Doug Cutting (doug@csli.stanford.edu)
29 ;;; Substantially modified by Jamie Zawinski <jwz@lucid.com> for
30 ;;; the new lapcode-based byte compiler.
34 ;;; The variable byte-code-vector is defined by the new bytecomp.el.
35 ;;; The function byte-decompile-lapcode is defined in byte-opt.el.
36 ;;; Since we don't use byte-decompile-lapcode, let's try not loading byte-opt.
37 (require 'byte-compile
"bytecomp")
39 (defvar disassemble-column-1-indent
5 "*")
40 (defvar disassemble-column-2-indent
10 "*")
42 (defvar disassemble-recursive-indent
3 "*")
44 (defun disassemble (object &optional buffer indent interactive-p
)
45 "Print disassembled code for OBJECT in (optional) BUFFER.
46 OBJECT can be a symbol defined as a function, or a function itself
47 \(a lambda expression or a compiled-function object).
48 If OBJECT is not already compiled, we compile it, but do not
49 redefine OBJECT if it is a symbol."
50 (interactive (list (intern (completing-read "Disassemble function: "
53 (if (eq (car-safe object
) 'byte-code
)
54 (setq object
(list 'lambda
() object
)))
55 (or indent
(setq indent
0)) ;Default indent to zero
57 (if (or interactive-p
(null buffer
))
58 (with-output-to-temp-buffer "*Disassemble*"
59 (set-buffer "*Disassemble*")
60 (disassemble-internal object indent
(not interactive-p
)))
62 (disassemble-internal object indent nil
)))
66 (defun disassemble-internal (obj indent interactive-p
)
73 obj
(symbol-function obj
)))
75 (error "Can't disassemble #<subr %s>" name
))
76 (if (eq (car-safe obj
) 'macro
) ;handle macros
79 (if (and (listp obj
) (not (eq (car obj
) 'lambda
)))
80 (error "not a function"))
82 (if (assq 'byte-code obj
)
84 (if interactive-p
(message (if name
85 "Compiling %s's definition..."
86 "Compiling definition...")
88 (setq obj
(byte-compile obj
))
89 (if interactive-p
(message "Done compiling. Disassembling..."))))
91 (setq obj
(cdr obj
)) ;throw lambda away
92 (setq args
(car obj
)) ;save arg list
95 (setq args
(aref obj
0))))
96 (if (zerop indent
) ; not a nested function
99 (insert (format "byte code%s%s%s:\n"
100 (if (or macro name
) " for" "")
101 (if macro
" macro" "")
102 (if name
(format " %s" name
) "")))))
103 (let ((doc (if (consp obj
)
104 (and (stringp (car obj
)) (car obj
))
105 (and (> (length obj
) 4) (aref obj
4)))))
106 (if (and doc
(stringp doc
))
107 (progn (and (consp obj
) (setq obj
(cdr obj
)))
109 (princ " doc: " (current-buffer))
110 (if (string-match "\n" doc
)
111 (setq doc
(concat (substring doc
0 (match-beginning 0))
116 (prin1 args
(current-buffer))
118 (let ((interactive (cond ((consp obj
)
119 (assq 'interactive obj
))
121 (list 'interactive
(aref obj
5))))))
124 (setq interactive
(nth 1 interactive
))
125 (if (eq (car-safe (car-safe obj
)) 'interactive
)
126 (setq obj
(cdr obj
)))
128 (insert " interactive: ")
129 (if (eq (car-safe interactive
) 'byte-code
)
132 (disassemble-1 interactive
133 (+ indent disassemble-recursive-indent
)))
134 (let ((print-escape-newlines t
))
135 (prin1 interactive
(current-buffer))))
137 (cond ((and (consp obj
) (assq 'byte-code obj
))
138 (disassemble-1 (assq 'byte-code obj
) indent
))
139 ((compiled-function-p obj
)
140 (disassemble-1 obj indent
))
142 (insert "Uncompiled body: ")
143 (let ((print-escape-newlines t
))
144 (prin1 (if (cdr obj
) (cons 'progn obj
) (car obj
))
145 (current-buffer))))))
150 (defun disassemble-1 (obj indent
)
151 "Prints the byte-code call OBJ in the current buffer.
152 OBJ should be a call to BYTE-CODE generated by the byte compiler."
153 (let (bytes constvec
)
155 (setq bytes
(car (cdr obj
)) ;the byte code
156 constvec
(car (cdr (cdr obj
)))) ;constant vector
157 (setq bytes
(aref obj
1)
158 constvec
(aref obj
2)))
159 (let ((lap (byte-decompile-bytecode bytes constvec
))
164 (while (setq tmp
(assq 'TAG lap
))
165 (setcar (cdr tmp
) (setq tagno
(1+ tagno
)))
166 (setq lap
(cdr (memq tmp lap
)))))
168 (setq op
(car (car lap
))
172 (insert (int-to-string (car arg
)) ":")
174 (indent-to (+ indent disassemble-column-1-indent
))
176 (string-match "^byte-" (setq opname
(symbol-name op
))))
177 (setq opname
(substring opname
5))
178 (setq opname
"<not-an-opcode>"))
179 (if (eq op
'byte-constant2
)
180 (insert " #### shouldn't have seen constant2 here!\n "))
182 (indent-to (+ indent disassemble-column-1-indent
183 disassemble-column-2-indent
186 (cond ((memq op byte-goto-ops
)
187 (insert (int-to-string (nth 1 arg
))))
188 ((memq op
'(byte-call byte-unbind
189 byte-listN byte-concatN byte-insertN
))
190 (insert (int-to-string arg
)))
191 ((memq op
'(byte-varref byte-varset byte-varbind
))
192 (prin1 (car arg
) (current-buffer)))
193 ((memq op
'(byte-constant byte-constant2
))
196 ;; but if the value of the constant is compiled code, then
197 ;; recursively disassemble it.
198 (cond ((or (compiled-function-p arg
)
199 (and (eq (car-safe arg
) 'lambda
)
200 (assq 'byte-code arg
))
201 (and (eq (car-safe arg
) 'macro
)
202 (or (compiled-function-p (cdr arg
))
203 (and (eq (car-safe (cdr arg
)) 'lambda
)
204 (assq 'byte-code
(cdr arg
))))))
205 (cond ((compiled-function-p arg
)
206 (insert "<compiled-function>\n"))
207 ((eq (car-safe arg
) 'lambda
)
208 (insert "<compiled lambda>"))
209 (t (insert "<compiled macro>\n")))
210 (disassemble-internal
212 (+ indent disassemble-recursive-indent
1)
214 ((eq (car-safe arg
) 'byte-code
)
215 (insert "<byte code>\n")
216 (disassemble-1 ;recurse on byte-code object
218 (+ indent disassemble-recursive-indent
)))
219 ((eq (car-safe (car-safe arg
)) 'byte-code
)
220 (insert "(<byte code>...)\n")
221 (mapcar ;recurse on list of byte-code objects
225 (+ indent disassemble-recursive-indent
)))
228 ;; really just a constant
229 (let ((print-escape-newlines t
))
230 (prin1 arg
(current-buffer))))))
233 (setq lap
(cdr lap
)))))
236 ;;; disass.el ends here