1 ;;; Disassembler for compiled Emacs Lisp code
2 ;;; Copyright (C) 1986 Free Software Foundation, Inc.
3 ;;; Original version by Doug Cutting (doug@csli.stanford.edu)
4 ;;; Substantially modified by Jamie Zawinski <jwz@lucid.com> for
5 ;;; the new lapcode-based byte compiler.
6 ;;; Last modified 22-oct-91.
8 ;; This file is part of GNU Emacs.
10 ;; GNU Emacs is free software; you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation; either version 1, or (at your option)
15 ;; GNU Emacs is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;; GNU General Public License for more details.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs; see the file COPYING. If not, write to
22 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
25 ;;; The variable byte-code-vector is defined by the new bytecomp.el.
26 ;;; The function byte-decompile-lapcode is defined in byte-optimize.el.
27 (require 'byte-optimize
)
29 (defvar disassemble-column-1-indent
5 "*")
30 (defvar disassemble-column-2-indent
10 "*")
32 (defvar disassemble-recursive-indent
3 "*")
34 (defun disassemble (object &optional buffer indent interactive-p
)
35 "Print disassembled code for OBJECT in (optional) BUFFER.
36 OBJECT can be a symbol defined as a function, or a function itself
37 \(a lambda expression or a compiled-function object).
38 If OBJECT is not already compiled, we compile it, but do not
39 redefine OBJECT if it is a symbol."
40 (interactive (list (intern (completing-read "Disassemble function: "
43 (if (eq (car-safe object
) 'byte-code
)
44 (setq object
(list 'lambda
() object
)))
45 (or indent
(setq indent
0)) ;Default indent to zero
47 (if (or interactive-p
(null buffer
))
48 (with-output-to-temp-buffer "*Disassemble*"
49 (set-buffer "*Disassemble*")
50 (disassemble-internal object indent
(not interactive-p
)))
52 (disassemble-internal object indent nil
)))
56 (defun disassemble-internal (obj indent interactive-p
)
63 obj
(symbol-function obj
)))
65 (error "Can't disassemble #<subr %s>" name
))
66 (if (eq (car-safe obj
) 'macro
) ;handle macros
69 (if (and (listp obj
) (not (eq (car obj
) 'lambda
)))
70 (error "not a function"))
72 (if (assq 'byte-code obj
)
74 (if interactive-p
(message (if name
75 "Compiling %s's definition..."
76 "Compiling definition...")
78 (setq obj
(byte-compile obj
))
79 (if interactive-p
(message "Done compiling. Disassembling..."))))
81 (setq obj
(cdr obj
)) ;throw lambda away
82 (setq args
(car obj
)) ;save arg list
85 (setq args
(aref obj
0))))
86 (if (zerop indent
) ; not a nested function
89 (insert (format "byte code%s%s%s:\n"
90 (if (or macro name
) " for" "")
91 (if macro
" macro" "")
92 (if name
(format " %s" name
) "")))))
93 (let ((doc (if (consp obj
)
94 (and (stringp (car obj
)) (car obj
))
95 (and (> (length obj
) 4) (aref obj
4)))))
96 (if (and doc
(stringp doc
))
97 (progn (and (consp obj
) (setq obj
(cdr obj
)))
99 (princ " doc: " (current-buffer))
100 (if (string-match "\n" doc
)
101 (setq doc
(concat (substring doc
0 (match-beginning 0))
106 (prin1 args
(current-buffer))
108 (let ((interactive (cond ((consp obj
)
109 (assq 'interactive obj
))
111 (list 'interactive
(aref obj
5))))))
114 (setq interactive
(nth 1 interactive
))
115 (if (eq (car-safe (car-safe obj
)) 'interactive
)
116 (setq obj
(cdr obj
)))
118 (insert " interactive: ")
119 (if (eq (car-safe interactive
) 'byte-code
)
122 (disassemble-1 interactive
123 (+ indent disassemble-recursive-indent
)))
124 (let ((print-escape-newlines t
))
125 (prin1 interactive
(current-buffer))))
127 (cond ((and (consp obj
) (assq 'byte-code obj
))
128 (disassemble-1 (assq 'byte-code obj
) indent
))
129 ((compiled-function-p obj
)
130 (disassemble-1 obj indent
))
132 (insert "Uncompiled body: ")
133 (let ((print-escape-newlines t
))
134 (prin1 (if (cdr obj
) (cons 'progn obj
) (car obj
))
135 (current-buffer))))))
140 (defun disassemble-1 (obj indent
)
141 "Prints the byte-code call OBJ in the current buffer.
142 OBJ should be a call to BYTE-CODE generated by the byte compiler."
143 (let (bytes constvec
)
145 (setq bytes
(car (cdr obj
)) ;the byte code
146 constvec
(car (cdr (cdr obj
)))) ;constant vector
147 (setq bytes
(aref obj
1)
148 constvec
(aref obj
2)))
149 (let ((lap (byte-decompile-bytecode bytes constvec
))
154 (while (setq tmp
(assq 'TAG lap
))
155 (setcar (cdr tmp
) (setq tagno
(1+ tagno
)))
156 (setq lap
(cdr (memq tmp lap
)))))
158 (setq op
(car (car lap
))
162 (insert (int-to-string (car arg
)) ":")
164 (indent-to (+ indent disassemble-column-1-indent
))
166 (string-match "^byte-" (setq opname
(symbol-name op
))))
167 (setq opname
(substring opname
5))
168 (setq opname
"<not-an-opcode>"))
169 (if (eq op
'byte-constant2
)
170 (insert " #### shouldn't have seen constant2 here!\n "))
172 (indent-to (+ indent disassemble-column-1-indent
173 disassemble-column-2-indent
176 (cond ((memq op byte-goto-ops
)
177 (insert (int-to-string (nth 1 arg
))))
178 ((memq op
'(byte-call byte-unbind
179 byte-listN byte-concatN byte-insertN
))
180 (insert (int-to-string arg
)))
181 ((memq op
'(byte-varref byte-varset byte-varbind
))
182 (prin1 (car arg
) (current-buffer)))
183 ((memq op
'(byte-constant byte-constant2
))
186 ;; but if the value of the constant is compiled code, then
187 ;; recursively disassemble it.
188 (cond ((or (compiled-function-p arg
)
189 (and (eq (car-safe arg
) 'lambda
)
190 (assq 'byte-code arg
))
191 (and (eq (car-safe arg
) 'macro
)
192 (or (compiled-function-p (cdr arg
))
193 (and (eq (car-safe (cdr arg
)) 'lambda
)
194 (assq 'byte-code
(cdr arg
))))))
195 (cond ((compiled-function-p arg
)
196 (insert "<compiled-function>\n"))
197 ((eq (car-safe arg
) 'lambda
)
198 (insert "<compiled lambda>"))
199 (t (insert "<compiled macro>\n")))
200 (disassemble-internal
202 (+ indent disassemble-recursive-indent
1)
204 ((eq (car-safe arg
) 'byte-code
)
205 (insert "<byte code>\n")
206 (disassemble-1 ;recurse on byte-code object
208 (+ indent disassemble-recursive-indent
)))
209 ((eq (car-safe (car-safe arg
)) 'byte-code
)
210 (insert "(<byte code>...)\n")
211 (mapcar ;recurse on list of byte-code objects
215 (+ indent disassemble-recursive-indent
)))
218 ;; really just a constant
219 (let ((print-escape-newlines t
))
220 (prin1 arg
(current-buffer))))))
223 (setq lap
(cdr lap
)))))