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