home *** CD-ROM | disk | FTP | other *** search
/ Fresh Fish 4 / FreshFish_May-June1994.bin / bbs / may94 / util / edit / jade.lha / Jade / lisp / disassembler.jl < prev    next >
Lisp/Scheme  |  1994-04-16  |  6KB  |  247 lines
  1. ;;;; disassembler.jl -- Disassembles compiled Lisp functions
  2. ;;;  Copyright (C) 1993, 1994 John Harper <jsh@ukc.ac.uk>
  3.  
  4. ;;; This file is part of Jade.
  5.  
  6. ;;; Jade is free software; you can redistribute it and/or modify it
  7. ;;; under the terms of the GNU General Public License as published by
  8. ;;; the Free Software Foundation; either version 2, or (at your option)
  9. ;;; any later version.
  10.  
  11. ;;; Jade is distributed in the hope that it will be useful, but
  12. ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14. ;;; GNU General Public License for more details.
  15.  
  16. ;;; You should have received a copy of the GNU General Public License
  17. ;;; along with Jade; see the file COPYING.  If not, write to
  18. ;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  19.  
  20. ;; need this for the opcode constants
  21. (require 'compiler)
  22. (provide 'disassembler)
  23.  
  24. (defun disassemble-fun (fun &optional stream)
  25.   "(disassemble-fun FUN [STREAM])
  26. Disassembles the lisp-code form which is the function value of FUN. If
  27. STREAM is given prints to that stream."
  28.   (when (symbolp fun)
  29.     (setq fun (symbol-function fun)))
  30.   (if (eq (car fun) 'macro)
  31.       (setq fun (nthcdr 3 fun))
  32.     (setq fun (nthcdr 2 fun)))
  33.   (disassemble (car (if (or (stringp (car fun)) (numberp (car fun))) (cdr fun) fun)) stream))
  34.  
  35. ;; Disassembles the LISP-CODE form, output goes to STREAM
  36. (defun disassemble (lisp-code &optional stream)
  37.   (let
  38.       ((code-string (nth 1 lisp-code))
  39.        (consts (nth 2 lisp-code))
  40.        (i 0)
  41.        (screen-tab 24)
  42.        c arg op)
  43.     (unless stream
  44.       (setq stream standard-output))
  45.     (while (setq c (aref code-string i))
  46.       (format stream "\n%d:\t" i)
  47.       (cond
  48.     ((< c op-last-with-args)
  49.       (setq op (bit-and c 0xf8))
  50.       (cond
  51.         ((< (bit-and c 0x07) 6)
  52.           (setq arg (bit-and c 0x07)))
  53.         ((= (bit-and c 0x07) 6)
  54.           (setq
  55.         i (1+ i)
  56.         arg (bit-and (aref code-string i) 0x7f)))
  57.         (t
  58.           (setq
  59.         arg (bit-or (lsh (bit-and (aref code-string (1+ i)) 0x7f) 7)
  60.                 (bit-and (aref code-string (+ i 2)) 0x7f))
  61.         i (+ i 2))))
  62.       (cond
  63.         ((= op op-call)
  64.           (format stream "call\t#%d" arg))
  65.         ((= op op-push)
  66.           (let
  67.           ((argobj (aref consts arg)))
  68.         (if (and (consp argobj) (eq (car argobj) 'lisp-code))
  69.             (progn
  70.               (format stream "push\t[%d] %S\n<lisp-code" arg argobj)
  71.               (disassemble argobj stream)
  72.               (write stream "\n>"))
  73.           (format stream "push\t[%d] %S" arg (aref consts arg)))))
  74.         ((= op op-vrefc)
  75.           (format stream "vrefc\t[%d] %S" arg (aref consts arg)))
  76.         ((= op op-vsetc)
  77.           (format stream "vsetc\t[%d] %S" arg (aref consts arg)))
  78.         ((= op op-list)
  79.           (format stream "list\t#%d" arg))
  80.         ((= op op-bind)
  81.           (format stream "bind\t[%d] %S" arg (aref consts arg)))))
  82.     ((> c op-last-before-jmps)
  83.       (setq
  84.         arg (bit-or (lsh (bit-and (aref code-string (1+ i)) 0x7f) 7)
  85.             (bit-and (aref code-string (+ i 2)) 0x7f))
  86.         op c
  87.         i (+ i 2))
  88.       (format stream
  89.         (cond
  90.           ((= op op-jmp)
  91.         "jmp\t%d")
  92.           ((= op op-jmp-nil)
  93.         "jmp-nil\t%d")
  94.           ((= op op-jmp-t)
  95.         "jmp-t\t%d")
  96.           ((= op op-jmp-nil-else-pop)
  97.         "jmp-nil-else-pop\t%d")
  98.           ((= op op-jmp-t-else-pop)
  99.         "jmp-t-else-pop\t%d"))
  100.         arg))
  101.     (t
  102.       (setq op c)
  103.       (write stream
  104.         (cond
  105.           ((= op op-pop)
  106.         "pop")
  107.           ((= op op-vref)
  108.         "vref")
  109.           ((= op op-vset)
  110.         "vset")
  111.           ((= op op-fref)
  112.         "fref")
  113.           ((= op op-fset)
  114.         "fset")
  115.           ((= op op-init-bind)
  116.         "init-bind")
  117.           ((= op op-unbind)
  118.         "unbind")
  119.           ((= op op-dup)
  120.         "dup")
  121.           ((= op op-swap)
  122.         "swap")
  123.           ((= op op-nil)
  124.         "nil")
  125.           ((= op op-t)
  126.         "t")
  127.           ((= op op-cons)
  128.         "cons")
  129.           ((= op op-car)
  130.         "car")
  131.           ((= op op-cdr)
  132.         "cdr")
  133.           ((= op op-rplaca)
  134.         "rplaca")
  135.           ((= op op-rplacd)
  136.         "rplacd")
  137.           ((= op op-nth)
  138.         "nth")
  139.           ((= op op-nthcdr)
  140.         "nthcdr")
  141.           ((= op op-aset)
  142.         "aset")
  143.           ((= op op-aref)
  144.         "aref")
  145.           ((= op op-length)
  146.         "length")
  147.           ((= op op-eval)
  148.         "eval")
  149.           ((= op op-plus-2)
  150.         "plus-2")
  151.           ((= op op-negate)
  152.         "negate")
  153.           ((= op op-minus-2)
  154.         "minus-2")
  155.           ((= op op-product-2)
  156.         "product-2")
  157.           ((= op op-divide-2)
  158.         "divide-2")
  159.           ((= op op-mod-2)
  160.         "mod-2")
  161.           ((= op op-bit-not)
  162.         "bit-not")
  163.           ((= op op-not)
  164.         "not")
  165.           ((= op op-bit-or-2)
  166.         "bit-or-2")
  167.           ((= op op-bit-and-2)
  168.         "bit-and-2")
  169.           ((= op op-equal)
  170.         "equal")
  171.           ((= op op-eq)
  172.         "eq")
  173.           ((= op op-num-eq)
  174.         "num-eq")
  175.           ((= op op-num-noteq)
  176.         "num-noteq")
  177.           ((= op op-gtthan)
  178.         "gtthan")
  179.           ((= op op-gethan)
  180.         "gethan")
  181.           ((= op op-ltthan)
  182.         "ltthan")
  183.           ((= op op-lethan)
  184.         "lethan")
  185.           ((= op op-inc)
  186.         "inc")
  187.           ((= op op-dec)
  188.         "dec")
  189.           ((= op op-lsh)
  190.         "lsh")
  191.           ((= op op-zerop)
  192.         "zerop")
  193.           ((= op op-null)
  194.         "null")
  195.           ((= op op-atom)
  196.         "atom")
  197.           ((= op op-consp)
  198.         "consp")
  199.           ((= op op-listp)
  200.         "listp")
  201.           ((= op op-numberp)
  202.         "numberp")
  203.           ((= op op-stringp)
  204.         "stringp")
  205.           ((= op op-vectorp)
  206.         "vectorp")
  207.           ((= op op-catch-kludge)
  208.         "catch-kludge")
  209.           ((= op op-throw)
  210.         "throw")
  211.           ((= op op-unwind-pro)
  212.         "unwind-pro")
  213.           ((= op op-un-unwind-pro)
  214.         "un-unwind-pro")
  215.           ((= op op-fboundp)
  216.         "fboundp")
  217.           ((= op op-boundp)
  218.         "boundp")
  219.           ((= op op-symbolp)
  220.         "symbolp")
  221.           ((= op op-get)
  222.         "get")
  223.           ((= op op-put)
  224.         "put")
  225.           ((= op op-error-pro)
  226.         "error-pro")
  227.           ((= op op-signal)
  228.         "signal")
  229.           ((= op op-set-current-buffer)
  230.         "set-current-buffer")
  231.           ((= op op-swap-buffer)
  232.         "swap-buffer")
  233.           ((= op op-current-buffer)
  234.         "current-buffer")
  235.           ((= op op-bufferp)
  236.         "bufferp")
  237.           ((= op op-mark-p)
  238.         "mark-p")
  239.           ((= op op-windowp)
  240.         "windowp")
  241.           ((= op op-swap-window)
  242.         "swap-window")
  243.           (t
  244.         (format-string "<unknown %d>" op))))))
  245.       (setq i (1+ i)))
  246.     t))
  247.