home *** CD-ROM | disk | FTP | other *** search
/ Dream 49 / Amiga_Dream_49.iso / atari / texte / 1857bin-d2.zoo / lisp / disass.el < prev    next >
Lisp/Scheme  |  1991-12-02  |  12KB  |  447 lines
  1. ;;; Disassembler for compiled Emacs Lisp code
  2. ;; Copyright (C) 1986 Free Software Foundation
  3. ;;; By Doug Cutting (doug@csli.stanford.edu)
  4.  
  5. ;; This file is part of GNU Emacs.
  6.  
  7. ;; GNU Emacs is free software; you can redistribute it and/or modify
  8. ;; it under the terms of the GNU General Public License as published by
  9. ;; the Free Software Foundation; either version 1, or (at your option)
  10. ;; any later version.
  11.  
  12. ;; GNU Emacs is distributed in the hope that it will be useful,
  13. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15. ;; GNU General Public License for more details.
  16.  
  17. ;; You should have received a copy of the GNU General Public License
  18. ;; along with GNU Emacs; see the file COPYING.  If not, write to
  19. ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  20.  
  21.  
  22. (require 'byte-compile "bytecomp")
  23.  
  24. (defvar disassemble-column-1-indent 4 "*")
  25.  
  26. (defvar disassemble-column-2-indent 9 "*")
  27.  
  28. (defvar disassemble-recursive-indent 3 "*")
  29.  
  30. ;(defun d (x)
  31. ;  (interactive "xDiss ")
  32. ;  (with-output-to-temp-buffer "*Disassemble*"
  33. ;    (disassemble-internal (list 'lambda '() x ''return-value)
  34. ;              standard-output 0 t)))
  35.  
  36. (defun disassemble (object &optional stream indent interactive-p)
  37.   "Print disassembled code for OBJECT on (optional) STREAM.
  38. OBJECT can be a function name, lambda expression or any function object
  39. returned by SYMBOL-FUNCTION.  If OBJECT is not already compiled, we will
  40. compile it (but not redefine it)."
  41.   (interactive (list (intern (completing-read "Disassemble function: "
  42.                           obarray 'fboundp t))
  43.              nil 0 t))
  44.   (or indent (setq indent 0))        ;Default indent to zero
  45.   (if interactive-p
  46.       (with-output-to-temp-buffer "*Disassemble*"
  47.     (disassemble-internal object standard-output indent t))
  48.     (disassemble-internal object (or stream standard-output) indent nil))
  49.   nil)
  50.  
  51. (defun disassemble-internal (obj stream indent interactive-p)
  52.   (let ((macro 'nil)
  53.     (name 'nil)
  54.     (doc 'nil)
  55.     args)
  56.     (while (symbolp obj)
  57.       (setq name obj
  58.         obj (symbol-function obj)))
  59.     (if (subrp obj)
  60.     (error "Can't disassemble #<subr %s>" name))
  61.     (if (eq (car obj) 'macro)        ;handle macros
  62.     (setq macro t
  63.           obj (cdr obj)))
  64.     (if (not (eq (car obj) 'lambda))
  65.     (error "not a function"))
  66.     (if (assq 'byte-code obj)
  67.     nil
  68.       (if interactive-p (message (if name
  69.                      "Compiling %s's definition..."
  70.                      "Compiling definition...")
  71.                  name))
  72.       (setq obj (byte-compile-lambda obj))
  73.       (if interactive-p (message "Done compiling.  Disassembling...")))
  74.     (setq obj (cdr obj))        ;throw lambda away
  75.     (setq args (car obj))        ;save arg list
  76.     (setq obj (cdr obj))
  77.     (write-spaces indent stream)
  78.     (princ (format "byte code%s%s%s:\n"
  79.            (if (or macro name) " for" "")
  80.            (if macro " macro" "")
  81.            (if name (format " %s" name) ""))
  82.        stream)
  83.     (let ((doc (and (stringp (car obj)) (car obj))))
  84.       (if doc
  85.       (progn (setq obj (cdr obj))
  86.          (write-spaces indent stream)
  87.          (princ " doc: " stream)
  88.          (princ doc stream)
  89.          (terpri stream))))
  90.     (write-spaces indent stream)
  91.     (princ " args: " stream)
  92.     (prin1 args stream)
  93.     (terpri stream)
  94.     (let ((interactive (car (cdr (assq 'interactive obj)))))
  95.       (if interactive
  96.       (progn (write-spaces indent stream)
  97.          (princ " interactive: " stream)
  98.          (if (eq (car-safe interactive) 'byte-code)
  99.              (disassemble-1 interactive stream
  100.                (+ indent disassemble-recursive-indent))
  101.            (prin1 interactive stream)
  102.            (terpri stream)))))
  103.     (setq obj (assq 'byte-code obj))    ;obj is now call to byte-code
  104.     (disassemble-1 obj stream indent))
  105.   (if interactive-p
  106.       (message "")))
  107.  
  108. (defun disassemble-1 (obj &optional stream indent)
  109.   "Prints the byte-code call OBJ to (optional) STREAM.
  110. OBJ should be a call to BYTE-CODE generated by the byte compiler."
  111.   (or indent (setq indent 0))        ;default indent to 0
  112.   (or stream (setq stream standard-output))
  113.   (let ((bytes (car (cdr obj)))        ;the byte code
  114.     (ptr -1)            ;where we are in it
  115.     (constants (car (cdr (cdr obj)))) ;constant vector
  116.     ;(next-indent indent)
  117.     offset tmp length)
  118.     (setq length (length bytes))
  119.     (terpri stream)
  120.     (while (< (setq ptr (1+ ptr)) length)
  121.       ;(setq indent next-indent)
  122.       (write-spaces indent stream)    ;indent to recursive indent
  123.       (princ (setq tmp (prin1-to-string ptr)) stream) ;print line #
  124.       (write-char ?\  stream)
  125.       (write-spaces (- disassemble-column-1-indent (length tmp) 1)
  126.             stream)
  127.       (setq op (aref bytes ptr))    ;fetch opcode
  128.       ;; Note: as offsets are either encoded in opcodes or stored as
  129.       ;; bytes in the code, this function (disassemble-offset)
  130.       ;; can set OP and/or PTR.
  131.       (setq offset (disassemble-offset));fetch offset
  132.       (setq tmp (aref byte-code-vector op))
  133.       (if (consp tmp)
  134.       (setq ;next-indent (if (numberp (cdr tmp))
  135.         ;        (+ indent (cdr tmp))
  136.         ;          (+ indent (funcall (cdr tmp) offset)))
  137.         tmp (car tmp)))
  138.       (setq tmp (symbol-name tmp))
  139.       (princ tmp stream)        ;print op-name for opcode
  140.       (if (null offset)
  141.       nil
  142.     (write-char ?\  stream)
  143.     (write-spaces (- disassemble-column-2-indent (length tmp) 1)
  144.               stream)        ;indent to col 2
  145.     (princ                ;print offset
  146.      (cond ((or (eq op byte-varref)
  147.             (eq op byte-varset)
  148.             (eq op byte-varbind))
  149.         ;; it's a varname (atom)
  150.         (aref constants offset)) ;fetch it from constants
  151.            ((or (eq op byte-goto)
  152.             (eq op byte-goto-if-nil)
  153.             (eq op byte-goto-if-not-nil)
  154.             (eq op byte-goto-if-nil-else-pop)
  155.             (eq op byte-goto-if-not-nil-else-pop)
  156.             (eq op byte-call)
  157.             (eq op byte-unbind))
  158.         ;; it's a number
  159.         offset)            ;return it
  160.            ((or (eq op byte-constant)
  161.             (eq op byte-constant2))
  162.         ;; it's a constant
  163.         (setq tmp (aref constants offset))
  164.         ;; but is constant byte code?
  165.         (cond ((and (eq (car-safe tmp) 'lambda)
  166.                 (assq 'byte-code tmp))
  167.                (princ "<compiled lambda>" stream)
  168.                (terpri stream)
  169.                (disassemble    ;recurse on compiled lambda
  170.              tmp
  171.              stream
  172.              (+ indent disassemble-recursive-indent))
  173.                "")
  174.               ((eq (car-safe tmp) 'byte-code)
  175.                (princ "<byte code>" stream)
  176.                (terpri stream)
  177.                (disassemble-1    ;recurse on byte-code object
  178.              tmp
  179.              stream
  180.              (+ indent disassemble-recursive-indent))
  181.                "")
  182.               ((eq (car-safe (car-safe tmp)) 'byte-code)
  183.                (princ "(<byte code>...)" stream)
  184.                (terpri stream)
  185.                (mapcar        ;recurse on list of byte-code objects
  186.              (function (lambda (obj)
  187.                      (disassemble-1
  188.                        obj
  189.                        stream
  190.                        (+ indent disassemble-recursive-indent))))
  191.              tmp)
  192.                "")
  193.               ((and (eq tmp 'byte-code) 
  194.                 (eq (aref bytes (+ ptr 4)) (+ byte-call 3)))
  195.                ;; this won't catch cases where args are pushed w/
  196.                ;; constant2.
  197.                (setq ptr (+ ptr 4))
  198.                "<compiled call to byte-code.  compiled code compiled?>")
  199.               (t
  200.                ;; really just a constant
  201.                (let ((print-escape-newlines t))
  202.              (prin1-to-string tmp)))))
  203.            (t "<error in disassembler>"))
  204.      stream))
  205.       (terpri stream)))
  206.   nil)
  207.  
  208.  
  209. (defun disassemble-offset ()
  210.   "Don't call this!"
  211.   ;; fetch and return the offset for the current opcode.
  212.   ;; return NIL if this opcode has no offset
  213.   ;; OP, PTR and BYTES are used and set dynamically
  214.   (let (tem)
  215.     (cond ((< op byte-nth)
  216.        (setq tem (logand op 7))
  217.        (setq op (logand op 248))
  218.        (cond ((eq tem 6)
  219.           (setq ptr (1+ ptr))    ;offset in next byte
  220.           (aref bytes ptr))
  221.          ((eq tem 7)
  222.           (setq ptr (1+ ptr))    ;offset in next 2 bytes
  223.           (+ (aref bytes ptr)
  224.              (progn (setq ptr (1+ ptr))
  225.                 (lsh (aref bytes ptr) 8))))
  226.          (t tem)))    ;offset was in opcode
  227.       ((>= op byte-constant)
  228.        (setq tem (- op byte-constant)) ;offset in opcode
  229.        (setq op byte-constant)
  230.        tem)
  231.       ((or (= op byte-constant2)
  232.            (and (>= op byte-goto)
  233.             (<= op byte-goto-if-not-nil-else-pop)))
  234.        (setq ptr (1+ ptr))        ;offset in next 2 bytes
  235.        (+ (aref bytes ptr)
  236.           (progn (setq ptr (1+ ptr))
  237.              (lsh (aref bytes ptr) 8))))
  238.       (t nil))))            ;no offset
  239.  
  240.  
  241. (defun write-spaces (n &optional stream)
  242.   "Print N spaces to (optional) STREAM."
  243.   (or stream (setq stream standard-output))
  244.   (if (< n 0) (setq n 0))
  245.   (if (eq stream (current-buffer))
  246.       (insert-char ?\  n)
  247.     (while (> n 0)
  248.       (write-char ?\  stream)
  249.       (setq n (1- n)))))
  250.  
  251. (defconst byte-code-vector
  252.  '[<not-an-opcode>
  253.    <not-an-opcode>
  254.    <not-an-opcode>
  255.    <not-an-opcode>
  256.    <not-an-opcode>
  257.    <not-an-opcode>
  258.    <not-an-opcode>
  259.    <not-an-opcode>
  260.    (varref . 1)
  261.    <not-an-opcode>
  262.    <not-an-opcode>
  263.    <not-an-opcode>
  264.    <not-an-opcode>
  265.    <not-an-opcode>
  266.    <not-an-opcode>
  267.    <not-an-opcode>
  268.    (varset . -1)
  269.    <not-an-opcode>
  270.    <not-an-opcode>
  271.    <not-an-opcode>
  272.    <not-an-opcode>
  273.    <not-an-opcode>
  274.    <not-an-opcode>
  275.    <not-an-opcode>
  276.    (varbind . 0);Pops a value, "pushes" a binding
  277.    <not-an-opcode>
  278.    <not-an-opcode>
  279.    <not-an-opcode>
  280.    <not-an-opcode>
  281.    <not-an-opcode>
  282.    <not-an-opcode>
  283.    <not-an-opcode>
  284.    (call . -); #'-, not -1!
  285.    <not-an-opcode>
  286.    <not-an-opcode>
  287.    <not-an-opcode>
  288.    <not-an-opcode>
  289.    <not-an-opcode>
  290.    <not-an-opcode>
  291.    <not-an-opcode>
  292.    (unbind . -);"pops" bindings
  293.    <not-an-opcode>
  294.    <not-an-opcode>
  295.    <not-an-opcode>
  296.    <not-an-opcode>
  297.    <not-an-opcode>
  298.    <not-an-opcode>
  299.    <not-an-opcode>
  300.    <not-an-opcode>
  301.    <not-an-opcode>
  302.    <not-an-opcode>
  303.    <not-an-opcode>
  304.    <not-an-opcode>
  305.    <not-an-opcode>
  306.    <not-an-opcode>
  307.    <not-an-opcode>
  308.    (nth . -1)
  309.    symbolp
  310.    consp
  311.    stringp
  312.    listp
  313.    (eq . -1)
  314.    (memq . -1)
  315.    not
  316.    car
  317.    cdr
  318.    (cons . -1)
  319.    list1
  320.    (list2 . -1)
  321.    (list3 . -2)
  322.    (list4 . -3)
  323.    length
  324.    (aref . -1)
  325.    (aset . -2)
  326.    symbol-value
  327.    symbol-function
  328.    (set . -1)
  329.    (fset . -1)
  330.    (get . -1)
  331.    (substring . -2)
  332.    (concat2 . -1)
  333.    (concat3 . -2)
  334.    (concat4 . -3)
  335.    sub1
  336.    add1
  337.    (eqlsign . -1) ;=
  338.    (gtr . -1)     ;>
  339.    (lss . -1)     ;<
  340.    (leq . -1)     ;<=
  341.    (geq . -1)     ;>=
  342.    (diff . -1)    ;-
  343.    negate         ;unary -
  344.    (plus . -1)    ;+
  345.    (max . -1)
  346.    (min . -1)
  347.    <not-an-opcode>
  348.    (point . 1)
  349.    (mark\(obsolete\) . 1)
  350.    goto-char 
  351.    insert
  352.    (point-max . 1)
  353.    (point-min . 1)
  354.    char-after
  355.    (following-char . 1)
  356.    (preceding-char . 1)
  357.    (current-column . 1)
  358.    (indent-to . 1)
  359.    (scan-buffer\(obsolete\) . -2)
  360.    (eolp . 1)
  361.    (eobp . 1)
  362.    (bolp . 1)
  363.    (bobp . 1)
  364.    (current-buffer . 1)
  365.    set-buffer
  366.    (read-char . 1)
  367.    set-mark\(obsolete\)
  368.    interactive-p
  369.    <not-an-opcode>
  370.    <not-an-opcode>
  371.    <not-an-opcode>
  372.    <not-an-opcode>
  373.    <not-an-opcode>
  374.    <not-an-opcode>
  375.    <not-an-opcode>
  376.    <not-an-opcode>
  377.    <not-an-opcode>
  378.    <not-an-opcode>
  379.    <not-an-opcode>
  380.    <not-an-opcode>
  381.    (constant2 . 1)
  382.    goto;>>>
  383.    goto-if-nil;>>
  384.    goto-if-not-nil;>>
  385.    (goto-if-nil-else-pop . -1)
  386.    (goto-if-not-nil-else-pop . -1)
  387.    return
  388.    (discard . -1)
  389.    (dup . 1)
  390.    (save-excursion . 1);Pushes a binding
  391.    (save-window-excursion . 1);Pushes a binding
  392.    (save-restriction . 1);Pushes a binding
  393.    (catch . -1);Takes one argument, returns a value
  394.    (unwind-protect . 1);Takes one argument, pushes a binding, returns a value
  395.    (condition-case . -2);Takes three arguments, returns a value
  396.    (temp-output-buffer-setup . -1)
  397.    temp-output-buffer-show
  398.    <not-an-opcode>
  399.    <not-an-opcode>
  400.    <not-an-opcode>
  401.    <not-an-opcode>
  402.    <not-an-opcode>
  403.    <not-an-opcode>
  404.    <not-an-opcode>
  405.    <not-an-opcode>
  406.    <not-an-opcode>
  407.    <not-an-opcode>
  408.    <not-an-opcode>
  409.    <not-an-opcode>
  410.    <not-an-opcode>
  411.    <not-an-opcode>
  412.    <not-an-opcode>
  413.    <not-an-opcode>
  414.    <not-an-opcode>
  415.    <not-an-opcode>
  416.    <not-an-opcode>
  417.    <not-an-opcode>
  418.    <not-an-opcode>
  419.    <not-an-opcode>
  420.    <not-an-opcode>
  421.    <not-an-opcode>
  422.    <not-an-opcode>
  423.    <not-an-opcode>
  424.    <not-an-opcode>
  425.    <not-an-opcode>
  426.    <not-an-opcode>
  427.    <not-an-opcode>
  428.    <not-an-opcode>
  429.    <not-an-opcode>
  430.    <not-an-opcode>
  431.    <not-an-opcode>
  432.    <not-an-opcode>
  433.    <not-an-opcode>
  434.    <not-an-opcode>
  435.    <not-an-opcode>
  436.    <not-an-opcode>
  437.    <not-an-opcode>
  438.    <not-an-opcode>
  439.    <not-an-opcode>
  440.    <not-an-opcode>
  441.    <not-an-opcode>
  442.    <not-an-opcode>
  443.    <not-an-opcode>
  444.    (constant . 1)
  445.    ])
  446.  
  447.