(require (quote byte-compile) "bytecomp") (defvar disassemble-column-1-indent 4 "\ *") (defvar disassemble-column-2-indent 9 "\ *") (defvar disassemble-recursive-indent 3 "\ *") (defun disassemble (object &optional stream indent interactive-p) "\ Print disassembled code for OBJECT on (optional) STREAM. OBJECT can be a function name, lambda expression or any function object returned by SYMBOL-FUNCTION. If OBJECT is not already compiled, we will compile it (but not redefine it)." (interactive (byte-code "ÃÄÅÆÁ$!ÂÇÁF‡" [obarray t nil intern completing-read "Disassemble function: " fboundp 0] 6)) (byte-code "ˆ † ȉˆ ƒÉÊ  Á$‘‚'Ê †$ Â$ˆÂ‡" [obarray t nil indent interactive-p object standard-output stream 0 "*Disassemble*" disassemble-internal] 6)) (defun disassemble-internal (obj stream indent interactive-p) (byte-code "ÆÆÆÆ 9…  K‰ˆ‚ˆÌ !…\"ÍÎ \"ˆ @À=…0Å A‰ˆ @Ï=?…<ÍÐ!ˆÑÒ \"ƒHÆ‚h…YÓ ƒVÔ‚WÕ \"ˆÖ !‰ˆ…hÓ×!ˆ A‰ˆ @‰ˆ A‰ˆØ \"ˆÙÚÛ†‡ ƒŽÜ‚݃—Þ‚˜Ý ƒ£Úß \"‚¤Ý$ \"ˆ @;…± @ …Ò A‰ˆØ \"ˆÙà \"ˆÙ  \"ˆá !)ˆØ \"ˆÙâ \"ˆã  \"ˆá !ˆÑÊ \"A@  …(Ø \"ˆÙä \"ˆå !Ò=ƒæ   \\#‚(ã  \"ˆá !)ˆÑÒ \"‰ˆæ  #,ˆ…BÓÝ!‡" [macro name doc args obj t nil interactive-p indent stream interactive disassemble-recursive-indent subrp error "Can't disassemble #" lambda "not a function" assq byte-code message "Compiling %s's definition..." "Compiling definition..." byte-compile-lambda "Done compiling. Disassembling..." write-spaces princ format "byte code%s%s%s: " " for" "" " macro" " %s" " doc: " terpri " args: " prin1 " interactive: " car-safe disassemble-1] 31)) (defun disassemble-1 (obj &optional stream indent) "\ Prints the byte-code call OBJ to (optional) STREAM. OBJ should be a call to BYTE-CODE generated by the byte compiler." (byte-code "†Þ‰ˆ † ‰ˆ A@ß AA@ÍÍÍ  G‰ ˆà !ˆ T‰ W…¶á \"ˆâã !‰ \"ˆäå \"ˆáæ Gç# \"ˆ H‰ ˆè ‰ˆ  H‰ˆ:…{@‰ˆé!‰ˆâ \"ˆ?ƒ”Í‚®äå \"ˆáæGç# \"ˆâ =†» =†» =ƒÆH‚¬ =†û =†û =†û =†û =†û =†û =ƒ‚¬ =† =ƒ«H‰ˆê!ë=…*ìí\"ƒDâî \"ˆà !ˆï \\#ˆð‚¨ê!í=ƒdâñ \"ˆà !ˆò \\#ˆð‚¨êê!!í=ƒ‚âó \"ˆà !ˆôõ\"ˆð‚¨í=…“ ö\\H÷\\=ƒ  ö\\‰ˆø‚¨Üã!)‚¬ù \"ˆà !ˆ‚/.ˆÍ‡" [indent stream standard-output bytes obj ptr constants offset tmp length disassemble-column-1-indent op byte-code-vector nil disassemble-column-2-indent byte-varref byte-varset byte-varbind byte-goto byte-goto-if-nil byte-goto-if-not-nil byte-goto-if-nil-else-pop byte-goto-if-not-nil-else-pop byte-call byte-unbind byte-constant byte-constant2 disassemble-recursive-indent t print-escape-newlines 0 -1 terpri write-spaces princ prin1-to-string write-char 32 - 1 disassemble-offset symbol-name car-safe lambda assq byte-code "" disassemble "" "" disassemble-1 "(...)" mapcar (lambda (obj) (byte-code "Ä \\#‡" [obj stream indent disassemble-recursive-indent disassemble-1] 5)) 4 3 "" ""] 32)) (defun disassemble-offset nil "\ Don't call this!" (byte-code "Ê WƒHË Ì\"‰ˆË Í\"‰ˆÎ=ƒ' T‰ˆ H‚EÌ=ƒD T‰ˆ H T‰ˆÏ HÐ\"\\‚E‚Œ Yƒ_ Z‰ˆ‰ˆ‚Œ U†q Y…q  Xƒ‹ T‰ˆ H T‰ˆÏ HÐ\"\\‚ŒÊ)‡" [tem op byte-nth ptr bytes t byte-constant byte-constant2 byte-goto byte-goto-if-not-nil-else-pop nil logand 7 248 6 lsh 8] 7)) (defun write-spaces (n &optional stream) "\ Print N spaces to (optional) STREAM." (byte-code "† ‰ˆ ÃW…Ɉp=ƒÄÅ \"‚2 ÃV…2ÆÅ\"ˆ S‰ˆ‚‡" [stream standard-output n 0 insert-char 32 write-char] 5)) (defconst byte-code-vector (quote [ (varref . 1) (varset . -1) (varbind . 0) (call . -) (unbind . -) (nth . -1) symbolp consp stringp listp (eq . -1) (memq . -1) not car cdr (cons . -1) list1 (list2 . -1) (list3 . -2) (list4 . -3) length (aref . -1) (aset . -2) symbol-value symbol-function (set . -1) (fset . -1) (get . -1) (substring . -2) (concat2 . -1) (concat3 . -2) (concat4 . -3) sub1 add1 (eqlsign . -1) (gtr . -1) (lss . -1) (leq . -1) (geq . -1) (diff . -1) negate (plus . -1) (max . -1) (min . -1) (point . 1) (mark\(obsolete\) . 1) goto-char insert (point-max . 1) (point-min . 1) char-after (following-char . 1) (preceding-char . 1) (current-column . 1) (indent-to . 1) (scan-buffer\(obsolete\) . -2) (eolp . 1) (eobp . 1) (bolp . 1) (bobp . 1) (current-buffer . 1) set-buffer (read-char . 1) set-mark\(obsolete\) interactive-p (constant2 . 1) goto goto-if-nil goto-if-not-nil (goto-if-nil-else-pop . -1) (goto-if-not-nil-else-pop . -1) return (discard . -1) (dup . 1) (save-excursion . 1) (save-window-excursion . 1) (save-restriction . 1) (catch . -1) (unwind-protect . 1) (condition-case . -2) (temp-output-buffer-setup . -1) temp-output-buffer-show (constant . 1)]))