eval-region から簡易デバッガ（作りかけ放置版） #xyzzy

gistfile1.lisp

;;; -*- mode: lisp; package: debuggable-eval -*-
;;;
;;; debuggable-eval.l

#|
eval-region からデバッガ、のようなもの（作りかけ放置版）。
色々とアレなので使うのはおすすめしないけど参考になればと貼っておくことにした。

condition-restart の頃に作ったので何もなしに restart-case が使われてる。
ansify なら ansify::install しとけばたぶん動く。restart 使わんなら tagbody
と go を含むクロージャ（restart は内部でそんな事してる）とか catch & throw
（使ったこと無いけど説明読む限りできそう）とかで何とか。
|#

(in-package :lisp)

(export '(break
          * ** ***
          + ++ +++))


(defpackage :debuggable-eval (:use :lisp :editor))
(in-package :debuggable-eval)


(defvar *return-prefix* "=> ")
(defvar *abort-prefix* ">> ")

;;;;
;;;; * Utilities

(defun keyword (name) (intern (string name) :keyword))

(defun function-symbol (fn)
  "Find symbol naming FN."
  (ed::protect-match-data
    (when (string-match "^#<\\(?:lexical-closure\\|function\\): \\(.+\\)>$"
                        (format nil "~S" fn))
      (let ((name (match-string 1)))
        ;(assert (stringp name) (name))
        (when (string-match "^\\(\\sw\\|\\s_\\)+:\\{1,2\\}\\(.+\\)$" name)
          (setf name (match-string 2)))
        (find-if (lambda (symbol)
                   (and (fboundp symbol)
                        (eql (symbol-function symbol) fn)))
          (find-all-symbols name))))))

(defun function-parameter-list (fn)
  (cond
   ((si:*closurep fn)
    (cadr (si:closure-body fn)))
   ((si:*builtin-function-p fn)
    (let ((name (function-symbol fn)))
      (if (null name)
        (cerror "Could not find function symbol: ~S" fn)
        (get name 'si::builtin-function-argument))))))

(defmacro aif (test then &optional else)
  `(let ((it ,test)) (if it ,then ,else)))
#+xyzzy
(setf (get 'aif 'ed:lisp-indent-hook) 1)

(defmacro awhen (test &body body)
  `(let ((it ,test)) (when it ,@body)))
#+xyzzy
(setf (get 'awhen 'ed:lisp-indent-hook) 1)

(defun condition-type (condition)
  (si:*structure-definition-name
   (si:*structure-definition condition)))



(defun get-temp-buffer (name &key (erase t))
  (let ((buffer (get-buffer-create name)))
    (setup-temp-buffer buffer)
    (when erase (erase-buffer buffer))
    buffer))

;;; save-excursion and save-window-excursion are vulnerable to non-local
;;; transfer of control.
(defmacro with-switch-to-window (window &body body)
  `(let ((#1=#:owin (selected-window)))
     (unwind-protect
         (progn
           (set-window ,window)
           ,@body)
       (set-window #1#))))

(defmacro with-switch-to-buffer (buffer &body body)
  `(let ((#1=#:obuf (selected-buffer)))
     (unwind-protect
         (progn
           (set-buffer ,buffer)
           ,@body)
       (set-buffer #1#))))

;;;;
;;;; * Eval with Reproducing Call Stack

(defstruct stack-frame
  function
  arguments
  bindings)

(defun parse-keyword-parameter (param)
  "Return key-symbol, variable, default-form, supplied-p-variable from
 keyword parameter."
  (cond
   ;; keyvar
   ((symbolp param)
    (values (keyword param) param))
   ;; (keyvar default supplied-p-var)
   ((and (consp param) (symbolp (first param)))
    (values-list (cons (keyword (first param)) param)))
   ;; ((key var) default supplied-p-var)
   ((and (consp param) (consp (first param)))
    (let ((first (first param)))
      (values (first first)
              (second first)
              (second param)
              (third param))))
   (t
    (error 'invalid-lambda-list :datum param))))

(defun dispatch-arguments (lambda-list arguments)
  "Dispatch ARGUMENTS to variables in LAMBDA-LIST. If a variable bounds to
 result of evaluation of default-form, store the default-form with mark
 instead of evaluate it."
  (let (bindings rest-var
        (args arguments)
        (state '&required))
    (macrolet ((bind (var value) `(push (cons ,var ,value) bindings))
               (next ()          `(prog1 (car args) (setf args (cdr args)))))
      (dolist (param lambda-list)
        (if (member param lambda-list-keywords :test #'eql)
          (setf state param)
          (case state
            (&required
             (bind param (next)))
            (&optional
             (multiple-value-bind (var default sp-var)
                 (if (consp param) (values-list param) param)
               (when sp-var
                 (bind sp-var (if args t nil)))
               (bind var (if args (next)
                           (if default (list :eval default)
                             nil)))))
            (&rest
             (bind param args)
             (setf rest-var param))
            (&key
             (when (null rest-var)
               (setf rest-var (gensym "KEY-ARGS-"))
               (bind rest-var args))
             (multiple-value-bind (key var default sp-var)
                 (parse-keyword-parameter param)
               (multiple-value-bind (key value found)
                   (get-properties args (list key))
                 (when sp-var
                   (bind sp-var (if found t nil)))
                 (bind var (if found value
                             (if default (list :eval default)
                               nil))))))
            (&aux
             (if (consp param)
               (bind (first param) (second param))
               (bind param nil)))
            (t (error "should not see me."))
            (t (error 'invalid-lambda-list :datum lambda-list)))))
      (nreverse bindings))))

;; NOTE: クソ遅かったので :binding なし版（すぐ下）で上書きされてる
(defun new-stack-frame (fn args)
  (make-stack-frame
   :function fn
   :arguments args
   :bindings (remove-duplicates
              (append (dispatch-arguments (function-parameter-list fn) args)
                      (when (si:*closurep fn)
                        (si:closure-variable fn))))))

(defun new-stack-frame (fn args)
  (make-stack-frame
   :function fn
   :arguments  args))


(defun print-stack-frame-expression (frame stream &optional n)
  (format stream "(~S~{ ~S~})"
    (or (function-symbol (stack-frame-function frame))
        (stack-frame-function frame))
    (stack-frame-arguments frame)))

(defun print-stack-frame-bindings (frame stream)
  (format stream "~&  Local Bindings:~%")
  (dolist (x (stack-frame-bindings frame))
    (let ((var (car x))
          (value (cdr x)))
      (format stream "~&    ~S => " var)
      (if (and (consp value) (eq (first value) :eval))
        (format stream "EVAL: ~S~%" (second value))
        (format stream "~S~%" value)))))


(defparameter *call-stack* nil)
(defparameter *bypass-stacking-apply-hook* nil)

(defun stacking-apply-hook (fn args)
  ;(format t "* ~S~%" fn)
  (if *bypass-stacking-apply-hook*
    (apply fn args)
    (let ((*call-stack* (cons (new-stack-frame fn args) *call-stack*)))
      (applyhook fn args nil #'stacking-apply-hook))))

(defun eval+ (form)
    (evalhook form nil #'stacking-apply-hook nil))

;;;;
;;;; * Pseudo Debugger

(defparameter *debugger-window-finder* nil
  "A function which called with no argument and return a window to display debugger,
 or nil to use selected-window.")

(defparameter *debugger-buffer-name* "*xldb*")
(defparameter *debugger-restart-name-attribute* '(:foreground 1))

(defparameter *debugger-keymap* nil)

(unless *debugger-keymap*
  (setf *debugger-keymap* (make-sparse-keymap))
  (mapc (lambda (key.command)
          (define-key *debugger-keymap* (car key.command) (cdr key.command)))
        '((#\C-g . invoke-abort-or-quit)
          (#\a   . invoke-abort-or-quit)
          (#\c   . invoke-continue)
          (#\C-n . forward-line)
          (#\C-p . previous-line)
          (#\0   . invoke-restart-by-number)
          (#\1   . invoke-restart-by-number)
          (#\2   . invoke-restart-by-number)
          (#\3   . invoke-restart-by-number)
          (#\4   . invoke-restart-by-number)
          (#\5   . invoke-restart-by-number)
          (#\6   . invoke-restart-by-number)
          (#\7   . invoke-restart-by-number)
          (#\8   . invoke-restart-by-number)
          (#\9   . invoke-restart-by-number)
          (#\r   . invoke-restart-by-number)
          (#\RET . invoke-this-restart)
          )))


(defun find-debugger-window ()
  (aif *debugger-window-finder*
    (funcall it)
    (selected-window)))

(defun print-debugging-condition (condition stream)
  (format stream "~&Debugger entered on `~S':~%  ~A~2%"
    (condition-type condition)
    condition))

(defun print-restart-list (restarts stream &aux (i -1))
  (format stream "~&Available Restarts:~%")
  (dolist (r restarts)
    (let ((name (or (restart-name r) "名無しさん"))
          (report (restart::restart-report-function r)))
      (format stream "~&~4D [" (incf i))
      (let ((from (buffer-stream-point stream)))
        (format stream "~10A" name)
        (apply #'set-text-attribute from (buffer-stream-point stream) 'restart
               *debugger-restart-name-attribute*))
      (format stream "] ")
      (if report (funcall report stream) (format stream "~A" name))
      (fresh-line stream)))
  (terpri stream))

(defun print-traceback (call-stack stream &aux (i -1))
  (format stream "Traceback:~%")
  (dolist (frame call-stack)
    (format stream "~&~4D: " (incf i))
    (print-stack-frame-expression frame stream))
  (terpri stream))

;;;;
;;;; * Commands for Debugger

(defun invoke-abort-or-quit (&optional condition)
  (interactive)
  (let ((r (find-restart 'abort condition)))
    (if r
      (invoke-restart-interactively r)
      (quit))))

(defun invoke-continue (&optional condition)
  (interactive)
  (let ((r (find-restart 'continue condition)))
    (if r (invoke-restart-interactively r)
      (message "再起動 continue が見つかりません"))))

(defparameter *available-restarts* nil)
(defparameter *restart-regexp* (compile-regexp "^[ \t]*\\([0-9]+\\) \\["))

(defun invoke-restart-by-number (n)
  (interactive
      (list (or (digit-char-p *last-command-char*)
                (labels ((read-n ()
                           (message "C-g to cancel.")
                           (let ((n (read-integer "Restart: ")))
                             (if (< -1 n (length *available-restarts*))
                               n
                               (read-n)))))
                  (read-n)))))
  (when (and (numberp n)
             (< n (length *available-restarts*)))
    (invoke-restart-interactively (nth n *available-restarts*))))

(defun invoke-this-restart ()
  (interactive)
  (save-excursion
    (goto-bol)
    (when (looking-at *restart-regexp*)
      (invoke-restart-by-number (parse-integer (match-string 1))))))


(defun enter-debugger (condition)
  (let ((*bypass-stacking-apply-hook* t))
    (with-switch-to-window (find-debugger-window)
      (with-switch-to-buffer (get-temp-buffer *debugger-buffer-name* :erase t)
        (let ((*available-restarts* (compute-restarts condition))
              (out (make-buffer-stream (selected-buffer))))
          (format out "Welcome to XLDB. This is your best friend, worst enemy, and everything between.~2%")
          (print-debugging-condition condition out)
          (print-restart-list *available-restarts* out)
          (print-traceback *call-stack* out)
          (refresh-screen)
          ;; Command Loop
          (let (*this-command*
                *last-command*
                *last-command-char*
                (keymap *debugger-keymap*)
                prefixed-keys)
            (loop
              (refresh-screen)
              (setf *last-command-char* (read-char *keyboard*)
                    *this-command* (lookup-keymap keymap *last-command-char*))
              (cond ((commandp *this-command*)
                     (unwind-protect
                         (call-interactively *this-command*)
                       (setf *last-command* *this-command*
                             prefixed-keys nil
                             keymap *debugger-keymap*)))
                    ((keymapp *this-command*)
                     (message "~{~S~^ ~}"
                              (setf prefixed-keys (append prefixed-keys (list *last-command-char*))))
                     (setf keymap *this-command*))
                    (t
                     nil)))))))))


(defvar *debugger-hook* nil
  "*If non-nil, it must be a function accepts two arguments: a condition and the value
 of `*debugger-hook*'.  The function is called prior to entry to debugger, and if it
 returns normally, debugger is entered.")

(defun invoke-debugger (condition)
  (let ((*bypass-stacking-apply-hook* t))
    (when *debugger-hook*
      (let ((fn *debugger-hook*)
            (*debugger-hook* nil))
        (funcall fn condition fn)))
    (enter-debugger condition)))



(defun break (&optional (fmt-control "ブレイク！") &rest args)
  (let ((*bypass-stacking-apply-hook* t))
    (with-simple-restart (continue "構わん、続けろ。")
      (let ((*debugger-hook* nil))
        (invoke-debugger
         (make-condition 'simple-condition
                         :format-string fmt-control
                         :format-arguments args))))
    nil))


;;;;
;;;; * eval-region


(defparameter *this-condition* nil)

(defvar-local -eval-package- nil)
(defvar-local -eval-buffer- nil)
(defvar-local -eval-window- nil)

(defvar-local -eval-results-history- nil)
(defvar-local -eval-expression-history- nil)

(defun eval-region+ (from to &optional stream)
  (interactive "r")
  (when (> from to) (rotatef from to))
  (prog ((result nil)
         (obuff (selected-buffer))
         (s (make-buffer-stream (selected-buffer) from to))
         (*package* (or (when (local-variable-p '-eval-package-) -eval-package-)
                        (find-package (lisp-mode-extra::point-package-name))
                        *package*))
         (*   (first -eval-results-history-))
         (**  (second -eval-results-history-))
         (*** (third -eval-results-history-))
         )
    (unwind-protect
        (handler-bind ((quit
                        (lambda (q)
                          (let ((*this-condition* q)
                                (r (find-restart 'abort q)))
                            (when r (invoke-restart r q :silent (typep q 'silent-quit))))))
                       (warning
                        (lambda (w)
                          (let ((*this-condition* w))
                            (when (and stream)
                              (format t "~&; Warning: ~A~%" w)))))
                       (serious-condition
                        (lambda (e)
                          (let ((*bypass-stacking-apply-hook* t)
                                (*this-condition* e))
                            (invoke-debugger e)))))
          ;(when (windowp -eval-window-) (set-window -eval-window-))
          (when (bufferp -eval-buffer-) (set-buffer -eval-buffer-))
          (restart-case
              (while (< (buffer-stream-point s) to)
                (let ((form (read s nil '#1=#:eof)))
                  (when (eq form '#1#) (return))
                  (setq result (multiple-value-list (eval+ form)))))
            (abort (&optional condition &key silent)
              :report "評価を中止する"
              :interactive (lambda () (list *this-condition*))
              (if silent
                (message "Evaluation aborted~@[: ~A~]" condition)
                (format t "~&; Evaluation aborted~@[ on `~S'~%~]~@[;   ~A~]~%"
                  (when condition (condition-type condition))
                  condition))
              (return (values)))))
      (let ((buffer (selected-buffer)))
        (with-switch-to-buffer obuff
          (setf -eval-buffer- buffer
                -eval-window- (selected-window)
                -eval-package- *package*
                -eval-results-history- (list (car result) * **)))))
    (ed::eval-region-print stream
      (if (null stream)
        (message "~A~S" *return-prefix* (car result))
        (dolist (x result)
          (format t "~A~S~%" *return-prefix* x))))
    (return (values-list result))))

(defconstant +original-eval-region+ #'ed:eval-region)
;(setf (symbol-function 'ed:eval-region) #'debuggable-eval::eval-region+)


(defun check ()
  (interactive)
  (msgbox "~S" (let ((*package* (find-package :debuggable-eval)))
                 (eval (read-sexp ">> ")))))