Mercurial > hg > xemacs-beta

comparison lisp/disass.el @ 380:8626e4521993 r21-2-5

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-5
author cvs
date Mon, 13 Aug 2007 11:07:10 +0200
parents 41ff10fd062f
children 74fd4e045ea6
comparison
equal deleted inserted replaced
379:76b7d63099ad 380:8626e4521993
37 ;; Substantially modified by Jamie Zawinski for 37 ;; Substantially modified by Jamie Zawinski for
38 ;; the new lapcode-based byte compiler. 38 ;; the new lapcode-based byte compiler.
39 39
40 ;;; Code: 40 ;;; Code:
41 41
42 ;;; The variable byte-code-vector is defined by the new bytecomp.el.
43 ;;; The function byte-decompile-lapcode is defined in byte-opt.el.
44 ;;; Since we don't use byte-decompile-lapcode, let's try not loading byte-opt.
45 ;;; The variable byte-code-vector is defined by the new bytecomp.el.
46 ;;; The function byte-decompile-lapcode is defined in byte-optimize.el.
47 (require 'byte-optimize) 42 (require 'byte-optimize)
48 43
49 (defvar disassemble-column-1-indent 8 "*") 44 (defvar disassemble-column-1-indent 8 "*")
50 (defvar disassemble-column-2-indent 10 "*") 45 (defvar disassemble-column-2-indent 10 "*")
51 (defvar disassemble-recursive-indent 3 "*") 46 (defvar disassemble-recursive-indent 3 "*")
52
53 47
54 ;;;###autoload 48 ;;;###autoload
55 (defun disassemble (object &optional buffer indent interactive-p) 49 (defun disassemble (object &optional buffer indent interactive-p)
56 "Print disassembled code for OBJECT in (optional) BUFFER. 50 "Print disassembled code for OBJECT in (optional) BUFFER.
57 OBJECT can be a symbol defined as a function, or a function itself 51 OBJECT can be a symbol defined as a function, or a function itself
73 (disassemble-internal object indent nil))) 67 (disassemble-internal object indent nil)))
74 nil) 68 nil)
75 69
76 70
77 (defun disassemble-internal (obj indent interactive-p) 71 (defun disassemble-internal (obj indent interactive-p)
78 (let ((macro 'nil) 72 (let ((macro nil)
79 (name 'nil) 73 (name nil)
80 args) 74 args)
81 (while (symbolp obj) 75 (while (symbolp obj)
82 (setq name obj 76 (setq name obj
83 obj (symbol-function obj))) 77 obj (symbol-function obj)))
84 (if (subrp obj) 78 (if (subrp obj)
167 (if interactive-p 161 (if interactive-p
168 (message nil))) 162 (message nil)))
169 163
170 164
171 (defun disassemble-1 (obj indent) 165 (defun disassemble-1 (obj indent)
172 "Prints the byte-code call OBJ in the current buffer. 166 "Print the byte-code call OBJ in the current buffer.
173 OBJ should be a call to BYTE-CODE generated by the byte compiler." 167 OBJ should be a compiled-function object generated by the byte compiler."
174 (let (bytes constvec) 168 (let (bytes constvec)
175 (if (consp obj) 169 (if (consp obj)
176 (setq bytes (car (cdr obj)) ; the byte code 170 (setq bytes (car (cdr obj)) ; the byte code
177 constvec (car (cdr (cdr obj)))) ; constant vector 171 constvec (car (cdr (cdr obj)))) ; constant vector
178 (setq bytes (compiled-function-instructions obj) 172 (setq bytes (compiled-function-instructions obj)
252 arg 246 arg
253 (+ indent disassemble-recursive-indent))) 247 (+ indent disassemble-recursive-indent)))
254 ((eq (car-safe (car-safe arg)) 'byte-code) 248 ((eq (car-safe (car-safe arg)) 'byte-code)
255 (insert "(<byte code>...)\n") 249 (insert "(<byte code>...)\n")
256 (mapcar ;recurse on list of byte-code objects 250 (mapcar ;recurse on list of byte-code objects
257 '(lambda (obj) 251 #'(lambda (obj)
258 (disassemble-1 252 (disassemble-1
259 obj 253 obj
260 (+ indent disassemble-recursive-indent))) 254 (+ indent disassemble-recursive-indent)))
261 arg)) 255 arg))
262 (t 256 (t
263 ;; really just a constant 257 ;; really just a constant
264 (let ((print-escape-newlines t)) 258 (let ((print-escape-newlines t))
265 (prin1 arg (current-buffer)))))) 259 (prin1 arg (current-buffer))))))