![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to disass.el CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Apple XNU] / GNUtools / emacs / lisp|
Return to disass.el CVS log | Up to [Apple XNU] / GNUtools / emacs / lisp |
1.1 ! root 1: ;;; Disassembler for compiled Emacs Lisp code ! 2: ;; Copyright (C) 1986 Free Software Foundation ! 3: ;;; By Doug Cutting ([email protected]) ! 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:
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.