Mercurial > hg > xemacs-beta

comparison lisp/energize/backtrace-logging.el @ 0:376386a54a3c r19-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children 131b0175ea99
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
1 ;;; -*- Mode: EMACS-LISP; Syntax: E-Lisp; Base: 10 -*-
2 ;;;
3 ;;;; backtrace-logging.el
4 ;;;
5 ;;; User code for interacting with backtrace logging.
6 ;;;
7 ;;; ***************************************************************************
8 ;;;
9 ;;; Revision: 29-Jan-92 12:14:49
10 ;;;
11 ;;; Programmer: Harlan Sexton
12 ;;;
13 ;;; Edit-History:
14 ;;;
15 ;;; Created: 30-Aug-91 by hbs
16 ;;;
17 ;;; End-of-Edit-History
18
19 (defvar *btl-index-counter* 1)
20 (defvar *btl-data-file* nil)
21 (defvar *btl-indices-assigned* nil)
22 (defvar elisp-only-btl nil)
23 (defvar cadillac-id-tag-save 'cadillac-id-tag-save)
24
25 (defun assign-btl-indices (&optional force)
26 (if (or force
27 (not *btl-indices-assigned*))
28 (progn
29 (mapatoms 'assign-btl-index)
30 (setq *btl-indices-assigned* t))))
31
32 (defun btl-compiled-p (function)
33 (or (subrp function)
34 (compiled-function-p function)
35 (and (consp function)
36 (eq (car function) 'lambda)
37 (let ((rest (cdr (cdr function)))
38 (quit nil))
39 (while (and rest (not quit))
40 (let ((trial (car rest)))
41 (if (consp trial)
42 (setq quit (eq (car trial) 'byte-code)))
43 (setq rest (cdr rest))))
44 quit))))
45
46 (defun get-btl-index (symbol)
47 (if (symbolp symbol)
48 (let ((val (or (get symbol cadillac-id-tag)
49 (get symbol 'cadillac-id-tag-save))))
50 (if (and val (integerp val) (> val 0))
51 val
52 (progn
53 (setq val *btl-index-counter*)
54 (setq *btl-index-counter* (1+ *btl-index-counter*))
55 val)))))
56
57 (defun disable-btl-index (symbol)
58 (if (symbolp symbol)
59 (let ((val (or (get symbol cadillac-id-tag)
60 (get symbol 'cadillac-id-tag-save))))
61 (if (and val (integerp val) (> val 0))
62 (put symbol 'cadillac-id-tag-save val))
63 (remprop symbol cadillac-id-tag))))
64
65 (defun assign-btl-index (symbol)
66 (if (and (symbolp symbol)
67 (fboundp symbol))
68 (let* ((function (symbol-function symbol))
69 (subr-function (subrp function))
70 (compiled-function (btl-compiled-p function))
71 (tagged-function (get symbol cadillac-id-tag)))
72 (cond ((and elisp-only-btl compiled-function (not tagged-function))
73 (put symbol cadillac-id-tag (get-btl-index symbol)))
74 ((and (not elisp-only-btl) subr-function tagged-function)
75 (disable-btl-index symbol))))))
76
77 (defun file-to-btl-data-file (file)
78 (let ((base-dir (expand-file-name "")))
79 (if (string-equal base-dir file)
80 (setq file nil)))
81 (setq file (or file *btl-data-file*))
82 (let ((go-ahead nil))
83 (if (or (not (stringp file))
84 (file-directory-p file))
85 (setq go-ahead nil)
86 (if (file-exists-p file)
87 (setq go-ahead
88 (y-or-n-p (message "File exists -- overwrite %s? "
89 file)))
90 (setq go-ahead t)))
91 (if (not go-ahead)
92 (error "Bad data file.")))
93 file)
94
95 (defun btl-init (file &optional pc-logging)
96 (setq file (file-to-btl-data-file file))
97 (let ((log-type (if pc-logging "PC logging" "btl")))
98 (message (format "Initializing %s..." log-type))
99 (sit-for 0)
100 (assign-btl-indices t)
101 (setq *btl-data-file* file)
102 (if pc-logging
103 (initialize-pc-logging-internal file)
104 (initialize-backtrace-logging-internal file))
105 (message (format "Initializing %s...done." log-type))
106 (sit-for 1)
107 (message "")
108 (sit-for 0)))
109
110 (defun start-btl (file &optional elisp-flag-val)
111 (interactive "FFile in which to write data: ")
112 (terminate-logging)
113 (setq elisp-only-btl elisp-flag-val)
114 (btl-init file)
115 (start-logging))
116
117 (defun start-btl-elisp (file)
118 (interactive "FFile in which to write data: ")
119 (start-btl file t))
120
121 (defun consing-btl (file &optional elisp-flag-val)
122 (interactive "FFile in which to write data: ")
123 (terminate-logging)
124 (setq elisp-only-btl elisp-flag-val)
125 (set-log-signal 0)
126 (btl-init file)
127 (start-logging))
128
129 (defun consing-btl-elisp (file)
130 (interactive "FFile in which to write data: ")
131 (consing-btl file t))
132
133 (defun set-elisp-btl (arg)
134 (interactive "p")
135 (setq elisp-only-btl (eql arg 1)))
136
137 (defun start-pcl (file &optional elisp-flag-val)
138 (interactive "FFile in which to write data: ")
139 (setq elisp-only-btl elisp-flag-val)
140 (btl-init file t)
141 (start-logging))
142
143 (defun start-pcl-elisp (file)
144 (interactive "FFile in which to write data: ")
145 (start-pcl file t))
146
147 (defun suspend-btl ()
148 (interactive)
149 (stop-logging))
150
151 (defun suspend-pcl ()
152 (interactive)
153 (stop-logging))
154
155 (defun resume-btl ()
156 (interactive)
157 (start-logging))
158
159 (defun resume-pcl ()
160 (interactive)
161 (start-logging))
162
163 (defun stop-btl ()
164 (interactive)
165 (terminate-logging))
166
167 (defun stop-pcl ()
168 (interactive)
169 (terminate-logging))
170
171 (defun show-btl ()
172 (interactive)
173 (terminate-logging)
174 (switch-to-buffer (get-buffer-create "*BTL Log Info*"))
175 (goto-char (point-max))
176 (buffer-disable-undo (current-buffer))
177 (if *btl-data-file*
178 (summarize-logging *btl-data-file*)))