;;; 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)
   ])