Function: disassemble-1

disassemble-1 is an autoloaded and byte-compiled function defined in disass.el.gz.

Signature

(disassemble-1 OBJ INDENT)

Documentation

Print the byte-code call OBJ in the current buffer.

OBJ should be a call to BYTE-CODE generated by the byte compiler.

Source Code

;; Defined in /usr/src/emacs/lisp/emacs-lisp/disass.el.gz
(defun disassemble-1 (obj indent)
  "Print the byte-code call OBJ in the current buffer.
OBJ should be a call to BYTE-CODE generated by the byte compiler."
  (let (bytes constvec)
    (if (consp obj)
	(setq bytes (car (cdr obj))		;the byte code
	      constvec (car (cdr (cdr obj))))	;constant vector
      (setq bytes (aref obj 1)
	    constvec (aref obj 2)))
    (cl-assert (not (multibyte-string-p bytes)))
    (let ((lap (byte-decompile-bytecode bytes constvec))
	  op arg opname pc-value)
      (let ((tagno 0)
	    tmp
	    (lap lap))
	(while (setq tmp (assq 'TAG lap))
	  (setcar (cdr tmp) (setq tagno (1+ tagno)))
	  (setq lap (cdr (memq tmp lap)))))
      (while lap
	;; Take off the pc value of the next thing
	;; and put it in pc-value.
	(setq pc-value nil)
	(if (numberp (car lap))
	    (setq pc-value (car lap)
		  lap (cdr lap)))
	;; Fetch the next op and its arg.
	(setq op (car (car lap))
	      arg (cdr (car lap)))
	(setq lap (cdr lap))
	(indent-to indent)
	(if (eq 'TAG op)
	    (progn
	      ;; We have a label.  Display it, but first its pc value.
	      (if pc-value
		  (insert (format "%d:" pc-value)))
	      (insert (int-to-string (car arg))))
	  ;; We have an instruction.  Display its pc value first.
	  (if pc-value
	      (insert (format "%d" pc-value)))
	  (indent-to (+ indent disassemble-column-1-indent))
	  (if (and op
		   (string-match "^byte-" (setq opname (symbol-name op))))
	      (setq opname (substring opname 5))
	    (setq opname "<not-an-opcode>"))
	  (if (eq op 'byte-constant2)
	      (insert " #### shouldn't have seen constant2 here!\n  "))
	  (insert opname)
	  (indent-to (+ indent disassemble-column-1-indent
			disassemble-column-2-indent
			-1))
	  (insert " ")
	  (cond ((memq op byte-goto-ops)
		 (insert (int-to-string (nth 1 arg))))
		((memq op '(byte-call byte-unbind
			    byte-listN byte-concatN byte-insertN
			    byte-stack-ref byte-stack-set byte-stack-set2
			    byte-discardN byte-discardN-preserve-tos))
		 (insert (int-to-string arg)))
		((memq op '(byte-varref byte-varset byte-varbind))
		 (prin1 (car arg) (current-buffer)))
		((memq op '(byte-constant byte-constant2))
		 ;; it's a constant
		 (setq arg (car arg))
                 ;; if the succeeding op is byte-switch, display the jump table
                 ;; used
		 (cond ((eq (car-safe (car-safe (cdr lap))) 'byte-switch)
                        (insert (format "<jump-table-%s (" (hash-table-test arg)))
                        (let ((first-time t))
                          (maphash #'(lambda (value tag)
                                       (if first-time
                                           (setq first-time nil)
                                         (insert " "))
                                       (insert (format "%s %s" value (cadr tag))))
                                   arg))
                        (insert ")>"))
                       ;; if the value of the constant is compiled code, then
                       ;; recursively disassemble it.
                       ((or (byte-code-function-p arg)
			    (and (eq (car-safe arg) 'macro)
				 (byte-code-function-p (cdr arg))))
			(cond ((byte-code-function-p arg)
			       (insert "<byte-code-function>\n"))
			      (t (insert "<compiled macro>\n")))
			(disassemble-internal
			 arg
			 (+ indent disassemble-recursive-indent 1)
			 nil))
		       ((eq (car-safe arg) 'byte-code)
			(insert "<byte code>\n")
			(disassemble-1	;recurse on byte-code object
			 arg
			 (+ indent disassemble-recursive-indent)))
		       ((eq (car-safe (car-safe arg)) 'byte-code)
			;; FIXME: I'm 99% sure bytecomp never generates
			;; this any more.
			(insert "(<byte code>...)\n")
			(mapc      ;Recurse on list of byte-code objects.
			 (lambda (obj)
                           (disassemble-1
                            obj
                            (+ indent disassemble-recursive-indent)))
			 arg))
		       (t
			;; really just a constant
			(let ((print-escape-newlines t))
			  (prin1 arg (current-buffer))))))
		)
	  (insert "\n")))))
  nil)