home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / elisp / packages / bytecomp / disass.el < prev    next >
Encoding:
Text File  |  1992-07-02  |  7.4 KB  |  225 lines
  1. ;;; Disassembler for compiled Emacs Lisp code
  2. ;;; Copyright (C) 1986 Free Software Foundation, Inc.
  3. ;;; Original version by Doug Cutting (doug@csli.stanford.edu)
  4. ;;; Substantially modified by Jamie Zawinski <jwz@lucid.com> for
  5. ;;; the new lapcode-based byte compiler.
  6. ;;; Last modified 22-oct-91.
  7.  
  8. ;; This file is part of GNU Emacs.
  9.  
  10. ;; GNU Emacs is free software; you can redistribute it and/or modify
  11. ;; it under the terms of the GNU General Public License as published by
  12. ;; the Free Software Foundation; either version 1, or (at your option)
  13. ;; any later version.
  14.  
  15. ;; GNU Emacs is distributed in the hope that it will be useful,
  16. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18. ;; GNU General Public License for more details.
  19.  
  20. ;; You should have received a copy of the GNU General Public License
  21. ;; along with GNU Emacs; see the file COPYING.  If not, write to
  22. ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  23.  
  24.  
  25. ;;; The variable byte-code-vector is defined by the new bytecomp.el.
  26. ;;; The function byte-decompile-lapcode is defined in byte-optimize.el.
  27. (require 'byte-optimize)
  28.  
  29. (defvar disassemble-column-1-indent 5 "*")
  30. (defvar disassemble-column-2-indent 10 "*")
  31.  
  32. (defvar disassemble-recursive-indent 3 "*")
  33.  
  34. (defun disassemble (object &optional buffer indent interactive-p)
  35.   "Print disassembled code for OBJECT in (optional) BUFFER.
  36. OBJECT can be a symbol defined as a function, or a function itself
  37. \(a lambda expression or a compiled-function object).
  38. If OBJECT is not already compiled, we compile it, but do not
  39. redefine OBJECT if it is a symbol."
  40.   (interactive (list (intern (completing-read "Disassemble function: "
  41.                           obarray 'fboundp t))
  42.              nil 0 t))
  43.   (if (eq (car-safe object) 'byte-code)
  44.       (setq object (list 'lambda () object)))
  45.   (or indent (setq indent 0))        ;Default indent to zero
  46.   (save-excursion
  47.     (if (or interactive-p (null buffer))
  48.     (with-output-to-temp-buffer "*Disassemble*"
  49.       (set-buffer "*Disassemble*")
  50.       (disassemble-internal object indent (not interactive-p)))
  51.       (set-buffer buffer)
  52.       (disassemble-internal object indent nil)))
  53.   nil)
  54.  
  55.  
  56. (defun disassemble-internal (obj indent interactive-p)
  57.   (let ((macro 'nil)
  58.     (name 'nil)
  59.     (doc 'nil)
  60.     args)
  61.     (while (symbolp obj)
  62.       (setq name obj
  63.         obj (symbol-function obj)))
  64.     (if (subrp obj)
  65.     (error "Can't disassemble #<subr %s>" name))
  66.     (if (eq (car-safe obj) 'macro)    ;handle macros
  67.     (setq macro t
  68.           obj (cdr obj)))
  69.     (if (and (listp obj) (not (eq (car obj) 'lambda)))
  70.     (error "not a function"))
  71.     (if (consp obj)
  72.     (if (assq 'byte-code obj)
  73.         nil
  74.       (if interactive-p (message (if name
  75.                      "Compiling %s's definition..."
  76.                        "Compiling definition...")
  77.                      name))
  78.       (setq obj (byte-compile obj))
  79.       (if interactive-p (message "Done compiling.  Disassembling..."))))
  80.     (cond ((consp obj)
  81.        (setq obj (cdr obj))        ;throw lambda away
  82.        (setq args (car obj))    ;save arg list
  83.        (setq obj (cdr obj)))
  84.       (t
  85.        (setq args (aref obj 0))))
  86.     (if (zerop indent) ; not a nested function
  87.     (progn
  88.       (indent-to indent)
  89.       (insert (format "byte code%s%s%s:\n"
  90.               (if (or macro name) " for" "")
  91.               (if macro " macro" "")
  92.               (if name (format " %s" name) "")))))
  93.     (let ((doc (if (consp obj)
  94.            (and (stringp (car obj)) (car obj))
  95.          (and (> (length obj) 4) (aref obj 4)))))
  96.       (if (and doc (stringp doc))
  97.       (progn (and (consp obj) (setq obj (cdr obj)))
  98.          (indent-to indent)
  99.          (princ "  doc:  " (current-buffer))
  100.          (if (string-match "\n" doc)
  101.              (setq doc (concat (substring doc 0 (match-beginning 0))
  102.                        " ...")))
  103.          (insert doc "\n"))))
  104.     (indent-to indent)
  105.     (insert "  args: ")
  106.     (prin1 args (current-buffer))
  107.     (insert "\n")
  108.     (let ((interactive (cond ((consp obj)
  109.                   (assq 'interactive obj))
  110.                  ((> (length obj) 5)
  111.                   (list 'interactive (aref obj 5))))))
  112.       (if interactive
  113.       (progn
  114.         (setq interactive (nth 1 interactive))
  115.         (if (eq (car-safe (car-safe obj)) 'interactive)
  116.         (setq obj (cdr obj)))
  117.         (indent-to indent)
  118.         (insert " interactive: ")
  119.         (if (eq (car-safe interactive) 'byte-code)
  120.         (progn
  121.           (insert "\n")
  122.           (disassemble-1 interactive
  123.                  (+ indent disassemble-recursive-indent)))
  124.           (let ((print-escape-newlines t))
  125.         (prin1 interactive (current-buffer))))
  126.         (insert "\n"))))
  127.     (cond ((and (consp obj) (assq 'byte-code obj))
  128.        (disassemble-1 (assq 'byte-code obj) indent))
  129.       ((compiled-function-p obj)
  130.        (disassemble-1 obj indent))
  131.       (t
  132.        (insert "Uncompiled body:  ")
  133.        (let ((print-escape-newlines t))
  134.          (prin1 (if (cdr obj) (cons 'progn obj) (car obj))
  135.             (current-buffer))))))
  136.   (if interactive-p
  137.       (message "")))
  138.  
  139.  
  140. (defun disassemble-1 (obj indent)
  141.   "Prints the byte-code call OBJ in the current buffer.
  142. OBJ should be a call to BYTE-CODE generated by the byte compiler."
  143.   (let (bytes constvec)
  144.     (if (consp obj)
  145.     (setq bytes (car (cdr obj))        ;the byte code
  146.           constvec (car (cdr (cdr obj))))    ;constant vector
  147.       (setq bytes (aref obj 1)
  148.         constvec (aref obj 2)))
  149.     (let ((lap (byte-decompile-bytecode bytes constvec))
  150.       op arg opname)
  151.       (let ((tagno 0)
  152.         tmp
  153.         (lap lap))
  154.     (while (setq tmp (assq 'TAG lap))
  155.       (setcar (cdr tmp) (setq tagno (1+ tagno)))
  156.       (setq lap (cdr (memq tmp lap)))))
  157.       (while lap
  158.     (setq op (car (car lap))
  159.           arg (cdr (car lap)))
  160.     (indent-to indent)
  161.     (if (eq 'TAG op)
  162.         (insert (int-to-string (car arg)) ":")
  163.  
  164.       (indent-to (+ indent disassemble-column-1-indent))
  165.       (if (and op
  166.            (string-match "^byte-" (setq opname (symbol-name op))))
  167.           (setq opname (substring opname 5))
  168.         (setq opname "<not-an-opcode>"))
  169.       (if (eq op 'byte-constant2)
  170.           (insert " #### shouldn't have seen constant2 here!\n  "))
  171.       (insert opname)
  172.       (indent-to (+ indent disassemble-column-1-indent
  173.             disassemble-column-2-indent
  174.             -1))
  175.       (insert " ")
  176.       (cond ((memq op byte-goto-ops)
  177.          (insert (int-to-string (nth 1 arg))))
  178.         ((memq op '(byte-call byte-unbind
  179.                 byte-listN byte-concatN byte-insertN))
  180.          (insert (int-to-string arg)))
  181.         ((memq op '(byte-varref byte-varset byte-varbind))
  182.          (prin1 (car arg) (current-buffer)))
  183.         ((memq op '(byte-constant byte-constant2))
  184.          ;; it's a constant
  185.          (setq arg (car arg))
  186.          ;; but if the value of the constant is compiled code, then
  187.          ;; recursively disassemble it.
  188.          (cond ((or (compiled-function-p arg)
  189.                 (and (eq (car-safe arg) 'lambda)
  190.                  (assq 'byte-code arg))
  191.                 (and (eq (car-safe arg) 'macro)
  192.                  (or (compiled-function-p (cdr arg))
  193.                      (and (eq (car-safe (cdr arg)) 'lambda)
  194.                       (assq 'byte-code (cdr arg))))))
  195.             (cond ((compiled-function-p arg)
  196.                    (insert "<compiled-function>\n"))
  197.                   ((eq (car-safe arg) 'lambda)
  198.                    (insert "<compiled lambda>"))
  199.                   (t (insert "<compiled macro>\n")))
  200.             (disassemble-internal
  201.              arg
  202.              (+ indent disassemble-recursive-indent 1)
  203.              nil))
  204.                ((eq (car-safe arg) 'byte-code)
  205.             (insert "<byte code>\n")
  206.             (disassemble-1    ;recurse on byte-code object
  207.              arg
  208.              (+ indent disassemble-recursive-indent)))
  209.                ((eq (car-safe (car-safe arg)) 'byte-code)
  210.             (insert "(<byte code>...)\n")
  211.             (mapcar ;recurse on list of byte-code objects
  212.              '(lambda (obj)
  213.                 (disassemble-1
  214.                  obj
  215.                  (+ indent disassemble-recursive-indent)))
  216.              arg))
  217.                (t
  218.             ;; really just a constant
  219.             (let ((print-escape-newlines t))
  220.               (prin1 arg (current-buffer))))))
  221.         )
  222.       (insert "\n"))
  223.     (setq lap (cdr lap)))))
  224.   nil)
  225.