![[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 [CSRG BSD Unix] / 43BSDReno / contrib / emacs-18.55 / lisp|
Return to disass.el CVS log | Up to [CSRG BSD Unix] / 43BSDReno / contrib / emacs-18.55 / 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 distributed in the hope that it will be useful, ! 8: ;; but WITHOUT ANY WARRANTY. No author or distributor ! 9: ;; accepts responsibility to anyone for the consequences of using it ! 10: ;; or for whether it serves any particular purpose or works at all, ! 11: ;; unless he says so in writing. Refer to the GNU Emacs General Public ! 12: ;; License for full details. ! 13: ! 14: ;; Everyone is granted permission to copy, modify and redistribute ! 15: ;; GNU Emacs, but only under the conditions described in the ! 16: ;; GNU Emacs General Public License. A copy of this license is ! 17: ;; supposed to have been given to you along with GNU Emacs so you ! 18: ;; can know your rights and responsibilities. It should be in a ! 19: ;; file named COPYING. Among other things, the copyright notice ! 20: ;; and this notice must be preserved on all copies. ! 21: ! 22: ! 23: (require 'byte-compile "bytecomp") ! 24: ! 25: (defvar disassemble-column-1-indent 4 "*") ! 26: ! 27: (defvar disassemble-column-2-indent 9 "*") ! 28: ! 29: (defvar disassemble-recursive-indent 3 "*") ! 30: ! 31: ;(defun d (x) ! 32: ; (interactive "xDiss ") ! 33: ; (with-output-to-temp-buffer "*Disassemble*" ! 34: ; (disassemble-internal (list 'lambda '() x ''return-value) ! 35: ; standard-output 0 t))) ! 36: ! 37: (defun disassemble (object &optional stream indent interactive-p) ! 38: "Print disassembled code for OBJECT on (optional) STREAM. ! 39: OBJECT can be a function name, lambda expression or any function object ! 40: returned by SYMBOL-FUNCTION. If OBJECT is not already compiled, we will ! 41: compile it (but not redefine it)." ! 42: (interactive (list (intern (completing-read "Disassemble function: " ! 43: obarray 'fboundp t)) ! 44: nil 0 t)) ! 45: (or indent (setq indent 0)) ;Default indent to zero ! 46: (if interactive-p ! 47: (with-output-to-temp-buffer "*Disassemble*" ! 48: (disassemble-internal object standard-output indent t)) ! 49: (disassemble-internal object (or stream standard-output) indent nil)) ! 50: nil) ! 51: ! 52: (defun disassemble-internal (obj stream indent interactive-p) ! 53: (let ((macro 'nil) ! 54: (name 'nil) ! 55: (doc 'nil) ! 56: args) ! 57: (while (symbolp obj) ! 58: (setq name obj ! 59: obj (symbol-function obj))) ! 60: (if (subrp obj) ! 61: (error "Can't disassemble #<subr %s>" name)) ! 62: (if (eq (car obj) 'macro) ;handle macros ! 63: (setq macro t ! 64: obj (cdr obj))) ! 65: (if (not (eq (car obj) 'lambda)) ! 66: (error "not a function")) ! 67: (if (assq 'byte-code obj) ! 68: nil ! 69: (if interactive-p (message (if name ! 70: "Compiling %s's definition..." ! 71: "Compiling definition...") ! 72: name)) ! 73: (setq obj (byte-compile-lambda obj)) ! 74: (if interactive-p (message "Done compiling. Disassembling..."))) ! 75: (setq obj (cdr obj)) ;throw lambda away ! 76: (setq args (car obj)) ;save arg list ! 77: (setq obj (cdr obj)) ! 78: (write-spaces indent stream) ! 79: (princ (format "byte code%s%s%s:\n" ! 80: (if (or macro name) " for" "") ! 81: (if macro " macro" "") ! 82: (if name (format " %s" name) "")) ! 83: stream) ! 84: (let ((doc (and (stringp (car obj)) (car obj)))) ! 85: (if doc ! 86: (progn (setq obj (cdr obj)) ! 87: (write-spaces indent stream) ! 88: (princ " doc: " stream) ! 89: (princ doc stream) ! 90: (terpri stream)))) ! 91: (write-spaces indent stream) ! 92: (princ " args: " stream) ! 93: (prin1 args stream) ! 94: (terpri stream) ! 95: (let ((interactive (car (cdr (assq 'interactive obj))))) ! 96: (if interactive ! 97: (progn (write-spaces indent stream) ! 98: (princ " interactive: " stream) ! 99: (if (eq (car-safe interactive) 'byte-code) ! 100: (disassemble-1 interactive stream ! 101: (+ indent disassemble-recursive-indent)) ! 102: (prin1 interactive stream) ! 103: (terpri stream))))) ! 104: (setq obj (assq 'byte-code obj)) ;obj is now call to byte-code ! 105: (disassemble-1 obj stream indent)) ! 106: (if interactive-p ! 107: (message ""))) ! 108: ! 109: (defun disassemble-1 (obj &optional stream indent) ! 110: "Prints the byte-code call OBJ to (optional) STREAM. ! 111: OBJ should be a call to BYTE-CODE generated by the byte compiler." ! 112: (or indent (setq indent 0)) ;default indent to 0 ! 113: (or stream (setq stream standard-output)) ! 114: (let ((bytes (car (cdr obj))) ;the byte code ! 115: (ptr -1) ;where we are in it ! 116: (constants (car (cdr (cdr obj)))) ;constant vector ! 117: ;(next-indent indent) ! 118: offset tmp length) ! 119: (setq length (length bytes)) ! 120: (terpri stream) ! 121: (while (< (setq ptr (1+ ptr)) length) ! 122: ;(setq indent next-indent) ! 123: (write-spaces indent stream) ;indent to recursive indent ! 124: (princ (setq tmp (prin1-to-string ptr)) stream) ;print line # ! 125: (write-char ?\ stream) ! 126: (write-spaces (- disassemble-column-1-indent (length tmp) 1) ! 127: stream) ! 128: (setq op (aref bytes ptr)) ;fetch opcode ! 129: ;; Note: as offsets are either encoded in opcodes or stored as ! 130: ;; bytes in the code, this function (disassemble-offset) ! 131: ;; can set OP and/or PTR. ! 132: (setq offset (disassemble-offset));fetch offset ! 133: (setq tmp (aref byte-code-vector op)) ! 134: (if (consp tmp) ! 135: (setq ;next-indent (if (numberp (cdr tmp)) ! 136: ; (+ indent (cdr tmp)) ! 137: ; (+ indent (funcall (cdr tmp) offset))) ! 138: tmp (car tmp))) ! 139: (setq tmp (symbol-name tmp)) ! 140: (princ tmp stream) ;print op-name for opcode ! 141: (if (null offset) ! 142: nil ! 143: (write-char ?\ stream) ! 144: (write-spaces (- disassemble-column-2-indent (length tmp) 1) ! 145: stream) ;indent to col 2 ! 146: (princ ;print offset ! 147: (cond ((or (eq op byte-varref) ! 148: (eq op byte-varset) ! 149: (eq op byte-varbind)) ! 150: ;; it's a varname (atom) ! 151: (aref constants offset)) ;fetch it from constants ! 152: ((or (eq op byte-goto) ! 153: (eq op byte-goto-if-nil) ! 154: (eq op byte-goto-if-not-nil) ! 155: (eq op byte-goto-if-nil-else-pop) ! 156: (eq op byte-goto-if-not-nil-else-pop) ! 157: (eq op byte-call) ! 158: (eq op byte-unbind)) ! 159: ;; it's a number ! 160: offset) ;return it ! 161: ((or (eq op byte-constant) ! 162: (eq op byte-constant2)) ! 163: ;; it's a constant ! 164: (setq tmp (aref constants offset)) ! 165: ;; but is constant byte code? ! 166: (cond ((and (eq (car-safe tmp) 'lambda) ! 167: (assq 'byte-code tmp)) ! 168: (princ "<compiled lambda>" stream) ! 169: (terpri stream) ! 170: (disassemble ;recurse on compiled lambda ! 171: tmp ! 172: stream ! 173: (+ indent disassemble-recursive-indent)) ! 174: "") ! 175: ((eq (car-safe tmp) 'byte-code) ! 176: (princ "<byte code>" stream) ! 177: (terpri stream) ! 178: (disassemble-1 ;recurse on byte-code object ! 179: tmp ! 180: stream ! 181: (+ indent disassemble-recursive-indent)) ! 182: "") ! 183: ((eq (car-safe (car-safe tmp)) 'byte-code) ! 184: (princ "(<byte code>...)" stream) ! 185: (terpri stream) ! 186: (mapcar ;recurse on list of byte-code objects ! 187: (function (lambda (obj) ! 188: (disassemble-1 ! 189: obj ! 190: stream ! 191: (+ indent disassemble-recursive-indent)))) ! 192: tmp) ! 193: "") ! 194: ((and (eq tmp 'byte-code) ! 195: (eq (aref bytes (+ ptr 4)) (+ byte-call 3))) ! 196: ;; this won't catch cases where args are pushed w/ ! 197: ;; constant2. ! 198: (setq ptr (+ ptr 4)) ! 199: "<compiled call to byte-code. compiled code compiled?>") ! 200: (t ! 201: ;; really just a constant ! 202: (let ((print-escape-newlines t)) ! 203: (prin1-to-string tmp))))) ! 204: (t "<error in disassembler>")) ! 205: stream)) ! 206: (terpri stream))) ! 207: nil) ! 208: ! 209: ! 210: (defun disassemble-offset () ! 211: "Don't call this!" ! 212: ;; fetch and return the offset for the current opcode. ! 213: ;; return NIL if this opcode has no offset ! 214: ;; OP, PTR and BYTES are used and set dynamically ! 215: (let (tem) ! 216: (cond ((< op byte-nth) ! 217: (setq tem (logand op 7)) ! 218: (setq op (logand op 248)) ! 219: (cond ((eq tem 6) ! 220: (setq ptr (1+ ptr)) ;offset in next byte ! 221: (aref bytes ptr)) ! 222: ((eq tem 7) ! 223: (setq ptr (1+ ptr)) ;offset in next 2 bytes ! 224: (+ (aref bytes ptr) ! 225: (progn (setq ptr (1+ ptr)) ! 226: (lsh (aref bytes ptr) 8)))) ! 227: (t tem))) ;offset was in opcode ! 228: ((>= op byte-constant) ! 229: (setq tem (- op byte-constant)) ;offset in opcode ! 230: (setq op byte-constant) ! 231: tem) ! 232: ((or (= op byte-constant2) ! 233: (and (>= op byte-goto) ! 234: (<= op byte-goto-if-not-nil-else-pop))) ! 235: (setq ptr (1+ ptr)) ;offset in next 2 bytes ! 236: (+ (aref bytes ptr) ! 237: (progn (setq ptr (1+ ptr)) ! 238: (lsh (aref bytes ptr) 8)))) ! 239: (t nil)))) ;no offset ! 240: ! 241: ! 242: (defun write-spaces (n &optional stream) ! 243: "Print N spaces to (optional) STREAM." ! 244: (or stream (setq stream standard-output)) ! 245: (if (< n 0) (setq n 0)) ! 246: (if (eq stream (current-buffer)) ! 247: (insert-char ?\ n) ! 248: (while (> n 0) ! 249: (write-char ?\ stream) ! 250: (setq n (1- n))))) ! 251: ! 252: (defconst byte-code-vector ! 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: <not-an-opcode> ! 261: (varref . 1) ! 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: <not-an-opcode> ! 269: (varset . -1) ! 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: <not-an-opcode> ! 277: (varbind . 0);Pops a value, "pushes" a binding ! 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: <not-an-opcode> ! 285: (call . -); #'-, not -1! ! 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: <not-an-opcode> ! 293: (unbind . -);"pops" bindings ! 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: <not-an-opcode> ! 309: (nth . -1) ! 310: symbolp ! 311: consp ! 312: stringp ! 313: listp ! 314: (eq . -1) ! 315: (memq . -1) ! 316: not ! 317: car ! 318: cdr ! 319: (cons . -1) ! 320: list1 ! 321: (list2 . -1) ! 322: (list3 . -2) ! 323: (list4 . -3) ! 324: length ! 325: (aref . -1) ! 326: (aset . -2) ! 327: symbol-value ! 328: symbol-function ! 329: (set . -1) ! 330: (fset . -1) ! 331: (get . -1) ! 332: (substring . -2) ! 333: (concat2 . -1) ! 334: (concat3 . -2) ! 335: (concat4 . -3) ! 336: sub1 ! 337: add1 ! 338: (eqlsign . -1) ;= ! 339: (gtr . -1) ;> ! 340: (lss . -1) ;< ! 341: (leq . -1) ;<= ! 342: (geq . -1) ;>= ! 343: (diff . -1) ;- ! 344: negate ;unary - ! 345: (plus . -1) ;+ ! 346: (max . -1) ! 347: (min . -1) ! 348: <not-an-opcode> ! 349: (point . 1) ! 350: (mark\(obsolete\) . 1) ! 351: goto-char ! 352: insert ! 353: (point-max . 1) ! 354: (point-min . 1) ! 355: char-after ! 356: (following-char . 1) ! 357: (preceding-char . 1) ! 358: (current-column . 1) ! 359: (indent-to . 1) ! 360: (scan-buffer\(obsolete\) . -2) ! 361: (eolp . 1) ! 362: (eobp . 1) ! 363: (bolp . 1) ! 364: (bobp . 1) ! 365: (current-buffer . 1) ! 366: set-buffer ! 367: (read-char . 1) ! 368: set-mark\(obsolete\) ! 369: interactive-p ! 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: <not-an-opcode> ! 382: (constant2 . 1) ! 383: goto;>>> ! 384: goto-if-nil;>> ! 385: goto-if-not-nil;>> ! 386: (goto-if-nil-else-pop . -1) ! 387: (goto-if-not-nil-else-pop . -1) ! 388: return ! 389: (discard . -1) ! 390: (dup . 1) ! 391: (save-excursion . 1);Pushes a binding ! 392: (save-window-excursion . 1);Pushes a binding ! 393: (save-restriction . 1);Pushes a binding ! 394: (catch . -1);Takes one argument, returns a value ! 395: (unwind-protect . 1);Takes one argument, pushes a binding, returns a value ! 396: (condition-case . -2);Takes three arguments, returns a value ! 397: (temp-output-buffer-setup . -1) ! 398: temp-output-buffer-show ! 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: <not-an-opcode> ! 445: (constant . 1) ! 446: ]) ! 447:
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.