![[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.