4.4BSD/usr/src/contrib/emacs-18.57/lisp/disass.el
;;; Disassembler for compiled Emacs Lisp code
;; Copyright (C) 1986 Free Software Foundation
;;; By Doug Cutting (doug@csli.stanford.edu)
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 1, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
(require 'byte-compile "bytecomp")
(defvar disassemble-column-1-indent 4 "*")
(defvar disassemble-column-2-indent 9 "*")
(defvar disassemble-recursive-indent 3 "*")
;(defun d (x)
; (interactive "xDiss ")
; (with-output-to-temp-buffer "*Disassemble*"
; (disassemble-internal (list 'lambda '() x ''return-value)
; standard-output 0 t)))
(defun disassemble (object &optional stream indent interactive-p)
"Print disassembled code for OBJECT on (optional) STREAM.
OBJECT can be a function name, lambda expression or any function object
returned by SYMBOL-FUNCTION. If OBJECT is not already compiled, we will
compile it (but not redefine it)."
(interactive (list (intern (completing-read "Disassemble function: "
obarray 'fboundp t))
nil 0 t))
(or indent (setq indent 0)) ;Default indent to zero
(if interactive-p
(with-output-to-temp-buffer "*Disassemble*"
(disassemble-internal object standard-output indent t))
(disassemble-internal object (or stream standard-output) indent nil))
nil)
(defun disassemble-internal (obj stream indent interactive-p)
(let ((macro 'nil)
(name 'nil)
(doc 'nil)
args)
(while (symbolp obj)
(setq name obj
obj (symbol-function obj)))
(if (subrp obj)
(error "Can't disassemble #<subr %s>" name))
(if (eq (car obj) 'macro) ;handle macros
(setq macro t
obj (cdr obj)))
(if (not (eq (car obj) 'lambda))
(error "not a function"))
(if (assq 'byte-code obj)
nil
(if interactive-p (message (if name
"Compiling %s's definition..."
"Compiling definition...")
name))
(setq obj (byte-compile-lambda obj))
(if interactive-p (message "Done compiling. Disassembling...")))
(setq obj (cdr obj)) ;throw lambda away
(setq args (car obj)) ;save arg list
(setq obj (cdr obj))
(write-spaces indent stream)
(princ (format "byte code%s%s%s:\n"
(if (or macro name) " for" "")
(if macro " macro" "")
(if name (format " %s" name) ""))
stream)
(let ((doc (and (stringp (car obj)) (car obj))))
(if doc
(progn (setq obj (cdr obj))
(write-spaces indent stream)
(princ " doc: " stream)
(princ doc stream)
(terpri stream))))
(write-spaces indent stream)
(princ " args: " stream)
(prin1 args stream)
(terpri stream)
(let ((interactive (car (cdr (assq 'interactive obj)))))
(if interactive
(progn (write-spaces indent stream)
(princ " interactive: " stream)
(if (eq (car-safe interactive) 'byte-code)
(disassemble-1 interactive stream
(+ indent disassemble-recursive-indent))
(prin1 interactive stream)
(terpri stream)))))
(setq obj (assq 'byte-code obj)) ;obj is now call to byte-code
(disassemble-1 obj stream indent))
(if interactive-p
(message "")))
(defun disassemble-1 (obj &optional stream indent)
"Prints the byte-code call OBJ to (optional) STREAM.
OBJ should be a call to BYTE-CODE generated by the byte compiler."
(or indent (setq indent 0)) ;default indent to 0
(or stream (setq stream standard-output))
(let ((bytes (car (cdr obj))) ;the byte code
(ptr -1) ;where we are in it
(constants (car (cdr (cdr obj)))) ;constant vector
;(next-indent indent)
offset tmp length)
(setq length (length bytes))
(terpri stream)
(while (< (setq ptr (1+ ptr)) length)
;(setq indent next-indent)
(write-spaces indent stream) ;indent to recursive indent
(princ (setq tmp (prin1-to-string ptr)) stream) ;print line #
(write-char ?\ stream)
(write-spaces (- disassemble-column-1-indent (length tmp) 1)
stream)
(setq op (aref bytes ptr)) ;fetch opcode
;; Note: as offsets are either encoded in opcodes or stored as
;; bytes in the code, this function (disassemble-offset)
;; can set OP and/or PTR.
(setq offset (disassemble-offset));fetch offset
(setq tmp (aref byte-code-vector op))
(if (consp tmp)
(setq ;next-indent (if (numberp (cdr tmp))
; (+ indent (cdr tmp))
; (+ indent (funcall (cdr tmp) offset)))
tmp (car tmp)))
(setq tmp (symbol-name tmp))
(princ tmp stream) ;print op-name for opcode
(if (null offset)
nil
(write-char ?\ stream)
(write-spaces (- disassemble-column-2-indent (length tmp) 1)
stream) ;indent to col 2
(princ ;print offset
(cond ((or (eq op byte-varref)
(eq op byte-varset)
(eq op byte-varbind))
;; it's a varname (atom)
(aref constants offset)) ;fetch it from constants
((or (eq op byte-goto)
(eq op byte-goto-if-nil)
(eq op byte-goto-if-not-nil)
(eq op byte-goto-if-nil-else-pop)
(eq op byte-goto-if-not-nil-else-pop)
(eq op byte-call)
(eq op byte-unbind))
;; it's a number
offset) ;return it
((or (eq op byte-constant)
(eq op byte-constant2))
;; it's a constant
(setq tmp (aref constants offset))
;; but is constant byte code?
(cond ((and (eq (car-safe tmp) 'lambda)
(assq 'byte-code tmp))
(princ "<compiled lambda>" stream)
(terpri stream)
(disassemble ;recurse on compiled lambda
tmp
stream
(+ indent disassemble-recursive-indent))
"")
((eq (car-safe tmp) 'byte-code)
(princ "<byte code>" stream)
(terpri stream)
(disassemble-1 ;recurse on byte-code object
tmp
stream
(+ indent disassemble-recursive-indent))
"")
((eq (car-safe (car-safe tmp)) 'byte-code)
(princ "(<byte code>...)" stream)
(terpri stream)
(mapcar ;recurse on list of byte-code objects
(function (lambda (obj)
(disassemble-1
obj
stream
(+ indent disassemble-recursive-indent))))
tmp)
"")
((and (eq tmp 'byte-code)
(eq (aref bytes (+ ptr 4)) (+ byte-call 3)))
;; this won't catch cases where args are pushed w/
;; constant2.
(setq ptr (+ ptr 4))
"<compiled call to byte-code. compiled code compiled?>")
(t
;; really just a constant
(let ((print-escape-newlines t))
(prin1-to-string tmp)))))
(t "<error in disassembler>"))
stream))
(terpri stream)))
nil)
(defun disassemble-offset ()
"Don't call this!"
;; fetch and return the offset for the current opcode.
;; return NIL if this opcode has no offset
;; OP, PTR and BYTES are used and set dynamically
(let (tem)
(cond ((< op byte-nth)
(setq tem (logand op 7))
(setq op (logand op 248))
(cond ((eq tem 6)
(setq ptr (1+ ptr)) ;offset in next byte
(aref bytes ptr))
((eq tem 7)
(setq ptr (1+ ptr)) ;offset in next 2 bytes
(+ (aref bytes ptr)
(progn (setq ptr (1+ ptr))
(lsh (aref bytes ptr) 8))))
(t tem))) ;offset was in opcode
((>= op byte-constant)
(setq tem (- op byte-constant)) ;offset in opcode
(setq op byte-constant)
tem)
((or (= op byte-constant2)
(and (>= op byte-goto)
(<= op byte-goto-if-not-nil-else-pop)))
(setq ptr (1+ ptr)) ;offset in next 2 bytes
(+ (aref bytes ptr)
(progn (setq ptr (1+ ptr))
(lsh (aref bytes ptr) 8))))
(t nil)))) ;no offset
(defun write-spaces (n &optional stream)
"Print N spaces to (optional) STREAM."
(or stream (setq stream standard-output))
(if (< n 0) (setq n 0))
(if (eq stream (current-buffer))
(insert-char ?\ n)
(while (> n 0)
(write-char ?\ stream)
(setq n (1- n)))))
(defconst byte-code-vector
'[<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
(varref . 1)
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
(varset . -1)
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
(varbind . 0);Pops a value, "pushes" a binding
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
(call . -); #'-, not -1!
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
(unbind . -);"pops" bindings
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
(nth . -1)
symbolp
consp
stringp
listp
(eq . -1)
(memq . -1)
not
car
cdr
(cons . -1)
list1
(list2 . -1)
(list3 . -2)
(list4 . -3)
length
(aref . -1)
(aset . -2)
symbol-value
symbol-function
(set . -1)
(fset . -1)
(get . -1)
(substring . -2)
(concat2 . -1)
(concat3 . -2)
(concat4 . -3)
sub1
add1
(eqlsign . -1) ;=
(gtr . -1) ;>
(lss . -1) ;<
(leq . -1) ;<=
(geq . -1) ;>=
(diff . -1) ;-
negate ;unary -
(plus . -1) ;+
(max . -1)
(min . -1)
<not-an-opcode>
(point . 1)
(mark\(obsolete\) . 1)
goto-char
insert
(point-max . 1)
(point-min . 1)
char-after
(following-char . 1)
(preceding-char . 1)
(current-column . 1)
(indent-to . 1)
(scan-buffer\(obsolete\) . -2)
(eolp . 1)
(eobp . 1)
(bolp . 1)
(bobp . 1)
(current-buffer . 1)
set-buffer
(read-char . 1)
set-mark\(obsolete\)
interactive-p
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
(constant2 . 1)
goto;>>>
goto-if-nil;>>
goto-if-not-nil;>>
(goto-if-nil-else-pop . -1)
(goto-if-not-nil-else-pop . -1)
return
(discard . -1)
(dup . 1)
(save-excursion . 1);Pushes a binding
(save-window-excursion . 1);Pushes a binding
(save-restriction . 1);Pushes a binding
(catch . -1);Takes one argument, returns a value
(unwind-protect . 1);Takes one argument, pushes a binding, returns a value
(condition-case . -2);Takes three arguments, returns a value
(temp-output-buffer-setup . -1)
temp-output-buffer-show
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
<not-an-opcode>
(constant . 1)
])