diff --git a/contrib/slynk-mrepl.lisp b/contrib/slynk-mrepl.lisp index 6bf6a8630..51147f4ab 100644 --- a/contrib/slynk-mrepl.lisp +++ b/contrib/slynk-mrepl.lisp @@ -218,7 +218,18 @@ Set this to NIL to turn this feature off.") (unwind-protect (funcall previous-hook condition hook) (pop (mrepl-pending-errors repl)))))))) - (setq results (mrepl-eval-1 repl string) + (setq results (flet ((eval-it () + (mrepl-eval-1 repl string))) + ;; Honour `*eval-for-emacs-wrappers*'. + (loop for lambda = #'eval-it then + (handler-case + (funcall wrapper lambda) + (error (e) + (warn "~s ignoring wrapper ~a (~a)" + 'eval-for-emacs wrapper e) + lambda)) + for wrapper in *eval-for-emacs-wrappers* + finally (return (funcall lambda)))) ;; If somehow the form above MREPL-EVAL-1 exited ;; normally, set ABORTED to nil aborted nil)) diff --git a/slynk/slynk.lisp b/slynk/slynk.lisp index 0458a20a1..26fd7f800 100644 --- a/slynk/slynk.lisp +++ b/slynk/slynk.lisp @@ -200,18 +200,18 @@ Backend code should treat the connection structure as opaque.") ;;;; Connections ;;; ;;; Connection structures represent the network connections between -;;; Emacs and Lisp. +;;; Emacs and Lisp. ;;; (defstruct (connection (:constructor %make-connection) (:conc-name connection-) (:print-function print-connection)) ;; The listening socket. (usually closed) - ;; + ;; (socket (missing-arg) :type t :read-only t) ;; Character I/O stream of socket connection. Read-only to avoid ;; race conditions during initialization. - ;; + ;; (socket-io (missing-arg) :type stream :read-only t) ;; An alist of (ID . CHANNEL) entries. Channels are good for ;; streaming data over the wire (see their description in sly.el) @@ -225,19 +225,19 @@ Backend code should treat the connection structure as opaque.") ;; A list of INSPECTOR objects. Each inspector has its own history ;; of inspected objects. An inspector might also be tied to a ;; specific thread. - ;; + ;; (inspectors '() :type list) ;;Cache of macro-indentation information that ;; has been sent to Emacs. This is used for preparing deltas to ;; update Emacs's knowledge. Maps: symbol -> ;; indentation-specification - ;; + ;; (indentation-cache (make-hash-table :test 'eq) :type hash-table) ;; The list of packages represented in the cache: - ;; + ;; (indentation-cache-packages '()) ;; The communication style used. - ;; + ;; (communication-style nil :type (member nil :spawn :sigio :fd-handler)) ) @@ -461,11 +461,11 @@ The list of patterns is searched for a HEAD `eq' to the car of VALUE. If one is found, the BODY is executed with ARGS bound to the corresponding values in the CDR of VALUE." (let ((operator (gensym "op-")) - (operands (gensym "rand-")) - (tmp (gensym "tmp-"))) + (operands (gensym "rand-")) + (tmp (gensym "tmp-"))) `(let* ((,tmp ,value) - (,operator (car ,tmp)) - (,operands (cdr ,tmp))) + (,operator (car ,tmp)) + (,operands (cdr ,tmp))) (case ,operator ,@(loop for (pattern . body) in patterns collect (if (eq pattern t) @@ -551,7 +551,7 @@ corresponding values in the CDR of VALUE." (defmacro listeners () `(connection-listeners *emacs-connection*)) -(defmethod initialize-instance :after ((l listener) &key initial-env) +(defmethod initialize-instance :after ((l listener) &key initial-env) (with-slots (out in env) l (let ((io (make-two-way-stream in out))) (setf env @@ -702,7 +702,7 @@ corresponding values in the CDR of VALUE." (with-slynk-error-handler (connection) (with-default-listener (connection) (call-with-debugger-hook #'slynk-debugger-hook - function)))))))) + function)))))))) (defun call-with-retry-restart (msg thunk) (loop (with-simple-restart (retry "~a" msg) @@ -1304,12 +1304,12 @@ point the thread terminates and CHANNEL is closed." (cond ((and ch thread) (send-event thread `(:emacs-channel-send ,ch ,msg))) (ch - (encode-message + (encode-message (list :invalid-channel channel-id "No suitable threads for channel") (current-socket-io))) (t - (encode-message + (encode-message (list :invalid-channel channel-id "Channel not found") (current-socket-io)))))) ((:reader-error packet condition) @@ -1416,10 +1416,10 @@ event was found." ;;; FIXME: Make this use SLYNK-MATCH. (defun event-match-p (event pattern) (cond ((or (keywordp pattern) (numberp pattern) (stringp pattern) - (member pattern '(nil t))) - (equal event pattern)) - ((symbolp pattern) t) - ((consp pattern) + (member pattern '(nil t))) + (equal event pattern)) + ((symbolp pattern) t) + ((consp pattern) (case (car pattern) ((or) (some (lambda (p) (event-match-p event p)) (cdr pattern))) (t (and (consp event) @@ -1639,13 +1639,13 @@ converted to lower case." (t (force-output) (let ((tag (make-tag))) - (send-to-emacs `(:eval ,(current-thread-id) ,tag - ,(process-form-for-emacs form))) - (let ((value (caddr (wait-for-event `(:emacs-return ,tag result))))) - (destructure-case value - ((:ok value) value) + (send-to-emacs `(:eval ,(current-thread-id) ,tag + ,(process-form-for-emacs form))) + (let ((value (caddr (wait-for-event `(:emacs-return ,tag result))))) + (destructure-case value + ((:ok value) value) ((:error kind . data) (error "~a: ~{~a~}" kind data)) - ((:abort) (abort)))))))) + ((:abort) (abort)))))))) (defun sly-version-string () "Return a string identifying the SLY version. @@ -1851,9 +1851,9 @@ considered to represent a symbol internal to some current package.)" (untokenize-symbol \"quux\" t \"foo\") ==> \"quux::foo\" (untokenize-symbol nil nil \"foo\") ==> \"foo\" " - (cond ((not package-name) symbol-name) - (internal-p (cat package-name "::" symbol-name)) - (t (cat package-name ":" symbol-name)))) + (cond ((not package-name) symbol-name) + (internal-p (cat package-name "::" symbol-name)) + (t (cat package-name ":" symbol-name)))) (defun char-casifier (string) "Return a function which converts characters in STRING according to `readtable-case'." @@ -1943,7 +1943,8 @@ Fall back to the current if no such package exists." (or (and string (guess-package string)) *package*)) -(defvar *eval-for-emacs-wrappers* nil +(defvar *eval-for-emacs-wrappers* + (list 'wrap-to-allow-user-debugger-hooks) "List of functions for fine-grained control over form evaluation. Each element must be a function taking an arbitrary number of arguments, the first of which is a function of no arguments, call it @@ -1980,7 +1981,7 @@ invoke our debugger. EXTRA-REX-OPTIONS are passed to the functions of ;; (setq result (apply (car form) (cdr form))) (eval form))) ;; Honour *EVAL-FOR-EMACS-WRAPPERS* - ;; + ;; (loop for lambda = #'eval-it then (handler-case (apply wrapper lambda extra-rex-options) @@ -2280,7 +2281,7 @@ MAP -- rewrite the chars in STRING according to this alist." (defvar *canonical-package-nicknames* `((:common-lisp-user . :cl-user)) "Canonical package names to use instead of shortest name/nickname.") - + (defvar *auto-abbreviate-dotted-packages* t "Abbreviate dotted package names to their last component if T.") @@ -2415,6 +2416,29 @@ at least SECONDS." ;;;; Debugger +(defvar *debugger-hook-override* nil + "When non-nil, Slynk will make sure that this function is used as the +`*debugger-hook*'. It should be automatically set by an +`eval-for-emacs' wrapper function such as +`wrap-to-allow-user-debugger-hooks'.") + +(defun wrap-to-allow-user-debugger-hooks (in-function &rest extra-rex-options) + "If evaluating `in-function' causes the `*debugger-hook*' to change, +make certain that Slynk respects this change. This allows end-users to +roll their own `*debugger-hook*' at the top-level." + (flet ((out-function () + (let* ((*debugger-hook* + (or *debugger-hook-override* *debugger-hook*)) + (*debugger-hook-before* *debugger-hook*)) + (prog1 + (funcall in-function) + (let ((*debugger-hook-after* *debugger-hook*)) + (when (not (eq *debugger-hook-before* + *debugger-hook-after*)) + (setf *debugger-hook-override* + *debugger-hook-after*))))))) + #'out-function)) + (defun invoke-sly-debugger (condition) "Sends a message to Emacs declaring that the debugger has been entered, then waits to handle further requests from Emacs. Eventually returns @@ -2554,7 +2578,7 @@ conditions are simply reported." ;; JT@15/08/24: FIXME: Actually, with a nice and proper method-combination for ;; interfaces (as was once quite bravely attempted by Helmut, this variable ;; could go away and contribs could simply add methods to CONDITION-EXTRAS) - ;; + ;; "A property list of extra options describing a condition. This works much like the CONDITION-EXTRAS interface, but can be dynamically bound by contribs when invoking the debugger.") @@ -3420,7 +3444,7 @@ DSPEC is a string and LOCATION a source location. NAME is a string." (name :initarg :name :initform (error "Name this INSPECTOR!") :accessor inspector-name))) (defmethod print-object ((i inspector) s) - (print-unreadable-object (i s :type t) + (print-unreadable-object (i s :type t) (format s "~a/~a" (inspector-name i) (length (inspector-%history i))))) (defmethod initialize-instance :after ((i inspector) &key name) @@ -3826,7 +3850,7 @@ Example: (when (and *emacs-connection* (use-threads-p) ;; FIXME: hardcoded thread name - (equalp (thread-name (current-thread)) "slynk-worker")) + (equalp (thread-name (current-thread)) "slynk-worker")) (setf *thread-list* (delete (current-thread) *thread-list*))) (let* ((plist (thread-attributes (car *thread-list*))) (labels (loop for (key) on plist by #'cddr