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