Function: disassemble-internal

disassemble-internal is a byte-compiled function defined in disass.el.gz.

Signature

(disassemble-internal OBJ INDENT INTERACTIVE-P)

Source Code

;; Defined in /usr/src/emacs/lisp/emacs-lisp/disass.el.gz
(cl-defun disassemble-internal (obj indent interactive-p)
  (let ((macro 'nil)
	(name (when (symbolp obj)
                (prog1 obj
                  (setq obj (indirect-function obj)))))
	args)
    (setq obj (autoload-do-load obj name))
    (if (subrp obj)
        (if (and (fboundp 'subr-native-elisp-p)
                 (subr-native-elisp-p obj))
            (progn
              (require 'comp)
              (let ((eln (native-comp-unit-file (subr-native-comp-unit obj))))
                (if (file-exists-p eln)
                    (call-process "objdump" nil (current-buffer) t "-S" eln)
                  (error "Missing eln file for #<subr %s>" name)))
              (goto-char (point-min))
              (re-search-forward (concat "^.*<_?"
                                         (regexp-quote
                                          (comp-c-func-name
                                           (subr-name obj) "F" t))
                                         ">:"))
              (beginning-of-line)
              (delete-region (point-min) (point))
              (when (re-search-forward "^.*<.*>:" nil t 2)
                (delete-region (match-beginning 0) (point-max)))
              (asm-mode)
              (setq buffer-read-only t)
              (cl-return-from disassemble-internal))
	  (error "Can't disassemble #<subr %s>" name)))
    (if (eq (car-safe obj) 'macro)	;Handle macros.
	(setq macro t
	      obj (cdr obj)))
    (if (eq (car-safe obj) 'byte-code)
	(setq obj `(lambda () ,obj)))
    (when (consp obj)
      (unless (functionp obj) (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 obj))
        (if interactive-p (message "Done compiling.  Disassembling..."))))
    (cond ((consp obj)
	   (setq args (help-function-arglist obj))	;save arg list
	   (setq obj (cdr obj))		;throw lambda away
	   (setq obj (cdr obj)))
	  ((byte-code-function-p obj)
	   (setq args (help-function-arglist obj)))
          (t (error "Compilation failed")))
    (if (zerop indent) ; not a nested function
	(progn
	  (indent-to indent)
	  (insert (format "byte code%s%s%s:\n"
			  (if (or macro name) " for" "")
			  (if macro " macro" "")
			  (if name (format " %s" name) "")))))
    (let ((doc (if (consp obj)
		   (and (stringp (car obj)) (car obj))
		 ;; Use documentation to get lazy-loaded doc string
		 (documentation obj t))))
      (if (and doc (stringp doc))
	  (progn (and (consp obj) (setq obj (cdr obj)))
		 (indent-to indent)
		 (princ "  doc:  " (current-buffer))
		 (if (string-match "\n" doc)
		     (setq doc (concat (substring doc 0 (match-beginning 0))
				       " ...")))
		 (insert doc "\n"))))
    (indent-to indent)
    (insert "  args: ")
    (prin1 args (current-buffer))
    (insert "\n")
    (let ((interactive (interactive-form obj)))
      (if interactive
	  (progn
	    (setq interactive (nth 1 interactive))
	    (if (eq (car-safe (car-safe obj)) 'interactive)
		(setq obj (cdr obj)))
	    (indent-to indent)
	    (insert " interactive: ")
	    (if (eq (car-safe interactive) 'byte-code)
		(progn
		  (insert "\n")
		  (disassemble-1 interactive
				 (+ indent disassemble-recursive-indent)))
	      (let ((print-escape-newlines t))
		(prin1 interactive (current-buffer))))
	    (insert "\n"))))
    (cond ((and (consp obj) (assq 'byte-code obj))
	   (disassemble-1 (assq 'byte-code obj) indent))
	  ((byte-code-function-p obj)
	   (disassemble-1 obj indent))
	  (t
	   (insert "Uncompiled body:  ")
	   (let ((print-escape-newlines t))
	     (prin1 (macroexp-progn obj)
		    (current-buffer))))))
  (if interactive-p
      (message "")))