1 ;;; ***********************************************************
  2 ;;; *                                                         *
  3 ;;; * Copyright, (C) Honeywell Information Systems Inc., 1982 *
  4 ;;; *                                                         *
  5 ;;; * Copyright (c) 1978 by Massachusetts Institute of        *
  6 ;;; * Technology and Honeywell Information Systems, Inc.      *
  7 ;;; *                                                         *
  8 ;;; ***********************************************************
  9 ;;;
 10 ;;;
 11 ;;;       LDEBUG mode cause i needed it
 12 ;;;       BSG 2/24/79
 13 ;;;       Some features by RWK 9/79
 14 ;;;       Lisp trace features by BSG 10/6/79
 15 ;;;       Register-option forms commented out and moved to e_option_defaults_,
 16 ;;;       Barmar 1/19/84
 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)            ; Number of nested breaks
 34 
 35 
 36 ;; User options
 37 
 38 (declare (special ldebug-prinlevel ldebug-prinlength ldebug-base ldebug-ibase))
 39 
 40 ;;; (register-option 'ldebug-prinlevel 6.) ;moved to e_option_defaults_
 41 ;;; (register-option 'ldebug-prinlength 10.) ;moved to e_option_defaults_
 42 ;;; (register-option 'ldebug-base 8.) ;moved to e_option_defaults_
 43 ;;; (register-option 'ldebug-ibase 8.) ;moved to e_option_defaults_
 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 ;Make this loser use backward-sexp to get entire sexpression!
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 ;                            (gc-daemon   'ldebug-lisp-toplevel-error-handler)
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 ;ldebug-flush-whitespace deletes extra white-space off the both ends of
214 ;a string for passing to readline.  Clobbers
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 ;;;       Break format is (number . (state function buffer mark))
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)))                      ;Show while ye grinds.
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 ;print the desired lisp form into the buffer, with right base, prinlevel,
398 ;etc.
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 ;;;       Trace Hackery
412 ;;;       BSG 10/6/79
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