Mercurial > hg > xemacs-beta
annotate lisp/disass.el @ 5075:868a9ffcc37b
Normally return a compiled function if one argument, #'constantly.
2010-02-24 Aidan Kehoe <kehoea@parhasard.net>
* cl-extra.el (constantly):
Normally return a compiled function from #'constantly if we are
handed a single argument. Shouldn't actually matter, the overhead
for returning a single constant in a lambda form vs. in a compiled
function is minuscule, but using compiled functions as much as
possible is good style in XEmacs, our interpreter is not stellar
(nor indeed should it need to be).
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Wed, 24 Feb 2010 17:17:13 +0000 |
| parents | e29fcfd8df5f |
| children | 308d34e9f07d |
| rev | line source |
|---|---|
| 428 | 1 ;;; disass.el --- disassembler for compiled Emacs Lisp code |
| 2 | |
| 3 ;;; Copyright (C) 1986, 1991-1994 Free Software Foundation, Inc. | |
| 4 | |
| 5 ;; Author: Doug Cutting <doug@csli.stanford.edu> | |
| 6 ;; Jamie Zawinski <jwz@jwz.org> | |
| 7 ;; Maintainer: XEmacs Development Team | |
| 8 ;; Keywords: internal | |
| 9 | |
| 10 ;; This file is part of XEmacs. | |
| 11 | |
| 12 ;; XEmacs is free software; you can redistribute it and/or modify it | |
| 13 ;; under the terms of the GNU General Public License as published by | |
| 14 ;; the Free Software Foundation; either version 2, or (at your option) | |
| 15 ;; any later version. | |
| 16 | |
| 17 ;; XEmacs is distributed in the hope that it will be useful, but | |
| 18 ;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
| 19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
| 20 ;; General Public License for more details. | |
| 21 | |
| 22 ;; You should have received a copy of the GNU General Public License | |
| 23 ;; along with XEmacs; see the file COPYING. If not, write to the | |
| 24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
| 25 ;; Boston, MA 02111-1307, USA. | |
| 26 | |
| 27 ;;; Synched up with: FSF 19.28. | |
| 28 | |
| 29 ;;; Commentary: | |
| 30 | |
| 31 ;; The single entry point, `disassemble', disassembles a code object generated | |
| 32 ;; by the Emacs Lisp byte-compiler. This doesn't invert the compilation | |
| 33 ;; operation, not by a long shot, but it's useful for debugging. | |
| 34 | |
| 35 ;; | |
| 36 ;; Original version by Doug Cutting (doug@csli.stanford.edu) | |
| 37 ;; Substantially modified by Jamie Zawinski for | |
| 38 ;; the new lapcode-based byte compiler. | |
| 39 | |
| 40 ;;; Code: | |
| 41 | |
| 42 (require 'byte-optimize) | |
| 43 | |
| 44 (defvar disassemble-column-1-indent 8 "*") | |
| 45 (defvar disassemble-column-2-indent 10 "*") | |
| 46 (defvar disassemble-recursive-indent 3 "*") | |
| 47 | |
| 48 ;;;###autoload | |
| 49 (defun disassemble (object &optional buffer indent interactive-p) | |
| 50 "Print disassembled code for OBJECT in (optional) BUFFER. | |
| 51 OBJECT can be a symbol defined as a function, or a function itself | |
| 52 \(a lambda expression or a compiled-function object). | |
| 53 If OBJECT is not already compiled, we compile it, but do not | |
| 54 redefine OBJECT if it is a symbol." | |
| 55 (interactive (list (intern (completing-read "Disassemble function: " | |
| 56 obarray 'fboundp t)) | |
| 57 nil 0 t)) | |
| 58 (if (eq (car-safe object) 'byte-code) | |
| 59 (setq object (list 'lambda () object))) | |
| 60 (or indent (setq indent 0)) ;Default indent to zero | |
| 61 (save-excursion | |
| 62 (if (or interactive-p (null buffer)) | |
| 63 (with-output-to-temp-buffer "*Disassemble*" | |
| 64 (set-buffer "*Disassemble*") | |
| 65 (disassemble-internal object indent (not interactive-p))) | |
| 66 (set-buffer buffer) | |
| 67 (disassemble-internal object indent nil))) | |
| 68 nil) | |
| 69 | |
| 70 | |
| 71 (defun disassemble-internal (obj indent interactive-p) | |
| 72 (let ((macro nil) | |
| 73 (name nil) | |
| 74 args) | |
| 75 (while (symbolp obj) | |
| 76 (setq name obj | |
| 77 obj (symbol-function obj))) | |
| 78 (if (subrp obj) | |
| 79 (error "Can't disassemble #<subr %s>" name)) | |
| 80 (if (eq (car-safe obj) 'autoload) | |
| 81 (progn | |
| 82 (load (elt obj 1)) | |
| 83 (setq obj (symbol-function name)))) | |
| 84 (if (eq (car-safe obj) 'macro) ;handle macros | |
| 85 (setq macro t | |
| 86 obj (cdr obj))) | |
| 87 (if (and (listp obj) (eq (car obj) 'byte-code)) | |
| 88 (setq obj (list 'lambda nil obj))) | |
| 89 (if (and (listp obj) (not (eq (car obj) 'lambda))) | |
| 90 (error "not a function")) | |
| 91 (if (consp obj) | |
| 92 (if (assq 'byte-code obj) | |
| 93 nil | |
| 94 (if interactive-p (message (if name | |
| 95 "Compiling %s's definition..." | |
| 96 "Compiling definition...") | |
| 97 name)) | |
| 98 (setq obj (byte-compile obj)) | |
| 99 (if interactive-p (message "Done compiling. Disassembling...")))) | |
| 100 (cond ((consp obj) | |
| 101 (setq obj (cdr obj)) ;throw lambda away | |
| 102 (setq args (car obj)) ;save arg list | |
| 103 (setq obj (cdr obj))) | |
| 104 (t | |
| 105 (setq args (compiled-function-arglist obj)))) | |
| 106 (if (zerop indent) ; not a nested function | |
| 107 (progn | |
| 108 (indent-to indent) | |
| 109 (insert (format "byte code%s%s%s:\n" | |
| 110 (if (or macro name) " for" "") | |
| 111 (if macro " macro" "") | |
| 112 (if name (format " %s" name) ""))))) | |
| 113 (let ((doc (if (consp obj) | |
| 114 (and (stringp (car obj)) (car obj)) | |
| 115 (condition-case error | |
| 116 (documentation obj) | |
| 117 (error (format "%S" error)))))) | |
| 118 (if (and doc (stringp doc)) | |
| 119 (progn (and (consp obj) (setq obj (cdr obj))) | |
| 120 (indent-to indent) | |
| 121 (princ " doc: " (current-buffer)) | |
| 122 (let ((frobbed nil)) | |
| 123 (if (string-match "\n" doc) | |
| 124 (setq doc (substring doc 0 (match-beginning 0)) | |
| 125 frobbed t)) | |
| 126 (if (> (length doc) 70) | |
| 127 (setq doc (substring doc 0 65) frobbed t)) | |
| 128 (if frobbed (setq doc (concat doc " ...")))) | |
| 129 (insert doc "\n")))) | |
| 130 (indent-to indent) | |
| 131 (insert " args: ") | |
| 132 (prin1 args (current-buffer)) | |
| 133 (insert "\n") | |
| 134 (if (condition-case () | |
| 135 (commandp obj) ; ie interactivep | |
| 136 (error nil)) | |
| 137 (let ((interactive (if (consp obj) | |
| 138 (elt (assq 'interactive obj) 1) | |
| 139 (elt (compiled-function-interactive obj) 1)))) | |
| 140 (if (eq (car-safe (car-safe obj)) 'interactive) | |
| 141 (setq obj (cdr obj))) | |
| 142 (indent-to indent) | |
| 143 (insert " interactive: ") | |
| 144 (if (eq (car-safe interactive) 'byte-code) | |
| 145 (progn | |
| 146 (insert "\n") | |
| 147 (disassemble-1 interactive | |
| 148 (+ indent disassemble-recursive-indent))) | |
| 149 (let ((print-escape-newlines t)) | |
| 150 (prin1 interactive (current-buffer)))) | |
| 151 (insert "\n"))) | |
| 152 (cond ((and (consp obj) (assq 'byte-code obj)) | |
| 153 (disassemble-1 (assq 'byte-code obj) indent)) | |
| 154 ((compiled-function-p obj) | |
| 155 (disassemble-1 obj indent)) | |
| 156 (t | |
| 157 (insert "Uncompiled body: ") | |
| 158 (let ((print-escape-newlines t)) | |
| 159 (prin1 (if (cdr obj) (cons 'progn obj) (car obj)) | |
| 160 (current-buffer)))))) | |
| 161 (if interactive-p | |
| 162 (message nil))) | |
| 163 | |
| 164 | |
| 165 (defun disassemble-1 (obj indent) | |
| 166 "Print the byte-code call OBJ in the current buffer. | |
| 167 OBJ should be a compiled-function object generated by the byte compiler." | |
| 168 (let (bytes constvec) | |
| 169 (if (consp obj) | |
| 170 (setq bytes (car (cdr obj)) ; the byte code | |
| 171 constvec (car (cdr (cdr obj)))) ; constant vector | |
| 172 (setq bytes (compiled-function-instructions obj) | |
| 173 constvec (compiled-function-constants obj))) | |
| 174 (let ((lap (byte-decompile-bytecode bytes constvec)) | |
| 175 op arg opname pc-value) | |
| 176 (let ((tagno 0) | |
| 177 tmp | |
| 178 (lap lap)) | |
| 179 (while (setq tmp (assq 'TAG lap)) | |
| 180 (setcar (cdr tmp) (setq tagno (1+ tagno))) | |
| 181 (setq lap (cdr (memq tmp lap))))) | |
| 182 (while lap | |
| 183 ;; Take off the pc value of the next thing | |
| 184 ;; and put it in pc-value. | |
| 185 (setq pc-value nil) | |
| 186 (if (numberp (car lap)) | |
| 187 (setq pc-value (car lap) | |
| 188 lap (cdr lap))) | |
| 189 ;; Fetch the next op and its arg. | |
| 190 (setq op (car (car lap)) | |
| 191 arg (cdr (car lap))) | |
| 192 (setq lap (cdr lap)) | |
| 193 (indent-to indent) | |
| 194 (if (eq 'TAG op) | |
| 195 (progn | |
| 196 ;; We have a label. Display it, but first its pc value. | |
| 197 (if pc-value | |
| 198 (insert (format "%d:" pc-value))) | |
| 199 (insert (int-to-string (car arg)))) | |
| 200 ;; We have an instruction. Display its pc value first. | |
| 201 (if pc-value | |
| 202 (insert (format "%d" pc-value))) | |
| 203 (indent-to (+ indent disassemble-column-1-indent)) | |
| 204 (if (and op | |
| 205 (string-match "^byte-" (setq opname (symbol-name op)))) | |
| 206 (setq opname (substring opname 5)) | |
| 207 (setq opname "<not-an-opcode>")) | |
| 208 (if (eq op 'byte-constant2) | |
| 209 (insert " #### shouldn't have seen constant2 here!\n ")) | |
| 210 (insert opname) | |
| 211 (indent-to (+ indent disassemble-column-1-indent | |
| 212 disassemble-column-2-indent | |
| 213 -1)) | |
| 214 (insert " ") | |
| 215 (cond ((memq op byte-goto-ops) | |
| 216 (insert (int-to-string (nth 1 arg)))) | |
| 217 ((memq op '(byte-call byte-unbind | |
| 218 byte-listN byte-concatN byte-insertN)) | |
| 219 (insert (int-to-string arg))) | |
| 220 ((memq op '(byte-varref byte-varset byte-varbind)) | |
| 221 (prin1 (car arg) (current-buffer))) | |
| 222 ((memq op '(byte-constant byte-constant2)) | |
| 223 ;; it's a constant | |
| 224 (setq arg (car arg)) | |
| 225 ;; but if the value of the constant is compiled code, then | |
| 226 ;; recursively disassemble it. | |
| 227 (cond ((or (compiled-function-p arg) | |
| 228 (and (eq (car-safe arg) 'lambda) | |
| 229 (assq 'byte-code arg)) | |
| 230 (and (eq (car-safe arg) 'macro) | |
| 231 (or (compiled-function-p (cdr arg)) | |
| 232 (and (eq (car-safe (cdr arg)) 'lambda) | |
| 233 (assq 'byte-code (cdr arg)))))) | |
| 234 (cond ((compiled-function-p arg) | |
| 235 (insert "<compiled-function>\n")) | |
| 236 ((eq (car-safe arg) 'lambda) | |
| 237 (insert "<compiled lambda>")) | |
| 238 (t (insert "<compiled macro>\n"))) | |
| 239 (disassemble-internal | |
| 240 arg | |
| 241 (+ indent disassemble-recursive-indent 1) | |
| 242 nil)) | |
| 243 ((eq (car-safe arg) 'byte-code) | |
| 244 (insert "<byte code>\n") | |
| 245 (disassemble-1 ;recurse on byte-code object | |
| 246 arg | |
| 247 (+ indent disassemble-recursive-indent))) | |
| 248 ((eq (car-safe (car-safe arg)) 'byte-code) | |
| 249 (insert "(<byte code>...)\n") | |
|
4783
e29fcfd8df5f
Eliminate most core code byte-compile warnings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
428
diff
changeset
|
250 (mapc ;recurse on list of byte-code objects |
| 428 | 251 #'(lambda (obj) |
| 252 (disassemble-1 | |
| 253 obj | |
| 254 (+ indent disassemble-recursive-indent))) | |
| 255 arg)) | |
| 256 (t | |
| 257 ;; really just a constant | |
| 258 (let ((print-escape-newlines t)) | |
| 259 (prin1 arg (current-buffer)))))) | |
| 260 ) | |
| 261 (insert "\n"))))) | |
| 262 nil) | |
| 263 | |
| 264 (provide 'disass) | |
| 265 | |
| 266 ;;; disass.el ends here |