1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18 (%include e-macros)
19 (declare (*lexpr ldebug-ioa)(genprefix /!ldb_))
20
21 (declare (special ldebug-closure ldebug-break-index ldebug-buf errset
22 ldebug-breaklist ldebug-cur-bkpt ldebug-trace-indent
23 ldebug-cur-bkpte ldebug-level e-lisp-error-mode))
24
25 (declare (*expr backward-sexp begin-defun down-list-level e_lap_$get-x7
26 eval-top-level-form forward-sexp kill-sexp lisp-mode))
27
28 (defvar ldebug-mode-hook nil)
29
30 (setq ldebug-break-index 0
31 ldebug-breaklist nil
32 ldebug-cur-bkpte nil
33 ldebug-level 0)
34
35
36
37
38 (declare (special ldebug-prinlevel ldebug-prinlength ldebug-base ldebug-ibase))
39
40
41
42
43
44
45 (defprop ldebug
46 "Enables a mode to take advantage of emacs editing capabilities
47 while interacting with lisp. You type in se-expressions with the
48 full emacs command set available, and type CR to send your last
49 expresison to lisp. The output will be inserted into the buffer with
50 prinlevel and prinlength bound to the values of the options ldebug-prinlevel
51 and ldebug-prinlength (default 6. and 10.). The symbol * will be set to
52 the result of the evaluation, as in the default lisp top-level.
53
54 Errors encountered will enter a break level of editing on the buffer.
55 esc-G will return to the top-level edit loop, exc-P to the previous level,
56 esc-L will list the breaks currently in effect, esc-R resets a break
57 esc-s will show source for a breakpoint, esc-T will print a backtrace. Esc-^S will
58 show where the editor was at the time of the error."
59 documentation)
60
61 (defun ldebug-mode ()
62 (lisp-mode)
63 (dont-notice-modified-buffer current-buffer)
64 (mapc '(lambda (x)(set-key (car x)(cadr x)))
65 '((^M ldebug-eval-and-print-result)
66 (esc-G ldebug-return-to-emacs-top-level)
67 (esc-P ldebug-return)
68 (esc-L ldebug-list-breaks)
69 (esc-R ldebug-reset-break)
70 (esc-S ldebug-show-bkpt-source)
71 (esc-T ldebug-trace-stack)
72 (esc-^S ldebug-display-where-editor-was)))
73 (setq current-buffer-mode 'Lisp/ Debug)
74 (if ldebug-mode-hook
75 (errset (funcall ldebug-mode-hook))))
76
77 (defun %% (bx)(ldebug-catch bx (e_lap_$get-x7)))
78
79 (defun ldebug-catch (bx cl)
80 (let ((ldebug-closure cl)
81 (ldebug-buf current-buffer)
82 (ldebug-cur-bkpt bx)
83 (ldebug-cur-bkpte (ldebug-find-bkpte bx)))
84 (let ((state (car ldebug-cur-bkpte)))
85 (cond ((memq state '(dead benign)))
86 ((eq state 'live)(ldebug-yggdrasil 'curbkpt))
87 ((not (numberp state)))
88 ((< state 2)
89 (rplaca ldebug-cur-bkpte 'live)
90 (ldebug-yggdrasil 'curbkpt))
91 (t (rplaca ldebug-cur-bkpte (1- state)))))))
92
93 (defprop ldebug
94 "$$$ enters a buffer LDEBUG in ldebug-mode, to
95 do interactive debugging of lisp code. See the
96 documentation for ldebug-mode for details."
97 documentation)
98
99 (defun ldebug ()
100 (let ((ldebug-buf current-buffer)
101 (*rset t)
102 (ldebug-trace-indent 0)
103 (ldebug-closure (e_lap_$get-x7))
104 (ldebug-cur-bkpte nil)
105 (e-lisp-error-mode 'ldebug-lisp-toplevel-error-handler))
106 (ldebug-yggdrasil 'ldebug)))
107
108 (defun ldebug-lisp-toplevel-error-handler (arg)
109 (setq arg arg)
110 (let ((ldebug-buf current-buffer)
111 (ldebug-level (1+ ldebug-level))
112 (ldebug-closure (cadddr (errframe nil)))
113 (* nil))
114 (ldebug-yggdrasil 'errbreak)))
115
116 (defun ldebug-in-breakp ()
117 (or ldebug-cur-bkpte (display-error "No current break.")))
118
119 (defun within-LDEBUG/'s-buffer-window macro (x)
120 `(let ((oldbuf current-buffer)
121 (oldfdw (buffer-on-display-in-window current-buffer)))
122 (find-buffer-in-window 'LDEBUG)
123 (prog2 0 (progn ,@(cdr x))
124 (if (null oldfdw)
125 (go-to-buffer oldbuf)
126 else (find-buffer-in-window oldbuf)))))
127
128 (defun ldebug-yggdrasil (key)
129 (within-LDEBUG/'s-buffer-window
130 (if (empty-buffer-p current-buffer)
131 (new-line)
132 (ldebug-mode)
133 else
134 (go-to-end-of-buffer))
135 (if (not (line-is-blank))(new-line))
136 (if (eq key 'errbreak)
137 (errset
138 (ring-tty-bell)
139 (let ((f (caddr (errframe nil))))
140 (new-line)
141 (ldebug-ioa "Lisp breakpoint " (caddr f) " at level "
142 (decimal-rep ldebug-level) " in buffer "
143 ldebug-buf ":")
144 (ldebug-ioa (car f)(maknam (explodec (cadr f)))))))
145 (if (eq key 'trace-break)
146 (ring-tty-bell)
147 (ldebug-ioa "Entry breakpoint to function "
148 (cadr ldebug-cur-bkpte)))
149 (if (eq key 'curbkpt)
150 (ring-tty-bell)
151 (ldebug-ioa "Break " (decimal-rep ldebug-cur-bkpt)
152 " in " (cadr ldebug-cur-bkpte)))
153 (let ((*rset t)
154 (ldebug-trace-indent ldebug-trace-indent))
155 (let ((val (catch (charlisten) gazongues-des-lispes)))
156 (if (eq val 'tres-grandes-gazongues)
157 (go-to-buffer ldebug-buf)
158 (command-quit)
159 else val)))))
160
161 (defprop ldebug-return-to-emacs-top-level
162 "Release the current level of LDEBUG mode, returning to the
163 previous level. All executing code betweent the two levels
164 is aborted."
165 documentation)
166
167 (defun ldebug-return-to-emacs-top-level ()
168 (ldebug-ioa "$g")
169 (throw 'tres-grandes-gazongues gazongues-des-lispes))
170
171 (defun ldebug-ioa n
172 (go-to-end-of-buffer)
173 (insert-string (apply 'catenate (listify n)))
174 (redisplay)
175 (new-line))
176
177 (defprop ldebug-eval-and-print-result
178 "Takes the contents of the current line, reads it as an s-expression,
179 and inserts the result into the buffer, with prinlength and prinlevel
180 bound according to the ldebug-prinlength and ldebug-prinlevel options.
181 The variable * is set to the result of the evaluation, as in the default
182 lisp top-level." documentation)
183
184
185
186 (defun ldebug-eval-and-print-result ()
187 (let ((string (e_lap_$trim
188 (let ((s (curline-as-string)))
189 (let ((sl (stringlength s)))
190 (and (samepnamep (substr s sl 1) NL)
191 (setq s (substr s 1 (1- sl)))))
192 s))))
193 (if (not (nullstringp string))
194 (let ((errset 'ldebug-lisp-toplevel-error-handler))
195 (ldebug-output-to-buffer
196 (let ((fail-act 'ldebug-lisp-toplevel-error-handler)
197
198 (pdl-overflow 'ldebug-lisp-toplevel-error-handler)
199 (wrng-type-arg 'ldebug-lisp-toplevel-error-handler)
200 (*rset-trap 'ldebug-lisp-toplevel-error-handler)
201 (unbnd-vrbl 'ldebug-lisp-toplevel-error-handler)
202 (undf-fnctn 'ldebug-lisp-toplevel-error-handler)
203 (unseen-go-tag 'ldebug-lisp-toplevel-error-handler)
204 (wrng-no-args 'ldebug-lisp-toplevel-error-handler)
205 (ibase ldebug-ibase))
206 (car (errset
207 (prog2 0
208 (setq * (eval (read-from-string string)))
209 (new-line)
210 (insert-string "=> ")) nil)))))
211 else (new-line))))
212
213
214
215
216 (defun ldebug-flush-whitespace (string)
217 (nreverse (ldebug-flush-whitespace-beginning
218 (nreverse (ldebug-flush-whitespace-beginning string)))))
219
220 (defun ldebug-flush-whitespace-beginning (string)
221 (do ((string string (cdr string)))
222 ((not (memq (car string) '(9. 10. 32.)))
223 string)))
224
225 (defprop ldebug-return
226 "Restart the current breakpoint or Lisp error which entered
227 the LDEBUG buffer, restoring buffer, point, and window. If a
228 numeric argument is given, restart this (trace or code) break
229 that many times automatically (including this time). If
230 a Lisp error is being restarted, return the current line's
231 Lisp value to the Lisp error breakpoint."
232 documetation)
233
234 (defun ldebug-return ()
235 (if numarg
236 (ldebug-in-breakp)
237 (ldebug-ioa "Set for " (decimal-rep numarg) " proceeds.")
238 (rplaca ldebug-cur-bkpte numarg))
239 (throw (prog2 0
240 (if (not (line-is-blank))
241 (car (errset
242 (let ((ibase ldebug-ibase))
243 (read-from-string (curline-as-string)))))
244 else nil)
245 (ldebug-ioa "$p"))
246 gazongues-des-lispes))
247
248
249
250
251
252 (defprop ldebug-set-break
253 "Set a breakpoint in the Lisp code pointed at by the cursor.
254 The break number, in decimal, is plaed in the break code,
255 which is placed in the current buffer. The function pointed at
256 is reevaluated. When the break is executed, LDEBUG will be entered."
257 documentation)
258
259 (defun ldebug-set-break ()
260 (setq *rset t)
261 (let ((fn nil))
262 (save-excursion
263 (begin-defun)
264 (down-list-level)
265 (do-times 2 (forward-sexp))
266 (with-mark m
267 (backward-sexp)
268 (setq fn (point-mark-to-string m))))
269 (insert-string
270 (catenate
271 " (%% "
272 (decimal-rep (setq ldebug-break-index (1+ ldebug-break-index)))
273 ".)"))
274 (backward-sexp)
275 (setq ldebug-breaklist
276 (cons (cons ldebug-break-index
277 (list 'live fn current-buffer (set-mark)))
278 ldebug-breaklist))
279 (save-excursion (eval-top-level-form))))
280
281 (defun ldebug-errset-trap (x)
282 (setq x (caddr (errframe nil)))
283 (find-buffer-in-window 'LDEBUG)
284 (new-line)
285 (ldebug-ioa "<<ERROR>>: " (car x))
286 (ldebug-ioa " " (maknam (explodec (cdr x))))
287 (command-quit))
288
289 (defprop ldebug-trace-stack
290 "Insert into the buffer a traceback of the stack." documentation)
291
292 (defun ldebug-trace-stack ()
293 (ldebug-ioa "--STACK TRACE--")
294 (do x (evalframe nil)(evalframe (cadddr x))(null x)
295 (if (< (cadddr x) ldebug-closure)
296 (ldebug-output-to-buffer (caddr x))
297 (redisplay)))
298 (ldebug-ioa "--END TRACE--")
299 (new-line))
300
301 (defprop ldebug-show-bkpt-source
302 "Show the source for the current LDEBUG code breakpoint.
303 If a numeric argument is given, show the source for that breakpoint,
304 by break number."
305 documentation)
306
307 (defun ldebug-show-bkpt-source ()
308 (if numarg (ldebug-display-bkpt-source (ldebug-find-bkpte numarg))
309 else
310 (ldebug-in-breakp)
311 (if (eq (cadddr ldebug-cur-bkpte) '*trace)
312 (display-error "Trace breaks have no source."))
313 (ldebug-display-bkpt-source ldebug-cur-bkpte)))
314
315 (defun ldebug-display-bkpt-source (brk)
316 (find-buffer-in-window (caddr brk))
317 (go-to-mark (cadddr brk)))
318
319 (defprop ldebug-reset-break
320 "With no numeric argument, reset the current (active) LDEBUG
321 code or trace entry break. With a numeric argument, reset
322 the code break of that break number." documentation)
323
324 (defun ldebug-reset-break ()
325 (if numarg (ldebug-reset-bkpte numarg (ldebug-find-bkpte numarg))
326 else
327 (ldebug-in-breakp)
328 (if (eq (cadddr ldebug-cur-bkpte) '*trace)
329 (let ((fn (cadr ldebug-cur-bkpte)))
330 (if (caar (errset (eval (list 'untrace fn))))
331 (rplaca ldebug-cur-bkpte 'dead)
332 (ldebug-ioa "Reset entry break to function " fn)))
333 else
334 (ldebug-reset-bkpte ldebug-cur-bkpt ldebug-cur-bkpte))))
335
336 (defun ldebug-reset-bkpte (bx bkpte)
337 (rplaca bkpte 'dead)
338 (save-excursion-buffer
339 (go-to-buffer (caddr bkpte))
340 (go-to-mark (cadddr bkpte))
341 (backward-char)
342 (kill-sexp)
343 (eval-top-level-form))
344 (minibuffer-print "Reset break " (decimal-rep bx)))
345
346 (defun ldebug-find-bkpte (no)
347 (or (cdr (assoc no ldebug-breaklist))
348 (display-error "Breakpoint " (decimal-rep no) " somehow got lost.")))
349
350 (defprop ldebug-list-breaks
351 "Insert into the LDEBUG buffer a list of all active
352 breakpoints: their number, function, status, and buffer."
353 documentation)
354
355 (defun ldebug-list-breaks ()
356 (if (null ldebug-breaklist)(display-error "No active breaks.")
357 else
358 (ldebug-ioa "BREAK LIST")
359 (ldebug-ioa "# Function Status Buffer")
360 (do l (setq ldebug-breaklist
361 (sort ldebug-breaklist
362 '(lambda (x y)(< (car x)(car y)))))
363 (cdr l)
364 (null l)
365 (let ((n (caar l))(brk (cdar l)))
366 (if (not (eq (car brk) 'dead))
367 (insert-string (decimal-rep n))
368 (format-to-col 6.)
369 (insert-string (cadr brk))
370 (format-to-col 21.)
371 (insert-string (maknam (explodec (car brk))))
372 (format-to-col 30.)
373 (insert-string (caddr brk))
374 (if (eq brk ldebug-cur-bkpte)
375 (format-to-col 50.)
376 (insert-string "<<<"))
377 (redisplay)
378 (new-line))))
379 (ldebug-ioa "END BREAK LIST")))
380
381 (defprop ldebug-display-where-editor-was
382 "Select the buffer (and window, if that buffer is on display),
383 where Emacs was when the current breakpoint was taken. The cursor
384 will be moved to the place where point was when the break was taken.
385 If point is moved, it will remain moved when the break is restarted."
386 documentation)
387
388 (defun ldebug-display-where-editor-was ()
389 (let ((m (save-excursion-buffer
390 (go-to-buffer ldebug-buf)
391 (set-mark))))
392 (find-buffer-in-window ldebug-buf)
393 (go-to-mark m)
394 (release-mark m)))
395
396
397
398
399
400 (defun ldebug-output-to-buffer (form)
401 (insert-string (maknam
402 (let ((prinlevel ldebug-prinlevel)
403 (prinlength ldebug-prinlength)
404 (base ldebug-base))
405 (explode form))))
406 (redisplay)
407 (new-line))
408
409 ^L
410
411
412
413
414
415
416
417 (%include e-macros)
418
419 (declare (special trace-indent-incr trace-indent-max trace-ok-flag
420 ldebug-prinlength ldebug-prinlevel rdis-suppress-redisplay))
421
422 (setq ldebug-trace-indent 0)
423
424 (defun ldebug-trace-printer (arg)
425 (if trace-ok-flag
426 (let ((trace-ok-flag nil))
427 (save-excursion-buffer
428 (go-to-or-create-buffer 'LDEBUG)
429 (go-to-end-of-buffer)
430 (if (empty-buffer-p current-buffer)(ldebug-mode))
431 (ldebug-trace-real-printer
432 (car arg)(cadr arg)(caddr arg)(cadddr arg)(cddddr arg))
433 (if (not (buffer-on-display-in-window 'LDEBUG))
434 (local-display-current-line)))
435 (if (buffer-on-display-in-window 'LDEBUG)
436 (within-LDEBUG/'s-buffer-window (redisplay))))))
437
438 (defun ldebug-trace-real-printer (recurlev type fn arg stuff)
439 (setq ldebug-trace-indent (max 0 ldebug-trace-indent))
440 (new-line)
441 (and (eq type 'exit)(setq ldebug-trace-indent (- ldebug-trace-indent trace-indent-incr)))
442 (whitespace-to-hpos (max 0 (min trace-indent-max ldebug-trace-indent)))
443 (and (eq type 'enter)(setq ldebug-trace-indent (+ ldebug-trace-indent trace-indent-incr)))
444 (insert-string "(")
445 (insert-string (decimal-rep recurlev))
446 (insert-string " ")
447 (insert-string type)
448 (insert-string " ")
449 (insert-string fn)
450 (insert-string " ")
451 (ldebug-trace-insert-lisp-string arg)
452 (mapc '(lambda (x)(insert-string " ")(ldebug-trace-insert-lisp-string x))
453 stuff)
454 (insert-string ")"))))
455
456 (defun ldebug-trace-insert-lisp-string (x)
457 (let ((prinlength ldebug-prinlength)
458 (prinlevel ldebug-prinlevel)
459 (base ldebug-base))
460 (insert-string (maknam (explode x)))))
461
462
463 (defun ldebug-trace-break (fname)
464 (let ((ldebug-closure (e_lap_$get-x7))
465 (ldebug-buf current-buffer)
466 (ldebug-cur-bkpt '*trace)
467 (ldebug-cur-bkpte (or (get fname 'ldebug-trace-break)
468 (putprop fname
469 (list 'live fname '*trace '*trace)
470 'ldebug-trace-break))))
471 (let ((state (car ldebug-cur-bkpte)))
472 (cond ((memq state '(dead benign)))
473 ((eq state 'live)(ldebug-yggdrasil 'trace-break))
474 ((not (numberp state)))
475 ((< state 2)
476 (rplaca ldebug-cur-bkpte 'live)
477 (ldebug-yggdrasil 'curbkpt))
478 (t (rplaca ldebug-cur-bkpte (1- state)))))))
479