commit a9df54930de3f5056bb96ac7183ee9f80d06bb49 parent bde020d77bc19f409bd6343ddbf27bad4928c8bc Author: Lukas Henkel <lh@entf.net> Date: Thu, 21 Apr 2022 22:54:38 +0200 Update sly Diffstat:
82 files changed, 12846 insertions(+), 12819 deletions(-)
diff --git a/elpa/sly-20211121.1002/lib/sly-tests.el b/elpa/sly-20211121.1002/lib/sly-tests.el @@ -1,1546 +0,0 @@ -;;; sly-tests.el --- Automated tests for sly.el -*- lexical-binding: t; -*- -;; -;;;; License -;; Copyright (C) 2003 Eric Marsden, Luke Gorrie, Helmut Eller -;; Copyright (C) 2004,2005,2006 Luke Gorrie, Helmut Eller -;; Copyright (C) 2007,2008,2009 Helmut Eller, Tobias C. Rittweiler -;; Copyright (C) 2013 -;; -;; For a detailed list of contributors, see the manual. -;; -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2 of -;; the License, or (at your option) any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public -;; License along with this program; if not, write to the Free -;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, -;; MA 02111-1307, USA. - - -;;;; Tests -(require 'sly) -(require 'ert nil t) -(require 'ert "lib/ert" t) ;; look for bundled version for Emacs 23 -(require 'cl-lib) -(require 'bytecomp) ; byte-compile-current-file - -(defun sly-shuffle-list (list) - (let* ((len (length list)) - (taken (make-vector len nil)) - (result (make-vector len nil))) - (dolist (e list) - (while (let ((i (random len))) - (cond ((aref taken i)) - (t (aset taken i t) - (aset result i e) - nil))))) - (append result '()))) - -(defun sly-batch-test (&optional test-name randomize) - "Run the test suite in batch-mode. -Exits Emacs when finished. The exit code is the number of failed tests." - (interactive) - (let ((ert-debug-on-error nil) - (timeout 30)) - (sly) - ;; Block until we are up and running. - (let (timed-out) - (run-with-timer timeout nil - (lambda () (setq timed-out t))) - (while (not (sly-connected-p)) - (sit-for 1) - (when timed-out - (when noninteractive - (kill-emacs 252))))) - (sly-sync-to-top-level 5) - (let* ((selector (if randomize - `(member ,@(sly-shuffle-list - (ert-select-tests (or test-name t) t))) - (or test-name t))) - (ert-fun (if noninteractive - 'ert-run-tests-batch - 'ert))) - (let ((stats (funcall ert-fun selector))) - (if noninteractive - (kill-emacs (ert-stats-completed-unexpected stats))))))) - -(defun sly-skip-test (message) - ;; ERT for Emacs 23 and earlier doesn't have `ert-skip' - (if (fboundp 'ert-skip) - (ert-skip message) - (message (concat "SKIPPING: " message)) - (ert-pass))) - -(defun sly-tests--undefine-all () - (dolist (test (ert-select-tests t t)) - (let ((sym (ert-test-name test))) - (cl-assert (eq (get sym 'ert--test) test)) - (cl-remprop sym 'ert--test)))) - -(sly-tests--undefine-all) - -(eval-and-compile - (defun sly-tests-auto-tags () - (append '(sly) - (let ((file-name (or load-file-name - byte-compile-current-file))) - (if (and file-name - (string-match "test/sly-\\(.*\\)\.elc?$" file-name)) - (list 'contrib (intern (match-string 1 file-name))) - '(core))))) - - (defmacro define-sly-ert-test (name &rest args) - "Like `ert-deftest', but set tags automatically. -Also don't error if `ert.el' is missing." - (declare (debug (&define name sexp sexp &rest def-form))) - (let* ((docstring (and (stringp (cl-second args)) - (cl-second args))) - (args (if docstring - (cddr args) - (cdr args))) - (tags (sly-tests-auto-tags))) - `(ert-deftest ,name () ,(or docstring "No docstring for this test.") - :tags ',tags - ,@args))) - - (defun sly-test-ert-test-for (name input i doc _body fails-for style fname) - `(define-sly-ert-test - ,(intern (format "%s-%d" name i)) () - ,(format "For input %s, %s" (truncate-string-to-width - (format "%s" input) - 15 nil nil 'ellipsis) - (replace-regexp-in-string "^.??\\(\\w+\\)" - (lambda (s) (downcase s)) - doc - t)) - ,@(if fails-for - `(:expected-result - '(satisfies - (lambda (result) - (ert-test-result-type-p - result - (if (cl-find-if - (lambda (impl) - (unless (listp impl) - (setq impl (list impl #'(lambda (&rest _ign) t)))) - (and (equal (car impl) (sly-lisp-implementation-name)) - (funcall - (cadr impl) - ;; Appease `version-to-list' for - ;; SBCL. `version-regexp-alist' - ;; doesn't work here. - (replace-regexp-in-string - "[-._+ ]?[[:alnum:]]\\{7,9\\}$" - "-snapshot" - (sly-lisp-implementation-version)) - (caddr impl)))) - ',fails-for) - :failed - :passed)))))) - - ,@(when style - `((let ((style (sly-communication-style))) - (when (not (member style ',style)) - (sly-skip-test (format "test not applicable for style %s" - style)))))) - (apply #',fname ',input)))) - -(defmacro def-sly-test (name args doc inputs &rest body) - "Define a test case. -NAME ::= SYMBOL | (SYMBOL OPTION*) is a symbol naming the test. -OPTION ::= (:fails-for IMPLEMENTATION*) | (:style COMMUNICATION-STYLE*) -ARGS is a lambda-list. -DOC is a docstring. -INPUTS is a list of argument lists, each tested separately. -BODY is the test case. The body can use `sly-check' to test -conditions (assertions)." - (declare (debug (&define name sexp sexp sexp &rest def-form)) - (indent 4)) - (if (not (featurep 'ert)) - (warn "No ert.el found: not defining test %s" - name) - `(progn - ,@(cl-destructuring-bind (name &rest options) - (if (listp name) name (list name)) - (let ((fname (intern (format "sly-test-%s" name)))) - (cons `(defun ,fname ,args - (sly-sync-to-top-level 0.3) - ,@body - (sly-sync-to-top-level 0.3)) - (cl-loop for input in (eval inputs) - for i from 1 - with fails-for = (cdr (assoc :fails-for options)) - with style = (cdr (assoc :style options)) - collect (sly-test-ert-test-for name - input - i - doc - body - fails-for - style - fname)))))))) - -(defmacro sly-check (check &rest body) - (declare (indent defun)) - `(unless (progn ,@body) - (ert-fail ,(cl-etypecase check - (cons `(concat "Ooops, " ,(cons 'format check))) - (string `(concat "Check failed: " ,check)) - (symbol `(concat "Check failed: " ,(symbol-name check))))))) - - -;;;;; Test case definitions -(defun sly-check-top-level () ;(&optional _test-name) - (accept-process-output nil 0.001) - (sly-check "At the top level (no debugging or pending RPCs)" - (sly-at-top-level-p))) - -(defun sly-at-top-level-p () - (and (not (sly-db-get-default-buffer)) - (null (sly-rex-continuations)))) - -(defun sly-wait-condition (name predicate timeout &optional cleanup) - (let ((end (time-add (current-time) (seconds-to-time timeout)))) - (while (not (funcall predicate)) - (let ((now (current-time))) - (sly-message "waiting for condition: %s [%s.%06d]" name - (format-time-string "%H:%M:%S" now) (cl-third now))) - (cond ((time-less-p end (current-time)) - (unwind-protect - (error "Timeout waiting for condition: %S" name) - (funcall cleanup))) - (t - ;; XXX if a process-filter enters a recursive-edit, we - ;; hang forever - (accept-process-output nil 0.1)))))) - -(defun sly-sync-to-top-level (timeout) - (sly-wait-condition "top-level" #'sly-at-top-level-p timeout - (lambda () - (let ((sly-db-buffer - (sly-db-get-default-buffer))) - (when (bufferp sly-db-buffer) - (with-current-buffer sly-db-buffer - (sly-db-quit))))))) - -;; XXX: unused function -(defun sly-check-sly-db-level (expected) - (let ((sly-db-level (let ((sly-db (sly-db-get-default-buffer))) - (if sly-db - (with-current-buffer sly-db - sly-db-level))))) - (sly-check ("SLY-DB level (%S) is %S" expected sly-db-level) - (equal expected sly-db-level)))) - -(defun sly-test-expect (_name expected actual &optional test) - (when (stringp expected) (setq expected (substring-no-properties expected))) - (when (stringp actual) (setq actual (substring-no-properties actual))) - (if test - (should (funcall test expected actual)) - (should (equal expected actual)))) - -(defun sly-db-level () - (let ((sly-db (sly-db-get-default-buffer))) - (if sly-db - (with-current-buffer sly-db - sly-db-level)))) - -(defun sly-sly-db-level= (level) - (equal level (sly-db-level))) - -(eval-when-compile - (defvar sly-test-symbols - '(("foobar") ("foo@bar") ("@foobar") ("foobar@") ("\\@foobar") - ("|asdf||foo||bar|") - ("\\#<Foo@Bar>") - ("\\(setf\\ car\\)")))) - -(defun sly-check-symbol-at-point (prefix symbol suffix) - ;; We test that `sly-symbol-at-point' works at every - ;; character of the symbol name. - (with-temp-buffer - (lisp-mode) - (insert prefix) - (let ((start (point))) - (insert symbol suffix) - (dotimes (i (length symbol)) - (goto-char (+ start i)) - (sly-test-expect (format "Check `%s' (at %d)..." - (buffer-string) (point)) - symbol - (sly-symbol-at-point) - #'equal))))) - - - -(def-sly-test symbol-at-point.2 (sym) - "fancy symbol-name _not_ at BOB/EOB" - sly-test-symbols - (sly-check-symbol-at-point "(foo " sym " bar)")) - -(def-sly-test symbol-at-point.3 (sym) - "fancy symbol-name with leading ," - (cl-remove-if (lambda (s) (eq (aref (car s) 0) ?@)) sly-test-symbols) - (sly-check-symbol-at-point "," sym "")) - -(def-sly-test symbol-at-point.4 (sym) - "fancy symbol-name with leading ,@" - sly-test-symbols - (sly-check-symbol-at-point ",@" sym "")) - -(def-sly-test symbol-at-point.5 (sym) - "fancy symbol-name with leading `" - sly-test-symbols - (sly-check-symbol-at-point "`" sym "")) - -(def-sly-test symbol-at-point.6 (sym) - "fancy symbol-name wrapped in ()" - sly-test-symbols - (sly-check-symbol-at-point "(" sym ")")) - -(def-sly-test symbol-at-point.7 (sym) - "fancy symbol-name wrapped in #< {DEADBEEF}>" - sly-test-symbols - (sly-check-symbol-at-point "#<" sym " {DEADBEEF}>")) - -;;(def-sly-test symbol-at-point.8 (sym) -;; "fancy symbol-name wrapped in #<>" -;; sly-test-symbols -;; (sly-check-symbol-at-point "#<" sym ">")) - -(def-sly-test symbol-at-point.9 (sym) - "fancy symbol-name wrapped in #| ... |#" - sly-test-symbols - (sly-check-symbol-at-point "#|\n" sym "\n|#")) - -(def-sly-test symbol-at-point.10 (sym) - "fancy symbol-name after #| )))(( |# (1)" - sly-test-symbols - (sly-check-symbol-at-point "#| )))(( #|\n" sym "")) - -(def-sly-test symbol-at-point.11 (sym) - "fancy symbol-name after #| )))(( |# (2)" - sly-test-symbols - (sly-check-symbol-at-point "#| )))(( #|" sym "")) - -(def-sly-test symbol-at-point.12 (sym) - "fancy symbol-name wrapped in \"...\"" - sly-test-symbols - (sly-check-symbol-at-point "\"\n" sym "\"\n")) - -(def-sly-test symbol-at-point.13 (sym) - "fancy symbol-name wrapped in \" )))(( \" (1)" - sly-test-symbols - (sly-check-symbol-at-point "\" )))(( \"\n" sym "")) - -(def-sly-test symbol-at-point.14 (sym) - "fancy symbol-name wrapped in \" )))(( \" (1)" - sly-test-symbols - (sly-check-symbol-at-point "\" )))(( \"" sym "")) - -(def-sly-test symbol-at-point.15 (sym) - "symbol-at-point after #." - sly-test-symbols - (sly-check-symbol-at-point "#." sym "")) - -(def-sly-test symbol-at-point.16 (sym) - "symbol-at-point after #+" - sly-test-symbols - (sly-check-symbol-at-point "#+" sym "")) - - -(def-sly-test sexp-at-point.1 (string) - "symbol-at-point after #'" - '(("foo") - ("#:foo") - ("#'foo") - ("#'(lambda (x) x)") - ("()")) - (with-temp-buffer - (lisp-mode) - (insert string) - (goto-char (point-min)) - (sly-test-expect (format "Check sexp `%s' (at %d)..." - (buffer-string) (point)) - string - (sly-sexp-at-point) - #'equal))) - -(def-sly-test narrowing () - "Check that narrowing is properly sustained." - '() - (sly-check-top-level) - (let ((random-buffer-name (symbol-name (cl-gensym))) - (defun-pos) (tmpbuffer)) - (with-temp-buffer - (dotimes (i 100) (insert (format ";;; %d. line\n" i))) - (setq tmpbuffer (current-buffer)) - (setq defun-pos (point)) - (insert (concat "(defun __foo__ (x y)" "\n" - " 'nothing)" "\n")) - (dotimes (i 100) (insert (format ";;; %d. line\n" (+ 100 i)))) - (sly-check "Checking that newly created buffer is not narrowed." - (not (buffer-narrowed-p))) - - (goto-char defun-pos) - (narrow-to-defun) - (sly-check "Checking that narrowing succeeded." - (buffer-narrowed-p)) - - (sly-with-popup-buffer (random-buffer-name) - (sly-check ("Checking that we're in Sly's temp buffer `%s'" - random-buffer-name) - (equal (buffer-name (current-buffer)) random-buffer-name))) - (with-current-buffer random-buffer-name - ;; Notice that we cannot quit the buffer within the extent - ;; of sly-with-output-to-temp-buffer. - (quit-window t)) - (sly-check ("Checking that we've got back from `%s'" - random-buffer-name) - (and (eq (current-buffer) tmpbuffer) - (= (point) defun-pos))) - - (sly-check "Checking that narrowing sustained \ -after quitting Sly's temp buffer." - (buffer-narrowed-p)) - - (let ((sly-buffer-package "SLYNK") - (symbol '*buffer-package*)) - (sly-edit-definition (symbol-name symbol)) - (sly-check ("Checking that we've got M-. into slynk.lisp. %S" symbol) - (string= (file-name-nondirectory (buffer-file-name)) - "slynk.lisp")) - (sly-pop-find-definition-stack) - (sly-check ("Checking that we've got back.") - (and (eq (current-buffer) tmpbuffer) - (= (point) defun-pos))) - - (sly-check "Checking that narrowing sustained after M-," - (buffer-narrowed-p))) - )) - (sly-check-top-level)) - -(defun sly-test--pos-at-line (line) - (save-excursion - (goto-char (point-min)) - (forward-line (1- line)) - (line-beginning-position))) - -(def-sly-test recenter - (pos-line target expected-window-start) - "Test `sly-recenter'." - ;; numbers are actually lines numbers - '(;; region visible, point in region - (2 4 1) - ;; end not visible - (2 (+ wh 2) 2) - ;; end and start not visible - ((+ wh 2) (+ wh 500) (+ wh 2))) - (when noninteractive - (sly-skip-test "Can't test sly-recenter in batch mode")) - (with-temp-buffer - (cl-loop for i from 1 upto 1000 - do (insert (format "%09d\n" i))) - (let* ((win (display-buffer (current-buffer)))) - (cl-flet ((eval-with-wh (form) - (eval `(let ((wh ,(window-text-height win))) - ,form)))) - (with-selected-window win - (goto-char (sly-test--pos-at-line (eval-with-wh pos-line))) - (sly-recenter (sly-test--pos-at-line (eval-with-wh target))) - (redisplay) - (should (= (eval-with-wh expected-window-start) - (line-number-at-pos (window-start))))))))) - -(def-sly-test find-definition - (name buffer-package snippet) - "Find the definition of a function or macro in slynk.lisp." - '(("start-server" "SLYNK" "(defun start-server ") - ("slynk::start-server" "CL-USER" "(defun start-server ") - ("slynk:start-server" "CL-USER" "(defun start-server ") - ("slynk::connection" "CL-USER" "(defstruct (connection") - ("slynk::*emacs-connection*" "CL-USER" "(defvar \\*emacs-connection\\*") - ) - (switch-to-buffer "*scratch*") ; not buffer of definition - (sly-check-top-level) - (let ((orig-buffer (current-buffer)) - (orig-pos (point)) - (enable-local-variables nil) ; don't get stuck on -*- eval: -*- - (sly-buffer-package buffer-package)) - (sly-edit-definition name) - ;; Postconditions - (sly-check ("Definition of `%S' is in slynk.lisp." name) - (string= (file-name-nondirectory (buffer-file-name)) "slynk.lisp")) - (sly-check ("Looking at '%s'." snippet) (looking-at snippet)) - (sly-pop-find-definition-stack) - (sly-check "Returning from definition restores original buffer/position." - (and (eq orig-buffer (current-buffer)) - (= orig-pos (point))))) - (sly-check-top-level)) - -(def-sly-test (find-definition.2 (:fails-for "allegro" "lispworks")) - (buffer-content buffer-package snippet) - "Check that we're able to find definitions even when -confronted with nasty #.-fu." - '(("#.(prog1 nil (defvar *foobar* 42)) - - (defun .foo. (x) - (+ x #.*foobar*)) - - #.(prog1 nil (makunbound '*foobar*)) - " - "SLYNK" - "[ \t]*(defun .foo. " - ) - ("#.(prog1 nil (defvar *foobar* 42)) - - ;; some comment - (defun .foo. (x) - (+ x #.*foobar*)) - - #.(prog1 nil (makunbound '*foobar*)) - " - "SLYNK" - "[ \t]*(defun .foo. " - ) - ("(in-package slynk) -(eval-when (:compile-toplevel) (defparameter *bar* 456)) -(eval-when (:load-toplevel :execute) (makunbound '*bar*)) -(defun bar () #.*bar*) -(defun .foo. () 123)" -"SLYNK" -"[ \t]*(defun .foo. () 123)")) - (let ((sly-buffer-package buffer-package)) - (with-temp-buffer - (insert buffer-content) - (sly-check-top-level) - (sly-eval - `(slynk:compile-string-for-emacs - ,buffer-content - ,(buffer-name) - '((:position 0) (:line 1 1)) - ,nil - ,nil)) - (let ((bufname (buffer-name))) - (sly-edit-definition ".foo.") - (sly-check ("Definition of `.foo.' is in buffer `%s'." bufname) - (string= (buffer-name) bufname)) - (sly-check "Definition now at point." (looking-at snippet))) - ))) - -(def-sly-test (find-definition.3 - (:fails-for "abcl" "allegro" "clisp" "lispworks" - ("sbcl" version< "1.3.0") - "ecl")) - (name source regexp) - "Extra tests for defstruct." - '(("slynk::foo-struct" - "(progn - (defun foo-fun ()) - (defstruct (foo-struct (:constructor nil) (:predicate nil))) -)" - "(defstruct (foo-struct")) - (switch-to-buffer "*scratch*") - (with-temp-buffer - (insert source) - (let ((sly-buffer-package "SLYNK")) - (sly-eval - `(slynk:compile-string-for-emacs - ,source - ,(buffer-name) - '((:position 0) (:line 1 1)) - ,nil - ,nil))) - (let ((temp-buffer (current-buffer))) - (with-current-buffer "*scratch*" - (sly-edit-definition name) - (sly-check ("Definition of %S is in buffer `%s'." - name temp-buffer) - (eq (current-buffer) temp-buffer)) - (sly-check "Definition now at point." (looking-at regexp))) - ))) - -(def-sly-test complete-symbol - (prefix expected-completions) - "Find the completions of a symbol-name prefix." - '(("cl:compile" (("cl:compile" "cl:compile-file" "cl:compile-file-pathname" - "cl:compiled-function" "cl:compiled-function-p" - "cl:compiler-macro" "cl:compiler-macro-function") - "cl:compile")) - ("cl:foobar" (nil "")) - ("slynk::compile-file" (("slynk::compile-file" - "slynk::compile-file-for-emacs" - "slynk::compile-file-if-needed" - "slynk::compile-file-output" - "slynk::compile-file-pathname") - "slynk::compile-file")) - ("cl:m-v-l" (nil ""))) - (let ((completions (sly-simple-completions prefix))) - (sly-test-expect "Completion set" expected-completions completions))) - -(def-sly-test flex-complete-symbol - (prefix expectations) - "Find the flex completions of a symbol-name prefix." - '(("m-v-b" (("multiple-value-bind" 1))) - ("mvbind" (("multiple-value-bind" 1))) - ("mvcall" (("multiple-value-call" 1))) - ("mvlist" (("multiple-value-list" 3))) - ("echonumberlist" (("slynk:*echo-number-alist*" 1)))) - (let* ((sly-buffer-package "COMMON-LISP") - (completions (car (sly-flex-completions prefix)))) - (cl-loop for (completion before-or-at) in expectations - for pos = (cl-position completion completions :test #'string=) - unless pos - do (ert-fail (format "Didn't find %s in the completions for %s" completion prefix)) - unless (< pos before-or-at) - do (ert-fail (format "Expected to find %s in the first %s completions for %s, but it came in %s -=> %s" - completion before-or-at prefix (1+ pos) - (cl-subseq completions 0 (1+ pos))))))) - -(def-sly-test basic-completion - (input-keys expected-result) - "Test `sly-read-from-minibuffer' with INPUT-KEYS as events." - '(("( r e v e TAB TAB SPC ' ( 1 SPC 2 SPC 3 ) ) RET" - "(reverse '(1 2 3))") - ("( c l : c o n TAB s t a n t l TAB TAB SPC 4 2 ) RET" - "(cl:constantly 42)")) - (when noninteractive - (sly-skip-test "Can't use unread-command-events in batch mode")) - (setq unread-command-events (listify-key-sequence (kbd input-keys))) - (let ((actual-result (sly-read-from-minibuffer "Test: "))) - (sly-test-expect "Completed string" expected-result actual-result))) - -(def-sly-test arglist - ;; N.B. Allegro apparently doesn't return the default values of - ;; optional parameters. Thus the regexp in the start-server - ;; expected value. In a perfect world we'd find a way to smooth - ;; over this difference between implementations--perhaps by - ;; convincing Franz to provide a function that does what we want. - (function-name expected-arglist) - "Lookup the argument list for FUNCTION-NAME. -Confirm that EXPECTED-ARGLIST is displayed." - '(("slynk::operator-arglist" "(slynk::operator-arglist name package)") - ("slynk::compute-backtrace" "(slynk::compute-backtrace start end)") - ("slynk::emacs-connected" "(slynk::emacs-connected)") - ("slynk::compile-string-for-emacs" - "(slynk::compile-string-for-emacs \ -string buffer position filename policy)") - ("slynk::connection-socket-io" - "(slynk::connection-socket-io \ -\\(struct\\(ure\\)?\\|object\\|instance\\|x\\|connection\\))") - ("cl:lisp-implementation-type" "(cl:lisp-implementation-type)") - ("cl:class-name" - "(cl:class-name \\(class\\|object\\|instance\\|structure\\))")) - (let ((arglist (sly-eval `(slynk:operator-arglist ,function-name - "slynk")))) - (sly-test-expect "Argument list is as expected" - expected-arglist (and arglist (downcase arglist)) - (lambda (pattern arglist) - (and arglist (string-match pattern arglist)))))) - -(defun sly-test--compile-defun (program subform) - (sly-check-top-level) - (with-temp-buffer - (lisp-mode) - (insert program) - (let ((font-lock-verbose nil)) - (setq sly-buffer-package ":slynk") - (sly-compile-string (buffer-string) 1) - (setq sly-buffer-package ":cl-user") - (sly-sync-to-top-level 5) - (goto-char (point-max)) - (call-interactively 'sly-previous-note) - (sly-check error-location-correct - (equal (read (current-buffer)) subform)))) - (sly-check-top-level)) - -(def-sly-test (compile-defun (:fails-for "allegro" "lispworks" "clisp")) - (program subform) - "Compile PROGRAM containing errors. -Confirm that the EXPECTED subform is correctly located." - '(("(defun cl-user::foo () (cl-user::bar))" (cl-user::bar)) - ("(defun cl-user::foo () - #\\space - ;;Sdf - (cl-user::bar))" - (cl-user::bar)) - ("(defun cl-user::foo () - #+(or)skipped - #| #||# - #||# |# - (cl-user::bar))" - (cl-user::bar)) - ("(defun cl-user::foo () - \"\\\" bla bla \\\"\" - (cl-user::bar))" - (cl-user::bar)) - ("(defun cl-user::foo () - #.*log-events* - (cl-user::bar))" - (cl-user::bar)) - ("#.'(defun x () (/ 1 0)) - (defun foo () - (cl-user::bar)) - - " - (cl-user::bar))) - (sly-test--compile-defun program subform)) - -;; This test ideally would be collapsed into the previous -;; compile-defun test, but only 1 case fails for ccl--and that's here -(def-sly-test (compile-defun-with-reader-conditionals - (:fails-for "allegro" "lispworks" "clisp" "ccl")) - (program expected) - "Compile PROGRAM containing errors. -Confirm that the EXPECTED subform is correctly located." - '(("(defun foo () - #+#.'(:and) (/ 1 0))" - (/ 1 0))) - (sly-test--compile-defun program expected)) - -;; SBCL used to pass this one but since 1.2.2 the backquote/unquote -;; reader was changed. See -;; https://bugs.launchpad.net/sbcl/+bug/1361502 -(def-sly-test (compile-defun-with-backquote - (:fails-for "sbcl" "allegro" "lispworks" "clisp")) - (program subform) - "Compile PROGRAM containing errors. -Confirm that SUBFORM is correctly located." - '(("(defun cl-user::foo () - (list `(1 ,(random 10) 2 ,@(make-list (random 10)) 3 - ,(cl-user::bar))))" - (cl-user::bar))) - (sly-test--compile-defun program subform)) - -(def-sly-test (compile-file (:fails-for "allegro" "lispworks" "clisp")) - (string) - "Insert STRING in a file, and compile it." - `((,(pp-to-string '(defun foo () nil)))) - (let ((filename "/tmp/sly-tmp-file.lisp")) - (with-temp-file filename - (insert string)) - (let ((cell (cons nil nil))) - (sly-eval-async - `(slynk:compile-file-for-emacs ,filename nil) - (sly-rcurry (lambda (result cell) - (setcar cell t) - (setcdr cell result)) - cell)) - (sly-wait-condition "Compilation finished" (lambda () (car cell)) - 0.5) - (let ((result (cdr cell))) - (sly-check "Compilation successfull" - (eq (sly-compilation-result.successp result) t)))))) - -(def-sly-test utf-8-source - (input output) - "Source code containing utf-8 should work" - (list (let* ((bytes "\343\201\212\343\201\257\343\202\210\343\201\206") - ;;(encode-coding-string (string #x304a #x306f #x3088 #x3046) - ;; 'utf-8) - (string (decode-coding-string bytes 'utf-8-unix))) - (cl-assert (equal bytes (encode-coding-string string 'utf-8-unix))) - (list (concat "(defun cl-user::foo () \"" string "\")") - string))) - (sly-eval `(cl:eval (cl:read-from-string ,input))) - (sly-test-expect "Eval result correct" - output (sly-eval '(cl-user::foo))) - (let ((cell (cons nil nil))) - (let ((hook (sly-curry (lambda (cell &rest _) (setcar cell t)) cell))) - (add-hook 'sly-compilation-finished-hook hook) - (unwind-protect - (progn - (sly-compile-string input 0) - (sly-wait-condition "Compilation finished" - (lambda () (car cell)) - 0.5) - (sly-test-expect "Compile-string result correct" - output (sly-eval '(cl-user::foo)))) - (remove-hook 'sly-compilation-finished-hook hook)) - (let ((filename "/tmp/sly-tmp-file.lisp")) - (setcar cell nil) - (add-hook 'sly-compilation-finished-hook hook) - (unwind-protect - (with-temp-buffer - (when (fboundp 'set-buffer-multibyte) - (set-buffer-multibyte t)) - (setq buffer-file-coding-system 'utf-8-unix) - (setq buffer-file-name filename) - (insert ";; -*- coding: utf-8-unix -*- \n") - (insert input) - (let ((coding-system-for-write 'utf-8-unix)) - (write-region nil nil filename nil t)) - (let ((sly-load-failed-fasl 'always)) - (sly-compile-and-load-file) - (sly-wait-condition "Compilation finished" - (lambda () (car cell)) - 0.5)) - (sly-test-expect "Compile-file result correct" - output (sly-eval '(cl-user::foo)))) - (remove-hook 'sly-compilation-finished-hook hook) - (ignore-errors (delete-file filename))))))) - -(def-sly-test async-eval-debugging (depth) - "Test recursive debugging of asynchronous evaluation requests." - '((1) (2) (3)) - (let ((depth depth) - (debug-hook-max-depth 0)) - (let ((debug-hook - (lambda () - (with-current-buffer (sly-db-get-default-buffer) - (when (> sly-db-level debug-hook-max-depth) - (setq debug-hook-max-depth sly-db-level) - (if (= sly-db-level depth) - ;; We're at maximum recursion - time to unwind - (sly-db-quit) - ;; Going down - enter another recursive debug - ;; Recursively debug. - (sly-eval-async '(error)))))))) - (let ((sly-db-hook (cons debug-hook sly-db-hook))) - (sly-eval-async '(error)) - (sly-sync-to-top-level 5) - (sly-check ("Maximum depth reached (%S) is %S." - debug-hook-max-depth depth) - (= debug-hook-max-depth depth)))))) - -(def-sly-test unwind-to-previous-sly-db-level (level2 level1) - "Test recursive debugging and returning to lower SLY-DB levels." - '((2 1) (4 2)) - (sly-check-top-level) - (let ((level2 level2) - (level1 level1) - (state 'enter) - (max-depth 0)) - (let ((debug-hook - (lambda () - (with-current-buffer (sly-db-get-default-buffer) - (setq max-depth (max sly-db-level max-depth)) - (cl-ecase state - (enter - (cond ((= sly-db-level level2) - (setq state 'leave) - (sly-db-invoke-restart (sly-db-first-abort-restart))) - (t - (sly-eval-async `(cl:aref cl:nil ,sly-db-level))))) - (leave - (cond ((= sly-db-level level1) - (setq state 'ok) - (sly-db-quit)) - (t - (sly-db-invoke-restart (sly-db-first-abort-restart)) - )))))))) - (let ((sly-db-hook (cons debug-hook sly-db-hook))) - (sly-eval-async `(cl:aref cl:nil 0)) - (sly-sync-to-top-level 15) - (sly-check-top-level) - (sly-check ("Maximum depth reached (%S) is %S." max-depth level2) - (= max-depth level2)) - (sly-check ("Final state reached.") - (eq state 'ok)))))) - -(defun sly-db-first-abort-restart () - (let ((case-fold-search t)) - (cl-position-if (lambda (x) (string-match "abort" (car x))) sly-db-restarts))) - -(def-sly-test loop-interrupt-quit - () - "Test interrupting a loop." - '(()) - (sly-check-top-level) - (sly-eval-async '(cl:loop) (lambda (_) ) "CL-USER") - (accept-process-output nil 1) - (sly-check "In eval state." (sly-busy-p)) - (sly-interrupt) - (sly-wait-condition "First interrupt" (lambda () (sly-sly-db-level= 1)) 5) - (with-current-buffer (sly-db-get-default-buffer) - (sly-db-quit)) - (sly-sync-to-top-level 5) - (sly-check-top-level)) - -(def-sly-test loop-interrupt-continue-interrupt-quit - () - "Test interrupting a previously interrupted but continued loop." - '(()) - (sly-check-top-level) - (sly-eval-async '(cl:loop) (lambda (_) ) "CL-USER") - (sleep-for 1) - (sly-wait-condition "running" #'sly-busy-p 5) - (sly-interrupt) - (sly-wait-condition "First interrupt" (lambda () (sly-sly-db-level= 1)) 5) - (with-current-buffer (sly-db-get-default-buffer) - (sly-db-continue)) - (sly-wait-condition "running" (lambda () - (and (sly-busy-p) - (not (sly-db-get-default-buffer)))) 5) - (sly-interrupt) - (sly-wait-condition "Second interrupt" (lambda () (sly-sly-db-level= 1)) 5) - (with-current-buffer (sly-db-get-default-buffer) - (sly-db-quit)) - (sly-sync-to-top-level 5) - (sly-check-top-level)) - -(def-sly-test interactive-eval - () - "Test interactive eval and continuing from the debugger." - '(()) - (sly-check-top-level) - (let ((sly-db-hook (lambda () - (sly-db-continue)))) - (sly-interactive-eval - "(progn\ - (cerror \"foo\" \"restart\")\ - (cerror \"bar\" \"restart\")\ - (+ 1 2))") - (sly-sync-to-top-level 5) - (current-message)) - (unless noninteractive - (should (equal "=> 3 (2 bits, #x3, #o3, #b11)" - (current-message))))) - -(def-sly-test report-condition-with-circular-list - (format-control format-argument) - "Test conditions involving circular lists." - '(("~a" "(let ((x (cons nil nil))) (setf (cdr x) x))") - ("~a" "(let ((x (cons nil nil))) (setf (car x) x))") - ("~a" "(let ((x (cons (make-string 100000 :initial-element #\\X) nil)))\ - (setf (cdr x) x))")) - (sly-check-top-level) - (let ((done nil)) - (let ((sly-db-hook (lambda () (sly-db-continue) (setq done t)))) - (sly-interactive-eval - (format "(with-standard-io-syntax (cerror \"foo\" \"%s\" %s) (+ 1 2))" - format-control format-argument)) - (while (not done) (accept-process-output)) - (sly-sync-to-top-level 5) - (sly-check-top-level) - (unless noninteractive - (let ((message (current-message))) - (sly-check "Minibuffer contains: \"3\"" - (equal "=> 3 (2 bits, #x3, #o3, #b11)" message))))))) - -(def-sly-test interrupt-bubbling-idiot - () - "Test interrupting a loop that sends a lot of output to Emacs." - '(()) - (accept-process-output nil 1) - (sly-check-top-level) - (sly-eval-async '(cl:loop :for i :from 0 :do (cl:progn (cl:print i) - (cl:finish-output))) - (lambda (_) ) - "CL-USER") - (sleep-for 1) - (sly-interrupt) - (sly-wait-condition "Debugger visible" - (lambda () - (and (sly-sly-db-level= 1) - (get-buffer-window (sly-db-get-default-buffer)))) - 30) - (with-current-buffer (sly-db-get-default-buffer) - (sly-db-quit)) - (sly-sync-to-top-level 5)) - -(def-sly-test (interrupt-encode-message (:style :sigio)) - () - "Test interrupt processing during slynk::encode-message" - '(()) - (sly-eval-async '(cl:loop :for i :from 0 - :do (slynk::background-message "foo ~d" i))) - (sleep-for 1) - (sly-eval-async '(cl:/ 1 0)) - (sly-wait-condition "Debugger visible" - (lambda () - (and (sly-sly-db-level= 1) - (get-buffer-window (sly-db-get-default-buffer)))) - 30) - (with-current-buffer (sly-db-get-default-buffer) - (sly-db-quit)) - (sly-sync-to-top-level 5)) - -(def-sly-test inspector - (exp) - "Test basic inspector workingness." - '(((let ((h (make-hash-table))) - (loop for i below 10 do (setf (gethash i h) i)) - h)) - ((make-array 10)) - ((make-list 10)) - ('cons) - (#'cons)) - (sly-inspect (prin1-to-string exp)) - (cl-assert (not (sly-inspector-visible-p))) - (sly-wait-condition "Inspector visible" #'sly-inspector-visible-p 5) - (with-current-buffer (window-buffer (selected-window)) - (sly-inspector-quit)) - (sly-wait-condition "Inspector closed" - (lambda () (not (sly-inspector-visible-p))) - 5) - (sly-sync-to-top-level 1)) - -(defun sly-buffer-visible-p (name) - (let ((buffer (window-buffer (selected-window)))) - (string-match name (buffer-name buffer)))) - -(defun sly-inspector-visible-p () - (sly-buffer-visible-p (sly-buffer-name :inspector :connection t))) - -(defun sly-execute-as-command (name) - "Execute `name' as if it was done by the user through the -Command Loop. Similiar to `call-interactively' but also pushes on -the buffer's undo-list." - (undo-boundary) - (call-interactively name)) - -(def-sly-test macroexpand - (macro-defs bufcontent expansion1 search-str expansion2) - "foo" - '((("(defmacro qwertz (&body body) `(list :qwertz ',body))" - "(defmacro yxcv (&body body) `(list :yxcv (qwertz ,@body)))") - "(yxcv :A :B :C)" - "(list :yxcv (qwertz :a :b :c))" - "(qwertz" - "(list :yxcv (list :qwertz '(:a :b :c)))")) - (sly-check-top-level) - (setq sly-buffer-package ":slynk") - (with-temp-buffer - (lisp-mode) - (dolist (def macro-defs) - (sly-compile-string def 0) - (sly-sync-to-top-level 5)) - (insert bufcontent) - (goto-char (point-min)) - (sly-execute-as-command 'sly-macroexpand-1) - (sly-wait-condition "Macroexpansion buffer visible" - (lambda () - (sly-buffer-visible-p - (sly-buffer-name :macroexpansion))) - 5) - (with-current-buffer (get-buffer (sly-buffer-name :macroexpansion)) - (sly-test-expect "Initial macroexpansion is correct" - expansion1 - (downcase (buffer-string)) - #'sly-test-macroexpansion=) - (search-forward search-str) - (backward-up-list) - (sly-execute-as-command 'sly-macroexpand-1-inplace) - (sly-sync-to-top-level 3) - (sly-test-expect "In-place macroexpansion is correct" - expansion2 - (downcase (buffer-string)) - #'sly-test-macroexpansion=) - (sly-execute-as-command 'sly-macroexpand-undo) - (sly-test-expect "Expansion after undo is correct" - expansion1 - (downcase (buffer-string)) - #'sly-test-macroexpansion=))) - (setq sly-buffer-package ":cl-user")) - -(defun sly-test-macroexpansion= (string1 string2 &optional ignore-case) - (let ((string1 (replace-regexp-in-string " *\n *" " " string1)) - (string2 (replace-regexp-in-string " *\n *" " " string2))) - (compare-strings string1 nil nil - string2 nil nil - ignore-case))) - -(def-sly-test indentation (buffer-content point-markers) - "Check indentation update to work correctly." - '((" -\(in-package :slynk) - -\(defmacro with-lolipop (&body body) - `(progn ,@body)) - -\(defmacro lolipop (&body body) - `(progn ,@body)) - -\(with-lolipop - 1 - 2 - 42) - -\(lolipop - 1 - 2 - 23) -" - ("23" "42"))) - (with-temp-buffer - (lisp-mode) - (sly-editing-mode 1) - (insert buffer-content) - (sly-compile-region (point-min) (point-max)) - (sly-sync-to-top-level 3) - (sly-update-indentation) - (sly-sync-to-top-level 3) - (dolist (marker point-markers) - (search-backward marker) - (beginning-of-defun) - (indent-region (point) (progn (end-of-defun) (point)))) - (sly-test-expect "Correct buffer content" - buffer-content - (substring-no-properties (buffer-string))))) - -(def-sly-test break - (times exp) - "Test whether BREAK invokes SLY-DB." - (let ((exp1 '(break))) - `((1 ,exp1) (2 ,exp1) (3 ,exp1))) - (accept-process-output nil 0.2) - (sly-check-top-level) - (sly-eval-async - `(cl:eval (cl:read-from-string - ,(prin1-to-string `(dotimes (i ,times) - (unless (= i 0) - (slynk::sleep-for 1)) - ,exp))))) - (dotimes (_i times) - (sly-wait-condition "Debugger visible" - (lambda () - (and (sly-sly-db-level= 1) - (get-buffer-window - (sly-db-get-default-buffer)))) - 3) - (with-current-buffer (sly-db-get-default-buffer) - (sly-db-continue)) - (sly-wait-condition "sly-db closed" - (lambda () (not (sly-db-get-default-buffer))) - 0.5)) - (sly-sync-to-top-level 1)) - -(def-sly-test (break2 (:fails-for "cmucl" "allegro")) - (times exp) - "Backends should arguably make sure that BREAK does not depend -on *DEBUGGER-HOOK*." - (let ((exp2 - '(block outta - (let ((*debugger-hook* (lambda (c h) (return-from outta 42)))) - (break))))) - `((1 ,exp2) (2 ,exp2) (3 ,exp2))) - (sly-test-break times exp)) - -(def-sly-test locally-bound-debugger-hook - () - "Test that binding *DEBUGGER-HOOK* locally works properly." - '(()) - (accept-process-output nil 1) - (sly-check-top-level) - (sly-compile-string - (prin1-to-string `(defun cl-user::quux () - (block outta - (let ((*debugger-hook* - (lambda (c hook) - (declare (ignore c hook)) - (return-from outta 42)))) - (error "FOO"))))) - 0) - (sly-sync-to-top-level 2) - (sly-eval-async '(cl-user::quux)) - ;; FIXME: sly-wait-condition returns immediately if the test returns true - (sly-wait-condition "Checking that Debugger does not popup" - (lambda () - (not (sly-db-get-default-buffer))) - 3) - (sly-sync-to-top-level 5)) - -(def-sly-test end-of-file - (expr) - "Signalling END-OF-FILE should invoke the debugger." - '(((cl:read-from-string "")) - ((cl:error 'cl:end-of-file))) - (let ((value (sly-eval - `(cl:let ((condition nil)) - (cl:with-simple-restart - (cl:continue "continue") - (cl:let ((cl:*debugger-hook* - (cl:lambda (c h) - (cl:setq condition c) - (cl:continue)))) - ,expr)) - (cl:and (cl:typep condition 'cl:end-of-file)))))) - (sly-test-expect "Debugger invoked" t value))) - -(def-sly-test interrupt-at-toplevel - () - "Let's see what happens if we send a user interrupt at toplevel." - '(()) - (sly-check-top-level) - (unless (and (eq (sly-communication-style) :spawn) - (not (featurep 'sly-repl))) - (sly-interrupt) - (sly-wait-condition - "Debugger visible" - (lambda () - (and (sly-sly-db-level= 1) - (get-buffer-window (sly-db-get-default-buffer)))) - 5) - (with-current-buffer (sly-db-get-default-buffer) - (sly-db-quit)) - (sly-sync-to-top-level 5))) - -(def-sly-test interrupt-in-debugger (interrupts continues) - "Let's see what happens if we interrupt the debugger. -INTERRUPTS ... number of nested interrupts -CONTINUES ... how often the continue restart should be invoked" - '((1 0) (2 1) (4 2)) - (sly-check "No debugger" (not (sly-db-get-default-buffer))) - (when (and (eq (sly-communication-style) :spawn) - (not (featurep 'sly-repl))) - (sly-eval-async '(slynk::without-sly-interrupts - (slynk::receive))) - (sit-for 0.2)) - (dotimes (i interrupts) - (sly-interrupt) - (let ((level (1+ i))) - (sly-wait-condition (format "Debug level %d reachend" level) - (lambda () (equal (sly-db-level) level)) - 2))) - (dotimes (i continues) - (with-current-buffer (sly-db-get-default-buffer) - (sly-db-continue)) - (let ((level (- interrupts (1+ i)))) - (sly-wait-condition (format "Return to debug level %d" level) - (lambda () (equal (sly-db-level) level)) - 2))) - (with-current-buffer (sly-db-get-default-buffer) - (sly-db-quit)) - (sly-sync-to-top-level 1)) - -(def-sly-test flow-control - (n delay interrupts) - "Let Lisp produce output faster than Emacs can consume it." - `((300 0.03 3)) - (when noninteractive - (sly-skip-test "test is currently unstable")) - (sly-check "No debugger" (not (sly-db-get-default-buffer))) - (sly-eval-async `(slynk:flow-control-test ,n ,delay)) - (sleep-for 0.2) - (dotimes (_i interrupts) - (sly-interrupt) - (sly-wait-condition "In debugger" (lambda () (sly-sly-db-level= 1)) 5) - (sly-check "In debugger" (sly-sly-db-level= 1)) - (with-current-buffer (sly-db-get-default-buffer) - (sly-db-continue)) - (sly-wait-condition "No debugger" (lambda () (sly-sly-db-level= nil)) 3) - (sly-check "Debugger closed" (sly-sly-db-level= nil))) - (sly-sync-to-top-level 10)) - -(def-sly-test sbcl-world-lock - (n delay) - "Print something from *MACROEXPAND-HOOK*. -In SBCL, the compiler grabs a lock which can be problematic because -no method dispatch code can be generated for other threads. -This test will fail more likely before dispatch caches are warmed up." - '((10 0.03) - ;;((cl:+ slynk::send-counter-limit 10) 0.03) - ) - (sly-test-expect "no error" - 123 - (sly-eval - `(cl:let ((cl:*macroexpand-hook* - (cl:lambda (fun form env) - (slynk:flow-control-test ,n ,delay) - (cl:funcall fun form env)))) - (cl:eval '(cl:macrolet ((foo () 123)) - (foo))))))) - -(def-sly-test (disconnect-one-connection (:style :spawn)) () - "`sly-disconnect' should disconnect only the current connection" - '(()) - (let ((connection-count (length sly-net-processes)) - (old-connection sly-default-connection) - (sly-connected-hook nil)) - (unwind-protect - (let ((sly-dispatching-connection - (sly-connect "localhost" - ;; Here we assume that the request will - ;; be evaluated in its own thread. - (sly-eval `(slynk:create-server - :port 0 ; use random port - :style :spawn - :dont-close nil))))) - (sly-sync-to-top-level 3) - (sly-disconnect) - (sly-test-expect "Number of connections must remane the same" - connection-count - (length sly-net-processes))) - (sly-select-connection old-connection)))) - -(def-sly-test disconnect-and-reconnect - () - "Close the connetion. -Confirm that the subprocess continues gracefully. -Reconnect afterwards." - '(()) - (sly-check-top-level) - (let* ((c (sly-connection)) - (p (sly-inferior-process c))) - (with-current-buffer (process-buffer p) - (erase-buffer)) - (delete-process c) - (cl-assert (equal (process-status c) 'closed) nil "Connection not closed") - (accept-process-output nil 0.1) - (cl-assert (equal (process-status p) 'run) nil "Subprocess not running") - (with-current-buffer (process-buffer p) - (cl-assert (< (buffer-size) 500) nil "Unusual output")) - (sly-inferior-connect p (sly-inferior-lisp-args p)) - (let ((hook nil) (p p)) - (setq hook (lambda () - (sly-test-expect - "We are connected again" p (sly-inferior-process)) - (remove-hook 'sly-connected-hook hook))) - (add-hook 'sly-connected-hook hook) - (sly-wait-condition "Lisp restarted" - (lambda () - (not (member hook sly-connected-hook))) - 5)))) - - -;;;; SLY-loading tests that launch separate Emacsen -;;;; -(defvar sly-test-check-repl-forms - `((unless (and (featurep 'sly-mrepl) - (assq 'slynk/mrepl sly-contrib--required-slynk-modules)) - (die "`sly-repl' contrib not properly setup")) - (let ((mrepl-buffer (sly-mrepl--find-buffer))) - (unless mrepl-buffer - (die "MREPL buffer not setup!")) - (with-current-buffer mrepl-buffer - ;; FIXME: suboptimal: wait one second for the lisp - ;; to reply. - (sit-for 1) - (unless (and (string-match "^; +SLY" (buffer-string)) - (string-match "CL-USER> *$" (buffer-string))) - (die (format "MREPL prompt: %s" (buffer-string)))))))) - -(defvar sly-test-check-asdf-loader-forms - `((when (sly-eval '(cl:and (cl:find-package :slynk-loader) t)) - (die "Didn't expect SLY to be loaded with slynk-loader.lisp")))) - -(cl-defun sly-test-recipe-test-for - (&key preflight - (takeoff `((call-interactively 'sly))) - (landing (append sly-test-check-repl-forms - sly-test-check-asdf-loader-forms))) - (let ((success nil) - (test-file (make-temp-file "sly-recipe-" nil ".el")) - (test-forms - `((require 'cl) - (labels - ((die (reason &optional more) - (princ reason) - (terpri) - (and more (pp more)) - (kill-emacs 254))) - (condition-case err - (progn ,@preflight - ,@takeoff - ,(when (null landing) '(kill-emacs 0)) - (add-hook - 'sly-connected-hook - #'(lambda () - (condition-case err - (progn - ,@landing - (kill-emacs 0)) - (error - (die "Unexpected error running landing forms" - err)))) - t)) - (error - (die "Unexpected error running preflight/takeoff forms" err))) - (with-timeout - (30 - (die "Timeout waiting for recipe test to finish.")) - (while t (sit-for 1))))))) - (unwind-protect - (progn - (with-temp-buffer - (mapc #'insert (mapcar #'pp-to-string test-forms)) - (write-file test-file)) - (with-temp-buffer - (let ((retval - (call-process (concat invocation-directory invocation-name) - nil (list t nil) nil - "-Q" "--batch" - "-l" test-file))) - (unless (= 0 retval) - (ert-fail (buffer-string))))) - (setq success t)) - (if success (delete-file test-file) - (message "Test failed: keeping %s for inspection" test-file))))) - -(define-sly-ert-test readme-recipe () - "Test the README.md's autoload recipe." - (sly-test-recipe-test-for - :preflight `((add-to-list 'load-path ,sly-path) - (setq inferior-lisp-program ,inferior-lisp-program) - (require 'sly-autoloads)))) - -(define-sly-ert-test traditional-recipe () - "Test the README.md's traditional recipe." - (sly-test-recipe-test-for - :preflight `((add-to-list 'load-path ,sly-path) - (setq inferior-lisp-program ,inferior-lisp-program) - (require 'sly) - (sly-setup '(sly-fancy))))) - -(define-sly-ert-test slynk-loader-fallback () - "Test `sly-init-using-slynk-loader'" - ;; TODO: another useful test would be to test - ;; `sly-init-using-asdf's fallback to slynk-loader.lisp." - (sly-test-recipe-test-for - :preflight `((add-to-list 'load-path ,sly-path) - (setq inferior-lisp-program ,inferior-lisp-program) - (require 'sly-autoloads) - (setq sly-contribs '(sly-fancy)) - (setq sly-init-function 'sly-init-using-slynk-loader) - (sly-setup '(sly-fancy))) - :landing `((unless (sly-eval '(cl:and (cl:find-package :slynk-loader) t)) - (die "Expected SLY to be loaded with slynk-loader.lisp")) - ,@sly-test-check-repl-forms))) - - -;;; xref recompilation -;;; -(defun sly-test--eval-now (string) - (cl-second (sly-eval `(slynk:eval-and-grab-output ,string)))) - -(def-sly-test (sly-recompile-all-xrefs (:fails-for "cmucl")) () - "Test recompilation of all references within an xref buffer." - '(()) - (let* ((cell (cons nil nil)) - (hook (sly-curry (lambda (cell &rest _) (setcar cell t)) cell)) - (filename (make-temp-file "sly-recompile-all-xrefs" nil ".lisp")) - (xref-buffer)) - (add-hook 'sly-compilation-finished-hook hook) - (unwind-protect - (with-temp-file filename - (set-visited-file-name filename) - (sly-test--eval-now "(defparameter slynk::*.var.* nil)") - (insert "(in-package :slynk) - (defun .fn1. ()) - (defun .fn2. () (.fn1.) #.*.var.*) - (defun .fn3. () (.fn1.) #.*.var.*)") - (save-buffer) - (sly-compile-and-load-file) - (sly-wait-condition "Compilation finished" - (lambda () (car cell)) - 0.5) - (sly-test--eval-now "(setq *.var.* t)") - (setcar cell nil) - (sly-xref :calls ".fn1." - (lambda (&rest args) - (setq xref-buffer (apply #'sly-xref--show-results args)) - (setcar cell t))) - (sly-wait-condition "Xrefs computed and displayed" - (lambda () (car cell)) - 0.5) - (setcar cell nil) - (should (cl-equalp (list (sly-test--eval-now "(.fn2.)") - (sly-test--eval-now "(.fn3.)")) - '("nil" "nil"))) - ;; Recompile now - ;; - (with-current-buffer xref-buffer - (sly-recompile-all-xrefs) - (sly-wait-condition "Compilation finished" - (lambda () (car cell)) - 0.5)) - (should (cl-equalp (list (sly-test--eval-now "(.fn2.)") - (sly-test--eval-now "(.fn3.)")) - '("T" "T")))) - (remove-hook 'sly-compilation-finished-hook hook) - (when xref-buffer - (kill-buffer xref-buffer))))) - - -;;; window management after M-. -;;; -(cl-defmacro sly-test--with-find-definition-window-checker (fn - (window-splits - total-windows - starting-buffer-sym - starting-window-sym) - &rest body) - (declare (indent 2)) - (let ((temp-frame-sym (cl-gensym "temp-frame-"))) - `(progn - (sly-check-top-level) - (let ((,temp-frame-sym nil)) - (unwind-protect - (progn - (setq ,temp-frame-sym (if noninteractive - (selected-frame) - (make-frame))) - ;; too large a frame will exhibit slightly different - ;; window-popping behaviour - (set-frame-width ,temp-frame-sym 100) - (set-frame-height ,temp-frame-sym 40) - (with-selected-frame ,temp-frame-sym - (with-temp-buffer - (delete-other-windows) - (switch-to-buffer (current-buffer)) - (let ((,starting-window-sym (selected-window)) - (,starting-buffer-sym (current-buffer))) - (dotimes (_i ,window-splits) - (split-window)) - (funcall ,fn "cl:print-object") - (should (= ,total-windows (length (window-list ,temp-frame-sym)))) - (with-current-buffer - (window-buffer (selected-window)) - (should (eq major-mode 'sly-xref-mode)) - (forward-line 1) - (sly-xref-goto)) - ,@body)))) - (unless noninteractive - (delete-frame ,temp-frame-sym t))))))) - -(def-sly-test find-definition-same-window (window-splits total-windows) - "Test `sly-edit-definition' windows" - '((0 2) - (1 2) - (2 3)) - (sly-test--with-find-definition-window-checker - 'sly-edit-definition - (window-splits - total-windows - temp-buffer - original-window) - (with-current-buffer - (window-buffer (selected-window)) - (should-not (eq temp-buffer (current-buffer))) - (should (eq (selected-window) original-window))) - (should (= (if (zerop window-splits) - 1 - total-windows) - (length (window-list (selected-frame))))))) - -(def-sly-test find-definition-other-window (window-splits total-windows) - "Test `sly-edit-definition-other-window' windows" - '((0 2) - (1 2) - (2 3)) - (sly-test--with-find-definition-window-checker - 'sly-edit-definition-other-window - (window-splits - total-windows - temp-buffer - original-window) - (with-current-buffer - (window-buffer (selected-window)) - (should (window-live-p original-window)) - (should (eq temp-buffer (window-buffer original-window))) - (should-not (eq (selected-window) original-window))) - (should (= total-windows - (length (window-list (selected-frame))))))) - - - -(provide 'sly-tests) diff --git a/elpa/sly-20211121.1002/sly-autoloads.el b/elpa/sly-20211121.1002/sly-autoloads.el @@ -1,127 +0,0 @@ -;;; sly-autoloads.el --- automatically extracted autoloads -;; -;;; Code: - -(add-to-list 'load-path (directory-file-name - (or (file-name-directory #$) (car load-path)))) - - -;;;### (autoloads nil "sly" "sly.el" (0 0 0 0)) -;;; Generated autoloads from sly.el - -(define-obsolete-variable-alias 'sly-setup-contribs 'sly-contribs "2.3.2") - -(defvar sly-contribs '(sly-fancy) "\ -A list of contrib packages to load with SLY.") - -(autoload 'sly-setup "sly" "\ -Have SLY load and use extension modules CONTRIBS. -CONTRIBS defaults to `sly-contribs' and is a list (LIB1 LIB2...) -symbols of `provide'd and `require'd Elisp libraries. - -If CONTRIBS is nil, `sly-contribs' is *not* affected, otherwise -it is set to CONTRIBS. - -However, after `require'ing LIB1, LIB2 ..., this command invokes -additional initialization steps associated with each element -LIB1, LIB2, which can theoretically be reverted by -`sly-disable-contrib.' - -Notably, one of the extra initialization steps is affecting the -value of `sly-required-modules' (which see) thus affecting the -libraries loaded in the Slynk servers. - -If SLY is currently connected to a Slynk and a contrib in -CONTRIBS has never been loaded, that Slynk is told to load the -associated Slynk extension module. - -To ensure that a particular contrib is loaded, use -`sly-enable-contrib' instead. - -\(fn &optional CONTRIBS)" t nil) - -(autoload 'sly-mode "sly" "\ -Minor mode for horizontal SLY functionality. - -If called interactively, enable Sly mode if ARG is positive, and -disable it if ARG is zero or negative. If called from Lisp, also -enable the mode if ARG is omitted or nil, and toggle it if ARG is -`toggle'; disable the mode otherwise. - -\(fn &optional ARG)" t nil) - -(autoload 'sly-editing-mode "sly" "\ -Minor mode for editing `lisp-mode' buffers. - -If called interactively, enable Sly-Editing mode if ARG is -positive, and disable it if ARG is zero or negative. If called -from Lisp, also enable the mode if ARG is omitted or nil, and -toggle it if ARG is `toggle'; disable the mode otherwise. - -\(fn &optional ARG)" t nil) - -(autoload 'sly "sly" "\ -Start a Lisp implementation and connect to it. - - COMMAND designates a the Lisp implementation to start as an -\"inferior\" process to the Emacs process. It is either a -pathname string pathname to a lisp executable, a list (EXECUTABLE -ARGS...), or a symbol indexing -`sly-lisp-implementations'. CODING-SYSTEM is a symbol overriding -`sly-net-coding-system'. - -Interactively, both COMMAND and CODING-SYSTEM are nil and the -prefix argument controls the precise behaviour: - -- With no prefix arg, try to automatically find a Lisp. First - consult `sly-command-switch-to-existing-lisp' and analyse open - connections to maybe switch to one of those. If a new lisp is - to be created, first lookup `sly-lisp-implementations', using - `sly-default-lisp' as a default strategy. Then try - `inferior-lisp-program' if it looks like it points to a valid - lisp. Failing that, guess the location of a lisp - implementation. - -- With a positive prefix arg (one C-u), prompt for a command - string that starts a Lisp implementation. - -- With a negative prefix arg (M-- M-x sly, for example) prompt - for a symbol indexing one of the entries in - `sly-lisp-implementations' - -\(fn &optional COMMAND CODING-SYSTEM INTERACTIVE)" t nil) - -(autoload 'sly-connect "sly" "\ -Connect to a running Slynk server. Return the connection. -With prefix arg, asks if all connections should be closed -before. - -\(fn HOST PORT &optional CODING-SYSTEM INTERACTIVE-P)" t nil) - -(autoload 'sly-hyperspec-lookup "sly" "\ -A wrapper for `hyperspec-lookup' - -\(fn SYMBOL-NAME)" t nil) - -(autoload 'sly-info "sly" "\ -Read SLY manual - -\(fn FILE &optional NODE)" t nil) - -(add-hook 'lisp-mode-hook 'sly-editing-mode) - -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "sly" '("define-sly-" "inferior-lisp-program" "make-sly-" "sly-"))) - -;;;*** - -;;;### (autoloads nil nil ("sly-pkg.el") (0 0 0 0)) - -;;;*** - -;; Local Variables: -;; version-control: never -;; no-byte-compile: t -;; no-update-autoloads: t -;; coding: utf-8 -;; End: -;;; sly-autoloads.el ends here diff --git a/elpa/sly-20211121.1002/sly-pkg.el b/elpa/sly-20211121.1002/sly-pkg.el @@ -1,8 +0,0 @@ -(define-package "sly" "20211121.1002" "Sylvester the Cat's Common Lisp IDE" - '((emacs "24.3")) - :commit "0470c0281498b9de072fcbf3718fc66720eeb3d0" :keywords - '("languages" "lisp" "sly") - :url "https://github.com/joaotavora/sly") -;; Local Variables: -;; no-byte-compile: t -;; End: diff --git a/elpa/sly-20211121.1002/sly.el b/elpa/sly-20211121.1002/sly.el @@ -1,7484 +0,0 @@ -;;; sly.el --- Sylvester the Cat's Common Lisp IDE -*- lexical-binding: t; -*- - -;; Version: 1.0.43 -;; URL: https://github.com/joaotavora/sly -;; Package-Requires: ((emacs "24.3")) -;; Keywords: languages, lisp, sly - -;; Copyright (C) 2003 Eric Marsden, Luke Gorrie, Helmut Eller -;; Copyright (C) 2004,2005,2006 Luke Gorrie, Helmut Eller -;; Copyright (C) 2007,2008,2009 Helmut Eller, Tobias C. Rittweiler -;; Copyright (C) 2014 João Távora -;; For a detailed list of contributors, see the manual. - -;; This program is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see <http://www.gnu.org/licenses/>. - -;;; Commentary: -;; -;; _____ __ __ __ -;; / ___/ / / \ \/ / |\ _,,,---,,_ -;; \__ \ / / \ / /,`.-'`' -. ;-;;,_ -;; ___/ / / /___ / / |,4- ) )-,_..;\ ( `'-' -;; /____/ /_____/ /_/ '---''(_/--' `-'\_) -;; -;; -;; SLY is Sylvester the Cat's Common Lisp IDE. -;; -;; SLY is a direct fork of SLIME, and contains the following -;; improvements over it: -;; -;; * A full-featured REPL based on Emacs's `comint.el`; -;; * Live code annotations via a new `sly-stickers` contrib; -;; * Consistent button interface. Every Lisp object can be copied to the REPL; -;; * flex-style completion out-of-the-box, using Emacs's completion API. -;; Company, Helm, and others supported natively, no plugin required; -;; * Cleanly ASDF-loaded by default, including contribs, enabled out-of-the-box; -;; * Multiple inspectors and multiple REPLs; -;; * An interactive trace dialog with interactive objects. Copies function calls -;; to the REPL; -;; * "Presentations" replaced by interactive backreferences which -;; highlight the object and remain stable throughout the REPL session; -;; -;; SLY is a fork of SLIME. We track its bugfixes, particularly to the -;; implementation backends. All SLIME's familar features (debugger, -;; inspector, xref, etc...) are still available, with improved overall -;; UX. -;; -;; See the NEWS.md file (should be sitting alongside this file) for -;; more information - -;;; Code: - -(require 'cl-lib) - -(eval-and-compile - (if (version< emacs-version "24.3") - (error "Sly requires at least Emacs 24.3"))) - -(eval-and-compile - (or (require 'hyperspec nil t) - (require 'hyperspec "lib/hyperspec"))) -(require 'thingatpt) -(require 'comint) -(require 'pp) -(require 'easymenu) -(require 'arc-mode) -(require 'etags) -(require 'apropos) -(require 'bytecomp) ;; for `byte-compile-current-file' and -;; `sly-byte-compile-hotspots'. - -(require 'sly-common "lib/sly-common") -(require 'sly-messages "lib/sly-messages") -(require 'sly-buttons "lib/sly-buttons") -(require 'sly-completion "lib/sly-completion") - -(require 'gv) ; for gv--defsetter - -(eval-when-compile - (require 'compile) - (require 'gud)) - -(defvar sly-path nil - "Directory containing the SLY package. -This is used to load the supporting Common Lisp library, Slynk. -The default value is automatically computed from the location of the -Emacs Lisp package.") - -;; Determine `sly-path' at load time, regardless of filename (.el or -;; .elc) being loaded. -;; -(setq sly-path - (if load-file-name - (file-name-directory load-file-name) - (error "[sly] fatal: impossible to determine sly-path"))) - -(defun sly-slynk-path () - "Path where the bundled Slynk server is located." - (expand-file-name "slynk/" sly-path)) - -;;;###autoload -(define-obsolete-variable-alias 'sly-setup-contribs - 'sly-contribs "2.3.2") -;;;###autoload -(defvar sly-contribs '(sly-fancy) - "A list of contrib packages to load with SLY.") - -;;;###autoload -(defun sly-setup (&optional contribs) - "Have SLY load and use extension modules CONTRIBS. -CONTRIBS defaults to `sly-contribs' and is a list (LIB1 LIB2...) -symbols of `provide'd and `require'd Elisp libraries. - -If CONTRIBS is nil, `sly-contribs' is *not* affected, otherwise -it is set to CONTRIBS. - -However, after `require'ing LIB1, LIB2 ..., this command invokes -additional initialization steps associated with each element -LIB1, LIB2, which can theoretically be reverted by -`sly-disable-contrib.' - -Notably, one of the extra initialization steps is affecting the -value of `sly-required-modules' (which see) thus affecting the -libraries loaded in the Slynk servers. - -If SLY is currently connected to a Slynk and a contrib in -CONTRIBS has never been loaded, that Slynk is told to load the -associated Slynk extension module. - -To ensure that a particular contrib is loaded, use -`sly-enable-contrib' instead." - ;; FIXME: The contract should be like some hypothetical - ;; `sly-refresh-contribs' - ;; - (interactive) - (when contribs - (setq sly-contribs contribs)) - (sly--setup-contribs)) - -(defvaralias 'sly-required-modules 'sly-contrib--required-slynk-modules) - -(defvar sly-contrib--required-slynk-modules '() - "Alist of (MODULE . (WHERE CONTRIB)) for slynk-provided features. - -MODULE is a symbol naming a specific Slynk feature, WHERE is -the full pathname to the directory where the file(s) -providing the feature are found and CONTRIB is a symbol as found -in `sly-contribs.'") - -(cl-defmacro sly--contrib-safe (contrib &body body) - "Run BODY catching and resignalling any errors for CONTRIB" - (declare (indent 1)) - `(condition-case-unless-debug e - (progn - ,@body) - (error (sly-error "There's an error in %s: %s" - ,contrib - e)))) - -(defun sly--setup-contribs () - "Load and initialize contribs." - ;; active != enabled - ;; ^ ^ - ;; | | - ;; v v - ;; forgotten != disabled - (add-to-list 'load-path (expand-file-name "contrib" sly-path)) - (mapc (lambda (c) - (sly--contrib-safe c (require c))) - sly-contribs) - (let* ((all-active-contribs - ;; these are the contribs the user chose to activate - ;; - (mapcar #'sly-contrib--find-contrib - (cl-reduce #'append (mapcar #'sly-contrib--all-dependencies - sly-contribs)))) - (defined-but-forgotten-contribs - ;; "forgotten contribs" are the ones the chose not to - ;; activate but whose definitions we have seen - ;; - (cl-remove-if #'(lambda (contrib) - (memq contrib all-active-contribs)) - (sly-contrib--all-contribs)))) - ;; Disable any forgotten contribs that are enabled right now. - ;; - (cl-loop for to-disable in defined-but-forgotten-contribs - when (sly--contrib-safe to-disable - (sly-contrib--enabled-p to-disable)) - do (funcall (sly-contrib--disable to-disable))) - ;; Enable any active contrib that is *not* enabled right now. - ;; - (cl-loop for to-enable in all-active-contribs - unless (sly--contrib-safe to-enable - (sly-contrib--enabled-p to-enable)) - do (funcall (sly-contrib--enable to-enable))) - ;; Some contribs add stuff to `sly-mode-hook' or - ;; `sly-editing-hook', so make sure we re-run those hooks now. - (when all-active-contribs - (defvar sly-editing-mode) ;FIXME: Forward reference! - (cl-loop for buffer in (buffer-list) - do (with-current-buffer buffer - (when sly-editing-mode (sly-editing-mode 1))))))) - -(eval-and-compile - (defun sly-version (&optional interactive file) - "Read SLY's version of its own sly.el file. -If FILE is passed use that instead to discover the version." - (interactive "p") - (let ((version - (with-temp-buffer - (insert-file-contents - (or file - (expand-file-name "sly.el" sly-path)) - nil 0 200) - (and (search-forward-regexp - ";;[[:space:]]*Version:[[:space:]]*\\(.*\\)$" nil t) - (match-string 1))))) - (if interactive - (sly-message "SLY %s" version) - version)))) - -(defvar sly-protocol-version nil) - -(setq sly-protocol-version - ;; Compile the version string into the generated .elc file, but - ;; don't actualy affect `sly-protocol-version' until load-time. - ;; - (eval-when-compile (sly-version nil (or load-file-name - byte-compile-current-file)))) - - -;;;; Customize groups -;; -;;;;; sly - -(defgroup sly nil - "Interaction with the Superior Lisp Environment." - :prefix "sly-" - :group 'applications) - -;;;;; sly-ui - -(defgroup sly-ui nil - "Interaction with the Superior Lisp Environment." - :prefix "sly-" - :group 'sly) - -(defcustom sly-truncate-lines t - "Set `truncate-lines' in popup buffers. -This applies to buffers that present lines as rows of data, such as -debugger backtraces and apropos listings." - :type 'boolean - :group 'sly-ui) - -(defcustom sly-kill-without-query-p nil - "If non-nil, kill SLY processes without query when quitting Emacs. -This applies to the *inferior-lisp* buffer and the network connections." - :type 'boolean - :group 'sly-ui) - -;;;;; sly-lisp - -(defgroup sly-lisp nil - "Lisp server configuration." - :prefix "sly-" - :group 'sly) - -(defcustom sly-ignore-protocol-mismatches nil - "If non-nil, ignore protocol mismatches between SLY and Slynk. -Programatically, this variable can be let-bound around calls to -`sly' or `sly-connect'." - :type 'boolean - :group 'sly) - -(defcustom sly-init-function 'sly-init-using-asdf - "Function bootstrapping slynk on the remote. - -Value is a function of two arguments: SLYNK-PORTFILE and an -ingored argument for backward compatibility. Function should -return a string issuing very first commands issued by Sly to -the remote-connection process. Some time after this there should -be a port number ready in SLYNK-PORTFILE." - :type '(choice (const :tag "Use ASDF" - sly-init-using-asdf) - (const :tag "Use legacy slynk-loader.lisp" - sly-init-using-slynk-loader)) - :group 'sly-lisp) - -(define-obsolete-variable-alias 'sly-backend - 'sly-slynk-loader-backend "3.0") - -(defcustom sly-slynk-loader-backend "slynk-loader.lisp" - "The name of the slynk-loader that loads the Slynk server. -Only applicable if `sly-init-function' is set to -`sly-init-using-slynk-loader'. This name is interpreted -relative to the directory containing sly.el, but could also be -set to an absolute filename." - :type 'string - :group 'sly-lisp) - -(defcustom sly-connected-hook nil - "List of functions to call when SLY connects to Lisp." - :type 'hook - :group 'sly-lisp) - -(defcustom sly-enable-evaluate-in-emacs nil - "*If non-nil, the inferior Lisp can evaluate arbitrary forms in Emacs. -The default is nil, as this feature can be a security risk." - :type '(boolean) - :group 'sly-lisp) - -(defcustom sly-lisp-host "localhost" - "The default hostname (or IP address) to connect to." - :type 'string - :group 'sly-lisp) - -(defcustom sly-port 4005 - "Port to use as the default for `sly-connect'." - :type 'integer - :group 'sly-lisp) - -(defvar sly-connect-host-history (list sly-lisp-host)) -(defvar sly-connect-port-history (list (prin1-to-string sly-port))) - -(defvar sly-net-valid-coding-systems - '((iso-latin-1-unix nil "iso-latin-1-unix") - (iso-8859-1-unix nil "iso-latin-1-unix") - (binary nil "iso-latin-1-unix") - (utf-8-unix t "utf-8-unix") - (emacs-mule-unix t "emacs-mule-unix") - (euc-jp-unix t "euc-jp-unix")) - "A list of valid coding systems. -Each element is of the form: (NAME MULTIBYTEP CL-NAME)") - -(defun sly-find-coding-system (name) - "Return the coding system for the symbol NAME. -The result is either an element in `sly-net-valid-coding-systems' -of nil." - (let ((probe (assq name sly-net-valid-coding-systems))) - (when (and probe (if (fboundp 'check-coding-system) - (ignore-errors (check-coding-system (car probe))) - (eq (car probe) 'binary))) - probe))) - -(defcustom sly-net-coding-system - (car (cl-find-if 'sly-find-coding-system - sly-net-valid-coding-systems :key 'car)) - "Coding system used for network connections. -See also `sly-net-valid-coding-systems'." - :type (cons 'choice - (mapcar (lambda (x) - (list 'const (car x))) - sly-net-valid-coding-systems)) - :group 'sly-lisp) - -;;;;; sly-mode - -(defgroup sly-mode nil - "Settings for sly-mode Lisp source buffers." - :prefix "sly-" - :group 'sly) - -;;;;; sly-mode-faces - -(defgroup sly-mode-faces nil - "Faces in sly-mode source code buffers." - :prefix "sly-" - :group 'sly-mode) - -(defface sly-error-face - `((((class color) (background light)) - (:underline "tomato")) - (((class color) (background dark)) - (:underline "tomato")) - (t (:underline t))) - "Face for errors from the compiler." - :group 'sly-mode-faces) - -(defface sly-warning-face - `((((class color) (background light)) - (:underline "orange")) - (((class color) (background dark)) - (:underline "coral")) - (t (:underline t))) - "Face for warnings from the compiler." - :group 'sly-mode-faces) - -(defface sly-style-warning-face - `((((class color) (background light)) - (:underline "olive drab")) - (((class color) (background dark)) - (:underline "khaki")) - (t (:underline t))) - "Face for style-warnings from the compiler." - :group 'sly-mode-faces) - -(defface sly-note-face - `((((class color) (background light)) - (:underline "brown3")) - (((class color) (background dark)) - (:underline "light goldenrod")) - (t (:underline t))) - "Face for notes from the compiler." - :group 'sly-mode-faces) - -;;;;; sly-db - -(defgroup sly-debugger nil - "Backtrace options and fontification." - :prefix "sly-db-" - :group 'sly) - -(defmacro define-sly-db-faces (&rest faces) - "Define the set of SLY-DB faces. -Each face specifiation is (NAME DESCRIPTION &optional PROPERTIES). -NAME is a symbol; the face will be called sly-db-NAME-face. -DESCRIPTION is a one-liner for the customization buffer. -PROPERTIES specifies any default face properties." - `(progn ,@(cl-loop for face in faces - collect `(define-sly-db-face ,@face)))) - -(defmacro define-sly-db-face (name description &optional default) - (let ((facename (intern (format "sly-db-%s-face" (symbol-name name))))) - `(defface ,facename - (list (list t ,default)) - ,(format "Face for %s." description) - :group 'sly-debugger))) - -(define-sly-db-faces - (topline "the top line describing the error") - (condition "the condition class" '(:inherit error)) - (section "the labels of major sections in the debugger buffer" - '(:inherit header-line)) - (frame-label "backtrace frame numbers" - '(:inherit shadow)) - (restart "restart descriptions") - (restart-number "restart numbers (correspond to keystrokes to invoke)" - '(:inherit shadow)) - (frame-line "function names and arguments in the backtrace") - (restartable-frame-line - "frames which are surely restartable" - '(:inherit font-lock-constant-face)) - (non-restartable-frame-line - "frames which are surely not restartable") - (local-name "local variable names") - (catch-tag "catch tags")) - - -;;;;; Key bindings -(defvar sly-doc-map - (let ((map (make-sparse-keymap))) - (define-key map (kbd "C-a") 'sly-apropos) - (define-key map (kbd "C-z") 'sly-apropos-all) - (define-key map (kbd "C-p") 'sly-apropos-package) - (define-key map (kbd "C-d") 'sly-describe-symbol) - (define-key map (kbd "C-f") 'sly-describe-function) - (define-key map (kbd "C-h") 'sly-documentation-lookup) - (define-key map (kbd "~") 'common-lisp-hyperspec-format) - (define-key map (kbd "C-g") 'common-lisp-hyperspec-glossary-term) - (define-key map (kbd "#") 'common-lisp-hyperspec-lookup-reader-macro) - map)) - -(defvar sly-who-map - (let ((map (make-sparse-keymap))) - (define-key map (kbd "C-c") 'sly-who-calls) - (define-key map (kbd "C-w") 'sly-calls-who) - (define-key map (kbd "C-r") 'sly-who-references) - (define-key map (kbd "C-b") 'sly-who-binds) - (define-key map (kbd "C-s") 'sly-who-sets) - (define-key map (kbd "C-m") 'sly-who-macroexpands) - (define-key map (kbd "C-a") 'sly-who-specializes) - map)) - -(defvar sly-selector-map (let ((map (make-sparse-keymap))) - (define-key map "c" 'sly-list-connections) - (define-key map "t" 'sly-list-threads) - (define-key map "d" 'sly-db-pop-to-debugger-maybe) - (define-key map "e" 'sly-pop-to-events-buffer) - (define-key map "i" 'sly-inferior-lisp-buffer) - (define-key map "l" 'sly-switch-to-most-recent) - map) - "A keymap for frequently used SLY shortcuts. -Access to this keymap can be installed in in -`sly-mode-map', using something like - - (global-set-key (kbd \"C-z\") sly-selector-map) - -This will bind C-z to this prefix map, one keystroke away from -the available shortcuts: - -\\{sly-selector-map} -As usual, users or extensions can plug in -any command into it using - - (define-key sly-selector-map (kbd \"k\") 'sly-command) - -Where \"k\" is the key to bind and \"sly-command\" is any -interactive command.\".") - -(defvar sly-prefix-map - (let ((map (make-sparse-keymap))) - (define-key map (kbd "C-r") 'sly-eval-region) - (define-key map (kbd ":") 'sly-interactive-eval) - (define-key map (kbd "C-e") 'sly-interactive-eval) - (define-key map (kbd "E") 'sly-edit-value) - (define-key map (kbd "C-l") 'sly-load-file) - (define-key map (kbd "C-b") 'sly-interrupt) - (define-key map (kbd "M-d") 'sly-disassemble-symbol) - (define-key map (kbd "C-t") 'sly-toggle-trace-fdefinition) - (define-key map (kbd "I") 'sly-inspect) - (define-key map (kbd "C-x t") 'sly-list-threads) - (define-key map (kbd "C-x n") 'sly-next-connection) - (define-key map (kbd "C-x c") 'sly-list-connections) - (define-key map (kbd "C-x p") 'sly-prev-connection) - (define-key map (kbd "<") 'sly-list-callers) - (define-key map (kbd ">") 'sly-list-callees) - ;; Include DOC keys... - (define-key map (kbd "C-d") sly-doc-map) - ;; Include XREF WHO-FOO keys... - (define-key map (kbd "C-w") sly-who-map) - ;; `sly-selector-map' used to be bound to "C-c C-s" by default, - ;; but sly-stickers has a better binding for that. - ;; - ;; (define-key map (kbd "C-s") sly-selector-map) - map)) - -(defvar sly-mode-map - (let ((map (make-sparse-keymap))) - ;; These used to be a `sly-parent-map' - (define-key map (kbd "M-.") 'sly-edit-definition) - (define-key map (kbd "M-,") 'sly-pop-find-definition-stack) - (define-key map (kbd "M-_") 'sly-edit-uses) ; for German layout - (define-key map (kbd "M-?") 'sly-edit-uses) ; for USian layout - (define-key map (kbd "C-x 4 .") 'sly-edit-definition-other-window) - (define-key map (kbd "C-x 5 .") 'sly-edit-definition-other-frame) - (define-key map (kbd "C-x C-e") 'sly-eval-last-expression) - (define-key map (kbd "C-M-x") 'sly-eval-defun) - ;; Include PREFIX keys... - (define-key map (kbd "C-c") sly-prefix-map) - ;; Completion - (define-key map (kbd "C-c TAB") 'completion-at-point) - ;; Evaluating - (define-key map (kbd "C-c C-p") 'sly-pprint-eval-last-expression) - ;; Macroexpand - (define-key map (kbd "C-c C-m") 'sly-expand-1) - (define-key map (kbd "C-c M-m") 'sly-macroexpand-all) - ;; Misc - (define-key map (kbd "C-c C-u") 'sly-undefine-function) - map)) - -(defvar sly-editing-mode-map - (let ((map (make-sparse-keymap))) - (define-key map (kbd "M-p") 'sly-previous-note) - (define-key map (kbd "M-n") 'sly-next-note) - (define-key map (kbd "C-c M-c") 'sly-remove-notes) - (define-key map (kbd "C-c C-k") 'sly-compile-and-load-file) - (define-key map (kbd "C-c M-k") 'sly-compile-file) - (define-key map (kbd "C-c C-c") 'sly-compile-defun) - map)) - -(defvar sly-popup-buffer-mode-map - (let ((map (make-sparse-keymap))) - (define-key map (kbd "q") 'quit-window) - map)) - - -;;;; Minor modes - -;;;;; sly-mode -(defvar sly-buffer-connection) -(defvar sly-dispatching-connection) -(defvar sly-current-thread) - -;; exceptional forward decl -(defvar company-tooltip-align-annotations) - -;;;###autoload -(define-minor-mode sly-mode - "Minor mode for horizontal SLY functionality." - nil nil nil - ;; Company-mode should have this by default - ;; See gh#166 - (set (make-local-variable 'company-tooltip-align-annotations) t)) - -(defun sly--lisp-indent-function (&rest args) - (let ((fn (if (fboundp 'sly-common-lisp-indent-function) - #'sly-common-lisp-indent-function - #'lisp-indent-function))) - (apply fn args))) - -;;;###autoload -(define-minor-mode sly-editing-mode - "Minor mode for editing `lisp-mode' buffers." - nil nil nil - (sly-mode 1) - (setq-local lisp-indent-function #'sly--lisp-indent-function)) - -(define-minor-mode sly-popup-buffer-mode - "Minor mode for all read-only SLY buffers" - nil nil nil - (sly-mode 1) - (sly-interactive-buttons-mode 1) - (setq buffer-read-only t)) - - -;;;;;; Mode-Line -(defface sly-mode-line - '((t (:inherit font-lock-constant-face - :weight bold))) - "Face for package-name in SLY's mode line." - :group 'sly) - -(defvar sly--mode-line-format `(:eval (sly--mode-line-format))) - -(put 'sly--mode-line-format 'risky-local-variable t) - -(defvar sly-menu) ;; forward referenced - -(defvar sly-extra-mode-line-constructs nil - "A list of mode-line constructs to add to SLY's mode-line. -Each construct is separated by a \"/\" and may be a regular -mode-line construct or a symbol naming a function of no arguments -that returns one such construct.") - -(defun sly--mode-line-format () - (let* ((conn (sly-current-connection)) - (conn (and (process-live-p conn) conn)) - (name (or (and conn - (sly-connection-name conn)) - "*")) - (pkg (sly-current-package)) - (format-number (lambda (n) (cond ((and n (not (zerop n))) - (format "%d" n)) - (n "-") - (t "*")))) - (package-name (and pkg - (sly--pretty-package-name pkg))) - (pending (and conn - (length (sly-rex-continuations conn)))) - (sly-dbs (and conn (length (sly-db-buffers conn))))) - `((:propertize "sly" - face sly-mode-line - keymap ,(let ((map (make-sparse-keymap))) - (define-key map [mode-line down-mouse-1] - sly-menu) - map) - mouse-face mode-line-highlight - help-echo "mouse-1: pop-up SLY menu" - ) - " " - (:propertize ,name - face sly-mode-line - keymap ,(let ((map (make-sparse-keymap))) - (define-key map [mode-line mouse-1] 'sly-prev-connection) - (define-key map [mode-line mouse-2] 'sly-list-connections) - (define-key map [mode-line mouse-3] 'sly-next-connection) - map) - mouse-face mode-line-highlight - help-echo ,(concat "mouse-1: previous connection\n" - "mouse-2: list connections\n" - "mouse-3: next connection")) - "/" - ,(or package-name "*") - "/" - (:propertize ,(funcall format-number pending) - help-echo ,(if conn (format "%s pending events outgoing\n%s" - pending - (concat "mouse-1: go to *sly-events* buffer" - "mouse-3: forget pending continuations")) - "No current connection") - mouse-face mode-line-highlight - face ,(cond ((and pending (cl-plusp pending)) - 'warning) - (t - 'sly-mode-line)) - keymap ,(let ((map (make-sparse-keymap))) - (define-key map [mode-line mouse-1] 'sly-pop-to-events-buffer) - (define-key map [mode-line mouse-3] 'sly-forget-pending-events) - map)) - "/" - (:propertize ,(funcall format-number sly-dbs) - help-echo ,(if conn (format "%s SLY-DB buffers waiting\n%s" - pending - "mouse-1: go to first one") - "No current connection") - mouse-face mode-line-highlight - face ,(cond ((and sly-dbs (cl-plusp sly-dbs)) - 'warning) - (t - 'sly-mode-line)) - keymap ,(let ((map (make-sparse-keymap))) - (define-key map [mode-line mouse-1] 'sly-db-pop-to-debugger) - map)) - ,@(cl-loop for construct in sly-extra-mode-line-constructs - collect "/" - collect (if (and (symbolp construct) - (fboundp construct)) - (condition-case _oops - (funcall construct) - (error "*sly-invalid*")) - construct))))) - -(defun sly--refresh-mode-line () - (force-mode-line-update t)) - -(defun sly--pretty-package-name (name) - "Return a pretty version of a package name NAME." - (cond ((string-match "^#?:\\(.*\\)$" name) - (match-string 1 name)) - ((string-match "^\"\\(.*\\)\"$" name) - (match-string 1 name)) - (t name))) - -(add-to-list 'mode-line-misc-info - `(sly-mode (" [" sly--mode-line-format "] "))) - - -;;;; Framework'ey bits -;;; -;;; This section contains some standard SLY idioms: basic macros, -;;; ways of showing messages to the user, etc. All the code in this -;;; file should use these functions when applicable. -;;; -;;;;; Syntactic sugar - -(cl-defmacro sly--when-let ((var value) &rest body) - "Evaluate VALUE, if the result is non-nil bind it to VAR and eval BODY. - -\(fn (VAR VALUE) &rest BODY)" - (declare (indent 1)) - `(let ((,var ,value)) - (when ,var ,@body))) - -(cl-defmacro sly--when-let* (bindings &rest body) - "Same as `sly--when-let', but for multiple BINDINGS" - (declare (indent 1)) - (if bindings - `(sly--when-let ,(car bindings) - (sly--when-let* ,(cdr bindings) ,@body)) - `(progn ,@body))) - -(defmacro sly-dcase (value &rest patterns) - (declare (indent 1) - (debug (sexp &rest (sexp &rest form)))) - "Dispatch VALUE to one of PATTERNS. -A cross between `case' and `destructuring-bind'. -The pattern syntax is: - ((HEAD . ARGS) . BODY) -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 (cl-gensym "op-")) - (operands (cl-gensym "rand-")) - (tmp (cl-gensym "tmp-"))) - `(let* ((,tmp ,value) - (,operator (car ,tmp)) - (,operands (cdr ,tmp))) - (cl-case ,operator - ,@(mapcar (lambda (clause) - (if (eq (car clause) t) - `(t ,@(cdr clause)) - (cl-destructuring-bind ((op &rest rands) &rest body) - clause - `(,op (cl-destructuring-bind ,rands ,operands - . ,(or body - '((ignore)) ; suppress some warnings - )))))) - patterns) - ,@(if (eq (caar (last patterns)) t) - '() - `((t (sly-error "Elisp sly-dcase failed: %S" ,tmp)))))))) - -;;;;; Very-commonly-used functions - -;; Interface -(cl-defun sly-buffer-name (type &key connection hidden suffix) - (cl-assert (keywordp type)) - (mapconcat #'identity - `(,@(if hidden `(" ")) - "*sly-" - ,(downcase (substring (symbol-name type) 1)) - ,@(if connection - `(" for " - ,(sly-connection-name - (if (eq connection t) - (sly-current-connection) - connection)))) - ,@(if suffix - `(" (" - ,suffix - ")")) - "*") - "")) - -(defun sly-recenter (target &optional move-point) - "Make the region between point and TARGET visible. -Minimize window motion if possible. If MOVE-POINT allow point to -move to make TARGET visible." - (unless (pos-visible-in-window-p target) - (redisplay) - (let ((screen-line (- (line-number-at-pos) - (line-number-at-pos (window-start)))) - (window-end (line-number-at-pos (window-end))) - (window-start (line-number-at-pos (window-start))) - (target-line (line-number-at-pos target)) - recenter-arg) - (cond ((> (point) target) - (setq recenter-arg (+ screen-line (- window-start target-line))) - (if (or (not move-point) - (<= recenter-arg (window-height))) - (recenter recenter-arg) - (goto-char target) - (recenter -1) - (move-to-window-line -1))) - ((<= (point) target) - (setq recenter-arg (- screen-line (- target-line window-end))) - (if (or (not move-point) - (> recenter-arg 0)) - (recenter (max recenter-arg 0)) - (goto-char target) - (recenter 0) - (move-to-window-line 0))))))) - -;; Interface -(defun sly-set-truncate-lines () - "Apply `sly-truncate-lines' to the current buffer." - (when sly-truncate-lines - (set (make-local-variable 'truncate-lines) t))) - -;; Interface -(defun sly-read-package-name (prompt &optional initial-value allow-blank) - "Read a package name from the minibuffer, prompting with PROMPT. -If ALLOW-BLANK may return nil to signal no particular package -selected." - (let* ((completion-ignore-case t) - (res (completing-read - (concat "[sly] " prompt) - (sly-eval - `(slynk:list-all-package-names t)) - nil (not allow-blank) initial-value))) - (unless (zerop (length res)) - res))) - -;; Interface -(defmacro sly-propertize-region (props &rest body) - "Execute BODY and add PROPS to all the text it inserts. -More precisely, PROPS are added to the region between the point's -positions before and after executing BODY." - (declare (indent 1) (debug (sexp &rest form))) - (let ((start (cl-gensym))) - `(let ((,start (point))) - (prog1 (progn ,@body) - (add-text-properties ,start (point) ,props))))) - -(defun sly-add-face (face string) - (declare (indent 1)) - (add-text-properties 0 (length string) (list 'face face) string) - string) - -;; Interface -(defsubst sly-insert-propertized (props &rest args) - "Insert all ARGS and then add text-PROPS to the inserted text." - (sly-propertize-region props (apply #'insert args))) - -(defmacro sly-with-rigid-indentation (level &rest body) - "Execute BODY and then rigidly indent its text insertions. -Assumes all insertions are made at point." - (declare (indent 1)) - (let ((start (cl-gensym)) (l (cl-gensym))) - `(let ((,start (point)) (,l ,(or level '(current-column)))) - (prog1 (progn ,@body) - (sly-indent-rigidly ,start (point) ,l))))) - -(defun sly-indent-rigidly (start end column) - ;; Similar to `indent-rigidly' but doesn't inherit text props. - (let ((indent (make-string column ?\ ))) - (save-excursion - (goto-char end) - (beginning-of-line) - (while (and (<= start (point)) - (progn - (insert-before-markers indent) - (zerop (forward-line -1)))))))) - -(defun sly-insert-indented (&rest strings) - "Insert all arguments rigidly indented." - (sly-with-rigid-indentation nil - (apply #'insert strings))) - -(defun sly-compose (&rest functions) - "Compose unary FUNCTIONS right-associatively, returning a function" - #'(lambda (x) - (cl-reduce #'funcall functions :initial-value x :from-end t))) - -(defun sly-curry (fun &rest args) - "Partially apply FUN to ARGS. The result is a new function." - (lambda (&rest more) (apply fun (append args more)))) - -(defun sly-rcurry (fun &rest args) - "Like `sly-curry' but ARGS on the right are applied." - (lambda (&rest more) (apply fun (append more args)))) - - -;;;;; Temporary popup buffers - -;; keep compiler quiet -(defvar sly-buffer-package) -(defvar sly-buffer-connection) - - -;; Interface -(cl-defmacro sly-with-popup-buffer ((name &key package connection select - same-window-p - mode) - &body body) - "Similar to `with-output-to-temp-buffer'. -Bind standard-output and initialize some buffer-local variables. -Restore window configuration when closed. NAME is the name of -the buffer to be created. PACKAGE is the value -`sly-buffer-package'. CONNECTION is the value for -`sly-buffer-connection', if nil, no explicit connection is -associated with the buffer. If t, the current connection is -taken. MODE is the name of a major mode which will be enabled. -Non-nil SELECT indicates the buffer should be switched to, unless -it is `:hidden' meaning the buffer should not even be -displayed. SELECT can also be `:raise' meaning the buffer should -be switched to and the frame raised. SAME-WINDOW-P is a form -indicating if the popup *can* happen in the same window. The -forms SELECT and SAME-WINDOW-P are evaluated at runtime, not -macroexpansion time. -" - (declare (indent 1) - (debug (sexp &rest form))) - (let* ((package-sym (cl-gensym "package-")) - (connection-sym (cl-gensym "connection-")) - (select-sym (cl-gensym "select")) - (major-mode-sym (cl-gensym "select"))) - `(let ((,package-sym ,(if (eq package t) - `(sly-current-package) - package)) - (,connection-sym ,(if (eq connection t) - `(sly-current-connection) - connection)) - (,major-mode-sym major-mode) - (,select-sym ,select) - (view-read-only nil)) - (with-current-buffer (get-buffer-create ,name) - (let ((inhibit-read-only t) - (standard-output (current-buffer))) - (erase-buffer) - ,@(cond (mode - `((funcall ,mode))) - (t - `((sly-popup-buffer-mode 1)))) - (setq sly-buffer-package ,package-sym - sly-buffer-connection ,connection-sym) - (set-syntax-table lisp-mode-syntax-table) - ,@body - (unless (eq ,select-sym :hidden) - (let ((window (display-buffer - (current-buffer) - (if ,(cond (same-window-p same-window-p) - (mode `(eq ,major-mode-sym ,mode))) - nil - t)))) - (when ,select-sym - (if window - (select-window window t)))) - (if (eq ,select-sym :raise) (raise-frame))) - (current-buffer)))))) - -;;;;; Filename translation -;;; -;;; Filenames passed between Emacs and Lisp should be translated using -;;; these functions. This way users who run Emacs and Lisp on separate -;;; machines have a chance to integrate file operations somehow. - -(defvar sly-to-lisp-filename-function #'convert-standard-filename - "Function to translate Emacs filenames to CL namestrings.") -(defvar sly-from-lisp-filename-function #'identity - "Function to translate CL namestrings to Emacs filenames.") - -(defun sly-to-lisp-filename (filename) - "Translate the string FILENAME to a Lisp filename." - (funcall sly-to-lisp-filename-function (substring-no-properties filename))) - -(defun sly-from-lisp-filename (filename) - "Translate the Lisp filename FILENAME to an Emacs filename." - (funcall sly-from-lisp-filename-function filename)) - - -;;;; Starting SLY -;;; -;;; This section covers starting an inferior-lisp, compiling and -;;; starting the server, initiating a network connection. - -;;;;; Entry points - -;; We no longer load inf-lisp, but we use this variable for backward -;; compatibility. -(defcustom inferior-lisp-program "lisp" - "Program name for starting a Lisp subprocess to Emacs. -Can be a string naming a program, a whitespace-separated string -of \"EXECUTABLE ARG1 ARG2\" or a list (EXECUTABLE ARGS...) where -EXECUTABLE and ARGS are strings." - :type 'string - :group 'sly-lisp) - -(defvar sly-lisp-implementations nil - "*A list of known Lisp implementations. -The list should have the form: - ((NAME (PROGRAM PROGRAM-ARGS...) &key KEYWORD-ARGS) ...) - -NAME is a symbol for the implementation. -PROGRAM and PROGRAM-ARGS are strings used to start the Lisp process. -For KEYWORD-ARGS see `sly-start'. - -Here's an example: - ((cmucl (\"/opt/cmucl/bin/lisp\" \"-quiet\") :init sly-init-command) - (acl (\"acl7\") :coding-system emacs-mule))") - -(defcustom sly-command-switch-to-existing-lisp 'ask - "Should the `sly' command start new lisp if one is available?" - :type '(choice (const :tag "Ask the user" ask) - (const :tag "Always" 'always) - (const :tag "Never" 'never))) - -(defcustom sly-auto-select-connection 'ask - "Controls auto selection after the default connection was closed." - :group 'sly-mode - :type '(choice (const never) - (const always) - (const ask))) - -(defcustom sly-default-lisp nil - "A symbol naming the preferred Lisp implementation. -See `sly-lisp-implementations'" - :type 'function - :group 'sly-mode) - -;; dummy definitions for the compiler -(defvar sly-net-processes) -(defvar sly-default-connection) - -;;;###autoload -(cl-defun sly (&optional command coding-system interactive) - "Start a Lisp implementation and connect to it. - - COMMAND designates a the Lisp implementation to start as an -\"inferior\" process to the Emacs process. It is either a -pathname string pathname to a lisp executable, a list (EXECUTABLE -ARGS...), or a symbol indexing -`sly-lisp-implementations'. CODING-SYSTEM is a symbol overriding -`sly-net-coding-system'. - -Interactively, both COMMAND and CODING-SYSTEM are nil and the -prefix argument controls the precise behaviour: - -- With no prefix arg, try to automatically find a Lisp. First - consult `sly-command-switch-to-existing-lisp' and analyse open - connections to maybe switch to one of those. If a new lisp is - to be created, first lookup `sly-lisp-implementations', using - `sly-default-lisp' as a default strategy. Then try - `inferior-lisp-program' if it looks like it points to a valid - lisp. Failing that, guess the location of a lisp - implementation. - -- With a positive prefix arg (one C-u), prompt for a command - string that starts a Lisp implementation. - -- With a negative prefix arg (M-- M-x sly, for example) prompt - for a symbol indexing one of the entries in - `sly-lisp-implementations'" - (interactive (list nil nil t)) - (sly--when-let* - ((active (and interactive - (not current-prefix-arg) - (sly--purge-connections))) - (target (or (and (eq sly-command-switch-to-existing-lisp 'ask) - (sly-prompt-for-connection - "[sly] Switch to open connection?\n\ - (Customize `sly-command-switch-to-existing-lisp' to avoid this prompt.)\n\ - Connections: " nil "(start a new one)")) - (and (eq sly-command-switch-to-existing-lisp 'always) - (car active))))) - (sly-message "Switching to `%s'" (sly-connection-name target)) - (sly-connection-list-default-action target) - (cl-return-from sly nil)) - (let ((command (or command inferior-lisp-program)) - (sly-net-coding-system (or coding-system sly-net-coding-system))) - (apply #'sly-start - (cond (interactive - (sly--read-interactive-args)) - (t - (if sly-lisp-implementations - (sly--lookup-lisp-implementation - sly-lisp-implementations - (or (and (symbolp command) command) - sly-default-lisp - (car (car sly-lisp-implementations)))) - (let ((command-and-args (if (listp command) - command - (split-string command)))) - `(:program ,(car command-and-args) - :program-args ,(cdr command-and-args))))))))) - -(defvar sly-inferior-lisp-program-history '() - "History list of command strings. Used by M-x sly.") - -(defun sly--read-interactive-args () - "Return the list of args which should be passed to `sly-start'. -Helper for M-x sly" - (cond ((not current-prefix-arg) - (cond (sly-lisp-implementations - (sly--lookup-lisp-implementation sly-lisp-implementations - (or sly-default-lisp - (car (car sly-lisp-implementations))))) - (t (cl-destructuring-bind (program &rest args) - (split-string-and-unquote - (sly--guess-inferior-lisp-program t)) - (list :program program :program-args args))))) - ((eq current-prefix-arg '-) - (let ((key (completing-read - "Lisp name: " (mapcar (lambda (x) - (list (symbol-name (car x)))) - sly-lisp-implementations) - nil t))) - (sly--lookup-lisp-implementation sly-lisp-implementations (intern key)))) - (t - (cl-destructuring-bind (program &rest program-args) - (split-string-and-unquote - (read-shell-command "[sly] Run lisp: " - (sly--guess-inferior-lisp-program nil) - 'sly-inferior-lisp-program-history)) - (let ((coding-system - (if (eq 16 (prefix-numeric-value current-prefix-arg)) - (read-coding-system "[sly] Set sly-coding-system: " - sly-net-coding-system) - sly-net-coding-system))) - (list :program program :program-args program-args - :coding-system coding-system)))))) - - -(defun sly--lookup-lisp-implementation (table name) - (let ((arguments (cl-rest (assoc name table)))) - (unless arguments - (error "Could not find lisp implementation with the name '%S'" name)) - (when (and (= (length arguments) 1) - (functionp (cl-first arguments))) - (setf arguments (funcall (cl-first arguments)))) - (cl-destructuring-bind ((prog &rest args) &rest keys) arguments - (cl-list* :name name :program prog :program-args args keys)))) - -(defun sly-inferior-lisp-buffer (sly-process-or-connection &optional pop-to-buffer) - "Return PROCESS's buffer. With POP-TO-BUFFER, pop to it." - (interactive (list (sly-process) t)) - (let ((buffer (cond ((and sly-process-or-connection - (process-get sly-process-or-connection - 'sly-inferior-lisp-process)) - (process-buffer sly-process-or-connection)) - (sly-process-or-connection - ;; call ourselves recursively with a - ;; sly-started process - ;; - (sly-inferior-lisp-buffer (sly-process sly-process-or-connection) - pop-to-buffer ))))) - (cond ((and buffer - pop-to-buffer) - (pop-to-buffer buffer)) - ((and pop-to-buffer - sly-process-or-connection) - (sly-message "No *inferior lisp* process for current connection!")) - (pop-to-buffer - (sly-error "No *inferior lisp* buffer"))) - buffer)) - -(defun sly--guess-inferior-lisp-program (&optional interactive) - "Compute pathname to a seemingly valid lisp implementation. -If ERRORP, error if such a thing cannot be found" - (let ((inferior-lisp-program-and-args - (and inferior-lisp-program - (if (listp inferior-lisp-program) - inferior-lisp-program - (split-string-and-unquote inferior-lisp-program))))) - (if (and inferior-lisp-program-and-args - (executable-find (car inferior-lisp-program-and-args))) - (combine-and-quote-strings inferior-lisp-program-and-args) - (let ((guessed (cl-some #'executable-find - '("lisp" "sbcl" "clisp" "cmucl" - "acl" "alisp")))) - (cond ((and guessed - (or (not interactive) - noninteractive - (sly-y-or-n-p - "Can't find `inferior-lisp-program' (set to `%s'). Use `%s' instead? " - inferior-lisp-program guessed))) - guessed) - (interactive - (sly-error - (substitute-command-keys - "Can't find a suitable Lisp. Use \\[sly-info] to read about `Multiple Lisps'"))) - (t - nil)))))) - -(cl-defun sly-start (&key (program - (sly-error "must supply :program")) - program-args - directory - (coding-system sly-net-coding-system) - (init sly-init-function) - name - (buffer (format "*sly-started inferior-lisp for %s*" - (file-name-nondirectory program))) - init-function - env) - "Start a Lisp process and connect to it. -This function is intended for programmatic use if `sly' is not -flexible enough. - -PROGRAM and PROGRAM-ARGS are the filename and argument strings - for the subprocess. -INIT is a function that should return a string to load and start - Slynk. The function will be called with the PORT-FILENAME and ENCODING as - arguments. INIT defaults to `sly-init-function'. -CODING-SYSTEM a symbol for the coding system. The default is - sly-net-coding-system -ENV environment variables for the subprocess (see `process-environment'). -INIT-FUNCTION function to call right after the connection is established. -BUFFER the name of the buffer to use for the subprocess. -NAME a symbol to describe the Lisp implementation -DIRECTORY change to this directory before starting the process. -" - (let ((args (list :program program :program-args program-args :buffer buffer - :coding-system coding-system :init init :name name - :init-function init-function :env env))) - (sly-check-coding-system coding-system) - (let ((proc (sly-maybe-start-lisp program program-args env - directory buffer))) - (sly-inferior-connect proc args) - (sly-inferior-lisp-buffer proc)))) - -;;;###autoload -(defun sly-connect (host port &optional _coding-system interactive-p) - "Connect to a running Slynk server. Return the connection. -With prefix arg, asks if all connections should be closed -before." - (interactive (list (read-from-minibuffer - "[sly] Host: " (cl-first sly-connect-host-history) - nil nil '(sly-connect-host-history . 1)) - (string-to-number - (read-from-minibuffer - "[sly] Port: " (cl-first sly-connect-port-history) - nil nil '(sly-connect-port-history . 1))) - nil t)) - (when (and interactive-p - sly-net-processes - current-prefix-arg - (sly-y-or-n-p "[sly] Close all connections first? ")) - (sly-disconnect-all)) - (sly-message "Connecting to Slynk on port %S.." port) - (let* ((process (sly-net-connect host port)) - (sly-dispatching-connection process)) - (sly-setup-connection process))) - -;;;;; Start inferior lisp -;;; -;;; Here is the protocol for starting SLY via `M-x sly': -;;; -;;; 1. Emacs starts an inferior Lisp process. -;;; 2. Emacs tells Lisp (via stdio) to load and start Slynk. -;;; 3. Lisp recompiles the Slynk if needed. -;;; 4. Lisp starts the Slynk server and writes its TCP port to a temp file. -;;; 5. Emacs reads the temp file to get the port and then connects. -;;; 6. Emacs prints a message of warm encouragement for the hacking ahead. -;;; -;;; Between steps 2-5 Emacs polls for the creation of the temp file so -;;; that it can make the connection. This polling may continue for a -;;; fair while if Slynk needs recompilation. - -(defvar sly-connect-retry-timer nil - "Timer object while waiting for an inferior-lisp to start.") - -(defun sly-abort-connection () - "Abort connection the current connection attempt." - (interactive) - (cond (sly-connect-retry-timer - (sly-cancel-connect-retry-timer) - (sly-message "Cancelled connection attempt.")) - (t (error "Not connecting")))) - -;;; Starting the inferior Lisp and loading Slynk: - -(defun sly-maybe-start-lisp (program program-args env directory buffer) - "Return a new or existing inferior lisp process." - (cond ((not (comint-check-proc buffer)) - (sly-start-lisp program program-args env directory buffer)) - (t (sly-start-lisp program program-args env directory - (generate-new-buffer-name buffer))))) - -(defvar sly-inferior-process-start-hook nil - "Hook called whenever a new process gets started.") - -(defun sly-start-lisp (program program-args env directory buffer) - "Does the same as `inferior-lisp' but less ugly. -Return the created process." - (with-current-buffer (get-buffer-create buffer) - (when directory - (cd (expand-file-name directory))) - (comint-mode) - (let ((process-environment (append env process-environment)) - (process-connection-type nil)) - (comint-exec (current-buffer) "inferior-lisp" program nil program-args)) - (lisp-mode-variables t) - (let ((proc (get-buffer-process (current-buffer)))) - (process-put proc 'sly-inferior-lisp-process t) - (set-process-query-on-exit-flag proc (not sly-kill-without-query-p)) - (run-hooks 'sly-inferior-process-start-hook) - proc))) - -(defun sly-inferior-connect (process args) - "Start a Slynk server in the inferior Lisp and connect." - (sly-delete-slynk-port-file 'quiet) - (sly-start-slynk-server process args) - (sly-read-port-and-connect process)) - -(defun sly-start-slynk-server (inf-process args) - "Start a Slynk server on the inferior lisp." - (cl-destructuring-bind (&key coding-system init &allow-other-keys) args - (with-current-buffer (process-buffer inf-process) - (process-put inf-process 'sly-inferior-lisp-args args) - (let ((str (funcall init (sly-slynk-port-file) coding-system))) - (goto-char (process-mark inf-process)) - (insert-before-markers str) - (process-send-string inf-process str))))) - -(defun sly-inferior-lisp-args (inf-process) - "Return the initial process arguments. -See `sly-start'." - (process-get inf-process 'sly-inferior-lisp-args)) - -(defun sly-init-using-asdf (port-filename coding-system) - "Return a string to initialize Lisp using ASDF. -Fall back to `sly-init-using-slynk-loader' if ASDF fails." - (format "%S\n\n" - `(cond ((ignore-errors - (funcall 'require "asdf") - (funcall (read-from-string "asdf:version-satisfies") - (funcall (read-from-string "asdf:asdf-version")) - "2.019")) - (push (pathname ,(sly-to-lisp-filename (sly-slynk-path))) - (symbol-value - (read-from-string "asdf:*central-registry*"))) - (funcall - (read-from-string "asdf:load-system") - :slynk) - (funcall - (read-from-string "slynk:start-server") - ,(sly-to-lisp-filename port-filename))) - (t - ,(read (sly-init-using-slynk-loader port-filename - coding-system)))))) - -;; XXX load-server & start-server used to be separated. maybe that was better. -(defun sly-init-using-slynk-loader (port-filename _coding-system) - "Return a string to initialize Lisp." - (let ((loader (sly-to-lisp-filename - (expand-file-name sly-slynk-loader-backend (sly-slynk-path))))) - ;; Return a single form to avoid problems with buffered input. - (format "%S\n\n" - `(progn - (load ,loader :verbose t) - (funcall (read-from-string "slynk-loader:init")) - (funcall (read-from-string "slynk:start-server") - ,port-filename))))) - -(defun sly-slynk-port-file () - "Filename where the SLYNK server writes its TCP port number." - (expand-file-name (format "sly.%S" (emacs-pid)) (sly-temp-directory))) - -(defun sly-temp-directory () - (cond ((fboundp 'temp-directory) (temp-directory)) - ((boundp 'temporary-file-directory) temporary-file-directory) - (t "/tmp/"))) - -(defun sly-delete-slynk-port-file (&optional quiet) - (condition-case data - (delete-file (sly-slynk-port-file)) - (error - (cl-ecase quiet - ((nil) (signal (car data) (cdr data))) - (quiet) - (sly-message (sly-message "Unable to delete slynk port file %S" - (sly-slynk-port-file))))))) - -(defun sly-read-port-and-connect (inferior-process) - (sly-attempt-connection inferior-process nil 1)) - -(defcustom sly-connection-poll-interval 0.3 - "Seconds to wait between connection attempts when first connecting." - :type 'number - :group 'sly-ui) - -(defun sly-attempt-connection (process retries attempt) - ;; A small one-state machine to attempt a connection with - ;; timer-based retries. - (sly-cancel-connect-retry-timer) - (let ((file (sly-slynk-port-file))) - (unless (active-minibuffer-window) - (sly-message "Polling %S .. %d (Abort with `M-x sly-abort-connection'.)" - file attempt)) - (cond ((and (file-exists-p file) - (> (nth 7 (file-attributes file)) 0)) ; file size - (let ((port (sly-read-slynk-port)) - (args (sly-inferior-lisp-args process))) - (sly-delete-slynk-port-file 'message) - (let ((c (sly-connect sly-lisp-host port - (plist-get args :coding-system)))) - (sly-set-inferior-process c process)))) - ((and retries (zerop retries)) - (sly-message "Gave up connecting to Slynk after %d attempts." attempt)) - ((eq (process-status process) 'exit) - (sly-message "Failed to connect to Slynk: inferior process exited.")) - (t - (when (and (file-exists-p file) - (zerop (nth 7 (file-attributes file)))) - (sly-message "(Zero length port file)") - ;; the file may be in the filesystem but not yet written - (unless retries (setq retries 3))) - (cl-assert (not sly-connect-retry-timer)) - (setq sly-connect-retry-timer - (run-with-timer - sly-connection-poll-interval nil - (lambda () - (let ((sly-ignore-protocol-mismatches - sly-ignore-protocol-mismatches)) - (sly-attempt-connection process (and retries (1- retries)) - (1+ attempt)))))))))) - -(defun sly-cancel-connect-retry-timer () - (when sly-connect-retry-timer - (cancel-timer sly-connect-retry-timer) - (setq sly-connect-retry-timer nil))) - -(defun sly-read-slynk-port () - "Read the Slynk server port number from the `sly-slynk-port-file'." - (save-excursion - (with-temp-buffer - (insert-file-contents (sly-slynk-port-file)) - (goto-char (point-min)) - (let ((port (read (current-buffer)))) - (cl-assert (integerp port)) - port)))) - -(defun sly-toggle-debug-on-slynk-error () - (interactive) - (if (sly-eval `(slynk:toggle-debug-on-slynk-error)) - (sly-message "Debug on SLYNK error enabled.") - (sly-message "Debug on SLYNK error disabled."))) - -;;; Words of encouragement - -(defun sly-user-first-name () - (let ((name (if (string= (user-full-name) "") - (user-login-name) - (user-full-name)))) - (string-match "^[^ ]*" name) - (capitalize (match-string 0 name)))) - -(defvar sly-words-of-encouragement - `("Let the hacking commence!" - "Hacks and glory await!" - "Hack and be merry!" - "Your hacking starts... NOW!" - "May the source be with you!" - "Take this REPL, brother, and may it serve you well." - "Lemonodor-fame is but a hack away!" - "Are we consing yet?" - ,(format "%s, this could be the start of a beautiful program." - (sly-user-first-name))) - "Scientifically-proven optimal words of hackerish encouragement.") - -(defun sly-random-words-of-encouragement () - "Return a string of hackerish encouragement." - (eval (nth (random (length sly-words-of-encouragement)) - sly-words-of-encouragement) - t)) - - -;;;; Networking -;;; -;;; This section covers the low-level networking: establishing -;;; connections and encoding/decoding protocol messages. -;;; -;;; Each SLY protocol message beings with a 6-byte header followed -;;; by an S-expression as text. The sexp must be readable both by -;;; Emacs and by Common Lisp, so if it contains any embedded code -;;; fragments they should be sent as strings: -;;; -;;; The set of meaningful protocol messages are not specified -;;; here. They are defined elsewhere by the event-dispatching -;;; functions in this file and in slynk.lisp. - -(defvar sly-net-processes nil - "List of processes (sockets) connected to Lisps.") - -(defvar sly-net-process-close-hooks '() - "List of functions called when a sly network connection closes. -The functions are called with the process as their argument.") - -(defun sly-secret () - "Find the magic secret from the user's home directory. -Return nil if the file doesn't exist or is empty; otherwise the -first line of the file." - (condition-case _err - (with-temp-buffer - (insert-file-contents "~/.sly-secret") - (goto-char (point-min)) - (buffer-substring (point-min) (line-end-position))) - (file-error nil))) - -;;; Interface -(defvar sly--net-connect-counter 0) - -(defun sly-send-secret (proc) - (sly--when-let (secret (sly-secret)) - (let* ((payload (encode-coding-string secret 'utf-8-unix)) - (string (concat (sly-net-encode-length (length payload)) - payload))) - (process-send-string proc string)))) - -(defun sly-net-connect (host port) - "Establish a connection with a CL." - (let* ((inhibit-quit nil) - (name (format "sly-%s" (cl-incf sly--net-connect-counter))) - (connection (open-network-stream name nil host port)) - (buffer (sly-make-net-buffer (format " *%s*" name)))) - (push connection sly-net-processes) - (set-process-plist connection `(sly--net-connect-counter - ,sly--net-connect-counter)) - (set-process-buffer connection buffer) - (set-process-filter connection 'sly-net-filter) - (set-process-sentinel connection 'sly-net-sentinel) - (set-process-query-on-exit-flag connection (not sly-kill-without-query-p)) - (when (fboundp 'set-process-coding-system) - (set-process-coding-system connection 'binary 'binary)) - (sly-send-secret connection) - connection)) - -(defun sly-make-net-buffer (name) - "Make a buffer suitable for a network process." - (let ((buffer (generate-new-buffer name))) - (with-current-buffer buffer - (buffer-disable-undo) - (set (make-local-variable 'kill-buffer-query-functions) nil)) - buffer)) - -;;;;; Coding system madness - -(defun sly-check-coding-system (coding-system) - "Signal an error if CODING-SYSTEM isn't a valid coding system." - (interactive) - (let ((props (sly-find-coding-system coding-system))) - (unless props - (error "Invalid sly-net-coding-system: %s. %s" - coding-system (mapcar #'car sly-net-valid-coding-systems))) - (when (and (cl-second props) (boundp 'default-enable-multibyte-characters)) - (cl-assert default-enable-multibyte-characters)) - t)) - -(defun sly-coding-system-mulibyte-p (coding-system) - (cl-second (sly-find-coding-system coding-system))) - -(defun sly-coding-system-cl-name (coding-system) - (cl-third (sly-find-coding-system coding-system))) - -;;; Interface -(defvar sly-net-send-translator nil - "If non-nil, function to translate outgoing sexps for the wire.") - -(defun sly--sanitize-or-lose (form) - "Sanitize FORM for Slynk or error." - (cl-typecase form - (number) - (symbol 'fonix) - (string (set-text-properties 0 (length form) nil form)) - (cons (sly--sanitize-or-lose (car form)) - (sly--sanitize-or-lose (cdr form))) - (t (sly-error "Can't serialize %s for Slynk." form))) - form) - -(defun sly-net-send (sexp proc) - "Send a SEXP to Lisp over the socket PROC. -This is the lowest level of communication. The sexp will be READ and -EVAL'd by Lisp." - (let* ((print-circle nil) - (print-quoted nil) - (sexp (sly--sanitize-or-lose sexp)) - (sexp (if (and sly-net-send-translator - (fboundp sly-net-send-translator)) - (funcall sly-net-send-translator sexp) - sexp)) - (payload (encode-coding-string - (concat (sly-prin1-to-string sexp) "\n") - 'utf-8-unix)) - (string (concat (sly-net-encode-length (length payload)) - payload))) - (sly-log-event sexp proc) - (process-send-string proc string))) - -(defun sly-safe-encoding-p (coding-system string) - "Return true iff CODING-SYSTEM can safely encode STRING." - (or (let ((candidates (find-coding-systems-string string)) - (base (coding-system-base coding-system))) - (or (equal candidates '(undecided)) - (memq base candidates))) - (and (not (multibyte-string-p string)) - (not (sly-coding-system-mulibyte-p coding-system))))) - -(defun sly-net-close (connection reason &optional debug _force) - "Close the network connection CONNECTION because REASON." - (process-put connection 'sly-net-close-reason reason) - (setq sly-net-processes (remove connection sly-net-processes)) - (when (eq connection sly-default-connection) - (setq sly-default-connection nil)) - ;; Run hooks - ;; - (unless debug - (run-hook-with-args 'sly-net-process-close-hooks connection)) - ;; We close the socket connection by killing its hidden - ;; *sly-<number>* buffer, but we first unset the connection's - ;; sentinel otherwise we could get a second `sly-net-close' call. In - ;; case the buffer is already killed (we killed it manually), this - ;; function is probably running as a result of that, and rekilling - ;; it is harmless. - ;; - (set-process-sentinel connection nil) - (when debug - (set-process-filter connection nil)) - (if debug - (delete-process connection) ; leave the buffer - (kill-buffer (process-buffer connection)))) - -(defun sly-net-sentinel (process message) - (let ((reason (format "Lisp connection closed unexpectedly: %s" message))) - (sly-message reason) - (sly-net-close process reason))) - -;;; Socket input is handled by `sly-net-filter', which decodes any -;;; complete messages and hands them off to the event dispatcher. - -(defun sly-net-filter (process string) - "Accept output from the socket and process all complete messages." - (with-current-buffer (process-buffer process) - (goto-char (point-max)) - (insert string)) - (sly-process-available-input process)) - -(defun sly-process-available-input (process) - "Process all complete messages that have arrived from Lisp." - (with-current-buffer (process-buffer process) - (while (sly-net-have-input-p) - (let ((event (sly-net-read-or-lose process)) - (ok nil)) - (sly-log-event event process) - (unwind-protect - (save-current-buffer - (sly-dispatch-event event process) - (setq ok t)) - (unless ok - (run-at-time 0 nil 'sly-process-available-input process))))))) - -(defsubst sly-net-decode-length () - (string-to-number (buffer-substring (point) (+ (point) 6)) - 16)) - -(defun sly-net-have-input-p () - "Return true if a complete message is available." - (goto-char (point-min)) - (and (>= (buffer-size) 6) - (>= (- (buffer-size) 6) (sly-net-decode-length)))) - -(defun sly-handle-net-read-error (error) - (let ((packet (buffer-string))) - (sly-with-popup-buffer ((sly-buffer-name :error - :connection (get-buffer-process (current-buffer)))) - (princ (format "%s\nin packet:\n%s" (error-message-string error) packet)) - (goto-char (point-min))) - (cond ((sly-y-or-n-p "Skip this packet? ") - `(:emacs-skipped-packet ,packet)) - (t - (when (sly-y-or-n-p "Enter debugger instead? ") - (debug 'error error)) - (signal (car error) (cdr error)))))) - -(defun sly-net-read-or-lose (process) - (condition-case error - (sly-net-read) - (error - (sly-net-close process "Fatal net-read error" t) - (error "net-read error: %S" error)))) - -(defun sly-net-read () - "Read a message from the network buffer." - (goto-char (point-min)) - (let* ((length (sly-net-decode-length)) - (start (+ (point) 6)) - (end (+ start length))) - (cl-assert (cl-plusp length)) - (prog1 (save-restriction - (narrow-to-region start end) - (condition-case error - (progn - (decode-coding-region start end 'utf-8-unix) - (setq end (point-max)) - (read (current-buffer))) - (error - (sly-handle-net-read-error error)))) - (delete-region (point-min) end)))) - -(defun sly-net-encode-length (n) - (format "%06x" n)) - -(defun sly-prin1-to-string (sexp) - "Like `prin1-to-string' but don't octal-escape non-ascii characters. -This is more compatible with the CL reader." - (let (print-escape-nonascii - print-escape-newlines - print-length - print-level) - (prin1-to-string sexp))) - - -;;;; Connections -;;; -;;; "Connections" are the high-level Emacs<->Lisp networking concept. -;;; -;;; Emacs has a connection to each Lisp process that it's interacting -;;; with. Typically there would only be one, but a user can choose to -;;; connect to many Lisps simultaneously. -;;; -;;; A connection consists of a control socket, optionally an extra -;;; socket dedicated to receiving Lisp output (an optimization), and a -;;; set of connection-local state variables. -;;; -;;; The state variables are stored as buffer-local variables in the -;;; control socket's process-buffer and are used via accessor -;;; functions. These variables include things like the *FEATURES* list -;;; and Unix Pid of the Lisp process. -;;; -;;; One connection is "current" at any given time. This is: -;;; `sly-dispatching-connection' if dynamically bound, or -;;; `sly-buffer-connection' if this is set buffer-local, or -;;; `sly-default-connection' otherwise. -;;; -;;; When you're invoking commands in your source files you'll be using -;;; `sly-default-connection'. This connection can be interactively -;;; reassigned via the connection-list buffer. -;;; -;;; When a command creates a new buffer it will set -;;; `sly-buffer-connection' so that commands in the new buffer will -;;; use the connection that the buffer originated from. For example, -;;; the apropos command creates the *Apropos* buffer and any command -;;; in that buffer (e.g. `M-.') will go to the same Lisp that did the -;;; apropos search. REPL buffers are similarly tied to their -;;; respective connections. -;;; -;;; When Emacs is dispatching some network message that arrived from a -;;; connection it will dynamically bind `sly-dispatching-connection' -;;; so that the event will be processed in the context of that -;;; connection. -;;; -;;; This is mostly transparent. The user should be aware that he can -;;; set the default connection to pick which Lisp handles commands in -;;; Lisp-mode source buffers, and sly hackers should be aware that -;;; they can tie a buffer to a specific connection. The rest takes -;;; care of itself. - -(defvar sly-dispatching-connection nil - "Network process currently executing. -This is dynamically bound while handling messages from Lisp; it -overrides `sly-buffer-connection' and `sly-default-connection'.") - -(make-variable-buffer-local - (defvar sly-buffer-connection nil - "Network connection to use in the current buffer. -This overrides `sly-default-connection'.")) - -(defvar sly-default-connection nil - "Network connection to use by default. -Used for all Lisp communication, except when overridden by -`sly-dispatching-connection' or `sly-buffer-connection'.") - -(defun sly-current-connection () - "Return the connection to use for Lisp interaction. -Return nil if there's no connection." - (or sly-dispatching-connection - sly-buffer-connection - sly-default-connection)) - -(defun sly-connection () - "Return the connection to use for Lisp interaction. -Signal an error if there's no connection." - (let ((conn (sly-current-connection))) - (cond ((and (not conn) sly-net-processes) - (or (sly-auto-select-connection) - (error "Connections available, but none selected."))) - ((not conn) - (or (sly-auto-start) - (error "No current SLY connection."))) - ((not (process-live-p conn)) - (error "Current connection %s is closed." conn)) - (t conn)))) - -(define-obsolete-variable-alias 'sly-auto-connect - 'sly-auto-start "2.5") -(defcustom sly-auto-start 'never - "Controls auto connection when information from lisp process is needed. -This doesn't mean it will connect right after SLY is loaded." - :group 'sly-mode - :type '(choice (const never) - (const always) - (const ask))) - -(defun sly-auto-start () - (cond ((or (eq sly-auto-start 'always) - (and (eq sly-auto-start 'ask) - (sly-y-or-n-p "No connection. Start SLY? "))) - (save-window-excursion - (sly) - (while (not (sly-current-connection)) - (sleep-for 1)) - (sly-connection))) - (t nil))) - -(cl-defmacro sly-with-connection-buffer ((&optional process) &rest body) - "Execute BODY in the process-buffer of PROCESS. -If PROCESS is not specified, `sly-connection' is used. - -\(fn (&optional PROCESS) &body BODY))" - (declare (indent 1)) - `(with-current-buffer - (process-buffer (or ,process (sly-connection) - (error "No connection"))) - ,@body)) - -;;; Connection-local variables: - -(defmacro sly-def-connection-var (varname &rest initial-value-and-doc) - "Define a connection-local variable. -The value of the variable can be read by calling the function of the -same name (it must not be accessed directly). The accessor function is -setf-able. - -The actual variable bindings are stored buffer-local in the -process-buffers of connections. The accessor function refers to -the binding for `sly-connection'." - (declare (indent 2)) - `(progn - ;; Accessor - (defun ,varname (&optional process) - ,(cl-second initial-value-and-doc) - (let ((process (or process - (sly-current-connection) - (error "Can't access prop %s for no connection" ',varname)))) - (or (process-get process ',varname) - (let ((once ,(cl-first initial-value-and-doc))) - (process-put process ',varname once) - once)))) - ;; Setf - (gv-define-setter ,varname (store &optional process) - `(let ((process (or ,process - (sly-current-connection) - (error "Can't access prop %s for no connection" ',',varname))) - (store-once ,store)) - (process-put process ',',varname store-once) - store-once)) - '(\, varname))) - -(sly-def-connection-var sly-connection-number nil - "Serial number of a connection. -Bound in the connection's process-buffer.") - -(sly-def-connection-var sly-lisp-features '() - "The symbol-names of Lisp's *FEATURES*. -This is automatically synchronized from Lisp.") - -(sly-def-connection-var sly-lisp-modules '() - "The strings of Lisp's *MODULES*.") - -(sly-def-connection-var sly-pid nil - "The process id of the Lisp process.") - -(sly-def-connection-var sly-lisp-implementation-type nil - "The implementation type of the Lisp process.") - -(sly-def-connection-var sly-lisp-implementation-version nil - "The implementation type of the Lisp process.") - -(sly-def-connection-var sly-lisp-implementation-name nil - "The short name for the Lisp implementation.") - -(sly-def-connection-var sly-lisp-implementation-program nil - "The argv[0] of the process running the Lisp implementation.") - -(sly-def-connection-var sly-connection-name nil - "The short name for connection.") - -(sly-def-connection-var sly-inferior-process nil - "The inferior process for the connection if any.") - -(sly-def-connection-var sly-communication-style nil - "The communication style.") - -(sly-def-connection-var sly-machine-instance nil - "The name of the (remote) machine running the Lisp process.") - -(sly-def-connection-var sly-connection-coding-systems nil - "Coding systems supported by the Lisp process.") - -;;;;; Connection setup - -(defvar sly-connection-counter 0 - "The number of SLY connections made. For generating serial numbers.") - -;;; Interface -(defun sly-setup-connection (process) - "Make a connection out of PROCESS." - (let ((sly-dispatching-connection process)) - (sly-init-connection-state process) - (sly-select-connection process) - (sly--setup-contribs) - process)) - -(defun sly-init-connection-state (proc) - "Initialize connection state in the process-buffer of PROC." - ;; To make life simpler for the user: if this is the only open - ;; connection then reset the connection counter. - (when (equal sly-net-processes (list proc)) - (setq sly-connection-counter 0)) - (sly-with-connection-buffer () - (setq sly-buffer-connection proc)) - (setf (sly-connection-number proc) (cl-incf sly-connection-counter)) - ;; We do the rest of our initialization asynchronously. The current - ;; function may be called from a timer, and if we setup the REPL - ;; from a timer then it mysteriously uses the wrong keymap for the - ;; first command. - (let ((sly-current-thread t)) - (sly-eval-async '(slynk:connection-info) - (sly-curry #'sly-set-connection-info proc) - nil - `((sly-ignore-protocol-mismatches . ,sly-ignore-protocol-mismatches))))) - -(defun sly--trampling-rename-buffer (newname) - "Rename current buffer NEWNAME, trampling over existing ones." - (let ((existing (get-buffer newname))) - (unless (eq existing - (current-buffer)) - ;; Trample over any existing buffers on reconnection - (when existing - (let ((kill-buffer-query-functions nil)) - (kill-buffer existing))) - (rename-buffer newname)))) - -(defun sly-set-connection-info (connection info) - "Initialize CONNECTION with INFO received from Lisp." - (let ((sly-dispatching-connection connection) - (sly-current-thread t)) - (cl-destructuring-bind (&key pid style lisp-implementation machine - features version modules encoding - &allow-other-keys) info - (sly-check-version version connection) - (setf (sly-pid) pid - (sly-communication-style) style - (sly-lisp-features) features - (sly-lisp-modules) modules) - (cl-destructuring-bind (&key type name version program) - lisp-implementation - (setf (sly-lisp-implementation-type) type - (sly-lisp-implementation-version) version - (sly-lisp-implementation-name) name - (sly-lisp-implementation-program) program - (sly-connection-name) (sly-generate-connection-name name))) - (cl-destructuring-bind (&key instance ((:type _)) ((:version _))) machine - (setf (sly-machine-instance) instance)) - (cl-destructuring-bind (&key coding-systems) encoding - (setf (sly-connection-coding-systems) coding-systems))) - (let ((args (sly--when-let (p (sly-inferior-process)) - (sly-inferior-lisp-args p)))) - (sly--when-let (name (plist-get args ':name)) - (unless (string= (sly-lisp-implementation-name) name) - (setf (sly-connection-name) - (sly-generate-connection-name (symbol-name name))))) - (sly-contrib--load-slynk-dependencies) - (run-hooks 'sly-connected-hook) - (sly--when-let (fun (plist-get args ':init-function)) - (funcall fun))) - ;; Give the events buffer its final name - (with-current-buffer (sly--events-buffer connection) - (sly--trampling-rename-buffer (sly-buffer-name - :events - :connection connection))) - ;; Rename the inferior lisp buffer if there is one (i.e. when - ;; started via `M-x sly') - ;; - (let ((inferior-lisp-buffer (sly-inferior-lisp-buffer - (sly-process connection)))) - (when inferior-lisp-buffer - (with-current-buffer inferior-lisp-buffer - (sly--trampling-rename-buffer (sly-buffer-name - :inferior-lisp - :connection connection))))) - (sly-message "Connected. %s" (sly-random-words-of-encouragement)))) - -(defun sly-check-version (version conn) - (or (equal version sly-protocol-version) - (null sly-protocol-version) - sly-ignore-protocol-mismatches - (sly-y-or-n-p - (format "Versions differ: %s (sly) vs. %s (slynk). Continue? " - sly-protocol-version version)) - (sly-net-close conn "Versions differ") - (top-level))) - -(defun sly-generate-connection-name (lisp-name) - (when (file-exists-p lisp-name) - (setq lisp-name (file-name-nondirectory lisp-name))) - (cl-loop for i from 1 - for name = lisp-name then (format "%s<%d>" lisp-name i) - while (cl-find name sly-net-processes - :key #'sly-connection-name :test #'equal) - finally (cl-return name))) - -(defun sly-select-new-default-connection (conn) - "If dead CONN was the default connection, select a new one." - (when (eq conn sly-default-connection) - (when sly-net-processes - (sly-select-connection (car sly-net-processes)) - (sly-message "Default connection closed; default is now #%S (%S)" - (sly-connection-number) - (sly-connection-name))))) - -(defcustom sly-keep-buffers-on-connection-close '(:mrepl) - "List of buffers to keep around after a connection closes." - :group 'sly-mode - :type '(repeat - (choice - (const :tag "Debugger" :db) - (const :tag "Repl" :mrepl) - (const :tag "Ispector" :inspector) - (const :tag "Stickers replay" :stickers-replay) - (const :tag "Error" :error) - (const :tag "Source" :source) - (const :tag "Compilation" :compilation) - (const :tag "Apropos" :apropos) - (const :tag "Xref" :xref) - (const :tag "Macroexpansion" :macroexpansion) - (symbol :tag "Other")))) - -(defun sly-kill-stale-connection-buffers (conn) ; - "If CONN had some stale buffers, kill them. -Respect `sly-keep-buffers-on-connection-close'." - (let ((buffer-list (buffer-list)) - (matchers - (mapcar - (lambda (type) - (format ".*%s.*$" - ;; XXX: this is synched with `sly-buffer-name'. - (regexp-quote (format "*sly-%s" - (downcase (substring (symbol-name type) - 1)))))) - (cl-set-difference '(:db - :mrepl - :inspector - :stickers-replay - :error - :source - :compilation - :apropos - :xref - :macroexpansion) - sly-keep-buffers-on-connection-close)))) - (cl-loop for buffer in buffer-list - when (and (cl-some (lambda (matcher) - (string-match matcher (buffer-name buffer))) - matchers) - (with-current-buffer buffer - (eq sly-buffer-connection conn))) - do (kill-buffer buffer)))) - -(add-hook 'sly-net-process-close-hooks 'sly-select-new-default-connection) -(add-hook 'sly-net-process-close-hooks 'sly-kill-stale-connection-buffers 'append) - -;;;;; Commands on connections - -(defun sly--purge-connections () - "Purge `sly-net-processes' of dead processes, return living." - (cl-loop for process in sly-net-processes - if (process-live-p process) - collect process - else do - (sly-warning "process %s in `sly-net-processes' dead. Force closing..." process) - (sly-net-close process "process state invalid" nil t))) - -(defun sly-prompt-for-connection (&optional prompt connections dont-require-match) - (let* ((connections (or connections (sly--purge-connections))) - (connection-names (cl-loop for process in - (sort connections - #'(lambda (p1 _p2) - (eq p1 (sly-current-connection)))) - collect (sly-connection-name process))) - (connection-names (if dont-require-match - (cons dont-require-match - connection-names) - connection-names)) - (connection-name (and connection-names - (completing-read - (or prompt "Connection: ") - connection-names - nil (not dont-require-match)))) - (target (cl-find connection-name sly-net-processes :key #'sly-connection-name - :test #'string=))) - (cond (target target) - ((and dont-require-match (or (zerop (length connection-name)) - (string= connection-name dont-require-match))) - nil) - (connection-name - (sly-error "No such connection")) - (t - (sly-error "No connections"))))) - -(defun sly-auto-select-connection () - (let* ((c0 (car (sly--purge-connections))) - (c (cond ((eq sly-auto-select-connection 'always) c0) - ((and (eq sly-auto-select-connection 'ask) - (sly-prompt-for-connection "Choose a new default connection: ")))))) - (when c - (sly-select-connection c) - (sly-message "Switching to connection: %s" (sly-connection-name c)) - c))) - -(defvar sly-select-connection-hook nil) - -(defun sly-select-connection (process) - "Make PROCESS the default connection." - (setq sly-default-connection process) - (run-hooks 'sly-select-connection-hook)) - -(define-obsolete-function-alias 'sly-cycle-connections 'sly-next-connection "1.0.0-beta") - -(defun sly-next-connection (arg &optional dont-wrap) - "Switch to the next SLY connection, cycling through all connections. -Skip ARG-1 connections. Negative ARG means cycle back. DONT-WRAP -means don't wrap around when last connection is reached." - (interactive "p") - (cl-labels ((connection-full-name - (c) - (format "%s %s" (sly-connection-name c) (process-contact c)))) - (cond ((not sly-net-processes) - (sly-error "No connections to cycle")) - ((null (cdr sly-net-processes)) - (sly-message "Only one connection: %s" (connection-full-name (car sly-net-processes)))) - (t - (let* ((dest (append (member (sly-current-connection) - sly-net-processes) - (unless dont-wrap sly-net-processes))) - (len (length sly-net-processes)) - (target (nth (mod arg len) - dest))) - (unless target - (sly-error "No more connections")) - (sly-select-connection target) - (if (and sly-buffer-connection - (not (eq sly-buffer-connection target))) - (sly-message "switched to: %s but buffer remains in: %s" - (connection-full-name target) - (connection-full-name sly-buffer-connection)) - (sly-message "switched to: %s (%s/%s)" (connection-full-name target) - (1+ (cl-position target sly-net-processes)) - len)) - (sly--refresh-mode-line)))))) - -(defun sly-prev-connection (arg &optional dont-wrap) - "Switch to the previous SLY connection, cycling through all connections. -See `sly-next-connection' for other args." - (interactive "p") - (sly-next-connection (- arg) dont-wrap)) - -(defun sly-disconnect (&optional interactive) - "Close the current connection." - (interactive (list t)) - (let ((connection (if interactive - (sly-prompt-for-connection "Connection to disconnect: ") - (sly-current-connection)))) - (sly-net-close connection "Disconnecting"))) - -(defun sly-disconnect-all () - "Disconnect all connections." - (interactive) - (mapc #'(lambda (process) - (sly-net-close process "Disconnecting all connections")) - sly-net-processes)) - -(defun sly-connection-port (connection) - "Return the remote port number of CONNECTION." - (cadr (process-contact connection))) - -(defun sly-process (&optional connection) - "Return the Lisp process for CONNECTION (default `sly-connection'). -Return nil if there's no process object for the connection." - (let ((proc (sly-inferior-process connection))) - (if (and proc - (memq (process-status proc) '(run stop))) - proc))) - -;; Non-macro version to keep the file byte-compilable. -(defun sly-set-inferior-process (connection process) - (setf (sly-inferior-process connection) process)) - -(defun sly-use-sigint-for-interrupt (&optional connection) - (let ((c (or connection (sly-connection)))) - (cl-ecase (sly-communication-style c) - ((:fd-handler nil) t) - ((:spawn :sigio) nil)))) - -(defvar sly-inhibit-pipelining t - "*If true, don't send background requests if Lisp is already busy.") - -(defun sly-background-activities-enabled-p () - (and (let ((con (sly-current-connection))) - (and con - (eq (process-status con) 'open))) - (or (not (sly-busy-p)) - (not sly-inhibit-pipelining)))) - - -;;;; Communication protocol - -;;;;; Emacs Lisp programming interface -;;; -;;; The programming interface for writing Emacs commands is based on -;;; remote procedure calls (RPCs). The basic operation is to ask Lisp -;;; to apply a named Lisp function to some arguments, then to do -;;; something with the result. -;;; -;;; Requests can be either synchronous (blocking) or asynchronous -;;; (with the result passed to a callback/continuation function). If -;;; an error occurs during the request then the debugger is entered -;;; before the result arrives -- for synchronous evaluations this -;;; requires a recursive edit. -;;; -;;; You should use asynchronous evaluations (`sly-eval-async') for -;;; most things. Reserve synchronous evaluations (`sly-eval') for -;;; the cases where blocking Emacs is really appropriate (like -;;; completion) and that shouldn't trigger errors (e.g. not evaluate -;;; user-entered code). -;;; -;;; We have the concept of the "current Lisp package". RPC requests -;;; always say what package the user is making them from and the Lisp -;;; side binds that package to *BUFFER-PACKAGE* to use as it sees -;;; fit. The current package is defined as the buffer-local value of -;;; `sly-buffer-package' if set, and otherwise the package named by -;;; the nearest IN-PACKAGE as found by text search (cl-first backwards, -;;; then forwards). -;;; -;;; Similarly we have the concept of the current thread, i.e. which -;;; thread in the Lisp process should handle the request. The current -;;; thread is determined solely by the buffer-local value of -;;; `sly-current-thread'. This is usually bound to t meaning "no -;;; particular thread", but can also be used to nominate a specific -;;; thread. The REPL and the debugger both use this feature to deal -;;; with specific threads. - -(make-variable-buffer-local - (defvar sly-current-thread t - "The id of the current thread on the Lisp side. -t means the \"current\" thread; -fixnum a specific thread.")) - -(make-variable-buffer-local - (defvar sly-buffer-package nil - "The Lisp package associated with the current buffer. -This is set only in buffers bound to specific packages.")) - -;;; `sly-rex' is the RPC primitive which is used to implement both -;;; `sly-eval' and `sly-eval-async'. You can use it directly if -;;; you need to, but the others are usually more convenient. - -(defvar sly-rex-extra-options-functions nil - "Functions returning extra options to send with `sly-rex'.") - -(cl-defmacro sly-rex ((&rest _) - (sexp &optional - (package '(sly-current-package)) - (thread 'sly-current-thread)) - &rest continuations) - "(sly-rex (VAR ...) (SEXP &optional PACKAGE THREAD) CLAUSES ...) - -Remote EXecute SEXP. - -SEXP is evaluated and the princed version is sent to Lisp. - -PACKAGE is evaluated and Lisp binds *BUFFER-PACKAGE* to this package. -The default value is (sly-current-package). - -CLAUSES is a list of patterns with same syntax as -`sly-dcase'. The result of the evaluation of SEXP is -dispatched on CLAUSES. The result is either a sexp of the -form (:ok VALUE) or (:abort CONDITION). CLAUSES is executed -asynchronously. - -Note: don't use backquote syntax for SEXP, because various Emacs -versions cannot deal with that." - (declare (indent 2) - (debug (sexp (form &optional sexp sexp) - &rest (sexp &rest form)))) - (let ((result (cl-gensym))) - `(sly-dispatch-event - (cl-list* :emacs-rex ,sexp ,package ,thread - (lambda (,result) - (sly-dcase ,result - ,@continuations)) - (cl-loop for fn in sly-rex-extra-options-functions - append (funcall fn)))))) - -;;; Interface -(defun sly-current-package () - "Return the Common Lisp package in the current context. -If `sly-buffer-package' has a value then return that, otherwise -search for and read an `in-package' form." - (or sly-buffer-package - (save-restriction - (widen) - (sly-find-buffer-package)))) - -(defvar sly-find-buffer-package-function 'sly-search-buffer-package - "*Function to use for `sly-find-buffer-package'. -The result should be the package-name (a string) -or nil if nothing suitable can be found.") - -(defun sly-find-buffer-package () - "Figure out which Lisp package the current buffer is associated with." - (funcall sly-find-buffer-package-function)) - -(make-variable-buffer-local - (defvar sly-package-cache nil - "Cons of the form (buffer-modified-tick . package)")) - -;; When modifing this code consider cases like: -;; (in-package #.*foo*) -;; (in-package #:cl) -;; (in-package :cl) -;; (in-package "CL") -;; (in-package |CL|) -;; (in-package #+ansi-cl :cl #-ansi-cl 'lisp) - -(defun sly-search-buffer-package () - (let ((case-fold-search t) - (regexp (concat "^[ \t]*(\\(cl:\\|common-lisp:\\)?in-package\\>[ \t']*" - "\\([^)]+\\)[ \t]*)"))) - (save-excursion - (when (or (re-search-backward regexp nil t) - (re-search-forward regexp nil t)) - (match-string-no-properties 2))))) - -;;; Synchronous requests are implemented in terms of asynchronous -;;; ones. We make an asynchronous request with a continuation function -;;; that `throw's its result up to a `catch' and then enter a loop of -;;; handling I/O until that happens. - -(defvar sly--stack-eval-tags nil - "List of stack-tags of waiting on the elisp stack. -This is used by the sly-db debugger to decide whether to enter a -`recursive-edit', so that if a synchronous `sly-eval' request -errors and brings us a Slynk debugger, we can fix the error, -invoke a restart and still get the return value of the `sly-eval' -as if nothing had happened.") - -(defun sly-eval (sexp &optional package cancel-on-input cancel-on-input-retval) - "Evaluate SEXP in Slynk's PACKAGE and return the result. -If CANCEL-ON-INPUT cancel the request immediately if the user -wants to input, and return CANCEL-ON-INPUT-RETVAL." - (when (null package) (setq package (sly-current-package))) - (let* ((catch-tag (make-symbol (format "sly-result-%d" - (sly-continuation-counter)))) - (sly--stack-eval-tags (cons catch-tag sly--stack-eval-tags)) - (cancelled nil) - (check-conn - (lambda () - (unless (eq (process-status (sly-connection)) 'open) - (error "Lisp connection closed unexpectedly")))) - (retval - (unwind-protect - (catch catch-tag - (sly-rex () - (sexp package) - ((:ok value) - (unless cancelled - (unless (member catch-tag sly--stack-eval-tags) - (error "Reply to nested `sly-eval' request with tag=%S sexp=%S" - catch-tag sexp)) - (throw catch-tag (list #'identity value)))) - ((:abort _condition) - (unless cancelled - (throw catch-tag - (list #'error "Synchronous Lisp Evaluation aborted"))))) - (cond (cancel-on-input - ;; Setting `inhibit-quit' to t helps with - ;; callers that wrap us in `while-no-input', - ;; like `fido-mode' and Helm. It doesn't seem - ;; to create any specific problems, since - ;; `sit-for' exits immediately given input - ;; anyway. This include the C-g input, and - ;; thus even with `inhibit-quit' set to t, quit - ;; happens immediately. - (unwind-protect - (let ((inhibit-quit t)) (while (sit-for 30))) - (setq cancelled t)) - (funcall check-conn)) - (t - (while t - (funcall check-conn) - (accept-process-output nil 30)))) - (list #'identity cancel-on-input-retval)) - ;; Protect against user quit during - ;; `accept-process-output' or `sit-for', so that if the - ;; Lisp is alive and replies, we don't get an error. - (setq cancelled t)))) - (apply (car retval) (cdr retval)))) - -(defun sly-eval-async (sexp &optional cont package env) - "Evaluate SEXP on the superior Lisp and call CONT with the result. - -CONT is called with the overriding dynamic environment in ENV, an -alist of bindings" - (declare (indent 1)) - (let ((buffer (current-buffer))) - (sly-rex () - (sexp (or package (sly-current-package))) - ((:ok result) - (when cont - (set-buffer buffer) - (cl-progv (mapcar #'car env) (mapcar #'cdr env) - (if debug-on-error - (funcall cont result) - (condition-case err - (funcall cont result) - (error - (sly-message "`sly-eval-async' errored: %s" - (if (and (eq 'error (car err)) - (stringp (cadr err))) - (cadr err) - err)))))))) - ((:abort condition) - (sly-message "Evaluation aborted on %s." condition)))) - ;; Guard against arbitrary return values which once upon a time - ;; showed up in the minibuffer spuriously (due to a bug in - ;; sly-autodoc.) If this ever happens again, returning the - ;; following will make debugging much easier: - :sly-eval-async) - -;;; These functions can be handy too: - -(defun sly-connected-p () - "Return true if the Slynk connection is open." - (not (null sly-net-processes))) - -(defun sly-check-connected () - "Signal an error if we are not connected to Lisp." - (unless (sly-connected-p) - (error "Not connected. Use `%s' to start a Lisp." - (substitute-command-keys "\\[sly]")))) - -;; UNUSED -(defun sly-debugged-connection-p (conn) - ;; This previously was (AND (SLY-DB-DEBUGGED-CONTINUATIONS CONN) T), - ;; but an SLY-DB buffer may exist without having continuations - ;; attached to it, e.g. the one resulting from `sly-interrupt'. - (cl-loop for b in (sly-db-buffers) - thereis (with-current-buffer b - (eq sly-buffer-connection conn)))) - -(defun sly-busy-p (&optional conn) - "True if Lisp has outstanding requests. -Debugged requests are ignored." - (let ((debugged (sly-db-debugged-continuations (or conn (sly-connection))))) - (cl-remove-if (lambda (id) - (memq id debugged)) - (sly-rex-continuations) - :key #'car))) - -(defun sly-sync () - "Block until the most recent request has finished." - (when (sly-rex-continuations) - (let ((tag (caar (sly-rex-continuations)))) - (while (cl-find tag (sly-rex-continuations) :key #'car) - (accept-process-output nil 0.1))))) - -(defun sly-ping () - "Check that communication works." - (interactive) - (sly-message "%s" (sly-eval "PONG"))) - -;;;;; Protocol event handler (the guts) -;;; -;;; This is the protocol in all its glory. The input to this function -;;; is a protocol event that either originates within Emacs or arrived -;;; over the network from Lisp. -;;; -;;; Each event is a list beginning with a keyword and followed by -;;; arguments. The keyword identifies the type of event. Events -;;; originating from Emacs have names starting with :emacs- and events -;;; from Lisp don't. - -(sly-def-connection-var sly-rex-continuations '() - "List of (ID . FUNCTION) continuations waiting for RPC results.") - -(sly-def-connection-var sly-continuation-counter 0 - "Continuation serial number counter.") - -(defvar sly-event-hooks) - -(defun sly-dispatch-event (event &optional process) - (let ((sly-dispatching-connection (or process (sly-connection)))) - (or (run-hook-with-args-until-success 'sly-event-hooks event) - (sly-dcase event - ((:emacs-rex form package thread continuation &rest extra-options) - (when (and (sly-use-sigint-for-interrupt) (sly-busy-p)) - (sly-display-oneliner "; pipelined request... %S" form)) - (let ((id (cl-incf (sly-continuation-counter)))) - ;; JT@2020-12-10: FIXME: Force inhibit-quit here to - ;; ensure atomicity between `sly-send' and the `push'? - ;; See Github#385.. - (sly-send `(:emacs-rex ,form ,package ,thread ,id ,@extra-options)) - (push (cons id continuation) (sly-rex-continuations)) - (sly--refresh-mode-line))) - ((:return value id) - (let ((rec (assq id (sly-rex-continuations)))) - (cond (rec (setf (sly-rex-continuations) - (remove rec (sly-rex-continuations))) - (funcall (cdr rec) value) - (sly--refresh-mode-line)) - (t - (error "Unexpected reply: %S %S" id value))))) - ((:debug-activate thread level &optional _ignored) - (cl-assert thread) - (sly-db--ensure-initialized thread level)) - ((:debug thread level condition restarts frames conts) - (cl-assert thread) - (sly-db-setup thread level condition restarts frames conts)) - ((:debug-return thread level stepping) - (cl-assert thread) - (sly-db-exit thread level stepping)) - ((:emacs-interrupt thread) - (sly-send `(:emacs-interrupt ,thread))) - ((:read-from-minibuffer thread tag prompt initial-value) - (sly-read-from-minibuffer-for-slynk thread tag prompt - initial-value)) - ((:y-or-n-p thread tag question) - (sly-remote-y-or-n-p thread tag question)) - ((:emacs-return-string thread tag string) - (sly-send `(:emacs-return-string ,thread ,tag ,string))) - ((:new-features features) - (setf (sly-lisp-features) features)) - ((:indentation-update info) - (sly-handle-indentation-update info)) - ((:eval-no-wait form) - (sly-check-eval-in-emacs-enabled) - (eval (read form) t)) - ((:eval thread tag form-string) - (sly-check-eval-in-emacs-enabled) - (sly-eval-for-lisp thread tag form-string)) - ((:emacs-return thread tag value) - (sly-send `(:emacs-return ,thread ,tag ,value))) - ((:ed what) - (sly-ed what)) - ((:inspect what thread tag) - (let ((hook (when (and thread tag) - (sly-curry #'sly-send - `(:emacs-return ,thread ,tag nil))))) - (sly--open-inspector what :kill-hook hook :switch :raise))) - ((:background-message message) - (sly-temp-message 1 3 "[background-message] %s" message)) - ((:debug-condition thread message) - (cl-assert thread) - (sly-message "[debug-condition] %s" message)) - ((:ping thread tag) - (sly-send `(:emacs-pong ,thread ,tag))) - ((:reader-error packet condition) - (sly-with-popup-buffer ((sly-buffer-name :error - :connection sly-dispatching-connection)) - (princ (format "Invalid protocol message:\n%s\n\n%s" - condition packet)) - (goto-char (point-min))) - (error "Invalid protocol message")) - ((:invalid-rpc id message) - (setf (sly-rex-continuations) - (cl-remove id (sly-rex-continuations) :key #'car)) - (error "Invalid rpc: %s" message)) - ((:emacs-skipped-packet _pkg)) - ((:test-delay seconds) ; for testing only - (sit-for seconds)) - ((:channel-send id msg) - (sly-channel-send (or (sly-find-channel id) - (error "Invalid channel id: %S %S" id msg)) - msg)) - ((:emacs-channel-send id msg) - (sly-send `(:emacs-channel-send ,id ,msg))) - ((:invalid-channel channel-id reason) - (error "Invalid remote channel %s: %s" channel-id reason)))))) - -(defvar sly--send-last-command nil - "Value of `this-command' at time of last `sly-send' call.") - -(defun sly-send (sexp) - "Send SEXP directly over the wire on the current connection." - (setq sly--send-last-command this-command) - (sly-net-send sexp (sly-connection))) - -(defun sly-reset () - "Clear all pending continuations and erase connection buffer." - (interactive) - (setf (sly-rex-continuations) '()) - (mapc #'kill-buffer (sly-db-buffers)) - (sly-with-connection-buffer () - (erase-buffer))) - -(defun sly-send-sigint () - (interactive) - (signal-process (sly-pid) 'SIGINT)) - -;;;;; Channels - -;;; A channel implements a set of operations. Those operations can be -;;; invoked by sending messages to the channel. Channels are used for -;;; protocols which can't be expressed naturally with RPCs, e.g. for -;;; streaming data over the wire. -;;; -;;; A channel can be "remote" or "local". Remote channels are -;;; represented by integers. Local channels are structures. Messages -;;; sent to a closed (remote) channel are ignored. - -(sly-def-connection-var sly-channels '() - "Alist of the form (ID . CHANNEL).") - -(sly-def-connection-var sly-channels-counter 0 - "Channel serial number counter.") - -(cl-defstruct (sly-channel (:conc-name sly-channel.) - (:constructor - sly-make-channel% (operations name id plist))) - operations name id plist) - -(defun sly-make-channel (operations &optional name) - (let* ((id (cl-incf (sly-channels-counter))) - (ch (sly-make-channel% operations name id nil))) - (push (cons id ch) (sly-channels)) - ch)) - -(defun sly-close-channel (channel) - (setf (sly-channel.operations channel) 'closed-channel) - (let ((probe (assq (sly-channel.id channel) - (and (sly-current-connection) - (sly-channels))))) - (cond (probe (setf (sly-channels) (delete probe (sly-channels)))) - (t (error "Can't close invalid channel: %s" channel))))) - -(defun sly-find-channel (id) - (cdr (assq id (sly-channels)))) - -(defun sly-channel-send (channel message) - (apply (or (gethash (car message) (sly-channel.operations channel)) - (error "Unsupported operation %S for channel %d" - (car message) - (sly-channel.id channel))) - channel (cdr message))) - -(defun sly-channel-put (channel prop value) - (setf (sly-channel.plist channel) - (plist-put (sly-channel.plist channel) prop value))) - -(defun sly-channel-get (channel prop) - (plist-get (sly-channel.plist channel) prop)) - -(eval-and-compile - (defun sly-channel-method-table-name (type) - (intern (format "sly-%s-channel-methods" type)))) - -(defmacro sly-define-channel-type (name) - (declare (indent defun)) - (let ((tab (sly-channel-method-table-name name))) - `(defvar ,tab (make-hash-table :size 10)))) - -(defmacro sly-define-channel-method (type method args &rest body) - (declare (indent 3) (debug (&define sexp name lambda-list - def-body))) - `(puthash ',method - (lambda (self . ,args) ,@body) - ,(sly-channel-method-table-name type))) - -(defun sly-send-to-remote-channel (channel-id msg) - (sly-dispatch-event `(:emacs-channel-send ,channel-id ,msg))) - -;;;;; Event logging to *sly-events* -;;; -;;; The *sly-events* buffer logs all protocol messages for debugging -;;; purposes. - -(defvar sly-log-events t - "*Log protocol events to the *sly-events* buffer.") - -(defun sly-log-event (event process) - "Record the fact that EVENT occurred in PROCESS." - (when sly-log-events - (with-current-buffer (sly--events-buffer process) - ;; trim? - (when (> (buffer-size) 100000) - (goto-char (/ (buffer-size) 2)) - (re-search-forward "^(" nil t) - (delete-region (point-min) (point))) - (goto-char (point-max)) - (unless (bolp) (insert "\n")) - (cond ((and (stringp event) - (string-match "^;" event)) - (insert-before-markers event)) - (t - (save-excursion - (sly-pprint-event event (current-buffer))))) - (goto-char (point-max))))) - -(defun sly-pprint-event (event buffer) - "Pretty print EVENT in BUFFER with limited depth and width." - (let ((print-length 20) - (print-level 6) - (pp-escape-newlines t)) - ;; HACK workaround for gh#183 - (condition-case _oops (pp event buffer) (error (print event buffer))))) - -(defun sly--events-buffer (process) - "Return or create the event log buffer." - (let* ((probe (process-get process 'sly--events-buffer)) - (buffer (or (and (buffer-live-p probe) - probe) - (let ((buffer (get-buffer-create - (apply #'sly-buffer-name - :events - (if (sly-connection-name process) - `(:connection ,process) - `(:suffix ,(format "%s" process))))))) - (with-current-buffer buffer - (buffer-disable-undo) - (when (fboundp 'lisp-data-mode) ; Emacs >= 28 only - (funcall 'lisp-data-mode)) - (set (make-local-variable 'sly-buffer-connection) process) - (sly-mode 1)) - (process-put process 'sly--events-buffer buffer) - buffer)))) - buffer)) - -(defun sly-pop-to-events-buffer (process) - "Pop to the SLY events buffer for PROCESS" - (interactive (list (sly-current-connection))) - (pop-to-buffer (sly--events-buffer process))) - -(defun sly-switch-to-most-recent (mode) - "Switch to most recent buffer in MODE, a major-mode symbol. -With prefix argument, prompt for MODE" - (interactive - (list (if current-prefix-arg - (intern (completing-read - "Switch to most recent buffer in what mode? " - (mapcar #'symbol-name '(lisp-mode - emacs-lisp-mode)) - nil t)) - 'lisp-mode))) - (cl-loop for buffer in (buffer-list) - when (and (with-current-buffer buffer (eq major-mode mode)) - (not (eq buffer (current-buffer))) - (not (string-match "^ " (buffer-name buffer)))) - do (pop-to-buffer buffer) and return buffer)) - -(defun sly-forget-pending-events (process) - "Forget any outgoing events for the PROCESS" - (interactive (list (sly-current-connection))) - (setf (sly-rex-continuations process) nil)) - - -;;;;; Cleanup after a quit - -(defun sly-restart-inferior-lisp () - "Kill and restart the Lisp subprocess." - (interactive) - (cl-assert (sly-inferior-process) () "No inferior lisp process") - (sly-quit-lisp-internal (sly-connection) 'sly-restart-sentinel t)) - -(defun sly-restart-sentinel (connection _message) - "When CONNECTION dies, start a similar inferior lisp process. -Also rearrange windows." - (cl-assert (process-status connection) 'closed) - (let* ((moribund-proc (sly-inferior-process connection)) - (args (sly-inferior-lisp-args moribund-proc)) - (buffer (buffer-name (process-buffer moribund-proc)))) - (sly-net-close connection "Restarting inferior lisp process") - (sly-inferior-connect (sly-start-lisp (plist-get args :program) - (plist-get args :program-args) - (plist-get args :env) - nil - buffer) - args))) - - -;;;; Compilation and the creation of compiler-note annotations - -(defvar sly-highlight-compiler-notes t - "*When non-nil annotate buffers with compilation notes etc.") - -(defcustom sly-compilation-finished-hook '(sly-maybe-show-compilation-log) - "Hook called after compilation. -Each function is called with four arguments (SUCCESSP NOTES BUFFER LOADP) -SUCCESSP indicates if the compilation was successful. -NOTES is a list of compilation notes. -BUFFER is the buffer just compiled, or nil if a string was compiled. -LOADP is the value of the LOAD flag passed to `sly-compile-file', or t -if a string." - :group 'sly-mode - :type 'hook - :options '(sly-maybe-show-compilation-log - sly-show-compilation-log - sly-maybe-show-xrefs-for-notes - sly-goto-first-note)) - -;; FIXME: I doubt that anybody uses this directly and it seems to be -;; only an ugly way to pass arguments. -(defvar sly-compilation-policy nil - "When non-nil compile with these optimization settings.") - -(defun sly-compute-policy (arg) - "Return the policy for the prefix argument ARG." - (let ((between (lambda (min n max) - (cond ((< n min) min) - ((> n max) max) - (t n))))) - (let ((n (prefix-numeric-value arg))) - (cond ((not arg) sly-compilation-policy) - ((cl-plusp n) `((cl:debug . ,(funcall between 0 n 3)))) - ((eq arg '-) `((cl:speed . 3))) - (t `((cl:speed . ,(funcall between 0 (abs n) 3)))))))) - -(cl-defstruct (sly-compilation-result - (:type list) - (:conc-name sly-compilation-result.) - (:constructor nil) - (:copier nil)) - tag notes successp duration loadp faslfile) - -(defvar sly-last-compilation-result nil - "The result of the most recently issued compilation.") - -(defun sly-compiler-notes () - "Return all compiler notes, warnings, and errors." - (sly-compilation-result.notes sly-last-compilation-result)) - -(defun sly-compile-and-load-file (&optional policy) - "Compile and load the buffer's file and highlight compiler notes. - -With (positive) prefix argument the file is compiled with maximal -debug settings (`C-u'). With negative prefix argument it is compiled for -speed (`M--'). If a numeric argument is passed set debug or speed settings -to it depending on its sign. - -Each source location that is the subject of a compiler note is -underlined and annotated with the relevant information. The commands -`sly-next-note' and `sly-previous-note' can be used to navigate -between compiler notes and to display their full details." - (interactive "P") - (sly-compile-file t (sly-compute-policy policy))) - -(defcustom sly-compile-file-options '() - "Plist of additional options that C-c C-k should pass to Lisp. -Currently only :fasl-directory is supported." - :group 'sly-lisp - :type '(plist :key-type symbol :value-type (file :must-match t))) - -(defun sly-compile-file (&optional load policy) - "Compile current buffer's file and highlight resulting compiler notes. - -See `sly-compile-and-load-file' for further details." - (interactive) - (unless buffer-file-name - (error "Buffer %s is not associated with a file." (buffer-name))) - (check-parens) - (when (and (buffer-modified-p) - (or (not compilation-ask-about-save) - (sly-y-or-n-p (format "Save file %s? " (buffer-file-name))))) - (save-buffer)) - (let ((file (sly-to-lisp-filename (buffer-file-name))) - (options (sly-simplify-plist `(,@sly-compile-file-options - :policy ,policy)))) - (sly-eval-async - `(slynk:compile-file-for-emacs ,file ,(if load t nil) - . ,(sly-hack-quotes options)) - #'(lambda (result) - (sly-compilation-finished result (current-buffer)))) - (sly-message "Compiling %s..." file))) - -(defun sly-hack-quotes (arglist) - ;; eval is the wrong primitive, we really want funcall - (cl-loop for arg in arglist collect `(quote ,arg))) - -(defun sly-simplify-plist (plist) - (cl-loop for (key val) on plist by #'cddr - append (cond ((null val) '()) - (t (list key val))))) - -(defun sly-compile-defun (&optional raw-prefix-arg) - "Compile the current toplevel form. - -With (positive) prefix argument the form is compiled with maximal -debug settings (`C-u'). With negative prefix argument it is compiled for -speed (`M--'). If a numeric argument is passed set debug or speed settings -to it depending on its sign." - (interactive "P") - (let ((sly-compilation-policy (sly-compute-policy raw-prefix-arg))) - (if (use-region-p) - (sly-compile-region (region-beginning) (region-end)) - (apply #'sly-compile-region (sly-region-for-defun-at-point))))) - -(defvar sly-compile-region-function 'sly-compile-region-as-string - "Function called by `sly-compile-region' to do actual work.") - -(defun sly-compile-region (start end) - "Compile the region." - (interactive "r") - ;; Check connection before running hooks things like - ;; sly-flash-region don't make much sense if there's no connection - (sly-connection) - (funcall sly-compile-region-function start end)) - -(defun sly-compile-region-as-string (start end) - (sly-flash-region start end) - (sly-compile-string (buffer-substring-no-properties start end) start)) - -(defun sly-compile-string (string start-offset) - (let* ((position (sly-compilation-position start-offset))) - (sly-eval-async - `(slynk:compile-string-for-emacs - ,string - ,(buffer-name) - ',position - ,(if (buffer-file-name) (sly-to-lisp-filename (buffer-file-name))) - ',sly-compilation-policy) - #'(lambda (result) - (sly-compilation-finished result nil))))) - -(defun sly-compilation-position (start-offset) - (let ((line (save-excursion - (goto-char start-offset) - (list (line-number-at-pos) (1+ (current-column)))))) - `((:position ,start-offset) (:line ,@line)))) - -(defcustom sly-load-failed-fasl 'never - "Which action to take when COMPILE-FILE set FAILURE-P to T. -NEVER doesn't load the fasl -ALWAYS loads the fasl -ASK asks the user." - :type '(choice (const never) - (const always) - (const ask))) - -(defun sly-load-failed-fasl-p () - (cl-ecase sly-load-failed-fasl - (never nil) - (always t) - (ask (sly-y-or-n-p "Compilation failed. Load fasl file anyway? ")))) - -(defun sly-compilation-finished (result buffer &optional message) - (let ((notes (sly-compilation-result.notes result)) - (duration (sly-compilation-result.duration result)) - (successp (sly-compilation-result.successp result)) - (faslfile (sly-compilation-result.faslfile result)) - (loadp (sly-compilation-result.loadp result))) - (setf sly-last-compilation-result result) - (sly-show-note-counts notes duration (cond ((not loadp) successp) - (t (and faslfile successp))) - (or (not buffer) loadp) - message) - (when sly-highlight-compiler-notes - (sly-highlight-notes notes)) - (when (and loadp faslfile - (or successp - (sly-load-failed-fasl-p))) - (sly-eval-async `(slynk:load-file ,faslfile))) - (run-hook-with-args 'sly-compilation-finished-hook successp notes buffer loadp))) - -(defun sly-show-note-counts (notes secs successp loadp &optional message) - (sly-message (concat - (cond ((and successp loadp) - "Compiled and loaded") - (successp "Compilation finished") - (t (sly-add-face 'font-lock-warning-face - "Compilation failed"))) - (if (null notes) ". (No warnings)" ": ") - (mapconcat - (lambda (msgs) - (cl-destructuring-bind (sev . notes) msgs - (let ((len (length notes))) - (format "%d %s%s" len (sly-severity-label sev) - (if (= len 1) "" "s"))))) - (sort (sly-alistify notes #'sly-note.severity #'eq) - (lambda (x y) (sly-severity< (car y) (car x)))) - " ") - (if secs (format " [%.2f secs]" secs)) - message))) - -(defun sly-highlight-notes (notes) - "Highlight compiler notes, warnings, and errors in the buffer." - (interactive (list (sly-compiler-notes))) - (with-temp-message "Highlighting notes..." - (save-excursion - (save-restriction - (widen) ; highlight notes on the whole buffer - (sly-remove-notes (point-min) (point-max)) - (mapc #'sly--add-in-buffer-note notes))))) - - -;;;;; Recompilation. - -;; FIXME: This whole idea is questionable since it depends so -;; crucially on precise source-locs. - -(defun sly-recompile-location (location) - (save-excursion - (sly-move-to-source-location location) - (sly-compile-defun))) - -(defun sly-recompile-locations (locations cont) - (sly-eval-async - `(slynk:compile-multiple-strings-for-emacs - ',(cl-loop for loc in locations collect - (save-excursion - (sly-move-to-source-location loc) - (cl-destructuring-bind (start end) - (sly-region-for-defun-at-point) - (list (buffer-substring-no-properties start end) - (buffer-name) - (sly-current-package) - start - (if (buffer-file-name) - (sly-to-lisp-filename (buffer-file-name)) - nil))))) - ',sly-compilation-policy) - cont)) - - -;;;;; Compiler notes list - -(defun sly-one-line-ify (string) - "Return a single-line version of STRING. -Each newlines and following indentation is replaced by a single space." - (with-temp-buffer - (insert string) - (goto-char (point-min)) - (while (re-search-forward "\n[\n \t]*" nil t) - (replace-match " ")) - (buffer-string))) - -(defun sly-xref--get-xrefs-for-notes (notes) - (let ((xrefs)) - (dolist (note notes) - (let* ((location (cl-getf note :location)) - (fn (cadr (assq :file (cdr location)))) - (file (assoc fn xrefs)) - (node - (list (format "%s: %s" - (cl-getf note :severity) - (sly-one-line-ify (cl-getf note :message))) - location))) - (when fn - (if file - (push node (cdr file)) - (setf xrefs (cl-acons fn (list node) xrefs)))))) - xrefs)) - -(defun sly-maybe-show-xrefs-for-notes (_successp notes _buffer _loadp) - "Show the compiler notes NOTES if they come from more than one file." - (let ((xrefs (sly-xref--get-xrefs-for-notes notes))) - (when (cdr xrefs) ; >1 file - (sly-xref--show-results - xrefs 'definition "Compiler notes" (sly-current-package))))) - -(defun sly-maybe-show-compilation-log (successp notes buffer loadp) - "Display the log on failed compilations or if NOTES is non-nil." - (sly-show-compilation-log successp notes buffer loadp - (if successp :hidden nil))) - -(defun sly-show-compilation-log (successp notes buffer loadp &optional select) - "Create and display the compilation log buffer." - (interactive (list (sly-compiler-notes))) - (sly-with-popup-buffer ((sly-buffer-name :compilation) - :mode 'compilation-mode - :select select) - (sly--insert-compilation-log successp notes buffer loadp) - (insert "Compilation " - (if successp "successful" "failed") - "."))) - -(defvar sly-compilation-log--notes (make-hash-table) - "Hash-table (NOTE -> (BUFFER POSITION)) for finding notes in - the SLY compilation log") - -(defun sly--insert-compilation-log (_successp notes _buffer _loadp) - "Insert NOTES in format suitable for `compilation-mode'." - (clrhash sly-compilation-log--notes) - (cl-multiple-value-bind (grouped-notes canonicalized-locs-table) - (sly-group-and-sort-notes notes) - (with-temp-message "Preparing compilation log..." - (let ((inhibit-read-only t) - (inhibit-modification-hooks t)) ; inefficient font-lock-hook - (insert (format "cd %s\n%d compiler notes:\n\n" - default-directory (length notes))) - (cl-loop for notes in grouped-notes - for loc = (gethash (cl-first notes) canonicalized-locs-table) - for start = (point) - do - (cl-loop for note in notes - do (puthash note - (cons (current-buffer) start) - sly-compilation-log--notes)) - (insert - (sly--compilation-note-group-button - (sly-canonicalized-location-to-string loc) notes) - ":") - (sly-insert-note-group notes) - (insert "\n") - (add-text-properties start (point) `(field ,notes)))) - (set (make-local-variable 'compilation-skip-threshold) 0) - (setq next-error-last-buffer (current-buffer))))) - -(defun sly-insert-note-group (notes) - "Insert a group of compiler messages." - (insert "\n") - (dolist (note notes) - (insert " " (sly-severity-label (sly-note.severity note)) ": ") - (let ((start (point))) - (insert (sly-note.message note)) - (let ((ctx (sly-note.source-context note))) - (if ctx (insert "\n" ctx))) - (sly-indent-block start 4)) - (insert "\n"))) - -(defun sly-indent-block (start column) - "If the region back to START isn't a one-liner indent it." - (when (< start (line-beginning-position)) - (save-excursion - (goto-char start) - (insert "\n")) - (sly-indent-rigidly start (point) column))) - -(defun sly-canonicalized-location (location) - "Return a list (FILE LINE COLUMN) for sly-location LOCATION. -This is quite an expensive operation so use carefully." - (save-excursion - (sly-goto-location-buffer (sly-location.buffer location)) - (save-excursion - (sly-move-to-source-location location) - (list (or (buffer-file-name) (buffer-name)) - (save-restriction - (widen) - (line-number-at-pos)) - (1+ (current-column)))))) - -(defun sly-canonicalized-location-to-string (loc) - (if loc - (cl-destructuring-bind (filename line col) loc - (format "%s:%d:%d" - (cond ((not filename) "") - ((let ((rel (file-relative-name filename))) - (if (< (length rel) (length filename)) - rel))) - (t filename)) - line col)) - (format "Unknown location"))) - -(defun sly-group-and-sort-notes (notes) - "First sort, then group NOTES according to their canonicalized locs." - (let ((locs (make-hash-table :test #'eq))) - (mapc (lambda (note) - (let ((loc (sly-note.location note))) - (when (sly-location-p loc) - (puthash note (sly-canonicalized-location loc) locs)))) - notes) - (cl-values (sly-group-similar - (lambda (n1 n2) - (equal (gethash n1 locs nil) (gethash n2 locs t))) - (let* ((bottom most-negative-fixnum) - (+default+ (list "" bottom bottom))) - (sort notes - (lambda (n1 n2) - (cl-destructuring-bind (filename1 line1 col1) - (gethash n1 locs +default+) - (cl-destructuring-bind (filename2 line2 col2) - (gethash n2 locs +default+) - (cond ((string-lessp filename1 filename2) t) - ((string-lessp filename2 filename1) nil) - ((< line1 line2) t) - ((> line1 line2) nil) - (t (< col1 col2))))))))) - locs))) - -(defun sly-note.severity (note) - (plist-get note :severity)) - -(defun sly-note.message (note) - (plist-get note :message)) - -(defun sly-note.source-context (note) - (plist-get note :source-context)) - -(defun sly-note.location (note) - (plist-get note :location)) - -(defun sly-severity-label (severity) - (cl-subseq (symbol-name severity) 1)) - - - -;;;;; Adding a single compiler note -;;;;; -(defun sly-choose-overlay-region (note) - "Choose the start and end points for an overlay over NOTE. -If the location's sexp is a list spanning multiple lines, then the -region around the first element is used. -Return nil if there's no useful source location." - (let ((location (sly-note.location note))) - (when location - (sly-dcase location - ((:error _)) ; do nothing - ((:location file pos _hints) - (cond ((eq (car file) ':source-form) nil) - ((eq (sly-note.severity note) :read-error) - (sly-choose-overlay-for-read-error location)) - ((equal pos '(:eof)) - (list (1- (point-max)) (point-max))) - (t - (sly-choose-overlay-for-sexp location)))))))) - -(defun sly-choose-overlay-for-read-error (location) - (let ((pos (sly-location-offset location))) - (save-excursion - (goto-char pos) - (cond ((sly-symbol-at-point) - ;; package not found, &c. - (list (sly-symbol-start-pos) (sly-symbol-end-pos))) - (t - (list pos (1+ pos))))))) - -(defun sly-choose-overlay-for-sexp (location) - (sly-move-to-source-location location) - (skip-chars-forward "'#`") - (let ((start (point))) - (ignore-errors (sly-forward-sexp)) - (if (sly-same-line-p start (point)) - (list start (point)) - (list (1+ start) - (progn (goto-char (1+ start)) - (ignore-errors (forward-sexp 1)) - (point)))))) -(defun sly-same-line-p (pos1 pos2) - "Return t if buffer positions POS1 and POS2 are on the same line." - (save-excursion (goto-char (min pos1 pos2)) - (<= (max pos1 pos2) (line-end-position)))) - -(defvar sly-severity-face-plist - (list :error 'sly-error-face - :read-error 'sly-error-face - :warning 'sly-warning-face - :redefinition 'sly-style-warning-face - :style-warning 'sly-style-warning-face - :note 'sly-note-face)) - -(defun sly-severity-face (severity) - "Return the name of the font-lock face representing SEVERITY." - (or (plist-get sly-severity-face-plist severity) - (error "No face for: %S" severity))) - -(defvar sly-severity-order - '(:note :style-warning :redefinition :warning :error :read-error)) - -(defun sly-severity< (sev1 sev2) - "Return true if SEV1 is less severe than SEV2." - (< (cl-position sev1 sly-severity-order) - (cl-position sev2 sly-severity-order))) - -(defun sly-forward-positioned-source-path (source-path) - "Move forward through a sourcepath from a fixed position. -The point is assumed to already be at the outermost sexp, making the -first element of the source-path redundant." - (ignore-errors - (sly-forward-sexp) - (beginning-of-defun)) - (sly--when-let (source-path (cdr source-path)) - (down-list 1) - (sly-forward-source-path source-path))) - -(defun sly-forward-source-path (source-path) - (let ((origin (point))) - (condition-case nil - (progn - (cl-loop for (count . more) on source-path - do (progn - (sly-forward-sexp count) - (when more (down-list 1)))) - ;; Align at beginning - (sly-forward-sexp) - (beginning-of-sexp)) - (error (goto-char origin))))) - - -;; FIXME: really fix this mess -;; FIXME: the check shouln't be done here anyway but by M-. itself. - -(defun sly-filesystem-toplevel-directory () - ;; Windows doesn't have a true toplevel root directory, and all - ;; filenames look like "c:/foo/bar/quux.baz" from an Emacs - ;; perspective anyway. - (if (memq system-type '(ms-dos windows-nt)) - "" - (file-name-as-directory "/"))) - -(defun sly-file-name-merge-source-root (target-filename buffer-filename) - "Returns a filename where the source root directory of TARGET-FILENAME -is replaced with the source root directory of BUFFER-FILENAME. - -If no common source root could be determined, return NIL. - -E.g. (sly-file-name-merge-source-root - \"/usr/local/src/joe/upstream/sbcl/code/late-extensions.lisp\" - \"/usr/local/src/joe/hacked/sbcl/compiler/deftype.lisp\") - - ==> \"/usr/local/src/joe/hacked/sbcl/code/late-extensions.lisp\" -" - (let ((target-dirs (split-string (file-name-directory target-filename) - "/" t)) - (buffer-dirs (split-string (file-name-directory buffer-filename) - "/" t))) - ;; Starting from the end, we look if one of the TARGET-DIRS exists - ;; in BUFFER-FILENAME---if so, it and everything left from that dirname - ;; is considered to be the source root directory of BUFFER-FILENAME. - (cl-loop with target-suffix-dirs = nil - with buffer-dirs* = (reverse buffer-dirs) - with target-dirs* = (reverse target-dirs) - for target-dir in target-dirs* - do (let ((concat-dirs (lambda (dirs) - (apply #'concat - (mapcar #'file-name-as-directory - dirs)))) - (pos (cl-position target-dir buffer-dirs* - :test #'equal))) - (if (not pos) ; TARGET-DIR not in BUFFER-FILENAME? - (push target-dir target-suffix-dirs) - (let* ((target-suffix - ; PUSH reversed for us! - (funcall concat-dirs target-suffix-dirs)) - (buffer-root - (funcall concat-dirs - (reverse (nthcdr pos buffer-dirs*))))) - (cl-return (concat (sly-filesystem-toplevel-directory) - buffer-root - target-suffix - (file-name-nondirectory - target-filename))))))))) - -(defun sly-highlight-differences-in-dirname (base-dirname contrast-dirname) - "Returns a copy of BASE-DIRNAME where all differences between -BASE-DIRNAME and CONTRAST-DIRNAME are propertized with a -highlighting face." - (setq base-dirname (file-name-as-directory base-dirname)) - (setq contrast-dirname (file-name-as-directory contrast-dirname)) - (let ((base-dirs (split-string base-dirname "/" t)) - (contrast-dirs (split-string contrast-dirname "/" t))) - (with-temp-buffer - (cl-loop initially (insert (sly-filesystem-toplevel-directory)) - for base-dir in base-dirs do - (let ((pos (cl-position base-dir contrast-dirs :test #'equal))) - (cond ((not pos) - (sly-insert-propertized '(face highlight) base-dir) - (insert "/")) - (t - (insert (file-name-as-directory base-dir)) - (setq contrast-dirs - (nthcdr (1+ pos) contrast-dirs)))))) - (buffer-substring (point-min) (point-max))))) - -(defvar sly-warn-when-possibly-tricked-by-M-. t - "When working on multiple source trees simultaneously, the way -`sly-edit-definition' (M-.) works can sometimes be confusing: - -`M-.' visits locations that are present in the current Lisp image, -which works perfectly well as long as the image reflects the source -tree that one is currently looking at. - -In the other case, however, one can easily end up visiting a file -in a different source root directory (the one corresponding to -the Lisp image), and is thus easily tricked to modify the wrong -source files---which can lead to quite some stressfull cursing. - -If this variable is T, a warning message is issued to raise the -user's attention whenever `M-.' is about opening a file in a -different source root that also exists in the source root -directory of the user's current buffer. - -There's no guarantee that all possible cases are covered, but -if you encounter such a warning, it's a strong indication that -you should check twice before modifying.") - -(defun sly-maybe-warn-for-different-source-root (target-filename - buffer-filename) - (let ((guessed-target (sly-file-name-merge-source-root target-filename - buffer-filename))) - (when (and guessed-target - (not (equal guessed-target target-filename)) - (file-exists-p guessed-target)) - (sly-message "Attention: This is `%s'." - (concat (sly-highlight-differences-in-dirname - (file-name-directory target-filename) - (file-name-directory guessed-target)) - (file-name-nondirectory target-filename)))))) - -(defun sly-check-location-filename-sanity (filename) - (when sly-warn-when-possibly-tricked-by-M-. - (cl-macrolet ((truename-safe (file) `(and ,file (file-truename ,file)))) - (let ((target-filename (truename-safe filename)) - (buffer-filename (truename-safe (buffer-file-name)))) - (when (and target-filename - buffer-filename) - (sly-maybe-warn-for-different-source-root - target-filename buffer-filename)))))) - -(defun sly-check-location-buffer-name-sanity (buffer-name) - (sly-check-location-filename-sanity - (buffer-file-name (get-buffer buffer-name)))) - - - -(defun sly-goto-location-buffer (buffer) - (sly-dcase buffer - ((:file filename) - (let ((filename (sly-from-lisp-filename filename))) - (sly-check-location-filename-sanity filename) - (set-buffer (or (get-file-buffer filename) - (let ((find-file-suppress-same-file-warnings t)) - (find-file-noselect filename)))))) - ((:buffer buffer-name) - (sly-check-location-buffer-name-sanity buffer-name) - (set-buffer buffer-name)) - ((:buffer-and-file buffer filename) - (sly-goto-location-buffer - (if (get-buffer buffer) - (list :buffer buffer) - (list :file filename)))) - ((:source-form string) - (set-buffer (get-buffer-create (sly-buffer-name :source))) - (erase-buffer) - (lisp-mode) - (insert string) - (goto-char (point-min))) - ((:zip file entry) - (require 'arc-mode) - (set-buffer (find-file-noselect file t)) - (goto-char (point-min)) - (re-search-forward (concat " " entry "$")) - (let ((buffer (save-window-excursion - (archive-extract) - (current-buffer)))) - (set-buffer buffer) - (goto-char (point-min)))))) - -(defun sly-goto-location-position (position) - (sly-dcase position - ((:position pos) - (goto-char 1) - (forward-char (- (1- pos) (sly-eol-conversion-fixup (1- pos))))) - ((:offset start offset) - (goto-char start) - (forward-char offset)) - ((:line start &optional column) - (goto-char (point-min)) - (beginning-of-line start) - (cond (column (move-to-column column)) - (t (skip-chars-forward " \t")))) - ((:function-name name) - (let ((case-fold-search t) - (name (regexp-quote name))) - (goto-char (point-min)) - (when (or - (re-search-forward - (format "\\s *(def\\(\\s_\\|\\sw\\)*\\s +(*%s\\S_" - (regexp-quote name)) nil t) - (re-search-forward - (format "[( \t]%s\\>\\(\\s \\|$\\)" name) nil t)) - (goto-char (match-beginning 0))))) - ((:method name specializers &rest qualifiers) - (sly-search-method-location name specializers qualifiers)) - ((:source-path source-path start-position) - (cond (start-position - (goto-char start-position) - (sly-forward-positioned-source-path source-path)) - (t - (sly-forward-source-path source-path)))) - ((:eof) - (goto-char (point-max))))) - -(defun sly-eol-conversion-fixup (n) - ;; Return the number of \r\n eol markers that we need to cross when - ;; moving N chars forward. N is the number of chars but \r\n are - ;; counted as 2 separate chars. - (if (zerop n) 0 - (cl-case (coding-system-eol-type buffer-file-coding-system) - ((1) - (save-excursion - (cl-do ((pos (+ (point) n)) - (count 0 (1+ count))) - ((>= (point) pos) (1- count)) - (forward-line) - (cl-decf pos)))) - (t 0)))) - -(defun sly-search-method-location (name specializers qualifiers) - ;; Look for a sequence of words (def<something> method name - ;; qualifers specializers don't look for "T" since it isn't requires - ;; (arg without t) as class is taken as such. - (let* ((case-fold-search t) - (name (regexp-quote name)) - (qualifiers (mapconcat (lambda (el) (concat ".+?\\<" el "\\>")) - qualifiers "")) - (specializers (mapconcat - (lambda (el) - (if (eql (aref el 0) ?\() - (let ((spec (read el))) - (if (eq (car spec) 'EQL) - (concat - ".*?\\n\\{0,1\\}.*?(EQL.*?'\\{0,1\\}" - (format "%s" (cl-second spec)) ")") - (error "don't understand specializer: %s,%s" - el (car spec)))) - (concat ".+?\n\\{0,1\\}.+?\\<" el "\\>"))) - (remove "T" specializers) "")) - (regexp (format "\\s *(def\\(\\s_\\|\\sw\\)*\\s +%s\\s +%s%s" name - qualifiers specializers))) - (or (and (re-search-forward regexp nil t) - (goto-char (match-beginning 0))) - ;; (sly-goto-location-position `(:function-name ,name)) - ))) - -(defun sly-search-call-site (fname) - "Move to the place where FNAME called. -Don't move if there are multiple or no calls in the current defun." - (save-restriction - (narrow-to-defun) - (let ((start (point)) - (regexp (concat "(" fname "[)\n \t]")) - (case-fold-search t)) - (cond ((and (re-search-forward regexp nil t) - (not (re-search-forward regexp nil t))) - (goto-char (match-beginning 0))) - (t (goto-char start)))))) - -(defun sly-search-edit-path (edit-path) - "Move to EDIT-PATH starting at the current toplevel form." - (when edit-path - (unless (and (= (current-column) 0) - (looking-at "(")) - (beginning-of-defun)) - (sly-forward-source-path edit-path))) - -(defun sly-move-to-source-location (location &optional noerror) - "Move to the source location LOCATION. -If NOERROR don't signal an error, but return nil. - -Several kinds of locations are supported: - -<location> ::= (:location <buffer> <position> <hints>) - | (:error <message>) - -<buffer> ::= (:file <filename>) - | (:buffer <buffername>) - | (:buffer-and-file <buffername> <filename>) - | (:source-form <string>) - | (:zip <file> <entry>) - -<position> ::= (:position <fixnum>) ; 1 based (for files) - | (:offset <start> <offset>) ; start+offset (for C-c C-c) - | (:line <line> [<column>]) - | (:function-name <string>) - | (:source-path <list> <start-position>) - | (:method <name string> <specializers> . <qualifiers>)" - (sly-dcase location - ((:location buffer _position _hints) - (sly-goto-location-buffer buffer) - (let ((pos (sly-location-offset location))) - (cond ((and (<= (point-min) pos) (<= pos (point-max)))) - (widen-automatically (widen)) - (t - (error "Location is outside accessible part of buffer"))) - (goto-char pos))) - ((:error message) - (cond (noerror - (sly-message "%s" message) - nil) - (t - (error "%s" message)))))) - -(defun sly--highlight-sexp (&optional start end) - "Highlight the first sexp after point." - (let ((start (or start (point))) - (end (or end (save-excursion (ignore-errors (forward-sexp)) (point))))) - (sly-flash-region start end))) - -(defun sly--highlight-line (&optional timeout) - (sly-flash-region (+ (line-beginning-position) (current-indentation)) - (line-end-position) - :timeout timeout)) - -(make-variable-buffer-local - (defvar sly-xref--popup-method nil - "Helper for `sly--display-source-location'")) - -(cl-defun sly--display-source-location (source-location - &optional noerror (method 'window)) - "Display SOURCE-LOCATION in a window according to METHOD. -Highlight the resulting sexp. Return the window or raise an -error, unless NOERROR is nil, in which case return nil. METHOD -specifies how to behave when a reference is selected in an xref -buffer. If one of symbols `window' or `frame' just -`display-buffer' accordingly. If nil, just switch to buffer in -current window. If a cons (WINDOW . METHOD) consider WINDOW the -\"starting window\" and reconsider METHOD like above: If it is -nil try to use WINDOW exclusively for showing the location, -otherwise prevent that window from being reused when popping to a -new window or frame." - (cl-labels - ((pop-it - (target-buffer method) - (cond ((eq method 'window) - (display-buffer target-buffer t)) - ((eq method 'frame) - (let ((pop-up-frames t)) - (display-buffer target-buffer t))) - ((consp method) - (let* ((window (car method)) - (sub-method (cdr method))) - (cond ((not (window-live-p window)) - ;; the original window has been deleted: all - ;; bets are off! - ;; - (pop-it target-buffer sub-method)) - (sub-method - ;; shield window from reuse, but restoring - ;; any dedicatedness - ;; - (let ((dedicatedness (window-dedicated-p window))) - (unwind-protect - (progn - ;; (set-window-dedicated-p window 'soft) - ;; - ;; jt@2018-01-27 commented the line - ;; above because since the fix to - ;; emacs' bug#28814 in Emacs 26.1 - ;; (which I myself authored), it won't - ;; work correctly. Best to disable it - ;; for now and eventually copy Emacs's - ;; approach to xref buffers, or better - ;; yet, reuse it. - (pop-it target-buffer sub-method)) - (set-window-dedicated-p window dedicatedness)))) - (t - ;; make efforts to reuse the window, respecting - ;; any `display-buffer' overrides - ;; - (display-buffer - target-buffer - `(,(lambda (buffer _alist) - (when (window-live-p window) - (set-window-buffer window buffer) - window)))))))) - (t - (switch-to-buffer target-buffer) - (selected-window))))) - (when (eq method 'sly-xref) - (setq method sly-xref--popup-method)) - (when (sly-move-to-source-location source-location noerror) - (let ((pos (point))) - (with-selected-window (pop-it (current-buffer) method) - (goto-char pos) - (recenter (if (= (current-column) 0) 1)) - (sly--highlight-sexp) - (selected-window)))))) - -(defun sly--pop-to-source-location (source-location &optional method) - "Pop to SOURCE-LOCATION using METHOD. -If called from an xref buffer, method will be `sly-xref' and -thus also honour `sly-xref--popup-method'." - (let* ((xref-window (selected-window)) - (xref-buffer (window-buffer xref-window))) - (when (eq method 'sly-xref) - (quit-restore-window xref-window 'bury)) - (with-current-buffer xref-buffer - ;; now pop to target - ;; - (select-window - (sly--display-source-location source-location nil method))) - (set-buffer (window-buffer (selected-window))))) - -(defun sly-location-offset (location) - "Return the position, as character number, of LOCATION." - (save-restriction - (widen) - (condition-case nil - (sly-goto-location-position - (sly-location.position location)) - (error (goto-char 0))) - (let ((hints (sly-location.hints location))) - (sly--when-let (snippet (cl-getf hints :snippet)) - (sly-isearch snippet)) - (sly--when-let (snippet (cl-getf hints :edit-path)) - (sly-search-edit-path snippet)) - (sly--when-let (fname (cl-getf hints :call-site)) - (sly-search-call-site fname)) - (when (cl-getf hints :align) - (sly-forward-sexp) - (beginning-of-sexp))) - (point))) - - -;;;;; Incremental search -;; -;; Search for the longest match of a string in either direction. -;; -;; This is for locating text that is expected to be near the point and -;; may have been modified (but hopefully not near the beginning!) - -(defun sly-isearch (string) - "Find the longest occurence of STRING either backwards of forwards. -If multiple matches exist the choose the one nearest to point." - (goto-char - (let* ((start (point)) - (len1 (sly-isearch-with-function 'search-forward string)) - (pos1 (point))) - (goto-char start) - (let* ((len2 (sly-isearch-with-function 'search-backward string)) - (pos2 (point))) - (cond ((and len1 len2) - ;; Have a match in both directions - (cond ((= len1 len2) - ;; Both are full matches -- choose the nearest. - (if (< (abs (- start pos1)) - (abs (- start pos2))) - pos1 pos2)) - ((> len1 len2) pos1) - ((> len2 len1) pos2))) - (len1 pos1) - (len2 pos2) - (t start)))))) - -(defun sly-isearch-with-function (search-fn string) - "Search for the longest substring of STRING using SEARCH-FN. -SEARCH-FN is either the symbol `search-forward' or `search-backward'." - (unless (string= string "") - (cl-loop for i from 1 to (length string) - while (funcall search-fn (substring string 0 i) nil t) - for match-data = (match-data) - do (cl-case search-fn - (search-forward (goto-char (match-beginning 0))) - (search-backward (goto-char (1+ (match-end 0))))) - finally (cl-return (if (null match-data) - nil - ;; Finish based on the last successful match - (store-match-data match-data) - (goto-char (match-beginning 0)) - (- (match-end 0) (match-beginning 0))))))) - - -;;;;; Visiting and navigating the overlays of compiler notes -(defun sly-note-button-p (button) - (eq (button-type button) 'sly-in-buffer-note)) - -(defalias 'sly-next-note 'sly-button-forward) -(defalias 'sly-previous-note 'sly-button-backward) - -(put 'sly-next-note 'sly-button-navigation-command t) -(put 'sly-previous-note 'sly-button-navigation-command t) - -(defun sly-goto-first-note (_successp notes _buffer _loadp) - "Go to the first note in the buffer." - (interactive (list (sly-compiler-notes))) - (when notes - (goto-char (point-min)) - (sly-next-note 1))) - -(defun sly-remove-notes (beg end) - "Remove `sly-note' annotation buttons from BEG to END." - (interactive (if (region-active-p) - (list (region-beginning) (region-end)) - (list (point-min) (point-max)))) - (cl-loop for existing in (overlays-in beg end) - when (sly-note-button-p existing) - do (delete-overlay existing))) - -(defun sly-show-notes (button &rest more-buttons) - "Present the details of a compiler note to the user." - (interactive) - (let ((notes (mapcar (sly-rcurry #'button-get 'sly-note) - (cons button more-buttons)))) - (sly-button-flash button :face (let ((color (face-underline-p (button-get button 'face)))) - (if color `(:background ,color) 'highlight))) - ;; If the compilation window is showing, try to land in a suitable - ;; place there, too... - ;; - (let* ((anchor (car notes)) - (compilation-buffer (sly-buffer-name :compilation)) - (compilation-window (get-buffer-window compilation-buffer t))) - (if compilation-window - (with-current-buffer compilation-buffer - (with-selected-window compilation-window - (let ((buffer-and-pos (gethash anchor - sly-compilation-log--notes))) - (when buffer-and-pos - (cl-assert (eq (car buffer-and-pos) (current-buffer))) - (goto-char (cdr buffer-and-pos)) - (let ((field-end (field-end (1+ (point))))) - (sly-flash-region (point) field-end) - (sly-recenter field-end)))) - (sly-message "Showing note in %s" (current-buffer)))) - ;; Else, do the next best thing, which is echo the messages. - ;; - (if (cdr notes) - (sly-message "%s notes:\n%s" - (length notes) - (mapconcat #'sly-note.message notes "\n")) - (sly-message "%s" (sly-note.message (car notes)))))))) - -(define-button-type 'sly-note :supertype 'sly-button) - -(define-button-type 'sly-in-buffer-note :supertype 'sly-note - 'keymap (let ((map (copy-keymap button-map))) - (define-key map "RET" nil) - map) - 'mouse-action 'sly-show-notes - 'sly-button-echo 'sly-show-notes - 'modification-hooks '(sly--in-buffer-note-modification)) - -(define-button-type 'sly-compilation-note-group :supertype 'sly-note - 'face nil) - -(defun sly--in-buffer-note-modification (button after? _beg _end &optional _len) - (unless after? (delete-overlay button))) - -(defun sly--add-in-buffer-note (note) - "Add NOTE as a `sly-in-buffer-note' button to the source buffer." - (cl-destructuring-bind (&optional beg end) - (sly-choose-overlay-region note) - (when beg - (let* ((contained (sly-button--overlays-between beg end)) - (containers (cl-set-difference (sly-button--overlays-at beg) - contained))) - (cl-loop for ov in contained do (cl-incf (sly-button--level ov))) - (let ((but (make-button beg - end - :type 'sly-in-buffer-note - 'sly-button-search-id (sly-button-next-search-id) - 'sly-note note - 'help-echo (format "[sly] %s" (sly-note.message note)) - 'face (sly-severity-face (sly-note.severity note))))) - (setf (sly-button--level but) - (1+ (cl-reduce #'max containers - :key #'sly-button--level - :initial-value 0)))))))) - -(defun sly--compilation-note-group-button (label notes) - "Pepare notes as a `sly-compilation-note' button. -For insertion in the `compilation-mode' buffer" - (sly--make-text-button label nil :type 'sly-compilation-note-group 'sly-notes-group notes)) - - -;;;; Basic arglisting -;;;; -(defun sly-show-arglist () - (let ((op (ignore-errors - (save-excursion - (backward-up-list 1) - (down-list 1) - (sly-symbol-at-point))))) - (when op - (sly-eval-async `(slynk:operator-arglist ,op ,(sly-current-package)) - (lambda (arglist) - (when arglist - (sly-message "%s" arglist))))))) - - -;;;; Edit definition - -(defun sly-push-definition-stack () - "Add point to find-tag-marker-ring." - (ring-insert find-tag-marker-ring (point-marker))) - -(defun sly-pop-find-definition-stack () - "Pop the edit-definition stack and goto the location." - (interactive) - (pop-tag-mark)) - -(cl-defstruct (sly-xref (:conc-name sly-xref.) (:type list)) - dspec location) - -(cl-defstruct (sly-location (:conc-name sly-location.) (:type list) - (:constructor nil) - (:copier nil)) - tag buffer position hints) - -(defun sly-location-p (o) (and (consp o) (eq (car o) :location))) - -(defun sly-xref-has-location-p (xref) - (sly-location-p (sly-xref.location xref))) - -(defun make-sly-buffer-location (buffer-name position &optional hints) - `(:location (:buffer ,buffer-name) (:position ,position) - ,(when hints `(:hints ,hints)))) - -(defun make-sly-file-location (file-name position &optional hints) - `(:location (:file ,file-name) (:position ,position) - ,(when hints `(:hints ,hints)))) - - - -(defun sly-edit-definition (&optional name method) - "Lookup the definition of the name at point. -If there's no name at point, or a prefix argument is given, then -the function name is prompted. METHOD can be nil, or one of -`window' or `frame' to specify if the new definition should be -popped, respectively, in the current window, a new window, or a -new frame." - (interactive (list (or (and (not current-prefix-arg) - (sly-symbol-at-point t)) - (sly-read-symbol-name "Edit Definition of: ")))) - ;; The hooks might search for a name in a different manner, so don't - ;; ask the user if it's missing before the hooks are run - (let ((xrefs (sly-eval `(slynk:find-definitions-for-emacs ,name)))) - (unless xrefs - (error "No known definition for: %s (in %s)" - name (sly-current-package))) - (cl-destructuring-bind (1loc file-alist) - (sly-analyze-xrefs xrefs) - (cond (1loc - (sly-push-definition-stack) - (sly--pop-to-source-location - (sly-xref.location (car xrefs)) method)) - ((null (cdr xrefs)) ; ((:error "...")) - (error "%s" xrefs)) - (t - (sly-push-definition-stack) - (sly-xref--show-results file-alist 'definition name - (sly-current-package) - (cons (selected-window) - method))))))) - -(defvar sly-edit-uses-xrefs - '(:calls :macroexpands :binds :references :sets :specializes)) - -;;; FIXME. TODO: Would be nice to group the symbols (in each -;;; type-group) by their home-package. -(defun sly-edit-uses (symbol) - "Lookup all the uses of SYMBOL." - (interactive (list (sly-read-symbol-name "Edit Uses of: "))) - (sly-xref--get-xrefs - sly-edit-uses-xrefs - symbol - (lambda (xrefs type symbol package) - (cond - ((and (sly-length= xrefs 1) ; one group - (sly-length= (cdar xrefs) 1)) ; one ref in group - (cl-destructuring-bind (_ (_ loc)) (cl-first xrefs) - (sly-push-definition-stack) - (sly--pop-to-source-location loc))) - (t - (sly-push-definition-stack) - (sly-xref--show-results xrefs type symbol package 'window)))))) - -(defun sly-analyze-xrefs (xrefs) - "Find common filenames in XREFS. -Return a list (SINGLE-LOCATION FILE-ALIST). -SINGLE-LOCATION is true if all xrefs point to the same location. -FILE-ALIST is an alist of the form ((FILENAME . (XREF ...)) ...)." - (list (and xrefs - (let ((loc (sly-xref.location (car xrefs)))) - (and (sly-location-p loc) - (cl-every (lambda (x) (equal (sly-xref.location x) loc)) - (cdr xrefs))))) - (sly-alistify xrefs #'sly-xref-group #'equal))) - -(defun sly-xref-group (xref) - (cond ((sly-xref-has-location-p xref) - (sly-dcase (sly-location.buffer (sly-xref.location xref)) - ((:file filename) filename) - ((:buffer bufname) - (let ((buffer (get-buffer bufname))) - (if buffer - (format "%S" buffer) ; "#<buffer foo.lisp>" - (format "%s (previously existing buffer)" bufname)))) - ((:buffer-and-file _buffer filename) filename) - ((:source-form _) "(S-Exp)") - ((:zip _zip entry) entry))) - (t - "(No location)"))) - -(defun sly-edit-definition-other-window (name) - "Like `sly-edit-definition' but switch to the other window." - (interactive (list (sly-read-symbol-name "Symbol: "))) - (sly-edit-definition name 'window)) - -(defun sly-edit-definition-other-frame (name) - "Like `sly-edit-definition' but switch to the other window." - (interactive (list (sly-read-symbol-name "Symbol: "))) - (sly-edit-definition name 'frame)) - - - -;;;;; first-change-hook - -(defun sly-first-change-hook () - "Notify Lisp that a source file's buffer has been modified." - ;; Be careful not to disturb anything! - ;; In particular if we muck up the match-data then query-replace - ;; breaks. -luke (26/Jul/2004) - (save-excursion - (save-match-data - (when (and (buffer-file-name) - (file-exists-p (buffer-file-name)) - (sly-background-activities-enabled-p)) - (let ((filename (sly-to-lisp-filename (buffer-file-name)))) - (sly-eval-async `(slynk:buffer-first-change ,filename))))))) - -(defun sly-setup-first-change-hook () - (add-hook 'first-change-hook #'sly-first-change-hook nil t)) - -(add-hook 'sly-mode-hook 'sly-setup-first-change-hook) - - -;;;; Eval for Lisp - -(defun sly-eval-for-lisp (thread tag form-string) - (let ((ok nil) - (value nil) - (error nil) - (c (sly-connection))) - (unwind-protect - (condition-case err - (progn - (sly-check-eval-in-emacs-enabled) - (setq value (eval (read form-string) t)) - (sly-check-eval-in-emacs-result value) - (setq ok t)) - ((debug error) - (setq error err))) - (let ((result (cond (ok `(:ok ,value)) - (error `(:error ,(symbol-name (car error)) - . ,(mapcar #'prin1-to-string - (cdr error)))) - (t `(:abort))))) - (sly-dispatch-event `(:emacs-return ,thread ,tag ,result) c))))) - -(defun sly-check-eval-in-emacs-result (x) - "Raise an error if X can't be marshaled." - (or (stringp x) - (memq x '(nil t)) - (integerp x) - (keywordp x) - (and (consp x) - (let ((l x)) - (while (consp l) - (sly-check-eval-in-emacs-result (car x)) - (setq l (cdr l))) - (sly-check-eval-in-emacs-result l))) - (error "Non-serializable return value: %S" x))) - -(defun sly-check-eval-in-emacs-enabled () - "Raise an error if `sly-enable-evaluate-in-emacs' isn't true." - (unless sly-enable-evaluate-in-emacs - (error (concat "sly-eval-in-emacs disabled for security." - "Set sly-enable-evaluate-in-emacs true to enable it.")))) - - -;;;; `ED' - -(defvar sly-ed-frame nil - "The frame used by `sly-ed'.") - -(defcustom sly-ed-use-dedicated-frame nil - "*When non-nil, `sly-ed' will create and reuse a dedicated frame." - :type 'boolean - :group 'sly-mode) - -(cl-defun sly-ed (what ) - "Edit WHAT. - -WHAT can be: - A filename (string), - A list (:filename FILENAME &key LINE COLUMN POSITION), - A function name (:function-name STRING) - nil. - -This is for use in the implementation of COMMON-LISP:ED." - (when sly-ed-use-dedicated-frame - (unless (and sly-ed-frame (frame-live-p sly-ed-frame)) - (setq sly-ed-frame (make-frame))) - (select-frame sly-ed-frame)) - (raise-frame) - (when what - (sly-dcase what - ((:filename file &key line column position bytep) - (find-file (sly-from-lisp-filename file)) - (when line (sly-goto-line line)) - (when column (move-to-column column)) - (when position - (goto-char (if bytep - (byte-to-position position) - position)))) - ((:function-name name) - (sly-edit-definition name))))) - -(defun sly-goto-line (line-number) - "Move to line LINE-NUMBER (1-based). -This is similar to `goto-line' but without pushing the mark and -the display stuff that we neither need nor want." - (cl-assert (= (buffer-size) (- (point-max) (point-min))) () - "sly-goto-line in narrowed buffer") - (goto-char (point-min)) - (forward-line (1- line-number))) - -(defun sly-remote-y-or-n-p (thread tag question) - (sly-dispatch-event `(:emacs-return ,thread ,tag ,(sly-y-or-n-p question)))) - -(defun sly-read-from-minibuffer-for-slynk (thread tag prompt initial-value) - (let ((answer (condition-case nil - (sly-read-from-minibuffer prompt initial-value t) - (quit nil)))) - (sly-dispatch-event `(:emacs-return ,thread ,tag ,answer)))) - -;;;; Interactive evaluation. - -(defun sly-interactive-eval (string) - "Read and evaluate STRING and print value in minibuffer. - -A prefix argument(`C-u') inserts the result into the current -buffer. A negative prefix argument (`M--') will sends it to the -kill ring." - (interactive (list (sly-read-from-minibuffer "SLY Eval: "))) - (cl-case current-prefix-arg - ((nil) - (sly-eval-with-transcript `(slynk:interactive-eval ,string))) - ((-) - (sly-eval-save string)) - (t - (sly-eval-print string)))) - -(defvar sly-transcript-start-hook nil - "Hook run before start an evalution.") -(defvar sly-transcript-stop-hook nil - "Hook run after finishing a evalution.") - -(defun sly-display-eval-result (value) - ;; Use `message', not `sly-message' - (with-temp-buffer - (insert value) - (goto-char (point-min)) - (end-of-line 1) - (if (or (< (1+ (point)) (point-max)) - (>= (- (point) (point-min)) (frame-width))) - (sly-show-description value (sly-current-package)) - (message "=> %s" value)))) - -(defun sly-eval-with-transcript (form) - "Eval FORM in Lisp. Display output, if any." - (run-hooks 'sly-transcript-start-hook) - (sly-rex () (form) - ((:ok value) - (run-hooks 'sly-transcript-stop-hook) - (sly-display-eval-result value)) - ((:abort condition) - (run-hooks 'sly-transcript-stop-hook) - (sly-message "Evaluation aborted on %s." condition)))) - -(defun sly-eval-print (string) - "Eval STRING in Lisp; insert any output and the result at point." - (sly-eval-async `(slynk:eval-and-grab-output ,string) - (lambda (result) - (cl-destructuring-bind (output value) result - (push-mark) - (let* ((start (point)) - (ppss (syntax-ppss)) - (string-or-comment-p (or (nth 3 ppss) (nth 4 ppss)))) - (insert output (if string-or-comment-p - "" - " => ") value) - (unless string-or-comment-p - (comment-region start (point) 1))))))) - -(defun sly-eval-save (string) - "Evaluate STRING in Lisp and save the result in the kill ring." - (sly-eval-async `(slynk:eval-and-grab-output ,string) - (lambda (result) - (cl-destructuring-bind (output value) result - (let ((string (concat output value))) - (kill-new string) - (sly-message "Evaluation finished; pushed result to kill ring.")))))) - -(defun sly-eval-describe (form) - "Evaluate FORM in Lisp and display the result in a new buffer." - (sly-eval-async form (sly-rcurry #'sly-show-description - (sly-current-package)))) - -(defvar sly-description-autofocus nil - "If non-nil select description windows on display.") - -(defun sly-show-description (string package) - ;; So we can have one description buffer open per connection. Useful - ;; for comparing the output of DISASSEMBLE across implementations. - ;; FIXME: could easily be achieved with M-x rename-buffer - (let ((bufname (sly-buffer-name :description))) - (sly-with-popup-buffer (bufname :package package - :connection t - :select sly-description-autofocus - :mode 'lisp-mode) - (sly-popup-buffer-mode) - (princ string) - (goto-char (point-min))))) - -(defun sly-last-expression () - (buffer-substring-no-properties - (save-excursion (backward-sexp) (point)) - (point))) - -(defun sly-eval-last-expression () - "Evaluate the expression preceding point." - (interactive) - (sly-interactive-eval (sly-last-expression))) - -(defun sly-eval-defun () - "Evaluate the current toplevel form. -Use `sly-re-evaluate-defvar' if the from starts with '(defvar'" - (interactive) - (let ((form (apply #'buffer-substring-no-properties - (sly-region-for-defun-at-point)))) - (cond ((string-match "^(defvar " form) - (sly-re-evaluate-defvar form)) - (t - (sly-interactive-eval form))))) - -(defun sly-eval-region (start end) - "Evaluate region." - (interactive "r") - (sly-eval-with-transcript - `(slynk:interactive-eval-region - ,(buffer-substring-no-properties start end)))) - -(defun sly-pprint-eval-region (start end) - "Evaluate region; pprint the value in a buffer." - (interactive "r") - (sly-eval-describe - `(slynk:pprint-eval - ,(buffer-substring-no-properties start end)))) - -(defun sly-eval-buffer () - "Evaluate the current buffer. -The value is printed in the echo area." - (interactive) - (sly-eval-region (point-min) (point-max))) - -(defun sly-re-evaluate-defvar (form) - "Force the re-evaluaton of the defvar form before point. - -First make the variable unbound, then evaluate the entire form." - (interactive (list (sly-last-expression))) - (sly-eval-with-transcript `(slynk:re-evaluate-defvar ,form))) - -(defun sly-pprint-eval-last-expression () - "Evaluate the form before point; pprint the value in a buffer." - (interactive) - (sly-eval-describe `(slynk:pprint-eval ,(sly-last-expression)))) - -(defun sly-eval-print-last-expression (string) - "Evaluate sexp before point; print value into the current buffer" - (interactive (list (sly-last-expression))) - (insert "\n") - (sly-eval-print string)) - -;;;; Edit Lisp value -;;; -(defun sly-edit-value (form-string) - "\\<sly-edit-value-mode-map>\ -Edit the value of a setf'able form in a new buffer. -The value is inserted into a temporary buffer for editing and then set -in Lisp when committed with \\[sly-edit-value-commit]." - (interactive - (list (sly-read-from-minibuffer "Edit value (evaluated): " - (sly-sexp-at-point)))) - (sly-eval-async `(slynk:value-for-editing ,form-string) - (let ((form-string form-string) - (package (sly-current-package))) - (lambda (result) - (sly-edit-value-callback form-string result - package))))) - -(make-variable-buffer-local - (defvar sly-edit-form-string nil - "The form being edited by `sly-edit-value'.")) - -(define-minor-mode sly-edit-value-mode - "Mode for editing a Lisp value." - nil - " Edit-Value" - '(("\C-c\C-c" . sly-edit-value-commit))) - -(defun sly-edit-value-callback (form-string current-value package) - (let* ((name (generate-new-buffer-name (format "*Edit %s*" form-string))) - (buffer (sly-with-popup-buffer (name :package package - :connection t - :select t - :mode 'lisp-mode) - (sly-mode 1) - (sly-edit-value-mode 1) - (setq sly-edit-form-string form-string) - (insert current-value) - (current-buffer)))) - (with-current-buffer buffer - (setq buffer-read-only nil) - (sly-message "Type C-c C-c when done")))) - -(defun sly-edit-value-commit () - "Commit the edited value to the Lisp image. -\\(See `sly-edit-value'.)" - (interactive) - (if (null sly-edit-form-string) - (error "Not editing a value.") - (let ((value (buffer-substring-no-properties (point-min) (point-max)))) - (let ((buffer (current-buffer))) - (sly-eval-async `(slynk:commit-edited-value ,sly-edit-form-string - ,value) - (lambda (_) - (with-current-buffer buffer - (quit-window t)))))))) - -;;;; Tracing - -(defun sly-untrace-all () - "Untrace all functions." - (interactive) - (sly-eval `(slynk:untrace-all))) - -(defun sly-toggle-trace-fdefinition (spec) - "Toggle trace." - (interactive (list (sly-read-from-minibuffer - "(Un)trace: " (sly-symbol-at-point)))) - (sly-message "%s" (sly-eval `(slynk:slynk-toggle-trace ,spec)))) - - - -(defun sly-disassemble-symbol (symbol-name) - "Display the disassembly for SYMBOL-NAME." - (interactive (list (sly-read-symbol-name "Disassemble: "))) - (sly-eval-describe `(slynk:disassemble-form ,(concat "'" symbol-name)))) - -(defun sly-undefine-function (symbol-name) - "Unbind the function slot of SYMBOL-NAME." - (interactive (list (sly-read-symbol-name "fmakunbound: " t))) - (sly-eval-async `(slynk:undefine-function ,symbol-name) - (lambda (result) (sly-message "%s" result)))) - -(defun sly-unintern-symbol (symbol-name package) - "Unintern the symbol given with SYMBOL-NAME PACKAGE." - (interactive (list (sly-read-symbol-name "Unintern symbol: " t) - (sly-read-package-name "from package: " - (sly-current-package)))) - (sly-eval-async `(slynk:unintern-symbol ,symbol-name ,package) - (lambda (result) (sly-message "%s" result)))) - -(defun sly-delete-package (package-name) - "Delete the package with name PACKAGE-NAME." - (interactive (list (sly-read-package-name "Delete package: " - (sly-current-package)))) - (sly-eval-async `(cl:delete-package - (slynk::guess-package ,package-name)))) - -(defun sly-load-file (filename) - "Load the Lisp file FILENAME." - (interactive (list - (read-file-name "[sly] Load file: " nil nil - nil (if (buffer-file-name) - (file-name-nondirectory - (buffer-file-name)))))) - (let ((lisp-filename (sly-to-lisp-filename (expand-file-name filename)))) - (sly-eval-with-transcript `(slynk:load-file ,lisp-filename)))) - -(defvar sly-change-directory-hooks nil - "Hook run by `sly-change-directory'. -The functions are called with the new (absolute) directory.") - -(defun sly-change-directory (directory) - "Make DIRECTORY become Lisp's current directory. -Return whatever slynk:set-default-directory returns." - (let ((dir (expand-file-name directory))) - (prog1 (sly-eval `(slynk:set-default-directory - (slynk-backend:filename-to-pathname - ,(sly-to-lisp-filename dir)))) - (sly-with-connection-buffer nil (cd-absolute dir)) - (run-hook-with-args 'sly-change-directory-hooks dir)))) - -(defun sly-cd (directory) - "Make DIRECTORY become Lisp's current directory. -Return whatever slynk:set-default-directory returns." - (interactive (list (read-directory-name "[sly] Directory: " nil nil t))) - (sly-message "default-directory: %s" (sly-change-directory directory))) - -(defun sly-pwd () - "Show Lisp's default directory." - (interactive) - (sly-message "Directory %s" (sly-eval `(slynk:default-directory)))) - - -;;;; Documentation - -(defvar sly-documentation-lookup-function - 'sly-hyperspec-lookup) - -(defun sly-documentation-lookup () - "Generalized documentation lookup. Defaults to hyperspec lookup." - (interactive) - (call-interactively sly-documentation-lookup-function)) - -;;;###autoload -(defun sly-hyperspec-lookup (symbol-name) - "A wrapper for `hyperspec-lookup'" - (interactive (list (common-lisp-hyperspec-read-symbol-name - (sly-symbol-at-point)))) - (hyperspec-lookup symbol-name)) - -(defun sly-describe-symbol (symbol-name) - "Describe the symbol at point." - (interactive (list (sly-read-symbol-name "Describe symbol: "))) - (when (not symbol-name) - (error "No symbol given")) - (sly-eval-describe `(slynk:describe-symbol ,symbol-name))) - -(defun sly-documentation (symbol-name) - "Display function- or symbol-documentation for SYMBOL-NAME." - (interactive (list (sly-read-symbol-name "Documentation for symbol: "))) - (when (not symbol-name) - (error "No symbol given")) - (sly-eval-describe - `(slynk:documentation-symbol ,symbol-name))) - -(defun sly-describe-function (symbol-name) - (interactive (list (sly-read-symbol-name "Describe symbol's function: "))) - (when (not symbol-name) - (error "No symbol given")) - (sly-eval-describe `(slynk:describe-function ,symbol-name))) - -(defface sly-apropos-symbol - '((t (:inherit sly-part-button-face))) - "Face for the symbol name in Apropos output." - :group 'sly) - -(defface sly-apropos-label - '((t (:inherit italic))) - "Face for label (`Function', `Variable' ...) in Apropos output." - :group 'sly) - -(defun sly-apropos-summary (string case-sensitive-p package only-external-p) - "Return a short description for the performed apropos search." - (concat (if case-sensitive-p "Case-sensitive " "") - "Apropos for " - (format "%S" string) - (if package (format " in package %S" package) "") - (if only-external-p " (external symbols only)" ""))) - -(defun sly-apropos (string &optional only-external-p package - case-sensitive-p) - "Show all bound symbols whose names match STRING. With prefix -arg, you're interactively asked for parameters of the search. -With M-- (negative) prefix arg, prompt for package only. " - (interactive - (cond ((eq '- current-prefix-arg) - (list (sly-read-from-minibuffer "Apropos external symbols: ") - t - (sly-read-package-name "Package (blank for all): " - nil 'allow-blank) - nil)) - (current-prefix-arg - (list (sly-read-from-minibuffer "Apropos: ") - (sly-y-or-n-p "External symbols only? ") - (sly-read-package-name "Package (blank for all): " - nil 'allow-blank) - (sly-y-or-n-p "Case-sensitive? "))) - (t - (list (sly-read-from-minibuffer "Apropos external symbols: ") t nil nil)))) - (sly-eval-async - `(slynk-apropos:apropos-list-for-emacs ,string ,only-external-p - ,case-sensitive-p ',package) - (sly-rcurry #'sly-show-apropos string package - (sly-apropos-summary string case-sensitive-p - package only-external-p)))) - -(defun sly-apropos-all () - "Shortcut for (sly-apropos <string> nil nil)" - (interactive) - (sly-apropos (sly-read-from-minibuffer "Apropos all symbols: ") nil nil)) - -(defun sly-apropos-package (package &optional internal) - "Show apropos listing for symbols in PACKAGE. -With prefix argument include internal symbols." - (interactive (list (let ((pkg (sly-read-package-name "Package: "))) - (if (string= pkg "") (sly-current-package) pkg)) - current-prefix-arg)) - (sly-apropos "" (not internal) package)) - -(defvar sly-apropos-mode-map - (let ((map (make-sparse-keymap))) - map)) - -(define-derived-mode sly-apropos-mode apropos-mode "SLY-Apropos" - "SLY Apropos Mode - -TODO" - (sly-mode)) - -(defun sly-show-apropos (plists string package summary) - (cond ((null plists) - (sly-message "No apropos matches for %S" string)) - (t - (sly-with-popup-buffer ((sly-buffer-name :apropos - :connection t) - :package package :connection t - :mode 'sly-apropos-mode) - (if (boundp 'header-line-format) - (setq header-line-format summary) - (insert summary "\n\n")) - (sly-set-truncate-lines) - (sly-print-apropos plists (not package)) - (set-syntax-table lisp-mode-syntax-table) - (goto-char (point-min)))))) - -(define-button-type 'sly-apropos-symbol :supertype 'sly-part - 'face nil - 'action 'sly-button-goto-source ;default action - 'sly-button-inspect - #'(lambda (name _type) - (sly-inspect (format "(quote %s)" name))) - 'sly-button-goto-source - #'(lambda (name _type) - (sly-edit-definition name 'window)) - 'sly-button-describe - #'(lambda (name _type) - (sly-eval-describe `(slynk:describe-symbol ,name)))) - -(defun sly--package-designator-prefix (designator) - (unless (listp designator) - (error "unknown designator type")) - (concat (cadr designator) - (if (cl-caddr designator) ":" "::"))) - -(defun sly-apropos-designator-string (designator) - (concat (sly--package-designator-prefix designator) - (car designator))) - -(defun sly-apropos-insert-symbol (designator item bounds package-designator-searched-p) - (let ((label (sly-apropos-designator-string designator))) - (setq label - (sly--make-text-button label nil - 'face 'sly-apropos-symbol - 'part-args (list item nil) - 'part-label "Symbol" - :type 'sly-apropos-symbol)) - (cl-loop - with offset = (if package-designator-searched-p - 0 - (length (sly--package-designator-prefix designator))) - for bound in bounds - for (start end) = (if (listp bound) bound (list bound (1+ bound))) - do - (put-text-property (+ start offset) (+ end offset) 'face 'highlight label) - finally (insert label)))) - -(defun sly-print-apropos (plists package-designator-searched-p) - (cl-loop - for plist in plists - for designator = (plist-get plist :designator) - for item = (substring-no-properties - (sly-apropos-designator-string designator)) - do - (sly-apropos-insert-symbol designator item (plist-get plist :bounds) package-designator-searched-p) - (terpri) - (cl-loop for (prop value) on plist by #'cddr - for start = (point) - unless (memq prop '(:designator - :package - :bounds)) - do - (let ((namespace (upcase-initials - (replace-regexp-in-string - "-" " " (substring (symbol-name prop) 1))))) - (princ " ") - (insert (propertize namespace - 'face 'sly-apropos-label)) - (princ ": ") - (princ (cond ((and value - (not (eq value :not-documented))) - value) - (t - "(not documented)"))) - (add-text-properties - start (point) - (list 'action 'sly-button-describe - 'sly-button-describe - #'(lambda (name type) - (sly-eval-describe `(slynk:describe-definition-for-emacs ,name - ,type))) - 'part-args (list item prop) - 'button t 'apropos-label namespace)) - (terpri))))) - -(defun sly-apropos-describe (name type) - (sly-eval-describe `(slynk:describe-definition-for-emacs ,name ,type))) - -(require 'info) -(defun sly-info--file () - (or (cl-some (lambda (subdir) - (cl-flet ((existing-file - (name) (let* ((path (expand-file-name subdir sly-path)) - (probe (expand-file-name name path))) - (and (file-exists-p probe) probe)))) - (or (existing-file "sly.info") - (existing-file "sly.info.gz")))) - (append '("doc" ".") Info-directory-list)) - (sly-error - "No sly.info, run `make -C doc sly.info' from a SLY git checkout"))) - -(require 'info) - -(defvar sly-info--cached-node-names nil) - -(defun sly-info--node-names (file) - (or sly-info--cached-node-names - (setq sly-info--cached-node-names - (with-temp-buffer - (info file (current-buffer)) - (ignore-errors - (Info-build-node-completions)))))) - -;;;###autoload -(defun sly-info (file &optional node) - "Read SLY manual" - (interactive - (let ((file (sly-info--file))) - (list file - (completing-read "Manual node? (`Top' to read the whole manual): " - (remove '("*") (sly-info--node-names file)) - nil t)))) - (info (if node (format "(%s)%s" file node) file))) - - -;;;; XREF: cross-referencing - -(defvar sly-xref-mode-map - (let ((map (make-sparse-keymap))) - (define-key map (kbd "RET") 'sly-xref-goto) - (define-key map (kbd "SPC") 'sly-xref-show) - (define-key map (kbd "n") 'sly-xref-next-line) - (define-key map (kbd "p") 'sly-xref-prev-line) - (define-key map (kbd ".") 'sly-xref-next-line) - (define-key map (kbd ",") 'sly-xref-prev-line) - (define-key map (kbd "C-c C-c") 'sly-recompile-xref) - (define-key map (kbd "C-c C-k") 'sly-recompile-all-xrefs) - - (define-key map (kbd "q") 'quit-window) - (set-keymap-parent map button-buffer-map) - - map)) - -(define-derived-mode sly-xref-mode lisp-mode "Xref" - "sly-xref-mode: Major mode for cross-referencing. -\\<sly-xref-mode-map>\ -The most important commands: -\\[sly-xref-show] - Display referenced source and keep xref window. -\\[sly-xref-goto] - Jump to referenced source and dismiss xref window. - -\\{sly-xref-mode-map}" - (setq font-lock-defaults nil) - (setq delayed-mode-hooks nil) - (setq buffer-read-only t) - (sly-mode)) - -(defun sly-next-line/not-add-newlines () - (interactive) - (let ((next-line-add-newlines nil)) - (forward-line 1))) - - -;;;;; XREF results buffer and window management - -(cl-defmacro sly-with-xref-buffer ((_xref-type _symbol &optional package) - &body body) - "Execute BODY in a xref buffer, then show that buffer." - (declare (indent 1)) - `(sly-with-popup-buffer ((sly-buffer-name :xref - :connection t) - :package ,package - :connection t - :select t - :mode 'sly-xref-mode) - (sly-set-truncate-lines) - ,@body)) - -;; TODO: Have this button support more options, not just "show source" -;; and "goto-source" -(define-button-type 'sly-xref :supertype 'sly-part - 'action 'sly-button-goto-source ;default action - 'mouse-action 'sly-button-goto-source ;default action - 'sly-button-show-source #'(lambda (location) - (sly-xref--show-location location)) - 'sly-button-goto-source #'(lambda (location) - (sly--pop-to-source-location location 'sly-xref))) - -(defun sly-xref-button (label location) - (sly--make-text-button label nil - :type 'sly-xref - 'part-args (list location) - 'part-label "Location")) - -(defun sly-insert-xrefs (xref-alist) - "Insert XREF-ALIST in the current-buffer. -XREF-ALIST is of the form ((GROUP . ((LABEL LOCATION) ...)) ...). -GROUP and LABEL are for decoration purposes. LOCATION is a -source-location." - (cl-loop for (group . refs) in xref-alist do - (sly-insert-propertized '(face bold) group "\n") - (cl-loop for (label location) in refs - for start = (point) - do - (insert - " " - (sly-xref-button (sly-one-line-ify label) location) - "\n") - (add-text-properties start (point) (list 'sly-location location)))) - ;; Remove the final newline to prevent accidental window-scrolling - (backward-delete-char 1)) - -(defun sly-xref-next-line (arg) - (interactive "p") - (let ((button (forward-button arg))) - (when button (sly-button-show-source button)))) - -(defun sly-xref-prev-line (arg) - (interactive "p") - (sly-xref-next-line (- arg))) - -(defun sly-xref--show-location (loc) - (cl-ecase (car loc) - (:location (sly--display-source-location loc)) - (:error (sly-message "%s" (cadr loc))) - ((nil)))) - -(defun sly-xref--show-results (xrefs _type symbol package &optional method) - "Maybe show a buffer listing the cross references XREFS. -METHOD is used to set `sly-xref--popup-method', which see." - (cond ((null xrefs) - (sly-message "No references found for %s." symbol) - nil) - (t - (sly-with-xref-buffer (_type _symbol package) - (sly-insert-xrefs xrefs) - (setq sly-xref--popup-method method) - (goto-char (point-min)) - (current-buffer))))) - - -;;;;; XREF commands - -(defun sly-who-calls (symbol) - "Show all known callers of the function SYMBOL. -This is implemented with special compiler support, see `sly-list-callers' for a -portable alternative." - (interactive (list (sly-read-symbol-name "Who calls: " t))) - (sly-xref :calls symbol)) - -(defun sly-calls-who (symbol) - "Show all known functions called by the function SYMBOL. -This is implemented with special compiler support and may not be supported by -all implementations. -See `sly-list-callees' for a portable alternative." - (interactive (list (sly-read-symbol-name "Who calls: " t))) - (sly-xref :calls-who symbol)) - -(defun sly-who-references (symbol) - "Show all known referrers of the global variable SYMBOL." - (interactive (list (sly-read-symbol-name "Who references: " t))) - (sly-xref :references symbol)) - -(defun sly-who-binds (symbol) - "Show all known binders of the global variable SYMBOL." - (interactive (list (sly-read-symbol-name "Who binds: " t))) - (sly-xref :binds symbol)) - -(defun sly-who-sets (symbol) - "Show all known setters of the global variable SYMBOL." - (interactive (list (sly-read-symbol-name "Who sets: " t))) - (sly-xref :sets symbol)) - -(defun sly-who-macroexpands (symbol) - "Show all known expanders of the macro SYMBOL." - (interactive (list (sly-read-symbol-name "Who macroexpands: " t))) - (sly-xref :macroexpands symbol)) - -(defun sly-who-specializes (symbol) - "Show all known methods specialized on class SYMBOL." - (interactive (list (sly-read-symbol-name "Who specializes: " t))) - (sly-xref :specializes symbol)) - -(defun sly-list-callers (symbol-name) - "List the callers of SYMBOL-NAME in a xref window. -See `sly-who-calls' for an implementation-specific alternative." - (interactive (list (sly-read-symbol-name "List callers: "))) - (sly-xref :callers symbol-name)) - -(defun sly-list-callees (symbol-name) - "List the callees of SYMBOL-NAME in a xref window. -See `sly-calls-who' for an implementation-specific alternative." - (interactive (list (sly-read-symbol-name "List callees: "))) - (sly-xref :callees symbol-name)) - -(defun sly-xref (type symbol &optional continuation) - "Make an XREF request to Lisp." - (sly-eval-async - `(slynk:xref ',type ',symbol) - (sly-rcurry (lambda (result type symbol package cont) - (and (sly-xref-implemented-p type result) - (let* ((file-alist (cadr (sly-analyze-xrefs result)))) - (funcall (or cont 'sly-xref--show-results) - file-alist type symbol package)))) - type - symbol - (sly-current-package) - continuation))) - -(defun sly-xref-implemented-p (type xrefs) - "Tell if xref TYPE is available according to XREFS." - (cond ((eq xrefs :not-implemented) - (sly-display-oneliner "%s is not implemented yet on %s." - (sly-xref-type type) - (sly-lisp-implementation-name)) - nil) - (t t))) - -(defun sly-xref-type (type) - "Return a human readable version of xref TYPE." - (format "who-%s" (sly-cl-symbol-name type))) - -(defun sly-xref--get-xrefs (types symbol &optional continuation) - "Make multiple XREF requests at once." - (sly-eval-async - `(slynk:xrefs ',types ',symbol) - #'(lambda (result) - (funcall (or continuation - #'sly-xref--show-results) - (cl-loop for (key . val) in result - collect (cons (sly-xref-type key) val)) - types symbol (sly-current-package))))) - - -;;;;; XREF navigation - -(defun sly-xref-location-at-point () - (save-excursion - ;; When the end of the last line is at (point-max) we can't find - ;; the text property there. Going to bol avoids this problem. - (beginning-of-line 1) - (or (get-text-property (point) 'sly-location) - (error "No reference at point.")))) - -(defun sly-xref-dspec-at-point () - (save-excursion - (beginning-of-line 1) - (with-syntax-table lisp-mode-syntax-table - (forward-sexp) ; skip initial whitespaces - (backward-sexp) - (sly-sexp-at-point)))) - -(defun sly-all-xrefs () - (let ((xrefs nil)) - (save-excursion - (goto-char (point-min)) - (while (zerop (forward-line 1)) - (sly--when-let (loc (get-text-property (point) 'sly-location)) - (let* ((dspec (sly-xref-dspec-at-point)) - (xref (make-sly-xref :dspec dspec :location loc))) - (push xref xrefs))))) - (nreverse xrefs))) - -(defun sly-xref-goto () - "Goto the cross-referenced location at point." - (interactive) - (sly--pop-to-source-location (sly-xref-location-at-point) 'sly-xref)) - -(defun sly-xref-show () - "Display the xref at point in the other window." - (interactive) - (sly--display-source-location (sly-xref-location-at-point))) - -(defun sly-search-property (prop &optional backward prop-value-fn) - "Search the next text range where PROP is non-nil. -Return the value of PROP. -If BACKWARD is non-nil, search backward. -If PROP-VALUE-FN is non-nil use it to extract PROP's value." - (let ((next-candidate (if backward - #'previous-single-char-property-change - #'next-single-char-property-change)) - (prop-value-fn (or prop-value-fn - (lambda () - (get-text-property (point) prop)))) - (start (point)) - (prop-value)) - (while (progn - (goto-char (funcall next-candidate (point) prop)) - (not (or (setq prop-value (funcall prop-value-fn)) - (eobp) - (bobp))))) - (cond (prop-value) - (t (goto-char start) nil)))) - -(defun sly-recompile-xref (&optional raw-prefix-arg) - "Recompile definition at point. -Uses prefix arguments like `sly-compile-defun'." - (interactive "P") - (let ((sly-compilation-policy (sly-compute-policy raw-prefix-arg))) - (let ((location (sly-xref-location-at-point)) - (dspec (sly-xref-dspec-at-point))) - (sly-recompile-locations - (list location) - (sly-rcurry #'sly-xref-recompilation-cont - (list dspec) (current-buffer)))))) - -(defun sly-recompile-all-xrefs (&optional raw-prefix-arg) - "Recompile all definitions. -Uses prefix arguments like `sly-compile-defun'." - (interactive "P") - (let ((sly-compilation-policy (sly-compute-policy raw-prefix-arg))) - (let ((dspecs) (locations)) - (dolist (xref (sly-all-xrefs)) - (when (sly-xref-has-location-p xref) - (push (sly-xref.dspec xref) dspecs) - (push (sly-xref.location xref) locations))) - (sly-recompile-locations - locations - (sly-rcurry #'sly-xref-recompilation-cont - dspecs (current-buffer)))))) - -(defun sly-xref-recompilation-cont (results dspecs buffer) - ;; Extreme long-windedness to insert status of recompilation; - ;; sometimes Elisp resembles more of an Ewwlisp. - - ;; FIXME: Should probably throw out the whole recompilation cruft - ;; anyway. -- helmut - ;; TODO: next iteration of fixme cleanup this is going in a contrib -- jt - (with-current-buffer buffer - (sly-compilation-finished (sly-aggregate-compilation-results results) - nil) - (save-excursion - (sly-xref-insert-recompilation-flags - dspecs (cl-loop for r in results collect - (or (sly-compilation-result.successp r) - (and (sly-compilation-result.notes r) - :complained))))))) - -(defun sly-aggregate-compilation-results (results) - `(:compilation-result - ,(cl-reduce #'append (mapcar #'sly-compilation-result.notes results)) - ,(cl-every #'sly-compilation-result.successp results) - ,(cl-reduce #'+ (mapcar #'sly-compilation-result.duration results)))) - -(defun sly-xref-insert-recompilation-flags (dspecs compilation-results) - (let* ((buffer-read-only nil) - (max-column (sly-column-max))) - (goto-char (point-min)) - (cl-loop for dspec in dspecs - for result in compilation-results - do (save-excursion - (cl-loop for dspec2 = (progn (search-forward dspec) - (sly-xref-dspec-at-point)) - until (equal dspec2 dspec)) - (end-of-line) ; skip old status information. - (insert-char ?\ (1+ (- max-column (current-column)))) - (insert (format "[%s]" - (cl-case result - ((t) :success) - ((nil) :failure) - (t result)))))))) - - -;;;; Macroexpansion - -(defvar sly-macroexpansion-minor-mode-map - (let ((map (make-sparse-keymap))) - (define-key map (kbd "g") 'sly-macroexpand-again) - (define-key map (kbd "a") 'sly-macroexpand-all-inplace) - (define-key map (kbd "q") 'quit-window) - (define-key map [remap sly-macroexpand-1] 'sly-macroexpand-1-inplace) - (define-key map [remap sly-macroexpand-all] 'sly-macroexpand-all-inplace) - (define-key map [remap sly-compiler-macroexpand-1] 'sly-compiler-macroexpand-1-inplace) - (define-key map [remap sly-expand-1] 'sly-expand-1-inplace) - (define-key map [remap undo] 'sly-macroexpand-undo) - map)) - -(define-minor-mode sly-macroexpansion-minor-mode - "SLY mode for macroexpansion" - nil - " Macroexpand" - nil - (read-only-mode 1)) - -(defun sly-macroexpand-undo (&optional arg) - (interactive) - ;; Emacs 22.x introduced `undo-only' which - ;; works by binding `undo-no-redo' to t. We do - ;; it this way so we don't break prior Emacs - ;; versions. - (cl-macrolet ((undo-only (arg) `(let ((undo-no-redo t)) (undo ,arg)))) - (let ((inhibit-read-only t)) - (when (fboundp 'sly-remove-edits) - (sly-remove-edits (point-min) (point-max))) - (undo-only arg)))) - -(defvar sly-eval-macroexpand-expression nil - "Specifies the last macroexpansion preformed. -This variable specifies both what was expanded and how.") - -(defun sly-eval-macroexpand (expander &optional string) - (let ((string (or string - (sly-sexp-at-point 'interactive)))) - (setq sly-eval-macroexpand-expression `(,expander ,string)) - (sly-eval-async sly-eval-macroexpand-expression - #'sly-initialize-macroexpansion-buffer))) - -(defun sly-macroexpand-again () - "Reperform the last macroexpansion." - (interactive) - (sly-eval-async sly-eval-macroexpand-expression - (sly-rcurry #'sly-initialize-macroexpansion-buffer - (current-buffer)))) - -(defun sly-initialize-macroexpansion-buffer (expansion &optional buffer) - (pop-to-buffer (or buffer (sly-create-macroexpansion-buffer))) - (setq buffer-undo-list nil) ; Get rid of undo information from - ; previous expansions. - (let ((inhibit-read-only t) - (buffer-undo-list t)) ; Make the initial insertion not be undoable. - (erase-buffer) - (insert expansion) - (goto-char (point-min)) - (if (fboundp 'font-lock-ensure) - (font-lock-ensure) - (with-no-warnings (font-lock-fontify-buffer))))) - -(defun sly-create-macroexpansion-buffer () - (let ((name (sly-buffer-name :macroexpansion))) - (sly-with-popup-buffer (name :package t :connection t - :mode 'lisp-mode) - (sly-macroexpansion-minor-mode 1) - (setq font-lock-keywords-case-fold-search t) - (current-buffer)))) - -(defun sly-eval-macroexpand-inplace (expander) - "Substitute the sexp at point with its macroexpansion. - -NB: Does not affect sly-eval-macroexpand-expression" - (interactive) - (let* ((bounds (sly-bounds-of-sexp-at-point 'interactive))) - (let* ((start (copy-marker (car bounds))) - (end (copy-marker (cdr bounds))) - (point (point)) - (buffer (current-buffer))) - (sly-eval-async - `(,expander ,(buffer-substring-no-properties start end)) - (lambda (expansion) - (with-current-buffer buffer - (let ((buffer-read-only nil)) - (when (fboundp 'sly-remove-edits) - (sly-remove-edits (point-min) (point-max))) - (goto-char start) - (delete-region start end) - (sly-insert-indented expansion) - (goto-char point)))))))) - -(defun sly-macroexpand-1 (&optional repeatedly) - "Display the macro expansion of the form at point. -The form is expanded with CL:MACROEXPAND-1 or, if a prefix -argument is given, with CL:MACROEXPAND." - (interactive "P") - (sly-eval-macroexpand - (if repeatedly 'slynk:slynk-macroexpand 'slynk:slynk-macroexpand-1))) - -(defun sly-macroexpand-1-inplace (&optional repeatedly) - (interactive "P") - (sly-eval-macroexpand-inplace - (if repeatedly 'slynk:slynk-macroexpand 'slynk:slynk-macroexpand-1))) - -(defun sly-macroexpand-all (&optional just-one) - "Display the recursively macro expanded sexp at point. -With optional JUST-ONE prefix arg, use CL:MACROEXPAND-1." - (interactive "P") - (sly-eval-macroexpand (if just-one - 'slynk:slynk-macroexpand-1 - 'slynk:slynk-macroexpand-all))) - -(defun sly-macroexpand-all-inplace () - "Display the recursively macro expanded sexp at point." - (interactive) - (sly-eval-macroexpand-inplace 'slynk:slynk-macroexpand-all)) - -(defun sly-compiler-macroexpand-1 (&optional repeatedly) - "Display the compiler-macro expansion of sexp at point." - (interactive "P") - (sly-eval-macroexpand - (if repeatedly - 'slynk:slynk-compiler-macroexpand - 'slynk:slynk-compiler-macroexpand-1))) - -(defun sly-compiler-macroexpand-1-inplace (&optional repeatedly) - "Display the compiler-macro expansion of sexp at point." - (interactive "P") - (sly-eval-macroexpand-inplace - (if repeatedly - 'slynk:slynk-compiler-macroexpand - 'slynk:slynk-compiler-macroexpand-1))) - -(defun sly-expand-1 (&optional repeatedly) - "Display the macro expansion of the form at point. - -The form is expanded with CL:MACROEXPAND-1 or, if a prefix -argument is given, with CL:MACROEXPAND. - -Contrary to `sly-macroexpand-1', if the form denotes a compiler -macro, SLYNK-BACKEND:COMPILER-MACROEXPAND or -SLYNK-BACKEND:COMPILER-MACROEXPAND-1 are used instead." - (interactive "P") - (sly-eval-macroexpand - (if repeatedly - 'slynk:slynk-expand - 'slynk:slynk-expand-1))) - -(defun sly-expand-1-inplace (&optional repeatedly) - "Display the macro expansion of the form at point. -The form is expanded with CL:MACROEXPAND-1 or, if a prefix -argument is given, with CL:MACROEXPAND." - (interactive "P") - (sly-eval-macroexpand-inplace - (if repeatedly - 'slynk:slynk-expand - 'slynk:slynk-expand-1))) - -(defun sly-format-string-expand (&optional string) - "Expand the format-string at point and display it. -With prefix arg, or if no string at point, prompt the user for a -string to expand. -" - (interactive (list (or (and (not current-prefix-arg) - (sly-string-at-point)) - (sly-read-from-minibuffer "Expand format: " - (sly-string-at-point))))) - (sly-eval-macroexpand 'slynk:slynk-format-string-expand - string)) - - -;;;; Subprocess control - -(defun sly-interrupt () - "Interrupt Lisp." - (interactive) - (cond ((sly-use-sigint-for-interrupt) (sly-send-sigint)) - (t (sly-dispatch-event `(:emacs-interrupt ,sly-current-thread))))) - -(defun sly-quit () - (error "Not implemented properly. Use `sly-interrupt' instead.")) - -(defun sly-quit-lisp (&optional kill interactive) - "Quit lisp, kill the inferior process and associated buffers." - (interactive (list current-prefix-arg t)) - (let ((connection (if interactive - (sly-prompt-for-connection "Connection to quit: ") - (sly-current-connection)))) - (sly-quit-lisp-internal connection 'sly-quit-sentinel kill))) - -(defun sly-quit-lisp-internal (connection sentinel kill) - "Kill SLY socket connection CONNECTION. -Do this by evaluating (SLYNK:QUIT-LISP) in it, and don't wait for -it to reply as usual with other evaluations. If it's non-nil, -setup SENTINEL to run on CONNECTION when it finishes dying. If -KILL is t, and there is such a thing, also kill the inferior lisp -process associated with CONNECTION." - (let ((sly-dispatching-connection connection)) - (sly-eval-async '(slynk:quit-lisp)) - (set-process-filter connection nil) - (let ((attempt 0) - (dying-p nil)) - (set-process-sentinel - connection - (lambda (connection status) - (setq dying-p t) - (sly-message "Connection %s is dying (%s)" connection status) - (let ((inf-process (sly-inferior-process connection))) - (cond ((and kill - inf-process - (not (memq (process-status inf-process) '(exit signal)))) - (sly-message "Quitting %s: also killing the inferior process %s" - connection inf-process) - (kill-process inf-process)) - ((and kill - inf-process) - (sly-message "Quitting %s: inferior process was already dead" - connection - inf-process)) - ((and - kill - (not inf-process)) - (sly-message "Quitting %s: No inferior process to kill!" - connection - inf-process)))) - (when sentinel - (funcall sentinel connection status)))) - (sly-message - "Waiting for connection %s to die by itself..." connection) - (while (and (< (cl-incf attempt) 30) - (not dying-p)) - (sleep-for 0.1)) - (unless dying-p - (sly-message - "Connection %s didn't die by itself. Killing it." connection) - (delete-process connection))))) - -(defun sly-quit-sentinel (process _message) - (cl-assert (process-status process) 'closed) - (let* ((inferior (sly-inferior-process process)) - (inferior-buffer (if inferior (process-buffer inferior)))) - (when inferior (delete-process inferior)) - (when inferior-buffer (kill-buffer inferior-buffer)) - (sly-net-close process "Quitting lisp") - (sly-message "Connection closed."))) - - -;;;; Debugger (SLY-DB) - -(defvar sly-db-hook nil - "Hook run on entry to the debugger.") - -(defcustom sly-db-initial-restart-limit 6 - "Maximum number of restarts to display initially." - :group 'sly-debugger - :type 'integer) - - -;;;;; Local variables in the debugger buffer - -;; Small helper. -(defun sly-make-variables-buffer-local (&rest variables) - (mapcar #'make-variable-buffer-local variables)) - -(sly-make-variables-buffer-local - (defvar sly-db-condition nil - "A list (DESCRIPTION TYPE) describing the condition being debugged.") - - (defvar sly-db-restarts nil - "List of (NAME DESCRIPTION) for each available restart.") - - (defvar sly-db-level nil - "Current debug level (recursion depth) displayed in buffer.") - - (defvar sly-db-backtrace-start-marker nil - "Marker placed at the first frame of the backtrace.") - - (defvar sly-db-restart-list-start-marker nil - "Marker placed at the first restart in the restart list.") - - (defvar sly-db-continuations nil - "List of ids for pending continuation.")) - -;;;;; SLY-DB macros - -;; some macros that we need to define before the first use - -(defmacro sly-db-in-face (name string) - "Return STRING propertised with face sly-db-NAME-face." - (declare (indent 1)) - (let ((facename (intern (format "sly-db-%s-face" (symbol-name name)))) - (var (cl-gensym "string"))) - `(let ((,var ,string)) - (sly-add-face ',facename ,var) - ,var))) - - -;;;;; sly-db-mode - -(defvar sly-db-mode-syntax-table - (let ((table (copy-syntax-table lisp-mode-syntax-table))) - ;; We give < and > parenthesis syntax, so that #< ... > is treated - ;; as a balanced expression. This enables autodoc-mode to match - ;; #<unreadable> actual arguments in the backtraces with formal - ;; arguments of the function. (For Lisp mode, this is not - ;; desirable, since we do not wish to get a mismatched paren - ;; highlighted everytime we type < or >.) - (modify-syntax-entry ?< "(" table) - (modify-syntax-entry ?> ")" table) - table) - "Syntax table for SLY-DB mode.") - -(defvar sly-db-mode-map - (let ((map (make-sparse-keymap))) - (define-key map "n" 'sly-db-down) - (define-key map "p" 'sly-db-up) - (define-key map "\M-n" 'sly-db-details-down) - (define-key map "\M-p" 'sly-db-details-up) - (define-key map "<" 'sly-db-beginning-of-backtrace) - (define-key map ">" 'sly-db-end-of-backtrace) - - (define-key map "a" 'sly-db-abort) - (define-key map "q" 'sly-db-abort) - (define-key map "c" 'sly-db-continue) - (define-key map "A" 'sly-db-break-with-system-debugger) - (define-key map "B" 'sly-db-break-with-default-debugger) - (define-key map "P" 'sly-db-print-condition) - (define-key map "I" 'sly-db-invoke-restart-by-name) - (define-key map "C" 'sly-db-inspect-condition) - (define-key map ":" 'sly-interactive-eval) - (define-key map "Q" 'sly-db-quit) - - (set-keymap-parent map button-buffer-map) - map)) - -(define-derived-mode sly-db-mode fundamental-mode "sly-db" - "Superior lisp debugger mode. -In addition to ordinary SLY commands, the following are -available:\\<sly-db-mode-map> - -Commands to invoke restarts: - \\[sly-db-quit] - quit - \\[sly-db-abort] - abort - \\[sly-db-continue] - continue - \\[sly-db-invoke-restart-0]-\\[sly-db-invoke-restart-9] - restart shortcuts - \\[sly-db-invoke-restart-by-name] - invoke restart by name - -Navigation commands: - \\[forward-button] - next interactive button - \\[sly-db-down] - down - \\[sly-db-up] - up - \\[sly-db-details-down] - down, with details - \\[sly-db-details-up] - up, with details - \\[sly-db-beginning-of-backtrace] - beginning of backtrace - \\[sly-db-end-of-backtrace] - end of backtrace - -Commands to examine and operate on the selected frame:\\<sly-db-frame-map> - \\[sly-db-show-frame-source] - show frame source - \\[sly-db-goto-source] - go to frame source - \\[sly-db-toggle-details] - toggle details - \\[sly-db-disassemble] - dissassemble frame - \\[sly-db-eval-in-frame] - prompt for a form to eval in frame - \\[sly-db-pprint-eval-in-frame] - eval in frame and pretty print result - \\[sly-db-inspect-in-frame] - inspect in frame's context - \\[sly-db-restart-frame] - restart frame - \\[sly-db-return-from-frame] - return from frame - -Miscellaneous commands:\\<sly-db-mode-map> - \\[sly-db-step] - step - \\[sly-db-break-with-default-debugger] - switch to native debugger - \\[sly-db-break-with-system-debugger] - switch to system debugger (gdb) - \\[sly-interactive-eval] - eval - \\[sly-db-inspect-condition] - inspect signalled condition - -Full list of commands: - -\\{sly-db-mode-map} - -Full list of frame-specific commands: - -\\{sly-db-frame-map}" - (erase-buffer) - (set-syntax-table sly-db-mode-syntax-table) - (sly-set-truncate-lines) - ;; Make original sly-connection "sticky" for SLY-DB commands in this buffer - (setq sly-buffer-connection (sly-connection)) - (setq buffer-read-only t) - (sly-mode 1) - (sly-interactive-buttons-mode 1)) - -;; Keys 0-9 are shortcuts to invoke particular restarts. -(dotimes (number 10) - (let ((fname (intern (format "sly-db-invoke-restart-%S" number))) - (docstring (format "Invoke restart numbered %S." number))) - ;; FIXME: In Emacs≥25, you could avoid `eval' and use - ;; (defalias .. (lambda .. (:documentation docstring) ...)) - ;; instead! - (eval `(defun ,fname () - ,docstring - (interactive) - (sly-db-invoke-restart ,number)) - t) - (define-key sly-db-mode-map (number-to-string number) fname))) - - -;;;;; SLY-DB buffer creation & update - -(defcustom sly-db-focus-debugger 'auto - "Control if debugger window gets focus immediately. - -If nil, the window is never focused automatically; if the symbol -`auto', the window is only focused if the user has performed no -other commands in the meantime (i.e. he/she is expecting a -possible debugger); any other non-nil value means to always -automatically focus the debugger window." - :group 'sly-debugger - :type '(choice (const always) (const never) (const auto))) - -(defun sly-filter-buffers (predicate) - "Return a list of where PREDICATE returns true. -PREDICATE is executed in the buffer to test." - (cl-remove-if-not (lambda (%buffer) - (with-current-buffer %buffer - (funcall predicate))) - (buffer-list))) - -(defun sly-db-buffers (&optional connection) - "Return a list of all sly-db buffers (belonging to CONNECTION.)" - (if connection - (sly-filter-buffers (lambda () - (and (eq sly-buffer-connection connection) - (eq major-mode 'sly-db-mode)))) - (sly-filter-buffers (lambda () (eq major-mode 'sly-db-mode))))) - -(defun sly-db-find-buffer (thread &optional connection) - (let ((connection (or connection (sly-connection)))) - (cl-find-if (lambda (buffer) - (with-current-buffer buffer - (and (eq sly-buffer-connection connection) - (eq sly-current-thread thread)))) - (sly-db-buffers)))) - -(defun sly-db-pop-to-debugger-maybe (&optional _button) - "Maybe pop to *sly-db* buffer for current context." - (interactive) - (let ((b (sly-db-find-buffer sly-current-thread))) - (if b (pop-to-buffer b) - (sly-error "Can't find a *sly-db* debugger for this context")))) - -(defsubst sly-db-get-default-buffer () - "Get a sly-db buffer. -The chosen buffer the default connection's it if exists." - (car (sly-db-buffers (sly-current-connection)))) - -(defun sly-db-pop-to-debugger () - "Pop to the first *sly-db* buffer if at least one exists." - (interactive) - (let ((b (sly-db-get-default-buffer))) - (if b (pop-to-buffer b) - (sly-error "No *sly-db* debugger buffers for this connection")))) - -(defun sly-db-get-buffer (thread &optional connection) - "Find or create a sly-db-buffer for THREAD." - (let ((connection (or connection (sly-connection)))) - (or (sly-db-find-buffer thread connection) - (let ((name (sly-buffer-name :db :connection connection - :suffix (format "thread %d" thread)))) - (with-current-buffer (generate-new-buffer name) - (setq sly-buffer-connection connection - sly-current-thread thread) - (current-buffer)))))) - -(defun sly-db-debugged-continuations (connection) - "Return the all debugged continuations for CONNECTION across SLY-DB buffers." - (cl-loop for b in (sly-db-buffers) - append (with-current-buffer b - (and (eq sly-buffer-connection connection) - sly-db-continuations)))) - -(defun sly-db-confirm-buffer-kill () - (when (or (not (process-live-p sly-buffer-connection)) - (sly-y-or-n-p "Really kill sly-db buffer and throw to toplevel?")) - (ignore-errors (sly-db-quit)) - t)) - -(defun sly-db--display-debugger (_thread) - "Display (or pop to) sly-db for THREAD as appropriate. -Also mark the window as a debugger window." - (let* ((action '(sly-db--display-in-prev-sly-db-window)) - (buffer (current-buffer)) - (win - (if (cond ((eq sly-db-focus-debugger 'auto) - (eq sly--send-last-command last-command)) - (t sly-db-focus-debugger)) - (progn - (pop-to-buffer buffer action) - (selected-window)) - (display-buffer buffer action)))) - (set-window-parameter win 'sly-db buffer) - win)) - -(defun sly-db-setup (thread level condition restarts frame-specs conts) - "Setup a new SLY-DB buffer. -CONDITION is a string describing the condition to debug. -RESTARTS is a list of strings (NAME DESCRIPTION) for each -available restart. FRAME-SPECS is a list of (NUMBER DESCRIPTION -&optional PLIST) describing the initial portion of the -backtrace. Frames are numbered from 0. CONTS is a list of -pending Emacs continuations." - (with-current-buffer (sly-db-get-buffer thread) - (cl-assert (if (equal sly-db-level level) - (equal sly-db-condition condition) - t) - () "Bug: sly-db-level is equal but condition differs\n%s\n%s" - sly-db-condition condition) - (with-selected-window (sly-db--display-debugger thread) - (unless (equal sly-db-level level) - (let ((inhibit-read-only t)) - (sly-db-mode) - (add-hook 'kill-buffer-query-functions - #'sly-db-confirm-buffer-kill - nil t) - (setq sly-current-thread thread) - (setq sly-db-level level) - (setq mode-name (format "sly-db[%d]" sly-db-level)) - (setq sly-db-condition condition) - (setq sly-db-restarts restarts) - (setq sly-db-continuations conts) - (sly-db-insert-condition condition) - (insert "\n\n" (sly-db-in-face section "Restarts:") "\n") - (setq sly-db-restart-list-start-marker (point-marker)) - (sly-db-insert-restarts restarts 0 sly-db-initial-restart-limit) - (insert "\n" (sly-db-in-face section "Backtrace:") "\n") - (setq sly-db-backtrace-start-marker (point-marker)) - (save-excursion - (if frame-specs - (sly-db-insert-frames (sly-db-prune-initial-frames frame-specs) t) - (insert "[No backtrace]"))) - (run-hooks 'sly-db-hook) - (set-syntax-table lisp-mode-syntax-table))) - (sly-recenter (point-min) 'allow-moving-point) - (when sly--stack-eval-tags - (sly-message "Entering recursive edit..") - (recursive-edit))))) - -(defun sly-db--display-in-prev-sly-db-window (buffer _alist) - (let ((window - (get-window-with-predicate - #'(lambda (w) - (let ((value (window-parameter w 'sly-db))) - (and value - (not (buffer-live-p value)))))))) - (when window - (display-buffer-record-window 'reuse window buffer) - (set-window-buffer window buffer) - window))) - -(defun sly-db--ensure-initialized (thread level) - "Initialize debugger buffer for THREAD. -If such a buffer exists for LEVEL, it is assumed to have been -sufficiently initialized, and this function does nothing." - (let ((buffer (sly-db-find-buffer thread))) - (unless (and buffer - (with-current-buffer buffer - (equal sly-db-level level))) - (sly-rex () - ('(slynk:debugger-info-for-emacs 0 10) - nil thread) - ((:ok result) - (apply #'sly-db-setup thread level result)))))) - -(defvar sly-db-exit-hook nil - "Hooks run in the debugger buffer just before exit") - -(defun sly-db-exit (thread _level &optional stepping) - "Exit from the debug level LEVEL." - (sly--when-let (sly-db (sly-db-find-buffer thread)) - (with-current-buffer sly-db - (setq kill-buffer-query-functions - (remove 'sly-db-confirm-buffer-kill kill-buffer-query-functions)) - (run-hooks 'sly-db-exit-hook) - (cond (stepping - (setq sly-db-level nil) - (run-with-timer 0.4 nil 'sly-db-close-step-buffer sly-db)) - ((not (eq sly-db (window-buffer (selected-window)))) - ;; A different window selection means an indirect, - ;; non-interactive exit, we just kill the sly-db buffer. - (kill-buffer)) - (t - (quit-window t)))))) - -(defun sly-db-close-step-buffer (buffer) - (when (buffer-live-p buffer) - (with-current-buffer buffer - (when (not sly-db-level) - (quit-window t))))) - - -;;;;;; SLY-DB buffer insertion - -(defun sly-db-insert-condition (condition) - "Insert the text for CONDITION. -CONDITION should be a list (MESSAGE TYPE EXTRAS). -EXTRAS is currently used for the stepper." - (cl-destructuring-bind (msg type extras) condition - (insert (sly-db-in-face topline msg) - "\n" - (sly-db-in-face condition type)) - (sly-db-dispatch-extras extras))) - -(defvar sly-db-extras-hooks nil - "Handlers for the extra options sent in a debugger invocation. -Each function is called with one argument, a list (OPTION -VALUE). It should return non-nil iff it can handle OPTION, and -thus preventing other handlers from trying. - -Functions are run in the SLDB buffer.") - -(defun sly-db-dispatch-extras (extras) - ;; this is (mis-)used for the stepper - (dolist (extra extras) - (sly-dcase extra - ((:show-frame-source n) - (sly-db-show-frame-source n)) - (t - (or (run-hook-with-args-until-success 'sly-db-extras-hooks extra) - ;;(error "Unhandled extra element:" extra) - ))))) - -(defun sly-db-insert-restarts (restarts start count) - "Insert RESTARTS and add the needed text props -RESTARTS should be a list ((NAME DESCRIPTION) ...)." - (let* ((len (length restarts)) - (end (if count (min (+ start count) len) len))) - (cl-loop for (name string) in (cl-subseq restarts start end) - for number from start - do (insert - " " (sly-db-in-face restart-number (number-to-string number)) - ": " (sly-make-action-button (format "[%s]" name) - (let ((n number)) - #'(lambda (_button) - (sly-db-invoke-restart n))) - 'restart-number number) - " " (sly-db-in-face restart string)) - (insert "\n")) - (when (< end len) - (insert (sly-make-action-button - " --more--" - #'(lambda (button) - (let ((inhibit-read-only t)) - (delete-region (button-start button) - (1+ (button-end button))) - (sly-db-insert-restarts restarts end nil) - (sly--when-let (win (get-buffer-window (current-buffer))) - (with-selected-window win - (sly-recenter (point-max)))))) - 'point-entered #'(lambda (_ new) (push-button new))) - "\n")))) - -(defun sly-db-frame-restartable-p (frame-spec) - (and (plist-get (cl-caddr frame-spec) :restartable) t)) - -(defun sly-db-prune-initial-frames (frame-specs) - "Return the prefix of FRAMES-SPECS to initially present to the user. -Regexp heuristics are used to avoid showing SLYNK-internal frames." - (let* ((case-fold-search t) - (rx "^\\([() ]\\|lambda\\)*slynk\\>")) - (or (cl-loop for frame-spec in frame-specs - until (string-match rx (cadr frame-spec)) - collect frame-spec) - frame-specs))) - -(defun sly-db-insert-frames (frame-specs more) - "Insert frames for FRAME-SPECS into buffer. -If MORE is non-nil, more frames are on the Lisp stack." - (cl-loop - for frame-spec in frame-specs - do (sly-db-insert-frame frame-spec) - finally - (when more - (insert (sly-make-action-button - " --more--\n" - (lambda (button) - (let* ((inhibit-read-only t) - (count 40) - (from (1+ (car frame-spec))) - (to (+ from count)) - (frames (sly-eval `(slynk:backtrace ,from ,to))) - (more (sly-length= frames count))) - (delete-region (button-start button) - (button-end button)) - (save-excursion - (sly-db-insert-frames frames more)) - (sly--when-let (win (get-buffer-window (current-buffer))) - (with-selected-window win - (sly-recenter (point-max)))))) - 'point-entered #'(lambda (_ new) (push-button new))))))) - -(defvar sly-db-frame-map - (let ((map (make-sparse-keymap))) - (define-key map (kbd "t") 'sly-db-toggle-details) - (define-key map (kbd "v") 'sly-db-show-frame-source) - (define-key map (kbd ".") 'sly-db-goto-source) - (define-key map (kbd "D") 'sly-db-disassemble) - (define-key map (kbd "e") 'sly-db-eval-in-frame) - (define-key map (kbd "d") 'sly-db-pprint-eval-in-frame) - (define-key map (kbd "i") 'sly-db-inspect-in-frame) - (define-key map (kbd "r") 'sly-db-restart-frame) - (define-key map (kbd "R") 'sly-db-return-from-frame) - (define-key map (kbd "RET") 'sly-db-toggle-details) - - (define-key map "s" 'sly-db-step) - (define-key map "x" 'sly-db-next) - (define-key map "o" 'sly-db-out) - (define-key map "b" 'sly-db-break-on-return) - - (define-key map "\C-c\C-c" 'sly-db-recompile-frame-source) - - (set-keymap-parent map sly-part-button-keymap) - map)) - -(defvar sly-db-frame-menu-map - (let ((map (make-sparse-keymap))) - (cl-macrolet ((item (label sym) - `(define-key map [,sym] '(menu-item ,label ,sym)))) - (item "Dissassemble" sly-db-disassemble) - (item "Eval In Context" sly-db-eval-in-frame) - (item "Eval and Pretty Print In Context" sly-db-pprint-eval-in-frame) - (item "Inspect In Context" sly-db-inspect-in-frame) - (item "Restart" sly-db-restart-frame) - (item "Return Value" sly-db-return-from-frame) - (item "Toggle Details" sly-db-toggle-details) - (item "Show Source" sly-db-show-frame-source) - (item "Go To Source" sly-db-goto-source)) - (set-keymap-parent map sly-button-popup-part-menu-keymap) - map)) - -(define-button-type 'sly-db-frame :supertype 'sly-part - 'keymap sly-db-frame-map - 'part-menu-keymap sly-db-frame-menu-map - 'action 'sly-db-toggle-details - 'mouse-action 'sly-db-toggle-details) - -(defun sly-db--guess-frame-function (frame) - (ignore-errors - (car (car (read-from-string - (replace-regexp-in-string "#" "" - (cadr frame))))))) - -(defun sly-db-frame-button (label frame face &rest props) - (apply #'sly--make-text-button label nil :type 'sly-db-frame - 'face face - 'field (car frame) - 'frame-number (car frame) - 'frame-string (cadr frame) - 'part-args (list (car frame) - (sly-db--guess-frame-function frame)) - 'part-label (format "Frame %d" (car frame)) - props)) - -(defun sly-db-frame-number-at-point () - (let ((button (sly-db-frame-button-near-point))) - (button-get button 'frame-number))) - -(defun sly-db-frame-button-near-point () - (or (sly-button-at nil 'sly-db-frame 'no-error) - (get-text-property (point) 'nearby-frame-button) - (error "No frame button here"))) - -(defun sly-db-insert-frame (frame-spec) - "Insert a frame for FRAME-SPEC." - (let* ((number (car frame-spec)) - (label (cadr frame-spec)) - (origin (point))) - (insert - (propertize (format "%2d: " number) - 'face 'sly-db-frame-label-face) - (sly-db-frame-button label frame-spec - (if (sly-db-frame-restartable-p frame-spec) - 'sly-db-restartable-frame-line-face - 'sly-db-frame-line-face)) - "\n") - (add-text-properties - origin (point) - (list 'field number - 'keymap sly-db-frame-map - 'nearby-frame-button (button-at (- (point) 2)))))) - - -;;;;;; SLY-DB examining text props -(defun sly-db--goto-last-visible-frame () - (goto-char (point-max)) - (while (not (get-text-property (point) 'frame-string)) - (goto-char (previous-single-property-change (point) 'frame-string)))) - -(defun sly-db-beginning-of-backtrace () - "Goto the first frame." - (interactive) - (goto-char sly-db-backtrace-start-marker)) - - -;;;;; SLY-DB commands -(defun sly-db-cycle () - "Cycle between restart list and backtrace." - (interactive) - (let ((pt (point))) - (cond ((< pt sly-db-restart-list-start-marker) - (goto-char sly-db-restart-list-start-marker)) - ((< pt sly-db-backtrace-start-marker) - (goto-char sly-db-backtrace-start-marker)) - (t - (goto-char sly-db-restart-list-start-marker))))) - -(defun sly-db-end-of-backtrace () - "Fetch the entire backtrace and go to the last frame." - (interactive) - (sly-db--fetch-all-frames) - (sly-db--goto-last-visible-frame)) - -(defun sly-db--fetch-all-frames () - (let ((inhibit-read-only t) - (inhibit-point-motion-hooks t)) - (sly-db--goto-last-visible-frame) - (let ((last (sly-db-frame-number-at-point))) - (goto-char (next-single-char-property-change (point) 'frame-string)) - (delete-region (point) (point-max)) - (save-excursion - (insert "\n") - (sly-db-insert-frames (sly-eval `(slynk:backtrace ,(1+ last) nil)) - nil))))) - - -;;;;;; SLY-DB show source -(defun sly-db-show-frame-source (frame-number) - "Highlight FRAME-NUMBER's expression in a source code buffer." - (interactive (list (sly-db-frame-number-at-point))) - (sly-eval-async - `(slynk:frame-source-location ,frame-number) - (lambda (source-location) - (sly-dcase source-location - ((:error message) - (sly-message "%s" message) - (ding)) - (t - (sly--display-source-location source-location)))))) - - -;;;;;; SLY-DB toggle details -(define-button-type 'sly-db-local-variable :supertype 'sly-part - 'sly-button-inspect - #'(lambda (frame-id var-id) - (sly-eval-for-inspector `(slynk:inspect-frame-var ,frame-id - ,var-id)) ) - 'sly-button-pretty-print - #'(lambda (frame-id var-id) - (sly-eval-describe `(slynk:pprint-frame-var ,frame-id - ,var-id))) - 'sly-button-describe - #'(lambda (frame-id var-id) - (sly-eval-describe `(slynk:describe-frame-var ,frame-id - ,var-id)))) - -(defun sly-db-local-variable-button (label frame-number var-id &rest props) - (apply #'sly--make-text-button label nil - :type 'sly-db-local-variable - 'part-args (list frame-number var-id) - 'part-label (format "Local Variable %d" var-id) props)) - -(defun sly-db-frame-details-region (frame-button) - "Get (BEG END) for FRAME-BUTTON's details, or nil if hidden" - (let ((beg (button-end frame-button)) - (end (1- (field-end (button-start frame-button) 'escape)))) - (unless (= beg end) (list beg end)))) - -(defun sly-db-toggle-details (frame-button) - "Toggle display of details for the current frame. -The details include local variable bindings and CATCH-tags." - (interactive (list (sly-db-frame-button-near-point))) - (if (sly-db-frame-details-region frame-button) - (sly-db-hide-frame-details frame-button) - (sly-db-show-frame-details frame-button))) - -(defun sly-db-show-frame-details (frame-button) - "Show details for FRAME-BUTTON" - (interactive (list (sly-db-frame-button-near-point))) - (cl-destructuring-bind (locals catches) - (sly-eval `(slynk:frame-locals-and-catch-tags - ,(button-get frame-button 'frame-number))) - (let ((inhibit-read-only t) - (inhibit-point-motion-hooks t)) - (save-excursion - (goto-char (button-end frame-button)) - (let ((indent1 " ") - (indent2 " ")) - (insert "\n" indent1 - (sly-db-in-face section (if locals "Locals:" "[No Locals]"))) - (cl-loop for i from 0 - for var in locals - with frame-number = (button-get frame-button 'frame-number) - do - (cl-destructuring-bind (&key name id value) var - (insert "\n" - indent2 - (sly-db-in-face local-name - (concat name (if (zerop id) - "" - (format "#%d" id)))) - " = " - (sly-db-local-variable-button value - frame-number - i)))) - (when catches - (insert "\n" indent1 (sly-db-in-face section "Catch-tags:")) - (dolist (tag catches) - (sly-propertize-region `(catch-tag ,tag) - (insert "\n" indent2 (sly-db-in-face catch-tag - (format "%s" tag)))))) - ;; The whole details field is propertized accordingly... - ;; - (add-text-properties (button-start frame-button) (point) - (list 'field (button-get frame-button 'field) - 'keymap sly-db-frame-map - 'nearby-frame-button frame-button)) - ;; ...but we must remember to remove the 'keymap property from - ;; any buttons inside the field - ;; - (cl-loop for pos = (point) then (button-start button) - for button = (previous-button pos) - while (and button - (> (button-start button) - (button-start frame-button))) - do (remove-text-properties (button-start button) - (button-end button) - '(keymap nil)))))) - (sly-recenter (field-end (button-start frame-button) 'escape)))) - -(defun sly-db-hide-frame-details (frame-button) - (interactive (list (sly-db-frame-button-near-point))) - (let* ((inhibit-read-only t) - (to-delete (sly-db-frame-details-region frame-button))) - (cl-assert to-delete) - (when (and (< (car to-delete) (point)) - (< (point) (cadr to-delete))) - (goto-char (button-start frame-button))) - (apply #'delete-region to-delete))) - -(defun sly-db-disassemble (frame-number) - "Disassemble the code for frame with FRAME-NUMBER." - (interactive (list (sly-db-frame-number-at-point))) - (sly-eval-async `(slynk:sly-db-disassemble ,frame-number) - (lambda (result) - (sly-show-description result nil)))) - - -;;;;;; SLY-DB eval and inspect - -(defun sly-db-eval-in-frame (frame-number string package) - "Prompt for an expression and evaluate it in the selected frame." - (interactive (sly-db-frame-eval-interactive "Eval in frame (%s)> ")) - (sly-eval-async `(slynk:eval-string-in-frame ,string ,frame-number ,package) - 'sly-display-eval-result)) - -(defun sly-db-pprint-eval-in-frame (frame-number string package) - "Prompt for an expression, evaluate in selected frame, pretty-print result." - (interactive (sly-db-frame-eval-interactive "Eval in frame (%s)> ")) - (sly-eval-async - `(slynk:pprint-eval-string-in-frame ,string ,frame-number ,package) - (lambda (result) - (sly-show-description result nil)))) - -(defun sly-db-frame-eval-interactive (fstring) - (let* ((frame-number (sly-db-frame-number-at-point)) - (pkg (sly-eval `(slynk:frame-package-name ,frame-number)))) - (list frame-number - (let ((sly-buffer-package pkg)) - (sly-read-from-minibuffer (format fstring pkg))) - pkg))) - -(defun sly-db-inspect-in-frame (frame-number string) - "Prompt for an expression and inspect it in the selected frame." - (interactive (list - (sly-db-frame-number-at-point) - (sly-read-from-minibuffer - "Inspect in frame (evaluated): " - (sly-sexp-at-point)))) - (sly-eval-for-inspector `(slynk:inspect-in-frame ,string ,frame-number))) - -(defun sly-db-inspect-condition () - "Inspect the current debugger condition." - (interactive) - (sly-eval-for-inspector '(slynk:inspect-current-condition))) - -(defun sly-db-print-condition () - (interactive) - (sly-eval-describe `(slynk:sdlb-print-condition))) - - -;;;;;; SLY-DB movement - -(defun sly-db-down (arg) - "Move down ARG frames. With negative ARG, move up." - (interactive "p") - (cl-loop - for i from 0 below (abs arg) - do (cl-loop - for tries from 0 below 2 - for pos = (point) then next-change - for next-change = (funcall (if (cl-minusp arg) - #'previous-single-char-property-change - #'next-single-char-property-change) - pos 'frame-number) - for prop-value = (get-text-property next-change 'frame-number) - when prop-value do (goto-char next-change) - until prop-value))) - -(defun sly-db-up (arg) - "Move up ARG frames. With negative ARG, move down." - (interactive "p") - (sly-db-down (- (or arg 1)))) - -(defun sly-db-sugar-move (move-fn arg) - (let ((current-frame-button (sly-db-frame-button-near-point))) - (when (and current-frame-button - (sly-db-frame-details-region current-frame-button)) - (sly-db-hide-frame-details current-frame-button))) - (funcall move-fn arg) - (let ((frame-button (sly-db-frame-button-near-point))) - (when frame-button - (sly-db-show-frame-source (button-get frame-button 'frame-number)) - (sly-db-show-frame-details frame-button)))) - -(defun sly-db-details-up (arg) - "Move up ARG frames and show details." - (interactive "p") - (sly-db-sugar-move 'sly-db-up arg)) - -(defun sly-db-details-down (arg) - "Move down ARG frames and show details." - (interactive "p") - (sly-db-sugar-move 'sly-db-down arg)) - - -;;;;;; SLY-DB restarts - -(defun sly-db-quit () - "Quit to toplevel." - (interactive) - (cl-assert sly-db-restarts () "sly-db-quit called outside of sly-db buffer") - (sly-rex () ('(slynk:throw-to-toplevel)) - ((:ok x) (error "sly-db-quit returned [%s]" x)) - ((:abort _)))) - -(defun sly-db-continue () - "Invoke the \"continue\" restart." - (interactive) - (cl-assert sly-db-restarts () "sly-db-continue called outside of sly-db buffer") - (sly-rex () - ('(slynk:sly-db-continue)) - ((:ok _) - (sly-message "No restart named continue") - (ding)) - ((:abort _)))) - -(defun sly-db-abort () - "Invoke the \"abort\" restart." - (interactive) - (sly-eval-async '(slynk:sly-db-abort) - (lambda (v) (sly-message "Restart returned: %S" v)))) - -(defun sly-db-invoke-restart (restart-number) - "Invoke the restart number NUMBER. -Interactively get the number from a button at point." - (interactive (button-get (sly-button-at (point)) 'restart-number)) - (sly-rex () - ((list 'slynk:invoke-nth-restart-for-emacs sly-db-level restart-number)) - ((:ok value) (sly-message "Restart returned: %s" value)) - ((:abort _)))) - -(defun sly-db-invoke-restart-by-name (restart-name) - (interactive (list (let ((completion-ignore-case t)) - (completing-read "Restart: " sly-db-restarts nil t - "" - 'sly-db-invoke-restart-by-name)))) - (sly-db-invoke-restart (cl-position restart-name sly-db-restarts - :test 'string= :key 'first))) - -(defun sly-db-break-with-default-debugger (&optional dont-unwind) - "Enter default debugger." - (interactive "P") - (sly-rex () - ((list 'slynk:sly-db-break-with-default-debugger - (not (not dont-unwind))) - nil sly-current-thread) - ((:abort _)))) - -(defun sly-db-break-with-system-debugger (&optional lightweight) - "Enter system debugger (gdb)." - (interactive "P") - (sly-attach-gdb sly-buffer-connection lightweight)) - -(defun sly-attach-gdb (connection &optional lightweight) - "Run `gud-gdb'on the connection with PID `pid'. - -If `lightweight' is given, do not send any request to the -inferior Lisp (e.g. to obtain default gdb config) but only -operate from the Emacs side; intended for cases where the Lisp is -truly screwed up." - (interactive - (list (sly-read-connection "Attach gdb to: " (sly-connection)) "P")) - (let ((pid (sly-pid connection)) - (file (sly-lisp-implementation-program connection)) - (commands (unless lightweight - (let ((sly-dispatching-connection connection)) - (sly-eval `(slynk:gdb-initial-commands)))))) - (gud-gdb (format "gdb -p %d %s" pid (or file ""))) - (with-current-buffer gud-comint-buffer - (dolist (cmd commands) - ;; First wait until gdb was initialized, then wait until current - ;; command was processed. - (while (not (looking-back comint-prompt-regexp (line-beginning-position) - nil)) - (sit-for 0.01)) - ;; We do not use `gud-call' because we want the initial commands - ;; to be displayed by the user so he knows what he's got. - (insert cmd) - (comint-send-input))))) - -(defun sly-read-connection (prompt &optional initial-value) - "Read a connection from the minibuffer. -Return the net process, or nil." - (cl-assert (memq initial-value sly-net-processes)) - (let* ((to-string (lambda (p) - (format "%s (pid %d)" - (sly-connection-name p) (sly-pid p)))) - (candidates (mapcar (lambda (p) (cons (funcall to-string p) p)) - sly-net-processes))) - (cdr (assoc (completing-read prompt candidates - nil t (funcall to-string initial-value)) - candidates)))) - -(defun sly-db-step (frame-number) - "Step to next basic-block boundary." - (interactive (list (sly-db-frame-number-at-point))) - (sly-eval-async `(slynk:sly-db-step ,frame-number))) - -(defun sly-db-next (frame-number) - "Step over call." - (interactive (list (sly-db-frame-number-at-point))) - (sly-eval-async `(slynk:sly-db-next ,frame-number))) - -(defun sly-db-out (frame-number) - "Resume stepping after returning from this function." - (interactive (list (sly-db-frame-number-at-point))) - (sly-eval-async `(slynk:sly-db-out ,frame-number))) - -(defun sly-db-break-on-return (frame-number) - "Set a breakpoint at the current frame. -The debugger is entered when the frame exits." - (interactive (list (sly-db-frame-number-at-point))) - (sly-eval-async `(slynk:sly-db-break-on-return ,frame-number) - (lambda (msg) (sly-message "%s" msg)))) - -(defun sly-db-break (name) - "Set a breakpoint at the start of the function NAME." - (interactive (list (sly-read-symbol-name "Function: " t))) - (sly-eval-async `(slynk:sly-db-break ,name) - (lambda (msg) (sly-message "%s" msg)))) - -(defun sly-db-return-from-frame (frame-number string) - "Reads an expression in the minibuffer and causes the function to -return that value, evaluated in the context of the frame." - (interactive (list (sly-db-frame-number-at-point) - (sly-read-from-minibuffer "Return from frame: "))) - (sly-rex () - ((list 'slynk:sly-db-return-from-frame frame-number string)) - ((:ok value) (sly-message "%s" value)) - ((:abort _)))) - -(defun sly-db-restart-frame (frame-number) - "Causes the frame to restart execution with the same arguments as it -was called originally." - (interactive (list (sly-db-frame-number-at-point))) - (sly-rex () - ((list 'slynk:restart-frame frame-number)) - ((:ok value) (sly-message "%s" value)) - ((:abort _)))) - -(defun sly-toggle-break-on-signals () - "Toggle the value of *break-on-signals*." - (interactive) - (sly-eval-async `(slynk:toggle-break-on-signals) - (lambda (msg) (sly-message "%s" msg)))) - - -;;;;;; SLY-DB recompilation commands - -(defun sly-db-recompile-frame-source (frame-number &optional raw-prefix-arg) - (interactive - (list (sly-db-frame-number-at-point) current-prefix-arg)) - (sly-eval-async - `(slynk:frame-source-location ,frame-number) - (let ((policy (sly-compute-policy raw-prefix-arg))) - (lambda (source-location) - (sly-dcase source-location - ((:error message) - (sly-message "%s" message) - (ding)) - (t - (let ((sly-compilation-policy policy)) - (sly-recompile-location source-location)))))))) - - -;;;; Thread control panel - -(defvar sly-threads-buffer-timer nil) - -(defcustom sly-threads-update-interval nil - "Interval at which the list of threads will be updated." - :type '(choice - (number :value 0.5) - (const nil)) - :group 'sly-ui) - -(defun sly-list-threads () - "Display a list of threads." - (interactive) - (let ((name (sly-buffer-name :threads - :connection t))) - (sly-with-popup-buffer (name :connection t - :mode 'sly-thread-control-mode) - (sly-update-threads-buffer (current-buffer)) - (goto-char (point-min)) - (when sly-threads-update-interval - (when sly-threads-buffer-timer - (cancel-timer sly-threads-buffer-timer)) - (setq sly-threads-buffer-timer - (run-with-timer - sly-threads-update-interval - sly-threads-update-interval - 'sly-update-threads-buffer - (current-buffer)))) - (add-hook 'kill-buffer-hook 'sly--threads-buffer-teardown - 'append 'local)))) - -(defun sly--threads-buffer-teardown () - (when sly-threads-buffer-timer - (cancel-timer sly-threads-buffer-timer)) - (when (process-live-p sly-buffer-connection) - (sly-eval-async `(slynk:quit-thread-browser)))) - -(defun sly-update-threads-buffer (&optional buffer) - (interactive) - (with-current-buffer (or buffer - (current-buffer)) - (sly-eval-async '(slynk:list-threads) - #'(lambda (threads) - (with-current-buffer (current-buffer) - (sly--display-threads threads)))))) - -(defun sly-move-point (position) - "Move point in the current buffer and in the window the buffer is displayed." - (let ((window (get-buffer-window (current-buffer) t))) - (goto-char position) - (when window - (set-window-point window position)))) - -(defun sly--display-threads (threads) - (let* ((inhibit-read-only t) - (old-thread-id (get-text-property (point) 'thread-id)) - (old-line (line-number-at-pos)) - (old-column (current-column))) - (erase-buffer) - (sly-insert-threads threads) - (let ((new-line (cl-position old-thread-id (cdr threads) - :key #'car :test #'equal))) - (goto-char (point-min)) - (forward-line (or new-line old-line)) - (move-to-column old-column) - (sly-move-point (point))))) - -(defun sly-transpose-lists (list-of-lists) - (let ((ncols (length (car list-of-lists)))) - (cl-loop for col-index below ncols - collect (cl-loop for row in list-of-lists - collect (elt row col-index))))) - -(defun sly-insert-table-row (line line-props col-props col-widths) - (sly-propertize-region line-props - (cl-loop for string in line - for col-prop in col-props - for width in col-widths do - (sly-insert-propertized col-prop string) - (insert-char ?\ (- width (length string)))))) - -(defun sly-insert-table (rows header row-properties column-properties) - "Insert a \"table\" so that the columns are nicely aligned." - (let* ((ncols (length header)) - (lines (cons header rows)) - (widths (cl-loop for columns in (sly-transpose-lists lines) - collect (1+ (cl-loop for cell in columns - maximize (length cell))))) - (header-line (with-temp-buffer - (sly-insert-table-row - header nil (make-list ncols nil) widths) - (buffer-string)))) - (cond ((boundp 'header-line-format) - (setq header-line-format header-line)) - (t (insert header-line "\n"))) - (cl-loop for line in rows for line-props in row-properties do - (sly-insert-table-row line line-props column-properties widths) - (insert "\n")))) - -(defvar sly-threads-table-properties - '(nil (face bold))) - -(defun sly-insert-threads (threads) - (let* ((labels (car threads)) - (threads (cdr threads)) - (header (cl-loop for label in labels collect - (capitalize (substring (symbol-name label) 1)))) - (rows (cl-loop for thread in threads collect - (cl-loop for prop in thread collect - (format "%s" prop)))) - (line-props (cl-loop for (id) in threads for i from 0 - collect `(thread-index ,i thread-id ,id))) - (col-props (cl-loop for nil in labels for i from 0 collect - (nth i sly-threads-table-properties)))) - (sly-insert-table rows header line-props col-props))) - - -;;;;; Major mode -(defvar sly-thread-control-mode-map - (let ((map (make-sparse-keymap))) - (define-key map "a" 'sly-thread-attach) - (define-key map "d" 'sly-thread-debug) - (define-key map "g" 'sly-update-threads-buffer) - (define-key map "k" 'sly-thread-kill) - (define-key map "q" 'quit-window) - map)) - -(define-derived-mode sly-thread-control-mode fundamental-mode - "Threads" - "SLY Thread Control Panel Mode. - -\\{sly-thread-control-mode-map}" - (when sly-truncate-lines - (set (make-local-variable 'truncate-lines) t)) - (read-only-mode 1) - (sly-mode 1) - (setq buffer-undo-list t)) - -(defun sly-thread-kill () - (interactive) - (sly-eval `(cl:mapc 'slynk:kill-nth-thread - ',(sly-get-properties 'thread-index))) - (call-interactively 'sly-update-threads-buffer)) - -(defun sly-get-region-properties (prop start end) - (cl-loop for position = (if (get-text-property start prop) - start - (next-single-property-change start prop)) - then (next-single-property-change position prop) - while (<= position end) - collect (get-text-property position prop))) - -(defun sly-get-properties (prop) - (if (use-region-p) - (sly-get-region-properties prop - (region-beginning) - (region-end)) - (let ((value (get-text-property (point) prop))) - (when value - (list value))))) - -(defun sly-thread-attach () - (interactive) - (let ((id (get-text-property (point) 'thread-index)) - (file (sly-slynk-port-file))) - (sly-eval-async `(slynk:start-slynk-server-in-thread ,id ,file))) - (sly-read-port-and-connect nil)) - -(defun sly-thread-debug () - (interactive) - (let ((id (get-text-property (point) 'thread-index))) - (sly-eval-async `(slynk:debug-nth-thread ,id)))) - - -;;;;; Connection listing - -(defvar sly-connection-list-mode-map - (let ((map (make-sparse-keymap))) - (define-key map "d" 'sly-connection-list-make-default) - (define-key map "g" 'sly-update-connection-list) - (define-key map (kbd "RET") 'sly-connection-list-default-action) - (define-key map (kbd "C-m") 'sly-connection-list-default-action) - (define-key map (kbd "C-k") 'sly-quit-connection-at-point) - (define-key map (kbd "R") 'sly-restart-connection-at-point) - (define-key map (kbd "q") 'quit-window) - map)) - -(define-derived-mode sly-connection-list-mode tabulated-list-mode - "SLY-Connections" - "SLY Connection List Mode. - -\\{sly-connection-list-mode-map}" - (set (make-local-variable 'tabulated-list-format) - `[("Default" 8) ("Name" 24 t) ("Host" 12) - ("Port" 6) ("Pid" 6 t) ("Type" 1000 t)]) - (tabulated-list-init-header)) - -(defun sly--connection-at-point () - (or (get-text-property (point) 'tabulated-list-id) - (error "No connection at point"))) - -(defvar sly-connection-list-button-action nil) - -(defun sly-connection-list-default-action (connection) - (interactive (list (sly--connection-at-point))) - (funcall sly-connection-list-button-action connection)) - -(defun sly-update-connection-list () - (interactive) - (set (make-local-variable 'tabulated-list-entries) - (mapcar - #'(lambda (p) - (list p - `[,(if (eq sly-default-connection p) "*" " ") - (,(file-name-nondirectory (or (sly-connection-name p) - "unknown")) - action - ,#'(lambda (_button) - (and sly-connection-list-button-action - (funcall sly-connection-list-button-action p)))) - ,(car (process-contact p)) - ,(format "%s" (cl-second (process-contact p))) - ,(format "%s" (sly-pid p)) - ,(or (sly-lisp-implementation-type p) - "unknown")])) - (reverse sly-net-processes))) - (let ((p (point))) - (tabulated-list-print) - (goto-char p))) - -(defun sly-quit-connection-at-point (connection) - (interactive (list (sly--connection-at-point))) - (let ((sly-dispatching-connection connection) - (end (time-add (current-time) (seconds-to-time 3)))) - (sly-quit-lisp t) - (while (memq connection sly-net-processes) - (when (time-less-p end (current-time)) - (sly-message "Quit timeout expired. Disconnecting.") - (delete-process connection)) - (sit-for 0 100))) - (sly-update-connection-list)) - -(defun sly-restart-connection-at-point (connection) - (interactive (list (sly--connection-at-point))) - (when (sly-y-or-n-p "Really restart '%s'" (sly-connection-name connection)) - (let ((sly-dispatching-connection connection)) - (sly-restart-inferior-lisp)))) - -(defun sly-connection-list-make-default () - "Make the connection at point the default connection." - (interactive) - (sly-select-connection (sly--connection-at-point)) - (sly-update-connection-list)) - -(defun sly-list-connections () - "Display a list of all connections." - (interactive) - (sly-with-popup-buffer ((sly-buffer-name :connections) - :mode 'sly-connection-list-mode) - (sly-update-connection-list))) - - - -;;;; Inspector - -(defgroup sly-inspector nil - "Options for the SLY inspector." - :prefix "sly-inspector-" - :group 'sly) - -(defvar sly--this-inspector-name nil - "Buffer-local inspector name (a string), or nil") - -(cl-defun sly-eval-for-inspector (slyfun-and-args - &key (error-message "Couldn't inspect") - restore-point - save-selected-window - (inspector-name sly--this-inspector-name) - opener) - (if (cl-some #'listp slyfun-and-args) - (sly-warning - "`sly-eval-for-inspector' not meant to be passed a generic form")) - (let ((pos (and (eq major-mode 'sly-inspector-mode) - (sly-inspector-position)))) - (sly-eval-async `(slynk:eval-for-inspector - ,sly--this-inspector-name ; current inspector, if any - ,inspector-name ; target inspector, if any - ',(car slyfun-and-args) - ,@(cdr slyfun-and-args)) - (or opener - (lambda (results) - (let ((opener (lambda () - (sly--open-inspector - results - :point (and restore-point pos) - :inspector-name inspector-name - :switch (not save-selected-window))))) - (cond (results - (funcall opener)) - (t - (sly-message error-message))))))))) - -(defun sly-read-inspector-name () - (let* ((names (cl-loop for b in (buffer-list) - when (with-current-buffer b - (and (eq sly-buffer-connection - (sly-current-connection)) - (eq major-mode 'sly-inspector-mode))) - when (buffer-local-value 'sly--this-inspector-name b) - collect it)) - (result (completing-read "Inspector name: " (cons "default" - names) - nil nil nil nil "default"))) - (unless (string= result "default") - result))) - -(defun sly-maybe-read-inspector-name () - (or (and current-prefix-arg - (sly-read-inspector-name)) - sly--this-inspector-name)) - -(defun sly-inspect (string &optional inspector-name) - "Eval an expression and inspect the result." - (interactive - (let* ((name (sly-maybe-read-inspector-name)) - (string (sly-read-from-minibuffer - (concat "Inspect value" - (and name - (format " in inspector \"%s\"" name)) - " (evaluated): ") - (sly-sexp-at-point 'interactive nil nil)))) - (list string name))) - (sly-eval-for-inspector `(slynk:init-inspector ,string) - :inspector-name inspector-name)) - -(defvar sly-inspector-mode-map - (let ((map (make-sparse-keymap))) - (define-key map "l" 'sly-inspector-pop) - (define-key map "n" 'sly-inspector-next) - (define-key map [mouse-6] 'sly-inspector-pop) - (define-key map [mouse-7] 'sly-inspector-next) - - (define-key map " " 'sly-inspector-next) - (define-key map "D" 'sly-inspector-describe-inspectee) - (define-key map "e" 'sly-inspector-eval) - (define-key map "h" 'sly-inspector-history) - (define-key map "g" 'sly-inspector-reinspect) - (define-key map ">" 'sly-inspector-fetch-all) - (define-key map "q" 'sly-inspector-quit) - - (set-keymap-parent map button-buffer-map) - map)) - -(define-derived-mode sly-inspector-mode fundamental-mode - "SLY-Inspector" - " -\\{sly-inspector-mode-map}" - (set-syntax-table lisp-mode-syntax-table) - (sly-set-truncate-lines) - (setq buffer-read-only t) - (sly-mode 1)) - -(define-button-type 'sly-inspector-part :supertype 'sly-part - 'sly-button-inspect - #'(lambda (id) - (sly-eval-for-inspector `(slynk:inspect-nth-part ,id) - :inspector-name (sly-maybe-read-inspector-name))) - 'sly-button-pretty-print - #'(lambda (id) - (sly-eval-describe `(slynk:pprint-inspector-part ,id))) - 'sly-button-describe - #'(lambda (id) - (sly-eval-describe `(slynk:describe-inspector-part ,id))) - 'sly-button-show-source - #'(lambda (id) - (sly-eval-async - `(slynk:find-source-location-for-emacs '(:inspector ,id)) - #'(lambda (result) - (sly--display-source-location result 'noerror))))) - -(defun sly-inspector-part-button (label id &rest props) - (apply #'sly--make-text-button - label nil - :type 'sly-inspector-part - 'part-args (list id) - 'part-label "Inspector Object" - props)) - -(defmacro sly-inspector-fontify (face string) - `(sly-add-face ',(intern (format "sly-inspector-%s-face" face)) ,string)) - -(cl-defun sly--open-inspector (inspected-parts - &key point kill-hook inspector-name (switch t)) - "Display INSPECTED-PARTS in a new inspector window. -Optionally set point to POINT. If KILL-HOOK is provided, it is -added to local KILL-BUFFER hooks for the inspector -buffer. INSPECTOR-NAME is the name of the target inspector, or -nil if the default one is to be used. SWITCH indicates the -buffer should be switched to (defaults to t)" - (sly-with-popup-buffer ((sly-buffer-name :inspector - :connection t - :suffix inspector-name) - :mode 'sly-inspector-mode - :select switch - :same-window-p - (and (eq major-mode 'sly-inspector-mode) - (or (null inspector-name) - (eq sly--this-inspector-name inspector-name))) - :connection t) - (when kill-hook - (add-hook 'kill-buffer-hook kill-hook t t)) - (set (make-local-variable 'sly--this-inspector-name) inspector-name) - (cl-destructuring-bind (&key id title content) inspected-parts - (cl-macrolet ((fontify (face string) - `(sly-inspector-fontify ,face ,string))) - (insert (sly-inspector-part-button title id 'skip t)) - (while (eq (char-before) ?\n) - (backward-delete-char 1)) - (insert "\n" (fontify label "--------------------") "\n") - (save-excursion - (sly-inspector-insert-content content)) - (when point - (cl-check-type point cons) - (ignore-errors - (goto-char (point-min)) - (forward-line (1- (car point))) - (move-to-column (cdr point)))))) - (buffer-disable-undo))) - -(defvar sly-inspector-limit 500) - -(defun sly-inspector-insert-content (content) - (sly-inspector-fetch-chunk - content nil - (lambda (chunk) - (let ((inhibit-read-only t)) - (sly-inspector-insert-chunk chunk t t))))) - -(defun sly-inspector-insert-chunk (chunk prev next) - "Insert CHUNK at point. -If PREV resp. NEXT are true insert more-buttons as needed." - (cl-destructuring-bind (ispecs len start end) chunk - (when (and prev (> start 0)) - (sly-inspector-insert-more-button start t)) - (mapc #'sly-inspector-insert-ispec ispecs) - (when (and next (< end len)) - (sly-inspector-insert-more-button end nil)))) - -(defun sly-inspector-insert-ispec (ispec) - (insert - (if (stringp ispec) ispec - (sly-dcase ispec - ((:value string id) - (sly-inspector-part-button string id)) - ((:label string) - (sly-inspector-fontify label string)) - ((:action string id) - (sly-make-action-button - string - #'(lambda (_button) - (sly-eval-for-inspector `(slynk::inspector-call-nth-action ,id) - :restore-point t)))))))) - -(defun sly-inspector-position () - "Return a pair (Y-POSITION X-POSITION) representing the -position of point in the current buffer." - ;; We make sure we return absolute coordinates even if the user has - ;; narrowed the buffer. - ;; FIXME: why would somebody narrow the buffer? - (save-restriction - (widen) - (cons (line-number-at-pos) - (current-column)))) - -(defun sly-inspector-pop () - "Reinspect the previous object." - (interactive) - (sly-eval-for-inspector `(slynk:inspector-pop) - :error-message "No previous object")) - -(defun sly-inspector-next () - "Inspect the next object in the history." - (interactive) - (sly-eval-for-inspector `(slynk:inspector-next) - :error-message "No next object")) - -(defun sly-inspector-quit (&optional reset) - "Quit the inspector and kill the buffer. -With optional RESET (true with prefix arg), also reset the -inspector on the Lisp side." - (interactive "P") - (when reset (sly-eval-async `(slynk:quit-inspector))) - (quit-window)) - -(defun sly-inspector-describe-inspectee () - "Describe the currently inspected object" - (interactive) - (sly-eval-describe `(slynk:describe-inspectee))) - -(defun sly-inspector-eval (string) - "Eval an expression in the context of the inspected object. -The `*' variable will be bound to the inspected object." - (interactive (list (sly-read-from-minibuffer "Inspector eval: "))) - (sly-eval-with-transcript `(slynk:inspector-eval ,string))) - -(defun sly-inspector-history () - "Show the previously inspected objects." - (interactive) - (sly-eval-describe `(slynk:inspector-history))) - -(defun sly-inspector-reinspect (&optional inspector-name) - (interactive (list (sly-maybe-read-inspector-name))) - (sly-eval-for-inspector `(slynk:inspector-reinspect) - :inspector-name inspector-name)) - -(defun sly-inspector-toggle-verbose () - (interactive) - (sly-eval-for-inspector `(slynk:inspector-toggle-verbose))) - -(defun sly-inspector-insert-more-button (index previous) - (insert (sly-make-action-button - (if previous " [--more--]\n" " [--more--]") - #'sly-inspector-fetch-more - 'range-args (list index previous)))) - -(defun sly-inspector-fetch-all () - "Fetch all inspector contents and go to the end." - (interactive) - (let ((button (button-at (1- (point-max))))) - (cond ((and button - (button-get button 'range-args)) - (let (sly-inspector-limit) - (sly-inspector-fetch-more button))) - (t - (sly-error "No more elements to fetch"))))) - -(defun sly-inspector-fetch-more (button) - (cl-destructuring-bind (index prev) (button-get button 'range-args) - (sly-inspector-fetch-chunk - (list '() (1+ index) index index) prev - (sly-rcurry - (lambda (chunk prev) - (let ((inhibit-read-only t)) - (delete-region (button-start button) (button-end button)) - (sly-inspector-insert-chunk chunk prev (not prev)))) - prev)))) - -(defun sly-inspector-fetch-chunk (chunk prev cont) - (sly-inspector-fetch chunk sly-inspector-limit prev cont)) - -(defun sly-inspector-fetch (chunk limit prev cont) - (cl-destructuring-bind (from to) - (sly-inspector-next-range chunk limit prev) - (cond ((and from to) - (sly-eval-for-inspector - `(slynk:inspector-range ,from ,to) - :opener (sly-rcurry (lambda (chunk2 chunk1 limit prev cont) - (sly-inspector-fetch - (sly-inspector-join-chunks chunk1 chunk2) - limit prev cont)) - chunk limit prev cont))) - (t (funcall cont chunk))))) - -(defun sly-inspector-next-range (chunk limit prev) - (cl-destructuring-bind (_ len start end) chunk - (let ((count (- end start))) - (cond ((and prev (< 0 start) (or (not limit) (< count limit))) - (list (if limit (max (- end limit) 0) 0) start)) - ((and (not prev) (< end len) (or (not limit) (< count limit))) - (list end (if limit (+ start limit) most-positive-fixnum))) - (t '(nil nil)))))) - -(defun sly-inspector-join-chunks (chunk1 chunk2) - (cl-destructuring-bind (i1 _l1 s1 e1) chunk1 - (cl-destructuring-bind (i2 l2 s2 e2) chunk2 - (cond ((= e1 s2) - (list (append i1 i2) l2 s1 e2)) - ((= e2 s1) - (list (append i2 i1) l2 s2 e1)) - (t (error "Invalid chunks")))))) - - -;;;; Indentation - -(defun sly-update-indentation () - "Update indentation for all macros defined in the Lisp system." - (interactive) - (sly-eval-async '(slynk:update-indentation-information))) - -(defvar sly-indentation-update-hooks) - -(defun sly-intern-indentation-spec (spec) - (cond ((consp spec) - (cons (sly-intern-indentation-spec (car spec)) - (sly-intern-indentation-spec (cdr spec)))) - ((stringp spec) - (intern spec)) - (t - spec))) - -;; FIXME: restore the old version without per-package -;; stuff. sly-indentation.el should be able tho disable the simple -;; version if needed. -(defun sly-handle-indentation-update (alist) - "Update Lisp indent information. - -ALIST is a list of (SYMBOL-NAME . INDENT-SPEC) of proposed indentation -settings for `sly-common-lisp-indent-function'. The appropriate property -is setup, unless the user already set one explicitly." - (dolist (info alist) - (let ((symbol (intern (car info))) - (indent (sly-intern-indentation-spec (cl-second info))) - (packages (cl-third info))) - (if (and (boundp 'sly-common-lisp-system-indentation) - (fboundp 'sly-update-system-indentation)) - ;; A table provided by sly-cl-indent.el. - (funcall #'sly-update-system-indentation symbol indent packages) - ;; Does the symbol have an indentation value that we set? - (when (equal (get symbol 'sly-common-lisp-indent-function) - (get symbol 'sly-indent)) - (put symbol 'sly-common-lisp-indent-function indent) - (put symbol 'sly-indent indent))) - (run-hook-with-args 'sly-indentation-update-hooks - symbol indent packages)))) - - -;;;; Contrib modules - -(defun sly-contrib--load-slynk-dependencies () - (let ((needed (cl-remove-if (lambda (s) - (cl-find (symbol-name s) - (sly-lisp-modules) - :key #'downcase - :test #'string=)) - sly-contrib--required-slynk-modules - :key #'car))) - (when needed - ;; No asynchronous request because with :SPAWN that could result - ;; in the attempt to load modules concurrently which may not be - ;; supported by the host Lisp. - (sly-eval `(slynk:slynk-add-load-paths ',(cl-remove-duplicates - (mapcar #'cl-second needed) - :test #'string=))) - (let* ((result (sly-eval - `(slynk:slynk-require - ',(mapcar #'symbol-name (mapcar #'cl-first needed))))) - (all-modules (cl-first result)) - (loaded-now (cl-second result))) - ;; check if everything went OK - ;; - (cl-loop for n in needed - unless (cl-find (cl-first n) loaded-now :test #'string=) - - ;; string= compares symbols and strings nicely - ;; - do (when (y-or-n-p (format - "\ -Watch out! SLY failed to load SLYNK module %s for contrib %s!\n -Disable it?" (cl-first n) (cl-third n))) - (sly-disable-contrib (cl-third n)) - (sly-temp-message 3 3 "\ -You'll need to re-enable %s manually with `sly-enable-contrib'\ -if/when you fix the error" (cl-third n)))) - ;; Update the connection-local list of all *MODULES* - ;; - (setf (sly-lisp-modules) all-modules))))) - -(cl-defstruct (sly-contrib - (:conc-name sly-contrib--)) - enabled-p - name - sly-dependencies - slynk-dependencies - enable - disable - authors - license) - -(defmacro define-sly-contrib (name _docstring &rest clauses) - (declare (indent 1)) - (cl-destructuring-bind (&key sly-dependencies - slynk-dependencies - on-load - on-unload - authors - license) - (cl-loop for (key . value) in clauses append `(,key ,value)) - (cl-labels - ((enable-fn (c) (intern (concat (symbol-name c) "-init"))) - (disable-fn (c) (intern (concat (symbol-name c) "-unload"))) - (path-sym (c) (intern (concat (symbol-name c) "--path"))) - (contrib-sym (c) (intern (concat (symbol-name c) "--contrib")))) - `(progn - (defvar ,(path-sym name)) - (defvar ,(contrib-sym name)) - (setq ,(path-sym name) (and load-file-name - (file-name-directory load-file-name))) - (eval-when-compile - (when byte-compile-current-file; protect against eager macro expansion - (add-to-list 'load-path - (file-name-as-directory - (file-name-directory byte-compile-current-file))))) - (setq ,(contrib-sym name) - (put 'sly-contribs ',name - (make-sly-contrib - :name ',name :authors ',authors :license ',license - :sly-dependencies ',sly-dependencies - :slynk-dependencies ',slynk-dependencies - :enable ',(enable-fn name) :disable ',(disable-fn name)))) - ,@(mapcar (lambda (d) `(require ',d)) sly-dependencies) - (defun ,(enable-fn name) () - (mapc #'funcall (mapcar - #'sly-contrib--enable - (cl-remove-if #'sly-contrib--enabled-p - (list ,@(mapcar #'contrib-sym - sly-dependencies))))) - (cl-loop for dep in ',slynk-dependencies - do (cl-pushnew (list dep ,(path-sym name) ',name) - sly-contrib--required-slynk-modules - :key #'cl-first)) - ;; FIXME: It's very tricky to do Slynk calls like - ;; `sly-contrib--load-slynk-dependencies' here, and it this - ;; should probably loop all connections. Anyway, we try - ;; ensure this can only happen from an interactive - ;; `sly-setup' call. - ;; - (when (and (eq this-command 'sly-setup) - (sly-connected-p)) - (sly-contrib--load-slynk-dependencies)) - ,@on-load - (setf (sly-contrib--enabled-p ,(contrib-sym name)) t)) - (defun ,(disable-fn name) () - ,@on-unload - (cl-loop for dep in ',slynk-dependencies - do (setq sly-contrib--required-slynk-modules - (cl-remove dep sly-contrib--required-slynk-modules - :key #'cl-first))) - (sly-warning "Disabling contrib %s" ',name) - (mapc #'funcall (mapcar - #'sly-contrib--disable - (cl-remove-if-not #'sly-contrib--enabled-p - (list ,@(mapcar #'contrib-sym - sly-dependencies))))) - (setf (sly-contrib--enabled-p ,(contrib-sym name)) nil)))))) - -(defun sly-contrib--all-contribs () - "All defined `sly-contrib' objects." - (cl-loop for (nil val) on (symbol-plist 'sly-contribs) by #'cddr - when (sly-contrib-p val) - collect val)) - -(defun sly-contrib--all-dependencies (contrib) - "Contrib names recursively needed by CONTRIB, including self." - (sly--contrib-safe contrib - (cons contrib - (cl-mapcan #'sly-contrib--all-dependencies - (sly-contrib--sly-dependencies - (sly-contrib--find-contrib contrib)))))) - -(defun sly-contrib--find-contrib (designator) - (if (sly-contrib-p designator) - designator - (or (get 'sly-contribs designator) - (error "Unknown contrib: %S" designator)))) - -(defun sly-contrib--read-contrib-name () - (let ((names (cl-loop for c in (sly-contrib--all-contribs) collect - (symbol-name (sly-contrib--name c))))) - (intern (completing-read "Contrib: " names nil t)))) - -(defun sly-enable-contrib (name) - "Attempt to enable contrib NAME." - (interactive (list (sly-contrib--read-contrib-name))) - (sly--contrib-safe name - (funcall (sly-contrib--enable (sly-contrib--find-contrib name))))) - -(defun sly-disable-contrib (name) - "Attempt to disable contrib NAME." - (interactive (list (sly-contrib--read-contrib-name))) - (sly--contrib-safe name - (funcall (sly-contrib--disable (sly-contrib--find-contrib name))))) - - -;;;;; Pull-down menu -(easy-menu-define sly-menu sly-mode-map "SLY" - (let ((C '(sly-connected-p))) - `("SLY" - [ "Edit Definition..." sly-edit-definition ,C ] - [ "Return From Definition" sly-pop-find-definition-stack ,C ] - [ "Complete Symbol" sly-complete-symbol ,C ] - "--" - ("Evaluation" - [ "Eval Defun" sly-eval-defun ,C ] - [ "Eval Last Expression" sly-eval-last-expression ,C ] - [ "Eval And Pretty-Print" sly-pprint-eval-last-expression ,C ] - [ "Eval Region" sly-eval-region ,C ] - [ "Eval Region And Pretty-Print" sly-pprint-eval-region ,C ] - [ "Interactive Eval..." sly-interactive-eval ,C ] - [ "Edit Lisp Value..." sly-edit-value ,C ] - [ "Call Defun" sly-call-defun ,C ]) - ("Debugging" - [ "Inspect..." sly-inspect ,C ] - [ "Macroexpand Once..." sly-macroexpand-1 ,C ] - [ "Macroexpand All..." sly-macroexpand-all ,C ] - [ "Disassemble..." sly-disassemble-symbol ,C ]) - ("Compilation" - [ "Compile Defun" sly-compile-defun ,C ] - [ "Compile and Load File" sly-compile-and-load-file ,C ] - [ "Compile File" sly-compile-file ,C ] - [ "Compile Region" sly-compile-region ,C ] - "--" - [ "Next Note" sly-next-note t ] - [ "Previous Note" sly-previous-note t ] - [ "Remove Notes" sly-remove-notes t ] - [ "List notes" sly-show-compilation-log t ]) - ("Cross Reference" - [ "Who Calls..." sly-who-calls ,C ] - [ "Who References... " sly-who-references ,C ] - [ "Who Sets..." sly-who-sets ,C ] - [ "Who Binds..." sly-who-binds ,C ] - [ "Who Macroexpands..." sly-who-macroexpands ,C ] - [ "Who Specializes..." sly-who-specializes ,C ] - [ "List Callers..." sly-list-callers ,C ] - [ "List Callees..." sly-list-callees ,C ] - [ "Next Location" sly-next-location t ]) - ("Editing" - [ "Check Parens" check-parens t] - [ "Update Indentation" sly-update-indentation ,C]) - ("Documentation" - [ "Describe Symbol..." sly-describe-symbol ,C ] - [ "Lookup Documentation..." sly-documentation-lookup t ] - [ "Apropos..." sly-apropos ,C ] - [ "Apropos all..." sly-apropos-all ,C ] - [ "Apropos Package..." sly-apropos-package ,C ] - [ "Hyperspec..." sly-hyperspec-lookup t ]) - "--" - [ "Interrupt Command" sly-interrupt ,C ] - [ "Abort Async. Command" sly-quit ,C ]))) - -(easy-menu-define sly-sly-db-menu sly-db-mode-map "SLY-DB Menu" - (let ((C '(sly-connected-p))) - `("SLY-DB" - [ "Next Frame" sly-db-down t ] - [ "Previous Frame" sly-db-up t ] - [ "Toggle Frame Details" sly-db-toggle-details t ] - [ "Next Frame (Details)" sly-db-details-down t ] - [ "Previous Frame (Details)" sly-db-details-up t ] - "--" - [ "Eval Expression..." sly-interactive-eval ,C ] - [ "Eval in Frame..." sly-db-eval-in-frame ,C ] - [ "Eval in Frame (pretty print)..." sly-db-pprint-eval-in-frame ,C ] - [ "Inspect In Frame..." sly-db-inspect-in-frame ,C ] - [ "Inspect Condition Object" sly-db-inspect-condition ,C ] - "--" - [ "Restart Frame" sly-db-restart-frame ,C ] - [ "Return from Frame..." sly-db-return-from-frame ,C ] - ("Invoke Restart" - [ "Continue" sly-db-continue ,C ] - [ "Abort" sly-db-abort ,C ] - [ "Step" sly-db-step ,C ] - [ "Step next" sly-db-next ,C ] - [ "Step out" sly-db-out ,C ] - ) - "--" - [ "Quit (throw)" sly-db-quit ,C ] - [ "Break With Default Debugger" sly-db-break-with-default-debugger ,C ]))) - -(easy-menu-define sly-inspector-menu sly-inspector-mode-map - "Menu for the SLY Inspector" - (let ((C '(sly-connected-p))) - `("SLY-Inspector" - [ "Pop Inspectee" sly-inspector-pop ,C ] - [ "Next Inspectee" sly-inspector-next ,C ] - [ "Describe this Inspectee" sly-inspector-describe ,C ] - [ "Eval in context" sly-inspector-eval ,C ] - [ "Show history" sly-inspector-history ,C ] - [ "Reinspect" sly-inspector-reinspect ,C ] - [ "Fetch all parts" sly-inspector-fetch-all ,C ] - [ "Quit" sly-inspector-quit ,C ]))) - - -;;;; Utilities (no not Paul Graham style) - -;;; FIXME: this looks almost sly `sly-alistify', perhaps the two -;;; functions can be merged. -(defun sly-group-similar (similar-p list) - "Return the list of lists of 'similar' adjacent elements of LIST. -The function SIMILAR-P is used to test for similarity. -The order of the input list is preserved." - (if (null list) - nil - (let ((accumulator (list (list (car list))))) - (dolist (x (cdr list)) - (if (funcall similar-p x (caar accumulator)) - (push x (car accumulator)) - (push (list x) accumulator))) - (nreverse (mapcar #'nreverse accumulator))))) - -(defun sly-alistify (list key test) - "Partition the elements of LIST into an alist. -KEY extracts the key from an element and TEST is used to compare -keys." - (let ((alist '())) - (dolist (e list) - (let* ((k (funcall key e)) - (probe (cl-assoc k alist :test test))) - (if probe - (push e (cdr probe)) - (push (cons k (list e)) alist)))) - ;; Put them back in order. - (nreverse (mapc (lambda (ent) - (setcdr ent (nreverse (cdr ent)))) - alist)))) - -;;;;; Misc. - -(defun sly-length= (list n) - "Return (= (length LIST) N)." - (if (zerop n) - (null list) - (let ((tail (nthcdr (1- n) list))) - (and tail (null (cdr tail)))))) - -(defun sly-length> (seq n) - "Return (> (length SEQ) N)." - (cl-etypecase seq - (list (nthcdr n seq)) - (sequence (> (length seq) n)))) - -(defun sly-trim-whitespace (str) - "Chomp leading and tailing whitespace from STR." - ;; lited from http://www.emacswiki.org/emacs/ElispCookbook - (replace-regexp-in-string (rx (or (: bos (* (any " \t\n"))) - (: (* (any " \t\n")) eos))) - "" - str)) - -;;;;; Buffer related - -(defun sly-column-max () - (save-excursion - (goto-char (point-min)) - (cl-loop for column = (prog2 (end-of-line) (current-column) (forward-line)) - until (= (point) (point-max)) - maximizing column))) - -;;;;; CL symbols vs. Elisp symbols. - -(defun sly-cl-symbol-name (symbol) - (let ((n (if (stringp symbol) symbol (symbol-name symbol)))) - (if (string-match ":\\([^:]*\\)$" n) - (let ((symbol-part (match-string 1 n))) - (if (string-match "^|\\(.*\\)|$" symbol-part) - (match-string 1 symbol-part) - symbol-part)) - n))) - -(defun sly-cl-symbol-package (symbol &optional default) - (let ((n (if (stringp symbol) symbol (symbol-name symbol)))) - (if (string-match "^\\([^:]*\\):" n) - (match-string 1 n) - default))) - -(defun sly-qualify-cl-symbol-name (symbol-or-name) - "Return a package-qualified string for SYMBOL-OR-NAME. -If SYMBOL-OR-NAME doesn't already have a package prefix the -current package is used." - (let ((s (if (stringp symbol-or-name) - symbol-or-name - (symbol-name symbol-or-name)))) - (if (sly-cl-symbol-package s) - s - (format "%s::%s" - (let* ((package (sly-current-package))) - ;; package is a string like ":cl-user" - ;; or "CL-USER", or "\"CL-USER\"". - (if package - (sly--pretty-package-name package) - "CL-USER")) - (sly-cl-symbol-name s))))) - -;;;;; Moving, CL idiosyncracies aware (reader conditionals &c.) - -(defmacro sly-point-moves-p (&rest body) - "Execute BODY and return true if the current buffer's point moved." - (declare (indent 0)) - (let ((pointvar (cl-gensym "point-"))) - `(let ((,pointvar (point))) - (save-current-buffer ,@body) - (/= ,pointvar (point))))) - -(defun sly-forward-sexp (&optional count) - "Like `forward-sexp', but understands reader-conditionals (#- and #+), -and skips comments." - (dotimes (_i (or count 1)) - (sly-forward-cruft) - (forward-sexp))) - -(defconst sly-reader-conditionals-regexp - ;; #!+, #!- are SBCL specific reader-conditional syntax. - ;; We need this for the source files of SBCL itself. - (regexp-opt '("#+" "#-" "#!+" "#!-"))) - -(defsubst sly-forward-reader-conditional () - "Move past any reader conditional (#+ or #-) at point." - (when (looking-at sly-reader-conditionals-regexp) - (goto-char (match-end 0)) - (let* ((plus-conditional-p (eq (char-before) ?+)) - (result (sly-eval-feature-expression - (condition-case e - (read (current-buffer)) - (invalid-read-syntax - (signal 'sly-unknown-feature-expression (cdr e))))))) - (unless (if plus-conditional-p result (not result)) - ;; skip this sexp - (sly-forward-sexp))))) - -(defun sly-forward-cruft () - "Move forward over whitespace, comments, reader conditionals." - (while (sly-point-moves-p (skip-chars-forward " \t\n") - (forward-comment (buffer-size)) - (sly-forward-reader-conditional)))) - -(defun sly-keywordify (symbol) - "Make a keyword out of the symbol SYMBOL." - (let ((name (downcase (symbol-name symbol)))) - (intern (if (eq ?: (aref name 0)) - name - (concat ":" name))))) - -(put 'sly-incorrect-feature-expression - 'error-conditions '(sly-incorrect-feature-expression error)) - -(put 'sly-unknown-feature-expression - 'error-conditions '(sly-unknown-feature-expression - sly-incorrect-feature-expression - error)) - -;; FIXME: let it crash -;; FIXME: the (null (cdr l)) constraint is bogus -(defun sly-eval-feature-expression (e) - "Interpret a reader conditional expression." - (cond ((symbolp e) - (memq (sly-keywordify e) (sly-lisp-features))) - ((and (consp e) (symbolp (car e))) - (funcall (let ((head (sly-keywordify (car e)))) - (cl-case head - (:and #'cl-every) - (:or #'cl-some) - (:not - (let ((feature-expression e)) - (lambda (f l) - (cond ((null l) t) - ((null (cdr l)) (not (apply f l))) - (t (signal 'sly-incorrect-feature-expression - feature-expression)))))) - (t (signal 'sly-unknown-feature-expression head)))) - #'sly-eval-feature-expression - (cdr e))) - (t (signal 'sly-incorrect-feature-expression e)))) - -;;;;; Extracting Lisp forms from the buffer or user - -(defun sly-region-for-defun-at-point (&optional pos) - "Return a list (START END) for the positions of defun at POS. -POS defaults to point" - (save-excursion - (save-match-data - (goto-char (or pos (point))) - (end-of-defun) - (let ((end (point))) - (beginning-of-defun) - (list (point) end))))) - -(defun sly-beginning-of-symbol () - "Move to the beginning of the CL-style symbol at point." - (while (re-search-backward "\\(\\sw\\|\\s_\\|\\s\\.\\|\\s\\\\|[#@|]\\)\\=" - (when (> (point) 2000) (- (point) 2000)) - t)) - (re-search-forward "\\=#[-+.<|]" nil t) - (when (and (eq (char-after) ?@) (eq (char-before) ?\,)) - (forward-char))) - -(defsubst sly-end-of-symbol () - "Move to the end of the CL-style symbol at point." - (re-search-forward "\\=\\(\\sw\\|\\s_\\|\\s\\.\\|#:\\|[@|]\\)*")) - -(put 'sly-symbol 'end-op 'sly-end-of-symbol) -(put 'sly-symbol 'beginning-op 'sly-beginning-of-symbol) - -(defun sly-symbol-start-pos () - "Return the starting position of the symbol under point. -The result is unspecified if there isn't a symbol under the point." - (save-excursion (sly-beginning-of-symbol) (point))) - -(defun sly-symbol-end-pos () - (save-excursion (sly-end-of-symbol) (point))) - -(defun sly-bounds-of-symbol-at-point () - "Return the bounds of the symbol around point. -The returned bounds are either nil or non-empty." - (let ((bounds (bounds-of-thing-at-point 'sly-symbol))) - (if (and bounds - (< (car bounds) - (cdr bounds))) - bounds))) - -(defun sly-symbol-at-point (&optional interactive) - "Return the name of the symbol at point, otherwise nil." - ;; (thing-at-point 'symbol) returns "" in empty buffers - (let ((bounds (sly-bounds-of-symbol-at-point))) - (when bounds - (let ((beg (car bounds)) (end (cdr bounds))) - (when interactive (sly-flash-region beg end)) - (buffer-substring-no-properties beg end))))) - -(defun sly-bounds-of-sexp-at-point (&optional interactive) - "Return the bounds sexp near point as a pair (or nil). -With non-nil INTERACTIVE, error if can't find such a thing." - (or (sly-bounds-of-symbol-at-point) - (and (equal (char-after) ?\() - (member (char-before) '(?\' ?\, ?\@)) - ;; hide stuff before ( to avoid quirks with '( etc. - (save-restriction - (narrow-to-region (point) (point-max)) - (bounds-of-thing-at-point 'sexp))) - (bounds-of-thing-at-point 'sexp) - (and (save-excursion - (and (ignore-errors - (backward-sexp 1) - t) - (bounds-of-thing-at-point 'sexp)))) - (when interactive - (user-error "No sexp near point")))) - -(cl-defun sly-sexp-at-point (&optional interactive stringp (errorp t)) - "Return the sexp at point as a string, otherwise nil. -With non-nil INTERACTIVE, flash the region and also error if no -sexp can be found, unless ERRORP, which defaults to t, is passed -as nil. With non-nil STRINGP, only look for strings" - (catch 'return - (let ((bounds (sly-bounds-of-sexp-at-point (and interactive - errorp)))) - (when bounds - (when (and stringp - (not (eq (syntax-class (syntax-after (car bounds))) - (char-syntax ?\")))) - (if (and interactive - interactive) - (user-error "No string at point") - (throw 'return nil))) - (when interactive - (sly-flash-region (car bounds) (cdr bounds))) - (buffer-substring-no-properties (car bounds) - (cdr bounds)))))) - -(defun sly-string-at-point (&optional interactive) - "Returns the string near point as a string, otherwise nil. -With non-nil INTERACTIVE, flash the region and error if no string -can be found." - (sly-sexp-at-point interactive 'stringp)) - -(defun sly-input-complete-p (start end) - "Return t if the region from START to END contains a complete sexp." - (save-excursion - (goto-char start) - (cond ((looking-at "\\s *['`#]?[(\"]") - (ignore-errors - (save-restriction - (narrow-to-region start end) - ;; Keep stepping over blanks and sexps until the end of - ;; buffer is reached or an error occurs. Tolerate extra - ;; close parens. - (cl-loop do (skip-chars-forward " \t\r\n)") - until (eobp) - do (forward-sexp)) - t))) - (t t)))) - - -;;;; sly.el in pretty colors - -(cl-loop for sym in (list 'sly-def-connection-var - 'sly-define-channel-type - 'sly-define-channel-method - 'define-sly-contrib) - for regexp = (format "(\\(%S\\)\\s +\\(\\(\\w\\|\\s_\\)+\\)" - sym) - do (font-lock-add-keywords - 'emacs-lisp-mode - `((,regexp (1 font-lock-keyword-face) - (2 font-lock-variable-name-face))))) - -;;;; Finishing up - -(defun sly--byte-compile (symbol) - (require 'bytecomp) ;; tricky interaction between autoload and let. - (let ((byte-compile-warnings '())) - (byte-compile symbol))) - -(defun sly-byte-compile-hotspots (syms) - (mapc (lambda (sym) - (cond ((fboundp sym) - (unless (or (byte-code-function-p (symbol-function sym)) - (subrp (symbol-function sym))) - (sly--byte-compile sym))) - (t (error "%S is not fbound" sym)))) - syms)) - -(sly-byte-compile-hotspots - '(sly-alistify - sly-log-event - sly--events-buffer - sly-process-available-input - sly-dispatch-event - sly-net-filter - sly-net-have-input-p - sly-net-decode-length - sly-net-read - sly-print-apropos - sly-insert-propertized - sly-beginning-of-symbol - sly-end-of-symbol - sly-eval-feature-expression - sly-forward-sexp - sly-forward-cruft - sly-forward-reader-conditional)) - -;;;###autoload -(add-hook 'lisp-mode-hook 'sly-editing-mode) - -(cond - ((or (not (memq 'slime-lisp-mode-hook lisp-mode-hook)) - noninteractive - (prog1 - (y-or-n-p "[sly] SLIME detected in `lisp-mode-hook', causes keybinding conflicts. Remove it for this Emacs session?") - (warn "To restore SLIME in this session, customize `lisp-mode-hook' -and replace `sly-editing-mode' with `slime-lisp-mode-hook'."))) - (remove-hook 'lisp-mode-hook 'slime-lisp-mode-hook) - (dolist (buffer (buffer-list)) - (with-current-buffer buffer - (when (eq major-mode 'lisp-mode) - (unless sly-editing-mode (sly-editing-mode 1)) - (ignore-errors (and (featurep 'slime) (funcall 'slime-mode -1))))))) - (t - (warn - "`sly.el' loaded OK. To use SLY, customize `lisp-mode-hook' and remove `slime-lisp-mode-hook'."))) - -(provide 'sly) - -;;; sly.el ends here -;; Local Variables: -;; coding: utf-8 -;; End: diff --git a/elpa/sly-20211121.1002/sly.info b/elpa/sly-20211121.1002/sly.info @@ -1,3539 +0,0 @@ -This is sly.info, produced by makeinfo version 6.7 from sly.texi. - -Written for SLIME Luke Gorrie and others, rewritten by João Távora for -SLY. - - This file has been placed in the public domain. -INFO-DIR-SECTION Emacs -START-INFO-DIR-ENTRY -* SLY: (sly). Common-Lisp IDE -END-INFO-DIR-ENTRY - - -File: sly.info, Node: Top, Next: Introduction, Up: (dir) - -SLY -*** - -SLY is a Common Lisp IDE for Emacs. This is the manual for version -1.0.42. (Last updated December 11, 2021) - - Written for SLIME Luke Gorrie and others, rewritten by João Távora -for SLY. - - This file has been placed in the public domain. - -* Menu: - -* Introduction:: -* Getting started:: -* A SLY tour for SLIME users:: -* Working with source files:: -* Common functionality:: -* The REPL and other special buffers:: -* Customization:: -* Tips and Tricks:: -* Extensions:: -* Credits:: -* Key Index:: -* Command Index:: -* Variable Index:: - - -- The Detailed Node Listing -- - -Getting started - -* Platforms:: -* Downloading:: -* Basic setup:: -* Running:: -* Basic customization:: -* Multiple Lisps:: - -Working with source files - -* Evaluation:: -* Compilation:: -* Autodoc:: -* Semantic indentation:: -* Reader conditionals:: -* Macro-expansion:: - -Common functionality - -* Finding definitions:: -* Cross-referencing:: -* Completion:: -* Interactive objects:: -* Documentation:: -* Multiple connections:: -* Disassembly:: -* Recovery:: -* Temporary buffers:: -* Multi-threading:: - -The REPL and other special buffers - -* REPL:: -* Inspector:: -* Debugger:: -* Trace Dialog:: -* Stickers:: - -The REPL: the "top level" - -* REPL commands:: -* REPL output:: -* REPL backreferences:: - -The SLY-DB Debugger - -* Examining frames:: -* Restarts:: -* Frame Navigation:: -* Miscellaneous:: - -Customization - -* Emacs-side:: -* Lisp-side customization:: - -Emacs-side - -* Keybindings:: -* Keymaps:: -* Defcustom variables:: -* Hooks:: - -Lisp-side (Slynk) - -* Communication style:: -* Other configurables:: - -Tips and Tricks - -* Connecting to a remote Lisp:: -* Loading Slynk faster:: -* Auto-SLY:: -* REPLs and game loops:: -* Controlling SLY from outside Emacs:: - -Connecting to a remote Lisp - -* Setting up the Lisp image:: -* Setting up Emacs:: -* Setting up pathname translations:: - -Extensions - -* Loading and unloading:: -* More contribs:: - -More contribs - -* TRAMP Support:: -* Scratch Buffer:: - - - -File: sly.info, Node: Introduction, Next: Getting started, Prev: Top, Up: Top - -1 Introduction -************** - -SLY is Sylvester the Cat's Common Lisp IDE. It extends Emacs with -support for interactive programming in Common Lisp. - - The features are centered around an Emacs minor-mode called -'sly-mode', which complements the standard major-mode 'lisp-mode' for -editing Lisp source files. 'sly-mode' adds support for interacting with -a running Common Lisp process for compilation, debugging, documentation -lookup, and so on. - - SLY attempts to follow the example of Emacs's own native Emacs-Lisp -environment. Many of the keybindings and interface concepts used to -interact with Emacs's Elisp machine are reused in SLY to interact with -the underlying Common Lisp run-times. Emacs makes requests to these -processes, asking them to compile files or code snippets; deliver -introspection information various objects; or invoke commands or -debugging restarts. - - Internally, SLY's user-interface, written in Emacs Lisp, is connected -via sockets to one or more instances of a server program called "Slynk" -that is running in the Lisp processes. - - The two sides communicate using a Remote Procedure Call (RPC) -protocol. The Lisp-side server is primarily written in portable Common -Lisp. However, because some non-standard functionality is provided -differently by each Lisp implementation (SBCL, CMUCL, Allegro, etc...) -the Lisp-side server is again split into two parts - portable and -non-portable implementation - which communicate using a well-defined -interface. Each Lisp implementation provides a separate implementation -of that interface, making SLY as a whole readily portable. - - SLY is a direct fork of SLIME, the "Superior Lisp Interaction Mode -for Emacs", which itself derived from previous Emacs programs such as -SLIM and ILISP. If you already know SLIME, SLY's closeness to it is -immediately apparent. However, where SLIME has traditionally focused on -the stability of its core functionality, SLY aims for a richer feature -set, a more consistent user interface, and an experience generally -closer to Emacs' own. - - To understand the differences between the two projects read SLY's -NEWS.md file. For a hand-on approach to these differences you might -want to *note A SLY tour for SLIME users::. - - -File: sly.info, Node: Getting started, Next: A SLY tour for SLIME users, Prev: Introduction, Up: Top - -2 Getting started -***************** - -This chapter tells you how to get SLY up and running. - -* Menu: - -* Platforms:: -* Downloading:: -* Basic setup:: -* Running:: -* Basic customization:: -* Multiple Lisps:: - - -File: sly.info, Node: Platforms, Next: Downloading, Up: Getting started - -2.1 Supported Platforms -======================= - -SLY supports a wide range of operating systems and Lisp implementations. -SLY runs on Unix systems, Mac OSX, and Microsoft Windows. GNU Emacs -versions 24.4 and above are supported. _XEmacs or Emacs 23 are notably -not supported_. - - The supported Lisp implementations, roughly ordered from the -best-supported, are: - - * CMU Common Lisp (CMUCL), 19d or newer - * Steel Bank Common Lisp (SBCL), 1.0 or newer - * Clozure Common Lisp (CCL), version 1.3 or newer - * LispWorks, version 4.3 or newer - * Allegro Common Lisp (ACL), version 6 or newer - * CLISP, version 2.35 or newer - * Armed Bear Common Lisp (ABCL) - * Scieneer Common Lisp (SCL), version 1.2.7 or newer - * Embedded Common Lisp (ECL) - * ManKai Common Lisp (MKCL) - * Clasp - - Most features work uniformly across implementations, but some are -prone to variation. These include the precision of placing -compiler-note annotations, XREF support, and fancy debugger commands -(like "restart frame"). - - -File: sly.info, Node: Downloading, Next: Basic setup, Prev: Platforms, Up: Getting started - -2.2 Downloading SLY -=================== - -By far the easiest method for getting SLY up and running is using Emacs’ -package system configured to the popular MELPA repository. This snippet -of code should already be in your configuration: - - (add-to-list 'package-archives - '("melpa" . "https://melpa.org/packages/")) - (package-initialize) - - You should now be able to issue the command 'M-x package-install', -choose 'sly' and have it be downloaded and installed automatically. If -you don’t find it in the list, ensure you run 'M-x -package-refresh-contents' first. - - In other situations, such as when developing SLY itself, you can -access the Git repository directly: - - git clone https://github.com/joaotavora/sly.git - - If you want to hack on SLY, use Github's _fork_ functionality and -submit a _pull request_. Be sure to first read the CONTRIBUTING.md file -first. - - -File: sly.info, Node: Basic setup, Next: Running, Prev: Downloading, Up: Getting started - -2.3 Basic setup -=============== - -If you installed SLY from MELPA, it is quite possible that you don’t -need any more configuration, provided that SLY can find a suitable Lisp -executable in your 'PATH' environment variable. - - Otherwise, you need to tell it where a Lisp program can be found, so -customize the variable 'inferior-lisp-program' (*note Defcustom -variables::) or add a line like this one to your '~/.emacs' or -'~/.emacs.d/init.el' (*note Emacs Init File::). - - (setq inferior-lisp-program "/opt/sbcl/bin/sbcl") - - After evaluating this, you should be able to execute 'M-x sly' and be -greeted with a REPL. - - If you cloned from the Git repository, you’ll have to add a couple of -more lines to your initialization file configuration: - - (add-to-list 'load-path "~/dir/to/cloned/sly") - (require 'sly-autoloads) - - -File: sly.info, Node: Running, Next: Basic customization, Prev: Basic setup, Up: Getting started - -2.4 Running SLY -=============== - -SLY can either ask Emacs to start its own Lisp subprocesss or connect to -a running process on a local or remote machine. - - The first alternative is more common for local development and is -started via 'M-x sly'. The "inferior" Lisp process thus started is told -to load the Lisp-side server known as "Slynk" and then a socket -connection is established between Emacs and Lisp. Finally a REPL buffer -is created where you can enter Lisp expressions for evaluation. - - The second alternative uses 'M-x sly-connect'. This assumes that -that a Slynk server is running on some local or remote host, and -listening on a given port. 'M-x sly-connect' prompts the user for these -values, and upon connection the REPL is established. - - -File: sly.info, Node: Basic customization, Next: Multiple Lisps, Prev: Running, Up: Getting started - -2.5 Basic customization -======================= - -A big part of Emacs, and Emacs’s extensions, are its near-infinite -customization possibilities. SLY is no exception, because it runs on -both Emacs and the Lisp process, there are layers of Emacs-side -customization and Lisp-side customization. But don’t be put off by -this! SLY tries hard to provide sensible defaults that don’t "hide" any -fanciness beneath layers of complicated code, so that even a setup with -no customization at all exposes SLY’s most important functionality. - - Emacs-side customization is usually done via Emacs-lisp code snippets -added to the user’s initialization file, usually '$HOME/.emacs' or -'$HOME/.emacs.d/init.el' (*note Emacs Init File::). - - 90% of Emacs-lisp customization happens in either "keymaps" or -"hooks" (*note Emacs-side::). Still on the Emacs side, there is also a -separate interface, appropriately called 'customize' (or sometimes just -'custom'), that uses a nicer UI with mouse-clickable buttons to set some -special variables. See *Note Defcustom variables::. - - Lisp-side customization is done exclusively via Common Lisp code -snippets added to the user’s '$HOME/.slynkrc' file. See *Note Lisp-side -customization::. - - As a preview, take this simple example of a frequently customized -part of SLY: its keyboard shortcuts, known as "keybindings". In the -following snippet 'M-h' is added to 'sly-prefix-map' thus yielding 'C-c -M-h' as a shortcut to the 'sly-documentation-lookup' command. - - (eval-after-load 'sly - `(define-key sly-prefix-map (kbd "M-h") 'sly-documentation-lookup)) - - -File: sly.info, Node: Multiple Lisps, Prev: Basic customization, Up: Getting started - -2.6 Multiple Lisps -================== - -By default, the command 'M-x sly' starts the program specified with -'inferior-lisp-program', a variable that you can customize (*note -Defcustom variables::). However, if you invoke 'M-x sly' with a _prefix -argument_, meaning you type 'C-u M-x sly' then Emacs prompts for the -program which should be started instead. - - If you need to do this frequently or if the command involves long -filenames it's more convenient to set the 'sly-lisp-implementations' -variable in your initialization file (*note Emacs Init File::). For -example here we define two programs: - - (setq sly-lisp-implementations - '((cmucl ("cmucl" "-quiet")) - (sbcl ("/opt/sbcl/bin/sbcl") :coding-system utf-8-unix))) - - Now, if you invoke SLY with a _negative_ prefix argument, 'M-- M-x -sly', you can select a program from that list. When called without a -prefix, either the name specified in 'sly-default-lisp', or the first -item of the list will be used. The elements of the list should look -like - - (NAME (PROGRAM PROGRAM-ARGS...) &key CODING-SYSTEM INIT INIT-FUNCTION ENV) - -'NAME' - is a symbol and is used to identify the program. -'PROGRAM' - is the filename of the program. Note that the filename can contain - spaces. -'PROGRAM-ARGS' - is a list of command line arguments. -'CODING-SYSTEM' - the coding system for the connection. (*note - sly-net-coding-system::)x -'INIT' - should be a function which takes two arguments: a filename and a - character encoding. The function should return a Lisp expression - as a string which instructs Lisp to start the Slynk server and to - write the port number to the file. At startup, SLY starts the Lisp - process and sends the result of this function to Lisp's standard - input. As default, 'sly-init-command' is used. An example is - shown in *note Loading Slynk faster: init-example. -'INIT-FUNCTION' - should be a function which takes no arguments. It is called after - the connection is established. (See also *note - sly-connected-hook::.) -'ENV' - specifies a list of environment variables for the subprocess. E.g. - (sbcl-cvs ("/home/me/sbcl-cvs/src/runtime/sbcl" - "--core" "/home/me/sbcl-cvs/output/sbcl.core") - :env ("SBCL_HOME=/home/me/sbcl-cvs/contrib/")) - initializes 'SBCL_HOME' in the subprocess. - - -File: sly.info, Node: A SLY tour for SLIME users, Next: Working with source files, Prev: Getting started, Up: Top - -3 A SLY tour for SLIME users -**************************** - -The chances are that if you’re into Common Lisp, you already know about -SLIME, the project that originated SLY. Itself originating in older -Emacs extensions SLIM and ILISP, SLIME has been around for at least a -decade longer than SLY and is quite an amazing IDE. It's likely that -most Lispers have some experience with it, making it a good idea to -provide, in the shape of a quick tutorial, a hands-on overview of some -of the improvements of SLY over SLIME. - - When you start SLY with 'M-x sly' (*note Basic setup::) you are -greeted with its REPL, a common starting point of Lisp hacking sessions. -This has been completely redesigned in SLY: you can spawn multiple REPL -sessions with 'sly-mrepl-new'; copy objects from most places directly -into it (with 'M-RET' and 'M-S-RET'); use powerful incremental history -search (with 'C-r') found in most modern shells; and get real-time -assistance when "backreferecing" previous evaluation values in your Lisp -input. - - - - - - Starting from the new REPL, let's showcase some of SLY’s features. -Let’s pretend we want to hack an existing Lisp project. We'll pick SLY -itself, or rather its Lisp server, called Slynk. Let's pretend we're -intrigued by the way its "flex"-style completion works. What is flex -completion, you ask? Well, if you're at the REPL you can try it now: -it's a way of 'TAB'-completing (*note Completion::) symbol names based -on educated guesses of a few letters. Thus if we type 'mvbind', SLY -guesses that we probably meant 'multiple-value-bind', and if we type -'domat' it might possibly guess 'cl-ppcre:do-matches'. Let's dig into -the code that makes this happen. - - But how? Where to begin, given we know so little about this project? - - Well, a good starting point is always the _apropos_ functionality, -which is a 'grep' of sorts, but aware of the symbols loaded in your -Lisp, rather the contents of text files. Furthermore, in SLY, -'sly-apropos' will do a regular-expression-enabled symbol search, which -will help us here since we don't yet know any symbols names of this -mysterious flex feature. - - To enable regular expression searches you need the 'CL-PPCRE' library -is loaded (else 'sly-apropos' falls back to regex-less mode). If you -have Quicklisp (https://www.quicklisp.org/beta/) installed (you do, -right?) you need only type '(ql:quickload :cl-ppcre)' now from the -REPL. - - Thus, if we want to hack SLY's flex completion, and _don't_ known any -of its symbol's names, we type 'C-c C-d C-z' (the shortcut for 'M-x -sly-apropos-all') and then type in "sly.*flex" at the prompt. We follow -with 'enter' or 'return' (abbreviated 'RET' or 'C-m'). SLY should now -present all Lisp symbols matching your search pattern. - - - - - - In the 'apropos' buffer, let’s grab the mouse and right-click the -symbol 'SLYNK-COMPLETIONS:FLEX-COMPLETIONS'. We’ll be presented with a -context menu with options for describing the symbol, inspecting it, or -navigating to its source definition. In general, the Lisp-side objects -that SLY presents -- symbols, CLOS objects, function calls, etc... -- -are right-clickable buttons with such a context menu (*note Interactive -objects::). For now, let’s navigate to the source definition of the -symbol by choosing "Go To source" from the menu. Alternatively, we -could also have just pressed 'M-.' on the symbol, of course. - - From the Lisp source buffer that we landed on (probably -'slynk-completion.lisp'), let’s _trace_ the newly found function -'SLYNK-COMPLETIONS:FLEX-COMPLETIONS'. However, instead of using the -regular 'CL:TRACE', we’ll use SLY’s Trace Dialog functionality. This is -how we set it up: - - 1. first type 'C-c C-t' on the function’s name, or enter that in the - minibuffer prompt; - - 2. now, open the Trace Dialog in a new window by typing 'C-c T' - (that’s a capital 'T'). We should already see our traced function - under the heading "Traced specs"; - - 3. thirdly, for good measure, let’s also trace the nearby function - 'SLYNK-COMPLETIONS::FLEX-SCORE' by also typing 'C-c C-t' on its - name, or just entering it in the minibuffer prompt. - - Now let’s return to the REPL by switching to its '*sly-mrepl ...' -buffer or typing 'C-c C-z'. To exercise the code we just traced, let’s -type something like 'desbind', followed by tab, and see if it suggest -'destructuring-bind' as the top match. We could now select some -completion from the list, but instead let's just type 'C-g' to dismiss -the completion, since we wanted to test completion, not write any actual -'destructuring-bind' expression. - - Remember the traced functions in the Trace Dialog? Time to see if we -got any traces. let's type 'C-c T' to switch to that buffer, and then -type capital 'G'. This should produce a fair number of traces organized -in a call graph. - - - - - - We can later learn more about this mode (*note Trace Dialog::), but -for now let’s again pretend we expected the function 'FLEX-SCORE' to -return a wildly different score for 'COMMON-LISP:DESTRUCTURING-BIND'. -In that case we should like to witness said 'FLEX-SCORE' function -respond to any implementation improvements we perform. To do so, it's -useful to be able to surgically re-run that function with those very -same arguments. Let's do this by finding the function call in the Trace -Dialog window, right-clicking it with the mouse and selecting "Copy call -to REPL". Pressing 'M-S-RET' on it should accomplish the same. We are -automatically transported to the REPL again, where the desired function -call has already been typed out for us at the command prompt, awaiting a -confirmation 'RET', which will run the function call: - - ; The actual arguments passed to trace 15 - "desbind" - "COMMON-LISP:DESTRUCTURING-BIND" - (12 13 14 26 27 28 29) - SLYNK-COMPLETION> (slynk-completion::flex-score #v1:0 #v1:1 #v1:2) - 0.003030303 (0.30303028%) - SLYNK-COMPLETION> - - - - - - If those '#v...''s look odd, here’s what’s going on: to copy the call -to the REPL, SLY first copied over its actual arguments, and then wrote -the function using special _backreferences_ to those arguments in the -correct place. These are the '#v4:0' and '#v4:1' bits seen at the -command prompt. If one puts the cursor on them or hovers with the -mouse, this highlights the corresponding object a few lines above in the -buffer. Later, you can also try typing "#v" at the REPL to -incrementally write your own backreferences (*note REPL -backreferences::). - - For one final demonstration, let’s now suppose say we are still -intrigued by how that function ('FLEX-SCORE') works internally. So -let's navigate to its definition using 'M-.' again (or just open the -'slynk-completion.lisp' buffer that you probably still have open). The -function’s code might look like this: - - (defun flex-score (pattern string indexes) - "Score the match of PATTERN on STRING. - INDEXES as calculated by FLEX-MATCHES" - ;; FIXME: hideously naive scoring - (declare (ignore pattern)) - (float - (/ 1 - (* (length string) - (max 1 - (reduce #'+ - (loop for (a b) on indexes - while b - collect (- b a 1)))))))) - - Can this function be working correctly? What do all those -expressions return? Should we reach for good old C-style 'printf'? -Let's try "stickers" instead. SLY's stickers are a form of -non-intrusive function instrumentation that work like carefully crafted -'print' or '(format t ...)'), but are much easier to work with. You can -later read more about them (*note Stickers::), but for now you can just -think of them as colorful labels placed on s-exp’s. Let’s place a bunch -here, like this: - - 1. on the last line of 'flex-score', place your cursor on the first - open parenthesis of that line (the opening parenthesis of the - expression '(- b a 1)') and press 'C-c C-s C-s'; - - 2. now do the same for the symbol 'indexes' a couple of lines above; - - 3. again, the same for the expressions '(loop...)', '(reduce...)', - '(max...)', '(length...)', '(*...)', '(/... )' and '(float...)'. - You could have done this in any order, by the way; - - Now let’s recompile this definition with 'C-c C-c'. Beside the -minibuffer note something about stickers being "armed" our function -should now look like a rainbow in blue. - - - - - - Now we return to the SLY REPL, but this time let’s use 'C-c ~' -(that’s 'C-c' followed by "tilde") to do so. This syncs the REPL’s -local package and local directory to the Lisp file that we’re visiting. -This is something not strictly necessary here but generally convenient -when hacking on a system, because you can now call functions from the -file you came from without package-qualification. - - Now, to re-run the newly instrumented function, by calling it with -the same arguments. No need to type all that again, because this REPL -supports reverse history i-search, remember? So just type the binding -'C-r' and then type something like 'scor' to search history backwards -and arrive at the function call copied to the REPL earlier. Type 'RET' -once to confirm that's the call your after, and 'RET' again to evaluate -it. Because those '#v...' backreferences are still trained specifically -on those very same function arguments, you can be sure that the function -call is equivalent. - - We can now use the 'C-c C-s C-r' to _replay_ the sticker recordings -of this last function call. This is a kind of slow walk-through -conducted in separate navigation window called '*sly-stickers-replay*' -which pops up. There we can see the Lisp value(s) that each sticker -'eval'’ed to each time (or a note if it exited non-locally). We can -navigate recordings with 'n' and 'p', and do the usual things allowed by -interactive objects like inspecting them and returning them to the REPL. -If you need help, toggle help by typing 'h'. There are lots of options -here for navigating stickers, ignoring some stickers, etc. When we’re -done in this window, we press 'q' to quit. - - - - - - Finally, we declare that we’re finished debugging 'FLEX-MATCHES'. -Even though stickers don’t get saved to the file in any way, we decide -we’re not interested in them anymore. So let’s open the "SLY" menu in -the menu bar, find the "Delete stickers from top-level form" option -under the "Stickers" sub-menu, and click it. Alternatively, we could -have typed 'C-u C-c C-s C-s'. - - -File: sly.info, Node: Working with source files, Next: Common functionality, Prev: A SLY tour for SLIME users, Up: Top - -4 Working with source files -*************************** - -SLY's commands when editing a Lisp file are provided via -'sly-editing-mode', a minor-mode used in conjunction with Emacs's -'lisp-mode'. - - This chapter describes SLY’s commands for editing and working in Lisp -source buffers. There are, of course, more SLY’s commands that also -apply to these buffers (*note Common functionality::), but with very few -exceptions these commands will always be run from a '.lisp' file. - -* Menu: - -* Evaluation:: -* Compilation:: -* Autodoc:: -* Semantic indentation:: -* Reader conditionals:: -* Macro-expansion:: - - -File: sly.info, Node: Evaluation, Next: Compilation, Up: Working with source files - -4.1 Evaluating code -=================== - -These commands each evaluate a Common Lisp expression in a different -way. Usually they mimic commands for evaluating Emacs Lisp code. By -default they show their results in the echo area, but a prefix argument -'C-u' inserts the results into the current buffer, while a negative -prefix argument 'M--' sends them to the kill ring. - -'C-x C-e' -'M-x sly-eval-last-expression' - - Evaluate the expression before point and show the result in the - echo area. - -'C-M-x' -'M-x sly-eval-defun' - Evaluate the current toplevel form and show the result in the echo - area. 'C-M-x' treats 'defvar' expressions specially. Normally, - evaluating a 'defvar' expression does nothing if the variable it - defines already has a value. But 'C-M-x' unconditionally resets - the variable to the initial value specified in the 'defvar' - expression. This special feature is convenient for debugging Lisp - programs. - - If 'C-M-x' or 'C-x C-e' is given a numeric argument, it inserts the -value into the current buffer, rather than displaying it in the echo -area. - -'C-c :' -'M-x sly-interactive-eval' - Evaluate an expression read from the minibuffer. - -'C-c C-r' -'M-x sly-eval-region' - Evaluate the region. - -'C-c C-p' -'M-x sly-pprint-eval-last-expression' - Evaluate the expression before point and pretty-print the result in - a fresh buffer. - -'C-c E' -'M-x sly-edit-value' - Edit the value of a setf-able form in a new buffer '*Edit <form>*'. - The value is inserted into a temporary buffer for editing and then - set in Lisp when committed with 'C-c C-c'. - -'C-c C-u' -'M-x sly-undefine-function' - Undefine the function, with 'fmakunbound', for the symbol at point. - - -File: sly.info, Node: Compilation, Next: Autodoc, Prev: Evaluation, Up: Working with source files - -4.2 Compiling functions and files -================================= - -SLY has fancy commands for compiling functions, files, and packages. -The fancy part is that notes and warnings offered by the Lisp compiler -are intercepted and annotated directly onto the corresponding -expressions in the Lisp source buffer. (Give it a try to see what this -means.) - -'C-c C-c' -'M-x sly-compile-defun' - Compile the top-level form at point. The region blinks shortly to - give some feedback which part was chosen. - - With (positive) prefix argument the form is compiled with maximal - debug settings ('C-u C-c C-c'). With negative prefix argument it - is compiled for speed ('M-- C-c C-c'). If a numeric argument is - passed set debug or speed settings to it depending on its sign. - - The code for the region is executed after compilation. In - principle, the command writes the region to a file, compiles that - file, and loads the resulting code. - - This compilation may arm stickers (*note Stickers::). - -'C-c C-k' -'M-x sly-compile-and-load-file' - Compile and load the current buffer's source file. If the - compilation step fails, the file is not loaded. It's not always - easy to tell whether the compilation failed: occasionally you may - end up in the debugger during the load step. - - With (positive) prefix argument the file is compiled with maximal - debug settings ('C-u C-c C-k'). With negative prefix argument it - is compiled for speed ('M-- C-c C-k'). If a numeric argument is - passed set debug or speed settings to it depending on its sign. - - This compilation may arm stickers (*note Stickers::). - -'C-c M-k' -'M-x sly-compile-file' - Compile (but don't load) the current buffer's source file. - -'C-c C-l' -'M-x sly-load-file' - Load a Lisp file. This command uses the Common Lisp LOAD function. - -'M-x sly-compile-region' - Compile the selected region. - - This compilation may arm stickers (*note Stickers::). - - The annotations are indicated as underlining on source forms. The -compiler message associated with an annotation can be read either by -placing the mouse over the text or with the selection commands below. - -'M-n' -'M-x sly-next-note' - Move the point to the next compiler note and displays the note. - -'M-p' -'M-x sly-previous-note' - Move the point to the previous compiler note and displays the note. - -'C-c M-c' -'M-x sly-remove-notes' - Remove all annotations from the buffer. - -'C-x `' -'M-x next-error' - Visit the next-error message. This is not actually a SLY command - but SLY creates a hidden buffer so that most of the Compilation - mode commands (*note (emacs)Compilation Mode::) work similarly for - Lisp as for batch compilers. - - -File: sly.info, Node: Autodoc, Next: Semantic indentation, Prev: Compilation, Up: Working with source files - -4.3 Autodoc -=========== - -SLY automatically shows information about symbols near the point. For -function names the argument list is displayed, and for global variables, -the value. Autodoc is implemented by means of 'eldoc-mode' of Emacs. - -'M-x sly-arglist NAME' - Show the argument list of the function NAME. - -'M-x sly-autodoc-mode' - Toggles autodoc-mode on or off according to the argument, and - toggles the mode when invoked without argument. -'M-x sly-autodoc-manually' - Like sly-autodoc, but when called twice, or after sly-autodoc was - already automatically called, display multiline arglist. - - If 'sly-autodoc-use-multiline-p' is set to non-nil, allow long -autodoc messages to resize echo area display. - - 'autodoc-mode' is a SLY extension and can be turned off if you so -wish (*note Extensions::) - - -File: sly.info, Node: Semantic indentation, Next: Reader conditionals, Prev: Autodoc, Up: Working with source files - -4.4 Semantic indentation -======================== - -SLY automatically discovers how to indent the macros in your Lisp -system. To do this the Lisp side scans all the macros in the system and -reports to Emacs all the ones with '&body' arguments. Emacs then -indents these specially, putting the first arguments four spaces in and -the "body" arguments just two spaces, as usual. - - This should "just work." If you are a lucky sort of person you -needn't read the rest of this section. - - To simplify the implementation, SLY doesn't distinguish between -macros with the same symbol-name but different packages. This makes it -fit nicely with Emacs's indentation code. However, if you do have -several macros with the same symbol-name then they will all be indented -the same way, arbitrarily using the style from one of their arglists. -You can find out which symbols are involved in collisions with: - - (slynk:print-indentation-lossage) - - If a collision causes you irritation, don't have a nervous breakdown, -just override the Elisp symbol's 'sly-common-lisp-indent-function' -property to your taste. SLY won't override your custom settings, it -just tries to give you good defaults. - - A more subtle issue is that imperfect caching is used for the sake of -performance. (1) - - In an ideal world, Lisp would automatically scan every symbol for -indentation changes after each command from Emacs. However, this is too -expensive to do every time. Instead Lisp usually just scans the symbols -whose home package matches the one used by the Emacs buffer where the -request comes from. That is sufficient to pick up the indentation of -most interactively-defined macros. To catch the rest we make a full -scan of every symbol each time a new Lisp package is created between -commands - that takes care of things like new systems being loaded. - - You can use 'M-x sly-update-indentation' to force all symbols to be -scanned for indentation information. - - ---------- Footnotes ---------- - - (1) _Of course_ we made sure it was actually too slow before making -the ugly optimization. - - -File: sly.info, Node: Reader conditionals, Next: Macro-expansion, Prev: Semantic indentation, Up: Working with source files - -4.5 Reader conditional fontification -==================================== - -SLY automatically evaluates reader-conditional expressions, like -'#+linux', in source buffers and "grays out" code that will be skipped -for the current Lisp connection. - - -File: sly.info, Node: Macro-expansion, Prev: Reader conditionals, Up: Working with source files - -4.6 Macro-expansion commands -============================ - -'C-c C-m' -'M-x sly-expand-1' - Macroexpand (or compiler-macroexpand) the expression at point once. - If invoked with a prefix argument use macroexpand instead or - macroexpand-1 (or compiler-macroexpand instead of - compiler-macroexpand-1). - -'M-x sly-macroexpand-1' - Macroexpand the expression at point once. If invoked with a prefix - argument, use macroexpand instead of macroexpand-1. - -'C-c M-m' -'M-x sly-macroexpand-all' - Fully macroexpand the expression at point. - -'M-x sly-compiler-macroexpand-1' - Display the compiler-macro expansion of sexp at point. - -'M-x sly-compiler-macroexpand' - Repeatedly expand compiler macros of sexp at point. - -'M-x sly-format-string-expand' - Expand the format-string at point and display it. With prefix arg, - or if no string at point, prompt the user for a string to expand. - - Within a sly macroexpansion buffer some extra commands are provided -(these commands are always available but are only bound to keys in a -macroexpansion buffer). - -'C-c C-m' -'M-x sly-macroexpand-1-inplace' - Just like sly-macroexpand-1 but the original form is replaced with - the expansion. - -'g' -'M-x sly-macroexpand-1-inplace' - The last macroexpansion is performed again, the current contents of - the macroexpansion buffer are replaced with the new expansion. - -'q' -'M-x sly-temp-buffer-quit' - Close the expansion buffer. - -'C-_' -'M-x sly-macroexpand-undo' - Undo last macroexpansion operation. - - -File: sly.info, Node: Common functionality, Next: The REPL and other special buffers, Prev: Working with source files, Up: Top - -5 Common functionality -********************** - -This chapter describes the commands available throughout SLY-enabled -buffers, which are not only Lisp source buffers, but every auxiliary -buffer created by SLY, such as the REPL, Inspector, etc (*note The REPL -and other special buffers::) In general, it’s a good bet that if the -buffer’s name starts with '*sly-...*', these commands and functionality -will be available there. - -* Menu: - -* Finding definitions:: -* Cross-referencing:: -* Completion:: -* Interactive objects:: -* Documentation:: -* Multiple connections:: -* Disassembly:: -* Recovery:: -* Temporary buffers:: -* Multi-threading:: - - -File: sly.info, Node: Finding definitions, Next: Cross-referencing, Up: Common functionality - -5.1 Finding definitions -======================= - -One of the most used keybindings across all of SLY is the familiar 'M-.' -binding for 'sly-edit-definition'. - - Here's the gist of it: when pressed with the cursor over a symbol -name, that symbol's name definition is looked up by the Lisp process, -thus producing a Lisp source location, which might be a file, or a -file-less buffer. For convenience, a type of "breadcrumb" is left -behind at the original location where 'M-.' was pressed, so that another -keybinding 'M-,' takes the user back to the original location. Thus -multiple 'M-.' trace a path through lisp sources that can be traced back -with an equal number of 'M-,'. - -'M-.' -'M-x sly-edit-definition' - Go to the definition of the symbol at point. - -'M-,' -'M-*' -'M-x sly-pop-find-definition-stack' - Go back to the point where 'M-.' was invoked. This gives - multi-level backtracking when 'M-.' has been used several times. - -'C-x 4 .' -'M-x sly-edit-definition-other-window' - Like 'sly-edit-definition' but switches to the other window to edit - the definition in. - -'C-x 5 .' -'M-x sly-edit-definition-other-frame' - Like 'sly-edit-definition' but opens another frame to edit the - definition in. - - The behaviour of the 'M-.' binding is sometimes affected by the type -of symbol you are giving it. - - * For single functions or variables, 'M-.' immediately switches the - current window's buffer and position to the target 'defun' or - 'defvar'. - - * For symbols with more than one associated definition, say, generic - functions, the same 'M-.' finds all methods and presents these - results in separate window displaying a special '*sly-xref*' buffer - (*note Cross-referencing::). - - -File: sly.info, Node: Cross-referencing, Next: Completion, Prev: Finding definitions, Up: Common functionality - -5.2 Cross-referencing -===================== - -Finding and presenting the definition of a function is actually the most -elementary aspect of broader _cross-referencing_ facilities framework in -SLY. There are other types of questions about the source code relations -that you can ask the Lisp process.(1) - - The following keybindings behave much like the 'M-.' keybinding -(*note Finding definitions::): when pressed as is they make a query -about the symbol at point, but with a 'C-u' prefix argument they prompt -the user for a symbol. Importantly, they always popup a transient -'*sly-xref*' buffer in a different window. - -'M-?' -'M-x sly-edit-uses' - Find all the references to this symbol, whatever the type of that - reference. - -'C-c C-w C-c' -'M-x sly-who-calls' - Show function callers. - -'C-c C-w C-w' -'M-x sly-calls-who' - Show all known callees. - -'C-c C-w C-r' -'M-x sly-who-references' - Show references to global variable. - -'C-c C-w C-b' -'M-x sly-who-binds' - Show bindings of a global variable. - -'C-c C-w C-s' -'M-x sly-who-sets' - Show assignments to a global variable. - -'C-c C-w C-m' -'M-x sly-who-macroexpands' - Show expansions of a macro. - -'M-x sly-who-specializes' - Show all known methods specialized on a class. - - There are two further "List callers/callees" commands that operate by -rummaging through function objects on the heap at a low-level to -discover the call graph. They are only available with some Lisp -systems, and are most useful as a fallback when precise XREF information -is unavailable. - -'C-c <' -'M-x sly-list-callers' - List callers of a function. - -'C-c >' -'M-x sly-list-callees' - List callees of a function. - - In the resulting '*sly-xref*' buffer, these commands are available: - -'RET' -'M-x sly-show-xref' - Show definition at point in the other window. Do not leave the - '*sly-xref' buffer. - -'Space' -'M-x sly-goto-xref' - Show definition at point in the other window and close the - '*sly-xref' buffer. - -'C-c C-c' -'M-x sly-recompile-xref' - Recompile definition at point. Uses prefix arguments like - 'sly-compile-defun'. - -'C-c C-k' -'M-x sly-recompile-all-xrefs' - Recompile all definitions. Uses prefix arguments like - 'sly-compile-defun'. - - ---------- Footnotes ---------- - - (1) This depends on the underlying implementation of some of these -facilities: for systems with no built-in XREF support SLY queries a -portable XREF package, which is taken from the 'CMU AI Repository' and -bundled with SLY. - - -File: sly.info, Node: Completion, Next: Interactive objects, Prev: Cross-referencing, Up: Common functionality - -5.3 Auto-completion -=================== - -Completion commands are used to complete a symbol or form based on what -is already present at point. Emacs has many completion mechanisms that -SLY tries to mimic as much as possible. - - SLY provides two styles of completion. The choice between them -happens in the Emacs customization variable *note -sly-complete-symbol-function::, which can be set to two values, or -methods: - - 1. 'sly-flex-completions' This method is speculative. It assumes that - the letters you've already typed aren't necessarily an exact prefix - of the symbol you're thinking of. Therefore, any possible - completion that contains these letters, in the order that you have - typed them, is potentially a match. Completion matches are then - sorted according to a score that should reflect the probability - that you really meant that them. - - Flex completion implies that the package-qualification needed to - access some symbols is automatically discovered for you. However, - to avoid searching too many symbols unnecessarily, this method - makes some minimal assumptions that you can override: it assumes, - for example, that you don't normally want to complete to fully - qualified internal symbols, but will do so if it finds two - consecutive colons ('::') in your initial pattern. Similarly, it - assumes that if you start a completion on a word starting ':', you - must mean a keyword (a symbol from the keyword package.) - - Here are the top results for some typical searches. - - CL-USER> (quiloa<TAB>) -> (ql:quickload) - CL-USER> (mvbind<TAB>) -> (multiple-value-bind) - CL-USER> (scan<TAB>) -> (ppcre:scan) - CL-USER> (p::scan<TAB>) -> (ppcre::scanner) - CL-USER> (setf locadirs<TAB>) -> (setf ql:*local-project-directories*) - CL-USER> foobar -> asdf:monolithic-binary-op - - 2. 'sly-simple-completions' This method uses "classical" completion on - an exact prefix. Although poorer, this is simpler, more - predictable and closer to the default Emacs completion method. You - type a prefix for a symbol reference and SLY let's you choose from - symbols whose beginnings match it exactly. - - As an enhancement in SLY over Emacs' built-in completion styles, when -the '*sly-completions*' buffer pops up, some keybindings are momentarily -diverted to it: - -'C-n' -'<down>' -'M-x sly-next-completion' - Select the next completion. - -'C-p' -'<up>' -'M-x sly-prev-completion' - Select the previous completion. - -'tab' -'RET' -'M-x sly-choose-completion' - Choose the currently selected completion and enter it at point. - - As soon as the user selects a completion or gives up by pressing -'C-g' or moves out of the symbol being completed, the -'*sly-completions*' buffer is closed. - - -File: sly.info, Node: Interactive objects, Next: Documentation, Prev: Completion, Up: Common functionality - -5.4 Interactive objects -======================= - -In many buffers and modes in SLY, there are snippets of text that -represent objects "living" in the Lisp process connected to SLY. These -regions are known in SLY as interactive values or objects. You can tell -these objects from regular text by their distinct "face", is Emacs -parlance for text colour, or decoration. Another way to check if bit of -text is an interactive object is to hover above it with the mouse and -right-click ('<mouse-3>') it: a context menu will appear listing actions -that you can take on that object. - - Depending on the mode, different actions may be active for different -types of objects. Actions can also be invoked using keybindings active -only when the cursor is on the button. - -'M-RET, ``Copy to REPL''' - - Copy the object to the main REPL (*note REPL output:: and *note - REPL backreferences::). - -'M-S-RET, ``Copy call to REPL''' - - An experimental feature. On some backtrace frames in the Debugger - (*note Debugger::) and Trace Dialog (*note Trace Dialog::), copy - the object to the main REPL. That’s _meta-shift-return_, by the - way, there’s no capital "S". - -'.,''Go To Source''' - - For function symbols, debugger frames, or traced function calls, go - to the Lisp source, much like with 'M-.'. - -'v,''Show Source''' - - For function symbols, debugger frames, or traced function calls, - show the Lisp source in another window, but don’t switch to it. - -'p,''Pretty Print''' - - Pretty print the object in a separate buffer, much like - 'sly-pprint-eval-last-expression'. - -'i,''Inspect''' - - Inspect the object in a separate inspector buffer (*note - Inspector::). - -'d,''Describe''' - - Describe the object in a separate buffer using Lisp’s - 'CL:DESCRIBE'. - - -File: sly.info, Node: Documentation, Next: Multiple connections, Prev: Interactive objects, Up: Common functionality - -5.5 Documentation commands -========================== - -SLY's online documentation commands follow the example of Emacs Lisp. -The commands all share the common prefix 'C-c C-d' and allow the final -key to be modified or unmodified (*note Keybindings::.) - -'M-x sly-info' - This command should land you in an electronic version of this very - manual that you can read inside Emacs. - -'C-c C-d C-d' -'M-x sly-describe-symbol' - Describe the symbol at point. - -'C-c C-d C-f' -'M-x sly-describe-function' - Describe the function at point. - -'C-c C-d C-a' -'M-x sly-apropos' - Perform an apropos search on Lisp symbol names for a regular - expression match and display their documentation strings. By - default the external symbols of all packages are searched. With a - prefix argument you can choose a specific package and whether to - include unexported symbols. - -'C-c C-d C-z' -'M-x sly-apropos-all' - Like 'sly-apropos' but also includes internal symbols by default. - -'C-c C-d C-p' -'M-x sly-apropos-package' - Show apropos results of all symbols in a package. This command is - for browsing a package at a high-level. With package-name - completion it also serves as a rudimentary Smalltalk-ish - image-browser. - -'C-c C-d C-h' -'M-x sly-hyperspec-lookup' - Lookup the symbol at point in the 'Common Lisp Hyperspec'. This - uses the familiar 'hyperspec.el' to show the appropriate section in - a web browser. The Hyperspec is found either on the Web or in - 'common-lisp-hyperspec-root', and the browser is selected by - 'browse-url-browser-function'. - - Note: this is one case where 'C-c C-d h' is _not_ the same as 'C-c - C-d C-h'. - -'C-c C-d ~' -'M-x hyperspec-lookup-format' - Lookup a _format character_ in the 'Common Lisp Hyperspec'. - -'C-c C-d #' -'M-x hyperspec-lookup-reader-macro' - Lookup a _reader macro_ in the 'Common Lisp Hyperspec'. - - -File: sly.info, Node: Multiple connections, Next: Disassembly, Prev: Documentation, Up: Common functionality - -5.6 Multiple connections -======================== - -SLY is able to connect to multiple Lisp processes at the same time. The -'M-x sly' command, when invoked with a prefix argument, will offer to -create an additional Lisp process if one is already running. This is -often convenient, but it requires some understanding to make sure that -your SLY commands execute in the Lisp that you expect them to. - - Some SLY buffers are tied to specific Lisp processes. It’s easy read -that from the buffer’s name which will usually be '*sly-<something> for -<connection>*', where 'connection' is the name of the connection. - - Each Lisp connection has its own main REPL buffer (*note REPL::), and -all expressions entered or SLY commands invoked in that buffer are sent -to the associated connection. Other buffers created by SLY are -similarly tied to the connections they originate from, including SLY-DB -buffers (*note Debugger::), apropos result listings, and so on. These -buffers are the result of some interaction with a Lisp process, so -commands in them always go back to that same process. - - Commands executed in other places, such as 'sly-mode' source buffers, -always use the "default" connection. Usually this is the most recently -established connection, but this can be reassigned via the "connection -list" buffer: - -'C-c C-x c' -'M-x sly-list-connections' - Pop up a buffer listing the established connections. - -'C-c C-x n' -'M-x sly-next-connection' - Switch to the next Lisp connection by cycling through all - connections. - -'C-c C-x p' -'M-x sly-prev-connection' - Switch to the previous Lisp connection by cycling through all - connections. - - The buffer displayed by 'sly-list-connections' gives a one-line -summary of each connection. The summary shows the connection's serial -number, the name of the Lisp implementation, and other details of the -Lisp process. The current "default" connection is indicated with an -asterisk. - - The commands available in the connection-list buffer are: - -'RET' -'M-x sly-goto-connection' - Pop to the REPL buffer of the connection at point. - -'d' -'M-x sly-connection-list-make-default' - Make the connection at point the "default" connection. It will - then be used for commands in 'sly-mode' source buffers. - -'g' -'M-x sly-update-connection-list' - Update the connection list in the buffer. - -'q' -'M-x sly-temp-buffer-quit' - Quit the connection list (kill buffer, restore window - configuration). - -'R' -'M-x sly-restart-connection-at-point' - Restart the Lisp process for the connection at point. - -'M-x sly-connect' - Connect to a running Slynk server. With prefix argument, asks if - all connections should be closed first. - -'M-x sly-disconnect' - Disconnect all connections. - -'M-x sly-abort-connection' - Abort the current attempt to connect. - - -File: sly.info, Node: Disassembly, Next: Recovery, Prev: Multiple connections, Up: Common functionality - -5.7 Disassembly commands -======================== - -'C-c M-d' -'M-x sly-disassemble-symbol' - Disassemble the function definition of the symbol at point. - -'C-c C-t' -'M-x sly-toggle-trace-fdefinition' - Toggle tracing of the function at point. If invoked with a prefix - argument, read additional information, like which particular method - should be traced. - -'M-x sly-untrace-all' - Untrace all functions. - - -File: sly.info, Node: Recovery, Next: Temporary buffers, Prev: Disassembly, Up: Common functionality - -5.8 Abort/Recovery commands -=========================== - -'C-c C-b' -'M-x sly-interrupt' - Interrupt Lisp (send 'SIGINT'). - -'M-x sly-restart-inferior-lisp' - Restart the 'inferior-lisp' process. - -'C-c ~' -'M-x sly-mrepl-sync' - Synchronize the current package and working directory from Emacs to - Lisp. - -'M-x sly-cd' - Set the current directory of the Lisp process. This also changes - the current directory of the REPL buffer. - -'M-x sly-pwd' - Print the current directory of the Lisp process. - - -File: sly.info, Node: Temporary buffers, Next: Multi-threading, Prev: Recovery, Up: Common functionality - -5.9 Temporary buffers -===================== - -Some SLY commands create temporary buffers to display their results. -Although these buffers usually have their own special-purpose -major-modes, certain conventions are observed throughout. - - Temporary buffers can be dismissed by pressing 'q'. This kills the -buffer and restores the window configuration as it was before the buffer -was displayed. Temporary buffers can also be killed with the usual -commands like 'kill-buffer', in which case the previous window -configuration won't be restored. - - Pressing 'RET' is supposed to "do the most obvious useful thing." -For instance, in an apropos buffer this prints a full description of the -symbol at point, and in an XREF buffer it displays the source code for -the reference at point. This convention is inherited from Emacs's own -buffers for apropos listings, compilation results, etc. - - Temporary buffers containing Lisp symbols use 'sly-mode' in addition -to any special mode of their own. This makes the usual SLY commands -available for describing symbols, looking up function definitions, and -so on. - - Initial focus of those "description" buffers depends on the variable -'sly-description-autofocus'. If 'nil' (the default), description -buffers do not receive focus automatically, and vice versa. - - -File: sly.info, Node: Multi-threading, Prev: Temporary buffers, Up: Common functionality - -5.10 Multi-threading -==================== - -If the Lisp system supports multi-threading, SLY spawns a new thread for -each request, e.g., 'C-x C-e' creates a new thread to evaluate the -expression. An exception to this rule are requests from the REPL: all -commands entered in the REPL buffer are evaluated in a dedicated REPL -thread. - - You can see a listing of the threads for the current connection with -the command 'M-x sly-list-threads', or 'C-c C-x t'. This pops open a -'*sly-threads*' buffer, where some keybindings to control threads are -active, if you know what you are doing. The most useful is probably 'k' -to kill a thread, but type 'C-h m' in that buffer to get a full listing. - - Some complications arise with multi-threading and special variables. -Non-global special bindings are thread-local, e.g., changing the value -of a let bound special variable in one thread has no effect on the -binding of the variables with the same name in other threads. This -makes it sometimes difficult to change the printer or reader behaviour -for new threads. The variable 'slynk:*default-worker-thread-bindings*' -was introduced for such situations: instead of modifying the global -value of a variable, add a binding the -'slynk:*default-worker-thread-bindings*'. E.g., with the following -code, new threads will read floating point values as doubles by default: - - (push '(*read-default-float-format* . double-float) - slynk:*default-worker-thread-bindings*). - - -File: sly.info, Node: The REPL and other special buffers, Next: Customization, Prev: Common functionality, Up: Top - -6 The REPL and other special buffers -************************************ - -* Menu: - -* REPL:: -* Inspector:: -* Debugger:: -* Trace Dialog:: -* Stickers:: - - -File: sly.info, Node: REPL, Next: Inspector, Up: The REPL and other special buffers - -6.1 The REPL: the "top level" -============================= - -SLY uses a custom Read-Eval-Print Loop (REPL, also known as a "top -level", or listener): - - * Conditions signalled in REPL expressions are debugged with the - integrated SLY debugger. - * Return values are interactive values (*note Interactive objects::) - distinguished from printed output by separate Emacs faces (colors). - * Output from the Lisp process is inserted in the right place, and - doesn't get mixed up with user input. - * Multiple REPLs are possible in the same Lisp connection. This is - useful for performing quick one-off experiments in different - packages or directories without disturbing the state of an existing - REPL. - * The REPL is a central hub for much of SLY's functionality, since - objects examined in the inspector (*note Inspector::), debugger - (*note Debugger::), and other extensions can be returned there. - - Switching to the REPL from anywhere in a SLY buffer is a very common -task. One way to do it is to find the '*sly-mrepl...*' buffer in -Emacs’s buffer list, but there are other ways to reach a REPL. - -'C-c C-z' -'M-x sly-mrepl' - Start or select an existing main REPL buffer. - -'M-x sly-mrepl-new' - Start a new secondary REPL session, prompting for a nickname. - -'C-c ~' -'M-x sly-mrepl-sync' - Go to the REPL, switching package and default directory as - applicable. More precisely the Lisp variables '*package*' and - '*default-pathname-defaults*' are affected by the location where - the command was issued. In a specific position of a '.lisp' file, - for instance the current package and that file’s directory are - chosen. - -* Menu: - -* REPL commands:: -* REPL output:: -* REPL backreferences:: - - -File: sly.info, Node: REPL commands, Next: REPL output, Up: REPL - -6.1.1 REPL commands -------------------- - -'RET' -'M-x sly-mrepl-return' - - Evaluate the expression at prompt and return the result. - -'TAB' -'M-x sly-mrepl-indent-and-complete-symbol' - - Indent the current line. If line already indented complete the - symbol at point (*note Completion::). If there is not symbol at - point show the argument list of the most recently enclosed function - or macro in the minibuffer. - -'M-p' -'M-x sly-mrepl-previous-input-or-button' - - When at the current prompt, fetches previous input from the - history, otherwise jumps to the previous interactive value (*note - Interactive objects::) representing a Lisp object. - -'M-n' -'M-x sly-mrepl-next-input-or-button' - - When at the current prompt, fetches next input from the history, - otherwise jumps to the previous interactive value representing a - Lisp object. - -'C-r' -'M-x isearch-backward' - - This regular Emacs keybinding, when invoked at the current REPL - prompt, starts a special transient mode turning the prompt into the - string "History-isearch backward". While in this mode, the user - can compose a string used to search backwards through history, and - reverse the direction of search by pressing 'C-s'. When invoked - outside the current REPL prompt, does a normal text search through - the buffer contents. - -'C-c C-b' -'M-x sly-interrupt' - - Interrupts the current thread of the inferior-lisp process. - - For convenience this function is also bound to 'C-c C-c'. - -'C-M-p' -'M-x sly-button-backward' - - Jump to the previous interactive value representing a Lisp object. - -'C-M-n' -'M-x sly-button-forward' - - Jump to the next interactive value representing a Lisp object. - -'C-c C-o' -'M-x sly-mrepl-clear-recent-output' - - Clear output between current and last REPL prompts, keeping - results. - -'C-c M-o' -'M-x sly-mrepl-clear-repl' - - Clear the whole REPL of output and results. - - -File: sly.info, Node: REPL output, Next: REPL backreferences, Prev: REPL commands, Up: REPL - -6.1.2 REPL output ------------------ - -REPLs wouldn’t be much use if they just took user input and didn’t print -anything back. In SLY the output printed to the REPL can come from four -different places: - - * A function’s return values. One line per return value is printed. - Each line of printed text, called a REPL result, persists after - more expressions are evaluated, and is actually a button (*note - Interactive objects::) presenting the Lisp-side object. You can, - for instance, inspect it (*note Inspector::) or re-return it to - right before the current command prompt so that you may conjure it - up again, as usual in Lisp REPLs, with the special variable '*'. - - In the SLY REPL, in addition to the '*', '**' and '***' special - variables, return values can also be accessed through a special - backreference (*note REPL backreferences::). - - * An object may be copied to the REPL from some other part in SLY, - such as the Inspector (*note Inspector::), Debugger (*note - Debugger::), etc. using the familiar 'M-RET' binding, or by - selecting "Copy to REPL" from the context menu of an interactive - object. Aside from not having been produced by the evaluation of a - Lisp form in the REPL, these objects behaves exactly like a REPL - result. - - * The characters printed to the standard Lisp streams - '*standard-output*', '*error-output*' and '*trace-output*' as a - _synchronous_ and direct result of the evaluation of an expression - in the REPL. - - * The characters printed to the standard Lisp streams - '*standard-output*', '*error-output*' and '*trace-output*' printed, - perhaps _asynchronously_, from others threads, for instance. This - feature is optional and controlled by the variable - 'SLYNK:*GLOBALLY-REDIRECT-IO*'. - -For advanced users, there are some Lisp-side Slynk variables affecting -the way Slynk transmits REPL output to SLY. - -'SLYNK:*GLOBALLY-REDIRECT-IO*' - - This variable controls the global redirection of the the standard - streams ('*standard-output*', etc) to the REPL in Emacs. The - default value is ':started-from-emacs', which means that - redirection should only take place upon 'M-x sly' invocations. - When 't', global redirection happens even for sessions started with - 'M-x sly-connect', meaning output may be diverted from wherever you - started the Lisp server originally. - - When 'NIL' these streams are only temporarily redirected to Emacs - using dynamic bindings while handling requests, meaning you only - see output caused by the commands you issued to the REPL. - - Note that '*standard-input*' is currently never globally redirected - into Emacs, because it can interact badly with the Lisp's native - REPL by having it try to read from the Emacs one. - - Also note that secondary REPLs (those started with 'sly-mrepl-new') - don’t receive any redirected output. - -'SLYNK:*USE-DEDICATED-OUTPUT-STREAM*' - - This variable controls whether to use a separate socket solely for - Lisp to send printed output to Emacs through, which is more - efficient than sending the output in protocol messages to Emacs. - - The default value is ':started-from-emacs', which means that the - socket should only be established upon 'M-x sly' invocations. When - 't', it's established even for sessions started with 'M-x - sly-connect'. When 'NIL' usual protocol messages are used for - sending input to the REPL. - - Notice that using a dedicated output stream makes it more difficult - to communicate to a Lisp running on a remote host via SSH (*note - Connecting to a remote Lisp::). If you connect via 'M-x - sly-connect', the default ':started-from-emacs' value should ensure - this isn't a problem. - -'SLYNK:*DEDICATED-OUTPUT-STREAM-PORT*' - - When '*USE-DEDICATED-OUTPUT-STREAM*' is 't' the stream will be - opened on this port. The default value, '0', means that the stream - will be opened on some random port. - -'SLYNK:*DEDICATED-OUTPUT-STREAM-BUFFERING*' - - For efficiency, some Lisps backends wait until a certain conditions - are met in a Lisp character stream before flushing that stream’s - contents, thus sending it to the SLY REPL. Be advised that this - sometimes works poorly on some implementations, so it’s probably - best to leave alone. Possible values are 'nil' (no buffering), 't' - (enable buffering) or ':line' (enable buffering on EOL) - - -File: sly.info, Node: REPL backreferences, Prev: REPL output, Up: REPL - -6.1.3 REPL backreferences -------------------------- - -In a regular Lisp REPL, the objects produced by evaluating expressions -at the command prompt can usually be referenced in future commands using -the special variables '*', '**' and '***'. This is also true of the SLY -REPL, but it also provides a different way to re-conjure these objects -through a special Lisp reader macro character available only in the -REPL. The macro character, which is '#v' by default takes, in a terse -syntax, two indexes specifying the precise objects in all of the SLY -REPL’s recorded history. - - Consider this fragment of a REPL session: - - ; Cleared REPL history - CL-USER> (values 'a 'b 'c) - A - B - C - CL-USER> (list #v0) - (A) - CL-USER> (list #v0:1 #v0:2) - (B C) - CL-USER> (append #v1:0 #v2:0) - (A B C) - CL-USER> - -Admittedly, while useful, this doesn’t seem terribly easy to use at -first sight. There are a couple of reasons, however, that should make -it worth considering: - - * Backreference annotation and highlighting - - As soon as the SLY REPL detects that you have pressed '#v', all the - REPL results that can possibly be referenced are temporarily - annotated on their left with two special numbers. These numbers - are in the syntax accepted by the '#v' macro-character, namely - '#vENTRY-IDX:VALUE-IDX'. - - Furthermore, as soon as you type a number for 'ENTRY-IDX', only - that entries values remain highlighted. Then, as you finish the - entry with 'VALUE-IDX', only that exact object remains highlighted. - If you make a mistake (say, by typing a letter or an invalid - number) while composing '#v' syntax, SLY lets you know by painting - the backreference red. - - Highlighting also happens when you place the cursor over existing - valid '#v' expressions. - - * Returning functions calls - - An experimental feature in SLY allows copying _function calls_ to - the REPL from the Debugger (*note Debugger::) and the Trace Dialog - (*note Trace Dialog::). In those buffers, pressing keybinding - 'M-S-RET' over objects that represent function calls will copy the - _call_, and not the object, to the REPL. This works by first - copying over the argument objects in order to the REPL results, and - then composing an input line that includes the called function's - name and backreferences to those arguments (*note REPL - backreferences::). - - Naturally, this call isn't _exactly_ the same because it doesn’t - evaluate in the same dynamic environment as the original one. But - it's a useful debug technique because backreferences are stable - (1), so repeating that very same function call with the very same - arguments is just a matter of textually copying the previous - expression into the command prompt, no matter how far ago it - happened. And that, in turn, is as easy as using 'C-r' and some - characters (*note REPL commands::) to arrive and repeat the desired - REPL history entry. - - ---------- Footnotes ---------- - - (1) until you clear the REPL’s output, that is - - -File: sly.info, Node: Inspector, Next: Debugger, Prev: REPL, Up: The REPL and other special buffers - -6.2 The Inspector -================= - -The SLY inspector is a Emacs-based alternative to the standard 'INSPECT' -function. The inspector presents objects in Emacs buffers using a -combination of plain text, hyperlinks to related objects. - - The inspector can easily be specialized for the objects in your own -programs. For details see the 'inspect-for-emacs' generic function in -'slynk-backend.lisp'. - -'C-c I' -'M-x sly-inspect' - Inspect the value of an expression entered in the minibuffer. - - The standard commands available in the inspector are: - -'RET' -'M-x sly-inspector-operate-on-point' - If point is on a value then recursively call the inspector on that - value. If point is on an action then call that action. - -'D' -'M-x sly-inspector-describe-inspectee' - Describe the slot at point. - -'e' -'M-x sly-inspector-eval' - Evaluate an expression in the context of the inspected object. The - variable '*' will be bound to the inspected object. - -'v' -'M-x sly-inspector-toggle-verbose' - Toggle between verbose and terse mode. Default is determined by - 'slynk:*inspector-verbose*'. - -'l' -'M-x sly-inspector-pop' - Go back to the previous object (return from 'RET'). - -'n' -'M-x sly-inspector-next' - The inverse of 'l'. Also bound to 'SPC'. - -'g' -'M-x sly-inspector-reinspect' - Reinspect. - -'h' -'M-x sly-inspector-history' - Show the previously inspected objects. - -'q' -'M-x sly-inspector-quit' - Dismiss the inspector buffer. - -'>' -'M-x sly-inspector-fetch-all' - Fetch all inspector contents and go to the end. - -'M-RET' -'M-x sly-mrepl-copy-part-to-repl' - Store the value under point in the variable '*'. This can then be - used to access the object in the REPL. - -'TAB, M-x forward-button' -'S-TAB, M-x backward-button' - - Jump to the next and previous inspectable object respectively. - - -File: sly.info, Node: Debugger, Next: Trace Dialog, Prev: Inspector, Up: The REPL and other special buffers - -6.3 The SLY-DB Debugger -======================= - -SLY has a custom Emacs-based debugger called SLY-DB. Conditions -signalled in the Lisp system invoke SLY-DB in Emacs by way of the Lisp -'*DEBUGGER-HOOK*'. - - SLY-DB pops up a buffer when a condition is signalled. The buffer -displays a description of the condition, a list of restarts, and a -backtrace. Commands are offered for invoking restarts, examining the -backtrace, and poking around in stack frames. - -* Menu: - -* Examining frames:: -* Restarts:: -* Frame Navigation:: -* Miscellaneous:: - - -File: sly.info, Node: Examining frames, Next: Restarts, Up: Debugger - -6.3.1 Examining frames ----------------------- - -Commands for examining the stack frame at point. - -'t' -'M-x sly-db-toggle-details' - Toggle display of local variables and 'CATCH' tags. - -'v' -'M-x sly-db-show-frame-source' - View the frame's current source expression. The expression is - presented in the Lisp source file's buffer. - -'e' -'M-x sly-db-eval-in-frame' - Evaluate an expression in the frame. The expression can refer to - the available local variables in the frame. - -'d' -'M-x sly-db-pprint-eval-in-frame' - Evaluate an expression in the frame and pretty-print the result in - a temporary buffer. - -'D' -'M-x sly-db-disassemble' - Disassemble the frame's function. Includes information such as the - instruction pointer within the frame. - -'i' -'M-x sly-db-inspect-in-frame' - Inspect the result of evaluating an expression in the frame. - -'C-c C-c' -'M-x sly-db-recompile-frame-source' - Recompile frame. 'C-u C-c C-c' for recompiling with maximum debug - settings. - - -File: sly.info, Node: Restarts, Next: Frame Navigation, Prev: Examining frames, Up: Debugger - -6.3.2 Invoking restarts ------------------------ - -'a' -'M-x sly-db-abort' - Invoke the 'ABORT' restart. - -'q' -'M-x sly-db-quit' - "Quit" - For SLY evaluation requests, invoke a restart which - restores to a known program state. For errors in other threads, - *Note *SLY-DB-QUIT-RESTART*::. - -'c' -'M-x sly-db-continue' - Invoke the 'CONTINUE' restart. - -'0 ... 9' -'M-x sly-db-invoke-restart-n' - Invoke a restart by number. - - Restarts can also be invoked by pressing 'RET' or 'Mouse-2' on them -in the buffer. - - -File: sly.info, Node: Frame Navigation, Next: Miscellaneous, Prev: Restarts, Up: Debugger - -6.3.3 Navigating between frames -------------------------------- - -'n, M-x sly-db-down' -'p, M-x sly-db-up' - Move between frames. - -'M-n, M-x sly-db-details-down' -'M-p, M-x sly-db-details-up' - Move between frames "with sugar": hide the details of the original - frame and display the details and source code of the next. Sugared - motion makes you see the details and source code for the current - frame only. - -'>' -'M-x sly-db-end-of-backtrace' - Fetch the entire backtrace and go to the last frame. - -'<' -'M-x sly-db-beginning-of-backtrace' - Go to the first frame. - - -File: sly.info, Node: Miscellaneous, Prev: Frame Navigation, Up: Debugger - -6.3.4 Miscellaneous Commands ----------------------------- - -'r' -'M-x sly-db-restart-frame' - Restart execution of the frame with the same arguments it was - originally called with. (This command is not available in all - implementations.) - -'R' -'M-x sly-db-return-from-frame' - Return from the frame with a value entered in the minibuffer. - (This command is not available in all implementations.) - -'B' -'M-x sly-db-break-with-default-debugger' - Exit SLY-DB and debug the condition using the Lisp system's default - debugger. - -'C' -'M-x sly-db-inspect-condition' - Inspect the condition currently being debugged. - -':' -'M-x sly-interactive-eval' - Evaluate an expression entered in the minibuffer. -'A' -'M-x sly-db-break-with-system-debugger' - Attach debugger (e.g. gdb) to the current lisp process. - - -File: sly.info, Node: Trace Dialog, Next: Stickers, Prev: Debugger, Up: The REPL and other special buffers - -6.4 Trace Dialog -================ - -The SLY Trace Dialog, in package 'sly-trace-dialog', is a tracing -facility, similar to Common Lisp's 'trace', but interactive rather than -purely textual. - - You use it just like you would regular 'trace': after tracing a -function, calling it causes interesting information about that -particular call to be reported. - - However, instead of printing the trace results to the the -'*trace-output*' stream (usually the REPL), the SLY Trace Dialog -collects and stores them in your Lisp environment until, on user's -request, they are fetched into Emacs and displayed in a dialog-like -interactive view. - - After starting up SLY, SLY's Trace Dialog installs a _Trace_ menu in -the menu-bar of any 'sly-mode' buffer and adds two new commands, with -respective key-bindings: - -'C-c C-t' -'M-x sly-trace-dialog-toggle-trace' - If point is on a symbol name, toggle tracing of its function - definition. If point is not on a symbol, prompt user for a - function. - - With a 'C-u' prefix argument, and if your lisp implementation - allows it, attempt to decipher lambdas, methods and other - complicated function signatures. - - The function is traced for the SLY Trace Dialog only, i.e. it is - not found in the list returned by Common Lisp's 'trace'. - -'C-c T' -'M-x sly-trace-dialog' - Pop to the interactive Trace Dialog buffer associated with the - current connection (*note Multiple connections::). - - Consider the (useless) program: - - (defun foo (n) (if (plusp n) (* n (bar (1- n))) 1)) - (defun bar (n) (if (plusp n) (* n (foo (1- n))) 1)) - - After tracing both 'foo' and 'bar' with 'C-c M-t', calling call '(foo -2)' and moving to the trace dialog with 'C-c T', we are presented with -this buffer. - - Traced specs (2) [refresh] - [untrace all] - [untrace] common-lisp-user::bar - [untrace] common-lisp-user::foo - - Trace collection status (3/3) [refresh] - [clear] - - 0 - common-lisp-user::foo - | > 2 - | < 2 - 1 `--- common-lisp-user::bar - | > 1 - | < 1 - 2 `-- common-lisp-user::foo - > 0 - < 1 - - The dialog is divided into sections displaying the functions already -traced, the trace collection progress and the actual trace tree that -follow your program's logic. The most important key-bindings in this -buffer are: - -'g' -'M-x sly-trace-dialog-fetch-status' - Update information on the trace collection and traced specs. -'G' -'M-x sly-trace-dialog-fetch-traces' - Fetch the next batch of outstanding (not fetched yet) traces. With - a 'C-u' prefix argument, repeat until no more outstanding traces. -'C-k' -'M-x sly-trace-dialog-clear-fetched-traces' - Prompt for confirmation, then clear all traces, both fetched and - outstanding. - - The arguments and return values below each entry are interactive -buttons. Clicking them opens the inspector (*note Inspector::). -Invoking 'M-RET' ('sly-trace-dialog-copy-down-to-repl') returns them to -the REPL for manipulation (*note REPL::). The number left of each entry -indicates its absolute position in the calling order, which might differ -from display order in case multiple threads call the same traced -function. - - 'sly-trace-dialog-hide-details-mode' hides arguments and return -values so you can concentrate on the calling logic. Additionally, -'sly-trace-dialog-autofollow-mode' will automatically display additional -detail about an entry when the cursor moves over it. - - -File: sly.info, Node: Stickers, Prev: Trace Dialog, Up: The REPL and other special buffers - -6.5 Stickers -============ - -SLY Stickers, implemented as the 'sly-stickers' contrib (*note -Extensions::), is a tool for "live" code annotations. It's an -alternative to the 'print' or 'break' statements you add to your code -when debugging. - - Contrary to these techniques, "stickers" are non-intrusive, meaning -that saving your file doesn't save your debug code along with it. - - Here's the general workflow: - - * In Lisp source files, using 'C-c C-s C-s' or 'M-x - sly-stickers-dwim' places a sticker on any Lisp form. Stickers can - exist inside other stickers. - - - - - - * Stickers are "armed" when a definition or a file is compiled with - the familiar 'C-c C-c' ('M-x sly-compile-defun') or 'C-c C-k' ('M-x - sly-compile-file') commands. An armed sticker changes color from - the default grey background to a blue background. - - - - - - From this point on, when the Lisp code is executed, the results of -evaluating the underlying forms are captured in the Lisp side. Stickers -help you examine your program's behaviour in three ways: - 1. 'C-c C-s C-r' (or 'M-x sly-stickers-replay') interactively walks - the user through recordings in the order that they occurred. In - the created '*sly-stickers-replay*' buffer, type 'h' for a list of - keybindings active in that buffer. - - - - - - 2. To step through stickers as your code is executed, ensure that - "breaking stickers" are enabled via 'M-x - sly-stickers-toggle-break-on-stickers'. Whenever a sticker-covered - expression is reached, the debugger comes up with useful restarts - and interactive for the values produced. You can tweak this - behaviour by setting the Lisp-side variable - 'SLYNK-STICKERS:*BREAK-ON-STICKERS*' to a list with the elements - ':before' and ':after', making SLY break before a sticker, after - it, or both. - - - - - - 3. 'C-c C-s S' ('M-x sly-stickers-fetch') populates the sticker - overlay with the latest captured results, called "recordings". If - a sticker has captured any recordings, it will turn green, - otherwise it will turn red. A sticker whose Lisp expression has - caused a non-local exit, will be also be marked with a special - face. - - - - - - At any point, stickers can be removed with the same -'sly-stickers-dwim' keybinding, by placing the cursor at the beginning -of a sticker. Additionally adding prefix arguments to -'sly-stickers-dwim' increase its scope, so 'C-u C-c C-s C-s' will remove -all stickers from the current function and 'C-u C-u C-c C-s C-s' will -remove all stickers from the current file. - - Stickers can be nested inside other stickers, so it is possible to -record the value of an expression inside another expression which is -also annotated. - - Stickers are interactive parts just like any other part in SLY that -represents Lisp-side objects, so they can be inspected and returned to -the REPL, for example. To move through the stickers with the keyboard -use the existing keybindings to move through compilation notes ('M-p' -and 'M-n') or use 'C-c C-s p' and 'C-c C-s n' -('sly-stickers-prev-sticker' and 'sly-stickers-next-sticker'). - - There are some caveats when using SLY Stickers: - - * Stickers on unevaluated forms (such as 'let' variable bindings, or - other constructs) are rejected, though the function is still - compiled as usual. To let the user know about this, these stickers - remain grey, and are marked as "disarmed". A message also appears - in the echo area. - * Stickers placed on expressions inside backquoted expressions in - macros are always armed, even though they may come to provoke a - runtime error when the macro's expansion is run. Think of this - when setting a sticker inside a macro definition. - - -File: sly.info, Node: Customization, Next: Tips and Tricks, Prev: The REPL and other special buffers, Up: Top - -7 Customization -*************** - -* Menu: - -* Emacs-side:: -* Lisp-side customization:: - - -File: sly.info, Node: Emacs-side, Next: Lisp-side customization, Up: Customization - -7.1 Emacs-side -============== - -* Menu: - -* Keybindings:: -* Keymaps:: -* Defcustom variables:: -* Hooks:: - - -File: sly.info, Node: Keybindings, Next: Keymaps, Up: Emacs-side - -7.1.1 Keybindings ------------------ - -In general we try to make our key bindings fit with the overall Emacs -style. - - We never bind 'C-h' anywhere in a key sequence. This is because -Emacs has a built-in default so that typing a prefix followed by 'C-h' -will display all bindings starting with that prefix, so 'C-c C-d C-h' -will actually list the bindings for all documentation commands. This -feature is just a bit too useful to clobber! - - "Are you deliberately spiting Emacs's brilliant online help - facilities? The gods will be angry!" - -This is a brilliant piece of advice. The Emacs online help facilities -are your most immediate, up-to-date and complete resource for keybinding -information. They are your friends: - -'C-h k <key>' - 'describe-key' "What does this key do?" - Describes current function bound to '<key>' for focus buffer. - -'C-h b' - 'describe-bindings' "Exactly what bindings are available?" - Lists the current key-bindings for the focus buffer. - -'C-h m' - 'describe-mode' "Tell me all about this mode" - Shows all the available major mode keys, then the minor mode keys, - for the modes of the focus buffer. - -'C-h l' - 'view-lossage' "Woah, what key chord did I just do?" - Shows you the literal sequence of keys you've pressed in order. - - For example, you can add one of the following to your Emacs init file -(usually '~/.emacs' or '~/.emacs.d/init.el', but *note Init File: -(emacs)Init File.). - - (eval-after-load 'sly - `(define-key sly-prefix-map (kbd "M-h") 'sly-documentation-lookup)) - - SLY comes bundled with many extensions (called "contribs" for -historical reasons, *note Extensions::) which you can customize just -like SLY's code. To make 'C-c C-c' clear the last REPL prompt's output, -for example, use - - (eval-after-load 'sly-mrepl - `(define-key sly-mrepl-mode-map (kbd "C-c C-k") - 'sly-mrepl-clear-recent-output)) - - -File: sly.info, Node: Keymaps, Next: Defcustom variables, Prev: Keybindings, Up: Emacs-side - -7.1.2 Keymaps -------------- - -Emacs’s keybindings "live" in keymap variables. To customize a -particular binding and keep it from trampling on other important keys -you should do it in one of SLY's keymaps. The following non-exhaustive -list of SLY-related keymaps is just a reference: the manual will go over -each associated functionality in detail. - -'sly-doc-map' - - Keymap for documentation commands (*note Documentation::) in - SLY-related buffers, accessible by the 'C-c C-d' prefix. - -'sly-who-map' - - Keymap for cross-referencing ("who-calls") commands (*note - Cross-referencing::) in SLY-related buffers, accessible by the 'C-c - C-w' prefix. - -'sly-selector-map' - - A keymap for SLY-related functionality that should be available in - globally in all Emacs buffers (not just SLY-related buffers). - -'sly-mode-map' - - A keymap for functionality available in all SLY-related buffers. - -'sly-editing-mode-map' - - A keymap for SLY functionality available in Lisp source files. - -'sly-popup-buffer-mode-map' - - A keymap for functionality available in the temporary "popup" - buffers that SLY displays (*note Temporary buffers::) - -'sly-apropos-mode-map' - - A keymap for functionality available in the temporary SLY "apropos" - buffers (*note Documentation::). - -'sly-xref-mode-map' - - A keymap for functionality available in the temporary 'xref' - buffers used by cross-referencing commands (*note - Cross-referencing::). - -'sly-macroexpansion-minor-mode-map' - - A keymap for functionality available in the temporary buffers used - for macroexpansion presentation (*note Macro-expansion::). - -'sly-db-mode-map' - - A keymap for functionality available in the debugger buffers used - to debug errors in the Lisp process (*note Debugger::). - -'sly-thread-control-mode-map' - - A keymap for functionality available in the SLY buffers dedicated - to controlling Lisp threads (*note Multi-threading::). - -'sly-connection-list-mode-map' - - A keymap for functionality available in the SLY buffers dedicated - to managing multiple Lisp connections (*note Multiple - connections::). - -'sly-inspector-mode-map' - - A keymap for functionality available in the SLY buffers dedicated - to inspecting Lisp objects (*note Inspector::). - -'sly-mrepl-mode-map' - - A keymap for functionality available in SLY’s REPL buffers (*note - REPL::). - -'sly-trace-dialog-mode-map' - - A keymap for functionality available in SLY’s "Trace Dialog" - buffers (*note Trace Dialog::). - - -File: sly.info, Node: Defcustom variables, Next: Hooks, Prev: Keymaps, Up: Emacs-side - -7.1.3 Defcustom variables -------------------------- - -The Emacs part of SLY can be configured with the Emacs 'customize' -system, just use 'M-x customize-group sly RET'. Because the customize -system is self-describing, we only cover a few important or obscure -configuration options here in the manual. - -'sly-truncate-lines' - The value to use for 'truncate-lines' in line-by-line summary - buffers popped up by SLY. This is 't' by default, which ensures - that lines do not wrap in backtraces, apropos listings, and so on. - It can however cause information to spill off the screen. - -'sly-complete-symbol-function' - The function to use for completion of Lisp symbols. Two completion - styles are available: 'sly-simple-completions' and - 'sly-flex-completions' (*note Completion::). - -'sly-filename-translations' - This variable controls filename translation between Emacs and the - Lisp system. It is useful if you run Emacs and Lisp on separate - machines which don't share a common file system or if they share - the filesystem but have different layouts, as is the case with - SMB-based file sharing. - -'sly-net-coding-system' - If you want to transmit Unicode characters between Emacs and the - Lisp system, you should customize this variable. E.g., if you use - SBCL, you can set: - (setq sly-net-coding-system 'utf-8-unix) - To actually display Unicode characters you also need appropriate - fonts, otherwise the characters will be rendered as hollow boxes. - If you are using Allegro CL and GNU Emacs, you can also use - 'emacs-mule-unix' as coding system. GNU Emacs has often nicer - fonts for the latter encoding. (Different encodings can be used - for different Lisps, see *note Multiple Lisps::.) - -'sly-keep-buffers-on-connection-close' - This variable holds a list of keywords indicating SLY buffer types - that should be kept around when a connection closes. For example, - if the variable's value includes ':mrepl' (which is the default), - REPL buffer is kept around while all other stale buffers (debugger, - inspector, etc..) are automatically killed. - - The following customization variables affect the behaviour of the -REPL (*note REPL::): - -'sly-mrepl-shortcut' - The key to use to trigger the REPL's "comma shortcut". We - recommend you keep the default setting which is the comma (',') - key, since there's special logic in the REPL to discern if you're - typing a comma inside a backquoted list or not. - -'sly-mrepl-prompt-formatter' - Holds a function that can be set from your Emacs init file (*note - Init File: (emacs)Init File.) to change the way the prompt is - rendered. It takes a number of arguments describing the prompt and - should return a propertized Elisp string. See the default value, - 'sly-mrepl-default-prompt', for how to implement such a prompt. - -'sly-mrepl-history-file-name' - Holds a string designating the file to use for keeping the shared - REPL histories persistently. The default is to use a hidden file - named '.sly-mrepl-history' in the user's home directory. - -'sly-mrepl-prevent-duplicate-history' - A symbol. If non-nil, prevent duplicate entries in input history. - If the non-nil value is the symbol 'move', the previously occuring - entry is moved to a more recent spot. - -'sly-mrepl-eli-like-history-navigation' - If non-NIL, navigate history like in ELI, Franz's Common Lisp IDE - for Emacs. - - -File: sly.info, Node: Hooks, Prev: Defcustom variables, Up: Emacs-side - -7.1.4 Hooks ------------ - -'sly-mode-hook' - This hook is run each time a buffer enters 'sly-mode'. It is most - useful for setting buffer-local configuration in your Lisp source - buffers. An example use is to enable 'sly-autodoc-mode' (*note - Autodoc::). - -'sly-connected-hook' - This hook is run when SLY establishes a connection to a Lisp - server. An example use is to pop to a new REPL. - -'sly-db-hook' - This hook is run after SLY-DB is invoked. The hook functions are - called from the SLY-DB buffer after it is initialized. An example - use is to add 'sly-db-print-condition' to this hook, which makes - all conditions debugged with SLY-DB be recorded in the REPL buffer. - - -File: sly.info, Node: Lisp-side customization, Prev: Emacs-side, Up: Customization - -7.2 Lisp-side (Slynk) -===================== - -The Lisp server side of SLY (known as "Slynk") offers several variables -to configure. The initialization file '~/.slynk.lisp' is automatically -evaluated at startup and can be used to set these variables. - -* Menu: - -* Communication style:: -* Other configurables:: - - -File: sly.info, Node: Communication style, Next: Other configurables, Up: Lisp-side customization - -7.2.1 Communication style -------------------------- - -The most important configurable is 'SLYNK:*COMMUNICATION-STYLE*', which -specifies the mechanism by which Lisp reads and processes protocol -messages from Emacs. The choice of communication style has a global -influence on SLY's operation. - - The available communication styles are: - -'NIL' - This style simply loops reading input from the communication socket - and serves SLY protocol events as they arise. The simplicity means - that the Lisp cannot do any other processing while under SLY's - control. - -':FD-HANDLER' - This style uses the classical Unix-style "'select()'-loop." Slynk - registers the communication socket with an event-dispatching - framework (such as 'SERVE-EVENT' in CMUCL and SBCL) and receives a - callback when data is available. In this style requests from Emacs - are only detected and processed when Lisp enters the event-loop. - This style is simple and predictable. - -':SIGIO' - This style uses "signal-driven I/O" with a 'SIGIO' signal handler. - Lisp receives requests from Emacs along with a signal, causing it - to interrupt whatever it is doing to serve the request. This style - has the advantage of responsiveness, since Emacs can perform - operations in Lisp even while it is busy doing other things. It - also allows Emacs to issue requests concurrently, e.g. to send one - long-running request (like compilation) and then interrupt that - with several short requests before it completes. The disadvantages - are that it may conflict with other uses of 'SIGIO' by Lisp code, - and it may cause untold havoc by interrupting Lisp at an awkward - moment. - -':SPAWN' - This style uses multiprocessing support in the Lisp system to - execute each request in a separate thread. This style has similar - properties to ':SIGIO', but it does not use signals and all - requests issued by Emacs can be executed in parallel. - - The default request handling style is chosen according to the -capabilities of your Lisp system. The general order of preference is -':SPAWN', then ':SIGIO', then ':FD-HANDLER', with 'NIL' as a last -resort. You can check the default style by calling -'SLYNK-BACKEND::PREFERRED-COMMUNICATION-STYLE'. You can also override -the default by setting 'SLYNK:*COMMUNICATION-STYLE*' in your Slynk init -file (*note Lisp-side customization::). - - -File: sly.info, Node: Other configurables, Prev: Communication style, Up: Lisp-side customization - -7.2.2 Other configurables -------------------------- - -These Lisp variables can be configured via your '~/.slynk.lisp' file: - -'SLYNK:*CONFIGURE-EMACS-INDENTATION*' - This variable controls whether indentation styles for - '&body'-arguments in macros are discovered and sent to Emacs. It - is enabled by default. - -'SLYNK:*GLOBAL-DEBUGGER*' - When true (the default) this causes '*DEBUGGER-HOOK*' to be - globally set to 'SLYNK:SLYNK-DEBUGGER-HOOK' and thus for SLY to - handle all debugging in the Lisp image. This is for debugging - multithreaded and callback-driven applications. - -'SLYNK:*SLY-DB-QUIT-RESTART*' - This variable names the restart that is invoked when pressing 'q' - (*note sly-db-quit::) in SLY-DB. For SLY evaluation requests this - is _unconditionally_ bound to a restart that returns to a safe - point. This variable is supposed to customize what 'q' does if an - application's thread lands into the debugger (see - 'SLYNK:*GLOBAL-DEBUGGER*'). - (setf slynk:*sly-db-quit-restart* 'sb-thread:terminate-thread) - -'SLYNK:*BACKTRACE-PRINTER-BINDINGS*' -'SLYNK:*MACROEXPAND-PRINTER-BINDINGS*' -'SLYNK:*SLY-DB-PRINTER-BINDINGS*' -'SLYNK:*SLYNK-PPRINT-BINDINGS*' - These variables can be used to customize the printer in various - situations. The values of the variables are association lists of - printer variable names with the corresponding value. E.g., to - enable the pretty printer for formatting backtraces in SLY-DB, you - can use: - - (push '(*print-pretty* . t) slynk:*sly-db-printer-bindings*). - - The fact that most SLY output (in the REPL for instance, *note - REPL::) uses 'SLYNK:*SLYNK-PPRINT-BINDINGS*' may surprise you if - you expected it to use a global setting for, say, '*PRINT-LENGTH*'. - The rationale for this decision is that output is a very basic - feature of SLY, and it should keep operating normally even if you - (mistakenly) set absurd values for some '*PRINT-...*' variable. - You, of course, override this protection: - - (setq slynk:*slynk-pprint-bindings* - (delete '*print-length* - slynk:*slynk-pprint-bindings* :key #'car)) - -'SLYNK:*STRING-ELISION-LENGTH*' -'SLYNK:*STRING-ELISION-LENGTH*' - - This variable controls the maximum length of strings before their - pretty printed representation in the Inspector, Debugger, REPL, etc - is elided. Don't set this variable directly, create a binding for - this variable in 'SLYNK:*SLYNK-PPRINT-BINDINGS*' instead. - -'SLYNK:*ECHO-NUMBER-ALIST*' -'SLYNK:*PRESENT-NUMBER-ALIST*' - These variables hold function designators used for displaying - numbers when SLY presents them in its interface. - - The difference between the two functions is that - '*PRESENT-NUMBER-ALIST*', if non-nil, overrides - '*ECHO-NUMBER-ALIST*' in the context of the REPL, Trace Dialog and - Stickers (see *note REPL::, *note Trace Dialog:: and *note - Stickers::), while the latter is used for commands like 'C-x C-e' - or the inspector (see *note Evaluation::, *note Inspector::). - - If in doubt, use '*ECHO-NUMBER-ALIST*'. - - Both variables have the same structure: each element in the alist - takes the form '(TYPE . FUNCTIONS)', where 'TYPE' is a type - designator and 'FUNCTIONS' is a list of function designators for - displaying that number in SLY. Each function takes the number as a - single argument and returns a string, or nil, if that particular - representation is to be disregarded. - - Additionally if a given function chooses to return 't' as its - optional second value, then all the remaining functions following - it in the list are disregarded. - - For integer numbers, the default value of this variable holds - function designators that echo an integer number in its binary, - hexadecimal and octal representation. However, if your application - is using integers to represent Unix Epoch Times you can use this - function to display a human-readable time whenever you evaluate an - integer. - - (defparameter *day-names* '("Monday" "Tuesday" "Wednesday" - "Thursday" "Friday" "Saturday" - "Sunday")) - - (defun fancy-unix-epoch-time (integer) - "Format INTEGER as a Unix Epoch Time if within 10 years from now." - (let ((now (get-universal-time)) - (tenyears (encode-universal-time 0 0 0 1 1 1910 0)) - (unix-to-universal - (+ integer - (encode-universal-time 0 0 0 1 1 1970 0)))) - (when (< (- now tenyears) unix-to-universal (+ now tenyears)) - (multiple-value-bind - (second minute hour date month year day-of-week dst-p tz) - (decode-universal-time unix-to-universal) - (declare (ignore dst-p)) - (format nil "~2,'0d:~2,'0d:~2,'0d on ~a, ~d/~2,'0d/~d (GMT~@d)" - hour minute second (nth day-of-week *day-names*) - month date year (- tz)))))) - - (pushnew 'fancy-unix-epoch-time - (cdr (assoc 'integer slynk:*echo-number-alist*))) - - 42 ; => 42 (6 bits, #x2A, #o52, #b101010) - 1451404675 ; => 1451404675 (15:57:55 on Tuesday, 12/29/2015 (GMT+0), 31 bits, #x5682AD83) - -'SLYNK-APROPOS:*PREFERRED-APROPOS-MATCHER*' - This variable holds a function used for performing apropos - searches. It defaults to 'SLYNK-APROPOS:MAKE-FLEX-MATCHER', but - can also be set to 'SLYNK-APROPOS:MAKE-CL-PPCRE-MATCHER' (to use a - regex-able matcher) or 'SLYNK-APROPOS:MAKE-PLAIN-MATCHER', for - example. - -'SLYNK:*LOG-EVENTS*' - Setting this variable to 't' causes all protocol messages exchanged - with Emacs to be printed to '*TERMINAL-IO*'. This is useful for - low-level debugging and for observing how SLY works "on the wire." - The output of '*TERMINAL-IO*' can be found in your Lisp system's - own listener, usually in the buffer '*inferior-lisp*'. - - -File: sly.info, Node: Tips and Tricks, Next: Extensions, Prev: Customization, Up: Top - -8 Tips and Tricks -***************** - -* Menu: - -* Connecting to a remote Lisp:: -* Loading Slynk faster:: -* Auto-SLY:: -* REPLs and game loops:: -* Controlling SLY from outside Emacs:: - - -File: sly.info, Node: Connecting to a remote Lisp, Next: Loading Slynk faster, Up: Tips and Tricks - -8.1 Connecting to a remote Lisp -=============================== - -One of the advantages of the way SLY is implemented is that we can -easily run the Emacs side ('sly.el' and friends) on one machine and the -Lisp backend (Slynk) on another. The basic idea is to start up Lisp on -the remote machine, load Slynk and wait for incoming SLY connections. -On the local machine we start up Emacs and tell SLY to connect to the -remote machine. The details are a bit messier but the underlying idea -is that simple. - -* Menu: - -* Setting up the Lisp image:: -* Setting up Emacs:: -* Setting up pathname translations:: - - -File: sly.info, Node: Setting up the Lisp image, Next: Setting up Emacs, Up: Connecting to a remote Lisp - -8.1.1 Setting up the Lisp image -------------------------------- - -The easiest way to load Slynk "standalone" (i.e. without having 'M-x -sly' start a Lisp that is subsidiary to a particular Emacs), is to load -the ASDF system definition for Slynk. - - Make sure the path to the directory containing Slynk's '.asd' file is -in 'ASDF:*CENTRAL-REGISTRY*'. This file lives in the 'slynk' -subdirectory of SLY. Type: - - (push #p"/path/to/sly/slynk/" ASDF:*CENTRAL-REGISTRY*) - (asdf:require-system :slynk) - - inside a running Lisp image(1). - - Now all we need to do is startup our Slynk server. A working example -uses the default settings: - - (slynk:create-server) - - This creates a "one-connection-only" server on port 4005 using the -preferred communication style for your Lisp system. The following -parameters to 'slynk:create-server' can be used to change that -behaviour: - -':PORT' - Port number for the server to listen on (default: 4005). -':DONT-CLOSE' - Boolean indicating if the server will continue to accept - connections after the first one (default: 'NIL'). For - "long-running" Lisp processes to which you want to be able to - connect from time to time, specify ':dont-close t' -':STYLE' - See *Note Communication style::. - - So a more complete example will be - (slynk:create-server :port 4006 :dont-close t) - - Finally, since section we're going to be tunneling our connection via -SSH(2) we'll only have one port open we must tell Slynk's REPL contrib -(see REPL) to not use an extra connection for output, which it will do -by default. - - (setf slynk:*use-dedicated-output-stream* nil) - - (3) - - ---------- Footnotes ---------- - - (1) SLY also SLIME's old-style 'slynk-loader.lisp' loader which does -the same thing, but ASDF is preferred - - (2) there is a way to connect without an SSH tunnel, but it has the -side-effect of giving the entire world access to your Lisp image, so -we're not going to talk about it - - (3) Alternatively, a separate tunnel for the port set in -'slynk:*dedicated-output-stream-port*' can also be used if a dedicated -output is essential. - - -File: sly.info, Node: Setting up Emacs, Next: Setting up pathname translations, Prev: Setting up the Lisp image, Up: Connecting to a remote Lisp - -8.1.2 Setting up Emacs ----------------------- - -Now we need to create the tunnel between the local machine and the -remote machine. Assuming a UNIX command-line, this can be done with: - - ssh -L4005:localhost:4005 youruser@remote.example.com - - This incantation creates a SSH tunnel between the port 4005 on our -local machine and the port 4005 on the remote machine, where 'youruser' -is expected to have an account. (1). - - Finally we start SLY with 'sly-connect' instead of the usual 'sly': - - M-x sly-connect RET RET - - The 'RET RET' sequence just means that we want to use the default -host ('localhost') and the default port ('4005'). Even though we're -connecting to a remote machine the SSH tunnel fools Emacs into thinking -it's actually 'localhost'. - - ---------- Footnotes ---------- - - (1) By default Slynk listens for incoming connections on port 4005, -had we passed a ':port' parameter to 'slynk:create-server' we'd be using -that port number instead - - -File: sly.info, Node: Setting up pathname translations, Prev: Setting up Emacs, Up: Connecting to a remote Lisp - -8.1.3 Setting up pathname translations --------------------------------------- - -One of the main problems with running slynk remotely is that Emacs -assumes the files can be found using normal filenames. if we want -things like 'sly-compile-and-load-file' ('C-c C-k') and -'sly-edit-definition' ('M-.') to work correctly we need to find a way to -let our local Emacs refer to remote files. - - There are, mainly, two ways to do this. The first is to mount, using -NFS or similar, the remote machine's hard disk on the local machine's -file system in such a fashion that a filename like -'/opt/project/source.lisp' refers to the same file on both machines. -Unfortunately NFS is usually slow, often buggy, and not always feasible. -Fortunately we have an ssh connection and Emacs' 'tramp-mode' can do the -rest. (See *note TRAMP User Manual: (tramp)Top.) - - What we do is teach Emacs how to take a filename on the remote -machine and translate it into something that tramp can understand and -access (and vice versa). Assuming the remote machine's host name is -'remote.example.com', 'cl:machine-instance' returns "remote" and we -login as the user "user" we can use 'sly-tramp' contrib to setup the -proper translations by simply doing: - - (add-to-list 'sly-filename-translations - (sly-create-filename-translator - :machine-instance "remote" - :remote-host "remote.example.com" - :username "user")) - - -File: sly.info, Node: Loading Slynk faster, Next: Auto-SLY, Prev: Connecting to a remote Lisp, Up: Tips and Tricks - -8.2 Loading Slynk faster -======================== - -In this section, a technique to load Slynk faster on South Bank Common -Lisp (SBCL) is presented. Similar setups should also work for other -Lisp implementations. - - A pre-canned solution that automates this technique was developed by -Pierre Neidhardt (https://gitlab.com/ambrevar/lisp-repl-core-dumper). - - For SBCL, we recommend that you create a custom core file with socket -support and POSIX bindings included because those modules take the most -time to load. To create such a core, execute the following steps: - - shell$ sbcl - * (mapc 'require '(sb-bsd-sockets sb-posix sb-introspect sb-cltl2 asdf)) - * (save-lisp-and-die "sbcl.core-for-sly") - - After that, add something like this to your '~/.emacs' or -'~/.emacs.d/init.el' (*note Emacs Init File::): - - (setq sly-lisp-implementations '((sbcl ("sbcl" "--core" - "sbcl.core-for-sly")))) - - For maximum startup speed you can include the Slynk server directly -in a core file. The disadvantage of this approach is that the setup is -a bit more involved and that you need to create a new core file when you -want to update SLY or SBCL. The steps to execute are: - - shell$ sbcl - * (load ".../sly/slynk-loader.lisp") - * (slynk-loader:dump-image "sbcl.core-with-slynk") - -Then add this to the Emacs initializion file: - - (setq sly-lisp-implementations - '((sbcl ("sbcl" "--core" "sbcl.core-with-slynk") - :init (lambda (port-file _) - (format "(slynk:start-server %S)\n" port-file))))) - - -File: sly.info, Node: Auto-SLY, Next: REPLs and game loops, Prev: Loading Slynk faster, Up: Tips and Tricks - -8.3 Connecting to SLY automatically -=================================== - -To make SLY connect to your lisp whenever you open a lisp file just add -this to your '~/.emacs' or '~/.emacs.d/init.el' (*note Emacs Init -File::): - - (add-hook 'sly-mode-hook - (lambda () - (unless (sly-connected-p) - (save-excursion (sly))))) - - -File: sly.info, Node: REPLs and game loops, Next: Controlling SLY from outside Emacs, Prev: Auto-SLY, Up: Tips and Tricks - -8.4 REPLs and "Game Loops" -========================== - -When developing Common Lisp video games or graphical applications, a -REPL (*note REPL::) is just as useful as anywhere else. But it is often -the case that one needs to control exactly the timing of REPL requests -and ensure they do not interfere with the "game loop". In other -situations, the choice of communication style (*note Communication -style::) to the Slynk server may invalidate simultaneous multi-threaded -operation of REPL and game loop. - - Instead of giving up on the REPL or using a complicated solution, -SLY's REPL can be built into your game loop by using a couple of Slynk -Common Lisp functions, 'SLYNK-MREPL:SEND-PROMPT' and -'SLYNK:PROCESS-REQUESTS'. - - (defun my-repl-aware-game-loop () - (loop initially - (princ "Starting our game") - (slynk-mrepl:send-prompt) - for i from 0 - do (with-simple-restart (abort "Skip rest of this game loop iteration") - (when (zerop (mod i 10)) - (fresh-line) - (princ "doing high-priority 3D game loop stuff")) - (sleep 0.1) - ;; When you're ready to serve a potential waiting - ;; REPL request, just do this non-blocking thing: - (with-simple-restart (abort "Abort this game REPL evaluation") - (slynk:process-requests t))))) - - Note that this function is to be called _from the REPL_, and will -enter kind of "sub-REPL" inside it. It'll likely "just work" in this -situation. However, if you need you need to call this from anywhere -else (like, say, another thread), you must additionally arrange for the -variable 'SLYNK-API:*CHANNEL*' to be bound to the value it is bound to -in whatever SLY REPL you wish to interact with your game. - - -File: sly.info, Node: Controlling SLY from outside Emacs, Prev: REPLs and game loops, Up: Tips and Tricks - -8.5 Controlling SLY from outside Emacs -====================================== - -If your application has a non-SLY, non-Emacs user interface (graphical -or otherwise), you can use it to exert some control over SLY -functionality, such as its REPL (*note REPL::) and inspector (*note -Inspector::). This requires that you first set, in Emacs, variable -'sly-enable-evaluate-in-emacs' to non-nil. As the name suggests, it -lets outside Slynk servers evaluate code in your Elisp runtime. It is -set to 'nil' by default for security purposes. - - Once you've done that, you can call -'SLYNK-MREPL:COPY-TO-REPL-IN-EMACS' from your CL code with some objects -you'd like to manipulate in the REPL. Then you can have this code run -from some UI event handler: - - (lambda () - (slynk-mrepl:copy-to-repl-in-emacs - (list 42 'foo) - :blurb "Just a forty-two and a foo")) - - And see those objects pop up in your REPL for inspection and -manipulation. - - You can also use the functions 'SLYNK:INSPECT-IN-EMACS', -'SLYNK:ED-IN-EMACS', and in general, any exported function ending in -'IN-EMACS'. See their docstrings for details. - - -File: sly.info, Node: Extensions, Next: Credits, Prev: Tips and Tricks, Up: Top - -9 Extensions -************ - -* Menu: - -* Loading and unloading:: More contribs:: -* More contribs:: - -Extensions, also known as "contribs" are Emacs packages that extend -SLY’s functionality. Contrasting with its ancestor SLIME (*note -Introduction::), most contribs bundled with SLY are active by default, -since they are a decent way to split SLY into pluggable modules. The -auto-documentation (*note Autodoc::), trace (*note Trace Dialog::) and -Stickers (*note Stickers::) are contribs enabled by default, for -example. - - Usually, contribs differ from regular Emacs plugins in that they are -partly written in Emacs-lisp and partly in Common Lisp. The former is -usually the UI that queries the latter for information and then presents -it to the user. SLIME used to load all the contribs’ Common Lisp code -upfront, but SLY takes care to loading these two parts at the correct -time. In this way, developers can write third-party contribs that live -independently of SLY perhaps even in different code repositories. The -'sly-macrostep' contrib (<https://github.com/joaotavora/sly-macrostep>) -is one such example. - - A special 'sly-fancy' contrib package is the only one loaded by -default. You might never want to fiddle with it (it is the one that -contains the default extensions), but if you find that you don't like -some package or you are having trouble with a package, you can modify -your setup a bit. Generally, you set the variable 'sly-contribs' with -the list of package-names that you want to use. For example, a setup to -load only the 'sly-scratch' and 'sly-mrepl' packages looks like: - - ;; _Setup load-path and autoloads_ - (add-to-list 'load-path "~/dir/to/cloned/sly") - (require 'sly-autoloads) - - ;; _Set your lisp system and some contribs_ - (setq inferior-lisp-program "/opt/sbcl/bin/sbcl") - (setq sly-contribs '(sly-scratch sly-mrepl)) - - After starting SLY, the commands of both packages should be -available. - - -File: sly.info, Node: Loading and unloading, Next: More contribs, Up: Extensions - -9.1 Loading and unloading "on the fly" -====================================== - -We recommend that you setup the 'sly-contribs' variable _before_ -starting SLY via 'M-x sly', but if you want to enable more contribs -_after_ you that, you can set new 'sly-contribs' variable to another -value and call 'M-x sly-setup' or 'M-x sly-enable-contrib'. Note this -though: - - * If you've removed contribs from the list they won't be unloaded - automatically. - * If you have more than one SLY connection currently active, you must - manually repeat the 'sly-setup' step for each of them. - - Short of restarting Emacs, a reasonable way of unloading contribs is -by calling an Emacs Lisp function whose name is obtained by adding -'-unload' to the contrib's name, for every contrib you wish to unload. -So, to remove 'sly-mrepl', you must call 'sly-mrepl-unload'. Because -the unload function will only, if ever, unload the Emacs Lisp side of -the contrib, you may also need to restart your lisps. - - -File: sly.info, Node: More contribs, Prev: Loading and unloading, Up: Extensions - -9.2 More contribs -================= - -* Menu: - -* TRAMP Support:: -* Scratch Buffer:: - - -File: sly.info, Node: TRAMP Support, Next: Scratch Buffer, Up: More contribs - -9.2.1 TRAMP ------------ - -The package 'sly-tramp' provides some functions to set up filename -translations for TRAMP. (*note Setting up pathname translations::) - - -File: sly.info, Node: Scratch Buffer, Prev: TRAMP Support, Up: More contribs - -9.2.2 Scratch Buffer --------------------- - -The SLY scratch buffer, in contrib package 'sly-scratch', imitates -Emacs' usual '*scratch*' buffer. If 'sly-scratch-file' is set, it is -used to back the scratch buffer, making it persistent. The buffer is -like any other Lisp buffer, except for the command bound to 'C-j'. - -'C-j' -'M-x sly-eval-print-last-expression' - Evaluate the expression sexp before point and insert a printed - representation of the return values into the current buffer. - -'M-x sly-scratch' - Create a '*sly-scratch*' buffer. In this buffer you can enter Lisp - expressions and evaluate them with 'C-j', like in Emacs's - '*scratch*' buffer. - - -File: sly.info, Node: Credits, Next: Key Index, Prev: Extensions, Up: Top - -10 Credits -********** - -_The soppy ending..._ - -Hackers of the good hack -======================== - -SLY is a fork of SLIME which is itself an Extension of SLIM by Eric -Marsden. At the time of writing, the authors and code-contributors of -SLY are: - -Helmut Eller João Távora Luke Gorrie -Tobias C. Rittweiler Stas Boukarev Marco Baringer -Matthias Koeppe Nikodemus Siivola Alan Ruttenberg -Attila Lendvai Luís Borges de Dan Barlow - Oliveira -Andras Simon Martin Simmons Geo Carncross -Christophe Rhodes Peter Seibel Mark Evenson -Juho Snellman Douglas Crosher Wolfgang Jenkner -R Primus Javier Olaechea Edi Weitz -Zach Shaftel James Bielman Daniel Kochmanski -Terje Norderhaug Vladimir Sedach Juan Jose Garcia - Ripoll -Alexander Artemenko Spenser Truex Nathan Trapuzzano -Brian Downing Mark Jeffrey Cunningham -Espen Wiborg Paul M. Rodriguez Masataro Asai -Jan Moringen Sébastien Villemot Samuel Freilich -Raymond Toy Pierre Neidhardt Phil Hargett -Paulo Madeira Kris Katterjohn Jonas Bernoulli -Ivan Shvedunov Gábor Melis Francois-Rene Rideau -Christophe Junke Bozhidar Batsov Bart Botta -Wilfredo Tianxiang Xiong Syohei YOSHIDA -Velázquez-Rodríguez -Stefan Monnier Rommel MARTINEZ Pavel Kulyov -Paul A. Patience Olof-Joachim Frahm Mike Clarke -Michał Herda Mark H. David Mario Lang -Manfred Bergmann Leo Liu Koga Kazuo -Jon Oddie John Stracke Joe Robertson -Grant Shangreaux Graham Dobbins Eric Timmons -Douglas Katzman Dmitry Igrishin Dmitrii Korobeinikov -Deokhwan Kim Denis Budyak Chunyang Xu -Cayman Angelo Rossi Andrew Kirkpatrick - - ... not counting the bundled code from 'hyperspec.el', 'CLOCC', and -the 'CMU AI Repository'. - - Many people on the 'sly-devel' mailing list have made non-code -contributions to SLY. Life is hard though: you gotta send code to get -your name in the manual. ':-)' - -Thanks! -======= - -We're indebted to the good people of 'common-lisp.net' for their hosting -and help, and for rescuing us from "Sourceforge hell." - - Implementors of the Lisps that we support have been a great help. -We'd like to thank the CMUCL maintainers for their helpful answers, -Craig Norvell and Kevin Layer at Franz providing Allegro CL licenses for -SLY development, and Peter Graves for his help to get SLY running with -ABCL. - - Most of all we're happy to be working with the Lisp implementors -who've joined in the SLY development: Dan Barlow and Christophe Rhodes -of SBCL, Gary Byers of OpenMCL, and Martin Simmons of LispWorks. Thanks -also to Alain Picard and Memetrics for funding Martin's initial work on -the LispWorks backend! - - -File: sly.info, Node: Key Index, Next: Command Index, Prev: Credits, Up: Top - -Key (Character) Index -********************* - - -* Menu: - -* 0 ... 9: Restarts. (line 22) -* :: Miscellaneous. (line 28) -* <: Frame Navigation. (line 23) -* >: Inspector. (line 61) -* > <1>: Frame Navigation. (line 19) -* a: Restarts. (line 8) -* A: Miscellaneous. (line 31) -* B: Miscellaneous. (line 19) -* c: Restarts. (line 18) -* C: Miscellaneous. (line 24) -* C-c :: Evaluation. (line 34) -* C-c <: Cross-referencing. (line 57) -* C-c >: Cross-referencing. (line 61) -* C-c C-b: Recovery. (line 8) -* C-c C-b <1>: REPL commands. (line 46) -* C-c C-c: Compilation. (line 14) -* C-c C-c <1>: Cross-referencing. (line 77) -* C-c C-c <2>: Examining frames. (line 38) -* C-c C-d #: Documentation. (line 58) -* C-c C-d C-a: Documentation. (line 24) -* C-c C-d C-d: Documentation. (line 16) -* C-c C-d C-f: Documentation. (line 20) -* C-c C-d C-h: Documentation. (line 43) -* C-c C-d C-p: Documentation. (line 36) -* C-c C-d C-z: Documentation. (line 32) -* C-c C-d ~: Documentation. (line 54) -* C-c C-k: Compilation. (line 30) -* C-c C-k <1>: Cross-referencing. (line 82) -* C-c C-l: Compilation. (line 48) -* C-c C-m: Macro-expansion. (line 8) -* C-c C-m <1>: Macro-expansion. (line 37) -* C-c C-o: REPL commands. (line 63) -* C-c C-p: Evaluation. (line 42) -* C-c C-r: Evaluation. (line 38) -* C-c C-t: Disassembly. (line 12) -* C-c C-t <1>: Trace Dialog. (line 26) -* C-c C-u: Evaluation. (line 53) -* C-c C-w C-b: Cross-referencing. (line 36) -* C-c C-w C-c: Cross-referencing. (line 24) -* C-c C-w C-m: Cross-referencing. (line 44) -* C-c C-w C-r: Cross-referencing. (line 32) -* C-c C-w C-s: Cross-referencing. (line 40) -* C-c C-w C-w: Cross-referencing. (line 28) -* C-c C-x c: Multiple connections. (line 31) -* C-c C-x n: Multiple connections. (line 35) -* C-c C-x p: Multiple connections. (line 40) -* C-c C-z: REPL. (line 29) -* C-c E: Evaluation. (line 47) -* C-c I: Inspector. (line 16) -* C-c M-c: Compilation. (line 69) -* C-c M-d: Disassembly. (line 8) -* C-c M-k: Compilation. (line 44) -* C-c M-m: Macro-expansion. (line 19) -* C-c M-o: REPL commands. (line 69) -* C-c T: Trace Dialog. (line 39) -* C-c ~: Recovery. (line 15) -* C-c ~ <1>: REPL. (line 36) -* C-j: Scratch Buffer. (line 13) -* C-k: Trace Dialog. (line 83) -* C-M-n: REPL commands. (line 58) -* C-M-p: REPL commands. (line 53) -* C-M-x: Evaluation. (line 20) -* C-n: Completion. (line 55) -* C-p: Completion. (line 60) -* C-r: REPL commands. (line 35) -* C-x 4 .: Finding definitions. (line 30) -* C-x 5 .: Finding definitions. (line 35) -* C-x C-e: Evaluation. (line 14) -* C-x `: Compilation. (line 73) -* C-_: Macro-expansion. (line 51) -* d: Multiple connections. (line 57) -* D: Inspector. (line 27) -* d <1>: Examining frames. (line 24) -* D <1>: Examining frames. (line 29) -* e: Inspector. (line 31) -* e <1>: Examining frames. (line 19) -* g: Macro-expansion. (line 42) -* g <1>: Multiple connections. (line 62) -* g <2>: Inspector. (line 49) -* g <3>: Trace Dialog. (line 76) -* G: Trace Dialog. (line 79) -* h: Inspector. (line 53) -* i: Examining frames. (line 34) -* l: Inspector. (line 41) -* M-,: Finding definitions. (line 25) -* M-.: Finding definitions. (line 20) -* M-?: Cross-referencing. (line 19) -* M-n: Compilation. (line 61) -* M-n <1>: REPL commands. (line 28) -* M-n <2>: Frame Navigation. (line 12) -* M-p: Compilation. (line 65) -* M-p <1>: REPL commands. (line 21) -* M-p <2>: Frame Navigation. (line 12) -* M-RET: Inspector. (line 65) -* n: Inspector. (line 45) -* n <1>: Frame Navigation. (line 8) -* p: Frame Navigation. (line 8) -* q: Macro-expansion. (line 47) -* q <1>: Multiple connections. (line 66) -* q <2>: Inspector. (line 57) -* q <3>: Restarts. (line 12) -* R: Multiple connections. (line 71) -* r: Miscellaneous. (line 8) -* R <1>: Miscellaneous. (line 14) -* RET: Cross-referencing. (line 67) -* RET <1>: Multiple connections. (line 53) -* RET <2>: REPL commands. (line 8) -* RET <3>: Inspector. (line 22) -* S-TAB: Inspector. (line 70) -* Space: Cross-referencing. (line 72) -* t: Examining frames. (line 10) -* tab: Completion. (line 65) -* TAB: REPL commands. (line 13) -* TAB <1>: Inspector. (line 70) -* v: Inspector. (line 36) -* v <1>: Examining frames. (line 14) - - -File: sly.info, Node: Command Index, Next: Variable Index, Prev: Key Index, Up: Top - -Command and Function Index -************************** - - -* Menu: - -* backward-button: Inspector. (line 70) -* forward-button: Inspector. (line 70) -* hyperspec-lookup-format: Documentation. (line 54) -* hyperspec-lookup-reader-macro: Documentation. (line 58) -* isearch-backward: REPL commands. (line 35) -* next-error: Compilation. (line 73) -* sly-abort-connection: Multiple connections. (line 81) -* sly-apropos: Documentation. (line 24) -* sly-apropos-all: Documentation. (line 32) -* sly-apropos-package: Documentation. (line 36) -* sly-arglist NAME: Autodoc. (line 11) -* sly-autodoc-manually: Autodoc. (line 17) -* sly-autodoc-mode: Autodoc. (line 14) -* sly-button-backward: REPL commands. (line 53) -* sly-button-forward: REPL commands. (line 58) -* sly-calls-who: Cross-referencing. (line 28) -* sly-cd: Recovery. (line 19) -* sly-choose-completion: Completion. (line 65) -* sly-compile-and-load-file: Compilation. (line 30) -* sly-compile-defun: Compilation. (line 14) -* sly-compile-file: Compilation. (line 44) -* sly-compile-region: Compilation. (line 51) -* sly-compiler-macroexpand: Macro-expansion. (line 25) -* sly-compiler-macroexpand-1: Macro-expansion. (line 22) -* sly-connect: Multiple connections. (line 74) -* sly-connection-list-make-default: Multiple connections. (line 57) -* sly-db-abort: Restarts. (line 8) -* sly-db-beginning-of-backtrace: Frame Navigation. (line 23) -* sly-db-break-with-default-debugger: Miscellaneous. (line 19) -* sly-db-break-with-system-debugger: Miscellaneous. (line 31) -* sly-db-continue: Restarts. (line 18) -* sly-db-details-down: Frame Navigation. (line 12) -* sly-db-details-up: Frame Navigation. (line 12) -* sly-db-disassemble: Examining frames. (line 29) -* sly-db-down: Frame Navigation. (line 8) -* sly-db-end-of-backtrace: Frame Navigation. (line 19) -* sly-db-eval-in-frame: Examining frames. (line 19) -* sly-db-inspect-condition: Miscellaneous. (line 24) -* sly-db-inspect-in-frame: Examining frames. (line 34) -* sly-db-invoke-restart-n: Restarts. (line 22) -* sly-db-pprint-eval-in-frame: Examining frames. (line 24) -* sly-db-quit: Restarts. (line 12) -* sly-db-recompile-frame-source: Examining frames. (line 38) -* sly-db-restart-frame: Miscellaneous. (line 8) -* sly-db-return-from-frame: Miscellaneous. (line 14) -* sly-db-show-frame-source: Examining frames. (line 14) -* sly-db-toggle-details: Examining frames. (line 10) -* sly-db-up: Frame Navigation. (line 8) -* sly-describe-function: Documentation. (line 20) -* sly-describe-symbol: Documentation. (line 16) -* sly-disassemble-symbol: Disassembly. (line 8) -* sly-disconnect: Multiple connections. (line 78) -* sly-edit-definition: Finding definitions. (line 20) -* sly-edit-definition-other-frame: Finding definitions. (line 35) -* sly-edit-definition-other-window: Finding definitions. (line 30) -* sly-edit-uses: Cross-referencing. (line 19) -* sly-edit-value: Evaluation. (line 47) -* sly-eval-defun: Evaluation. (line 20) -* sly-eval-last-expression: Evaluation. (line 14) -* sly-eval-print-last-expression: Scratch Buffer. (line 13) -* sly-eval-region: Evaluation. (line 38) -* sly-expand-1: Macro-expansion. (line 8) -* sly-format-string-expand: Macro-expansion. (line 28) -* sly-goto-connection: Multiple connections. (line 53) -* sly-goto-xref: Cross-referencing. (line 72) -* sly-hyperspec-lookup: Documentation. (line 43) -* sly-info: Documentation. (line 11) -* sly-inspect: Inspector. (line 16) -* sly-inspector-describe-inspectee: Inspector. (line 27) -* sly-inspector-eval: Inspector. (line 31) -* sly-inspector-fetch-all: Inspector. (line 61) -* sly-inspector-history: Inspector. (line 53) -* sly-inspector-next: Inspector. (line 45) -* sly-inspector-operate-on-point: Inspector. (line 22) -* sly-inspector-pop: Inspector. (line 41) -* sly-inspector-quit: Inspector. (line 57) -* sly-inspector-reinspect: Inspector. (line 49) -* sly-inspector-toggle-verbose: Inspector. (line 36) -* sly-interactive-eval: Evaluation. (line 34) -* sly-interactive-eval <1>: Miscellaneous. (line 28) -* sly-interrupt: Recovery. (line 8) -* sly-interrupt <1>: REPL commands. (line 46) -* sly-list-callees: Cross-referencing. (line 61) -* sly-list-callers: Cross-referencing. (line 57) -* sly-list-connections: Multiple connections. (line 31) -* sly-load-file: Compilation. (line 48) -* sly-macroexpand-1: Macro-expansion. (line 14) -* sly-macroexpand-1-inplace: Macro-expansion. (line 37) -* sly-macroexpand-1-inplace <1>: Macro-expansion. (line 42) -* sly-macroexpand-all: Macro-expansion. (line 19) -* sly-macroexpand-undo: Macro-expansion. (line 51) -* sly-mrepl: REPL. (line 29) -* sly-mrepl-clear-recent-output: REPL commands. (line 63) -* sly-mrepl-clear-repl: REPL commands. (line 69) -* sly-mrepl-copy-part-to-repl: Inspector. (line 65) -* sly-mrepl-indent-and-complete-symbol: REPL commands. (line 13) -* sly-mrepl-new: REPL. (line 32) -* sly-mrepl-next-input-or-button: REPL commands. (line 28) -* sly-mrepl-previous-input-or-button: REPL commands. (line 21) -* sly-mrepl-return: REPL commands. (line 8) -* sly-mrepl-sync: Recovery. (line 15) -* sly-mrepl-sync <1>: REPL. (line 36) -* sly-next-completion: Completion. (line 55) -* sly-next-connection: Multiple connections. (line 35) -* sly-next-note: Compilation. (line 61) -* sly-pop-find-definition-stack: Finding definitions. (line 25) -* sly-pprint-eval-last-expression: Evaluation. (line 42) -* sly-prev-completion: Completion. (line 60) -* sly-prev-connection: Multiple connections. (line 40) -* sly-previous-note: Compilation. (line 65) -* sly-pwd: Recovery. (line 23) -* sly-recompile-all-xrefs: Cross-referencing. (line 82) -* sly-recompile-xref: Cross-referencing. (line 77) -* sly-remove-notes: Compilation. (line 69) -* sly-restart-connection-at-point: Multiple connections. (line 71) -* sly-restart-inferior-lisp: Recovery. (line 11) -* sly-scratch: Scratch Buffer. (line 17) -* sly-show-xref: Cross-referencing. (line 67) -* sly-temp-buffer-quit: Macro-expansion. (line 47) -* sly-temp-buffer-quit <1>: Multiple connections. (line 66) -* sly-toggle-trace-fdefinition: Disassembly. (line 12) -* sly-trace-dialog: Trace Dialog. (line 39) -* sly-trace-dialog-clear-fetched-traces: Trace Dialog. (line 83) -* sly-trace-dialog-fetch-status: Trace Dialog. (line 76) -* sly-trace-dialog-fetch-traces: Trace Dialog. (line 79) -* sly-trace-dialog-toggle-trace: Trace Dialog. (line 26) -* sly-undefine-function: Evaluation. (line 53) -* sly-untrace-all: Disassembly. (line 17) -* sly-update-connection-list: Multiple connections. (line 62) -* sly-who-binds: Cross-referencing. (line 36) -* sly-who-calls: Cross-referencing. (line 24) -* sly-who-macroexpands: Cross-referencing. (line 44) -* sly-who-references: Cross-referencing. (line 32) -* sly-who-sets: Cross-referencing. (line 40) -* sly-who-specializes: Cross-referencing. (line 47) - - -File: sly.info, Node: Variable Index, Prev: Command Index, Up: Top - -Variable and Concept Index -************************** - - -* Menu: - -* ASCII: Defcustom variables. (line 29) -* Character Encoding: Defcustom variables. (line 29) -* Compilation: Compilation. (line 6) -* Compiling Functions: Compilation. (line 12) -* Completion: Completion. (line 6) -* Contribs: Extensions. (line 11) -* Contributions: Extensions. (line 11) -* Debugger: Debugger. (line 6) -* Extensions: Extensions. (line 11) -* LATIN-1: Defcustom variables. (line 29) -* Listener: REPL. (line 6) -* Macros: Macro-expansion. (line 6) -* Plugins: Extensions. (line 11) -* Symbol Completion: Completion. (line 6) -* TRAMP: TRAMP Support. (line 6) -* Unicode: Defcustom variables. (line 29) -* UTF-8: Defcustom variables. (line 29) - - - -Tag Table: -Node: Top294 -Node: Introduction2281 -Node: Getting started4600 -Node: Platforms4911 -Node: Downloading6011 -Node: Basic setup7011 -Node: Running7944 -Node: Basic customization8808 -Node: Multiple Lisps10524 -Node: A SLY tour for SLIME users13019 -Node: Working with source files23905 -Node: Evaluation24633 -Node: Compilation26460 -Node: Autodoc29313 -Node: Semantic indentation30255 -Ref: Semantic indentation-Footnote-132362 -Node: Reader conditionals32457 -Node: Macro-expansion32833 -Node: Common functionality34465 -Node: Finding definitions35236 -Node: Cross-referencing37066 -Ref: Cross-referencing-Footnote-139458 -Node: Completion39686 -Node: Interactive objects42678 -Node: Documentation44594 -Node: Multiple connections46628 -Node: Disassembly49579 -Node: Recovery50111 -Node: Temporary buffers50734 -Node: Multi-threading52150 -Node: The REPL and other special buffers53718 -Node: REPL53991 -Node: REPL commands55843 -Node: REPL output57858 -Node: REPL backreferences62463 -Ref: REPL backreferences-Footnote-165615 -Node: Inspector65668 -Node: Debugger67614 -Node: Examining frames68271 -Node: Restarts69355 -Ref: sly-db-quit69561 -Node: Frame Navigation69980 -Node: Miscellaneous70664 -Node: Trace Dialog71573 -Node: Stickers75357 -Node: Customization79471 -Node: Emacs-side79674 -Node: Keybindings79866 -Ref: describe-key80668 -Ref: describe-bindings80795 -Ref: describe-mode80926 -Ref: view-lossage81098 -Ref: Emacs Init File81234 -Node: Keymaps81866 -Node: Defcustom variables84503 -Ref: sly-complete-symbol-function85192 -Ref: sly-net-coding-system85740 -Node: Hooks88099 -Ref: sly-connected-hook88447 -Node: Lisp-side customization88890 -Node: Communication style89288 -Node: Other configurables91815 -Ref: *SLY-DB-QUIT-RESTART*92522 -Node: Tips and Tricks98056 -Node: Connecting to a remote Lisp98330 -Node: Setting up the Lisp image99037 -Ref: Setting up the Lisp image-Footnote-1100824 -Ref: Setting up the Lisp image-Footnote-2100935 -Ref: Setting up the Lisp image-Footnote-3101109 -Node: Setting up Emacs101262 -Ref: Setting up Emacs-Footnote-1102216 -Node: Setting up pathname translations102386 -Node: Loading Slynk faster103963 -Ref: init-example105440 -Node: Auto-SLY105662 -Node: REPLs and game loops106143 -Node: Controlling SLY from outside Emacs108110 -Node: Extensions109355 -Node: Loading and unloading111402 -Node: More contribs112478 -Node: TRAMP Support112649 -Node: Scratch Buffer112892 -Ref: sly-scratch113018 -Node: Credits113651 -Node: Key Index116920 -Node: Command Index125539 -Node: Variable Index135562 - -End Tag Table - - -Local Variables: -coding: utf-8 -End: diff --git a/elpa/sly-20211121.1002/slynk/slynk.asd b/elpa/sly-20211121.1002/slynk/slynk.asd @@ -1,115 +0,0 @@ -;;; -*- lisp -*- -(in-package :asdf) - -;; ASDF system definition for loading the Slynk server independently -;; of Emacs. -;; -;; Usage: -;; -;; (push #p"/path/to/this/file/" asdf:*central-registry*) -;; (asdf:load-system :slynk) -;; (slynk:create-server :port PORT) => ACTUAL-PORT -;; -;; (PORT can be zero to mean "any available port".) -;; Then the Slynk server is running on localhost:ACTUAL-PORT. You can -;; use `M-x sly-connect' to connect Emacs to it. -;; -;; This code has been placed in the Public Domain. All warranties -;; are disclaimed. - -(defsystem :slynk - :serial t - :components - ((:file "slynk-backend") - ;; If/when we require ASDF3, we shall use :if-feature instead - #+(or cmu sbcl scl) - (:file "slynk-source-path-parser") - #+(or cmu ecl sbcl scl) - (:file "slynk-source-file-cache") - #+clisp - (:file "xref") - #+(or clisp clozure clasp) - (:file "metering") - (:module "backend" - :serial t - :components (#+allegro - (:file "allegro") - #+armedbear - (:file "abcl") - #+clisp - (:file "clisp") - #+clozure - (:file "ccl") - #+cmu - (:file "cmucl") - #+cormanlisp - (:file "corman") - #+ecl - (:file "ecl") - #+lispworks - (:file "lispworks") - #+sbcl - (:file "sbcl") - #+clasp - (:file "clasp") - #+scl - (:file "scl") - #+mkcl - (:file "mkcl"))) - #-armedbear - (:file "slynk-gray") - (:file "slynk-match") - (:file "slynk-rpc") - (:file "slynk") - (:file "slynk-completion") - (:file "slynk-apropos"))) - -(defmethod perform :after ((o load-op) (c (eql (find-system :slynk)))) - (format *debug-io* "~&SLYNK's ASDF loader finished.") - (funcall (read-from-string "slynk::init"))) - -#+sbcl -(defmethod operate :around ((o load-op) (c (eql (find-system :slynk))) &key &allow-other-keys) - (let ((asdf:*compile-file-failure-behaviour* :warn) - (sb-ext:*on-package-variance* '(:warn t))) - (call-next-method))) - - -;;; Contrib systems (should probably go into their own file one day) -;;; -(defsystem :slynk/arglists - :depends-on (:slynk) - :components ((:file "../contrib/slynk-arglists"))) - -(defsystem :slynk/fancy-inspector - :depends-on (:slynk) - :components ((:file "../contrib/slynk-fancy-inspector"))) - -(defsystem :slynk/package-fu - :depends-on (:slynk) - :components ((:file "../contrib/slynk-package-fu"))) - -(defsystem :slynk/mrepl - :depends-on (:slynk) - :components ((:file "../contrib/slynk-mrepl"))) - -(defsystem :slynk/trace-dialog - :depends-on (:slynk) - :components ((:file "../contrib/slynk-trace-dialog"))) - -(defsystem :slynk/profiler - :depends-on (:slynk) - :components ((:file "../contrib/slynk-profiler"))) - -(defsystem :slynk/stickers - :depends-on (:slynk) - :components ((:file "../contrib/slynk-stickers"))) - -(defsystem :slynk/indentation - :depends-on (:slynk) - :components ((:file "../contrib/slynk-indentation"))) - -(defsystem :slynk/retro - :depends-on (:slynk) - :components ((:file "../contrib/slynk-retro"))) - diff --git a/elpa/sly-20211121.1002/contrib/sly-autodoc.el b/elpa/sly-20220302.1053/contrib/sly-autodoc.el diff --git a/elpa/sly-20211121.1002/contrib/sly-fancy-inspector.el b/elpa/sly-20220302.1053/contrib/sly-fancy-inspector.el diff --git a/elpa/sly-20211121.1002/contrib/sly-fancy-trace.el b/elpa/sly-20220302.1053/contrib/sly-fancy-trace.el diff --git a/elpa/sly-20211121.1002/contrib/sly-fancy.el b/elpa/sly-20220302.1053/contrib/sly-fancy.el diff --git a/elpa/sly-20211121.1002/contrib/sly-fontifying-fu.el b/elpa/sly-20220302.1053/contrib/sly-fontifying-fu.el diff --git a/elpa/sly-20211121.1002/contrib/sly-indentation.el b/elpa/sly-20220302.1053/contrib/sly-indentation.el diff --git a/elpa/sly-20211121.1002/contrib/sly-mrepl.el b/elpa/sly-20220302.1053/contrib/sly-mrepl.el diff --git a/elpa/sly-20211121.1002/contrib/sly-package-fu.el b/elpa/sly-20220302.1053/contrib/sly-package-fu.el diff --git a/elpa/sly-20211121.1002/contrib/sly-profiler.el b/elpa/sly-20220302.1053/contrib/sly-profiler.el diff --git a/elpa/sly-20211121.1002/contrib/sly-retro.el b/elpa/sly-20220302.1053/contrib/sly-retro.el diff --git a/elpa/sly-20211121.1002/contrib/sly-scratch.el b/elpa/sly-20220302.1053/contrib/sly-scratch.el diff --git a/elpa/sly-20211121.1002/contrib/sly-stickers.el b/elpa/sly-20220302.1053/contrib/sly-stickers.el diff --git a/elpa/sly-20211121.1002/contrib/sly-trace-dialog.el b/elpa/sly-20220302.1053/contrib/sly-trace-dialog.el diff --git a/elpa/sly-20211121.1002/contrib/sly-tramp.el b/elpa/sly-20220302.1053/contrib/sly-tramp.el diff --git a/elpa/sly-20211121.1002/contrib/slynk-arglists.lisp b/elpa/sly-20220302.1053/contrib/slynk-arglists.lisp diff --git a/elpa/sly-20211121.1002/contrib/slynk-fancy-inspector.lisp b/elpa/sly-20220302.1053/contrib/slynk-fancy-inspector.lisp diff --git a/elpa/sly-20211121.1002/contrib/slynk-indentation.lisp b/elpa/sly-20220302.1053/contrib/slynk-indentation.lisp diff --git a/elpa/sly-20211121.1002/contrib/slynk-mrepl.lisp b/elpa/sly-20220302.1053/contrib/slynk-mrepl.lisp diff --git a/elpa/sly-20211121.1002/contrib/slynk-package-fu.lisp b/elpa/sly-20220302.1053/contrib/slynk-package-fu.lisp diff --git a/elpa/sly-20211121.1002/contrib/slynk-profiler.lisp b/elpa/sly-20220302.1053/contrib/slynk-profiler.lisp diff --git a/elpa/sly-20211121.1002/contrib/slynk-retro.lisp b/elpa/sly-20220302.1053/contrib/slynk-retro.lisp diff --git a/elpa/sly-20211121.1002/contrib/slynk-stickers.lisp b/elpa/sly-20220302.1053/contrib/slynk-stickers.lisp diff --git a/elpa/sly-20211121.1002/contrib/slynk-trace-dialog.lisp b/elpa/sly-20220302.1053/contrib/slynk-trace-dialog.lisp diff --git a/elpa/sly-20211121.1002/contrib/sylvesters.txt b/elpa/sly-20220302.1053/contrib/sylvesters.txt diff --git a/elpa/sly-20211121.1002/contributors.info b/elpa/sly-20220302.1053/contributors.info diff --git a/elpa/sly-20211121.1002/dir b/elpa/sly-20220302.1053/dir diff --git a/elpa/sly-20211121.1002/images/stickers-1-placed-stickers.png b/elpa/sly-20220302.1053/images/stickers-1-placed-stickers.png Binary files differ. diff --git a/elpa/sly-20211121.1002/images/stickers-2-armed-stickers.png b/elpa/sly-20220302.1053/images/stickers-2-armed-stickers.png Binary files differ. diff --git a/elpa/sly-20211121.1002/images/stickers-3-replay-stickers.png b/elpa/sly-20220302.1053/images/stickers-3-replay-stickers.png Binary files differ. diff --git a/elpa/sly-20211121.1002/images/stickers-4-breaking-stickers.png b/elpa/sly-20220302.1053/images/stickers-4-breaking-stickers.png Binary files differ. diff --git a/elpa/sly-20211121.1002/images/stickers-5-fetch-recordings.png b/elpa/sly-20220302.1053/images/stickers-5-fetch-recordings.png Binary files differ. diff --git a/elpa/sly-20211121.1002/images/tutorial-1.png b/elpa/sly-20220302.1053/images/tutorial-1.png Binary files differ. diff --git a/elpa/sly-20211121.1002/images/tutorial-2.png b/elpa/sly-20220302.1053/images/tutorial-2.png Binary files differ. diff --git a/elpa/sly-20211121.1002/images/tutorial-3.png b/elpa/sly-20220302.1053/images/tutorial-3.png Binary files differ. diff --git a/elpa/sly-20211121.1002/images/tutorial-4.png b/elpa/sly-20220302.1053/images/tutorial-4.png Binary files differ. diff --git a/elpa/sly-20211121.1002/images/tutorial-5.png b/elpa/sly-20220302.1053/images/tutorial-5.png Binary files differ. diff --git a/elpa/sly-20211121.1002/images/tutorial-6.png b/elpa/sly-20220302.1053/images/tutorial-6.png Binary files differ. diff --git a/elpa/sly-20211121.1002/lib/.nosearch b/elpa/sly-20220302.1053/lib/.nosearch diff --git a/elpa/sly-20211121.1002/lib/hyperspec.el b/elpa/sly-20220302.1053/lib/hyperspec.el diff --git a/elpa/sly-20211121.1002/lib/sly-buttons.el b/elpa/sly-20220302.1053/lib/sly-buttons.el diff --git a/elpa/sly-20211121.1002/lib/sly-cl-indent.el b/elpa/sly-20220302.1053/lib/sly-cl-indent.el diff --git a/elpa/sly-20211121.1002/lib/sly-common.el b/elpa/sly-20220302.1053/lib/sly-common.el diff --git a/elpa/sly-20211121.1002/lib/sly-completion.el b/elpa/sly-20220302.1053/lib/sly-completion.el diff --git a/elpa/sly-20211121.1002/lib/sly-messages.el b/elpa/sly-20220302.1053/lib/sly-messages.el diff --git a/elpa/sly-20211121.1002/lib/sly-parse.el b/elpa/sly-20220302.1053/lib/sly-parse.el diff --git a/elpa/sly-20220302.1053/lib/sly-tests.el b/elpa/sly-20220302.1053/lib/sly-tests.el @@ -0,0 +1,1545 @@ +;;; sly-tests.el --- Automated tests for sly.el -*- lexical-binding: t; -*- +;; +;;;; License +;; Copyright (C) 2003 Eric Marsden, Luke Gorrie, Helmut Eller +;; Copyright (C) 2004,2005,2006 Luke Gorrie, Helmut Eller +;; Copyright (C) 2007,2008,2009 Helmut Eller, Tobias C. Rittweiler +;; Copyright (C) 2013 +;; +;; For a detailed list of contributors, see the manual. +;; +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2 of +;; the License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public +;; License along with this program; if not, write to the Free +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, +;; MA 02111-1307, USA. + + +;;;; Tests +(require 'sly) +(require 'ert nil t) +(require 'ert "lib/ert" t) ;; look for bundled version for Emacs 23 +(require 'cl-lib) +(require 'bytecomp) ; byte-compile-current-file + +(defun sly-shuffle-list (list) + (let* ((len (length list)) + (taken (make-vector len nil)) + (result (make-vector len nil))) + (dolist (e list) + (while (let ((i (random len))) + (cond ((aref taken i)) + (t (aset taken i t) + (aset result i e) + nil))))) + (append result '()))) + +(defun sly-batch-test (&optional test-name randomize) + "Run the test suite in batch-mode. +Exits Emacs when finished. The exit code is the number of failed tests." + (interactive) + (let ((ert-debug-on-error nil) + (timeout 30)) + (sly) + ;; Block until we are up and running. + (let (timed-out) + (run-with-timer timeout nil + (lambda () (setq timed-out t))) + (while (not (sly-connected-p)) + (sit-for 1) + (when timed-out + (when noninteractive + (kill-emacs 252))))) + (sly-sync-to-top-level 5) + (let* ((selector (if randomize + `(member ,@(sly-shuffle-list + (ert-select-tests (or test-name t) t))) + (or test-name t))) + (ert-fun (if noninteractive + 'ert-run-tests-batch + 'ert))) + (let ((stats (funcall ert-fun selector))) + (if noninteractive + (kill-emacs (ert-stats-completed-unexpected stats))))))) + +(defun sly-skip-test (message) + ;; ERT for Emacs 23 and earlier doesn't have `ert-skip' + (if (fboundp 'ert-skip) + (ert-skip message) + (message (concat "SKIPPING: " message)) + (ert-pass))) + +(defun sly-tests--undefine-all () + (dolist (test (ert-select-tests t t)) + (let ((sym (ert-test-name test))) + (cl-assert (eq (get sym 'ert--test) test)) + (cl-remprop sym 'ert--test)))) + +(sly-tests--undefine-all) + +(eval-and-compile + (defun sly-tests-auto-tags () + (append '(sly) + (let ((file-name (or load-file-name + byte-compile-current-file))) + (if (and file-name + (string-match "test/sly-\\(.*\\)\.elc?$" file-name)) + (list 'contrib (intern (match-string 1 file-name))) + '(core))))) + + (defmacro define-sly-ert-test (name &rest args) + "Like `ert-deftest', but set tags automatically. +Also don't error if `ert.el' is missing." + (declare (debug (&define name sexp sexp &rest def-form))) + (let* ((docstring (and (stringp (cl-second args)) + (cl-second args))) + (args (if docstring + (cddr args) + (cdr args))) + (tags (sly-tests-auto-tags))) + `(ert-deftest ,name () ,(or docstring "No docstring for this test.") + :tags ',tags + ,@args))) + + (defun sly-test-ert-test-for (name input i doc _body fails-for style fname) + `(define-sly-ert-test + ,(intern (format "%s-%d" name i)) () + ,(format "For input %s, %s" (truncate-string-to-width + (format "%s" input) + 15 nil nil 'ellipsis) + (replace-regexp-in-string "^.??\\(\\w+\\)" + (lambda (s) (downcase s)) + doc + t)) + ,@(if fails-for + `(:expected-result + '(satisfies + (lambda (result) + (ert-test-result-type-p + result + (if (cl-find-if + (lambda (impl) + (unless (listp impl) + (setq impl (list impl #'(lambda (&rest _ign) t)))) + (and (equal (car impl) (sly-lisp-implementation-name)) + (funcall + (cadr impl) + ;; Appease `version-to-list' for + ;; SBCL. `version-regexp-alist' + ;; doesn't work here. + (replace-regexp-in-string + "[-._+ ]?[[:alnum:]]\\{7,9\\}$" + "-snapshot" + (sly-lisp-implementation-version)) + (caddr impl)))) + ',fails-for) + :failed + :passed)))))) + + ,@(when style + `((let ((style (sly-communication-style))) + (when (not (member style ',style)) + (sly-skip-test (format "test not applicable for style %s" + style)))))) + (apply #',fname ',input)))) + +(defmacro def-sly-test (name args doc inputs &rest body) + "Define a test case. +NAME ::= SYMBOL | (SYMBOL OPTION*) is a symbol naming the test. +OPTION ::= (:fails-for IMPLEMENTATION*) | (:style COMMUNICATION-STYLE*) +ARGS is a lambda-list. +DOC is a docstring. +INPUTS is a list of argument lists, each tested separately. +BODY is the test case. The body can use `sly-check' to test +conditions (assertions)." + (declare (debug (&define name sexp sexp sexp &rest def-form)) + (indent 4)) + (if (not (featurep 'ert)) + (warn "No ert.el found: not defining test %s" + name) + `(progn + ,@(cl-destructuring-bind (name &rest options) + (if (listp name) name (list name)) + (let ((fname (intern (format "sly-test-%s" name)))) + (cons `(defun ,fname ,args + (sly-sync-to-top-level 0.3) + ,@body + (sly-sync-to-top-level 0.3)) + (cl-loop for input in (eval inputs) + for i from 1 + with fails-for = (cdr (assoc :fails-for options)) + with style = (cdr (assoc :style options)) + collect (sly-test-ert-test-for name + input + i + doc + body + fails-for + style + fname)))))))) + +(defmacro sly-check (check &rest body) + (declare (indent defun)) + `(unless (progn ,@body) + (ert-fail ,(cl-etypecase check + (cons `(concat "Ooops, " ,(cons 'format check))) + (string `(concat "Check failed: " ,check)) + (symbol `(concat "Check failed: " ,(symbol-name check))))))) + + +;;;;; Test case definitions +(defun sly-check-top-level () ;(&optional _test-name) + (accept-process-output nil 0.001) + (sly-check "At the top level (no debugging or pending RPCs)" + (sly-at-top-level-p))) + +(defun sly-at-top-level-p () + (and (not (sly-db-get-default-buffer)) + (null (sly-rex-continuations)))) + +(defun sly-wait-condition (name predicate timeout &optional cleanup) + (let ((end (time-add (current-time) (seconds-to-time timeout)))) + (while (not (funcall predicate)) + (sly-message "waiting for condition: %s [%s]" name + (format-time-string "%H:%M:%S.%6N")) + (cond ((time-less-p end (current-time)) + (unwind-protect + (error "Timeout waiting for condition: %S" name) + (funcall cleanup))) + (t + ;; XXX if a process-filter enters a recursive-edit, we + ;; hang forever + (accept-process-output nil 0.1)))))) + +(defun sly-sync-to-top-level (timeout) + (sly-wait-condition "top-level" #'sly-at-top-level-p timeout + (lambda () + (let ((sly-db-buffer + (sly-db-get-default-buffer))) + (when (bufferp sly-db-buffer) + (with-current-buffer sly-db-buffer + (sly-db-quit))))))) + +;; XXX: unused function +(defun sly-check-sly-db-level (expected) + (let ((sly-db-level (let ((sly-db (sly-db-get-default-buffer))) + (if sly-db + (with-current-buffer sly-db + sly-db-level))))) + (sly-check ("SLY-DB level (%S) is %S" expected sly-db-level) + (equal expected sly-db-level)))) + +(defun sly-test-expect (_name expected actual &optional test) + (when (stringp expected) (setq expected (substring-no-properties expected))) + (when (stringp actual) (setq actual (substring-no-properties actual))) + (if test + (should (funcall test expected actual)) + (should (equal expected actual)))) + +(defun sly-db-level () + (let ((sly-db (sly-db-get-default-buffer))) + (if sly-db + (with-current-buffer sly-db + sly-db-level)))) + +(defun sly-sly-db-level= (level) + (equal level (sly-db-level))) + +(eval-when-compile + (defvar sly-test-symbols + '(("foobar") ("foo@bar") ("@foobar") ("foobar@") ("\\@foobar") + ("|asdf||foo||bar|") + ("\\#<Foo@Bar>") + ("\\(setf\\ car\\)")))) + +(defun sly-check-symbol-at-point (prefix symbol suffix) + ;; We test that `sly-symbol-at-point' works at every + ;; character of the symbol name. + (with-temp-buffer + (lisp-mode) + (insert prefix) + (let ((start (point))) + (insert symbol suffix) + (dotimes (i (length symbol)) + (goto-char (+ start i)) + (sly-test-expect (format "Check `%s' (at %d)..." + (buffer-string) (point)) + symbol + (sly-symbol-at-point) + #'equal))))) + + + +(def-sly-test symbol-at-point.2 (sym) + "fancy symbol-name _not_ at BOB/EOB" + sly-test-symbols + (sly-check-symbol-at-point "(foo " sym " bar)")) + +(def-sly-test symbol-at-point.3 (sym) + "fancy symbol-name with leading ," + (cl-remove-if (lambda (s) (eq (aref (car s) 0) ?@)) sly-test-symbols) + (sly-check-symbol-at-point "," sym "")) + +(def-sly-test symbol-at-point.4 (sym) + "fancy symbol-name with leading ,@" + sly-test-symbols + (sly-check-symbol-at-point ",@" sym "")) + +(def-sly-test symbol-at-point.5 (sym) + "fancy symbol-name with leading `" + sly-test-symbols + (sly-check-symbol-at-point "`" sym "")) + +(def-sly-test symbol-at-point.6 (sym) + "fancy symbol-name wrapped in ()" + sly-test-symbols + (sly-check-symbol-at-point "(" sym ")")) + +(def-sly-test symbol-at-point.7 (sym) + "fancy symbol-name wrapped in #< {DEADBEEF}>" + sly-test-symbols + (sly-check-symbol-at-point "#<" sym " {DEADBEEF}>")) + +;;(def-sly-test symbol-at-point.8 (sym) +;; "fancy symbol-name wrapped in #<>" +;; sly-test-symbols +;; (sly-check-symbol-at-point "#<" sym ">")) + +(def-sly-test symbol-at-point.9 (sym) + "fancy symbol-name wrapped in #| ... |#" + sly-test-symbols + (sly-check-symbol-at-point "#|\n" sym "\n|#")) + +(def-sly-test symbol-at-point.10 (sym) + "fancy symbol-name after #| )))(( |# (1)" + sly-test-symbols + (sly-check-symbol-at-point "#| )))(( #|\n" sym "")) + +(def-sly-test symbol-at-point.11 (sym) + "fancy symbol-name after #| )))(( |# (2)" + sly-test-symbols + (sly-check-symbol-at-point "#| )))(( #|" sym "")) + +(def-sly-test symbol-at-point.12 (sym) + "fancy symbol-name wrapped in \"...\"" + sly-test-symbols + (sly-check-symbol-at-point "\"\n" sym "\"\n")) + +(def-sly-test symbol-at-point.13 (sym) + "fancy symbol-name wrapped in \" )))(( \" (1)" + sly-test-symbols + (sly-check-symbol-at-point "\" )))(( \"\n" sym "")) + +(def-sly-test symbol-at-point.14 (sym) + "fancy symbol-name wrapped in \" )))(( \" (1)" + sly-test-symbols + (sly-check-symbol-at-point "\" )))(( \"" sym "")) + +(def-sly-test symbol-at-point.15 (sym) + "symbol-at-point after #." + sly-test-symbols + (sly-check-symbol-at-point "#." sym "")) + +(def-sly-test symbol-at-point.16 (sym) + "symbol-at-point after #+" + sly-test-symbols + (sly-check-symbol-at-point "#+" sym "")) + + +(def-sly-test sexp-at-point.1 (string) + "symbol-at-point after #'" + '(("foo") + ("#:foo") + ("#'foo") + ("#'(lambda (x) x)") + ("()")) + (with-temp-buffer + (lisp-mode) + (insert string) + (goto-char (point-min)) + (sly-test-expect (format "Check sexp `%s' (at %d)..." + (buffer-string) (point)) + string + (sly-sexp-at-point) + #'equal))) + +(def-sly-test narrowing () + "Check that narrowing is properly sustained." + '() + (sly-check-top-level) + (let ((random-buffer-name (symbol-name (cl-gensym))) + (defun-pos) (tmpbuffer)) + (with-temp-buffer + (dotimes (i 100) (insert (format ";;; %d. line\n" i))) + (setq tmpbuffer (current-buffer)) + (setq defun-pos (point)) + (insert (concat "(defun __foo__ (x y)" "\n" + " 'nothing)" "\n")) + (dotimes (i 100) (insert (format ";;; %d. line\n" (+ 100 i)))) + (sly-check "Checking that newly created buffer is not narrowed." + (not (buffer-narrowed-p))) + + (goto-char defun-pos) + (narrow-to-defun) + (sly-check "Checking that narrowing succeeded." + (buffer-narrowed-p)) + + (sly-with-popup-buffer (random-buffer-name) + (sly-check ("Checking that we're in Sly's temp buffer `%s'" + random-buffer-name) + (equal (buffer-name (current-buffer)) random-buffer-name))) + (with-current-buffer random-buffer-name + ;; Notice that we cannot quit the buffer within the extent + ;; of sly-with-output-to-temp-buffer. + (quit-window t)) + (sly-check ("Checking that we've got back from `%s'" + random-buffer-name) + (and (eq (current-buffer) tmpbuffer) + (= (point) defun-pos))) + + (sly-check "Checking that narrowing sustained \ +after quitting Sly's temp buffer." + (buffer-narrowed-p)) + + (let ((sly-buffer-package "SLYNK") + (symbol '*buffer-package*)) + (sly-edit-definition (symbol-name symbol)) + (sly-check ("Checking that we've got M-. into slynk.lisp. %S" symbol) + (string= (file-name-nondirectory (buffer-file-name)) + "slynk.lisp")) + (sly-pop-find-definition-stack) + (sly-check ("Checking that we've got back.") + (and (eq (current-buffer) tmpbuffer) + (= (point) defun-pos))) + + (sly-check "Checking that narrowing sustained after M-," + (buffer-narrowed-p))) + )) + (sly-check-top-level)) + +(defun sly-test--pos-at-line (line) + (save-excursion + (goto-char (point-min)) + (forward-line (1- line)) + (line-beginning-position))) + +(def-sly-test recenter + (pos-line target expected-window-start) + "Test `sly-recenter'." + ;; numbers are actually lines numbers + '(;; region visible, point in region + (2 4 1) + ;; end not visible + (2 (+ wh 2) 2) + ;; end and start not visible + ((+ wh 2) (+ wh 500) (+ wh 2))) + (when noninteractive + (sly-skip-test "Can't test sly-recenter in batch mode")) + (with-temp-buffer + (cl-loop for i from 1 upto 1000 + do (insert (format "%09d\n" i))) + (let* ((win (display-buffer (current-buffer)))) + (cl-flet ((eval-with-wh (form) + (eval `(let ((wh ,(window-text-height win))) + ,form)))) + (with-selected-window win + (goto-char (sly-test--pos-at-line (eval-with-wh pos-line))) + (sly-recenter (sly-test--pos-at-line (eval-with-wh target))) + (redisplay) + (should (= (eval-with-wh expected-window-start) + (line-number-at-pos (window-start))))))))) + +(def-sly-test find-definition + (name buffer-package snippet) + "Find the definition of a function or macro in slynk.lisp." + '(("start-server" "SLYNK" "(defun start-server ") + ("slynk::start-server" "CL-USER" "(defun start-server ") + ("slynk:start-server" "CL-USER" "(defun start-server ") + ("slynk::connection" "CL-USER" "(defstruct (connection") + ("slynk::*emacs-connection*" "CL-USER" "(defvar \\*emacs-connection\\*") + ) + (switch-to-buffer "*scratch*") ; not buffer of definition + (sly-check-top-level) + (let ((orig-buffer (current-buffer)) + (orig-pos (point)) + (enable-local-variables nil) ; don't get stuck on -*- eval: -*- + (sly-buffer-package buffer-package)) + (sly-edit-definition name) + ;; Postconditions + (sly-check ("Definition of `%S' is in slynk.lisp." name) + (string= (file-name-nondirectory (buffer-file-name)) "slynk.lisp")) + (sly-check ("Looking at '%s'." snippet) (looking-at snippet)) + (sly-pop-find-definition-stack) + (sly-check "Returning from definition restores original buffer/position." + (and (eq orig-buffer (current-buffer)) + (= orig-pos (point))))) + (sly-check-top-level)) + +(def-sly-test (find-definition.2 (:fails-for "allegro" "lispworks")) + (buffer-content buffer-package snippet) + "Check that we're able to find definitions even when +confronted with nasty #.-fu." + '(("#.(prog1 nil (defvar *foobar* 42)) + + (defun .foo. (x) + (+ x #.*foobar*)) + + #.(prog1 nil (makunbound '*foobar*)) + " + "SLYNK" + "[ \t]*(defun .foo. " + ) + ("#.(prog1 nil (defvar *foobar* 42)) + + ;; some comment + (defun .foo. (x) + (+ x #.*foobar*)) + + #.(prog1 nil (makunbound '*foobar*)) + " + "SLYNK" + "[ \t]*(defun .foo. " + ) + ("(in-package slynk) +(eval-when (:compile-toplevel) (defparameter *bar* 456)) +(eval-when (:load-toplevel :execute) (makunbound '*bar*)) +(defun bar () #.*bar*) +(defun .foo. () 123)" +"SLYNK" +"[ \t]*(defun .foo. () 123)")) + (let ((sly-buffer-package buffer-package)) + (with-temp-buffer + (insert buffer-content) + (sly-check-top-level) + (sly-eval + `(slynk:compile-string-for-emacs + ,buffer-content + ,(buffer-name) + '((:position 0) (:line 1 1)) + ,nil + ,nil)) + (let ((bufname (buffer-name))) + (sly-edit-definition ".foo.") + (sly-check ("Definition of `.foo.' is in buffer `%s'." bufname) + (string= (buffer-name) bufname)) + (sly-check "Definition now at point." (looking-at snippet))) + ))) + +(def-sly-test (find-definition.3 + (:fails-for "abcl" "allegro" "clisp" "lispworks" + ("sbcl" version< "1.3.0") + "ecl")) + (name source regexp) + "Extra tests for defstruct." + '(("slynk::foo-struct" + "(progn + (defun foo-fun ()) + (defstruct (foo-struct (:constructor nil) (:predicate nil))) +)" + "(defstruct (foo-struct")) + (switch-to-buffer "*scratch*") + (with-temp-buffer + (insert source) + (let ((sly-buffer-package "SLYNK")) + (sly-eval + `(slynk:compile-string-for-emacs + ,source + ,(buffer-name) + '((:position 0) (:line 1 1)) + ,nil + ,nil))) + (let ((temp-buffer (current-buffer))) + (with-current-buffer "*scratch*" + (sly-edit-definition name) + (sly-check ("Definition of %S is in buffer `%s'." + name temp-buffer) + (eq (current-buffer) temp-buffer)) + (sly-check "Definition now at point." (looking-at regexp))) + ))) + +(def-sly-test complete-symbol + (prefix expected-completions) + "Find the completions of a symbol-name prefix." + '(("cl:compile" (("cl:compile" "cl:compile-file" "cl:compile-file-pathname" + "cl:compiled-function" "cl:compiled-function-p" + "cl:compiler-macro" "cl:compiler-macro-function") + "cl:compile")) + ("cl:foobar" (nil "")) + ("slynk::compile-file" (("slynk::compile-file" + "slynk::compile-file-for-emacs" + "slynk::compile-file-if-needed" + "slynk::compile-file-output" + "slynk::compile-file-pathname") + "slynk::compile-file")) + ("cl:m-v-l" (nil ""))) + (let ((completions (sly-simple-completions prefix))) + (sly-test-expect "Completion set" expected-completions completions))) + +(def-sly-test flex-complete-symbol + (prefix expectations) + "Find the flex completions of a symbol-name prefix." + '(("m-v-b" (("multiple-value-bind" 1))) + ("mvbind" (("multiple-value-bind" 1))) + ("mvcall" (("multiple-value-call" 1))) + ("mvlist" (("multiple-value-list" 3))) + ("echonumberlist" (("slynk:*echo-number-alist*" 1)))) + (let* ((sly-buffer-package "COMMON-LISP") + (completions (car (sly-flex-completions prefix)))) + (cl-loop for (completion before-or-at) in expectations + for pos = (cl-position completion completions :test #'string=) + unless pos + do (ert-fail (format "Didn't find %s in the completions for %s" completion prefix)) + unless (< pos before-or-at) + do (ert-fail (format "Expected to find %s in the first %s completions for %s, but it came in %s +=> %s" + completion before-or-at prefix (1+ pos) + (cl-subseq completions 0 (1+ pos))))))) + +(def-sly-test basic-completion + (input-keys expected-result) + "Test `sly-read-from-minibuffer' with INPUT-KEYS as events." + '(("( r e v e TAB TAB SPC ' ( 1 SPC 2 SPC 3 ) ) RET" + "(reverse '(1 2 3))") + ("( c l : c o n TAB s t a n t l TAB TAB SPC 4 2 ) RET" + "(cl:constantly 42)")) + (when noninteractive + (sly-skip-test "Can't use unread-command-events in batch mode")) + (setq unread-command-events (listify-key-sequence (kbd input-keys))) + (let ((actual-result (sly-read-from-minibuffer "Test: "))) + (sly-test-expect "Completed string" expected-result actual-result))) + +(def-sly-test arglist + ;; N.B. Allegro apparently doesn't return the default values of + ;; optional parameters. Thus the regexp in the start-server + ;; expected value. In a perfect world we'd find a way to smooth + ;; over this difference between implementations--perhaps by + ;; convincing Franz to provide a function that does what we want. + (function-name expected-arglist) + "Lookup the argument list for FUNCTION-NAME. +Confirm that EXPECTED-ARGLIST is displayed." + '(("slynk::operator-arglist" "(slynk::operator-arglist name package)") + ("slynk::compute-backtrace" "(slynk::compute-backtrace start end)") + ("slynk::emacs-connected" "(slynk::emacs-connected)") + ("slynk::compile-string-for-emacs" + "(slynk::compile-string-for-emacs \ +string buffer position filename policy)") + ("slynk::connection-socket-io" + "(slynk::connection-socket-io \ +\\(struct\\(ure\\)?\\|object\\|instance\\|x\\|connection\\))") + ("cl:lisp-implementation-type" "(cl:lisp-implementation-type)") + ("cl:class-name" + "(cl:class-name \\(class\\|object\\|instance\\|structure\\))")) + (let ((arglist (sly-eval `(slynk:operator-arglist ,function-name + "slynk")))) + (sly-test-expect "Argument list is as expected" + expected-arglist (and arglist (downcase arglist)) + (lambda (pattern arglist) + (and arglist (string-match pattern arglist)))))) + +(defun sly-test--compile-defun (program subform) + (sly-check-top-level) + (with-temp-buffer + (lisp-mode) + (insert program) + (let ((font-lock-verbose nil)) + (setq sly-buffer-package ":slynk") + (sly-compile-string (buffer-string) 1) + (setq sly-buffer-package ":cl-user") + (sly-sync-to-top-level 5) + (goto-char (point-max)) + (call-interactively 'sly-previous-note) + (sly-check error-location-correct + (equal (read (current-buffer)) subform)))) + (sly-check-top-level)) + +(def-sly-test (compile-defun (:fails-for "allegro" "lispworks" "clisp")) + (program subform) + "Compile PROGRAM containing errors. +Confirm that the EXPECTED subform is correctly located." + '(("(defun cl-user::foo () (cl-user::bar))" (cl-user::bar)) + ("(defun cl-user::foo () + #\\space + ;;Sdf + (cl-user::bar))" + (cl-user::bar)) + ("(defun cl-user::foo () + #+(or)skipped + #| #||# + #||# |# + (cl-user::bar))" + (cl-user::bar)) + ("(defun cl-user::foo () + \"\\\" bla bla \\\"\" + (cl-user::bar))" + (cl-user::bar)) + ("(defun cl-user::foo () + #.*log-events* + (cl-user::bar))" + (cl-user::bar)) + ("#.'(defun x () (/ 1 0)) + (defun foo () + (cl-user::bar)) + + " + (cl-user::bar))) + (sly-test--compile-defun program subform)) + +;; This test ideally would be collapsed into the previous +;; compile-defun test, but only 1 case fails for ccl--and that's here +(def-sly-test (compile-defun-with-reader-conditionals + (:fails-for "allegro" "lispworks" "clisp" "ccl")) + (program expected) + "Compile PROGRAM containing errors. +Confirm that the EXPECTED subform is correctly located." + '(("(defun foo () + #+#.'(:and) (/ 1 0))" + (/ 1 0))) + (sly-test--compile-defun program expected)) + +;; SBCL used to pass this one but since 1.2.2 the backquote/unquote +;; reader was changed. See +;; https://bugs.launchpad.net/sbcl/+bug/1361502 +(def-sly-test (compile-defun-with-backquote + (:fails-for "sbcl" "allegro" "lispworks" "clisp")) + (program subform) + "Compile PROGRAM containing errors. +Confirm that SUBFORM is correctly located." + '(("(defun cl-user::foo () + (list `(1 ,(random 10) 2 ,@(make-list (random 10)) 3 + ,(cl-user::bar))))" + (cl-user::bar))) + (sly-test--compile-defun program subform)) + +(def-sly-test (compile-file (:fails-for "allegro" "lispworks" "clisp")) + (string) + "Insert STRING in a file, and compile it." + `((,(pp-to-string '(defun foo () nil)))) + (let ((filename "/tmp/sly-tmp-file.lisp")) + (with-temp-file filename + (insert string)) + (let ((cell (cons nil nil))) + (sly-eval-async + `(slynk:compile-file-for-emacs ,filename nil) + (sly-rcurry (lambda (result cell) + (setcar cell t) + (setcdr cell result)) + cell)) + (sly-wait-condition "Compilation finished" (lambda () (car cell)) + 0.5) + (let ((result (cdr cell))) + (sly-check "Compilation successfull" + (eq (sly-compilation-result.successp result) t)))))) + +(def-sly-test utf-8-source + (input output) + "Source code containing utf-8 should work" + (list (let* ((bytes "\343\201\212\343\201\257\343\202\210\343\201\206") + ;;(encode-coding-string (string #x304a #x306f #x3088 #x3046) + ;; 'utf-8) + (string (decode-coding-string bytes 'utf-8-unix))) + (cl-assert (equal bytes (encode-coding-string string 'utf-8-unix))) + (list (concat "(defun cl-user::foo () \"" string "\")") + string))) + (sly-eval `(cl:eval (cl:read-from-string ,input))) + (sly-test-expect "Eval result correct" + output (sly-eval '(cl-user::foo))) + (let ((cell (cons nil nil))) + (let ((hook (sly-curry (lambda (cell &rest _) (setcar cell t)) cell))) + (add-hook 'sly-compilation-finished-hook hook) + (unwind-protect + (progn + (sly-compile-string input 0) + (sly-wait-condition "Compilation finished" + (lambda () (car cell)) + 0.5) + (sly-test-expect "Compile-string result correct" + output (sly-eval '(cl-user::foo)))) + (remove-hook 'sly-compilation-finished-hook hook)) + (let ((filename "/tmp/sly-tmp-file.lisp")) + (setcar cell nil) + (add-hook 'sly-compilation-finished-hook hook) + (unwind-protect + (with-temp-buffer + (when (fboundp 'set-buffer-multibyte) + (set-buffer-multibyte t)) + (setq buffer-file-coding-system 'utf-8-unix) + (setq buffer-file-name filename) + (insert ";; -*- coding: utf-8-unix -*- \n") + (insert input) + (let ((coding-system-for-write 'utf-8-unix)) + (write-region nil nil filename nil t)) + (let ((sly-load-failed-fasl 'always)) + (sly-compile-and-load-file) + (sly-wait-condition "Compilation finished" + (lambda () (car cell)) + 0.5)) + (sly-test-expect "Compile-file result correct" + output (sly-eval '(cl-user::foo)))) + (remove-hook 'sly-compilation-finished-hook hook) + (ignore-errors (delete-file filename))))))) + +(def-sly-test async-eval-debugging (depth) + "Test recursive debugging of asynchronous evaluation requests." + '((1) (2) (3)) + (let ((depth depth) + (debug-hook-max-depth 0)) + (let ((debug-hook + (lambda () + (with-current-buffer (sly-db-get-default-buffer) + (when (> sly-db-level debug-hook-max-depth) + (setq debug-hook-max-depth sly-db-level) + (if (= sly-db-level depth) + ;; We're at maximum recursion - time to unwind + (sly-db-quit) + ;; Going down - enter another recursive debug + ;; Recursively debug. + (sly-eval-async '(error)))))))) + (let ((sly-db-hook (cons debug-hook sly-db-hook))) + (sly-eval-async '(error)) + (sly-sync-to-top-level 5) + (sly-check ("Maximum depth reached (%S) is %S." + debug-hook-max-depth depth) + (= debug-hook-max-depth depth)))))) + +(def-sly-test unwind-to-previous-sly-db-level (level2 level1) + "Test recursive debugging and returning to lower SLY-DB levels." + '((2 1) (4 2)) + (sly-check-top-level) + (let ((level2 level2) + (level1 level1) + (state 'enter) + (max-depth 0)) + (let ((debug-hook + (lambda () + (with-current-buffer (sly-db-get-default-buffer) + (setq max-depth (max sly-db-level max-depth)) + (cl-ecase state + (enter + (cond ((= sly-db-level level2) + (setq state 'leave) + (sly-db-invoke-restart (sly-db-first-abort-restart))) + (t + (sly-eval-async `(cl:aref cl:nil ,sly-db-level))))) + (leave + (cond ((= sly-db-level level1) + (setq state 'ok) + (sly-db-quit)) + (t + (sly-db-invoke-restart (sly-db-first-abort-restart)) + )))))))) + (let ((sly-db-hook (cons debug-hook sly-db-hook))) + (sly-eval-async `(cl:aref cl:nil 0)) + (sly-sync-to-top-level 15) + (sly-check-top-level) + (sly-check ("Maximum depth reached (%S) is %S." max-depth level2) + (= max-depth level2)) + (sly-check ("Final state reached.") + (eq state 'ok)))))) + +(defun sly-db-first-abort-restart () + (let ((case-fold-search t)) + (cl-position-if (lambda (x) (string-match "abort" (car x))) sly-db-restarts))) + +(def-sly-test loop-interrupt-quit + () + "Test interrupting a loop." + '(()) + (sly-check-top-level) + (sly-eval-async '(cl:loop) (lambda (_) ) "CL-USER") + (accept-process-output nil 1) + (sly-check "In eval state." (sly-busy-p)) + (sly-interrupt) + (sly-wait-condition "First interrupt" (lambda () (sly-sly-db-level= 1)) 5) + (with-current-buffer (sly-db-get-default-buffer) + (sly-db-quit)) + (sly-sync-to-top-level 5) + (sly-check-top-level)) + +(def-sly-test loop-interrupt-continue-interrupt-quit + () + "Test interrupting a previously interrupted but continued loop." + '(()) + (sly-check-top-level) + (sly-eval-async '(cl:loop) (lambda (_) ) "CL-USER") + (sleep-for 1) + (sly-wait-condition "running" #'sly-busy-p 5) + (sly-interrupt) + (sly-wait-condition "First interrupt" (lambda () (sly-sly-db-level= 1)) 5) + (with-current-buffer (sly-db-get-default-buffer) + (sly-db-continue)) + (sly-wait-condition "running" (lambda () + (and (sly-busy-p) + (not (sly-db-get-default-buffer)))) 5) + (sly-interrupt) + (sly-wait-condition "Second interrupt" (lambda () (sly-sly-db-level= 1)) 5) + (with-current-buffer (sly-db-get-default-buffer) + (sly-db-quit)) + (sly-sync-to-top-level 5) + (sly-check-top-level)) + +(def-sly-test interactive-eval + () + "Test interactive eval and continuing from the debugger." + '(()) + (sly-check-top-level) + (let ((sly-db-hook (lambda () + (sly-db-continue)))) + (sly-interactive-eval + "(progn\ + (cerror \"foo\" \"restart\")\ + (cerror \"bar\" \"restart\")\ + (+ 1 2))") + (sly-sync-to-top-level 5) + (current-message)) + (unless noninteractive + (should (equal "=> 3 (2 bits, #x3, #o3, #b11)" + (current-message))))) + +(def-sly-test report-condition-with-circular-list + (format-control format-argument) + "Test conditions involving circular lists." + '(("~a" "(let ((x (cons nil nil))) (setf (cdr x) x))") + ("~a" "(let ((x (cons nil nil))) (setf (car x) x))") + ("~a" "(let ((x (cons (make-string 100000 :initial-element #\\X) nil)))\ + (setf (cdr x) x))")) + (sly-check-top-level) + (let ((done nil)) + (let ((sly-db-hook (lambda () (sly-db-continue) (setq done t)))) + (sly-interactive-eval + (format "(with-standard-io-syntax (cerror \"foo\" \"%s\" %s) (+ 1 2))" + format-control format-argument)) + (while (not done) (accept-process-output)) + (sly-sync-to-top-level 5) + (sly-check-top-level) + (unless noninteractive + (let ((message (current-message))) + (sly-check "Minibuffer contains: \"3\"" + (equal "=> 3 (2 bits, #x3, #o3, #b11)" message))))))) + +(def-sly-test interrupt-bubbling-idiot + () + "Test interrupting a loop that sends a lot of output to Emacs." + '(()) + (accept-process-output nil 1) + (sly-check-top-level) + (sly-eval-async '(cl:loop :for i :from 0 :do (cl:progn (cl:print i) + (cl:finish-output))) + (lambda (_) ) + "CL-USER") + (sleep-for 1) + (sly-interrupt) + (sly-wait-condition "Debugger visible" + (lambda () + (and (sly-sly-db-level= 1) + (get-buffer-window (sly-db-get-default-buffer)))) + 30) + (with-current-buffer (sly-db-get-default-buffer) + (sly-db-quit)) + (sly-sync-to-top-level 5)) + +(def-sly-test (interrupt-encode-message (:style :sigio)) + () + "Test interrupt processing during slynk::encode-message" + '(()) + (sly-eval-async '(cl:loop :for i :from 0 + :do (slynk::background-message "foo ~d" i))) + (sleep-for 1) + (sly-eval-async '(cl:/ 1 0)) + (sly-wait-condition "Debugger visible" + (lambda () + (and (sly-sly-db-level= 1) + (get-buffer-window (sly-db-get-default-buffer)))) + 30) + (with-current-buffer (sly-db-get-default-buffer) + (sly-db-quit)) + (sly-sync-to-top-level 5)) + +(def-sly-test inspector + (exp) + "Test basic inspector workingness." + '(((let ((h (make-hash-table))) + (loop for i below 10 do (setf (gethash i h) i)) + h)) + ((make-array 10)) + ((make-list 10)) + ('cons) + (#'cons)) + (sly-inspect (prin1-to-string exp)) + (cl-assert (not (sly-inspector-visible-p))) + (sly-wait-condition "Inspector visible" #'sly-inspector-visible-p 5) + (with-current-buffer (window-buffer (selected-window)) + (sly-inspector-quit)) + (sly-wait-condition "Inspector closed" + (lambda () (not (sly-inspector-visible-p))) + 5) + (sly-sync-to-top-level 1)) + +(defun sly-buffer-visible-p (name) + (let ((buffer (window-buffer (selected-window)))) + (string-match name (buffer-name buffer)))) + +(defun sly-inspector-visible-p () + (sly-buffer-visible-p (sly-buffer-name :inspector :connection t))) + +(defun sly-execute-as-command (name) + "Execute `name' as if it was done by the user through the +Command Loop. Similiar to `call-interactively' but also pushes on +the buffer's undo-list." + (undo-boundary) + (call-interactively name)) + +(def-sly-test macroexpand + (macro-defs bufcontent expansion1 search-str expansion2) + "foo" + '((("(defmacro qwertz (&body body) `(list :qwertz ',body))" + "(defmacro yxcv (&body body) `(list :yxcv (qwertz ,@body)))") + "(yxcv :A :B :C)" + "(list :yxcv (qwertz :a :b :c))" + "(qwertz" + "(list :yxcv (list :qwertz '(:a :b :c)))")) + (sly-check-top-level) + (setq sly-buffer-package ":slynk") + (with-temp-buffer + (lisp-mode) + (dolist (def macro-defs) + (sly-compile-string def 0) + (sly-sync-to-top-level 5)) + (insert bufcontent) + (goto-char (point-min)) + (sly-execute-as-command 'sly-macroexpand-1) + (sly-wait-condition "Macroexpansion buffer visible" + (lambda () + (sly-buffer-visible-p + (sly-buffer-name :macroexpansion))) + 5) + (with-current-buffer (get-buffer (sly-buffer-name :macroexpansion)) + (sly-test-expect "Initial macroexpansion is correct" + expansion1 + (downcase (buffer-string)) + #'sly-test-macroexpansion=) + (search-forward search-str) + (backward-up-list) + (sly-execute-as-command 'sly-macroexpand-1-inplace) + (sly-sync-to-top-level 3) + (sly-test-expect "In-place macroexpansion is correct" + expansion2 + (downcase (buffer-string)) + #'sly-test-macroexpansion=) + (sly-execute-as-command 'sly-macroexpand-undo) + (sly-test-expect "Expansion after undo is correct" + expansion1 + (downcase (buffer-string)) + #'sly-test-macroexpansion=))) + (setq sly-buffer-package ":cl-user")) + +(defun sly-test-macroexpansion= (string1 string2 &optional ignore-case) + (let ((string1 (replace-regexp-in-string " *\n *" " " string1)) + (string2 (replace-regexp-in-string " *\n *" " " string2))) + (compare-strings string1 nil nil + string2 nil nil + ignore-case))) + +(def-sly-test indentation (buffer-content point-markers) + "Check indentation update to work correctly." + '((" +\(in-package :slynk) + +\(defmacro with-lolipop (&body body) + `(progn ,@body)) + +\(defmacro lolipop (&body body) + `(progn ,@body)) + +\(with-lolipop + 1 + 2 + 42) + +\(lolipop + 1 + 2 + 23) +" + ("23" "42"))) + (with-temp-buffer + (lisp-mode) + (sly-editing-mode 1) + (insert buffer-content) + (sly-compile-region (point-min) (point-max)) + (sly-sync-to-top-level 3) + (sly-update-indentation) + (sly-sync-to-top-level 3) + (dolist (marker point-markers) + (search-backward marker) + (beginning-of-defun) + (indent-region (point) (progn (end-of-defun) (point)))) + (sly-test-expect "Correct buffer content" + buffer-content + (substring-no-properties (buffer-string))))) + +(def-sly-test break + (times exp) + "Test whether BREAK invokes SLY-DB." + (let ((exp1 '(break))) + `((1 ,exp1) (2 ,exp1) (3 ,exp1))) + (accept-process-output nil 0.2) + (sly-check-top-level) + (sly-eval-async + `(cl:eval (cl:read-from-string + ,(prin1-to-string `(dotimes (i ,times) + (unless (= i 0) + (slynk::sleep-for 1)) + ,exp))))) + (dotimes (_i times) + (sly-wait-condition "Debugger visible" + (lambda () + (and (sly-sly-db-level= 1) + (get-buffer-window + (sly-db-get-default-buffer)))) + 3) + (with-current-buffer (sly-db-get-default-buffer) + (sly-db-continue)) + (sly-wait-condition "sly-db closed" + (lambda () (not (sly-db-get-default-buffer))) + 0.5)) + (sly-sync-to-top-level 1)) + +(def-sly-test (break2 (:fails-for "cmucl" "allegro")) + (times exp) + "Backends should arguably make sure that BREAK does not depend +on *DEBUGGER-HOOK*." + (let ((exp2 + '(block outta + (let ((*debugger-hook* (lambda (c h) (return-from outta 42)))) + (break))))) + `((1 ,exp2) (2 ,exp2) (3 ,exp2))) + (sly-test-break times exp)) + +(def-sly-test locally-bound-debugger-hook + () + "Test that binding *DEBUGGER-HOOK* locally works properly." + '(()) + (accept-process-output nil 1) + (sly-check-top-level) + (sly-compile-string + (prin1-to-string `(defun cl-user::quux () + (block outta + (let ((*debugger-hook* + (lambda (c hook) + (declare (ignore c hook)) + (return-from outta 42)))) + (error "FOO"))))) + 0) + (sly-sync-to-top-level 2) + (sly-eval-async '(cl-user::quux)) + ;; FIXME: sly-wait-condition returns immediately if the test returns true + (sly-wait-condition "Checking that Debugger does not popup" + (lambda () + (not (sly-db-get-default-buffer))) + 3) + (sly-sync-to-top-level 5)) + +(def-sly-test end-of-file + (expr) + "Signalling END-OF-FILE should invoke the debugger." + '(((cl:read-from-string "")) + ((cl:error 'cl:end-of-file))) + (let ((value (sly-eval + `(cl:let ((condition nil)) + (cl:with-simple-restart + (cl:continue "continue") + (cl:let ((cl:*debugger-hook* + (cl:lambda (c h) + (cl:setq condition c) + (cl:continue)))) + ,expr)) + (cl:and (cl:typep condition 'cl:end-of-file)))))) + (sly-test-expect "Debugger invoked" t value))) + +(def-sly-test interrupt-at-toplevel + () + "Let's see what happens if we send a user interrupt at toplevel." + '(()) + (sly-check-top-level) + (unless (and (eq (sly-communication-style) :spawn) + (not (featurep 'sly-repl))) + (sly-interrupt) + (sly-wait-condition + "Debugger visible" + (lambda () + (and (sly-sly-db-level= 1) + (get-buffer-window (sly-db-get-default-buffer)))) + 5) + (with-current-buffer (sly-db-get-default-buffer) + (sly-db-quit)) + (sly-sync-to-top-level 5))) + +(def-sly-test interrupt-in-debugger (interrupts continues) + "Let's see what happens if we interrupt the debugger. +INTERRUPTS ... number of nested interrupts +CONTINUES ... how often the continue restart should be invoked" + '((1 0) (2 1) (4 2)) + (sly-check "No debugger" (not (sly-db-get-default-buffer))) + (when (and (eq (sly-communication-style) :spawn) + (not (featurep 'sly-repl))) + (sly-eval-async '(slynk::without-sly-interrupts + (slynk::receive))) + (sit-for 0.2)) + (dotimes (i interrupts) + (sly-interrupt) + (let ((level (1+ i))) + (sly-wait-condition (format "Debug level %d reachend" level) + (lambda () (equal (sly-db-level) level)) + 2))) + (dotimes (i continues) + (with-current-buffer (sly-db-get-default-buffer) + (sly-db-continue)) + (let ((level (- interrupts (1+ i)))) + (sly-wait-condition (format "Return to debug level %d" level) + (lambda () (equal (sly-db-level) level)) + 2))) + (with-current-buffer (sly-db-get-default-buffer) + (sly-db-quit)) + (sly-sync-to-top-level 1)) + +(def-sly-test flow-control + (n delay interrupts) + "Let Lisp produce output faster than Emacs can consume it." + `((300 0.03 3)) + (when noninteractive + (sly-skip-test "test is currently unstable")) + (sly-check "No debugger" (not (sly-db-get-default-buffer))) + (sly-eval-async `(slynk:flow-control-test ,n ,delay)) + (sleep-for 0.2) + (dotimes (_i interrupts) + (sly-interrupt) + (sly-wait-condition "In debugger" (lambda () (sly-sly-db-level= 1)) 5) + (sly-check "In debugger" (sly-sly-db-level= 1)) + (with-current-buffer (sly-db-get-default-buffer) + (sly-db-continue)) + (sly-wait-condition "No debugger" (lambda () (sly-sly-db-level= nil)) 3) + (sly-check "Debugger closed" (sly-sly-db-level= nil))) + (sly-sync-to-top-level 10)) + +(def-sly-test sbcl-world-lock + (n delay) + "Print something from *MACROEXPAND-HOOK*. +In SBCL, the compiler grabs a lock which can be problematic because +no method dispatch code can be generated for other threads. +This test will fail more likely before dispatch caches are warmed up." + '((10 0.03) + ;;((cl:+ slynk::send-counter-limit 10) 0.03) + ) + (sly-test-expect "no error" + 123 + (sly-eval + `(cl:let ((cl:*macroexpand-hook* + (cl:lambda (fun form env) + (slynk:flow-control-test ,n ,delay) + (cl:funcall fun form env)))) + (cl:eval '(cl:macrolet ((foo () 123)) + (foo))))))) + +(def-sly-test (disconnect-one-connection (:style :spawn)) () + "`sly-disconnect' should disconnect only the current connection" + '(()) + (let ((connection-count (length sly-net-processes)) + (old-connection sly-default-connection) + (sly-connected-hook nil)) + (unwind-protect + (let ((sly-dispatching-connection + (sly-connect "localhost" + ;; Here we assume that the request will + ;; be evaluated in its own thread. + (sly-eval `(slynk:create-server + :port 0 ; use random port + :style :spawn + :dont-close nil))))) + (sly-sync-to-top-level 3) + (sly-disconnect) + (sly-test-expect "Number of connections must remane the same" + connection-count + (length sly-net-processes))) + (sly-select-connection old-connection)))) + +(def-sly-test disconnect-and-reconnect + () + "Close the connetion. +Confirm that the subprocess continues gracefully. +Reconnect afterwards." + '(()) + (sly-check-top-level) + (let* ((c (sly-connection)) + (p (sly-inferior-process c))) + (with-current-buffer (process-buffer p) + (erase-buffer)) + (delete-process c) + (cl-assert (equal (process-status c) 'closed) nil "Connection not closed") + (accept-process-output nil 0.1) + (cl-assert (equal (process-status p) 'run) nil "Subprocess not running") + (with-current-buffer (process-buffer p) + (cl-assert (< (buffer-size) 500) nil "Unusual output")) + (sly-inferior-connect p (sly-inferior-lisp-args p)) + (let ((hook nil) (p p)) + (setq hook (lambda () + (sly-test-expect + "We are connected again" p (sly-inferior-process)) + (remove-hook 'sly-connected-hook hook))) + (add-hook 'sly-connected-hook hook) + (sly-wait-condition "Lisp restarted" + (lambda () + (not (member hook sly-connected-hook))) + 5)))) + + +;;;; SLY-loading tests that launch separate Emacsen +;;;; +(defvar sly-test-check-repl-forms + `((unless (and (featurep 'sly-mrepl) + (assq 'slynk/mrepl sly-contrib--required-slynk-modules)) + (die "`sly-repl' contrib not properly setup")) + (let ((mrepl-buffer (sly-mrepl--find-buffer))) + (unless mrepl-buffer + (die "MREPL buffer not setup!")) + (with-current-buffer mrepl-buffer + ;; FIXME: suboptimal: wait one second for the lisp + ;; to reply. + (sit-for 1) + (unless (and (string-match "^; +SLY" (buffer-string)) + (string-match "CL-USER> *$" (buffer-string))) + (die (format "MREPL prompt: %s" (buffer-string)))))))) + +(defvar sly-test-check-asdf-loader-forms + `((when (sly-eval '(cl:and (cl:find-package :slynk-loader) t)) + (die "Didn't expect SLY to be loaded with slynk-loader.lisp")))) + +(cl-defun sly-test-recipe-test-for + (&key preflight + (takeoff `((call-interactively 'sly))) + (landing (append sly-test-check-repl-forms + sly-test-check-asdf-loader-forms))) + (let ((success nil) + (test-file (make-temp-file "sly-recipe-" nil ".el")) + (test-forms + `((require 'cl) + (labels + ((die (reason &optional more) + (princ reason) + (terpri) + (and more (pp more)) + (kill-emacs 254))) + (condition-case err + (progn ,@preflight + ,@takeoff + ,(when (null landing) '(kill-emacs 0)) + (add-hook + 'sly-connected-hook + #'(lambda () + (condition-case err + (progn + ,@landing + (kill-emacs 0)) + (error + (die "Unexpected error running landing forms" + err)))) + t)) + (error + (die "Unexpected error running preflight/takeoff forms" err))) + (with-timeout + (30 + (die "Timeout waiting for recipe test to finish.")) + (while t (sit-for 1))))))) + (unwind-protect + (progn + (with-temp-buffer + (mapc #'insert (mapcar #'pp-to-string test-forms)) + (write-file test-file)) + (with-temp-buffer + (let ((retval + (call-process (concat invocation-directory invocation-name) + nil (list t nil) nil + "-Q" "--batch" + "-l" test-file))) + (unless (= 0 retval) + (ert-fail (buffer-string))))) + (setq success t)) + (if success (delete-file test-file) + (message "Test failed: keeping %s for inspection" test-file))))) + +(define-sly-ert-test readme-recipe () + "Test the README.md's autoload recipe." + (sly-test-recipe-test-for + :preflight `((add-to-list 'load-path ,sly-path) + (setq inferior-lisp-program ,inferior-lisp-program) + (require 'sly-autoloads)))) + +(define-sly-ert-test traditional-recipe () + "Test the README.md's traditional recipe." + (sly-test-recipe-test-for + :preflight `((add-to-list 'load-path ,sly-path) + (setq inferior-lisp-program ,inferior-lisp-program) + (require 'sly) + (sly-setup '(sly-fancy))))) + +(define-sly-ert-test slynk-loader-fallback () + "Test `sly-init-using-slynk-loader'" + ;; TODO: another useful test would be to test + ;; `sly-init-using-asdf's fallback to slynk-loader.lisp." + (sly-test-recipe-test-for + :preflight `((add-to-list 'load-path ,sly-path) + (setq inferior-lisp-program ,inferior-lisp-program) + (require 'sly-autoloads) + (setq sly-contribs '(sly-fancy)) + (setq sly-init-function 'sly-init-using-slynk-loader) + (sly-setup '(sly-fancy))) + :landing `((unless (sly-eval '(cl:and (cl:find-package :slynk-loader) t)) + (die "Expected SLY to be loaded with slynk-loader.lisp")) + ,@sly-test-check-repl-forms))) + + +;;; xref recompilation +;;; +(defun sly-test--eval-now (string) + (cl-second (sly-eval `(slynk:eval-and-grab-output ,string)))) + +(def-sly-test (sly-recompile-all-xrefs (:fails-for "cmucl")) () + "Test recompilation of all references within an xref buffer." + '(()) + (let* ((cell (cons nil nil)) + (hook (sly-curry (lambda (cell &rest _) (setcar cell t)) cell)) + (filename (make-temp-file "sly-recompile-all-xrefs" nil ".lisp")) + (xref-buffer)) + (add-hook 'sly-compilation-finished-hook hook) + (unwind-protect + (with-temp-file filename + (set-visited-file-name filename) + (sly-test--eval-now "(defparameter slynk::*.var.* nil)") + (insert "(in-package :slynk) + (defun .fn1. ()) + (defun .fn2. () (.fn1.) #.*.var.*) + (defun .fn3. () (.fn1.) #.*.var.*)") + (save-buffer) + (sly-compile-and-load-file) + (sly-wait-condition "Compilation finished" + (lambda () (car cell)) + 0.5) + (sly-test--eval-now "(setq *.var.* t)") + (setcar cell nil) + (sly-xref :calls ".fn1." + (lambda (&rest args) + (setq xref-buffer (apply #'sly-xref--show-results args)) + (setcar cell t))) + (sly-wait-condition "Xrefs computed and displayed" + (lambda () (car cell)) + 0.5) + (setcar cell nil) + (should (cl-equalp (list (sly-test--eval-now "(.fn2.)") + (sly-test--eval-now "(.fn3.)")) + '("nil" "nil"))) + ;; Recompile now + ;; + (with-current-buffer xref-buffer + (sly-recompile-all-xrefs) + (sly-wait-condition "Compilation finished" + (lambda () (car cell)) + 0.5)) + (should (cl-equalp (list (sly-test--eval-now "(.fn2.)") + (sly-test--eval-now "(.fn3.)")) + '("T" "T")))) + (remove-hook 'sly-compilation-finished-hook hook) + (when xref-buffer + (kill-buffer xref-buffer))))) + + +;;; window management after M-. +;;; +(cl-defmacro sly-test--with-find-definition-window-checker (fn + (window-splits + total-windows + starting-buffer-sym + starting-window-sym) + &rest body) + (declare (indent 2)) + (let ((temp-frame-sym (cl-gensym "temp-frame-"))) + `(progn + (sly-check-top-level) + (let ((,temp-frame-sym nil)) + (unwind-protect + (progn + (setq ,temp-frame-sym (if noninteractive + (selected-frame) + (make-frame))) + ;; too large a frame will exhibit slightly different + ;; window-popping behaviour + (set-frame-width ,temp-frame-sym 100) + (set-frame-height ,temp-frame-sym 40) + (with-selected-frame ,temp-frame-sym + (with-temp-buffer + (delete-other-windows) + (switch-to-buffer (current-buffer)) + (let ((,starting-window-sym (selected-window)) + (,starting-buffer-sym (current-buffer))) + (dotimes (_i ,window-splits) + (split-window)) + (funcall ,fn "cl:print-object") + (should (= ,total-windows (length (window-list ,temp-frame-sym)))) + (with-current-buffer + (window-buffer (selected-window)) + (should (eq major-mode 'sly-xref-mode)) + (forward-line 1) + (sly-xref-goto)) + ,@body)))) + (unless noninteractive + (delete-frame ,temp-frame-sym t))))))) + +(def-sly-test find-definition-same-window (window-splits total-windows) + "Test `sly-edit-definition' windows" + '((0 2) + (1 2) + (2 3)) + (sly-test--with-find-definition-window-checker + 'sly-edit-definition + (window-splits + total-windows + temp-buffer + original-window) + (with-current-buffer + (window-buffer (selected-window)) + (should-not (eq temp-buffer (current-buffer))) + (should (eq (selected-window) original-window))) + (should (= (if (zerop window-splits) + 1 + total-windows) + (length (window-list (selected-frame))))))) + +(def-sly-test find-definition-other-window (window-splits total-windows) + "Test `sly-edit-definition-other-window' windows" + '((0 2) + (1 2) + (2 3)) + (sly-test--with-find-definition-window-checker + 'sly-edit-definition-other-window + (window-splits + total-windows + temp-buffer + original-window) + (with-current-buffer + (window-buffer (selected-window)) + (should (window-live-p original-window)) + (should (eq temp-buffer (window-buffer original-window))) + (should-not (eq (selected-window) original-window))) + (should (= total-windows + (length (window-list (selected-frame))))))) + + + +(provide 'sly-tests) diff --git a/elpa/sly-20220302.1053/sly-autoloads.el b/elpa/sly-20220302.1053/sly-autoloads.el @@ -0,0 +1,145 @@ +;;; sly-autoloads.el --- automatically extracted autoloads -*- lexical-binding: t -*- +;; +;;; Code: + +(add-to-list 'load-path (directory-file-name + (or (file-name-directory #$) (car load-path)))) + + +;;;### (autoloads nil "sly" "sly.el" (0 0 0 0)) +;;; Generated autoloads from sly.el + +(define-obsolete-variable-alias 'sly-setup-contribs 'sly-contribs "2.3.2") + +(defvar sly-contribs '(sly-fancy) "\ +A list of contrib packages to load with SLY.") + +(autoload 'sly-setup "sly" "\ +Have SLY load and use extension modules CONTRIBS. +CONTRIBS defaults to `sly-contribs' and is a list (LIB1 LIB2...) +symbols of `provide'd and `require'd Elisp libraries. + +If CONTRIBS is nil, `sly-contribs' is *not* affected, otherwise +it is set to CONTRIBS. + +However, after `require'ing LIB1, LIB2 ..., this command invokes +additional initialization steps associated with each element +LIB1, LIB2, which can theoretically be reverted by +`sly-disable-contrib.' + +Notably, one of the extra initialization steps is affecting the +value of `sly-required-modules' (which see) thus affecting the +libraries loaded in the Slynk servers. + +If SLY is currently connected to a Slynk and a contrib in +CONTRIBS has never been loaded, that Slynk is told to load the +associated Slynk extension module. + +To ensure that a particular contrib is loaded, use +`sly-enable-contrib' instead. + +\(fn &optional CONTRIBS)" t nil) + +(autoload 'sly-mode "sly" "\ +Minor mode for horizontal SLY functionality. + +This is a minor mode. If called interactively, toggle the `Sly +mode' mode. If the prefix argument is positive, enable the mode, +and if it is zero or negative, disable the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. + +To check whether the minor mode is enabled in the current buffer, +evaluate `sly-mode'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + +\(fn &optional ARG)" t nil) + +(autoload 'sly-editing-mode "sly" "\ +Minor mode for editing `lisp-mode' buffers. + +This is a minor mode. If called interactively, toggle the +`Sly-Editing mode' mode. If the prefix argument is positive, +enable the mode, and if it is zero or negative, disable the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. + +To check whether the minor mode is enabled in the current buffer, +evaluate `sly-editing-mode'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + +\(fn &optional ARG)" t nil) + +(autoload 'sly "sly" "\ +Start a Lisp implementation and connect to it. + + COMMAND designates a the Lisp implementation to start as an +\"inferior\" process to the Emacs process. It is either a +pathname string pathname to a lisp executable, a list (EXECUTABLE +ARGS...), or a symbol indexing +`sly-lisp-implementations'. CODING-SYSTEM is a symbol overriding +`sly-net-coding-system'. + +Interactively, both COMMAND and CODING-SYSTEM are nil and the +prefix argument controls the precise behaviour: + +- With no prefix arg, try to automatically find a Lisp. First + consult `sly-command-switch-to-existing-lisp' and analyse open + connections to maybe switch to one of those. If a new lisp is + to be created, first lookup `sly-lisp-implementations', using + `sly-default-lisp' as a default strategy. Then try + `inferior-lisp-program' if it looks like it points to a valid + lisp. Failing that, guess the location of a lisp + implementation. + +- With a positive prefix arg (one C-u), prompt for a command + string that starts a Lisp implementation. + +- With a negative prefix arg (M-- M-x sly, for example) prompt + for a symbol indexing one of the entries in + `sly-lisp-implementations' + +\(fn &optional COMMAND CODING-SYSTEM INTERACTIVE)" t nil) + +(autoload 'sly-connect "sly" "\ +Connect to a running Slynk server. Return the connection. +With prefix arg, asks if all connections should be closed +before. + +\(fn HOST PORT &optional CODING-SYSTEM INTERACTIVE-P)" t nil) + +(autoload 'sly-hyperspec-lookup "sly" "\ +A wrapper for `hyperspec-lookup' + +\(fn SYMBOL-NAME)" t nil) + +(autoload 'sly-info "sly" "\ +Read SLY manual + +\(fn FILE &optional NODE)" t nil) + +(add-hook 'lisp-mode-hook 'sly-editing-mode) + +(register-definition-prefixes "sly" '("define-sly-" "inferior-lisp-program" "make-sly-" "sly-")) + +;;;*** + +;;;### (autoloads nil nil ("sly-pkg.el") (0 0 0 0)) + +;;;*** + +;; Local Variables: +;; version-control: never +;; no-byte-compile: t +;; no-update-autoloads: t +;; coding: utf-8-emacs-unix +;; End: +;;; sly-autoloads.el ends here diff --git a/elpa/sly-20220302.1053/sly-pkg.el b/elpa/sly-20220302.1053/sly-pkg.el @@ -0,0 +1,8 @@ +(define-package "sly" "20220302.1053" "Sylvester the Cat's Common Lisp IDE" + '((emacs "24.3")) + :commit "4513c382f07a2a2cedb3c046231b69eae2f5e6f0" :keywords + '("languages" "lisp" "sly") + :url "https://github.com/joaotavora/sly") +;; Local Variables: +;; no-byte-compile: t +;; End: diff --git a/elpa/sly-20220302.1053/sly.el b/elpa/sly-20220302.1053/sly.el @@ -0,0 +1,7487 @@ +;;; sly.el --- Sylvester the Cat's Common Lisp IDE -*- lexical-binding: t; -*- + +;; Version: 1.0.43 +;; URL: https://github.com/joaotavora/sly +;; Package-Requires: ((emacs "24.3")) +;; Keywords: languages, lisp, sly + +;; Copyright (C) 2003 Eric Marsden, Luke Gorrie, Helmut Eller +;; Copyright (C) 2004,2005,2006 Luke Gorrie, Helmut Eller +;; Copyright (C) 2007,2008,2009 Helmut Eller, Tobias C. Rittweiler +;; Copyright (C) 2014 João Távora +;; For a detailed list of contributors, see the manual. + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; _____ __ __ __ +;; / ___/ / / \ \/ / |\ _,,,---,,_ +;; \__ \ / / \ / /,`.-'`' -. ;-;;,_ +;; ___/ / / /___ / / |,4- ) )-,_..;\ ( `'-' +;; /____/ /_____/ /_/ '---''(_/--' `-'\_) +;; +;; +;; SLY is Sylvester the Cat's Common Lisp IDE. +;; +;; SLY is a direct fork of SLIME, and contains the following +;; improvements over it: +;; +;; * A full-featured REPL based on Emacs's `comint.el`; +;; * Live code annotations via a new `sly-stickers` contrib; +;; * Consistent button interface. Every Lisp object can be copied to the REPL; +;; * flex-style completion out-of-the-box, using Emacs's completion API. +;; Company, Helm, and others supported natively, no plugin required; +;; * Cleanly ASDF-loaded by default, including contribs, enabled out-of-the-box; +;; * Multiple inspectors and multiple REPLs; +;; * An interactive trace dialog with interactive objects. Copies function calls +;; to the REPL; +;; * "Presentations" replaced by interactive backreferences which +;; highlight the object and remain stable throughout the REPL session; +;; +;; SLY is a fork of SLIME. We track its bugfixes, particularly to the +;; implementation backends. All SLIME's familar features (debugger, +;; inspector, xref, etc...) are still available, with improved overall +;; UX. +;; +;; See the NEWS.md file (should be sitting alongside this file) for +;; more information + +;;; Code: + +(require 'cl-lib) + +(eval-and-compile + (if (version< emacs-version "24.3") + (error "Sly requires at least Emacs 24.3"))) + +(eval-and-compile + (or (require 'hyperspec nil t) + (require 'hyperspec "lib/hyperspec"))) +(require 'thingatpt) +(require 'comint) +(require 'pp) +(require 'easymenu) +(require 'arc-mode) +(require 'etags) +(require 'apropos) +(require 'bytecomp) ;; for `byte-compile-current-file' and +;; `sly-byte-compile-hotspots'. + +(require 'sly-common "lib/sly-common") +(require 'sly-messages "lib/sly-messages") +(require 'sly-buttons "lib/sly-buttons") +(require 'sly-completion "lib/sly-completion") + +(require 'gv) ; for gv--defsetter + +(eval-when-compile + (require 'compile) + (require 'gud)) + +(defvar sly-path nil + "Directory containing the SLY package. +This is used to load the supporting Common Lisp library, Slynk. +The default value is automatically computed from the location of the +Emacs Lisp package.") + +;; Determine `sly-path' at load time, regardless of filename (.el or +;; .elc) being loaded. +;; +(setq sly-path + (if load-file-name + (file-name-directory load-file-name) + (error "[sly] fatal: impossible to determine sly-path"))) + +(defun sly-slynk-path () + "Path where the bundled Slynk server is located." + (expand-file-name "slynk/" sly-path)) + +;;;###autoload +(define-obsolete-variable-alias 'sly-setup-contribs + 'sly-contribs "2.3.2") +;;;###autoload +(defvar sly-contribs '(sly-fancy) + "A list of contrib packages to load with SLY.") + +;;;###autoload +(defun sly-setup (&optional contribs) + "Have SLY load and use extension modules CONTRIBS. +CONTRIBS defaults to `sly-contribs' and is a list (LIB1 LIB2...) +symbols of `provide'd and `require'd Elisp libraries. + +If CONTRIBS is nil, `sly-contribs' is *not* affected, otherwise +it is set to CONTRIBS. + +However, after `require'ing LIB1, LIB2 ..., this command invokes +additional initialization steps associated with each element +LIB1, LIB2, which can theoretically be reverted by +`sly-disable-contrib.' + +Notably, one of the extra initialization steps is affecting the +value of `sly-required-modules' (which see) thus affecting the +libraries loaded in the Slynk servers. + +If SLY is currently connected to a Slynk and a contrib in +CONTRIBS has never been loaded, that Slynk is told to load the +associated Slynk extension module. + +To ensure that a particular contrib is loaded, use +`sly-enable-contrib' instead." + ;; FIXME: The contract should be like some hypothetical + ;; `sly-refresh-contribs' + ;; + (interactive) + (when contribs + (setq sly-contribs contribs)) + (sly--setup-contribs)) + +(defvaralias 'sly-required-modules 'sly-contrib--required-slynk-modules) + +(defvar sly-contrib--required-slynk-modules '() + "Alist of (MODULE . (WHERE CONTRIB)) for slynk-provided features. + +MODULE is a symbol naming a specific Slynk feature, WHERE is +the full pathname to the directory where the file(s) +providing the feature are found and CONTRIB is a symbol as found +in `sly-contribs.'") + +(cl-defmacro sly--contrib-safe (contrib &body body) + "Run BODY catching and resignalling any errors for CONTRIB" + (declare (indent 1)) + `(condition-case-unless-debug e + (progn + ,@body) + (error (sly-error "There's an error in %s: %s" + ,contrib + e)))) + +(defun sly--setup-contribs () + "Load and initialize contribs." + ;; active != enabled + ;; ^ ^ + ;; | | + ;; v v + ;; forgotten != disabled + (add-to-list 'load-path (expand-file-name "contrib" sly-path)) + (mapc (lambda (c) + (sly--contrib-safe c (require c))) + sly-contribs) + (let* ((all-active-contribs + ;; these are the contribs the user chose to activate + ;; + (mapcar #'sly-contrib--find-contrib + (cl-reduce #'append (mapcar #'sly-contrib--all-dependencies + sly-contribs)))) + (defined-but-forgotten-contribs + ;; "forgotten contribs" are the ones the chose not to + ;; activate but whose definitions we have seen + ;; + (cl-remove-if #'(lambda (contrib) + (memq contrib all-active-contribs)) + (sly-contrib--all-contribs)))) + ;; Disable any forgotten contribs that are enabled right now. + ;; + (cl-loop for to-disable in defined-but-forgotten-contribs + when (sly--contrib-safe to-disable + (sly-contrib--enabled-p to-disable)) + do (funcall (sly-contrib--disable to-disable))) + ;; Enable any active contrib that is *not* enabled right now. + ;; + (cl-loop for to-enable in all-active-contribs + unless (sly--contrib-safe to-enable + (sly-contrib--enabled-p to-enable)) + do (funcall (sly-contrib--enable to-enable))) + ;; Some contribs add stuff to `sly-mode-hook' or + ;; `sly-editing-hook', so make sure we re-run those hooks now. + (when all-active-contribs + (defvar sly-editing-mode) ;FIXME: Forward reference! + (cl-loop for buffer in (buffer-list) + do (with-current-buffer buffer + (when sly-editing-mode (sly-editing-mode 1))))))) + +(eval-and-compile + (defun sly-version (&optional interactive file) + "Read SLY's version of its own sly.el file. +If FILE is passed use that instead to discover the version." + (interactive "p") + (let ((version + (with-temp-buffer + (insert-file-contents + (or file + (expand-file-name "sly.el" sly-path)) + nil 0 200) + (and (search-forward-regexp + ";;[[:space:]]*Version:[[:space:]]*\\(.*\\)$" nil t) + (match-string 1))))) + (if interactive + (sly-message "SLY %s" version) + version)))) + +(defvar sly-protocol-version nil) + +(setq sly-protocol-version + ;; Compile the version string into the generated .elc file, but + ;; don't actualy affect `sly-protocol-version' until load-time. + ;; + (eval-when-compile (sly-version nil (or load-file-name + byte-compile-current-file)))) + + +;;;; Customize groups +;; +;;;;; sly + +(defgroup sly nil + "Interaction with the Superior Lisp Environment." + :prefix "sly-" + :group 'applications) + +;;;;; sly-ui + +(defgroup sly-ui nil + "Interaction with the Superior Lisp Environment." + :prefix "sly-" + :group 'sly) + +(defcustom sly-truncate-lines t + "Set `truncate-lines' in popup buffers. +This applies to buffers that present lines as rows of data, such as +debugger backtraces and apropos listings." + :type 'boolean + :group 'sly-ui) + +(defcustom sly-kill-without-query-p nil + "If non-nil, kill SLY processes without query when quitting Emacs. +This applies to the *inferior-lisp* buffer and the network connections." + :type 'boolean + :group 'sly-ui) + +;;;;; sly-lisp + +(defgroup sly-lisp nil + "Lisp server configuration." + :prefix "sly-" + :group 'sly) + +(defcustom sly-ignore-protocol-mismatches nil + "If non-nil, ignore protocol mismatches between SLY and Slynk. +Programatically, this variable can be let-bound around calls to +`sly' or `sly-connect'." + :type 'boolean + :group 'sly) + +(defcustom sly-init-function 'sly-init-using-asdf + "Function bootstrapping slynk on the remote. + +Value is a function of two arguments: SLYNK-PORTFILE and an +ingored argument for backward compatibility. Function should +return a string issuing very first commands issued by Sly to +the remote-connection process. Some time after this there should +be a port number ready in SLYNK-PORTFILE." + :type '(choice (const :tag "Use ASDF" + sly-init-using-asdf) + (const :tag "Use legacy slynk-loader.lisp" + sly-init-using-slynk-loader)) + :group 'sly-lisp) + +(define-obsolete-variable-alias 'sly-backend + 'sly-slynk-loader-backend "3.0") + +(defcustom sly-slynk-loader-backend "slynk-loader.lisp" + "The name of the slynk-loader that loads the Slynk server. +Only applicable if `sly-init-function' is set to +`sly-init-using-slynk-loader'. This name is interpreted +relative to the directory containing sly.el, but could also be +set to an absolute filename." + :type 'string + :group 'sly-lisp) + +(defcustom sly-connected-hook nil + "List of functions to call when SLY connects to Lisp." + :type 'hook + :group 'sly-lisp) + +(defcustom sly-enable-evaluate-in-emacs nil + "*If non-nil, the inferior Lisp can evaluate arbitrary forms in Emacs. +The default is nil, as this feature can be a security risk." + :type '(boolean) + :group 'sly-lisp) + +(defcustom sly-lisp-host "localhost" + "The default hostname (or IP address) to connect to." + :type 'string + :group 'sly-lisp) + +(defcustom sly-port 4005 + "Port to use as the default for `sly-connect'." + :type 'integer + :group 'sly-lisp) + +(defvar sly-connect-host-history (list sly-lisp-host)) +(defvar sly-connect-port-history (list (prin1-to-string sly-port))) + +(defvar sly-net-valid-coding-systems + '((iso-latin-1-unix nil "iso-latin-1-unix") + (iso-8859-1-unix nil "iso-latin-1-unix") + (binary nil "iso-latin-1-unix") + (utf-8-unix t "utf-8-unix") + (emacs-mule-unix t "emacs-mule-unix") + (euc-jp-unix t "euc-jp-unix")) + "A list of valid coding systems. +Each element is of the form: (NAME MULTIBYTEP CL-NAME)") + +(defun sly-find-coding-system (name) + "Return the coding system for the symbol NAME. +The result is either an element in `sly-net-valid-coding-systems' +of nil." + (let ((probe (assq name sly-net-valid-coding-systems))) + (when (and probe (if (fboundp 'check-coding-system) + (ignore-errors (check-coding-system (car probe))) + (eq (car probe) 'binary))) + probe))) + +(defcustom sly-net-coding-system + (car (cl-find-if 'sly-find-coding-system + sly-net-valid-coding-systems :key 'car)) + "Coding system used for network connections. +See also `sly-net-valid-coding-systems'." + :type (cons 'choice + (mapcar (lambda (x) + (list 'const (car x))) + sly-net-valid-coding-systems)) + :group 'sly-lisp) + +;;;;; sly-mode + +(defgroup sly-mode nil + "Settings for sly-mode Lisp source buffers." + :prefix "sly-" + :group 'sly) + +;;;;; sly-mode-faces + +(defgroup sly-mode-faces nil + "Faces in sly-mode source code buffers." + :prefix "sly-" + :group 'sly-mode) + +(defface sly-error-face + `((((class color) (background light)) + (:underline "tomato")) + (((class color) (background dark)) + (:underline "tomato")) + (t (:underline t))) + "Face for errors from the compiler." + :group 'sly-mode-faces) + +(defface sly-warning-face + `((((class color) (background light)) + (:underline "orange")) + (((class color) (background dark)) + (:underline "coral")) + (t (:underline t))) + "Face for warnings from the compiler." + :group 'sly-mode-faces) + +(defface sly-style-warning-face + `((((class color) (background light)) + (:underline "olive drab")) + (((class color) (background dark)) + (:underline "khaki")) + (t (:underline t))) + "Face for style-warnings from the compiler." + :group 'sly-mode-faces) + +(defface sly-note-face + `((((class color) (background light)) + (:underline "brown3")) + (((class color) (background dark)) + (:underline "light goldenrod")) + (t (:underline t))) + "Face for notes from the compiler." + :group 'sly-mode-faces) + +;;;;; sly-db + +(defgroup sly-debugger nil + "Backtrace options and fontification." + :prefix "sly-db-" + :group 'sly) + +(defmacro define-sly-db-faces (&rest faces) + "Define the set of SLY-DB faces. +Each face specifiation is (NAME DESCRIPTION &optional PROPERTIES). +NAME is a symbol; the face will be called sly-db-NAME-face. +DESCRIPTION is a one-liner for the customization buffer. +PROPERTIES specifies any default face properties." + `(progn ,@(cl-loop for face in faces + collect `(define-sly-db-face ,@face)))) + +(defmacro define-sly-db-face (name description &optional default) + (let ((facename (intern (format "sly-db-%s-face" (symbol-name name))))) + `(defface ,facename + (list (list t ,default)) + ,(format "Face for %s." description) + :group 'sly-debugger))) + +(define-sly-db-faces + (topline "the top line describing the error") + (condition "the condition class" '(:inherit error)) + (section "the labels of major sections in the debugger buffer" + '(:inherit header-line)) + (frame-label "backtrace frame numbers" + '(:inherit shadow)) + (restart "restart descriptions") + (restart-number "restart numbers (correspond to keystrokes to invoke)" + '(:inherit shadow)) + (frame-line "function names and arguments in the backtrace") + (restartable-frame-line + "frames which are surely restartable" + '(:inherit font-lock-constant-face)) + (non-restartable-frame-line + "frames which are surely not restartable") + (local-name "local variable names") + (catch-tag "catch tags")) + + +;;;;; Key bindings +(defvar sly-doc-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-a") 'sly-apropos) + (define-key map (kbd "C-z") 'sly-apropos-all) + (define-key map (kbd "C-p") 'sly-apropos-package) + (define-key map (kbd "C-d") 'sly-describe-symbol) + (define-key map (kbd "C-f") 'sly-describe-function) + (define-key map (kbd "C-h") 'sly-documentation-lookup) + (define-key map (kbd "~") 'common-lisp-hyperspec-format) + (define-key map (kbd "C-g") 'common-lisp-hyperspec-glossary-term) + (define-key map (kbd "#") 'common-lisp-hyperspec-lookup-reader-macro) + map)) + +(defvar sly-who-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-c") 'sly-who-calls) + (define-key map (kbd "C-w") 'sly-calls-who) + (define-key map (kbd "C-r") 'sly-who-references) + (define-key map (kbd "C-b") 'sly-who-binds) + (define-key map (kbd "C-s") 'sly-who-sets) + (define-key map (kbd "C-m") 'sly-who-macroexpands) + (define-key map (kbd "C-a") 'sly-who-specializes) + map)) + +(defvar sly-selector-map (let ((map (make-sparse-keymap))) + (define-key map "c" 'sly-list-connections) + (define-key map "t" 'sly-list-threads) + (define-key map "d" 'sly-db-pop-to-debugger-maybe) + (define-key map "e" 'sly-pop-to-events-buffer) + (define-key map "i" 'sly-inferior-lisp-buffer) + (define-key map "l" 'sly-switch-to-most-recent) + map) + "A keymap for frequently used SLY shortcuts. +Access to this keymap can be installed in in +`sly-mode-map', using something like + + (global-set-key (kbd \"C-z\") sly-selector-map) + +This will bind C-z to this prefix map, one keystroke away from +the available shortcuts: + +\\{sly-selector-map} +As usual, users or extensions can plug in +any command into it using + + (define-key sly-selector-map (kbd \"k\") 'sly-command) + +Where \"k\" is the key to bind and \"sly-command\" is any +interactive command.\".") + +(defvar sly-prefix-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-r") 'sly-eval-region) + (define-key map (kbd ":") 'sly-interactive-eval) + (define-key map (kbd "C-e") 'sly-interactive-eval) + (define-key map (kbd "E") 'sly-edit-value) + (define-key map (kbd "C-l") 'sly-load-file) + (define-key map (kbd "C-b") 'sly-interrupt) + (define-key map (kbd "M-d") 'sly-disassemble-symbol) + (define-key map (kbd "C-t") 'sly-toggle-trace-fdefinition) + (define-key map (kbd "I") 'sly-inspect) + (define-key map (kbd "C-x t") 'sly-list-threads) + (define-key map (kbd "C-x n") 'sly-next-connection) + (define-key map (kbd "C-x c") 'sly-list-connections) + (define-key map (kbd "C-x p") 'sly-prev-connection) + (define-key map (kbd "<") 'sly-list-callers) + (define-key map (kbd ">") 'sly-list-callees) + ;; Include DOC keys... + (define-key map (kbd "C-d") sly-doc-map) + ;; Include XREF WHO-FOO keys... + (define-key map (kbd "C-w") sly-who-map) + ;; `sly-selector-map' used to be bound to "C-c C-s" by default, + ;; but sly-stickers has a better binding for that. + ;; + ;; (define-key map (kbd "C-s") sly-selector-map) + map)) + +(defvar sly-mode-map + (let ((map (make-sparse-keymap))) + ;; These used to be a `sly-parent-map' + (define-key map (kbd "M-.") 'sly-edit-definition) + (define-key map (kbd "M-,") 'sly-pop-find-definition-stack) + (define-key map (kbd "M-_") 'sly-edit-uses) ; for German layout + (define-key map (kbd "M-?") 'sly-edit-uses) ; for USian layout + (define-key map (kbd "C-x 4 .") 'sly-edit-definition-other-window) + (define-key map (kbd "C-x 5 .") 'sly-edit-definition-other-frame) + (define-key map (kbd "C-x C-e") 'sly-eval-last-expression) + (define-key map (kbd "C-M-x") 'sly-eval-defun) + ;; Include PREFIX keys... + (define-key map (kbd "C-c") sly-prefix-map) + ;; Completion + (define-key map (kbd "C-c TAB") 'completion-at-point) + ;; Evaluating + (define-key map (kbd "C-c C-p") 'sly-pprint-eval-last-expression) + ;; Macroexpand + (define-key map (kbd "C-c C-m") 'sly-expand-1) + (define-key map (kbd "C-c M-m") 'sly-macroexpand-all) + ;; Misc + (define-key map (kbd "C-c C-u") 'sly-undefine-function) + map)) + +(defvar sly-editing-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "M-p") 'sly-previous-note) + (define-key map (kbd "M-n") 'sly-next-note) + (define-key map (kbd "C-c M-c") 'sly-remove-notes) + (define-key map (kbd "C-c C-k") 'sly-compile-and-load-file) + (define-key map (kbd "C-c M-k") 'sly-compile-file) + (define-key map (kbd "C-c C-c") 'sly-compile-defun) + map)) + +(defvar sly-popup-buffer-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "q") 'quit-window) + map)) + + +;;;; Minor modes + +;;;;; sly-mode +(defvar sly-buffer-connection) +(defvar sly-dispatching-connection) +(defvar sly-current-thread) + +;; exceptional forward decl +(defvar company-tooltip-align-annotations) + +;;;###autoload +(define-minor-mode sly-mode + "Minor mode for horizontal SLY functionality." + nil nil nil + ;; Company-mode should have this by default + ;; See gh#166 + (set (make-local-variable 'company-tooltip-align-annotations) t)) + +(defun sly--lisp-indent-function (&rest args) + (let ((fn (if (fboundp 'sly-common-lisp-indent-function) + #'sly-common-lisp-indent-function + #'lisp-indent-function))) + (apply fn args))) + +;;;###autoload +(define-minor-mode sly-editing-mode + "Minor mode for editing `lisp-mode' buffers." + nil nil nil + (sly-mode 1) + (setq-local lisp-indent-function #'sly--lisp-indent-function)) + +(define-minor-mode sly-popup-buffer-mode + "Minor mode for all read-only SLY buffers" + nil nil nil + (sly-mode 1) + (sly-interactive-buttons-mode 1) + (setq buffer-read-only t)) + + +;;;;;; Mode-Line +(defface sly-mode-line + '((t (:inherit font-lock-constant-face + :weight bold))) + "Face for package-name in SLY's mode line." + :group 'sly) + +(defvar sly--mode-line-format `(:eval (sly--mode-line-format))) + +(put 'sly--mode-line-format 'risky-local-variable t) + +(defvar sly-menu) ;; forward referenced + +(defvar sly-extra-mode-line-constructs nil + "A list of mode-line constructs to add to SLY's mode-line. +Each construct is separated by a \"/\" and may be a regular +mode-line construct or a symbol naming a function of no arguments +that returns one such construct.") + +(defun sly--mode-line-format () + (let* ((conn (sly-current-connection)) + (conn (and (process-live-p conn) conn)) + (name (or (and conn + (sly-connection-name conn)) + "*")) + (pkg (sly-current-package)) + (format-number (lambda (n) (cond ((and n (not (zerop n))) + (format "%d" n)) + (n "-") + (t "*")))) + (package-name (and pkg + (sly--pretty-package-name pkg))) + (pending (and conn + (length (sly-rex-continuations conn)))) + (sly-dbs (and conn (length (sly-db-buffers conn))))) + `((:propertize "sly" + face sly-mode-line + keymap ,(let ((map (make-sparse-keymap))) + (define-key map [mode-line down-mouse-1] + sly-menu) + map) + mouse-face mode-line-highlight + help-echo "mouse-1: pop-up SLY menu" + ) + " " + (:propertize ,name + face sly-mode-line + keymap ,(let ((map (make-sparse-keymap))) + (define-key map [mode-line mouse-1] 'sly-prev-connection) + (define-key map [mode-line mouse-2] 'sly-list-connections) + (define-key map [mode-line mouse-3] 'sly-next-connection) + map) + mouse-face mode-line-highlight + help-echo ,(concat "mouse-1: previous connection\n" + "mouse-2: list connections\n" + "mouse-3: next connection")) + "/" + ,(or package-name "*") + "/" + (:propertize ,(funcall format-number pending) + help-echo ,(if conn (format "%s pending events outgoing\n%s" + pending + (concat "mouse-1: go to *sly-events* buffer" + "mouse-3: forget pending continuations")) + "No current connection") + mouse-face mode-line-highlight + face ,(cond ((and pending (cl-plusp pending)) + 'warning) + (t + 'sly-mode-line)) + keymap ,(let ((map (make-sparse-keymap))) + (define-key map [mode-line mouse-1] 'sly-pop-to-events-buffer) + (define-key map [mode-line mouse-3] 'sly-forget-pending-events) + map)) + "/" + (:propertize ,(funcall format-number sly-dbs) + help-echo ,(if conn (format "%s SLY-DB buffers waiting\n%s" + pending + "mouse-1: go to first one") + "No current connection") + mouse-face mode-line-highlight + face ,(cond ((and sly-dbs (cl-plusp sly-dbs)) + 'warning) + (t + 'sly-mode-line)) + keymap ,(let ((map (make-sparse-keymap))) + (define-key map [mode-line mouse-1] 'sly-db-pop-to-debugger) + map)) + ,@(cl-loop for construct in sly-extra-mode-line-constructs + collect "/" + collect (if (and (symbolp construct) + (fboundp construct)) + (condition-case _oops + (funcall construct) + (error "*sly-invalid*")) + construct))))) + +(defun sly--refresh-mode-line () + (force-mode-line-update t)) + +(defun sly--pretty-package-name (name) + "Return a pretty version of a package name NAME." + (cond ((string-match "^#?:\\(.*\\)$" name) + (match-string 1 name)) + ((string-match "^\"\\(.*\\)\"$" name) + (match-string 1 name)) + (t name))) + +(add-to-list 'mode-line-misc-info + `(sly-mode (" [" sly--mode-line-format "] "))) + + +;;;; Framework'ey bits +;;; +;;; This section contains some standard SLY idioms: basic macros, +;;; ways of showing messages to the user, etc. All the code in this +;;; file should use these functions when applicable. +;;; +;;;;; Syntactic sugar + +(cl-defmacro sly--when-let ((var value) &rest body) + "Evaluate VALUE, if the result is non-nil bind it to VAR and eval BODY. + +\(fn (VAR VALUE) &rest BODY)" + (declare (indent 1)) + `(let ((,var ,value)) + (when ,var ,@body))) + +(cl-defmacro sly--when-let* (bindings &rest body) + "Same as `sly--when-let', but for multiple BINDINGS" + (declare (indent 1)) + (if bindings + `(sly--when-let ,(car bindings) + (sly--when-let* ,(cdr bindings) ,@body)) + `(progn ,@body))) + +(defmacro sly-dcase (value &rest patterns) + (declare (indent 1) + (debug (sexp &rest (sexp &rest form)))) + "Dispatch VALUE to one of PATTERNS. +A cross between `case' and `destructuring-bind'. +The pattern syntax is: + ((HEAD . ARGS) . BODY) +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 (cl-gensym "op-")) + (operands (cl-gensym "rand-")) + (tmp (cl-gensym "tmp-"))) + `(let* ((,tmp ,value) + (,operator (car ,tmp)) + (,operands (cdr ,tmp))) + (cl-case ,operator + ,@(mapcar (lambda (clause) + (if (eq (car clause) t) + `(t ,@(cdr clause)) + (cl-destructuring-bind ((op &rest rands) &rest body) + clause + `(,op (cl-destructuring-bind ,rands ,operands + . ,(or body + '((ignore)) ; suppress some warnings + )))))) + patterns) + ,@(if (eq (caar (last patterns)) t) + '() + `((t (sly-error "Elisp sly-dcase failed: %S" ,tmp)))))))) + +;;;;; Very-commonly-used functions + +;; Interface +(cl-defun sly-buffer-name (type &key connection hidden suffix) + (cl-assert (keywordp type)) + (mapconcat #'identity + `(,@(if hidden `(" ")) + "*sly-" + ,(downcase (substring (symbol-name type) 1)) + ,@(if connection + `(" for " + ,(sly-connection-name + (if (eq connection t) + (sly-current-connection) + connection)))) + ,@(if suffix + `(" (" + ,suffix + ")")) + "*") + "")) + +(defun sly-recenter (target &optional move-point) + "Make the region between point and TARGET visible. +Minimize window motion if possible. If MOVE-POINT allow point to +move to make TARGET visible." + (unless (pos-visible-in-window-p target) + (redisplay) + (let ((screen-line (- (line-number-at-pos) + (line-number-at-pos (window-start)))) + (window-end (line-number-at-pos (window-end))) + (window-start (line-number-at-pos (window-start))) + (target-line (line-number-at-pos target)) + recenter-arg) + (cond ((> (point) target) + (setq recenter-arg (+ screen-line (- window-start target-line))) + (if (or (not move-point) + (<= recenter-arg (window-height))) + (recenter recenter-arg) + (goto-char target) + (recenter -1) + (move-to-window-line -1))) + ((<= (point) target) + (setq recenter-arg (- screen-line (- target-line window-end))) + (if (or (not move-point) + (> recenter-arg 0)) + (recenter (max recenter-arg 0)) + (goto-char target) + (recenter 0) + (move-to-window-line 0))))))) + +;; Interface +(defun sly-set-truncate-lines () + "Apply `sly-truncate-lines' to the current buffer." + (when sly-truncate-lines + (set (make-local-variable 'truncate-lines) t))) + +;; Interface +(defun sly-read-package-name (prompt &optional initial-value allow-blank) + "Read a package name from the minibuffer, prompting with PROMPT. +If ALLOW-BLANK may return nil to signal no particular package +selected." + (let* ((completion-ignore-case t) + (res (completing-read + (concat "[sly] " prompt) + (sly-eval + `(slynk:list-all-package-names t)) + nil (not allow-blank) initial-value))) + (unless (zerop (length res)) + res))) + +;; Interface +(defmacro sly-propertize-region (props &rest body) + "Execute BODY and add PROPS to all the text it inserts. +More precisely, PROPS are added to the region between the point's +positions before and after executing BODY." + (declare (indent 1) (debug (sexp &rest form))) + (let ((start (cl-gensym))) + `(let ((,start (point))) + (prog1 (progn ,@body) + (add-text-properties ,start (point) ,props))))) + +(defun sly-add-face (face string) + (declare (indent 1)) + (add-text-properties 0 (length string) (list 'face face) string) + string) + +;; Interface +(defsubst sly-insert-propertized (props &rest args) + "Insert all ARGS and then add text-PROPS to the inserted text." + (sly-propertize-region props (apply #'insert args))) + +(defmacro sly-with-rigid-indentation (level &rest body) + "Execute BODY and then rigidly indent its text insertions. +Assumes all insertions are made at point." + (declare (indent 1)) + (let ((start (cl-gensym)) (l (cl-gensym))) + `(let ((,start (point)) (,l ,(or level '(current-column)))) + (prog1 (progn ,@body) + (sly-indent-rigidly ,start (point) ,l))))) + +(defun sly-indent-rigidly (start end column) + ;; Similar to `indent-rigidly' but doesn't inherit text props. + (let ((indent (make-string column ?\ ))) + (save-excursion + (goto-char end) + (beginning-of-line) + (while (and (<= start (point)) + (progn + (insert-before-markers indent) + (zerop (forward-line -1)))))))) + +(defun sly-insert-indented (&rest strings) + "Insert all arguments rigidly indented." + (sly-with-rigid-indentation nil + (apply #'insert strings))) + +(defun sly-compose (&rest functions) + "Compose unary FUNCTIONS right-associatively, returning a function" + #'(lambda (x) + (cl-reduce #'funcall functions :initial-value x :from-end t))) + +(defun sly-curry (fun &rest args) + "Partially apply FUN to ARGS. The result is a new function." + (lambda (&rest more) (apply fun (append args more)))) + +(defun sly-rcurry (fun &rest args) + "Like `sly-curry' but ARGS on the right are applied." + (lambda (&rest more) (apply fun (append more args)))) + + +;;;;; Temporary popup buffers + +;; keep compiler quiet +(defvar sly-buffer-package) +(defvar sly-buffer-connection) + + +;; Interface +(cl-defmacro sly-with-popup-buffer ((name &key package connection select + same-window-p + mode) + &body body) + "Similar to `with-output-to-temp-buffer'. +Bind standard-output and initialize some buffer-local variables. +Restore window configuration when closed. NAME is the name of +the buffer to be created. PACKAGE is the value +`sly-buffer-package'. CONNECTION is the value for +`sly-buffer-connection', if nil, no explicit connection is +associated with the buffer. If t, the current connection is +taken. MODE is the name of a major mode which will be enabled. +Non-nil SELECT indicates the buffer should be switched to, unless +it is `:hidden' meaning the buffer should not even be +displayed. SELECT can also be `:raise' meaning the buffer should +be switched to and the frame raised. SAME-WINDOW-P is a form +indicating if the popup *can* happen in the same window. The +forms SELECT and SAME-WINDOW-P are evaluated at runtime, not +macroexpansion time. +" + (declare (indent 1) + (debug (sexp &rest form))) + (let* ((package-sym (cl-gensym "package-")) + (connection-sym (cl-gensym "connection-")) + (select-sym (cl-gensym "select")) + (major-mode-sym (cl-gensym "select"))) + `(let ((,package-sym ,(if (eq package t) + `(sly-current-package) + package)) + (,connection-sym ,(if (eq connection t) + `(sly-current-connection) + connection)) + (,major-mode-sym major-mode) + (,select-sym ,select) + (view-read-only nil)) + (with-current-buffer (get-buffer-create ,name) + (let ((inhibit-read-only t) + (standard-output (current-buffer))) + (erase-buffer) + ,@(cond (mode + `((funcall ,mode))) + (t + `((sly-popup-buffer-mode 1)))) + (setq sly-buffer-package ,package-sym + sly-buffer-connection ,connection-sym) + (set-syntax-table lisp-mode-syntax-table) + ,@body + (unless (eq ,select-sym :hidden) + (let ((window (display-buffer + (current-buffer) + (if ,(cond (same-window-p same-window-p) + (mode `(eq ,major-mode-sym ,mode))) + nil + t)))) + (when ,select-sym + (if window + (select-window window t)))) + (if (eq ,select-sym :raise) (raise-frame))) + (current-buffer)))))) + +;;;;; Filename translation +;;; +;;; Filenames passed between Emacs and Lisp should be translated using +;;; these functions. This way users who run Emacs and Lisp on separate +;;; machines have a chance to integrate file operations somehow. + +(defvar sly-to-lisp-filename-function #'convert-standard-filename + "Function to translate Emacs filenames to CL namestrings.") +(defvar sly-from-lisp-filename-function #'identity + "Function to translate CL namestrings to Emacs filenames.") + +(defun sly-to-lisp-filename (filename) + "Translate the string FILENAME to a Lisp filename." + (funcall sly-to-lisp-filename-function (substring-no-properties filename))) + +(defun sly-from-lisp-filename (filename) + "Translate the Lisp filename FILENAME to an Emacs filename." + (funcall sly-from-lisp-filename-function filename)) + + +;;;; Starting SLY +;;; +;;; This section covers starting an inferior-lisp, compiling and +;;; starting the server, initiating a network connection. + +;;;;; Entry points + +;; We no longer load inf-lisp, but we use this variable for backward +;; compatibility. +(defcustom inferior-lisp-program "lisp" + "Program name for starting a Lisp subprocess to Emacs. +Can be a string naming a program, a whitespace-separated string +of \"EXECUTABLE ARG1 ARG2\" or a list (EXECUTABLE ARGS...) where +EXECUTABLE and ARGS are strings." + :type 'string + :group 'sly-lisp) + +(defvar sly-lisp-implementations nil + "*A list of known Lisp implementations. +The list should have the form: + ((NAME (PROGRAM PROGRAM-ARGS...) &key KEYWORD-ARGS) ...) + +NAME is a symbol for the implementation. +PROGRAM and PROGRAM-ARGS are strings used to start the Lisp process. +For KEYWORD-ARGS see `sly-start'. + +Here's an example: + ((cmucl (\"/opt/cmucl/bin/lisp\" \"-quiet\") :init sly-init-command) + (acl (\"acl7\") :coding-system emacs-mule))") + +(defcustom sly-command-switch-to-existing-lisp 'ask + "Should the `sly' command start new lisp if one is available?" + :type '(choice (const :tag "Ask the user" ask) + (const :tag "Always" 'always) + (const :tag "Never" 'never))) + +(defcustom sly-auto-select-connection 'ask + "Controls auto selection after the default connection was closed." + :group 'sly-mode + :type '(choice (const never) + (const always) + (const ask))) + +(defcustom sly-default-lisp nil + "A symbol naming the preferred Lisp implementation. +See `sly-lisp-implementations'" + :type 'function + :group 'sly-mode) + +;; dummy definitions for the compiler +(defvar sly-net-processes) +(defvar sly-default-connection) + +;;;###autoload +(cl-defun sly (&optional command coding-system interactive) + "Start a Lisp implementation and connect to it. + + COMMAND designates a the Lisp implementation to start as an +\"inferior\" process to the Emacs process. It is either a +pathname string pathname to a lisp executable, a list (EXECUTABLE +ARGS...), or a symbol indexing +`sly-lisp-implementations'. CODING-SYSTEM is a symbol overriding +`sly-net-coding-system'. + +Interactively, both COMMAND and CODING-SYSTEM are nil and the +prefix argument controls the precise behaviour: + +- With no prefix arg, try to automatically find a Lisp. First + consult `sly-command-switch-to-existing-lisp' and analyse open + connections to maybe switch to one of those. If a new lisp is + to be created, first lookup `sly-lisp-implementations', using + `sly-default-lisp' as a default strategy. Then try + `inferior-lisp-program' if it looks like it points to a valid + lisp. Failing that, guess the location of a lisp + implementation. + +- With a positive prefix arg (one C-u), prompt for a command + string that starts a Lisp implementation. + +- With a negative prefix arg (M-- M-x sly, for example) prompt + for a symbol indexing one of the entries in + `sly-lisp-implementations'" + (interactive (list nil nil t)) + (sly--when-let* + ((active (and interactive + (not current-prefix-arg) + (sly--purge-connections))) + (target (or (and (eq sly-command-switch-to-existing-lisp 'ask) + (sly-prompt-for-connection + "[sly] Switch to open connection?\n\ + (Customize `sly-command-switch-to-existing-lisp' to avoid this prompt.)\n\ + Connections: " nil "(start a new one)")) + (and (eq sly-command-switch-to-existing-lisp 'always) + (car active))))) + (sly-message "Switching to `%s'" (sly-connection-name target)) + (sly-connection-list-default-action target) + (cl-return-from sly nil)) + (let ((command (or command inferior-lisp-program)) + (sly-net-coding-system (or coding-system sly-net-coding-system))) + (apply #'sly-start + (cond (interactive + (sly--read-interactive-args)) + (t + (if sly-lisp-implementations + (sly--lookup-lisp-implementation + sly-lisp-implementations + (or (and (symbolp command) command) + sly-default-lisp + (car (car sly-lisp-implementations)))) + (let ((command-and-args (if (listp command) + command + (split-string command)))) + `(:program ,(car command-and-args) + :program-args ,(cdr command-and-args))))))))) + +(defvar sly-inferior-lisp-program-history '() + "History list of command strings. Used by M-x sly.") + +(defun sly--read-interactive-args () + "Return the list of args which should be passed to `sly-start'. +Helper for M-x sly" + (cond ((not current-prefix-arg) + (cond (sly-lisp-implementations + (sly--lookup-lisp-implementation sly-lisp-implementations + (or sly-default-lisp + (car (car sly-lisp-implementations))))) + (t (cl-destructuring-bind (program &rest args) + (split-string-and-unquote + (sly--guess-inferior-lisp-program t)) + (list :program program :program-args args))))) + ((eq current-prefix-arg '-) + (let ((key (completing-read + "Lisp name: " (mapcar (lambda (x) + (list (symbol-name (car x)))) + sly-lisp-implementations) + nil t))) + (sly--lookup-lisp-implementation sly-lisp-implementations (intern key)))) + (t + (cl-destructuring-bind (program &rest program-args) + (split-string-and-unquote + (read-shell-command "[sly] Run lisp: " + (sly--guess-inferior-lisp-program nil) + 'sly-inferior-lisp-program-history)) + (let ((coding-system + (if (eq 16 (prefix-numeric-value current-prefix-arg)) + (read-coding-system "[sly] Set sly-coding-system: " + sly-net-coding-system) + sly-net-coding-system))) + (list :program program :program-args program-args + :coding-system coding-system)))))) + + +(defun sly--lookup-lisp-implementation (table name) + (let ((arguments (cl-rest (assoc name table)))) + (unless arguments + (error "Could not find lisp implementation with the name '%S'" name)) + (when (and (= (length arguments) 1) + (functionp (cl-first arguments))) + (setf arguments (funcall (cl-first arguments)))) + (cl-destructuring-bind ((prog &rest args) &rest keys) arguments + (cl-list* :name name :program prog :program-args args keys)))) + +(defun sly-inferior-lisp-buffer (sly-process-or-connection &optional pop-to-buffer) + "Return PROCESS's buffer. With POP-TO-BUFFER, pop to it." + (interactive (list (sly-process) t)) + (let ((buffer (cond ((and sly-process-or-connection + (process-get sly-process-or-connection + 'sly-inferior-lisp-process)) + (process-buffer sly-process-or-connection)) + (sly-process-or-connection + ;; call ourselves recursively with a + ;; sly-started process + ;; + (sly-inferior-lisp-buffer (sly-process sly-process-or-connection) + pop-to-buffer ))))) + (cond ((and buffer + pop-to-buffer) + (pop-to-buffer buffer)) + ((and pop-to-buffer + sly-process-or-connection) + (sly-message "No *inferior lisp* process for current connection!")) + (pop-to-buffer + (sly-error "No *inferior lisp* buffer"))) + buffer)) + +(defun sly--guess-inferior-lisp-program (&optional interactive) + "Compute pathname to a seemingly valid lisp implementation. +If ERRORP, error if such a thing cannot be found" + (let ((inferior-lisp-program-and-args + (and inferior-lisp-program + (if (listp inferior-lisp-program) + inferior-lisp-program + (split-string-and-unquote inferior-lisp-program))))) + (if (and inferior-lisp-program-and-args + (executable-find (car inferior-lisp-program-and-args))) + (combine-and-quote-strings inferior-lisp-program-and-args) + (let ((guessed (cl-some #'executable-find + '("lisp" "sbcl" "clisp" "cmucl" + "acl" "alisp")))) + (cond ((and guessed + (or (not interactive) + noninteractive + (sly-y-or-n-p + "Can't find `inferior-lisp-program' (set to `%s'). Use `%s' instead? " + inferior-lisp-program guessed))) + guessed) + (interactive + (sly-error + (substitute-command-keys + "Can't find a suitable Lisp. Use \\[sly-info] to read about `Multiple Lisps'"))) + (t + nil)))))) + +(cl-defun sly-start (&key (program + (sly-error "must supply :program")) + program-args + directory + (coding-system sly-net-coding-system) + (init sly-init-function) + name + (buffer (format "*sly-started inferior-lisp for %s*" + (file-name-nondirectory program))) + init-function + env) + "Start a Lisp process and connect to it. +This function is intended for programmatic use if `sly' is not +flexible enough. + +PROGRAM and PROGRAM-ARGS are the filename and argument strings + for the subprocess. +INIT is a function that should return a string to load and start + Slynk. The function will be called with the PORT-FILENAME and ENCODING as + arguments. INIT defaults to `sly-init-function'. +CODING-SYSTEM a symbol for the coding system. The default is + sly-net-coding-system +ENV environment variables for the subprocess (see `process-environment'). +INIT-FUNCTION function to call right after the connection is established. +BUFFER the name of the buffer to use for the subprocess. +NAME a symbol to describe the Lisp implementation +DIRECTORY change to this directory before starting the process. +" + (let ((args (list :program program :program-args program-args :buffer buffer + :coding-system coding-system :init init :name name + :init-function init-function :env env))) + (sly-check-coding-system coding-system) + (let ((proc (sly-maybe-start-lisp program program-args env + directory buffer))) + (sly-inferior-connect proc args) + (sly-inferior-lisp-buffer proc)))) + +;;;###autoload +(defun sly-connect (host port &optional _coding-system interactive-p) + "Connect to a running Slynk server. Return the connection. +With prefix arg, asks if all connections should be closed +before." + (interactive (list (read-from-minibuffer + "[sly] Host: " (cl-first sly-connect-host-history) + nil nil '(sly-connect-host-history . 1)) + (string-to-number + (read-from-minibuffer + "[sly] Port: " (cl-first sly-connect-port-history) + nil nil '(sly-connect-port-history . 1))) + nil t)) + (when (and interactive-p + sly-net-processes + current-prefix-arg + (sly-y-or-n-p "[sly] Close all connections first? ")) + (sly-disconnect-all)) + (sly-message "Connecting to Slynk on port %S.." port) + (let* ((process (sly-net-connect host port)) + (sly-dispatching-connection process)) + (sly-setup-connection process))) + +;;;;; Start inferior lisp +;;; +;;; Here is the protocol for starting SLY via `M-x sly': +;;; +;;; 1. Emacs starts an inferior Lisp process. +;;; 2. Emacs tells Lisp (via stdio) to load and start Slynk. +;;; 3. Lisp recompiles the Slynk if needed. +;;; 4. Lisp starts the Slynk server and writes its TCP port to a temp file. +;;; 5. Emacs reads the temp file to get the port and then connects. +;;; 6. Emacs prints a message of warm encouragement for the hacking ahead. +;;; +;;; Between steps 2-5 Emacs polls for the creation of the temp file so +;;; that it can make the connection. This polling may continue for a +;;; fair while if Slynk needs recompilation. + +(defvar sly-connect-retry-timer nil + "Timer object while waiting for an inferior-lisp to start.") + +(defun sly-abort-connection () + "Abort connection the current connection attempt." + (interactive) + (cond (sly-connect-retry-timer + (sly-cancel-connect-retry-timer) + (sly-message "Cancelled connection attempt.")) + (t (error "Not connecting")))) + +;;; Starting the inferior Lisp and loading Slynk: + +(defun sly-maybe-start-lisp (program program-args env directory buffer) + "Return a new or existing inferior lisp process." + (cond ((not (comint-check-proc buffer)) + (sly-start-lisp program program-args env directory buffer)) + (t (sly-start-lisp program program-args env directory + (generate-new-buffer-name buffer))))) + +(defvar sly-inferior-process-start-hook nil + "Hook called whenever a new process gets started.") + +(defun sly-start-lisp (program program-args env directory buffer) + "Does the same as `inferior-lisp' but less ugly. +Return the created process." + (with-current-buffer (get-buffer-create buffer) + (when directory + (cd (expand-file-name directory))) + (comint-mode) + (let ((process-environment (append env process-environment)) + (process-connection-type nil)) + (comint-exec (current-buffer) "inferior-lisp" program nil program-args)) + (lisp-mode-variables t) + (let ((proc (get-buffer-process (current-buffer)))) + (process-put proc 'sly-inferior-lisp-process t) + (set-process-query-on-exit-flag proc (not sly-kill-without-query-p)) + (run-hooks 'sly-inferior-process-start-hook) + proc))) + +(defun sly-inferior-connect (process args) + "Start a Slynk server in the inferior Lisp and connect." + (sly-delete-slynk-port-file 'quiet) + (sly-start-slynk-server process args) + (sly-read-port-and-connect process)) + +(defun sly-start-slynk-server (inf-process args) + "Start a Slynk server on the inferior lisp." + (cl-destructuring-bind (&key coding-system init &allow-other-keys) args + (with-current-buffer (process-buffer inf-process) + (process-put inf-process 'sly-inferior-lisp-args args) + (let ((str (funcall init (sly-slynk-port-file) coding-system))) + (goto-char (process-mark inf-process)) + (insert-before-markers str) + (process-send-string inf-process str))))) + +(defun sly-inferior-lisp-args (inf-process) + "Return the initial process arguments. +See `sly-start'." + (process-get inf-process 'sly-inferior-lisp-args)) + +(defun sly-init-using-asdf (port-filename coding-system) + "Return a string to initialize Lisp using ASDF. +Fall back to `sly-init-using-slynk-loader' if ASDF fails." + (format "%S\n\n" + `(cond ((ignore-errors + (funcall 'require "asdf") + (funcall (read-from-string "asdf:version-satisfies") + (funcall (read-from-string "asdf:asdf-version")) + "2.019")) + (push (pathname ,(sly-to-lisp-filename (sly-slynk-path))) + (symbol-value + (read-from-string "asdf:*central-registry*"))) + (funcall + (read-from-string "asdf:load-system") + :slynk) + (funcall + (read-from-string "slynk:start-server") + ,(sly-to-lisp-filename port-filename))) + (t + ,(read (sly-init-using-slynk-loader port-filename + coding-system)))))) + +;; XXX load-server & start-server used to be separated. maybe that was better. +(defun sly-init-using-slynk-loader (port-filename _coding-system) + "Return a string to initialize Lisp." + (let ((loader (sly-to-lisp-filename + (expand-file-name sly-slynk-loader-backend (sly-slynk-path))))) + ;; Return a single form to avoid problems with buffered input. + (format "%S\n\n" + `(progn + (load ,loader :verbose t) + (funcall (read-from-string "slynk-loader:init")) + (funcall (read-from-string "slynk:start-server") + ,port-filename))))) + +(defun sly-slynk-port-file () + "Filename where the SLYNK server writes its TCP port number." + (expand-file-name (format "sly.%S" (emacs-pid)) (sly-temp-directory))) + +(defun sly-temp-directory () + (cond ((fboundp 'temp-directory) (temp-directory)) + ((boundp 'temporary-file-directory) temporary-file-directory) + (t "/tmp/"))) + +(defun sly-delete-slynk-port-file (&optional quiet) + (condition-case data + (delete-file (sly-slynk-port-file)) + (error + (cl-ecase quiet + ((nil) (signal (car data) (cdr data))) + (quiet) + (sly-message (sly-message "Unable to delete slynk port file %S" + (sly-slynk-port-file))))))) + +(defun sly-read-port-and-connect (inferior-process) + (sly-attempt-connection inferior-process nil 1)) + +(defcustom sly-connection-poll-interval 0.3 + "Seconds to wait between connection attempts when first connecting." + :type 'number + :group 'sly-ui) + +(defun sly-attempt-connection (process retries attempt) + ;; A small one-state machine to attempt a connection with + ;; timer-based retries. + (sly-cancel-connect-retry-timer) + (let ((file (sly-slynk-port-file))) + (unless (active-minibuffer-window) + (sly-message "Polling %S .. %d (Abort with `M-x sly-abort-connection'.)" + file attempt)) + (cond ((and (file-exists-p file) + (> (nth 7 (file-attributes file)) 0)) ; file size + (let ((port (sly-read-slynk-port)) + (args (sly-inferior-lisp-args process))) + (sly-delete-slynk-port-file 'message) + (let ((c (sly-connect sly-lisp-host port + (plist-get args :coding-system)))) + (sly-set-inferior-process c process)))) + ((and retries (zerop retries)) + (sly-message "Gave up connecting to Slynk after %d attempts." attempt)) + ((eq (process-status process) 'exit) + (sly-message "Failed to connect to Slynk: inferior process exited.")) + (t + (when (and (file-exists-p file) + (zerop (nth 7 (file-attributes file)))) + (sly-message "(Zero length port file)") + ;; the file may be in the filesystem but not yet written + (unless retries (setq retries 3))) + (cl-assert (not sly-connect-retry-timer)) + (setq sly-connect-retry-timer + (run-with-timer + sly-connection-poll-interval nil + (lambda () + (let ((sly-ignore-protocol-mismatches + sly-ignore-protocol-mismatches)) + (sly-attempt-connection process (and retries (1- retries)) + (1+ attempt)))))))))) + +(defun sly-cancel-connect-retry-timer () + (when sly-connect-retry-timer + (cancel-timer sly-connect-retry-timer) + (setq sly-connect-retry-timer nil))) + +(defun sly-read-slynk-port () + "Read the Slynk server port number from the `sly-slynk-port-file'." + (save-excursion + (with-temp-buffer + (insert-file-contents (sly-slynk-port-file)) + (goto-char (point-min)) + (let ((port (read (current-buffer)))) + (cl-assert (integerp port)) + port)))) + +(defun sly-toggle-debug-on-slynk-error () + (interactive) + (if (sly-eval `(slynk:toggle-debug-on-slynk-error)) + (sly-message "Debug on SLYNK error enabled.") + (sly-message "Debug on SLYNK error disabled."))) + +;;; Words of encouragement + +(defun sly-user-first-name () + (let ((name (if (string= (user-full-name) "") + (user-login-name) + (user-full-name)))) + (string-match "^[^ ]*" name) + (capitalize (match-string 0 name)))) + +(defvar sly-words-of-encouragement + `("Let the hacking commence!" + "Hacks and glory await!" + "Hack and be merry!" + "Your hacking starts... NOW!" + "May the source be with you!" + "Take this REPL, brother, and may it serve you well." + "Lemonodor-fame is but a hack away!" + "Are we consing yet?" + ,(format "%s, this could be the start of a beautiful program." + (sly-user-first-name))) + "Scientifically-proven optimal words of hackerish encouragement.") + +(defun sly-random-words-of-encouragement () + "Return a string of hackerish encouragement." + (eval (nth (random (length sly-words-of-encouragement)) + sly-words-of-encouragement) + t)) + + +;;;; Networking +;;; +;;; This section covers the low-level networking: establishing +;;; connections and encoding/decoding protocol messages. +;;; +;;; Each SLY protocol message beings with a 6-byte header followed +;;; by an S-expression as text. The sexp must be readable both by +;;; Emacs and by Common Lisp, so if it contains any embedded code +;;; fragments they should be sent as strings: +;;; +;;; The set of meaningful protocol messages are not specified +;;; here. They are defined elsewhere by the event-dispatching +;;; functions in this file and in slynk.lisp. + +(defvar sly-net-processes nil + "List of processes (sockets) connected to Lisps.") + +(defvar sly-net-process-close-hooks '() + "List of functions called when a sly network connection closes. +The functions are called with the process as their argument.") + +(defun sly-secret () + "Find the magic secret from the user's home directory. +Return nil if the file doesn't exist or is empty; otherwise the +first line of the file." + (condition-case _err + (with-temp-buffer + (insert-file-contents "~/.sly-secret") + (goto-char (point-min)) + (buffer-substring (point-min) (line-end-position))) + (file-error nil))) + +;;; Interface +(defvar sly--net-connect-counter 0) + +(defun sly-send-secret (proc) + (sly--when-let (secret (sly-secret)) + (let* ((payload (encode-coding-string secret 'utf-8-unix)) + (string (concat (sly-net-encode-length (length payload)) + payload))) + (process-send-string proc string)))) + +(defun sly-net-connect (host port) + "Establish a connection with a CL." + (let* ((inhibit-quit nil) + (name (format "sly-%s" (cl-incf sly--net-connect-counter))) + (connection (open-network-stream name nil host port)) + (buffer (sly-make-net-buffer (format " *%s*" name)))) + (push connection sly-net-processes) + (set-process-plist connection `(sly--net-connect-counter + ,sly--net-connect-counter)) + (set-process-buffer connection buffer) + (set-process-filter connection 'sly-net-filter) + (set-process-sentinel connection 'sly-net-sentinel) + (set-process-query-on-exit-flag connection (not sly-kill-without-query-p)) + (when (fboundp 'set-process-coding-system) + (set-process-coding-system connection 'binary 'binary)) + (sly-send-secret connection) + connection)) + +(defun sly-make-net-buffer (name) + "Make a buffer suitable for a network process." + (let ((buffer (generate-new-buffer name))) + (with-current-buffer buffer + (buffer-disable-undo) + (set (make-local-variable 'kill-buffer-query-functions) nil)) + buffer)) + +;;;;; Coding system madness + +(defun sly-check-coding-system (coding-system) + "Signal an error if CODING-SYSTEM isn't a valid coding system." + (interactive) + (let ((props (sly-find-coding-system coding-system))) + (unless props + (error "Invalid sly-net-coding-system: %s. %s" + coding-system (mapcar #'car sly-net-valid-coding-systems))) + (when (and (cl-second props) (boundp 'default-enable-multibyte-characters)) + (cl-assert default-enable-multibyte-characters)) + t)) + +(defun sly-coding-system-mulibyte-p (coding-system) + (cl-second (sly-find-coding-system coding-system))) + +(defun sly-coding-system-cl-name (coding-system) + (cl-third (sly-find-coding-system coding-system))) + +;;; Interface +(defvar sly-net-send-translator nil + "If non-nil, function to translate outgoing sexps for the wire.") + +(defun sly--sanitize-or-lose (form) + "Sanitize FORM for Slynk or error." + (cl-typecase form + (number) + (symbol 'fonix) + (string (set-text-properties 0 (length form) nil form)) + (cons (sly--sanitize-or-lose (car form)) + (sly--sanitize-or-lose (cdr form))) + (t (sly-error "Can't serialize %s for Slynk." form))) + form) + +(defun sly-net-send (sexp proc) + "Send a SEXP to Lisp over the socket PROC. +This is the lowest level of communication. The sexp will be READ and +EVAL'd by Lisp." + (let* ((print-circle nil) + (print-quoted nil) + (sexp (sly--sanitize-or-lose sexp)) + (sexp (if (and sly-net-send-translator + (fboundp sly-net-send-translator)) + (funcall sly-net-send-translator sexp) + sexp)) + (payload (encode-coding-string + (concat (sly-prin1-to-string sexp) "\n") + 'utf-8-unix)) + (string (concat (sly-net-encode-length (length payload)) + payload))) + (sly-log-event sexp proc) + (process-send-string proc string))) + +(defun sly-safe-encoding-p (coding-system string) + "Return true iff CODING-SYSTEM can safely encode STRING." + (or (let ((candidates (find-coding-systems-string string)) + (base (coding-system-base coding-system))) + (or (equal candidates '(undecided)) + (memq base candidates))) + (and (not (multibyte-string-p string)) + (not (sly-coding-system-mulibyte-p coding-system))))) + +(defun sly-net-close (connection reason &optional debug _force) + "Close the network connection CONNECTION because REASON." + (process-put connection 'sly-net-close-reason reason) + (setq sly-net-processes (remove connection sly-net-processes)) + (when (eq connection sly-default-connection) + (setq sly-default-connection nil)) + ;; Run hooks + ;; + (unless debug + (run-hook-with-args 'sly-net-process-close-hooks connection)) + ;; We close the socket connection by killing its hidden + ;; *sly-<number>* buffer, but we first unset the connection's + ;; sentinel otherwise we could get a second `sly-net-close' call. In + ;; case the buffer is already killed (we killed it manually), this + ;; function is probably running as a result of that, and rekilling + ;; it is harmless. + ;; + (set-process-sentinel connection nil) + (when debug + (set-process-filter connection nil)) + (if debug + (delete-process connection) ; leave the buffer + (kill-buffer (process-buffer connection)))) + +(defun sly-net-sentinel (process message) + (let ((reason (format "Lisp connection closed unexpectedly: %s" message))) + (sly-message reason) + (sly-net-close process reason))) + +;;; Socket input is handled by `sly-net-filter', which decodes any +;;; complete messages and hands them off to the event dispatcher. + +(defun sly-net-filter (process string) + "Accept output from the socket and process all complete messages." + (with-current-buffer (process-buffer process) + (goto-char (point-max)) + (insert string)) + (sly-process-available-input process)) + +(defun sly-process-available-input (process) + "Process all complete messages that have arrived from Lisp." + (with-current-buffer (process-buffer process) + (while (sly-net-have-input-p) + (let ((event (sly-net-read-or-lose process)) + (ok nil)) + (sly-log-event event process) + (unwind-protect + (save-current-buffer + (sly-dispatch-event event process) + (setq ok t)) + (unless ok + (run-at-time 0 nil 'sly-process-available-input process))))))) + +(defsubst sly-net-decode-length () + (string-to-number (buffer-substring (point) (+ (point) 6)) + 16)) + +(defun sly-net-have-input-p () + "Return true if a complete message is available." + (goto-char (point-min)) + (and (>= (buffer-size) 6) + (>= (- (buffer-size) 6) (sly-net-decode-length)))) + +(defun sly-handle-net-read-error (error) + (let ((packet (buffer-string))) + (sly-with-popup-buffer ((sly-buffer-name :error + :connection (get-buffer-process (current-buffer)))) + (princ (format "%s\nin packet:\n%s" (error-message-string error) packet)) + (goto-char (point-min))) + (cond ((sly-y-or-n-p "Skip this packet? ") + `(:emacs-skipped-packet ,packet)) + (t + (when (sly-y-or-n-p "Enter debugger instead? ") + (debug 'error error)) + (signal (car error) (cdr error)))))) + +(defun sly-net-read-or-lose (process) + (condition-case error + (sly-net-read) + (error + (sly-net-close process "Fatal net-read error" t) + (error "net-read error: %S" error)))) + +(defun sly-net-read () + "Read a message from the network buffer." + (goto-char (point-min)) + (let* ((length (sly-net-decode-length)) + (start (+ (point) 6)) + (end (+ start length))) + (cl-assert (cl-plusp length)) + (prog1 (save-restriction + (narrow-to-region start end) + (condition-case error + (progn + (decode-coding-region start end 'utf-8-unix) + (setq end (point-max)) + (read (current-buffer))) + (error + (sly-handle-net-read-error error)))) + (delete-region (point-min) end)))) + +(defun sly-net-encode-length (n) + (format "%06x" n)) + +(defun sly-prin1-to-string (sexp) + "Like `prin1-to-string' but don't octal-escape non-ascii characters. +This is more compatible with the CL reader." + (let (print-escape-nonascii + print-escape-newlines + print-length + print-level) + (prin1-to-string sexp))) + + +;;;; Connections +;;; +;;; "Connections" are the high-level Emacs<->Lisp networking concept. +;;; +;;; Emacs has a connection to each Lisp process that it's interacting +;;; with. Typically there would only be one, but a user can choose to +;;; connect to many Lisps simultaneously. +;;; +;;; A connection consists of a control socket, optionally an extra +;;; socket dedicated to receiving Lisp output (an optimization), and a +;;; set of connection-local state variables. +;;; +;;; The state variables are stored as buffer-local variables in the +;;; control socket's process-buffer and are used via accessor +;;; functions. These variables include things like the *FEATURES* list +;;; and Unix Pid of the Lisp process. +;;; +;;; One connection is "current" at any given time. This is: +;;; `sly-dispatching-connection' if dynamically bound, or +;;; `sly-buffer-connection' if this is set buffer-local, or +;;; `sly-default-connection' otherwise. +;;; +;;; When you're invoking commands in your source files you'll be using +;;; `sly-default-connection'. This connection can be interactively +;;; reassigned via the connection-list buffer. +;;; +;;; When a command creates a new buffer it will set +;;; `sly-buffer-connection' so that commands in the new buffer will +;;; use the connection that the buffer originated from. For example, +;;; the apropos command creates the *Apropos* buffer and any command +;;; in that buffer (e.g. `M-.') will go to the same Lisp that did the +;;; apropos search. REPL buffers are similarly tied to their +;;; respective connections. +;;; +;;; When Emacs is dispatching some network message that arrived from a +;;; connection it will dynamically bind `sly-dispatching-connection' +;;; so that the event will be processed in the context of that +;;; connection. +;;; +;;; This is mostly transparent. The user should be aware that he can +;;; set the default connection to pick which Lisp handles commands in +;;; Lisp-mode source buffers, and sly hackers should be aware that +;;; they can tie a buffer to a specific connection. The rest takes +;;; care of itself. + +(defvar sly-dispatching-connection nil + "Network process currently executing. +This is dynamically bound while handling messages from Lisp; it +overrides `sly-buffer-connection' and `sly-default-connection'.") + +(make-variable-buffer-local + (defvar sly-buffer-connection nil + "Network connection to use in the current buffer. +This overrides `sly-default-connection'.")) + +(defvar sly-default-connection nil + "Network connection to use by default. +Used for all Lisp communication, except when overridden by +`sly-dispatching-connection' or `sly-buffer-connection'.") + +(defun sly-current-connection () + "Return the connection to use for Lisp interaction. +Return nil if there's no connection." + (or sly-dispatching-connection + sly-buffer-connection + sly-default-connection)) + +(defun sly-connection () + "Return the connection to use for Lisp interaction. +Signal an error if there's no connection." + (let ((conn (sly-current-connection))) + (cond ((and (not conn) sly-net-processes) + (or (sly-auto-select-connection) + (error "Connections available, but none selected."))) + ((not conn) + (or (sly-auto-start) + (error "No current SLY connection."))) + ((not (process-live-p conn)) + (error "Current connection %s is closed." conn)) + (t conn)))) + +(define-obsolete-variable-alias 'sly-auto-connect + 'sly-auto-start "2.5") +(defcustom sly-auto-start 'never + "Controls auto connection when information from lisp process is needed. +This doesn't mean it will connect right after SLY is loaded." + :group 'sly-mode + :type '(choice (const never) + (const always) + (const ask))) + +(defun sly-auto-start () + (cond ((or (eq sly-auto-start 'always) + (and (eq sly-auto-start 'ask) + (sly-y-or-n-p "No connection. Start SLY? "))) + (save-window-excursion + (sly) + (while (not (sly-current-connection)) + (sleep-for 1)) + (sly-connection))) + (t nil))) + +(cl-defmacro sly-with-connection-buffer ((&optional process) &rest body) + "Execute BODY in the process-buffer of PROCESS. +If PROCESS is not specified, `sly-connection' is used. + +\(fn (&optional PROCESS) &body BODY))" + (declare (indent 1)) + `(with-current-buffer + (process-buffer (or ,process (sly-connection) + (error "No connection"))) + ,@body)) + +;;; Connection-local variables: + +(defmacro sly-def-connection-var (varname &rest initial-value-and-doc) + "Define a connection-local variable. +The value of the variable can be read by calling the function of the +same name (it must not be accessed directly). The accessor function is +setf-able. + +The actual variable bindings are stored buffer-local in the +process-buffers of connections. The accessor function refers to +the binding for `sly-connection'." + (declare (indent 2)) + `(progn + ;; Accessor + (defun ,varname (&optional process) + ,(cl-second initial-value-and-doc) + (let ((process (or process + (sly-current-connection) + (error "Can't access prop %s for no connection" ',varname)))) + (or (process-get process ',varname) + (let ((once ,(cl-first initial-value-and-doc))) + (process-put process ',varname once) + once)))) + ;; Setf + (gv-define-setter ,varname (store &optional process) + `(let ((process (or ,process + (sly-current-connection) + (error "Can't access prop %s for no connection" ',',varname))) + (store-once ,store)) + (process-put process ',',varname store-once) + store-once)) + '(\, varname))) + +(sly-def-connection-var sly-connection-number nil + "Serial number of a connection. +Bound in the connection's process-buffer.") + +(sly-def-connection-var sly-lisp-features '() + "The symbol-names of Lisp's *FEATURES*. +This is automatically synchronized from Lisp.") + +(sly-def-connection-var sly-lisp-modules '() + "The strings of Lisp's *MODULES*.") + +(sly-def-connection-var sly-pid nil + "The process id of the Lisp process.") + +(sly-def-connection-var sly-lisp-implementation-type nil + "The implementation type of the Lisp process.") + +(sly-def-connection-var sly-lisp-implementation-version nil + "The implementation type of the Lisp process.") + +(sly-def-connection-var sly-lisp-implementation-name nil + "The short name for the Lisp implementation.") + +(sly-def-connection-var sly-lisp-implementation-program nil + "The argv[0] of the process running the Lisp implementation.") + +(sly-def-connection-var sly-connection-name nil + "The short name for connection.") + +(sly-def-connection-var sly-inferior-process nil + "The inferior process for the connection if any.") + +(sly-def-connection-var sly-communication-style nil + "The communication style.") + +(sly-def-connection-var sly-machine-instance nil + "The name of the (remote) machine running the Lisp process.") + +(sly-def-connection-var sly-connection-coding-systems nil + "Coding systems supported by the Lisp process.") + +;;;;; Connection setup + +(defvar sly-connection-counter 0 + "The number of SLY connections made. For generating serial numbers.") + +;;; Interface +(defun sly-setup-connection (process) + "Make a connection out of PROCESS." + (let ((sly-dispatching-connection process)) + (sly-init-connection-state process) + (sly-select-connection process) + (sly--setup-contribs) + process)) + +(defun sly-init-connection-state (proc) + "Initialize connection state in the process-buffer of PROC." + ;; To make life simpler for the user: if this is the only open + ;; connection then reset the connection counter. + (when (equal sly-net-processes (list proc)) + (setq sly-connection-counter 0)) + (sly-with-connection-buffer () + (setq sly-buffer-connection proc)) + (setf (sly-connection-number proc) (cl-incf sly-connection-counter)) + ;; We do the rest of our initialization asynchronously. The current + ;; function may be called from a timer, and if we setup the REPL + ;; from a timer then it mysteriously uses the wrong keymap for the + ;; first command. + (let ((sly-current-thread t)) + (sly-eval-async '(slynk:connection-info) + (sly-curry #'sly-set-connection-info proc) + nil + `((sly-ignore-protocol-mismatches . ,sly-ignore-protocol-mismatches))))) + +(defun sly--trampling-rename-buffer (newname) + "Rename current buffer NEWNAME, trampling over existing ones." + (let ((existing (get-buffer newname))) + (unless (eq existing + (current-buffer)) + ;; Trample over any existing buffers on reconnection + (when existing + (let ((kill-buffer-query-functions nil)) + (kill-buffer existing))) + (rename-buffer newname)))) + +(defun sly-set-connection-info (connection info) + "Initialize CONNECTION with INFO received from Lisp." + (let ((sly-dispatching-connection connection) + (sly-current-thread t)) + (cl-destructuring-bind (&key pid style lisp-implementation machine + features version modules encoding + &allow-other-keys) info + (sly-check-version version connection) + (setf (sly-pid) pid + (sly-communication-style) style + (sly-lisp-features) features + (sly-lisp-modules) modules) + (cl-destructuring-bind (&key type name version program) + lisp-implementation + (setf (sly-lisp-implementation-type) type + (sly-lisp-implementation-version) version + (sly-lisp-implementation-name) name + (sly-lisp-implementation-program) program + (sly-connection-name) (sly-generate-connection-name name))) + (cl-destructuring-bind (&key instance ((:type _)) ((:version _))) machine + (setf (sly-machine-instance) instance)) + (cl-destructuring-bind (&key coding-systems) encoding + (setf (sly-connection-coding-systems) coding-systems))) + (let ((args (sly--when-let (p (sly-inferior-process)) + (sly-inferior-lisp-args p)))) + (sly--when-let (name (plist-get args ':name)) + (unless (string= (sly-lisp-implementation-name) name) + (setf (sly-connection-name) + (sly-generate-connection-name (symbol-name name))))) + (sly-contrib--load-slynk-dependencies) + (run-hooks 'sly-connected-hook) + (sly--when-let (fun (plist-get args ':init-function)) + (funcall fun))) + ;; Give the events buffer its final name + (with-current-buffer (sly--events-buffer connection) + (sly--trampling-rename-buffer (sly-buffer-name + :events + :connection connection))) + ;; Rename the inferior lisp buffer if there is one (i.e. when + ;; started via `M-x sly') + ;; + (let ((inferior-lisp-buffer (sly-inferior-lisp-buffer + (sly-process connection)))) + (when inferior-lisp-buffer + (with-current-buffer inferior-lisp-buffer + (sly--trampling-rename-buffer (sly-buffer-name + :inferior-lisp + :connection connection))))) + (sly-message "Connected. %s" (sly-random-words-of-encouragement)))) + +(defun sly-check-version (version conn) + (or (equal version sly-protocol-version) + (null sly-protocol-version) + sly-ignore-protocol-mismatches + (sly-y-or-n-p + (format "Versions differ: %s (sly) vs. %s (slynk). Continue? " + sly-protocol-version version)) + (sly-net-close conn "Versions differ") + (top-level))) + +(defun sly-generate-connection-name (lisp-name) + (when (file-exists-p lisp-name) + (setq lisp-name (file-name-nondirectory lisp-name))) + (cl-loop for i from 1 + for name = lisp-name then (format "%s<%d>" lisp-name i) + while (cl-find name sly-net-processes + :key #'sly-connection-name :test #'equal) + finally (cl-return name))) + +(defun sly-select-new-default-connection (conn) + "If dead CONN was the default connection, select a new one." + (when (eq conn sly-default-connection) + (when sly-net-processes + (sly-select-connection (car sly-net-processes)) + (sly-message "Default connection closed; default is now #%S (%S)" + (sly-connection-number) + (sly-connection-name))))) + +(defcustom sly-keep-buffers-on-connection-close '(:mrepl) + "List of buffers to keep around after a connection closes." + :group 'sly-mode + :type '(repeat + (choice + (const :tag "Debugger" :db) + (const :tag "Repl" :mrepl) + (const :tag "Ispector" :inspector) + (const :tag "Stickers replay" :stickers-replay) + (const :tag "Error" :error) + (const :tag "Source" :source) + (const :tag "Compilation" :compilation) + (const :tag "Apropos" :apropos) + (const :tag "Xref" :xref) + (const :tag "Macroexpansion" :macroexpansion) + (symbol :tag "Other")))) + +(defun sly-kill-stale-connection-buffers (conn) ; + "If CONN had some stale buffers, kill them. +Respect `sly-keep-buffers-on-connection-close'." + (let ((buffer-list (buffer-list)) + (matchers + (mapcar + (lambda (type) + (format ".*%s.*$" + ;; XXX: this is synched with `sly-buffer-name'. + (regexp-quote (format "*sly-%s" + (downcase (substring (symbol-name type) + 1)))))) + (cl-set-difference '(:db + :mrepl + :inspector + :stickers-replay + :error + :source + :compilation + :apropos + :xref + :macroexpansion) + sly-keep-buffers-on-connection-close)))) + (cl-loop for buffer in buffer-list + when (and (cl-some (lambda (matcher) + (string-match matcher (buffer-name buffer))) + matchers) + (with-current-buffer buffer + (eq sly-buffer-connection conn))) + do (kill-buffer buffer)))) + +(add-hook 'sly-net-process-close-hooks 'sly-select-new-default-connection) +(add-hook 'sly-net-process-close-hooks 'sly-kill-stale-connection-buffers 'append) + +;;;;; Commands on connections + +(defun sly--purge-connections () + "Purge `sly-net-processes' of dead processes, return living." + (cl-loop for process in sly-net-processes + if (process-live-p process) + collect process + else do + (sly-warning "process %s in `sly-net-processes' dead. Force closing..." process) + (sly-net-close process "process state invalid" nil t))) + +(defun sly-prompt-for-connection (&optional prompt connections dont-require-match) + (let* ((connections (or connections (sly--purge-connections))) + (connection-names (cl-loop for process in + (sort connections + #'(lambda (p1 _p2) + (eq p1 (sly-current-connection)))) + collect (sly-connection-name process))) + (connection-names (if dont-require-match + (cons dont-require-match + connection-names) + connection-names)) + (connection-name (and connection-names + (completing-read + (or prompt "Connection: ") + connection-names + nil (not dont-require-match)))) + (target (cl-find connection-name sly-net-processes :key #'sly-connection-name + :test #'string=))) + (cond (target target) + ((and dont-require-match (or (zerop (length connection-name)) + (string= connection-name dont-require-match))) + nil) + (connection-name + (sly-error "No such connection")) + (t + (sly-error "No connections"))))) + +(defun sly-auto-select-connection () + (let* ((c0 (car (sly--purge-connections))) + (c (cond ((eq sly-auto-select-connection 'always) c0) + ((and (eq sly-auto-select-connection 'ask) + (sly-prompt-for-connection "Choose a new default connection: ")))))) + (when c + (sly-select-connection c) + (sly-message "Switching to connection: %s" (sly-connection-name c)) + c))) + +(defvar sly-select-connection-hook nil) + +(defun sly-select-connection (process) + "Make PROCESS the default connection." + (setq sly-default-connection process) + (run-hooks 'sly-select-connection-hook)) + +(define-obsolete-function-alias 'sly-cycle-connections 'sly-next-connection "1.0.0-beta") + +(defun sly-next-connection (arg &optional dont-wrap) + "Switch to the next SLY connection, cycling through all connections. +Skip ARG-1 connections. Negative ARG means cycle back. DONT-WRAP +means don't wrap around when last connection is reached." + (interactive "p") + (cl-labels ((connection-full-name + (c) + (format "%s %s" (sly-connection-name c) (process-contact c)))) + (cond ((not sly-net-processes) + (sly-error "No connections to cycle")) + ((null (cdr sly-net-processes)) + (sly-message "Only one connection: %s" (connection-full-name (car sly-net-processes)))) + (t + (let* ((dest (append (member (sly-current-connection) + sly-net-processes) + (unless dont-wrap sly-net-processes))) + (len (length sly-net-processes)) + (target (nth (mod arg len) + dest))) + (unless target + (sly-error "No more connections")) + (sly-select-connection target) + (if (and sly-buffer-connection + (not (eq sly-buffer-connection target))) + (sly-message "switched to: %s but buffer remains in: %s" + (connection-full-name target) + (connection-full-name sly-buffer-connection)) + (sly-message "switched to: %s (%s/%s)" (connection-full-name target) + (1+ (cl-position target sly-net-processes)) + len)) + (sly--refresh-mode-line)))))) + +(defun sly-prev-connection (arg &optional dont-wrap) + "Switch to the previous SLY connection, cycling through all connections. +See `sly-next-connection' for other args." + (interactive "p") + (sly-next-connection (- arg) dont-wrap)) + +(defun sly-disconnect (&optional interactive) + "Close the current connection." + (interactive (list t)) + (let ((connection (if interactive + (sly-prompt-for-connection "Connection to disconnect: ") + (sly-current-connection)))) + (sly-net-close connection "Disconnecting"))) + +(defun sly-disconnect-all () + "Disconnect all connections." + (interactive) + (mapc #'(lambda (process) + (sly-net-close process "Disconnecting all connections")) + sly-net-processes)) + +(defun sly-connection-port (connection) + "Return the remote port number of CONNECTION." + (cadr (process-contact connection))) + +(defun sly-process (&optional connection) + "Return the Lisp process for CONNECTION (default `sly-connection'). +Return nil if there's no process object for the connection." + (let ((proc (sly-inferior-process connection))) + (if (and proc + (memq (process-status proc) '(run stop))) + proc))) + +;; Non-macro version to keep the file byte-compilable. +(defun sly-set-inferior-process (connection process) + (setf (sly-inferior-process connection) process)) + +(defun sly-use-sigint-for-interrupt (&optional connection) + (let ((c (or connection (sly-connection)))) + (cl-ecase (sly-communication-style c) + ((:fd-handler nil) t) + ((:spawn :sigio) nil)))) + +(defvar sly-inhibit-pipelining t + "*If true, don't send background requests if Lisp is already busy.") + +(defun sly-background-activities-enabled-p () + (and (let ((con (sly-current-connection))) + (and con + (eq (process-status con) 'open))) + (or (not (sly-busy-p)) + (not sly-inhibit-pipelining)))) + + +;;;; Communication protocol + +;;;;; Emacs Lisp programming interface +;;; +;;; The programming interface for writing Emacs commands is based on +;;; remote procedure calls (RPCs). The basic operation is to ask Lisp +;;; to apply a named Lisp function to some arguments, then to do +;;; something with the result. +;;; +;;; Requests can be either synchronous (blocking) or asynchronous +;;; (with the result passed to a callback/continuation function). If +;;; an error occurs during the request then the debugger is entered +;;; before the result arrives -- for synchronous evaluations this +;;; requires a recursive edit. +;;; +;;; You should use asynchronous evaluations (`sly-eval-async') for +;;; most things. Reserve synchronous evaluations (`sly-eval') for +;;; the cases where blocking Emacs is really appropriate (like +;;; completion) and that shouldn't trigger errors (e.g. not evaluate +;;; user-entered code). +;;; +;;; We have the concept of the "current Lisp package". RPC requests +;;; always say what package the user is making them from and the Lisp +;;; side binds that package to *BUFFER-PACKAGE* to use as it sees +;;; fit. The current package is defined as the buffer-local value of +;;; `sly-buffer-package' if set, and otherwise the package named by +;;; the nearest IN-PACKAGE as found by text search (cl-first backwards, +;;; then forwards). +;;; +;;; Similarly we have the concept of the current thread, i.e. which +;;; thread in the Lisp process should handle the request. The current +;;; thread is determined solely by the buffer-local value of +;;; `sly-current-thread'. This is usually bound to t meaning "no +;;; particular thread", but can also be used to nominate a specific +;;; thread. The REPL and the debugger both use this feature to deal +;;; with specific threads. + +(make-variable-buffer-local + (defvar sly-current-thread t + "The id of the current thread on the Lisp side. +t means the \"current\" thread; +fixnum a specific thread.")) + +(make-variable-buffer-local + (defvar sly-buffer-package nil + "The Lisp package associated with the current buffer. +This is set only in buffers bound to specific packages.")) + +;;; `sly-rex' is the RPC primitive which is used to implement both +;;; `sly-eval' and `sly-eval-async'. You can use it directly if +;;; you need to, but the others are usually more convenient. + +(defvar sly-rex-extra-options-functions nil + "Functions returning extra options to send with `sly-rex'.") + +(cl-defmacro sly-rex ((&rest _) + (sexp &optional + (package '(sly-current-package)) + (thread 'sly-current-thread)) + &rest continuations) + "(sly-rex (VAR ...) (SEXP &optional PACKAGE THREAD) CLAUSES ...) + +Remote EXecute SEXP. + +SEXP is evaluated and the princed version is sent to Lisp. + +PACKAGE is evaluated and Lisp binds *BUFFER-PACKAGE* to this package. +The default value is (sly-current-package). + +CLAUSES is a list of patterns with same syntax as +`sly-dcase'. The result of the evaluation of SEXP is +dispatched on CLAUSES. The result is either a sexp of the +form (:ok VALUE) or (:abort CONDITION). CLAUSES is executed +asynchronously. + +Note: don't use backquote syntax for SEXP, because various Emacs +versions cannot deal with that." + (declare (indent 2) + (debug (sexp (form &optional sexp sexp) + &rest (sexp &rest form)))) + (let ((result (cl-gensym))) + `(sly-dispatch-event + (cl-list* :emacs-rex ,sexp ,package ,thread + (lambda (,result) + (sly-dcase ,result + ,@continuations)) + (cl-loop for fn in sly-rex-extra-options-functions + append (funcall fn)))))) + +;;; Interface +(defun sly-current-package () + "Return the Common Lisp package in the current context. +If `sly-buffer-package' has a value then return that, otherwise +search for and read an `in-package' form." + (or sly-buffer-package + (save-restriction + (widen) + (sly-find-buffer-package)))) + +(defvar sly-find-buffer-package-function 'sly-search-buffer-package + "*Function to use for `sly-find-buffer-package'. +The result should be the package-name (a string) +or nil if nothing suitable can be found.") + +(defun sly-find-buffer-package () + "Figure out which Lisp package the current buffer is associated with." + (funcall sly-find-buffer-package-function)) + +(make-variable-buffer-local + (defvar sly-package-cache nil + "Cons of the form (buffer-modified-tick . package)")) + +;; When modifing this code consider cases like: +;; (in-package #.*foo*) +;; (in-package #:cl) +;; (in-package :cl) +;; (in-package "CL") +;; (in-package |CL|) +;; (in-package #+ansi-cl :cl #-ansi-cl 'lisp) + +(defun sly-search-buffer-package () + (let ((case-fold-search t) + (regexp (concat "^[ \t]*(\\(cl:\\|common-lisp:\\)?in-package\\>[ \t']*" + "\\([^)]+\\)[ \t]*)"))) + (save-excursion + (when (or (re-search-backward regexp nil t) + (re-search-forward regexp nil t)) + (match-string-no-properties 2))))) + +;;; Synchronous requests are implemented in terms of asynchronous +;;; ones. We make an asynchronous request with a continuation function +;;; that `throw's its result up to a `catch' and then enter a loop of +;;; handling I/O until that happens. + +(defvar sly--stack-eval-tags nil + "List of stack-tags of waiting on the elisp stack. +This is used by the sly-db debugger to decide whether to enter a +`recursive-edit', so that if a synchronous `sly-eval' request +errors and brings us a Slynk debugger, we can fix the error, +invoke a restart and still get the return value of the `sly-eval' +as if nothing had happened.") + +(defun sly-eval (sexp &optional package cancel-on-input cancel-on-input-retval) + "Evaluate SEXP in Slynk's PACKAGE and return the result. +If CANCEL-ON-INPUT cancel the request immediately if the user +wants to input, and return CANCEL-ON-INPUT-RETVAL." + (when (null package) (setq package (sly-current-package))) + (let* ((catch-tag (make-symbol (format "sly-result-%d" + (sly-continuation-counter)))) + (sly--stack-eval-tags (cons catch-tag sly--stack-eval-tags)) + (cancelled nil) + (check-conn + (lambda () + (unless (eq (process-status (sly-connection)) 'open) + (error "Lisp connection closed unexpectedly")))) + (retval + (unwind-protect + (catch catch-tag + (sly-rex () + (sexp package) + ((:ok value) + (unless cancelled + (unless (member catch-tag sly--stack-eval-tags) + (error "Reply to nested `sly-eval' request with tag=%S sexp=%S" + catch-tag sexp)) + (throw catch-tag (list #'identity value)))) + ((:abort _condition) + (unless cancelled + (throw catch-tag + (list #'error "Synchronous Lisp Evaluation aborted"))))) + (cond (cancel-on-input + ;; Setting `inhibit-quit' to t helps with + ;; callers that wrap us in `while-no-input', + ;; like `fido-mode' and Helm. It doesn't seem + ;; to create any specific problems, since + ;; `sit-for' exits immediately given input + ;; anyway. This include the C-g input, and + ;; thus even with `inhibit-quit' set to t, quit + ;; happens immediately. + (unwind-protect + (let ((inhibit-quit t)) (while (sit-for 30))) + (setq cancelled t)) + (funcall check-conn)) + (t + (while t + (funcall check-conn) + (accept-process-output nil 30)))) + (list #'identity cancel-on-input-retval)) + ;; Protect against user quit during + ;; `accept-process-output' or `sit-for', so that if the + ;; Lisp is alive and replies, we don't get an error. + (setq cancelled t)))) + (apply (car retval) (cdr retval)))) + +(defun sly-eval-async (sexp &optional cont package env) + "Evaluate SEXP on the superior Lisp and call CONT with the result. + +CONT is called with the overriding dynamic environment in ENV, an +alist of bindings" + (declare (indent 1)) + (let ((buffer (current-buffer))) + (sly-rex () + (sexp (or package (sly-current-package))) + ((:ok result) + (when cont + (set-buffer buffer) + (cl-progv (mapcar #'car env) (mapcar #'cdr env) + (if debug-on-error + (funcall cont result) + (condition-case err + (funcall cont result) + (error + (sly-message "`sly-eval-async' errored: %s" + (if (and (eq 'error (car err)) + (stringp (cadr err))) + (cadr err) + err)))))))) + ((:abort condition) + (sly-message "Evaluation aborted on %s." condition)))) + ;; Guard against arbitrary return values which once upon a time + ;; showed up in the minibuffer spuriously (due to a bug in + ;; sly-autodoc.) If this ever happens again, returning the + ;; following will make debugging much easier: + :sly-eval-async) + +;;; These functions can be handy too: + +(defun sly-connected-p () + "Return true if the Slynk connection is open." + (not (null sly-net-processes))) + +(defun sly-check-connected () + "Signal an error if we are not connected to Lisp." + (unless (sly-connected-p) + (error "Not connected. Use `%s' to start a Lisp." + (substitute-command-keys "\\[sly]")))) + +;; UNUSED +(defun sly-debugged-connection-p (conn) + ;; This previously was (AND (SLY-DB-DEBUGGED-CONTINUATIONS CONN) T), + ;; but an SLY-DB buffer may exist without having continuations + ;; attached to it, e.g. the one resulting from `sly-interrupt'. + (cl-loop for b in (sly-db-buffers) + thereis (with-current-buffer b + (eq sly-buffer-connection conn)))) + +(defun sly-busy-p (&optional conn) + "True if Lisp has outstanding requests. +Debugged requests are ignored." + (let ((debugged (sly-db-debugged-continuations (or conn (sly-connection))))) + (cl-remove-if (lambda (id) + (memq id debugged)) + (sly-rex-continuations) + :key #'car))) + +(defun sly-sync () + "Block until the most recent request has finished." + (when (sly-rex-continuations) + (let ((tag (caar (sly-rex-continuations)))) + (while (cl-find tag (sly-rex-continuations) :key #'car) + (accept-process-output nil 0.1))))) + +(defun sly-ping () + "Check that communication works." + (interactive) + (sly-message "%s" (sly-eval "PONG"))) + +;;;;; Protocol event handler (the guts) +;;; +;;; This is the protocol in all its glory. The input to this function +;;; is a protocol event that either originates within Emacs or arrived +;;; over the network from Lisp. +;;; +;;; Each event is a list beginning with a keyword and followed by +;;; arguments. The keyword identifies the type of event. Events +;;; originating from Emacs have names starting with :emacs- and events +;;; from Lisp don't. + +(sly-def-connection-var sly-rex-continuations '() + "List of (ID . FUNCTION) continuations waiting for RPC results.") + +(sly-def-connection-var sly-continuation-counter 0 + "Continuation serial number counter.") + +(defvar sly-event-hooks) + +(defun sly-dispatch-event (event &optional process) + (let ((sly-dispatching-connection (or process (sly-connection)))) + (or (run-hook-with-args-until-success 'sly-event-hooks event) + (sly-dcase event + ((:emacs-rex form package thread continuation &rest extra-options) + (when (and (sly-use-sigint-for-interrupt) (sly-busy-p)) + (sly-display-oneliner "; pipelined request... %S" form)) + (let ((id (cl-incf (sly-continuation-counter)))) + ;; JT@2020-12-10: FIXME: Force inhibit-quit here to + ;; ensure atomicity between `sly-send' and the `push'? + ;; See Github#385.. + (sly-send `(:emacs-rex ,form ,package ,thread ,id ,@extra-options)) + (push (cons id continuation) (sly-rex-continuations)) + (sly--refresh-mode-line))) + ((:return value id) + (let ((rec (assq id (sly-rex-continuations)))) + (cond (rec (setf (sly-rex-continuations) + (remove rec (sly-rex-continuations))) + (funcall (cdr rec) value) + (sly--refresh-mode-line)) + (t + (error "Unexpected reply: %S %S" id value))))) + ((:debug-activate thread level &optional _ignored) + (cl-assert thread) + (sly-db--ensure-initialized thread level)) + ((:debug thread level condition restarts frames conts) + (cl-assert thread) + (sly-db-setup thread level condition restarts frames conts)) + ((:debug-return thread level stepping) + (cl-assert thread) + (sly-db-exit thread level stepping)) + ((:emacs-interrupt thread) + (sly-send `(:emacs-interrupt ,thread))) + ((:read-from-minibuffer thread tag prompt initial-value) + (sly-read-from-minibuffer-for-slynk thread tag prompt + initial-value)) + ((:y-or-n-p thread tag question) + (sly-remote-y-or-n-p thread tag question)) + ((:emacs-return-string thread tag string) + (sly-send `(:emacs-return-string ,thread ,tag ,string))) + ((:new-features features) + (setf (sly-lisp-features) features)) + ((:indentation-update info) + (sly-handle-indentation-update info)) + ((:eval-no-wait form) + (sly-check-eval-in-emacs-enabled) + (eval (read form) t)) + ((:eval thread tag form-string) + (sly-check-eval-in-emacs-enabled) + (sly-eval-for-lisp thread tag form-string)) + ((:emacs-return thread tag value) + (sly-send `(:emacs-return ,thread ,tag ,value))) + ((:ed what) + (sly-ed what)) + ((:inspect what thread tag) + (let ((hook (when (and thread tag) + (sly-curry #'sly-send + `(:emacs-return ,thread ,tag nil))))) + (sly--open-inspector what :kill-hook hook :switch :raise))) + ((:background-message message) + (sly-temp-message 1 3 "[background-message] %s" message)) + ((:debug-condition thread message) + (cl-assert thread) + (sly-message "[debug-condition] %s" message)) + ((:ping thread tag) + (sly-send `(:emacs-pong ,thread ,tag))) + ((:reader-error packet condition) + (sly-with-popup-buffer ((sly-buffer-name :error + :connection sly-dispatching-connection)) + (princ (format "Invalid protocol message:\n%s\n\n%s" + condition packet)) + (goto-char (point-min))) + (error "Invalid protocol message")) + ((:invalid-rpc id message) + (setf (sly-rex-continuations) + (cl-remove id (sly-rex-continuations) :key #'car)) + (error "Invalid rpc: %s" message)) + ((:emacs-skipped-packet _pkg)) + ((:test-delay seconds) ; for testing only + (sit-for seconds)) + ((:channel-send id msg) + (sly-channel-send (or (sly-find-channel id) + (error "Invalid channel id: %S %S" id msg)) + msg)) + ((:emacs-channel-send id msg) + (sly-send `(:emacs-channel-send ,id ,msg))) + ((:invalid-channel channel-id reason) + (error "Invalid remote channel %s: %s" channel-id reason)))))) + +(defvar sly--send-last-command nil + "Value of `this-command' at time of last `sly-send' call.") + +(defun sly-send (sexp) + "Send SEXP directly over the wire on the current connection." + (setq sly--send-last-command this-command) + (sly-net-send sexp (sly-connection))) + +(defun sly-reset () + "Clear all pending continuations and erase connection buffer." + (interactive) + (setf (sly-rex-continuations) '()) + (mapc #'kill-buffer (sly-db-buffers)) + (sly-with-connection-buffer () + (erase-buffer))) + +(defun sly-send-sigint () + (interactive) + (signal-process (sly-pid) 'SIGINT)) + +;;;;; Channels + +;;; A channel implements a set of operations. Those operations can be +;;; invoked by sending messages to the channel. Channels are used for +;;; protocols which can't be expressed naturally with RPCs, e.g. for +;;; streaming data over the wire. +;;; +;;; A channel can be "remote" or "local". Remote channels are +;;; represented by integers. Local channels are structures. Messages +;;; sent to a closed (remote) channel are ignored. + +(sly-def-connection-var sly-channels '() + "Alist of the form (ID . CHANNEL).") + +(sly-def-connection-var sly-channels-counter 0 + "Channel serial number counter.") + +(cl-defstruct (sly-channel (:conc-name sly-channel.) + (:constructor + sly-make-channel% (operations name id plist))) + operations name id plist) + +(defun sly-make-channel (operations &optional name) + (let* ((id (cl-incf (sly-channels-counter))) + (ch (sly-make-channel% operations name id nil))) + (push (cons id ch) (sly-channels)) + ch)) + +(defun sly-close-channel (channel) + (setf (sly-channel.operations channel) 'closed-channel) + (let ((probe (assq (sly-channel.id channel) + (and (sly-current-connection) + (sly-channels))))) + (cond (probe (setf (sly-channels) (delete probe (sly-channels)))) + (t (error "Can't close invalid channel: %s" channel))))) + +(defun sly-find-channel (id) + (cdr (assq id (sly-channels)))) + +(defun sly-channel-send (channel message) + (apply (or (gethash (car message) (sly-channel.operations channel)) + (error "Unsupported operation %S for channel %d" + (car message) + (sly-channel.id channel))) + channel (cdr message))) + +(defun sly-channel-put (channel prop value) + (setf (sly-channel.plist channel) + (plist-put (sly-channel.plist channel) prop value))) + +(defun sly-channel-get (channel prop) + (plist-get (sly-channel.plist channel) prop)) + +(eval-and-compile + (defun sly-channel-method-table-name (type) + (intern (format "sly-%s-channel-methods" type)))) + +(defmacro sly-define-channel-type (name) + (declare (indent defun)) + (let ((tab (sly-channel-method-table-name name))) + `(defvar ,tab (make-hash-table :size 10)))) + +(defmacro sly-define-channel-method (type method args &rest body) + (declare (indent 3) (debug (&define sexp name lambda-list + def-body))) + `(puthash ',method + (lambda (self . ,args) ,@body) + ,(sly-channel-method-table-name type))) + +(defun sly-send-to-remote-channel (channel-id msg) + (sly-dispatch-event `(:emacs-channel-send ,channel-id ,msg))) + +;;;;; Event logging to *sly-events* +;;; +;;; The *sly-events* buffer logs all protocol messages for debugging +;;; purposes. + +(defvar sly-log-events t + "*Log protocol events to the *sly-events* buffer.") + +(defun sly-log-event (event process) + "Record the fact that EVENT occurred in PROCESS." + (when sly-log-events + (with-current-buffer (sly--events-buffer process) + ;; trim? + (when (> (buffer-size) 100000) + (goto-char (/ (buffer-size) 2)) + (re-search-forward "^(" nil t) + (delete-region (point-min) (point))) + (goto-char (point-max)) + (unless (bolp) (insert "\n")) + (cond ((and (stringp event) + (string-match "^;" event)) + (insert-before-markers event)) + (t + (save-excursion + (sly-pprint-event event (current-buffer))))) + (goto-char (point-max))))) + +(defun sly-pprint-event (event buffer) + "Pretty print EVENT in BUFFER with limited depth and width." + (let ((print-length 20) + (print-level 6) + (pp-escape-newlines t)) + ;; HACK workaround for gh#183 + (condition-case _oops (pp event buffer) (error (print event buffer))))) + +(defun sly--events-buffer (process) + "Return or create the event log buffer." + (let* ((probe (process-get process 'sly--events-buffer)) + (buffer (or (and (buffer-live-p probe) + probe) + (let ((buffer (get-buffer-create + (apply #'sly-buffer-name + :events + (if (sly-connection-name process) + `(:connection ,process) + `(:suffix ,(format "%s" process))))))) + (with-current-buffer buffer + (buffer-disable-undo) + (when (fboundp 'lisp-data-mode) ; Emacs >= 28 only + (funcall 'lisp-data-mode)) + (set (make-local-variable 'sly-buffer-connection) process) + (sly-mode 1)) + (process-put process 'sly--events-buffer buffer) + buffer)))) + buffer)) + +(defun sly-pop-to-events-buffer (process) + "Pop to the SLY events buffer for PROCESS" + (interactive (list (sly-current-connection))) + (pop-to-buffer (sly--events-buffer process))) + +(defun sly-switch-to-most-recent (mode) + "Switch to most recent buffer in MODE, a major-mode symbol. +With prefix argument, prompt for MODE" + (interactive + (list (if current-prefix-arg + (intern (completing-read + "Switch to most recent buffer in what mode? " + (mapcar #'symbol-name '(lisp-mode + emacs-lisp-mode)) + nil t)) + 'lisp-mode))) + (cl-loop for buffer in (buffer-list) + when (and (with-current-buffer buffer (eq major-mode mode)) + (not (eq buffer (current-buffer))) + (not (string-match "^ " (buffer-name buffer)))) + do (pop-to-buffer buffer) and return buffer)) + +(defun sly-forget-pending-events (process) + "Forget any outgoing events for the PROCESS" + (interactive (list (sly-current-connection))) + (setf (sly-rex-continuations process) nil)) + + +;;;;; Cleanup after a quit + +(defun sly-restart-inferior-lisp () + "Kill and restart the Lisp subprocess." + (interactive) + (cl-assert (sly-inferior-process) () "No inferior lisp process") + (sly-quit-lisp-internal (sly-connection) 'sly-restart-sentinel t)) + +(defun sly-restart-sentinel (connection _message) + "When CONNECTION dies, start a similar inferior lisp process. +Also rearrange windows." + (cl-assert (process-status connection) 'closed) + (let* ((moribund-proc (sly-inferior-process connection)) + (args (sly-inferior-lisp-args moribund-proc)) + (buffer (buffer-name (process-buffer moribund-proc)))) + (sly-net-close connection "Restarting inferior lisp process") + (sly-inferior-connect (sly-start-lisp (plist-get args :program) + (plist-get args :program-args) + (plist-get args :env) + nil + buffer) + args))) + + +;;;; Compilation and the creation of compiler-note annotations + +(defvar sly-highlight-compiler-notes t + "*When non-nil annotate buffers with compilation notes etc.") + +(defcustom sly-compilation-finished-hook '(sly-maybe-show-compilation-log) + "Hook called after compilation. +Each function is called with four arguments (SUCCESSP NOTES BUFFER LOADP) +SUCCESSP indicates if the compilation was successful. +NOTES is a list of compilation notes. +BUFFER is the buffer just compiled, or nil if a string was compiled. +LOADP is the value of the LOAD flag passed to `sly-compile-file', or t +if a string." + :group 'sly-mode + :type 'hook + :options '(sly-maybe-show-compilation-log + sly-show-compilation-log + sly-maybe-show-xrefs-for-notes + sly-goto-first-note)) + +;; FIXME: I doubt that anybody uses this directly and it seems to be +;; only an ugly way to pass arguments. +(defvar sly-compilation-policy nil + "When non-nil compile with these optimization settings.") + +(defun sly-compute-policy (arg) + "Return the policy for the prefix argument ARG." + (let ((between (lambda (min n max) + (cond ((< n min) min) + ((> n max) max) + (t n))))) + (let ((n (prefix-numeric-value arg))) + (cond ((not arg) sly-compilation-policy) + ((cl-plusp n) `((cl:debug . ,(funcall between 0 n 3)))) + ((eq arg '-) `((cl:speed . 3))) + (t `((cl:speed . ,(funcall between 0 (abs n) 3)))))))) + +(cl-defstruct (sly-compilation-result + (:type list) + (:conc-name sly-compilation-result.) + (:constructor nil) + (:copier nil)) + tag notes successp duration loadp faslfile) + +(defvar sly-last-compilation-result nil + "The result of the most recently issued compilation.") + +(defun sly-compiler-notes () + "Return all compiler notes, warnings, and errors." + (sly-compilation-result.notes sly-last-compilation-result)) + +(defun sly-compile-and-load-file (&optional policy) + "Compile and load the buffer's file and highlight compiler notes. + +With (positive) prefix argument the file is compiled with maximal +debug settings (`C-u'). With negative prefix argument it is compiled for +speed (`M--'). If a numeric argument is passed set debug or speed settings +to it depending on its sign. + +Each source location that is the subject of a compiler note is +underlined and annotated with the relevant information. The commands +`sly-next-note' and `sly-previous-note' can be used to navigate +between compiler notes and to display their full details." + (interactive "P") + (sly-compile-file t (sly-compute-policy policy))) + +(defcustom sly-compile-file-options '() + "Plist of additional options that C-c C-k should pass to Lisp. +Currently only :fasl-directory is supported." + :group 'sly-lisp + :type '(plist :key-type symbol :value-type (file :must-match t))) + +(defun sly-compile-file (&optional load policy) + "Compile current buffer's file and highlight resulting compiler notes. + +See `sly-compile-and-load-file' for further details." + (interactive) + (unless buffer-file-name + (error "Buffer %s is not associated with a file." (buffer-name))) + (check-parens) + (when (and (buffer-modified-p) + (or (not compilation-ask-about-save) + (sly-y-or-n-p (format "Save file %s? " (buffer-file-name))))) + (save-buffer)) + (let ((file (sly-to-lisp-filename (buffer-file-name))) + (options (sly-simplify-plist `(,@sly-compile-file-options + :policy ,policy)))) + (sly-eval-async + `(slynk:compile-file-for-emacs ,file ,(if load t nil) + . ,(sly-hack-quotes options)) + #'(lambda (result) + (sly-compilation-finished result (current-buffer)))) + (sly-message "Compiling %s..." file))) + +(defun sly-hack-quotes (arglist) + ;; eval is the wrong primitive, we really want funcall + (cl-loop for arg in arglist collect `(quote ,arg))) + +(defun sly-simplify-plist (plist) + (cl-loop for (key val) on plist by #'cddr + append (cond ((null val) '()) + (t (list key val))))) + +(defun sly-compile-defun (&optional raw-prefix-arg) + "Compile the current toplevel form. + +With (positive) prefix argument the form is compiled with maximal +debug settings (`C-u'). With negative prefix argument it is compiled for +speed (`M--'). If a numeric argument is passed set debug or speed settings +to it depending on its sign." + (interactive "P") + (let ((sly-compilation-policy (sly-compute-policy raw-prefix-arg))) + (if (use-region-p) + (sly-compile-region (region-beginning) (region-end)) + (apply #'sly-compile-region (sly-region-for-defun-at-point))))) + +(defvar sly-compile-region-function 'sly-compile-region-as-string + "Function called by `sly-compile-region' to do actual work.") + +(defun sly-compile-region (start end) + "Compile the region." + (interactive "r") + ;; Check connection before running hooks things like + ;; sly-flash-region don't make much sense if there's no connection + (sly-connection) + (funcall sly-compile-region-function start end)) + +(defun sly-compile-region-as-string (start end) + (sly-flash-region start end) + (sly-compile-string (buffer-substring-no-properties start end) start)) + +(defun sly-compile-string (string start-offset) + (let* ((position (sly-compilation-position start-offset))) + (sly-eval-async + `(slynk:compile-string-for-emacs + ,string + ,(buffer-name) + ',position + ,(if (buffer-file-name) (sly-to-lisp-filename (buffer-file-name))) + ',sly-compilation-policy) + #'(lambda (result) + (sly-compilation-finished result nil))))) + +(defun sly-compilation-position (start-offset) + (let ((line (save-excursion + (goto-char start-offset) + (list (line-number-at-pos) (1+ (current-column)))))) + `((:position ,start-offset) (:line ,@line)))) + +(defcustom sly-load-failed-fasl 'never + "Which action to take when COMPILE-FILE set FAILURE-P to T. +NEVER doesn't load the fasl +ALWAYS loads the fasl +ASK asks the user." + :type '(choice (const never) + (const always) + (const ask))) + +(defun sly-load-failed-fasl-p () + (cl-ecase sly-load-failed-fasl + (never nil) + (always t) + (ask (sly-y-or-n-p "Compilation failed. Load fasl file anyway? ")))) + +(defun sly-compilation-finished (result buffer &optional message) + (let ((notes (sly-compilation-result.notes result)) + (duration (sly-compilation-result.duration result)) + (successp (sly-compilation-result.successp result)) + (faslfile (sly-compilation-result.faslfile result)) + (loadp (sly-compilation-result.loadp result))) + (setf sly-last-compilation-result result) + (sly-show-note-counts notes duration (cond ((not loadp) successp) + (t (and faslfile successp))) + (or (not buffer) loadp) + message) + (when sly-highlight-compiler-notes + (sly-highlight-notes notes)) + (when (and loadp faslfile + (or successp + (sly-load-failed-fasl-p))) + (sly-eval-async `(slynk:load-file ,faslfile))) + (run-hook-with-args 'sly-compilation-finished-hook successp notes buffer loadp))) + +(defun sly-show-note-counts (notes secs successp loadp &optional message) + (sly-message (concat + (cond ((and successp loadp) + "Compiled and loaded") + (successp "Compilation finished") + (t (sly-add-face 'font-lock-warning-face + "Compilation failed"))) + (if (null notes) ". (No warnings)" ": ") + (mapconcat + (lambda (msgs) + (cl-destructuring-bind (sev . notes) msgs + (let ((len (length notes))) + (format "%d %s%s" len (sly-severity-label sev) + (if (= len 1) "" "s"))))) + (sort (sly-alistify notes #'sly-note.severity #'eq) + (lambda (x y) (sly-severity< (car y) (car x)))) + " ") + (if secs (format " [%.2f secs]" secs)) + message))) + +(defun sly-highlight-notes (notes) + "Highlight compiler notes, warnings, and errors in the buffer." + (interactive (list (sly-compiler-notes))) + (with-temp-message "Highlighting notes..." + (save-excursion + (save-restriction + (widen) ; highlight notes on the whole buffer + (sly-remove-notes (point-min) (point-max)) + (mapc #'sly--add-in-buffer-note notes))))) + + +;;;;; Recompilation. + +;; FIXME: This whole idea is questionable since it depends so +;; crucially on precise source-locs. + +(defun sly-recompile-location (location) + (save-excursion + (sly-move-to-source-location location) + (sly-compile-defun))) + +(defun sly-recompile-locations (locations cont) + (sly-eval-async + `(slynk:compile-multiple-strings-for-emacs + ',(cl-loop for loc in locations collect + (save-excursion + (sly-move-to-source-location loc) + (cl-destructuring-bind (start end) + (sly-region-for-defun-at-point) + (list (buffer-substring-no-properties start end) + (buffer-name) + (sly-current-package) + start + (if (buffer-file-name) + (sly-to-lisp-filename (buffer-file-name)) + nil))))) + ',sly-compilation-policy) + cont)) + + +;;;;; Compiler notes list + +(defun sly-one-line-ify (string) + "Return a single-line version of STRING. +Each newlines and following indentation is replaced by a single space." + (with-temp-buffer + (insert string) + (goto-char (point-min)) + (while (re-search-forward "\n[\n \t]*" nil t) + (replace-match " ")) + (buffer-string))) + +(defun sly-xref--get-xrefs-for-notes (notes) + (let ((xrefs)) + (dolist (note notes) + (let* ((location (cl-getf note :location)) + (fn (cadr (assq :file (cdr location)))) + (file (assoc fn xrefs)) + (node + (list (format "%s: %s" + (cl-getf note :severity) + (sly-one-line-ify (cl-getf note :message))) + location))) + (when fn + (if file + (push node (cdr file)) + (setf xrefs (cl-acons fn (list node) xrefs)))))) + xrefs)) + +(defun sly-maybe-show-xrefs-for-notes (_successp notes _buffer _loadp) + "Show the compiler notes NOTES if they come from more than one file." + (let ((xrefs (sly-xref--get-xrefs-for-notes notes))) + (when (cdr xrefs) ; >1 file + (sly-xref--show-results + xrefs 'definition "Compiler notes" (sly-current-package))))) + +(defun sly-maybe-show-compilation-log (successp notes buffer loadp) + "Display the log on failed compilations or if NOTES is non-nil." + (sly-show-compilation-log successp notes buffer loadp + (if successp :hidden nil))) + +(defun sly-show-compilation-log (successp notes buffer loadp &optional select) + "Create and display the compilation log buffer." + (interactive (list (sly-compiler-notes))) + (sly-with-popup-buffer ((sly-buffer-name :compilation) + :mode 'compilation-mode + :select select) + (sly--insert-compilation-log successp notes buffer loadp) + (insert "Compilation " + (if successp "successful" "failed") + "."))) + +(defvar sly-compilation-log--notes (make-hash-table) + "Hash-table (NOTE -> (BUFFER POSITION)) for finding notes in + the SLY compilation log") + +(defun sly--insert-compilation-log (_successp notes _buffer _loadp) + "Insert NOTES in format suitable for `compilation-mode'." + (clrhash sly-compilation-log--notes) + (cl-multiple-value-bind (grouped-notes canonicalized-locs-table) + (sly-group-and-sort-notes notes) + (with-temp-message "Preparing compilation log..." + (let ((inhibit-read-only t) + (inhibit-modification-hooks t)) ; inefficient font-lock-hook + (insert (format "cd %s\n%d compiler notes:\n\n" + default-directory (length notes))) + (cl-loop for notes in grouped-notes + for loc = (gethash (cl-first notes) canonicalized-locs-table) + for start = (point) + do + (cl-loop for note in notes + do (puthash note + (cons (current-buffer) start) + sly-compilation-log--notes)) + (insert + (sly--compilation-note-group-button + (sly-canonicalized-location-to-string loc) notes) + ":") + (sly-insert-note-group notes) + (insert "\n") + (add-text-properties start (point) `(field ,notes)))) + (set (make-local-variable 'compilation-skip-threshold) 0) + (setq next-error-last-buffer (current-buffer))))) + +(defun sly-insert-note-group (notes) + "Insert a group of compiler messages." + (insert "\n") + (dolist (note notes) + (insert " " (sly-severity-label (sly-note.severity note)) ": ") + (let ((start (point))) + (insert (sly-note.message note)) + (let ((ctx (sly-note.source-context note))) + (if ctx (insert "\n" ctx))) + (sly-indent-block start 4)) + (insert "\n"))) + +(defun sly-indent-block (start column) + "If the region back to START isn't a one-liner indent it." + (when (< start (line-beginning-position)) + (save-excursion + (goto-char start) + (insert "\n")) + (sly-indent-rigidly start (point) column))) + +(defun sly-canonicalized-location (location) + "Return a list (FILE LINE COLUMN) for sly-location LOCATION. +This is quite an expensive operation so use carefully." + (save-excursion + (sly-goto-location-buffer (sly-location.buffer location)) + (save-excursion + (sly-move-to-source-location location) + (list (or (buffer-file-name) (buffer-name)) + (save-restriction + (widen) + (line-number-at-pos)) + (1+ (current-column)))))) + +(defun sly-canonicalized-location-to-string (loc) + (if loc + (cl-destructuring-bind (filename line col) loc + (format "%s:%d:%d" + (cond ((not filename) "") + ((let ((rel (file-relative-name filename))) + (if (< (length rel) (length filename)) + rel))) + (t filename)) + line col)) + (format "Unknown location"))) + +(defun sly-group-and-sort-notes (notes) + "First sort, then group NOTES according to their canonicalized locs." + (let ((locs (make-hash-table :test #'eq))) + (mapc (lambda (note) + (let ((loc (sly-note.location note))) + (when (sly-location-p loc) + (puthash note (sly-canonicalized-location loc) locs)))) + notes) + (cl-values (sly-group-similar + (lambda (n1 n2) + (equal (gethash n1 locs nil) (gethash n2 locs t))) + (let* ((bottom most-negative-fixnum) + (+default+ (list "" bottom bottom))) + (sort notes + (lambda (n1 n2) + (cl-destructuring-bind (filename1 line1 col1) + (gethash n1 locs +default+) + (cl-destructuring-bind (filename2 line2 col2) + (gethash n2 locs +default+) + (cond ((string-lessp filename1 filename2) t) + ((string-lessp filename2 filename1) nil) + ((< line1 line2) t) + ((> line1 line2) nil) + (t (< col1 col2))))))))) + locs))) + +(defun sly-note.severity (note) + (plist-get note :severity)) + +(defun sly-note.message (note) + (plist-get note :message)) + +(defun sly-note.source-context (note) + (plist-get note :source-context)) + +(defun sly-note.location (note) + (plist-get note :location)) + +(defun sly-severity-label (severity) + (cl-subseq (symbol-name severity) 1)) + + + +;;;;; Adding a single compiler note +;;;;; +(defun sly-choose-overlay-region (note) + "Choose the start and end points for an overlay over NOTE. +If the location's sexp is a list spanning multiple lines, then the +region around the first element is used. +Return nil if there's no useful source location." + (let ((location (sly-note.location note))) + (when location + (sly-dcase location + ((:error _)) ; do nothing + ((:location file pos _hints) + (cond ((eq (car file) ':source-form) nil) + ((eq (sly-note.severity note) :read-error) + (sly-choose-overlay-for-read-error location)) + ((equal pos '(:eof)) + (list (1- (point-max)) (point-max))) + (t + (sly-choose-overlay-for-sexp location)))))))) + +(defun sly-choose-overlay-for-read-error (location) + (let ((pos (sly-location-offset location))) + (save-excursion + (goto-char pos) + (cond ((sly-symbol-at-point) + ;; package not found, &c. + (list (sly-symbol-start-pos) (sly-symbol-end-pos))) + (t + (list pos (1+ pos))))))) + +(defun sly-choose-overlay-for-sexp (location) + (sly-move-to-source-location location) + (skip-chars-forward "'#`") + (let ((start (point))) + (ignore-errors (sly-forward-sexp)) + (if (sly-same-line-p start (point)) + (list start (point)) + (list (1+ start) + (progn (goto-char (1+ start)) + (ignore-errors (forward-sexp 1)) + (point)))))) +(defun sly-same-line-p (pos1 pos2) + "Return t if buffer positions POS1 and POS2 are on the same line." + (save-excursion (goto-char (min pos1 pos2)) + (<= (max pos1 pos2) (line-end-position)))) + +(defvar sly-severity-face-plist + (list :error 'sly-error-face + :read-error 'sly-error-face + :warning 'sly-warning-face + :redefinition 'sly-style-warning-face + :style-warning 'sly-style-warning-face + :note 'sly-note-face)) + +(defun sly-severity-face (severity) + "Return the name of the font-lock face representing SEVERITY." + (or (plist-get sly-severity-face-plist severity) + (error "No face for: %S" severity))) + +(defvar sly-severity-order + '(:note :style-warning :redefinition :warning :error :read-error)) + +(defun sly-severity< (sev1 sev2) + "Return true if SEV1 is less severe than SEV2." + (< (cl-position sev1 sly-severity-order) + (cl-position sev2 sly-severity-order))) + +(defun sly-forward-positioned-source-path (source-path) + "Move forward through a sourcepath from a fixed position. +The point is assumed to already be at the outermost sexp, making the +first element of the source-path redundant." + (ignore-errors + (sly-forward-sexp) + (beginning-of-defun)) + (sly--when-let (source-path (cdr source-path)) + (down-list 1) + (sly-forward-source-path source-path))) + +(defun sly-forward-source-path (source-path) + (let ((origin (point))) + (condition-case nil + (progn + (cl-loop for (count . more) on source-path + do (progn + (sly-forward-sexp count) + (when more (down-list 1)))) + ;; Align at beginning + (sly-forward-sexp) + (beginning-of-sexp)) + (error (goto-char origin))))) + + +;; FIXME: really fix this mess +;; FIXME: the check shouln't be done here anyway but by M-. itself. + +(defun sly-filesystem-toplevel-directory () + ;; Windows doesn't have a true toplevel root directory, and all + ;; filenames look like "c:/foo/bar/quux.baz" from an Emacs + ;; perspective anyway. + (if (memq system-type '(ms-dos windows-nt)) + "" + (file-name-as-directory "/"))) + +(defun sly-file-name-merge-source-root (target-filename buffer-filename) + "Returns a filename where the source root directory of TARGET-FILENAME +is replaced with the source root directory of BUFFER-FILENAME. + +If no common source root could be determined, return NIL. + +E.g. (sly-file-name-merge-source-root + \"/usr/local/src/joe/upstream/sbcl/code/late-extensions.lisp\" + \"/usr/local/src/joe/hacked/sbcl/compiler/deftype.lisp\") + + ==> \"/usr/local/src/joe/hacked/sbcl/code/late-extensions.lisp\" +" + (let ((target-dirs (split-string (file-name-directory target-filename) + "/" t)) + (buffer-dirs (split-string (file-name-directory buffer-filename) + "/" t))) + ;; Starting from the end, we look if one of the TARGET-DIRS exists + ;; in BUFFER-FILENAME---if so, it and everything left from that dirname + ;; is considered to be the source root directory of BUFFER-FILENAME. + (cl-loop with target-suffix-dirs = nil + with buffer-dirs* = (reverse buffer-dirs) + with target-dirs* = (reverse target-dirs) + for target-dir in target-dirs* + do (let ((concat-dirs (lambda (dirs) + (apply #'concat + (mapcar #'file-name-as-directory + dirs)))) + (pos (cl-position target-dir buffer-dirs* + :test #'equal))) + (if (not pos) ; TARGET-DIR not in BUFFER-FILENAME? + (push target-dir target-suffix-dirs) + (let* ((target-suffix + ; PUSH reversed for us! + (funcall concat-dirs target-suffix-dirs)) + (buffer-root + (funcall concat-dirs + (reverse (nthcdr pos buffer-dirs*))))) + (cl-return (concat (sly-filesystem-toplevel-directory) + buffer-root + target-suffix + (file-name-nondirectory + target-filename))))))))) + +(defun sly-highlight-differences-in-dirname (base-dirname contrast-dirname) + "Returns a copy of BASE-DIRNAME where all differences between +BASE-DIRNAME and CONTRAST-DIRNAME are propertized with a +highlighting face." + (setq base-dirname (file-name-as-directory base-dirname)) + (setq contrast-dirname (file-name-as-directory contrast-dirname)) + (let ((base-dirs (split-string base-dirname "/" t)) + (contrast-dirs (split-string contrast-dirname "/" t))) + (with-temp-buffer + (cl-loop initially (insert (sly-filesystem-toplevel-directory)) + for base-dir in base-dirs do + (let ((pos (cl-position base-dir contrast-dirs :test #'equal))) + (cond ((not pos) + (sly-insert-propertized '(face highlight) base-dir) + (insert "/")) + (t + (insert (file-name-as-directory base-dir)) + (setq contrast-dirs + (nthcdr (1+ pos) contrast-dirs)))))) + (buffer-substring (point-min) (point-max))))) + +(defvar sly-warn-when-possibly-tricked-by-M-. t + "When working on multiple source trees simultaneously, the way +`sly-edit-definition' (M-.) works can sometimes be confusing: + +`M-.' visits locations that are present in the current Lisp image, +which works perfectly well as long as the image reflects the source +tree that one is currently looking at. + +In the other case, however, one can easily end up visiting a file +in a different source root directory (the one corresponding to +the Lisp image), and is thus easily tricked to modify the wrong +source files---which can lead to quite some stressfull cursing. + +If this variable is T, a warning message is issued to raise the +user's attention whenever `M-.' is about opening a file in a +different source root that also exists in the source root +directory of the user's current buffer. + +There's no guarantee that all possible cases are covered, but +if you encounter such a warning, it's a strong indication that +you should check twice before modifying.") + +(defun sly-maybe-warn-for-different-source-root (target-filename + buffer-filename) + (let ((guessed-target (sly-file-name-merge-source-root target-filename + buffer-filename))) + (when (and guessed-target + (not (equal guessed-target target-filename)) + (file-exists-p guessed-target)) + (sly-message "Attention: This is `%s'." + (concat (sly-highlight-differences-in-dirname + (file-name-directory target-filename) + (file-name-directory guessed-target)) + (file-name-nondirectory target-filename)))))) + +(defun sly-check-location-filename-sanity (filename) + (when sly-warn-when-possibly-tricked-by-M-. + (cl-macrolet ((truename-safe (file) `(and ,file (file-truename ,file)))) + (let ((target-filename (truename-safe filename)) + (buffer-filename (truename-safe (buffer-file-name)))) + (when (and target-filename + buffer-filename) + (sly-maybe-warn-for-different-source-root + target-filename buffer-filename)))))) + +(defun sly-check-location-buffer-name-sanity (buffer-name) + (sly-check-location-filename-sanity + (buffer-file-name (get-buffer buffer-name)))) + + + +(defun sly-goto-location-buffer (buffer) + (sly-dcase buffer + ((:file filename) + (let ((filename (sly-from-lisp-filename filename))) + (sly-check-location-filename-sanity filename) + (set-buffer (or (get-file-buffer filename) + (let ((find-file-suppress-same-file-warnings t)) + (find-file-noselect filename)))))) + ((:buffer buffer-name) + (sly-check-location-buffer-name-sanity buffer-name) + (set-buffer buffer-name)) + ((:buffer-and-file buffer filename) + (sly-goto-location-buffer + (if (get-buffer buffer) + (list :buffer buffer) + (list :file filename)))) + ((:source-form string) + (set-buffer (get-buffer-create (sly-buffer-name :source))) + (erase-buffer) + (lisp-mode) + (insert string) + (goto-char (point-min))) + ((:zip file entry) + (require 'arc-mode) + (set-buffer (find-file-noselect file t)) + (goto-char (point-min)) + (re-search-forward (concat " " entry "$")) + (let ((buffer (save-window-excursion + (archive-extract) + (current-buffer)))) + (set-buffer buffer) + (goto-char (point-min)))))) + +(defun sly-goto-location-position (position) + (sly-dcase position + ((:position pos) + (goto-char 1) + (forward-char (- (1- pos) (sly-eol-conversion-fixup (1- pos))))) + ((:offset start offset) + (goto-char start) + (forward-char offset)) + ((:line start &optional column) + (goto-char (point-min)) + (beginning-of-line start) + (cond (column (move-to-column column)) + (t (skip-chars-forward " \t")))) + ((:function-name name) + (let ((case-fold-search t) + (name (regexp-quote name))) + (goto-char (point-min)) + (when (or + (re-search-forward + (format "\\s *(def\\(\\s_\\|\\sw\\)*\\s +(*%s\\S_" + (regexp-quote name)) nil t) + (re-search-forward + (format "[( \t]%s\\>\\(\\s \\|$\\)" name) nil t)) + (goto-char (match-beginning 0))))) + ((:method name specializers &rest qualifiers) + (sly-search-method-location name specializers qualifiers)) + ((:source-path source-path start-position) + (cond (start-position + (goto-char start-position) + (sly-forward-positioned-source-path source-path)) + (t + (sly-forward-source-path source-path)))) + ((:eof) + (goto-char (point-max))))) + +(defun sly-eol-conversion-fixup (n) + ;; Return the number of \r\n eol markers that we need to cross when + ;; moving N chars forward. N is the number of chars but \r\n are + ;; counted as 2 separate chars. + (if (zerop n) 0 + (cl-case (coding-system-eol-type buffer-file-coding-system) + ((1) + (save-excursion + (cl-do ((pos (+ (point) n)) + (count 0 (1+ count))) + ((>= (point) pos) (1- count)) + (forward-line) + (cl-decf pos)))) + (t 0)))) + +(defun sly-search-method-location (name specializers qualifiers) + ;; Look for a sequence of words (def<something> method name + ;; qualifers specializers don't look for "T" since it isn't requires + ;; (arg without t) as class is taken as such. + (let* ((case-fold-search t) + (name (regexp-quote name)) + (qualifiers (mapconcat (lambda (el) (concat ".+?\\<" el "\\>")) + qualifiers "")) + (specializers (mapconcat + (lambda (el) + (if (eql (aref el 0) ?\() + (let ((spec (read el))) + (if (eq (car spec) 'EQL) + (concat + ".*?\\n\\{0,1\\}.*?(EQL.*?'\\{0,1\\}" + (format "%s" (cl-second spec)) ")") + (error "don't understand specializer: %s,%s" + el (car spec)))) + (concat ".+?\n\\{0,1\\}.+?\\<" el "\\>"))) + (remove "T" specializers) "")) + (regexp (format "\\s *(def\\(\\s_\\|\\sw\\)*\\s +%s\\s +%s%s" name + qualifiers specializers))) + (or (and (re-search-forward regexp nil t) + (goto-char (match-beginning 0))) + ;; (sly-goto-location-position `(:function-name ,name)) + ))) + +(defun sly-search-call-site (fname) + "Move to the place where FNAME called. +Don't move if there are multiple or no calls in the current defun." + (save-restriction + (narrow-to-defun) + (let ((start (point)) + (regexp (concat "(" fname "[)\n \t]")) + (case-fold-search t)) + (cond ((and (re-search-forward regexp nil t) + (not (re-search-forward regexp nil t))) + (goto-char (match-beginning 0))) + (t (goto-char start)))))) + +(defun sly-search-edit-path (edit-path) + "Move to EDIT-PATH starting at the current toplevel form." + (when edit-path + (unless (and (= (current-column) 0) + (looking-at "(")) + (beginning-of-defun)) + (sly-forward-source-path edit-path))) + +(defun sly-move-to-source-location (location &optional noerror) + "Move to the source location LOCATION. +If NOERROR don't signal an error, but return nil. + +Several kinds of locations are supported: + +<location> ::= (:location <buffer> <position> <hints>) + | (:error <message>) + +<buffer> ::= (:file <filename>) + | (:buffer <buffername>) + | (:buffer-and-file <buffername> <filename>) + | (:source-form <string>) + | (:zip <file> <entry>) + +<position> ::= (:position <fixnum>) ; 1 based (for files) + | (:offset <start> <offset>) ; start+offset (for C-c C-c) + | (:line <line> [<column>]) + | (:function-name <string>) + | (:source-path <list> <start-position>) + | (:method <name string> <specializers> . <qualifiers>)" + (sly-dcase location + ((:location buffer _position _hints) + (sly-goto-location-buffer buffer) + (let ((pos (sly-location-offset location))) + (cond ((and (<= (point-min) pos) (<= pos (point-max)))) + (widen-automatically (widen)) + (t + (error "Location is outside accessible part of buffer"))) + (goto-char pos))) + ((:error message) + (cond (noerror + (sly-message "%s" message) + nil) + (t + (error "%s" message)))))) + +(defun sly--highlight-sexp (&optional start end) + "Highlight the first sexp after point." + (let ((start (or start (point))) + (end (or end (save-excursion (ignore-errors (forward-sexp)) (point))))) + (sly-flash-region start end))) + +(defun sly--highlight-line (&optional timeout) + (sly-flash-region (+ (line-beginning-position) (current-indentation)) + (line-end-position) + :timeout timeout)) + +(make-variable-buffer-local + (defvar sly-xref--popup-method nil + "Helper for `sly--display-source-location'")) + +(cl-defun sly--display-source-location (source-location + &optional noerror (method 'window)) + "Display SOURCE-LOCATION in a window according to METHOD. +Highlight the resulting sexp. Return the window or raise an +error, unless NOERROR is nil, in which case return nil. METHOD +specifies how to behave when a reference is selected in an xref +buffer. If one of symbols `window' or `frame' just +`display-buffer' accordingly. If nil, just switch to buffer in +current window. If a cons (WINDOW . METHOD) consider WINDOW the +\"starting window\" and reconsider METHOD like above: If it is +nil try to use WINDOW exclusively for showing the location, +otherwise prevent that window from being reused when popping to a +new window or frame." + (cl-labels + ((pop-it + (target-buffer method) + (cond ((eq method 'window) + (display-buffer target-buffer t)) + ((eq method 'frame) + (let ((pop-up-frames t)) + (display-buffer target-buffer t))) + ((consp method) + (let* ((window (car method)) + (sub-method (cdr method))) + (cond ((not (window-live-p window)) + ;; the original window has been deleted: all + ;; bets are off! + ;; + (pop-it target-buffer sub-method)) + (sub-method + ;; shield window from reuse, but restoring + ;; any dedicatedness + ;; + (let ((dedicatedness (window-dedicated-p window))) + (unwind-protect + (progn + ;; (set-window-dedicated-p window 'soft) + ;; + ;; jt@2018-01-27 commented the line + ;; above because since the fix to + ;; emacs' bug#28814 in Emacs 26.1 + ;; (which I myself authored), it won't + ;; work correctly. Best to disable it + ;; for now and eventually copy Emacs's + ;; approach to xref buffers, or better + ;; yet, reuse it. + (pop-it target-buffer sub-method)) + (set-window-dedicated-p window dedicatedness)))) + (t + ;; make efforts to reuse the window, respecting + ;; any `display-buffer' overrides + ;; + (display-buffer + target-buffer + `(,(lambda (buffer _alist) + (when (window-live-p window) + (set-window-buffer window buffer) + window)))))))) + (t + (switch-to-buffer target-buffer) + (selected-window))))) + (when (eq method 'sly-xref) + (setq method sly-xref--popup-method)) + (when (sly-move-to-source-location source-location noerror) + (let ((pos (point))) + (with-selected-window (pop-it (current-buffer) method) + (goto-char pos) + (recenter (if (= (current-column) 0) 1)) + (sly--highlight-sexp) + (selected-window)))))) + +(defun sly--pop-to-source-location (source-location &optional method) + "Pop to SOURCE-LOCATION using METHOD. +If called from an xref buffer, method will be `sly-xref' and +thus also honour `sly-xref--popup-method'." + (let* ((xref-window (selected-window)) + (xref-buffer (window-buffer xref-window))) + (when (eq method 'sly-xref) + (quit-restore-window xref-window 'bury)) + (with-current-buffer xref-buffer + ;; now pop to target + ;; + (select-window + (sly--display-source-location source-location nil method))) + (set-buffer (window-buffer (selected-window))))) + +(defun sly-location-offset (location) + "Return the position, as character number, of LOCATION." + (save-restriction + (widen) + (condition-case nil + (sly-goto-location-position + (sly-location.position location)) + (error (goto-char 0))) + (let ((hints (sly-location.hints location))) + (sly--when-let (snippet (cl-getf hints :snippet)) + (sly-isearch snippet)) + (sly--when-let (snippet (cl-getf hints :edit-path)) + (sly-search-edit-path snippet)) + (sly--when-let (fname (cl-getf hints :call-site)) + (sly-search-call-site fname)) + (when (cl-getf hints :align) + (sly-forward-sexp) + (beginning-of-sexp))) + (point))) + + +;;;;; Incremental search +;; +;; Search for the longest match of a string in either direction. +;; +;; This is for locating text that is expected to be near the point and +;; may have been modified (but hopefully not near the beginning!) + +(defun sly-isearch (string) + "Find the longest occurence of STRING either backwards of forwards. +If multiple matches exist the choose the one nearest to point." + (goto-char + (let* ((start (point)) + (len1 (sly-isearch-with-function 'search-forward string)) + (pos1 (point))) + (goto-char start) + (let* ((len2 (sly-isearch-with-function 'search-backward string)) + (pos2 (point))) + (cond ((and len1 len2) + ;; Have a match in both directions + (cond ((= len1 len2) + ;; Both are full matches -- choose the nearest. + (if (< (abs (- start pos1)) + (abs (- start pos2))) + pos1 pos2)) + ((> len1 len2) pos1) + ((> len2 len1) pos2))) + (len1 pos1) + (len2 pos2) + (t start)))))) + +(defun sly-isearch-with-function (search-fn string) + "Search for the longest substring of STRING using SEARCH-FN. +SEARCH-FN is either the symbol `search-forward' or `search-backward'." + (unless (string= string "") + (cl-loop for i from 1 to (length string) + while (funcall search-fn (substring string 0 i) nil t) + for match-data = (match-data) + do (cl-case search-fn + (search-forward (goto-char (match-beginning 0))) + (search-backward (goto-char (1+ (match-end 0))))) + finally (cl-return (if (null match-data) + nil + ;; Finish based on the last successful match + (store-match-data match-data) + (goto-char (match-beginning 0)) + (- (match-end 0) (match-beginning 0))))))) + + +;;;;; Visiting and navigating the overlays of compiler notes +(defun sly-note-button-p (button) + (eq (button-type button) 'sly-in-buffer-note)) + +(defalias 'sly-next-note 'sly-button-forward) +(defalias 'sly-previous-note 'sly-button-backward) + +(put 'sly-next-note 'sly-button-navigation-command t) +(put 'sly-previous-note 'sly-button-navigation-command t) + +(defun sly-goto-first-note (_successp notes _buffer _loadp) + "Go to the first note in the buffer." + (interactive (list (sly-compiler-notes))) + (when notes + (goto-char (point-min)) + (sly-next-note 1))) + +(defun sly-remove-notes (beg end) + "Remove `sly-note' annotation buttons from BEG to END." + (interactive (if (region-active-p) + (list (region-beginning) (region-end)) + (list (point-min) (point-max)))) + (cl-loop for existing in (overlays-in beg end) + when (sly-note-button-p existing) + do (delete-overlay existing))) + +(defun sly-show-notes (button &rest more-buttons) + "Present the details of a compiler note to the user." + (interactive) + (let ((notes (mapcar (sly-rcurry #'button-get 'sly-note) + (cons button more-buttons)))) + (sly-button-flash button :face (let ((color (face-underline-p (button-get button 'face)))) + (if color `(:background ,color) 'highlight))) + ;; If the compilation window is showing, try to land in a suitable + ;; place there, too... + ;; + (let* ((anchor (car notes)) + (compilation-buffer (sly-buffer-name :compilation)) + (compilation-window (get-buffer-window compilation-buffer t))) + (if compilation-window + (with-current-buffer compilation-buffer + (with-selected-window compilation-window + (let ((buffer-and-pos (gethash anchor + sly-compilation-log--notes))) + (when buffer-and-pos + (cl-assert (eq (car buffer-and-pos) (current-buffer))) + (goto-char (cdr buffer-and-pos)) + (let ((field-end (field-end (1+ (point))))) + (sly-flash-region (point) field-end) + (sly-recenter field-end)))) + (sly-message "Showing note in %s" (current-buffer)))) + ;; Else, do the next best thing, which is echo the messages. + ;; + (if (cdr notes) + (sly-message "%s notes:\n%s" + (length notes) + (mapconcat #'sly-note.message notes "\n")) + (sly-message "%s" (sly-note.message (car notes)))))))) + +(define-button-type 'sly-note :supertype 'sly-button) + +(define-button-type 'sly-in-buffer-note :supertype 'sly-note + 'keymap (let ((map (copy-keymap button-map))) + (define-key map "RET" nil) + map) + 'mouse-action 'sly-show-notes + 'sly-button-echo 'sly-show-notes + 'modification-hooks '(sly--in-buffer-note-modification)) + +(define-button-type 'sly-compilation-note-group :supertype 'sly-note + 'face nil) + +(defun sly--in-buffer-note-modification (button after? _beg _end &optional _len) + (unless after? (delete-overlay button))) + +(defun sly--add-in-buffer-note (note) + "Add NOTE as a `sly-in-buffer-note' button to the source buffer." + (cl-destructuring-bind (&optional beg end) + (sly-choose-overlay-region note) + (when beg + (let* ((contained (sly-button--overlays-between beg end)) + (containers (cl-set-difference (sly-button--overlays-at beg) + contained))) + (cl-loop for ov in contained do (cl-incf (sly-button--level ov))) + (let ((but (make-button beg + end + :type 'sly-in-buffer-note + 'sly-button-search-id (sly-button-next-search-id) + 'sly-note note + 'help-echo (format "[sly] %s" (sly-note.message note)) + 'face (sly-severity-face (sly-note.severity note))))) + (setf (sly-button--level but) + (1+ (cl-reduce #'max containers + :key #'sly-button--level + :initial-value 0)))))))) + +(defun sly--compilation-note-group-button (label notes) + "Pepare notes as a `sly-compilation-note' button. +For insertion in the `compilation-mode' buffer" + (sly--make-text-button label nil :type 'sly-compilation-note-group 'sly-notes-group notes)) + + +;;;; Basic arglisting +;;;; +(defun sly-show-arglist () + (let ((op (ignore-errors + (save-excursion + (backward-up-list 1) + (down-list 1) + (sly-symbol-at-point))))) + (when op + (sly-eval-async `(slynk:operator-arglist ,op ,(sly-current-package)) + (lambda (arglist) + (when arglist + (sly-message "%s" arglist))))))) + + +;;;; Edit definition + +(defun sly-push-definition-stack () + "Add point to find-tag-marker-ring." + (require 'etags) + (if (fboundp 'xref-push-marker-stack) + (xref-push-marker-stack) + (ring-insert find-tag-marker-ring (point-marker)))) + +(defun sly-pop-find-definition-stack () + "Pop the edit-definition stack and goto the location." + (interactive) + (pop-tag-mark)) + +(cl-defstruct (sly-xref (:conc-name sly-xref.) (:type list)) + dspec location) + +(cl-defstruct (sly-location (:conc-name sly-location.) (:type list) + (:constructor nil) + (:copier nil)) + tag buffer position hints) + +(defun sly-location-p (o) (and (consp o) (eq (car o) :location))) + +(defun sly-xref-has-location-p (xref) + (sly-location-p (sly-xref.location xref))) + +(defun make-sly-buffer-location (buffer-name position &optional hints) + `(:location (:buffer ,buffer-name) (:position ,position) + ,(when hints `(:hints ,hints)))) + +(defun make-sly-file-location (file-name position &optional hints) + `(:location (:file ,file-name) (:position ,position) + ,(when hints `(:hints ,hints)))) + + + +(defun sly-edit-definition (&optional name method) + "Lookup the definition of the name at point. +If there's no name at point, or a prefix argument is given, then +the function name is prompted. METHOD can be nil, or one of +`window' or `frame' to specify if the new definition should be +popped, respectively, in the current window, a new window, or a +new frame." + (interactive (list (or (and (not current-prefix-arg) + (sly-symbol-at-point t)) + (sly-read-symbol-name "Edit Definition of: ")))) + ;; The hooks might search for a name in a different manner, so don't + ;; ask the user if it's missing before the hooks are run + (let ((xrefs (sly-eval `(slynk:find-definitions-for-emacs ,name)))) + (unless xrefs + (error "No known definition for: %s (in %s)" + name (sly-current-package))) + (cl-destructuring-bind (1loc file-alist) + (sly-analyze-xrefs xrefs) + (cond (1loc + (sly-push-definition-stack) + (sly--pop-to-source-location + (sly-xref.location (car xrefs)) method)) + ((null (cdr xrefs)) ; ((:error "...")) + (error "%s" xrefs)) + (t + (sly-push-definition-stack) + (sly-xref--show-results file-alist 'definition name + (sly-current-package) + (cons (selected-window) + method))))))) + +(defvar sly-edit-uses-xrefs + '(:calls :macroexpands :binds :references :sets :specializes)) + +;;; FIXME. TODO: Would be nice to group the symbols (in each +;;; type-group) by their home-package. +(defun sly-edit-uses (symbol) + "Lookup all the uses of SYMBOL." + (interactive (list (sly-read-symbol-name "Edit Uses of: "))) + (sly-xref--get-xrefs + sly-edit-uses-xrefs + symbol + (lambda (xrefs type symbol package) + (cond + ((and (sly-length= xrefs 1) ; one group + (sly-length= (cdar xrefs) 1)) ; one ref in group + (cl-destructuring-bind (_ (_ loc)) (cl-first xrefs) + (sly-push-definition-stack) + (sly--pop-to-source-location loc))) + (t + (sly-push-definition-stack) + (sly-xref--show-results xrefs type symbol package 'window)))))) + +(defun sly-analyze-xrefs (xrefs) + "Find common filenames in XREFS. +Return a list (SINGLE-LOCATION FILE-ALIST). +SINGLE-LOCATION is true if all xrefs point to the same location. +FILE-ALIST is an alist of the form ((FILENAME . (XREF ...)) ...)." + (list (and xrefs + (let ((loc (sly-xref.location (car xrefs)))) + (and (sly-location-p loc) + (cl-every (lambda (x) (equal (sly-xref.location x) loc)) + (cdr xrefs))))) + (sly-alistify xrefs #'sly-xref-group #'equal))) + +(defun sly-xref-group (xref) + (cond ((sly-xref-has-location-p xref) + (sly-dcase (sly-location.buffer (sly-xref.location xref)) + ((:file filename) filename) + ((:buffer bufname) + (let ((buffer (get-buffer bufname))) + (if buffer + (format "%S" buffer) ; "#<buffer foo.lisp>" + (format "%s (previously existing buffer)" bufname)))) + ((:buffer-and-file _buffer filename) filename) + ((:source-form _) "(S-Exp)") + ((:zip _zip entry) entry))) + (t + "(No location)"))) + +(defun sly-edit-definition-other-window (name) + "Like `sly-edit-definition' but switch to the other window." + (interactive (list (sly-read-symbol-name "Symbol: "))) + (sly-edit-definition name 'window)) + +(defun sly-edit-definition-other-frame (name) + "Like `sly-edit-definition' but switch to the other window." + (interactive (list (sly-read-symbol-name "Symbol: "))) + (sly-edit-definition name 'frame)) + + + +;;;;; first-change-hook + +(defun sly-first-change-hook () + "Notify Lisp that a source file's buffer has been modified." + ;; Be careful not to disturb anything! + ;; In particular if we muck up the match-data then query-replace + ;; breaks. -luke (26/Jul/2004) + (save-excursion + (save-match-data + (when (and (buffer-file-name) + (file-exists-p (buffer-file-name)) + (sly-background-activities-enabled-p)) + (let ((filename (sly-to-lisp-filename (buffer-file-name)))) + (sly-eval-async `(slynk:buffer-first-change ,filename))))))) + +(defun sly-setup-first-change-hook () + (add-hook 'first-change-hook #'sly-first-change-hook nil t)) + +(add-hook 'sly-mode-hook 'sly-setup-first-change-hook) + + +;;;; Eval for Lisp + +(defun sly-eval-for-lisp (thread tag form-string) + (let ((ok nil) + (value nil) + (error nil) + (c (sly-connection))) + (unwind-protect + (condition-case err + (progn + (sly-check-eval-in-emacs-enabled) + (setq value (eval (read form-string) t)) + (sly-check-eval-in-emacs-result value) + (setq ok t)) + ((debug error) + (setq error err))) + (let ((result (cond (ok `(:ok ,value)) + (error `(:error ,(symbol-name (car error)) + . ,(mapcar #'prin1-to-string + (cdr error)))) + (t `(:abort))))) + (sly-dispatch-event `(:emacs-return ,thread ,tag ,result) c))))) + +(defun sly-check-eval-in-emacs-result (x) + "Raise an error if X can't be marshaled." + (or (stringp x) + (memq x '(nil t)) + (integerp x) + (keywordp x) + (and (consp x) + (let ((l x)) + (while (consp l) + (sly-check-eval-in-emacs-result (car x)) + (setq l (cdr l))) + (sly-check-eval-in-emacs-result l))) + (error "Non-serializable return value: %S" x))) + +(defun sly-check-eval-in-emacs-enabled () + "Raise an error if `sly-enable-evaluate-in-emacs' isn't true." + (unless sly-enable-evaluate-in-emacs + (error (concat "sly-eval-in-emacs disabled for security." + "Set sly-enable-evaluate-in-emacs true to enable it.")))) + + +;;;; `ED' + +(defvar sly-ed-frame nil + "The frame used by `sly-ed'.") + +(defcustom sly-ed-use-dedicated-frame nil + "*When non-nil, `sly-ed' will create and reuse a dedicated frame." + :type 'boolean + :group 'sly-mode) + +(cl-defun sly-ed (what ) + "Edit WHAT. + +WHAT can be: + A filename (string), + A list (:filename FILENAME &key LINE COLUMN POSITION), + A function name (:function-name STRING) + nil. + +This is for use in the implementation of COMMON-LISP:ED." + (when sly-ed-use-dedicated-frame + (unless (and sly-ed-frame (frame-live-p sly-ed-frame)) + (setq sly-ed-frame (make-frame))) + (select-frame sly-ed-frame)) + (raise-frame) + (when what + (sly-dcase what + ((:filename file &key line column position bytep) + (find-file (sly-from-lisp-filename file)) + (when line (sly-goto-line line)) + (when column (move-to-column column)) + (when position + (goto-char (if bytep + (byte-to-position position) + position)))) + ((:function-name name) + (sly-edit-definition name))))) + +(defun sly-goto-line (line-number) + "Move to line LINE-NUMBER (1-based). +This is similar to `goto-line' but without pushing the mark and +the display stuff that we neither need nor want." + (cl-assert (= (buffer-size) (- (point-max) (point-min))) () + "sly-goto-line in narrowed buffer") + (goto-char (point-min)) + (forward-line (1- line-number))) + +(defun sly-remote-y-or-n-p (thread tag question) + (sly-dispatch-event `(:emacs-return ,thread ,tag ,(sly-y-or-n-p question)))) + +(defun sly-read-from-minibuffer-for-slynk (thread tag prompt initial-value) + (let ((answer (condition-case nil + (sly-read-from-minibuffer prompt initial-value t) + (quit nil)))) + (sly-dispatch-event `(:emacs-return ,thread ,tag ,answer)))) + +;;;; Interactive evaluation. + +(defun sly-interactive-eval (string) + "Read and evaluate STRING and print value in minibuffer. + +A prefix argument(`C-u') inserts the result into the current +buffer. A negative prefix argument (`M--') will sends it to the +kill ring." + (interactive (list (sly-read-from-minibuffer "SLY Eval: "))) + (cl-case current-prefix-arg + ((nil) + (sly-eval-with-transcript `(slynk:interactive-eval ,string))) + ((-) + (sly-eval-save string)) + (t + (sly-eval-print string)))) + +(defvar sly-transcript-start-hook nil + "Hook run before start an evalution.") +(defvar sly-transcript-stop-hook nil + "Hook run after finishing a evalution.") + +(defun sly-display-eval-result (value) + ;; Use `message', not `sly-message' + (with-temp-buffer + (insert value) + (goto-char (point-min)) + (end-of-line 1) + (if (or (< (1+ (point)) (point-max)) + (>= (- (point) (point-min)) (frame-width))) + (sly-show-description value (sly-current-package)) + (message "=> %s" value)))) + +(defun sly-eval-with-transcript (form) + "Eval FORM in Lisp. Display output, if any." + (run-hooks 'sly-transcript-start-hook) + (sly-rex () (form) + ((:ok value) + (run-hooks 'sly-transcript-stop-hook) + (sly-display-eval-result value)) + ((:abort condition) + (run-hooks 'sly-transcript-stop-hook) + (sly-message "Evaluation aborted on %s." condition)))) + +(defun sly-eval-print (string) + "Eval STRING in Lisp; insert any output and the result at point." + (sly-eval-async `(slynk:eval-and-grab-output ,string) + (lambda (result) + (cl-destructuring-bind (output value) result + (push-mark) + (let* ((start (point)) + (ppss (syntax-ppss)) + (string-or-comment-p (or (nth 3 ppss) (nth 4 ppss)))) + (insert output (if string-or-comment-p + "" + " => ") value) + (unless string-or-comment-p + (comment-region start (point) 1))))))) + +(defun sly-eval-save (string) + "Evaluate STRING in Lisp and save the result in the kill ring." + (sly-eval-async `(slynk:eval-and-grab-output ,string) + (lambda (result) + (cl-destructuring-bind (output value) result + (let ((string (concat output value))) + (kill-new string) + (sly-message "Evaluation finished; pushed result to kill ring.")))))) + +(defun sly-eval-describe (form) + "Evaluate FORM in Lisp and display the result in a new buffer." + (sly-eval-async form (sly-rcurry #'sly-show-description + (sly-current-package)))) + +(defvar sly-description-autofocus nil + "If non-nil select description windows on display.") + +(defun sly-show-description (string package) + ;; So we can have one description buffer open per connection. Useful + ;; for comparing the output of DISASSEMBLE across implementations. + ;; FIXME: could easily be achieved with M-x rename-buffer + (let ((bufname (sly-buffer-name :description))) + (sly-with-popup-buffer (bufname :package package + :connection t + :select sly-description-autofocus + :mode 'lisp-mode) + (sly-popup-buffer-mode) + (princ string) + (goto-char (point-min))))) + +(defun sly-last-expression () + (buffer-substring-no-properties + (save-excursion (backward-sexp) (point)) + (point))) + +(defun sly-eval-last-expression () + "Evaluate the expression preceding point." + (interactive) + (sly-interactive-eval (sly-last-expression))) + +(defun sly-eval-defun () + "Evaluate the current toplevel form. +Use `sly-re-evaluate-defvar' if the from starts with '(defvar'" + (interactive) + (let ((form (apply #'buffer-substring-no-properties + (sly-region-for-defun-at-point)))) + (cond ((string-match "^(defvar " form) + (sly-re-evaluate-defvar form)) + (t + (sly-interactive-eval form))))) + +(defun sly-eval-region (start end) + "Evaluate region." + (interactive "r") + (sly-eval-with-transcript + `(slynk:interactive-eval-region + ,(buffer-substring-no-properties start end)))) + +(defun sly-pprint-eval-region (start end) + "Evaluate region; pprint the value in a buffer." + (interactive "r") + (sly-eval-describe + `(slynk:pprint-eval + ,(buffer-substring-no-properties start end)))) + +(defun sly-eval-buffer () + "Evaluate the current buffer. +The value is printed in the echo area." + (interactive) + (sly-eval-region (point-min) (point-max))) + +(defun sly-re-evaluate-defvar (form) + "Force the re-evaluaton of the defvar form before point. + +First make the variable unbound, then evaluate the entire form." + (interactive (list (sly-last-expression))) + (sly-eval-with-transcript `(slynk:re-evaluate-defvar ,form))) + +(defun sly-pprint-eval-last-expression () + "Evaluate the form before point; pprint the value in a buffer." + (interactive) + (sly-eval-describe `(slynk:pprint-eval ,(sly-last-expression)))) + +(defun sly-eval-print-last-expression (string) + "Evaluate sexp before point; print value into the current buffer" + (interactive (list (sly-last-expression))) + (insert "\n") + (sly-eval-print string)) + +;;;; Edit Lisp value +;;; +(defun sly-edit-value (form-string) + "\\<sly-edit-value-mode-map>\ +Edit the value of a setf'able form in a new buffer. +The value is inserted into a temporary buffer for editing and then set +in Lisp when committed with \\[sly-edit-value-commit]." + (interactive + (list (sly-read-from-minibuffer "Edit value (evaluated): " + (sly-sexp-at-point)))) + (sly-eval-async `(slynk:value-for-editing ,form-string) + (let ((form-string form-string) + (package (sly-current-package))) + (lambda (result) + (sly-edit-value-callback form-string result + package))))) + +(make-variable-buffer-local + (defvar sly-edit-form-string nil + "The form being edited by `sly-edit-value'.")) + +(define-minor-mode sly-edit-value-mode + "Mode for editing a Lisp value." + nil + " Edit-Value" + '(("\C-c\C-c" . sly-edit-value-commit))) + +(defun sly-edit-value-callback (form-string current-value package) + (let* ((name (generate-new-buffer-name (format "*Edit %s*" form-string))) + (buffer (sly-with-popup-buffer (name :package package + :connection t + :select t + :mode 'lisp-mode) + (sly-mode 1) + (sly-edit-value-mode 1) + (setq sly-edit-form-string form-string) + (insert current-value) + (current-buffer)))) + (with-current-buffer buffer + (setq buffer-read-only nil) + (sly-message "Type C-c C-c when done")))) + +(defun sly-edit-value-commit () + "Commit the edited value to the Lisp image. +\\(See `sly-edit-value'.)" + (interactive) + (if (null sly-edit-form-string) + (error "Not editing a value.") + (let ((value (buffer-substring-no-properties (point-min) (point-max)))) + (let ((buffer (current-buffer))) + (sly-eval-async `(slynk:commit-edited-value ,sly-edit-form-string + ,value) + (lambda (_) + (with-current-buffer buffer + (quit-window t)))))))) + +;;;; Tracing + +(defun sly-untrace-all () + "Untrace all functions." + (interactive) + (sly-eval `(slynk:untrace-all))) + +(defun sly-toggle-trace-fdefinition (spec) + "Toggle trace." + (interactive (list (sly-read-from-minibuffer + "(Un)trace: " (sly-symbol-at-point)))) + (sly-message "%s" (sly-eval `(slynk:slynk-toggle-trace ,spec)))) + + + +(defun sly-disassemble-symbol (symbol-name) + "Display the disassembly for SYMBOL-NAME." + (interactive (list (sly-read-symbol-name "Disassemble: "))) + (sly-eval-describe `(slynk:disassemble-form ,(concat "'" symbol-name)))) + +(defun sly-undefine-function (symbol-name) + "Unbind the function slot of SYMBOL-NAME." + (interactive (list (sly-read-symbol-name "fmakunbound: " t))) + (sly-eval-async `(slynk:undefine-function ,symbol-name) + (lambda (result) (sly-message "%s" result)))) + +(defun sly-unintern-symbol (symbol-name package) + "Unintern the symbol given with SYMBOL-NAME PACKAGE." + (interactive (list (sly-read-symbol-name "Unintern symbol: " t) + (sly-read-package-name "from package: " + (sly-current-package)))) + (sly-eval-async `(slynk:unintern-symbol ,symbol-name ,package) + (lambda (result) (sly-message "%s" result)))) + +(defun sly-delete-package (package-name) + "Delete the package with name PACKAGE-NAME." + (interactive (list (sly-read-package-name "Delete package: " + (sly-current-package)))) + (sly-eval-async `(cl:delete-package + (slynk::guess-package ,package-name)))) + +(defun sly-load-file (filename) + "Load the Lisp file FILENAME." + (interactive (list + (read-file-name "[sly] Load file: " nil nil + nil (if (buffer-file-name) + (file-name-nondirectory + (buffer-file-name)))))) + (let ((lisp-filename (sly-to-lisp-filename (expand-file-name filename)))) + (sly-eval-with-transcript `(slynk:load-file ,lisp-filename)))) + +(defvar sly-change-directory-hooks nil + "Hook run by `sly-change-directory'. +The functions are called with the new (absolute) directory.") + +(defun sly-change-directory (directory) + "Make DIRECTORY become Lisp's current directory. +Return whatever slynk:set-default-directory returns." + (let ((dir (expand-file-name directory))) + (prog1 (sly-eval `(slynk:set-default-directory + (slynk-backend:filename-to-pathname + ,(sly-to-lisp-filename dir)))) + (sly-with-connection-buffer nil (cd-absolute dir)) + (run-hook-with-args 'sly-change-directory-hooks dir)))) + +(defun sly-cd (directory) + "Make DIRECTORY become Lisp's current directory. +Return whatever slynk:set-default-directory returns." + (interactive (list (read-directory-name "[sly] Directory: " nil nil t))) + (sly-message "default-directory: %s" (sly-change-directory directory))) + +(defun sly-pwd () + "Show Lisp's default directory." + (interactive) + (sly-message "Directory %s" (sly-eval `(slynk:default-directory)))) + + +;;;; Documentation + +(defvar sly-documentation-lookup-function + 'sly-hyperspec-lookup) + +(defun sly-documentation-lookup () + "Generalized documentation lookup. Defaults to hyperspec lookup." + (interactive) + (call-interactively sly-documentation-lookup-function)) + +;;;###autoload +(defun sly-hyperspec-lookup (symbol-name) + "A wrapper for `hyperspec-lookup'" + (interactive (list (common-lisp-hyperspec-read-symbol-name + (sly-symbol-at-point)))) + (hyperspec-lookup symbol-name)) + +(defun sly-describe-symbol (symbol-name) + "Describe the symbol at point." + (interactive (list (sly-read-symbol-name "Describe symbol: "))) + (when (not symbol-name) + (error "No symbol given")) + (sly-eval-describe `(slynk:describe-symbol ,symbol-name))) + +(defun sly-documentation (symbol-name) + "Display function- or symbol-documentation for SYMBOL-NAME." + (interactive (list (sly-read-symbol-name "Documentation for symbol: "))) + (when (not symbol-name) + (error "No symbol given")) + (sly-eval-describe + `(slynk:documentation-symbol ,symbol-name))) + +(defun sly-describe-function (symbol-name) + (interactive (list (sly-read-symbol-name "Describe symbol's function: "))) + (when (not symbol-name) + (error "No symbol given")) + (sly-eval-describe `(slynk:describe-function ,symbol-name))) + +(defface sly-apropos-symbol + '((t (:inherit sly-part-button-face))) + "Face for the symbol name in Apropos output." + :group 'sly) + +(defface sly-apropos-label + '((t (:inherit italic))) + "Face for label (`Function', `Variable' ...) in Apropos output." + :group 'sly) + +(defun sly-apropos-summary (string case-sensitive-p package only-external-p) + "Return a short description for the performed apropos search." + (concat (if case-sensitive-p "Case-sensitive " "") + "Apropos for " + (format "%S" string) + (if package (format " in package %S" package) "") + (if only-external-p " (external symbols only)" ""))) + +(defun sly-apropos (string &optional only-external-p package + case-sensitive-p) + "Show all bound symbols whose names match STRING. With prefix +arg, you're interactively asked for parameters of the search. +With M-- (negative) prefix arg, prompt for package only. " + (interactive + (cond ((eq '- current-prefix-arg) + (list (sly-read-from-minibuffer "Apropos external symbols: ") + t + (sly-read-package-name "Package (blank for all): " + nil 'allow-blank) + nil)) + (current-prefix-arg + (list (sly-read-from-minibuffer "Apropos: ") + (sly-y-or-n-p "External symbols only? ") + (sly-read-package-name "Package (blank for all): " + nil 'allow-blank) + (sly-y-or-n-p "Case-sensitive? "))) + (t + (list (sly-read-from-minibuffer "Apropos external symbols: ") t nil nil)))) + (sly-eval-async + `(slynk-apropos:apropos-list-for-emacs ,string ,only-external-p + ,case-sensitive-p ',package) + (sly-rcurry #'sly-show-apropos string package + (sly-apropos-summary string case-sensitive-p + package only-external-p)))) + +(defun sly-apropos-all () + "Shortcut for (sly-apropos <string> nil nil)" + (interactive) + (sly-apropos (sly-read-from-minibuffer "Apropos all symbols: ") nil nil)) + +(defun sly-apropos-package (package &optional internal) + "Show apropos listing for symbols in PACKAGE. +With prefix argument include internal symbols." + (interactive (list (let ((pkg (sly-read-package-name "Package: "))) + (if (string= pkg "") (sly-current-package) pkg)) + current-prefix-arg)) + (sly-apropos "" (not internal) package)) + +(defvar sly-apropos-mode-map + (let ((map (make-sparse-keymap))) + map)) + +(define-derived-mode sly-apropos-mode apropos-mode "SLY-Apropos" + "SLY Apropos Mode + +TODO" + (sly-mode)) + +(defun sly-show-apropos (plists string package summary) + (cond ((null plists) + (sly-message "No apropos matches for %S" string)) + (t + (sly-with-popup-buffer ((sly-buffer-name :apropos + :connection t) + :package package :connection t + :mode 'sly-apropos-mode) + (if (boundp 'header-line-format) + (setq header-line-format summary) + (insert summary "\n\n")) + (sly-set-truncate-lines) + (sly-print-apropos plists (not package)) + (set-syntax-table lisp-mode-syntax-table) + (goto-char (point-min)))))) + +(define-button-type 'sly-apropos-symbol :supertype 'sly-part + 'face nil + 'action 'sly-button-goto-source ;default action + 'sly-button-inspect + #'(lambda (name _type) + (sly-inspect (format "(quote %s)" name))) + 'sly-button-goto-source + #'(lambda (name _type) + (sly-edit-definition name 'window)) + 'sly-button-describe + #'(lambda (name _type) + (sly-eval-describe `(slynk:describe-symbol ,name)))) + +(defun sly--package-designator-prefix (designator) + (unless (listp designator) + (error "unknown designator type")) + (concat (cadr designator) + (if (cl-caddr designator) ":" "::"))) + +(defun sly-apropos-designator-string (designator) + (concat (sly--package-designator-prefix designator) + (car designator))) + +(defun sly-apropos-insert-symbol (designator item bounds package-designator-searched-p) + (let ((label (sly-apropos-designator-string designator))) + (setq label + (sly--make-text-button label nil + 'face 'sly-apropos-symbol + 'part-args (list item nil) + 'part-label "Symbol" + :type 'sly-apropos-symbol)) + (cl-loop + with offset = (if package-designator-searched-p + 0 + (length (sly--package-designator-prefix designator))) + for bound in bounds + for (start end) = (if (listp bound) bound (list bound (1+ bound))) + do + (put-text-property (+ start offset) (+ end offset) 'face 'highlight label) + finally (insert label)))) + +(defun sly-print-apropos (plists package-designator-searched-p) + (cl-loop + for plist in plists + for designator = (plist-get plist :designator) + for item = (substring-no-properties + (sly-apropos-designator-string designator)) + do + (sly-apropos-insert-symbol designator item (plist-get plist :bounds) package-designator-searched-p) + (terpri) + (cl-loop for (prop value) on plist by #'cddr + for start = (point) + unless (memq prop '(:designator + :package + :bounds)) + do + (let ((namespace (upcase-initials + (replace-regexp-in-string + "-" " " (substring (symbol-name prop) 1))))) + (princ " ") + (insert (propertize namespace + 'face 'sly-apropos-label)) + (princ ": ") + (princ (cond ((and value + (not (eq value :not-documented))) + value) + (t + "(not documented)"))) + (add-text-properties + start (point) + (list 'action 'sly-button-describe + 'sly-button-describe + #'(lambda (name type) + (sly-eval-describe `(slynk:describe-definition-for-emacs ,name + ,type))) + 'part-args (list item prop) + 'button t 'apropos-label namespace)) + (terpri))))) + +(defun sly-apropos-describe (name type) + (sly-eval-describe `(slynk:describe-definition-for-emacs ,name ,type))) + +(require 'info) +(defun sly-info--file () + (or (cl-some (lambda (subdir) + (cl-flet ((existing-file + (name) (let* ((path (expand-file-name subdir sly-path)) + (probe (expand-file-name name path))) + (and (file-exists-p probe) probe)))) + (or (existing-file "sly.info") + (existing-file "sly.info.gz")))) + (append '("doc" ".") Info-directory-list)) + (sly-error + "No sly.info, run `make -C doc sly.info' from a SLY git checkout"))) + +(require 'info) + +(defvar sly-info--cached-node-names nil) + +(defun sly-info--node-names (file) + (or sly-info--cached-node-names + (setq sly-info--cached-node-names + (with-temp-buffer + (info file (current-buffer)) + (ignore-errors + (Info-build-node-completions)))))) + +;;;###autoload +(defun sly-info (file &optional node) + "Read SLY manual" + (interactive + (let ((file (sly-info--file))) + (list file + (completing-read "Manual node? (`Top' to read the whole manual): " + (remove '("*") (sly-info--node-names file)) + nil t)))) + (info (if node (format "(%s)%s" file node) file))) + + +;;;; XREF: cross-referencing + +(defvar sly-xref-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "RET") 'sly-xref-goto) + (define-key map (kbd "SPC") 'sly-xref-show) + (define-key map (kbd "n") 'sly-xref-next-line) + (define-key map (kbd "p") 'sly-xref-prev-line) + (define-key map (kbd ".") 'sly-xref-next-line) + (define-key map (kbd ",") 'sly-xref-prev-line) + (define-key map (kbd "C-c C-c") 'sly-recompile-xref) + (define-key map (kbd "C-c C-k") 'sly-recompile-all-xrefs) + + (define-key map (kbd "q") 'quit-window) + (set-keymap-parent map button-buffer-map) + + map)) + +(define-derived-mode sly-xref-mode lisp-mode "Xref" + "sly-xref-mode: Major mode for cross-referencing. +\\<sly-xref-mode-map>\ +The most important commands: +\\[sly-xref-show] - Display referenced source and keep xref window. +\\[sly-xref-goto] - Jump to referenced source and dismiss xref window. + +\\{sly-xref-mode-map}" + (setq font-lock-defaults nil) + (setq delayed-mode-hooks nil) + (setq buffer-read-only t) + (sly-mode)) + +(defun sly-next-line/not-add-newlines () + (interactive) + (let ((next-line-add-newlines nil)) + (forward-line 1))) + + +;;;;; XREF results buffer and window management + +(cl-defmacro sly-with-xref-buffer ((_xref-type _symbol &optional package) + &body body) + "Execute BODY in a xref buffer, then show that buffer." + (declare (indent 1)) + `(sly-with-popup-buffer ((sly-buffer-name :xref + :connection t) + :package ,package + :connection t + :select t + :mode 'sly-xref-mode) + (sly-set-truncate-lines) + ,@body)) + +;; TODO: Have this button support more options, not just "show source" +;; and "goto-source" +(define-button-type 'sly-xref :supertype 'sly-part + 'action 'sly-button-goto-source ;default action + 'mouse-action 'sly-button-goto-source ;default action + 'sly-button-show-source #'(lambda (location) + (sly-xref--show-location location)) + 'sly-button-goto-source #'(lambda (location) + (sly--pop-to-source-location location 'sly-xref))) + +(defun sly-xref-button (label location) + (sly--make-text-button label nil + :type 'sly-xref + 'part-args (list location) + 'part-label "Location")) + +(defun sly-insert-xrefs (xref-alist) + "Insert XREF-ALIST in the current-buffer. +XREF-ALIST is of the form ((GROUP . ((LABEL LOCATION) ...)) ...). +GROUP and LABEL are for decoration purposes. LOCATION is a +source-location." + (cl-loop for (group . refs) in xref-alist do + (sly-insert-propertized '(face bold) group "\n") + (cl-loop for (label location) in refs + for start = (point) + do + (insert + " " + (sly-xref-button (sly-one-line-ify label) location) + "\n") + (add-text-properties start (point) (list 'sly-location location)))) + ;; Remove the final newline to prevent accidental window-scrolling + (backward-delete-char 1)) + +(defun sly-xref-next-line (arg) + (interactive "p") + (let ((button (forward-button arg))) + (when button (sly-button-show-source button)))) + +(defun sly-xref-prev-line (arg) + (interactive "p") + (sly-xref-next-line (- arg))) + +(defun sly-xref--show-location (loc) + (cl-ecase (car loc) + (:location (sly--display-source-location loc)) + (:error (sly-message "%s" (cadr loc))) + ((nil)))) + +(defun sly-xref--show-results (xrefs _type symbol package &optional method) + "Maybe show a buffer listing the cross references XREFS. +METHOD is used to set `sly-xref--popup-method', which see." + (cond ((null xrefs) + (sly-message "No references found for %s." symbol) + nil) + (t + (sly-with-xref-buffer (_type _symbol package) + (sly-insert-xrefs xrefs) + (setq sly-xref--popup-method method) + (goto-char (point-min)) + (current-buffer))))) + + +;;;;; XREF commands + +(defun sly-who-calls (symbol) + "Show all known callers of the function SYMBOL. +This is implemented with special compiler support, see `sly-list-callers' for a +portable alternative." + (interactive (list (sly-read-symbol-name "Who calls: " t))) + (sly-xref :calls symbol)) + +(defun sly-calls-who (symbol) + "Show all known functions called by the function SYMBOL. +This is implemented with special compiler support and may not be supported by +all implementations. +See `sly-list-callees' for a portable alternative." + (interactive (list (sly-read-symbol-name "Who calls: " t))) + (sly-xref :calls-who symbol)) + +(defun sly-who-references (symbol) + "Show all known referrers of the global variable SYMBOL." + (interactive (list (sly-read-symbol-name "Who references: " t))) + (sly-xref :references symbol)) + +(defun sly-who-binds (symbol) + "Show all known binders of the global variable SYMBOL." + (interactive (list (sly-read-symbol-name "Who binds: " t))) + (sly-xref :binds symbol)) + +(defun sly-who-sets (symbol) + "Show all known setters of the global variable SYMBOL." + (interactive (list (sly-read-symbol-name "Who sets: " t))) + (sly-xref :sets symbol)) + +(defun sly-who-macroexpands (symbol) + "Show all known expanders of the macro SYMBOL." + (interactive (list (sly-read-symbol-name "Who macroexpands: " t))) + (sly-xref :macroexpands symbol)) + +(defun sly-who-specializes (symbol) + "Show all known methods specialized on class SYMBOL." + (interactive (list (sly-read-symbol-name "Who specializes: " t))) + (sly-xref :specializes symbol)) + +(defun sly-list-callers (symbol-name) + "List the callers of SYMBOL-NAME in a xref window. +See `sly-who-calls' for an implementation-specific alternative." + (interactive (list (sly-read-symbol-name "List callers: "))) + (sly-xref :callers symbol-name)) + +(defun sly-list-callees (symbol-name) + "List the callees of SYMBOL-NAME in a xref window. +See `sly-calls-who' for an implementation-specific alternative." + (interactive (list (sly-read-symbol-name "List callees: "))) + (sly-xref :callees symbol-name)) + +(defun sly-xref (type symbol &optional continuation) + "Make an XREF request to Lisp." + (sly-eval-async + `(slynk:xref ',type ',symbol) + (sly-rcurry (lambda (result type symbol package cont) + (and (sly-xref-implemented-p type result) + (let* ((file-alist (cadr (sly-analyze-xrefs result)))) + (funcall (or cont 'sly-xref--show-results) + file-alist type symbol package)))) + type + symbol + (sly-current-package) + continuation))) + +(defun sly-xref-implemented-p (type xrefs) + "Tell if xref TYPE is available according to XREFS." + (cond ((eq xrefs :not-implemented) + (sly-display-oneliner "%s is not implemented yet on %s." + (sly-xref-type type) + (sly-lisp-implementation-name)) + nil) + (t t))) + +(defun sly-xref-type (type) + "Return a human readable version of xref TYPE." + (format "who-%s" (sly-cl-symbol-name type))) + +(defun sly-xref--get-xrefs (types symbol &optional continuation) + "Make multiple XREF requests at once." + (sly-eval-async + `(slynk:xrefs ',types ',symbol) + #'(lambda (result) + (funcall (or continuation + #'sly-xref--show-results) + (cl-loop for (key . val) in result + collect (cons (sly-xref-type key) val)) + types symbol (sly-current-package))))) + + +;;;;; XREF navigation + +(defun sly-xref-location-at-point () + (save-excursion + ;; When the end of the last line is at (point-max) we can't find + ;; the text property there. Going to bol avoids this problem. + (beginning-of-line 1) + (or (get-text-property (point) 'sly-location) + (error "No reference at point.")))) + +(defun sly-xref-dspec-at-point () + (save-excursion + (beginning-of-line 1) + (with-syntax-table lisp-mode-syntax-table + (forward-sexp) ; skip initial whitespaces + (backward-sexp) + (sly-sexp-at-point)))) + +(defun sly-all-xrefs () + (let ((xrefs nil)) + (save-excursion + (goto-char (point-min)) + (while (zerop (forward-line 1)) + (sly--when-let (loc (get-text-property (point) 'sly-location)) + (let* ((dspec (sly-xref-dspec-at-point)) + (xref (make-sly-xref :dspec dspec :location loc))) + (push xref xrefs))))) + (nreverse xrefs))) + +(defun sly-xref-goto () + "Goto the cross-referenced location at point." + (interactive) + (sly--pop-to-source-location (sly-xref-location-at-point) 'sly-xref)) + +(defun sly-xref-show () + "Display the xref at point in the other window." + (interactive) + (sly--display-source-location (sly-xref-location-at-point))) + +(defun sly-search-property (prop &optional backward prop-value-fn) + "Search the next text range where PROP is non-nil. +Return the value of PROP. +If BACKWARD is non-nil, search backward. +If PROP-VALUE-FN is non-nil use it to extract PROP's value." + (let ((next-candidate (if backward + #'previous-single-char-property-change + #'next-single-char-property-change)) + (prop-value-fn (or prop-value-fn + (lambda () + (get-text-property (point) prop)))) + (start (point)) + (prop-value)) + (while (progn + (goto-char (funcall next-candidate (point) prop)) + (not (or (setq prop-value (funcall prop-value-fn)) + (eobp) + (bobp))))) + (cond (prop-value) + (t (goto-char start) nil)))) + +(defun sly-recompile-xref (&optional raw-prefix-arg) + "Recompile definition at point. +Uses prefix arguments like `sly-compile-defun'." + (interactive "P") + (let ((sly-compilation-policy (sly-compute-policy raw-prefix-arg))) + (let ((location (sly-xref-location-at-point)) + (dspec (sly-xref-dspec-at-point))) + (sly-recompile-locations + (list location) + (sly-rcurry #'sly-xref-recompilation-cont + (list dspec) (current-buffer)))))) + +(defun sly-recompile-all-xrefs (&optional raw-prefix-arg) + "Recompile all definitions. +Uses prefix arguments like `sly-compile-defun'." + (interactive "P") + (let ((sly-compilation-policy (sly-compute-policy raw-prefix-arg))) + (let ((dspecs) (locations)) + (dolist (xref (sly-all-xrefs)) + (when (sly-xref-has-location-p xref) + (push (sly-xref.dspec xref) dspecs) + (push (sly-xref.location xref) locations))) + (sly-recompile-locations + locations + (sly-rcurry #'sly-xref-recompilation-cont + dspecs (current-buffer)))))) + +(defun sly-xref-recompilation-cont (results dspecs buffer) + ;; Extreme long-windedness to insert status of recompilation; + ;; sometimes Elisp resembles more of an Ewwlisp. + + ;; FIXME: Should probably throw out the whole recompilation cruft + ;; anyway. -- helmut + ;; TODO: next iteration of fixme cleanup this is going in a contrib -- jt + (with-current-buffer buffer + (sly-compilation-finished (sly-aggregate-compilation-results results) + nil) + (save-excursion + (sly-xref-insert-recompilation-flags + dspecs (cl-loop for r in results collect + (or (sly-compilation-result.successp r) + (and (sly-compilation-result.notes r) + :complained))))))) + +(defun sly-aggregate-compilation-results (results) + `(:compilation-result + ,(cl-reduce #'append (mapcar #'sly-compilation-result.notes results)) + ,(cl-every #'sly-compilation-result.successp results) + ,(cl-reduce #'+ (mapcar #'sly-compilation-result.duration results)))) + +(defun sly-xref-insert-recompilation-flags (dspecs compilation-results) + (let* ((buffer-read-only nil) + (max-column (sly-column-max))) + (goto-char (point-min)) + (cl-loop for dspec in dspecs + for result in compilation-results + do (save-excursion + (cl-loop for dspec2 = (progn (search-forward dspec) + (sly-xref-dspec-at-point)) + until (equal dspec2 dspec)) + (end-of-line) ; skip old status information. + (insert-char ?\ (1+ (- max-column (current-column)))) + (insert (format "[%s]" + (cl-case result + ((t) :success) + ((nil) :failure) + (t result)))))))) + + +;;;; Macroexpansion + +(defvar sly-macroexpansion-minor-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "g") 'sly-macroexpand-again) + (define-key map (kbd "a") 'sly-macroexpand-all-inplace) + (define-key map (kbd "q") 'quit-window) + (define-key map [remap sly-macroexpand-1] 'sly-macroexpand-1-inplace) + (define-key map [remap sly-macroexpand-all] 'sly-macroexpand-all-inplace) + (define-key map [remap sly-compiler-macroexpand-1] 'sly-compiler-macroexpand-1-inplace) + (define-key map [remap sly-expand-1] 'sly-expand-1-inplace) + (define-key map [remap undo] 'sly-macroexpand-undo) + map)) + +(define-minor-mode sly-macroexpansion-minor-mode + "SLY mode for macroexpansion" + nil + " Macroexpand" + nil + (read-only-mode 1)) + +(defun sly-macroexpand-undo (&optional arg) + (interactive) + ;; Emacs 22.x introduced `undo-only' which + ;; works by binding `undo-no-redo' to t. We do + ;; it this way so we don't break prior Emacs + ;; versions. + (cl-macrolet ((undo-only (arg) `(let ((undo-no-redo t)) (undo ,arg)))) + (let ((inhibit-read-only t)) + (when (fboundp 'sly-remove-edits) + (sly-remove-edits (point-min) (point-max))) + (undo-only arg)))) + +(defvar sly-eval-macroexpand-expression nil + "Specifies the last macroexpansion preformed. +This variable specifies both what was expanded and how.") + +(defun sly-eval-macroexpand (expander &optional string) + (let ((string (or string + (sly-sexp-at-point 'interactive)))) + (setq sly-eval-macroexpand-expression `(,expander ,string)) + (sly-eval-async sly-eval-macroexpand-expression + #'sly-initialize-macroexpansion-buffer))) + +(defun sly-macroexpand-again () + "Reperform the last macroexpansion." + (interactive) + (sly-eval-async sly-eval-macroexpand-expression + (sly-rcurry #'sly-initialize-macroexpansion-buffer + (current-buffer)))) + +(defun sly-initialize-macroexpansion-buffer (expansion &optional buffer) + (pop-to-buffer (or buffer (sly-create-macroexpansion-buffer))) + (setq buffer-undo-list nil) ; Get rid of undo information from + ; previous expansions. + (let ((inhibit-read-only t) + (buffer-undo-list t)) ; Make the initial insertion not be undoable. + (erase-buffer) + (insert expansion) + (goto-char (point-min)) + (if (fboundp 'font-lock-ensure) + (font-lock-ensure) + (with-no-warnings (font-lock-fontify-buffer))))) + +(defun sly-create-macroexpansion-buffer () + (let ((name (sly-buffer-name :macroexpansion))) + (sly-with-popup-buffer (name :package t :connection t + :mode 'lisp-mode) + (sly-macroexpansion-minor-mode 1) + (setq font-lock-keywords-case-fold-search t) + (current-buffer)))) + +(defun sly-eval-macroexpand-inplace (expander) + "Substitute the sexp at point with its macroexpansion. + +NB: Does not affect sly-eval-macroexpand-expression" + (interactive) + (let* ((bounds (sly-bounds-of-sexp-at-point 'interactive))) + (let* ((start (copy-marker (car bounds))) + (end (copy-marker (cdr bounds))) + (point (point)) + (buffer (current-buffer))) + (sly-eval-async + `(,expander ,(buffer-substring-no-properties start end)) + (lambda (expansion) + (with-current-buffer buffer + (let ((buffer-read-only nil)) + (when (fboundp 'sly-remove-edits) + (sly-remove-edits (point-min) (point-max))) + (goto-char start) + (delete-region start end) + (sly-insert-indented expansion) + (goto-char point)))))))) + +(defun sly-macroexpand-1 (&optional repeatedly) + "Display the macro expansion of the form at point. +The form is expanded with CL:MACROEXPAND-1 or, if a prefix +argument is given, with CL:MACROEXPAND." + (interactive "P") + (sly-eval-macroexpand + (if repeatedly 'slynk:slynk-macroexpand 'slynk:slynk-macroexpand-1))) + +(defun sly-macroexpand-1-inplace (&optional repeatedly) + (interactive "P") + (sly-eval-macroexpand-inplace + (if repeatedly 'slynk:slynk-macroexpand 'slynk:slynk-macroexpand-1))) + +(defun sly-macroexpand-all (&optional just-one) + "Display the recursively macro expanded sexp at point. +With optional JUST-ONE prefix arg, use CL:MACROEXPAND-1." + (interactive "P") + (sly-eval-macroexpand (if just-one + 'slynk:slynk-macroexpand-1 + 'slynk:slynk-macroexpand-all))) + +(defun sly-macroexpand-all-inplace () + "Display the recursively macro expanded sexp at point." + (interactive) + (sly-eval-macroexpand-inplace 'slynk:slynk-macroexpand-all)) + +(defun sly-compiler-macroexpand-1 (&optional repeatedly) + "Display the compiler-macro expansion of sexp at point." + (interactive "P") + (sly-eval-macroexpand + (if repeatedly + 'slynk:slynk-compiler-macroexpand + 'slynk:slynk-compiler-macroexpand-1))) + +(defun sly-compiler-macroexpand-1-inplace (&optional repeatedly) + "Display the compiler-macro expansion of sexp at point." + (interactive "P") + (sly-eval-macroexpand-inplace + (if repeatedly + 'slynk:slynk-compiler-macroexpand + 'slynk:slynk-compiler-macroexpand-1))) + +(defun sly-expand-1 (&optional repeatedly) + "Display the macro expansion of the form at point. + +The form is expanded with CL:MACROEXPAND-1 or, if a prefix +argument is given, with CL:MACROEXPAND. + +Contrary to `sly-macroexpand-1', if the form denotes a compiler +macro, SLYNK-BACKEND:COMPILER-MACROEXPAND or +SLYNK-BACKEND:COMPILER-MACROEXPAND-1 are used instead." + (interactive "P") + (sly-eval-macroexpand + (if repeatedly + 'slynk:slynk-expand + 'slynk:slynk-expand-1))) + +(defun sly-expand-1-inplace (&optional repeatedly) + "Display the macro expansion of the form at point. +The form is expanded with CL:MACROEXPAND-1 or, if a prefix +argument is given, with CL:MACROEXPAND." + (interactive "P") + (sly-eval-macroexpand-inplace + (if repeatedly + 'slynk:slynk-expand + 'slynk:slynk-expand-1))) + +(defun sly-format-string-expand (&optional string) + "Expand the format-string at point and display it. +With prefix arg, or if no string at point, prompt the user for a +string to expand. +" + (interactive (list (or (and (not current-prefix-arg) + (sly-string-at-point)) + (sly-read-from-minibuffer "Expand format: " + (sly-string-at-point))))) + (sly-eval-macroexpand 'slynk:slynk-format-string-expand + string)) + + +;;;; Subprocess control + +(defun sly-interrupt () + "Interrupt Lisp." + (interactive) + (cond ((sly-use-sigint-for-interrupt) (sly-send-sigint)) + (t (sly-dispatch-event `(:emacs-interrupt ,sly-current-thread))))) + +(defun sly-quit () + (error "Not implemented properly. Use `sly-interrupt' instead.")) + +(defun sly-quit-lisp (&optional kill interactive) + "Quit lisp, kill the inferior process and associated buffers." + (interactive (list current-prefix-arg t)) + (let ((connection (if interactive + (sly-prompt-for-connection "Connection to quit: ") + (sly-current-connection)))) + (sly-quit-lisp-internal connection 'sly-quit-sentinel kill))) + +(defun sly-quit-lisp-internal (connection sentinel kill) + "Kill SLY socket connection CONNECTION. +Do this by evaluating (SLYNK:QUIT-LISP) in it, and don't wait for +it to reply as usual with other evaluations. If it's non-nil, +setup SENTINEL to run on CONNECTION when it finishes dying. If +KILL is t, and there is such a thing, also kill the inferior lisp +process associated with CONNECTION." + (let ((sly-dispatching-connection connection)) + (sly-eval-async '(slynk:quit-lisp)) + (set-process-filter connection nil) + (let ((attempt 0) + (dying-p nil)) + (set-process-sentinel + connection + (lambda (connection status) + (setq dying-p t) + (sly-message "Connection %s is dying (%s)" connection status) + (let ((inf-process (sly-inferior-process connection))) + (cond ((and kill + inf-process + (not (memq (process-status inf-process) '(exit signal)))) + (sly-message "Quitting %s: also killing the inferior process %s" + connection inf-process) + (kill-process inf-process)) + ((and kill + inf-process) + (sly-message "Quitting %s: inferior process was already dead" + connection + inf-process)) + ((and + kill + (not inf-process)) + (sly-message "Quitting %s: No inferior process to kill!" + connection + inf-process)))) + (when sentinel + (funcall sentinel connection status)))) + (sly-message + "Waiting for connection %s to die by itself..." connection) + (while (and (< (cl-incf attempt) 30) + (not dying-p)) + (sleep-for 0.1)) + (unless dying-p + (sly-message + "Connection %s didn't die by itself. Killing it." connection) + (delete-process connection))))) + +(defun sly-quit-sentinel (process _message) + (cl-assert (process-status process) 'closed) + (let* ((inferior (sly-inferior-process process)) + (inferior-buffer (if inferior (process-buffer inferior)))) + (when inferior (delete-process inferior)) + (when inferior-buffer (kill-buffer inferior-buffer)) + (sly-net-close process "Quitting lisp") + (sly-message "Connection closed."))) + + +;;;; Debugger (SLY-DB) + +(defvar sly-db-hook nil + "Hook run on entry to the debugger.") + +(defcustom sly-db-initial-restart-limit 6 + "Maximum number of restarts to display initially." + :group 'sly-debugger + :type 'integer) + + +;;;;; Local variables in the debugger buffer + +;; Small helper. +(defun sly-make-variables-buffer-local (&rest variables) + (mapcar #'make-variable-buffer-local variables)) + +(sly-make-variables-buffer-local + (defvar sly-db-condition nil + "A list (DESCRIPTION TYPE) describing the condition being debugged.") + + (defvar sly-db-restarts nil + "List of (NAME DESCRIPTION) for each available restart.") + + (defvar sly-db-level nil + "Current debug level (recursion depth) displayed in buffer.") + + (defvar sly-db-backtrace-start-marker nil + "Marker placed at the first frame of the backtrace.") + + (defvar sly-db-restart-list-start-marker nil + "Marker placed at the first restart in the restart list.") + + (defvar sly-db-continuations nil + "List of ids for pending continuation.")) + +;;;;; SLY-DB macros + +;; some macros that we need to define before the first use + +(defmacro sly-db-in-face (name string) + "Return STRING propertised with face sly-db-NAME-face." + (declare (indent 1)) + (let ((facename (intern (format "sly-db-%s-face" (symbol-name name)))) + (var (cl-gensym "string"))) + `(let ((,var ,string)) + (sly-add-face ',facename ,var) + ,var))) + + +;;;;; sly-db-mode + +(defvar sly-db-mode-syntax-table + (let ((table (copy-syntax-table lisp-mode-syntax-table))) + ;; We give < and > parenthesis syntax, so that #< ... > is treated + ;; as a balanced expression. This enables autodoc-mode to match + ;; #<unreadable> actual arguments in the backtraces with formal + ;; arguments of the function. (For Lisp mode, this is not + ;; desirable, since we do not wish to get a mismatched paren + ;; highlighted everytime we type < or >.) + (modify-syntax-entry ?< "(" table) + (modify-syntax-entry ?> ")" table) + table) + "Syntax table for SLY-DB mode.") + +(defvar sly-db-mode-map + (let ((map (make-sparse-keymap))) + (define-key map "n" 'sly-db-down) + (define-key map "p" 'sly-db-up) + (define-key map "\M-n" 'sly-db-details-down) + (define-key map "\M-p" 'sly-db-details-up) + (define-key map "<" 'sly-db-beginning-of-backtrace) + (define-key map ">" 'sly-db-end-of-backtrace) + + (define-key map "a" 'sly-db-abort) + (define-key map "q" 'sly-db-abort) + (define-key map "c" 'sly-db-continue) + (define-key map "A" 'sly-db-break-with-system-debugger) + (define-key map "B" 'sly-db-break-with-default-debugger) + (define-key map "P" 'sly-db-print-condition) + (define-key map "I" 'sly-db-invoke-restart-by-name) + (define-key map "C" 'sly-db-inspect-condition) + (define-key map ":" 'sly-interactive-eval) + (define-key map "Q" 'sly-db-quit) + + (set-keymap-parent map button-buffer-map) + map)) + +(define-derived-mode sly-db-mode fundamental-mode "sly-db" + "Superior lisp debugger mode. +In addition to ordinary SLY commands, the following are +available:\\<sly-db-mode-map> + +Commands to invoke restarts: + \\[sly-db-quit] - quit + \\[sly-db-abort] - abort + \\[sly-db-continue] - continue + \\[sly-db-invoke-restart-0]-\\[sly-db-invoke-restart-9] - restart shortcuts + \\[sly-db-invoke-restart-by-name] - invoke restart by name + +Navigation commands: + \\[forward-button] - next interactive button + \\[sly-db-down] - down + \\[sly-db-up] - up + \\[sly-db-details-down] - down, with details + \\[sly-db-details-up] - up, with details + \\[sly-db-beginning-of-backtrace] - beginning of backtrace + \\[sly-db-end-of-backtrace] - end of backtrace + +Commands to examine and operate on the selected frame:\\<sly-db-frame-map> + \\[sly-db-show-frame-source] - show frame source + \\[sly-db-goto-source] - go to frame source + \\[sly-db-toggle-details] - toggle details + \\[sly-db-disassemble] - dissassemble frame + \\[sly-db-eval-in-frame] - prompt for a form to eval in frame + \\[sly-db-pprint-eval-in-frame] - eval in frame and pretty print result + \\[sly-db-inspect-in-frame] - inspect in frame's context + \\[sly-db-restart-frame] - restart frame + \\[sly-db-return-from-frame] - return from frame + +Miscellaneous commands:\\<sly-db-mode-map> + \\[sly-db-step] - step + \\[sly-db-break-with-default-debugger] - switch to native debugger + \\[sly-db-break-with-system-debugger] - switch to system debugger (gdb) + \\[sly-interactive-eval] - eval + \\[sly-db-inspect-condition] - inspect signalled condition + +Full list of commands: + +\\{sly-db-mode-map} + +Full list of frame-specific commands: + +\\{sly-db-frame-map}" + (erase-buffer) + (set-syntax-table sly-db-mode-syntax-table) + (sly-set-truncate-lines) + ;; Make original sly-connection "sticky" for SLY-DB commands in this buffer + (setq sly-buffer-connection (sly-connection)) + (setq buffer-read-only t) + (sly-mode 1) + (sly-interactive-buttons-mode 1)) + +;; Keys 0-9 are shortcuts to invoke particular restarts. +(dotimes (number 10) + (let ((fname (intern (format "sly-db-invoke-restart-%S" number))) + (docstring (format "Invoke restart numbered %S." number))) + ;; FIXME: In Emacs≥25, you could avoid `eval' and use + ;; (defalias .. (lambda .. (:documentation docstring) ...)) + ;; instead! + (eval `(defun ,fname () + ,docstring + (interactive) + (sly-db-invoke-restart ,number)) + t) + (define-key sly-db-mode-map (number-to-string number) fname))) + + +;;;;; SLY-DB buffer creation & update + +(defcustom sly-db-focus-debugger 'auto + "Control if debugger window gets focus immediately. + +If nil, the window is never focused automatically; if the symbol +`auto', the window is only focused if the user has performed no +other commands in the meantime (i.e. he/she is expecting a +possible debugger); any other non-nil value means to always +automatically focus the debugger window." + :group 'sly-debugger + :type '(choice (const always) (const never) (const auto))) + +(defun sly-filter-buffers (predicate) + "Return a list of where PREDICATE returns true. +PREDICATE is executed in the buffer to test." + (cl-remove-if-not (lambda (%buffer) + (with-current-buffer %buffer + (funcall predicate))) + (buffer-list))) + +(defun sly-db-buffers (&optional connection) + "Return a list of all sly-db buffers (belonging to CONNECTION.)" + (if connection + (sly-filter-buffers (lambda () + (and (eq sly-buffer-connection connection) + (eq major-mode 'sly-db-mode)))) + (sly-filter-buffers (lambda () (eq major-mode 'sly-db-mode))))) + +(defun sly-db-find-buffer (thread &optional connection) + (let ((connection (or connection (sly-connection)))) + (cl-find-if (lambda (buffer) + (with-current-buffer buffer + (and (eq sly-buffer-connection connection) + (eq sly-current-thread thread)))) + (sly-db-buffers)))) + +(defun sly-db-pop-to-debugger-maybe (&optional _button) + "Maybe pop to *sly-db* buffer for current context." + (interactive) + (let ((b (sly-db-find-buffer sly-current-thread))) + (if b (pop-to-buffer b) + (sly-error "Can't find a *sly-db* debugger for this context")))) + +(defsubst sly-db-get-default-buffer () + "Get a sly-db buffer. +The chosen buffer the default connection's it if exists." + (car (sly-db-buffers (sly-current-connection)))) + +(defun sly-db-pop-to-debugger () + "Pop to the first *sly-db* buffer if at least one exists." + (interactive) + (let ((b (sly-db-get-default-buffer))) + (if b (pop-to-buffer b) + (sly-error "No *sly-db* debugger buffers for this connection")))) + +(defun sly-db-get-buffer (thread &optional connection) + "Find or create a sly-db-buffer for THREAD." + (let ((connection (or connection (sly-connection)))) + (or (sly-db-find-buffer thread connection) + (let ((name (sly-buffer-name :db :connection connection + :suffix (format "thread %d" thread)))) + (with-current-buffer (generate-new-buffer name) + (setq sly-buffer-connection connection + sly-current-thread thread) + (current-buffer)))))) + +(defun sly-db-debugged-continuations (connection) + "Return the all debugged continuations for CONNECTION across SLY-DB buffers." + (cl-loop for b in (sly-db-buffers) + append (with-current-buffer b + (and (eq sly-buffer-connection connection) + sly-db-continuations)))) + +(defun sly-db-confirm-buffer-kill () + (when (or (not (process-live-p sly-buffer-connection)) + (sly-y-or-n-p "Really kill sly-db buffer and throw to toplevel?")) + (ignore-errors (sly-db-quit)) + t)) + +(defun sly-db--display-debugger (_thread) + "Display (or pop to) sly-db for THREAD as appropriate. +Also mark the window as a debugger window." + (let* ((action '(sly-db--display-in-prev-sly-db-window)) + (buffer (current-buffer)) + (win + (if (cond ((eq sly-db-focus-debugger 'auto) + (eq sly--send-last-command last-command)) + (t sly-db-focus-debugger)) + (progn + (pop-to-buffer buffer action) + (selected-window)) + (display-buffer buffer action)))) + (set-window-parameter win 'sly-db buffer) + win)) + +(defun sly-db-setup (thread level condition restarts frame-specs conts) + "Setup a new SLY-DB buffer. +CONDITION is a string describing the condition to debug. +RESTARTS is a list of strings (NAME DESCRIPTION) for each +available restart. FRAME-SPECS is a list of (NUMBER DESCRIPTION +&optional PLIST) describing the initial portion of the +backtrace. Frames are numbered from 0. CONTS is a list of +pending Emacs continuations." + (with-current-buffer (sly-db-get-buffer thread) + (cl-assert (if (equal sly-db-level level) + (equal sly-db-condition condition) + t) + () "Bug: sly-db-level is equal but condition differs\n%s\n%s" + sly-db-condition condition) + (with-selected-window (sly-db--display-debugger thread) + (unless (equal sly-db-level level) + (let ((inhibit-read-only t)) + (sly-db-mode) + (add-hook 'kill-buffer-query-functions + #'sly-db-confirm-buffer-kill + nil t) + (setq sly-current-thread thread) + (setq sly-db-level level) + (setq mode-name (format "sly-db[%d]" sly-db-level)) + (setq sly-db-condition condition) + (setq sly-db-restarts restarts) + (setq sly-db-continuations conts) + (sly-db-insert-condition condition) + (insert "\n\n" (sly-db-in-face section "Restarts:") "\n") + (setq sly-db-restart-list-start-marker (point-marker)) + (sly-db-insert-restarts restarts 0 sly-db-initial-restart-limit) + (insert "\n" (sly-db-in-face section "Backtrace:") "\n") + (setq sly-db-backtrace-start-marker (point-marker)) + (save-excursion + (if frame-specs + (sly-db-insert-frames (sly-db-prune-initial-frames frame-specs) t) + (insert "[No backtrace]"))) + (run-hooks 'sly-db-hook) + (set-syntax-table lisp-mode-syntax-table))) + (sly-recenter (point-min) 'allow-moving-point) + (when sly--stack-eval-tags + (sly-message "Entering recursive edit..") + (recursive-edit))))) + +(defun sly-db--display-in-prev-sly-db-window (buffer _alist) + (let ((window + (get-window-with-predicate + #'(lambda (w) + (let ((value (window-parameter w 'sly-db))) + (and value + (not (buffer-live-p value)))))))) + (when window + (display-buffer-record-window 'reuse window buffer) + (set-window-buffer window buffer) + window))) + +(defun sly-db--ensure-initialized (thread level) + "Initialize debugger buffer for THREAD. +If such a buffer exists for LEVEL, it is assumed to have been +sufficiently initialized, and this function does nothing." + (let ((buffer (sly-db-find-buffer thread))) + (unless (and buffer + (with-current-buffer buffer + (equal sly-db-level level))) + (sly-rex () + ('(slynk:debugger-info-for-emacs 0 10) + nil thread) + ((:ok result) + (apply #'sly-db-setup thread level result)))))) + +(defvar sly-db-exit-hook nil + "Hooks run in the debugger buffer just before exit") + +(defun sly-db-exit (thread _level &optional stepping) + "Exit from the debug level LEVEL." + (sly--when-let (sly-db (sly-db-find-buffer thread)) + (with-current-buffer sly-db + (setq kill-buffer-query-functions + (remove 'sly-db-confirm-buffer-kill kill-buffer-query-functions)) + (run-hooks 'sly-db-exit-hook) + (cond (stepping + (setq sly-db-level nil) + (run-with-timer 0.4 nil 'sly-db-close-step-buffer sly-db)) + ((not (eq sly-db (window-buffer (selected-window)))) + ;; A different window selection means an indirect, + ;; non-interactive exit, we just kill the sly-db buffer. + (kill-buffer)) + (t + (quit-window t)))))) + +(defun sly-db-close-step-buffer (buffer) + (when (buffer-live-p buffer) + (with-current-buffer buffer + (when (not sly-db-level) + (quit-window t))))) + + +;;;;;; SLY-DB buffer insertion + +(defun sly-db-insert-condition (condition) + "Insert the text for CONDITION. +CONDITION should be a list (MESSAGE TYPE EXTRAS). +EXTRAS is currently used for the stepper." + (cl-destructuring-bind (msg type extras) condition + (insert (sly-db-in-face topline msg) + "\n" + (sly-db-in-face condition type)) + (sly-db-dispatch-extras extras))) + +(defvar sly-db-extras-hooks nil + "Handlers for the extra options sent in a debugger invocation. +Each function is called with one argument, a list (OPTION +VALUE). It should return non-nil iff it can handle OPTION, and +thus preventing other handlers from trying. + +Functions are run in the SLDB buffer.") + +(defun sly-db-dispatch-extras (extras) + ;; this is (mis-)used for the stepper + (dolist (extra extras) + (sly-dcase extra + ((:show-frame-source n) + (sly-db-show-frame-source n)) + (t + (or (run-hook-with-args-until-success 'sly-db-extras-hooks extra) + ;;(error "Unhandled extra element:" extra) + ))))) + +(defun sly-db-insert-restarts (restarts start count) + "Insert RESTARTS and add the needed text props +RESTARTS should be a list ((NAME DESCRIPTION) ...)." + (let* ((len (length restarts)) + (end (if count (min (+ start count) len) len))) + (cl-loop for (name string) in (cl-subseq restarts start end) + for number from start + do (insert + " " (sly-db-in-face restart-number (number-to-string number)) + ": " (sly-make-action-button (format "[%s]" name) + (let ((n number)) + #'(lambda (_button) + (sly-db-invoke-restart n))) + 'restart-number number) + " " (sly-db-in-face restart string)) + (insert "\n")) + (when (< end len) + (insert (sly-make-action-button + " --more--" + #'(lambda (button) + (let ((inhibit-read-only t)) + (delete-region (button-start button) + (1+ (button-end button))) + (sly-db-insert-restarts restarts end nil) + (sly--when-let (win (get-buffer-window (current-buffer))) + (with-selected-window win + (sly-recenter (point-max)))))) + 'point-entered #'(lambda (_ new) (push-button new))) + "\n")))) + +(defun sly-db-frame-restartable-p (frame-spec) + (and (plist-get (cl-caddr frame-spec) :restartable) t)) + +(defun sly-db-prune-initial-frames (frame-specs) + "Return the prefix of FRAMES-SPECS to initially present to the user. +Regexp heuristics are used to avoid showing SLYNK-internal frames." + (let* ((case-fold-search t) + (rx "^\\([() ]\\|lambda\\)*slynk\\>")) + (or (cl-loop for frame-spec in frame-specs + until (string-match rx (cadr frame-spec)) + collect frame-spec) + frame-specs))) + +(defun sly-db-insert-frames (frame-specs more) + "Insert frames for FRAME-SPECS into buffer. +If MORE is non-nil, more frames are on the Lisp stack." + (cl-loop + for frame-spec in frame-specs + do (sly-db-insert-frame frame-spec) + finally + (when more + (insert (sly-make-action-button + " --more--\n" + (lambda (button) + (let* ((inhibit-read-only t) + (count 40) + (from (1+ (car frame-spec))) + (to (+ from count)) + (frames (sly-eval `(slynk:backtrace ,from ,to))) + (more (sly-length= frames count))) + (delete-region (button-start button) + (button-end button)) + (save-excursion + (sly-db-insert-frames frames more)) + (sly--when-let (win (get-buffer-window (current-buffer))) + (with-selected-window win + (sly-recenter (point-max)))))) + 'point-entered #'(lambda (_ new) (push-button new))))))) + +(defvar sly-db-frame-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "t") 'sly-db-toggle-details) + (define-key map (kbd "v") 'sly-db-show-frame-source) + (define-key map (kbd ".") 'sly-db-goto-source) + (define-key map (kbd "D") 'sly-db-disassemble) + (define-key map (kbd "e") 'sly-db-eval-in-frame) + (define-key map (kbd "d") 'sly-db-pprint-eval-in-frame) + (define-key map (kbd "i") 'sly-db-inspect-in-frame) + (define-key map (kbd "r") 'sly-db-restart-frame) + (define-key map (kbd "R") 'sly-db-return-from-frame) + (define-key map (kbd "RET") 'sly-db-toggle-details) + + (define-key map "s" 'sly-db-step) + (define-key map "x" 'sly-db-next) + (define-key map "o" 'sly-db-out) + (define-key map "b" 'sly-db-break-on-return) + + (define-key map "\C-c\C-c" 'sly-db-recompile-frame-source) + + (set-keymap-parent map sly-part-button-keymap) + map)) + +(defvar sly-db-frame-menu-map + (let ((map (make-sparse-keymap))) + (cl-macrolet ((item (label sym) + `(define-key map [,sym] '(menu-item ,label ,sym)))) + (item "Dissassemble" sly-db-disassemble) + (item "Eval In Context" sly-db-eval-in-frame) + (item "Eval and Pretty Print In Context" sly-db-pprint-eval-in-frame) + (item "Inspect In Context" sly-db-inspect-in-frame) + (item "Restart" sly-db-restart-frame) + (item "Return Value" sly-db-return-from-frame) + (item "Toggle Details" sly-db-toggle-details) + (item "Show Source" sly-db-show-frame-source) + (item "Go To Source" sly-db-goto-source)) + (set-keymap-parent map sly-button-popup-part-menu-keymap) + map)) + +(define-button-type 'sly-db-frame :supertype 'sly-part + 'keymap sly-db-frame-map + 'part-menu-keymap sly-db-frame-menu-map + 'action 'sly-db-toggle-details + 'mouse-action 'sly-db-toggle-details) + +(defun sly-db--guess-frame-function (frame) + (ignore-errors + (car (car (read-from-string + (replace-regexp-in-string "#" "" + (cadr frame))))))) + +(defun sly-db-frame-button (label frame face &rest props) + (apply #'sly--make-text-button label nil :type 'sly-db-frame + 'face face + 'field (car frame) + 'frame-number (car frame) + 'frame-string (cadr frame) + 'part-args (list (car frame) + (sly-db--guess-frame-function frame)) + 'part-label (format "Frame %d" (car frame)) + props)) + +(defun sly-db-frame-number-at-point () + (let ((button (sly-db-frame-button-near-point))) + (button-get button 'frame-number))) + +(defun sly-db-frame-button-near-point () + (or (sly-button-at nil 'sly-db-frame 'no-error) + (get-text-property (point) 'nearby-frame-button) + (error "No frame button here"))) + +(defun sly-db-insert-frame (frame-spec) + "Insert a frame for FRAME-SPEC." + (let* ((number (car frame-spec)) + (label (cadr frame-spec)) + (origin (point))) + (insert + (propertize (format "%2d: " number) + 'face 'sly-db-frame-label-face) + (sly-db-frame-button label frame-spec + (if (sly-db-frame-restartable-p frame-spec) + 'sly-db-restartable-frame-line-face + 'sly-db-frame-line-face)) + "\n") + (add-text-properties + origin (point) + (list 'field number + 'keymap sly-db-frame-map + 'nearby-frame-button (button-at (- (point) 2)))))) + + +;;;;;; SLY-DB examining text props +(defun sly-db--goto-last-visible-frame () + (goto-char (point-max)) + (while (not (get-text-property (point) 'frame-string)) + (goto-char (previous-single-property-change (point) 'frame-string)))) + +(defun sly-db-beginning-of-backtrace () + "Goto the first frame." + (interactive) + (goto-char sly-db-backtrace-start-marker)) + + +;;;;; SLY-DB commands +(defun sly-db-cycle () + "Cycle between restart list and backtrace." + (interactive) + (let ((pt (point))) + (cond ((< pt sly-db-restart-list-start-marker) + (goto-char sly-db-restart-list-start-marker)) + ((< pt sly-db-backtrace-start-marker) + (goto-char sly-db-backtrace-start-marker)) + (t + (goto-char sly-db-restart-list-start-marker))))) + +(defun sly-db-end-of-backtrace () + "Fetch the entire backtrace and go to the last frame." + (interactive) + (sly-db--fetch-all-frames) + (sly-db--goto-last-visible-frame)) + +(defun sly-db--fetch-all-frames () + (let ((inhibit-read-only t) + (inhibit-point-motion-hooks t)) + (sly-db--goto-last-visible-frame) + (let ((last (sly-db-frame-number-at-point))) + (goto-char (next-single-char-property-change (point) 'frame-string)) + (delete-region (point) (point-max)) + (save-excursion + (insert "\n") + (sly-db-insert-frames (sly-eval `(slynk:backtrace ,(1+ last) nil)) + nil))))) + + +;;;;;; SLY-DB show source +(defun sly-db-show-frame-source (frame-number) + "Highlight FRAME-NUMBER's expression in a source code buffer." + (interactive (list (sly-db-frame-number-at-point))) + (sly-eval-async + `(slynk:frame-source-location ,frame-number) + (lambda (source-location) + (sly-dcase source-location + ((:error message) + (sly-message "%s" message) + (ding)) + (t + (sly--display-source-location source-location)))))) + + +;;;;;; SLY-DB toggle details +(define-button-type 'sly-db-local-variable :supertype 'sly-part + 'sly-button-inspect + #'(lambda (frame-id var-id) + (sly-eval-for-inspector `(slynk:inspect-frame-var ,frame-id + ,var-id)) ) + 'sly-button-pretty-print + #'(lambda (frame-id var-id) + (sly-eval-describe `(slynk:pprint-frame-var ,frame-id + ,var-id))) + 'sly-button-describe + #'(lambda (frame-id var-id) + (sly-eval-describe `(slynk:describe-frame-var ,frame-id + ,var-id)))) + +(defun sly-db-local-variable-button (label frame-number var-id &rest props) + (apply #'sly--make-text-button label nil + :type 'sly-db-local-variable + 'part-args (list frame-number var-id) + 'part-label (format "Local Variable %d" var-id) props)) + +(defun sly-db-frame-details-region (frame-button) + "Get (BEG END) for FRAME-BUTTON's details, or nil if hidden" + (let ((beg (button-end frame-button)) + (end (1- (field-end (button-start frame-button) 'escape)))) + (unless (= beg end) (list beg end)))) + +(defun sly-db-toggle-details (frame-button) + "Toggle display of details for the current frame. +The details include local variable bindings and CATCH-tags." + (interactive (list (sly-db-frame-button-near-point))) + (if (sly-db-frame-details-region frame-button) + (sly-db-hide-frame-details frame-button) + (sly-db-show-frame-details frame-button))) + +(defun sly-db-show-frame-details (frame-button) + "Show details for FRAME-BUTTON" + (interactive (list (sly-db-frame-button-near-point))) + (cl-destructuring-bind (locals catches) + (sly-eval `(slynk:frame-locals-and-catch-tags + ,(button-get frame-button 'frame-number))) + (let ((inhibit-read-only t) + (inhibit-point-motion-hooks t)) + (save-excursion + (goto-char (button-end frame-button)) + (let ((indent1 " ") + (indent2 " ")) + (insert "\n" indent1 + (sly-db-in-face section (if locals "Locals:" "[No Locals]"))) + (cl-loop for i from 0 + for var in locals + with frame-number = (button-get frame-button 'frame-number) + do + (cl-destructuring-bind (&key name id value) var + (insert "\n" + indent2 + (sly-db-in-face local-name + (concat name (if (zerop id) + "" + (format "#%d" id)))) + " = " + (sly-db-local-variable-button value + frame-number + i)))) + (when catches + (insert "\n" indent1 (sly-db-in-face section "Catch-tags:")) + (dolist (tag catches) + (sly-propertize-region `(catch-tag ,tag) + (insert "\n" indent2 (sly-db-in-face catch-tag + (format "%s" tag)))))) + ;; The whole details field is propertized accordingly... + ;; + (add-text-properties (button-start frame-button) (point) + (list 'field (button-get frame-button 'field) + 'keymap sly-db-frame-map + 'nearby-frame-button frame-button)) + ;; ...but we must remember to remove the 'keymap property from + ;; any buttons inside the field + ;; + (cl-loop for pos = (point) then (button-start button) + for button = (previous-button pos) + while (and button + (> (button-start button) + (button-start frame-button))) + do (remove-text-properties (button-start button) + (button-end button) + '(keymap nil)))))) + (sly-recenter (field-end (button-start frame-button) 'escape)))) + +(defun sly-db-hide-frame-details (frame-button) + (interactive (list (sly-db-frame-button-near-point))) + (let* ((inhibit-read-only t) + (to-delete (sly-db-frame-details-region frame-button))) + (cl-assert to-delete) + (when (and (< (car to-delete) (point)) + (< (point) (cadr to-delete))) + (goto-char (button-start frame-button))) + (apply #'delete-region to-delete))) + +(defun sly-db-disassemble (frame-number) + "Disassemble the code for frame with FRAME-NUMBER." + (interactive (list (sly-db-frame-number-at-point))) + (sly-eval-async `(slynk:sly-db-disassemble ,frame-number) + (lambda (result) + (sly-show-description result nil)))) + + +;;;;;; SLY-DB eval and inspect + +(defun sly-db-eval-in-frame (frame-number string package) + "Prompt for an expression and evaluate it in the selected frame." + (interactive (sly-db-frame-eval-interactive "Eval in frame (%s)> ")) + (sly-eval-async `(slynk:eval-string-in-frame ,string ,frame-number ,package) + 'sly-display-eval-result)) + +(defun sly-db-pprint-eval-in-frame (frame-number string package) + "Prompt for an expression, evaluate in selected frame, pretty-print result." + (interactive (sly-db-frame-eval-interactive "Eval in frame (%s)> ")) + (sly-eval-async + `(slynk:pprint-eval-string-in-frame ,string ,frame-number ,package) + (lambda (result) + (sly-show-description result nil)))) + +(defun sly-db-frame-eval-interactive (fstring) + (let* ((frame-number (sly-db-frame-number-at-point)) + (pkg (sly-eval `(slynk:frame-package-name ,frame-number)))) + (list frame-number + (let ((sly-buffer-package pkg)) + (sly-read-from-minibuffer (format fstring pkg))) + pkg))) + +(defun sly-db-inspect-in-frame (frame-number string) + "Prompt for an expression and inspect it in the selected frame." + (interactive (list + (sly-db-frame-number-at-point) + (sly-read-from-minibuffer + "Inspect in frame (evaluated): " + (sly-sexp-at-point)))) + (sly-eval-for-inspector `(slynk:inspect-in-frame ,string ,frame-number))) + +(defun sly-db-inspect-condition () + "Inspect the current debugger condition." + (interactive) + (sly-eval-for-inspector '(slynk:inspect-current-condition))) + +(defun sly-db-print-condition () + (interactive) + (sly-eval-describe `(slynk:sdlb-print-condition))) + + +;;;;;; SLY-DB movement + +(defun sly-db-down (arg) + "Move down ARG frames. With negative ARG, move up." + (interactive "p") + (cl-loop + for i from 0 below (abs arg) + do (cl-loop + for tries from 0 below 2 + for pos = (point) then next-change + for next-change = (funcall (if (cl-minusp arg) + #'previous-single-char-property-change + #'next-single-char-property-change) + pos 'frame-number) + for prop-value = (get-text-property next-change 'frame-number) + when prop-value do (goto-char next-change) + until prop-value))) + +(defun sly-db-up (arg) + "Move up ARG frames. With negative ARG, move down." + (interactive "p") + (sly-db-down (- (or arg 1)))) + +(defun sly-db-sugar-move (move-fn arg) + (let ((current-frame-button (sly-db-frame-button-near-point))) + (when (and current-frame-button + (sly-db-frame-details-region current-frame-button)) + (sly-db-hide-frame-details current-frame-button))) + (funcall move-fn arg) + (let ((frame-button (sly-db-frame-button-near-point))) + (when frame-button + (sly-db-show-frame-source (button-get frame-button 'frame-number)) + (sly-db-show-frame-details frame-button)))) + +(defun sly-db-details-up (arg) + "Move up ARG frames and show details." + (interactive "p") + (sly-db-sugar-move 'sly-db-up arg)) + +(defun sly-db-details-down (arg) + "Move down ARG frames and show details." + (interactive "p") + (sly-db-sugar-move 'sly-db-down arg)) + + +;;;;;; SLY-DB restarts + +(defun sly-db-quit () + "Quit to toplevel." + (interactive) + (cl-assert sly-db-restarts () "sly-db-quit called outside of sly-db buffer") + (sly-rex () ('(slynk:throw-to-toplevel)) + ((:ok x) (error "sly-db-quit returned [%s]" x)) + ((:abort _)))) + +(defun sly-db-continue () + "Invoke the \"continue\" restart." + (interactive) + (cl-assert sly-db-restarts () "sly-db-continue called outside of sly-db buffer") + (sly-rex () + ('(slynk:sly-db-continue)) + ((:ok _) + (sly-message "No restart named continue") + (ding)) + ((:abort _)))) + +(defun sly-db-abort () + "Invoke the \"abort\" restart." + (interactive) + (sly-eval-async '(slynk:sly-db-abort) + (lambda (v) (sly-message "Restart returned: %S" v)))) + +(defun sly-db-invoke-restart (restart-number) + "Invoke the restart number NUMBER. +Interactively get the number from a button at point." + (interactive (button-get (sly-button-at (point)) 'restart-number)) + (sly-rex () + ((list 'slynk:invoke-nth-restart-for-emacs sly-db-level restart-number)) + ((:ok value) (sly-message "Restart returned: %s" value)) + ((:abort _)))) + +(defun sly-db-invoke-restart-by-name (restart-name) + (interactive (list (let ((completion-ignore-case t)) + (completing-read "Restart: " sly-db-restarts nil t + "" + 'sly-db-invoke-restart-by-name)))) + (sly-db-invoke-restart (cl-position restart-name sly-db-restarts + :test 'string= :key 'first))) + +(defun sly-db-break-with-default-debugger (&optional dont-unwind) + "Enter default debugger." + (interactive "P") + (sly-rex () + ((list 'slynk:sly-db-break-with-default-debugger + (not (not dont-unwind))) + nil sly-current-thread) + ((:abort _)))) + +(defun sly-db-break-with-system-debugger (&optional lightweight) + "Enter system debugger (gdb)." + (interactive "P") + (sly-attach-gdb sly-buffer-connection lightweight)) + +(defun sly-attach-gdb (connection &optional lightweight) + "Run `gud-gdb'on the connection with PID `pid'. + +If `lightweight' is given, do not send any request to the +inferior Lisp (e.g. to obtain default gdb config) but only +operate from the Emacs side; intended for cases where the Lisp is +truly screwed up." + (interactive + (list (sly-read-connection "Attach gdb to: " (sly-connection)) "P")) + (let ((pid (sly-pid connection)) + (file (sly-lisp-implementation-program connection)) + (commands (unless lightweight + (let ((sly-dispatching-connection connection)) + (sly-eval `(slynk:gdb-initial-commands)))))) + (gud-gdb (format "gdb -p %d %s" pid (or file ""))) + (with-current-buffer gud-comint-buffer + (dolist (cmd commands) + ;; First wait until gdb was initialized, then wait until current + ;; command was processed. + (while (not (looking-back comint-prompt-regexp (line-beginning-position) + nil)) + (sit-for 0.01)) + ;; We do not use `gud-call' because we want the initial commands + ;; to be displayed by the user so he knows what he's got. + (insert cmd) + (comint-send-input))))) + +(defun sly-read-connection (prompt &optional initial-value) + "Read a connection from the minibuffer. +Return the net process, or nil." + (cl-assert (memq initial-value sly-net-processes)) + (let* ((to-string (lambda (p) + (format "%s (pid %d)" + (sly-connection-name p) (sly-pid p)))) + (candidates (mapcar (lambda (p) (cons (funcall to-string p) p)) + sly-net-processes))) + (cdr (assoc (completing-read prompt candidates + nil t (funcall to-string initial-value)) + candidates)))) + +(defun sly-db-step (frame-number) + "Step to next basic-block boundary." + (interactive (list (sly-db-frame-number-at-point))) + (sly-eval-async `(slynk:sly-db-step ,frame-number))) + +(defun sly-db-next (frame-number) + "Step over call." + (interactive (list (sly-db-frame-number-at-point))) + (sly-eval-async `(slynk:sly-db-next ,frame-number))) + +(defun sly-db-out (frame-number) + "Resume stepping after returning from this function." + (interactive (list (sly-db-frame-number-at-point))) + (sly-eval-async `(slynk:sly-db-out ,frame-number))) + +(defun sly-db-break-on-return (frame-number) + "Set a breakpoint at the current frame. +The debugger is entered when the frame exits." + (interactive (list (sly-db-frame-number-at-point))) + (sly-eval-async `(slynk:sly-db-break-on-return ,frame-number) + (lambda (msg) (sly-message "%s" msg)))) + +(defun sly-db-break (name) + "Set a breakpoint at the start of the function NAME." + (interactive (list (sly-read-symbol-name "Function: " t))) + (sly-eval-async `(slynk:sly-db-break ,name) + (lambda (msg) (sly-message "%s" msg)))) + +(defun sly-db-return-from-frame (frame-number string) + "Reads an expression in the minibuffer and causes the function to +return that value, evaluated in the context of the frame." + (interactive (list (sly-db-frame-number-at-point) + (sly-read-from-minibuffer "Return from frame: "))) + (sly-rex () + ((list 'slynk:sly-db-return-from-frame frame-number string)) + ((:ok value) (sly-message "%s" value)) + ((:abort _)))) + +(defun sly-db-restart-frame (frame-number) + "Causes the frame to restart execution with the same arguments as it +was called originally." + (interactive (list (sly-db-frame-number-at-point))) + (sly-rex () + ((list 'slynk:restart-frame frame-number)) + ((:ok value) (sly-message "%s" value)) + ((:abort _)))) + +(defun sly-toggle-break-on-signals () + "Toggle the value of *break-on-signals*." + (interactive) + (sly-eval-async `(slynk:toggle-break-on-signals) + (lambda (msg) (sly-message "%s" msg)))) + + +;;;;;; SLY-DB recompilation commands + +(defun sly-db-recompile-frame-source (frame-number &optional raw-prefix-arg) + (interactive + (list (sly-db-frame-number-at-point) current-prefix-arg)) + (sly-eval-async + `(slynk:frame-source-location ,frame-number) + (let ((policy (sly-compute-policy raw-prefix-arg))) + (lambda (source-location) + (sly-dcase source-location + ((:error message) + (sly-message "%s" message) + (ding)) + (t + (let ((sly-compilation-policy policy)) + (sly-recompile-location source-location)))))))) + + +;;;; Thread control panel + +(defvar sly-threads-buffer-timer nil) + +(defcustom sly-threads-update-interval nil + "Interval at which the list of threads will be updated." + :type '(choice + (number :value 0.5) + (const nil)) + :group 'sly-ui) + +(defun sly-list-threads () + "Display a list of threads." + (interactive) + (let ((name (sly-buffer-name :threads + :connection t))) + (sly-with-popup-buffer (name :connection t + :mode 'sly-thread-control-mode) + (sly-update-threads-buffer (current-buffer)) + (goto-char (point-min)) + (when sly-threads-update-interval + (when sly-threads-buffer-timer + (cancel-timer sly-threads-buffer-timer)) + (setq sly-threads-buffer-timer + (run-with-timer + sly-threads-update-interval + sly-threads-update-interval + 'sly-update-threads-buffer + (current-buffer)))) + (add-hook 'kill-buffer-hook 'sly--threads-buffer-teardown + 'append 'local)))) + +(defun sly--threads-buffer-teardown () + (when sly-threads-buffer-timer + (cancel-timer sly-threads-buffer-timer)) + (when (process-live-p sly-buffer-connection) + (sly-eval-async `(slynk:quit-thread-browser)))) + +(defun sly-update-threads-buffer (&optional buffer) + (interactive) + (with-current-buffer (or buffer + (current-buffer)) + (sly-eval-async '(slynk:list-threads) + #'(lambda (threads) + (with-current-buffer (current-buffer) + (sly--display-threads threads)))))) + +(defun sly-move-point (position) + "Move point in the current buffer and in the window the buffer is displayed." + (let ((window (get-buffer-window (current-buffer) t))) + (goto-char position) + (when window + (set-window-point window position)))) + +(defun sly--display-threads (threads) + (let* ((inhibit-read-only t) + (old-thread-id (get-text-property (point) 'thread-id)) + (old-line (line-number-at-pos)) + (old-column (current-column))) + (erase-buffer) + (sly-insert-threads threads) + (let ((new-line (cl-position old-thread-id (cdr threads) + :key #'car :test #'equal))) + (goto-char (point-min)) + (forward-line (or new-line old-line)) + (move-to-column old-column) + (sly-move-point (point))))) + +(defun sly-transpose-lists (list-of-lists) + (let ((ncols (length (car list-of-lists)))) + (cl-loop for col-index below ncols + collect (cl-loop for row in list-of-lists + collect (elt row col-index))))) + +(defun sly-insert-table-row (line line-props col-props col-widths) + (sly-propertize-region line-props + (cl-loop for string in line + for col-prop in col-props + for width in col-widths do + (sly-insert-propertized col-prop string) + (insert-char ?\ (- width (length string)))))) + +(defun sly-insert-table (rows header row-properties column-properties) + "Insert a \"table\" so that the columns are nicely aligned." + (let* ((ncols (length header)) + (lines (cons header rows)) + (widths (cl-loop for columns in (sly-transpose-lists lines) + collect (1+ (cl-loop for cell in columns + maximize (length cell))))) + (header-line (with-temp-buffer + (sly-insert-table-row + header nil (make-list ncols nil) widths) + (buffer-string)))) + (cond ((boundp 'header-line-format) + (setq header-line-format header-line)) + (t (insert header-line "\n"))) + (cl-loop for line in rows for line-props in row-properties do + (sly-insert-table-row line line-props column-properties widths) + (insert "\n")))) + +(defvar sly-threads-table-properties + '(nil (face bold))) + +(defun sly-insert-threads (threads) + (let* ((labels (car threads)) + (threads (cdr threads)) + (header (cl-loop for label in labels collect + (capitalize (substring (symbol-name label) 1)))) + (rows (cl-loop for thread in threads collect + (cl-loop for prop in thread collect + (format "%s" prop)))) + (line-props (cl-loop for (id) in threads for i from 0 + collect `(thread-index ,i thread-id ,id))) + (col-props (cl-loop for nil in labels for i from 0 collect + (nth i sly-threads-table-properties)))) + (sly-insert-table rows header line-props col-props))) + + +;;;;; Major mode +(defvar sly-thread-control-mode-map + (let ((map (make-sparse-keymap))) + (define-key map "a" 'sly-thread-attach) + (define-key map "d" 'sly-thread-debug) + (define-key map "g" 'sly-update-threads-buffer) + (define-key map "k" 'sly-thread-kill) + (define-key map "q" 'quit-window) + map)) + +(define-derived-mode sly-thread-control-mode fundamental-mode + "Threads" + "SLY Thread Control Panel Mode. + +\\{sly-thread-control-mode-map}" + (when sly-truncate-lines + (set (make-local-variable 'truncate-lines) t)) + (read-only-mode 1) + (sly-mode 1) + (setq buffer-undo-list t)) + +(defun sly-thread-kill () + (interactive) + (sly-eval `(cl:mapc 'slynk:kill-nth-thread + ',(sly-get-properties 'thread-index))) + (call-interactively 'sly-update-threads-buffer)) + +(defun sly-get-region-properties (prop start end) + (cl-loop for position = (if (get-text-property start prop) + start + (next-single-property-change start prop)) + then (next-single-property-change position prop) + while (<= position end) + collect (get-text-property position prop))) + +(defun sly-get-properties (prop) + (if (use-region-p) + (sly-get-region-properties prop + (region-beginning) + (region-end)) + (let ((value (get-text-property (point) prop))) + (when value + (list value))))) + +(defun sly-thread-attach () + (interactive) + (let ((id (get-text-property (point) 'thread-index)) + (file (sly-slynk-port-file))) + (sly-eval-async `(slynk:start-slynk-server-in-thread ,id ,file))) + (sly-read-port-and-connect nil)) + +(defun sly-thread-debug () + (interactive) + (let ((id (get-text-property (point) 'thread-index))) + (sly-eval-async `(slynk:debug-nth-thread ,id)))) + + +;;;;; Connection listing + +(defvar sly-connection-list-mode-map + (let ((map (make-sparse-keymap))) + (define-key map "d" 'sly-connection-list-make-default) + (define-key map "g" 'sly-update-connection-list) + (define-key map (kbd "RET") 'sly-connection-list-default-action) + (define-key map (kbd "C-m") 'sly-connection-list-default-action) + (define-key map (kbd "C-k") 'sly-quit-connection-at-point) + (define-key map (kbd "R") 'sly-restart-connection-at-point) + (define-key map (kbd "q") 'quit-window) + map)) + +(define-derived-mode sly-connection-list-mode tabulated-list-mode + "SLY-Connections" + "SLY Connection List Mode. + +\\{sly-connection-list-mode-map}" + (set (make-local-variable 'tabulated-list-format) + `[("Default" 8) ("Name" 24 t) ("Host" 12) + ("Port" 6) ("Pid" 6 t) ("Type" 1000 t)]) + (tabulated-list-init-header)) + +(defun sly--connection-at-point () + (or (get-text-property (point) 'tabulated-list-id) + (error "No connection at point"))) + +(defvar sly-connection-list-button-action nil) + +(defun sly-connection-list-default-action (connection) + (interactive (list (sly--connection-at-point))) + (funcall sly-connection-list-button-action connection)) + +(defun sly-update-connection-list () + (interactive) + (set (make-local-variable 'tabulated-list-entries) + (mapcar + #'(lambda (p) + (list p + `[,(if (eq sly-default-connection p) "*" " ") + (,(file-name-nondirectory (or (sly-connection-name p) + "unknown")) + action + ,#'(lambda (_button) + (and sly-connection-list-button-action + (funcall sly-connection-list-button-action p)))) + ,(car (process-contact p)) + ,(format "%s" (cl-second (process-contact p))) + ,(format "%s" (sly-pid p)) + ,(or (sly-lisp-implementation-type p) + "unknown")])) + (reverse sly-net-processes))) + (let ((p (point))) + (tabulated-list-print) + (goto-char p))) + +(defun sly-quit-connection-at-point (connection) + (interactive (list (sly--connection-at-point))) + (let ((sly-dispatching-connection connection) + (end (time-add (current-time) (seconds-to-time 3)))) + (sly-quit-lisp t) + (while (memq connection sly-net-processes) + (when (time-less-p end (current-time)) + (sly-message "Quit timeout expired. Disconnecting.") + (delete-process connection)) + (sit-for 0 100))) + (sly-update-connection-list)) + +(defun sly-restart-connection-at-point (connection) + (interactive (list (sly--connection-at-point))) + (when (sly-y-or-n-p "Really restart '%s'" (sly-connection-name connection)) + (let ((sly-dispatching-connection connection)) + (sly-restart-inferior-lisp)))) + +(defun sly-connection-list-make-default () + "Make the connection at point the default connection." + (interactive) + (sly-select-connection (sly--connection-at-point)) + (sly-update-connection-list)) + +(defun sly-list-connections () + "Display a list of all connections." + (interactive) + (sly-with-popup-buffer ((sly-buffer-name :connections) + :mode 'sly-connection-list-mode) + (sly-update-connection-list))) + + + +;;;; Inspector + +(defgroup sly-inspector nil + "Options for the SLY inspector." + :prefix "sly-inspector-" + :group 'sly) + +(defvar sly--this-inspector-name nil + "Buffer-local inspector name (a string), or nil") + +(cl-defun sly-eval-for-inspector (slyfun-and-args + &key (error-message "Couldn't inspect") + restore-point + save-selected-window + (inspector-name sly--this-inspector-name) + opener) + (if (cl-some #'listp slyfun-and-args) + (sly-warning + "`sly-eval-for-inspector' not meant to be passed a generic form")) + (let ((pos (and (eq major-mode 'sly-inspector-mode) + (sly-inspector-position)))) + (sly-eval-async `(slynk:eval-for-inspector + ,sly--this-inspector-name ; current inspector, if any + ,inspector-name ; target inspector, if any + ',(car slyfun-and-args) + ,@(cdr slyfun-and-args)) + (or opener + (lambda (results) + (let ((opener (lambda () + (sly--open-inspector + results + :point (and restore-point pos) + :inspector-name inspector-name + :switch (not save-selected-window))))) + (cond (results + (funcall opener)) + (t + (sly-message error-message))))))))) + +(defun sly-read-inspector-name () + (let* ((names (cl-loop for b in (buffer-list) + when (with-current-buffer b + (and (eq sly-buffer-connection + (sly-current-connection)) + (eq major-mode 'sly-inspector-mode))) + when (buffer-local-value 'sly--this-inspector-name b) + collect it)) + (result (completing-read "Inspector name: " (cons "default" + names) + nil nil nil nil "default"))) + (unless (string= result "default") + result))) + +(defun sly-maybe-read-inspector-name () + (or (and current-prefix-arg + (sly-read-inspector-name)) + sly--this-inspector-name)) + +(defun sly-inspect (string &optional inspector-name) + "Eval an expression and inspect the result." + (interactive + (let* ((name (sly-maybe-read-inspector-name)) + (string (sly-read-from-minibuffer + (concat "Inspect value" + (and name + (format " in inspector \"%s\"" name)) + " (evaluated): ") + (sly-sexp-at-point 'interactive nil nil)))) + (list string name))) + (sly-eval-for-inspector `(slynk:init-inspector ,string) + :inspector-name inspector-name)) + +(defvar sly-inspector-mode-map + (let ((map (make-sparse-keymap))) + (define-key map "l" 'sly-inspector-pop) + (define-key map "n" 'sly-inspector-next) + (define-key map [mouse-6] 'sly-inspector-pop) + (define-key map [mouse-7] 'sly-inspector-next) + + (define-key map " " 'sly-inspector-next) + (define-key map "D" 'sly-inspector-describe-inspectee) + (define-key map "e" 'sly-inspector-eval) + (define-key map "h" 'sly-inspector-history) + (define-key map "g" 'sly-inspector-reinspect) + (define-key map ">" 'sly-inspector-fetch-all) + (define-key map "q" 'sly-inspector-quit) + + (set-keymap-parent map button-buffer-map) + map)) + +(define-derived-mode sly-inspector-mode fundamental-mode + "SLY-Inspector" + " +\\{sly-inspector-mode-map}" + (set-syntax-table lisp-mode-syntax-table) + (sly-set-truncate-lines) + (setq buffer-read-only t) + (sly-mode 1)) + +(define-button-type 'sly-inspector-part :supertype 'sly-part + 'sly-button-inspect + #'(lambda (id) + (sly-eval-for-inspector `(slynk:inspect-nth-part ,id) + :inspector-name (sly-maybe-read-inspector-name))) + 'sly-button-pretty-print + #'(lambda (id) + (sly-eval-describe `(slynk:pprint-inspector-part ,id))) + 'sly-button-describe + #'(lambda (id) + (sly-eval-describe `(slynk:describe-inspector-part ,id))) + 'sly-button-show-source + #'(lambda (id) + (sly-eval-async + `(slynk:find-source-location-for-emacs '(:inspector ,id)) + #'(lambda (result) + (sly--display-source-location result 'noerror))))) + +(defun sly-inspector-part-button (label id &rest props) + (apply #'sly--make-text-button + label nil + :type 'sly-inspector-part + 'part-args (list id) + 'part-label "Inspector Object" + props)) + +(defmacro sly-inspector-fontify (face string) + `(sly-add-face ',(intern (format "sly-inspector-%s-face" face)) ,string)) + +(cl-defun sly--open-inspector (inspected-parts + &key point kill-hook inspector-name (switch t)) + "Display INSPECTED-PARTS in a new inspector window. +Optionally set point to POINT. If KILL-HOOK is provided, it is +added to local KILL-BUFFER hooks for the inspector +buffer. INSPECTOR-NAME is the name of the target inspector, or +nil if the default one is to be used. SWITCH indicates the +buffer should be switched to (defaults to t)" + (sly-with-popup-buffer ((sly-buffer-name :inspector + :connection t + :suffix inspector-name) + :mode 'sly-inspector-mode + :select switch + :same-window-p + (and (eq major-mode 'sly-inspector-mode) + (or (null inspector-name) + (eq sly--this-inspector-name inspector-name))) + :connection t) + (when kill-hook + (add-hook 'kill-buffer-hook kill-hook t t)) + (set (make-local-variable 'sly--this-inspector-name) inspector-name) + (cl-destructuring-bind (&key id title content) inspected-parts + (cl-macrolet ((fontify (face string) + `(sly-inspector-fontify ,face ,string))) + (insert (sly-inspector-part-button title id 'skip t)) + (while (eq (char-before) ?\n) + (backward-delete-char 1)) + (insert "\n" (fontify label "--------------------") "\n") + (save-excursion + (sly-inspector-insert-content content)) + (when point + (cl-check-type point cons) + (ignore-errors + (goto-char (point-min)) + (forward-line (1- (car point))) + (move-to-column (cdr point)))))) + (buffer-disable-undo))) + +(defvar sly-inspector-limit 500) + +(defun sly-inspector-insert-content (content) + (sly-inspector-fetch-chunk + content nil + (lambda (chunk) + (let ((inhibit-read-only t)) + (sly-inspector-insert-chunk chunk t t))))) + +(defun sly-inspector-insert-chunk (chunk prev next) + "Insert CHUNK at point. +If PREV resp. NEXT are true insert more-buttons as needed." + (cl-destructuring-bind (ispecs len start end) chunk + (when (and prev (> start 0)) + (sly-inspector-insert-more-button start t)) + (mapc #'sly-inspector-insert-ispec ispecs) + (when (and next (< end len)) + (sly-inspector-insert-more-button end nil)))) + +(defun sly-inspector-insert-ispec (ispec) + (insert + (if (stringp ispec) ispec + (sly-dcase ispec + ((:value string id) + (sly-inspector-part-button string id)) + ((:label string) + (sly-inspector-fontify label string)) + ((:action string id) + (sly-make-action-button + string + #'(lambda (_button) + (sly-eval-for-inspector `(slynk::inspector-call-nth-action ,id) + :restore-point t)))))))) + +(defun sly-inspector-position () + "Return a pair (Y-POSITION X-POSITION) representing the +position of point in the current buffer." + ;; We make sure we return absolute coordinates even if the user has + ;; narrowed the buffer. + ;; FIXME: why would somebody narrow the buffer? + (save-restriction + (widen) + (cons (line-number-at-pos) + (current-column)))) + +(defun sly-inspector-pop () + "Reinspect the previous object." + (interactive) + (sly-eval-for-inspector `(slynk:inspector-pop) + :error-message "No previous object")) + +(defun sly-inspector-next () + "Inspect the next object in the history." + (interactive) + (sly-eval-for-inspector `(slynk:inspector-next) + :error-message "No next object")) + +(defun sly-inspector-quit (&optional reset) + "Quit the inspector and kill the buffer. +With optional RESET (true with prefix arg), also reset the +inspector on the Lisp side." + (interactive "P") + (when reset (sly-eval-async `(slynk:quit-inspector))) + (quit-window)) + +(defun sly-inspector-describe-inspectee () + "Describe the currently inspected object" + (interactive) + (sly-eval-describe `(slynk:describe-inspectee))) + +(defun sly-inspector-eval (string) + "Eval an expression in the context of the inspected object. +The `*' variable will be bound to the inspected object." + (interactive (list (sly-read-from-minibuffer "Inspector eval: "))) + (sly-eval-with-transcript `(slynk:inspector-eval ,string))) + +(defun sly-inspector-history () + "Show the previously inspected objects." + (interactive) + (sly-eval-describe `(slynk:inspector-history))) + +(defun sly-inspector-reinspect (&optional inspector-name) + (interactive (list (sly-maybe-read-inspector-name))) + (sly-eval-for-inspector `(slynk:inspector-reinspect) + :inspector-name inspector-name)) + +(defun sly-inspector-toggle-verbose () + (interactive) + (sly-eval-for-inspector `(slynk:inspector-toggle-verbose))) + +(defun sly-inspector-insert-more-button (index previous) + (insert (sly-make-action-button + (if previous " [--more--]\n" " [--more--]") + #'sly-inspector-fetch-more + 'range-args (list index previous)))) + +(defun sly-inspector-fetch-all () + "Fetch all inspector contents and go to the end." + (interactive) + (let ((button (button-at (1- (point-max))))) + (cond ((and button + (button-get button 'range-args)) + (let (sly-inspector-limit) + (sly-inspector-fetch-more button))) + (t + (sly-error "No more elements to fetch"))))) + +(defun sly-inspector-fetch-more (button) + (cl-destructuring-bind (index prev) (button-get button 'range-args) + (sly-inspector-fetch-chunk + (list '() (1+ index) index index) prev + (sly-rcurry + (lambda (chunk prev) + (let ((inhibit-read-only t)) + (delete-region (button-start button) (button-end button)) + (sly-inspector-insert-chunk chunk prev (not prev)))) + prev)))) + +(defun sly-inspector-fetch-chunk (chunk prev cont) + (sly-inspector-fetch chunk sly-inspector-limit prev cont)) + +(defun sly-inspector-fetch (chunk limit prev cont) + (cl-destructuring-bind (from to) + (sly-inspector-next-range chunk limit prev) + (cond ((and from to) + (sly-eval-for-inspector + `(slynk:inspector-range ,from ,to) + :opener (sly-rcurry (lambda (chunk2 chunk1 limit prev cont) + (sly-inspector-fetch + (sly-inspector-join-chunks chunk1 chunk2) + limit prev cont)) + chunk limit prev cont))) + (t (funcall cont chunk))))) + +(defun sly-inspector-next-range (chunk limit prev) + (cl-destructuring-bind (_ len start end) chunk + (let ((count (- end start))) + (cond ((and prev (< 0 start) (or (not limit) (< count limit))) + (list (if limit (max (- end limit) 0) 0) start)) + ((and (not prev) (< end len) (or (not limit) (< count limit))) + (list end (if limit (+ start limit) most-positive-fixnum))) + (t '(nil nil)))))) + +(defun sly-inspector-join-chunks (chunk1 chunk2) + (cl-destructuring-bind (i1 _l1 s1 e1) chunk1 + (cl-destructuring-bind (i2 l2 s2 e2) chunk2 + (cond ((= e1 s2) + (list (append i1 i2) l2 s1 e2)) + ((= e2 s1) + (list (append i2 i1) l2 s2 e1)) + (t (error "Invalid chunks")))))) + + +;;;; Indentation + +(defun sly-update-indentation () + "Update indentation for all macros defined in the Lisp system." + (interactive) + (sly-eval-async '(slynk:update-indentation-information))) + +(defvar sly-indentation-update-hooks) + +(defun sly-intern-indentation-spec (spec) + (cond ((consp spec) + (cons (sly-intern-indentation-spec (car spec)) + (sly-intern-indentation-spec (cdr spec)))) + ((stringp spec) + (intern spec)) + (t + spec))) + +;; FIXME: restore the old version without per-package +;; stuff. sly-indentation.el should be able tho disable the simple +;; version if needed. +(defun sly-handle-indentation-update (alist) + "Update Lisp indent information. + +ALIST is a list of (SYMBOL-NAME . INDENT-SPEC) of proposed indentation +settings for `sly-common-lisp-indent-function'. The appropriate property +is setup, unless the user already set one explicitly." + (dolist (info alist) + (let ((symbol (intern (car info))) + (indent (sly-intern-indentation-spec (cl-second info))) + (packages (cl-third info))) + (if (and (boundp 'sly-common-lisp-system-indentation) + (fboundp 'sly-update-system-indentation)) + ;; A table provided by sly-cl-indent.el. + (funcall #'sly-update-system-indentation symbol indent packages) + ;; Does the symbol have an indentation value that we set? + (when (equal (get symbol 'sly-common-lisp-indent-function) + (get symbol 'sly-indent)) + (put symbol 'sly-common-lisp-indent-function indent) + (put symbol 'sly-indent indent))) + (run-hook-with-args 'sly-indentation-update-hooks + symbol indent packages)))) + + +;;;; Contrib modules + +(defun sly-contrib--load-slynk-dependencies () + (let ((needed (cl-remove-if (lambda (s) + (cl-find (symbol-name s) + (sly-lisp-modules) + :key #'downcase + :test #'string=)) + sly-contrib--required-slynk-modules + :key #'car))) + (when needed + ;; No asynchronous request because with :SPAWN that could result + ;; in the attempt to load modules concurrently which may not be + ;; supported by the host Lisp. + (sly-eval `(slynk:slynk-add-load-paths ',(cl-remove-duplicates + (mapcar #'cl-second needed) + :test #'string=))) + (let* ((result (sly-eval + `(slynk:slynk-require + ',(mapcar #'symbol-name (mapcar #'cl-first needed))))) + (all-modules (cl-first result)) + (loaded-now (cl-second result))) + ;; check if everything went OK + ;; + (cl-loop for n in needed + unless (cl-find (cl-first n) loaded-now :test #'string=) + + ;; string= compares symbols and strings nicely + ;; + do (when (y-or-n-p (format + "\ +Watch out! SLY failed to load SLYNK module %s for contrib %s!\n +Disable it?" (cl-first n) (cl-third n))) + (sly-disable-contrib (cl-third n)) + (sly-temp-message 3 3 "\ +You'll need to re-enable %s manually with `sly-enable-contrib'\ +if/when you fix the error" (cl-third n)))) + ;; Update the connection-local list of all *MODULES* + ;; + (setf (sly-lisp-modules) all-modules))))) + +(cl-defstruct (sly-contrib + (:conc-name sly-contrib--)) + enabled-p + name + sly-dependencies + slynk-dependencies + enable + disable + authors + license) + +(defmacro define-sly-contrib (name _docstring &rest clauses) + (declare (indent 1)) + (cl-destructuring-bind (&key sly-dependencies + slynk-dependencies + on-load + on-unload + authors + license) + (cl-loop for (key . value) in clauses append `(,key ,value)) + (cl-labels + ((enable-fn (c) (intern (concat (symbol-name c) "-init"))) + (disable-fn (c) (intern (concat (symbol-name c) "-unload"))) + (path-sym (c) (intern (concat (symbol-name c) "--path"))) + (contrib-sym (c) (intern (concat (symbol-name c) "--contrib")))) + `(progn + (defvar ,(path-sym name)) + (defvar ,(contrib-sym name)) + (setq ,(path-sym name) (and load-file-name + (file-name-directory load-file-name))) + (eval-when-compile + (when byte-compile-current-file; protect against eager macro expansion + (add-to-list 'load-path + (file-name-as-directory + (file-name-directory byte-compile-current-file))))) + (setq ,(contrib-sym name) + (put 'sly-contribs ',name + (make-sly-contrib + :name ',name :authors ',authors :license ',license + :sly-dependencies ',sly-dependencies + :slynk-dependencies ',slynk-dependencies + :enable ',(enable-fn name) :disable ',(disable-fn name)))) + ,@(mapcar (lambda (d) `(require ',d)) sly-dependencies) + (defun ,(enable-fn name) () + (mapc #'funcall (mapcar + #'sly-contrib--enable + (cl-remove-if #'sly-contrib--enabled-p + (list ,@(mapcar #'contrib-sym + sly-dependencies))))) + (cl-loop for dep in ',slynk-dependencies + do (cl-pushnew (list dep ,(path-sym name) ',name) + sly-contrib--required-slynk-modules + :key #'cl-first)) + ;; FIXME: It's very tricky to do Slynk calls like + ;; `sly-contrib--load-slynk-dependencies' here, and it this + ;; should probably loop all connections. Anyway, we try + ;; ensure this can only happen from an interactive + ;; `sly-setup' call. + ;; + (when (and (eq this-command 'sly-setup) + (sly-connected-p)) + (sly-contrib--load-slynk-dependencies)) + ,@on-load + (setf (sly-contrib--enabled-p ,(contrib-sym name)) t)) + (defun ,(disable-fn name) () + ,@on-unload + (cl-loop for dep in ',slynk-dependencies + do (setq sly-contrib--required-slynk-modules + (cl-remove dep sly-contrib--required-slynk-modules + :key #'cl-first))) + (sly-warning "Disabling contrib %s" ',name) + (mapc #'funcall (mapcar + #'sly-contrib--disable + (cl-remove-if-not #'sly-contrib--enabled-p + (list ,@(mapcar #'contrib-sym + sly-dependencies))))) + (setf (sly-contrib--enabled-p ,(contrib-sym name)) nil)))))) + +(defun sly-contrib--all-contribs () + "All defined `sly-contrib' objects." + (cl-loop for (nil val) on (symbol-plist 'sly-contribs) by #'cddr + when (sly-contrib-p val) + collect val)) + +(defun sly-contrib--all-dependencies (contrib) + "Contrib names recursively needed by CONTRIB, including self." + (sly--contrib-safe contrib + (cons contrib + (cl-mapcan #'sly-contrib--all-dependencies + (sly-contrib--sly-dependencies + (sly-contrib--find-contrib contrib)))))) + +(defun sly-contrib--find-contrib (designator) + (if (sly-contrib-p designator) + designator + (or (get 'sly-contribs designator) + (error "Unknown contrib: %S" designator)))) + +(defun sly-contrib--read-contrib-name () + (let ((names (cl-loop for c in (sly-contrib--all-contribs) collect + (symbol-name (sly-contrib--name c))))) + (intern (completing-read "Contrib: " names nil t)))) + +(defun sly-enable-contrib (name) + "Attempt to enable contrib NAME." + (interactive (list (sly-contrib--read-contrib-name))) + (sly--contrib-safe name + (funcall (sly-contrib--enable (sly-contrib--find-contrib name))))) + +(defun sly-disable-contrib (name) + "Attempt to disable contrib NAME." + (interactive (list (sly-contrib--read-contrib-name))) + (sly--contrib-safe name + (funcall (sly-contrib--disable (sly-contrib--find-contrib name))))) + + +;;;;; Pull-down menu +(easy-menu-define sly-menu sly-mode-map "SLY" + (let ((C '(sly-connected-p))) + `("SLY" + [ "Edit Definition..." sly-edit-definition ,C ] + [ "Return From Definition" sly-pop-find-definition-stack ,C ] + [ "Complete Symbol" sly-complete-symbol ,C ] + "--" + ("Evaluation" + [ "Eval Defun" sly-eval-defun ,C ] + [ "Eval Last Expression" sly-eval-last-expression ,C ] + [ "Eval And Pretty-Print" sly-pprint-eval-last-expression ,C ] + [ "Eval Region" sly-eval-region ,C ] + [ "Eval Region And Pretty-Print" sly-pprint-eval-region ,C ] + [ "Interactive Eval..." sly-interactive-eval ,C ] + [ "Edit Lisp Value..." sly-edit-value ,C ] + [ "Call Defun" sly-call-defun ,C ]) + ("Debugging" + [ "Inspect..." sly-inspect ,C ] + [ "Macroexpand Once..." sly-macroexpand-1 ,C ] + [ "Macroexpand All..." sly-macroexpand-all ,C ] + [ "Disassemble..." sly-disassemble-symbol ,C ]) + ("Compilation" + [ "Compile Defun" sly-compile-defun ,C ] + [ "Compile and Load File" sly-compile-and-load-file ,C ] + [ "Compile File" sly-compile-file ,C ] + [ "Compile Region" sly-compile-region ,C ] + "--" + [ "Next Note" sly-next-note t ] + [ "Previous Note" sly-previous-note t ] + [ "Remove Notes" sly-remove-notes t ] + [ "List notes" sly-show-compilation-log t ]) + ("Cross Reference" + [ "Who Calls..." sly-who-calls ,C ] + [ "Who References... " sly-who-references ,C ] + [ "Who Sets..." sly-who-sets ,C ] + [ "Who Binds..." sly-who-binds ,C ] + [ "Who Macroexpands..." sly-who-macroexpands ,C ] + [ "Who Specializes..." sly-who-specializes ,C ] + [ "List Callers..." sly-list-callers ,C ] + [ "List Callees..." sly-list-callees ,C ] + [ "Next Location" sly-next-location t ]) + ("Editing" + [ "Check Parens" check-parens t] + [ "Update Indentation" sly-update-indentation ,C]) + ("Documentation" + [ "Describe Symbol..." sly-describe-symbol ,C ] + [ "Lookup Documentation..." sly-documentation-lookup t ] + [ "Apropos..." sly-apropos ,C ] + [ "Apropos all..." sly-apropos-all ,C ] + [ "Apropos Package..." sly-apropos-package ,C ] + [ "Hyperspec..." sly-hyperspec-lookup t ]) + "--" + [ "Interrupt Command" sly-interrupt ,C ] + [ "Abort Async. Command" sly-quit ,C ]))) + +(easy-menu-define sly-sly-db-menu sly-db-mode-map "SLY-DB Menu" + (let ((C '(sly-connected-p))) + `("SLY-DB" + [ "Next Frame" sly-db-down t ] + [ "Previous Frame" sly-db-up t ] + [ "Toggle Frame Details" sly-db-toggle-details t ] + [ "Next Frame (Details)" sly-db-details-down t ] + [ "Previous Frame (Details)" sly-db-details-up t ] + "--" + [ "Eval Expression..." sly-interactive-eval ,C ] + [ "Eval in Frame..." sly-db-eval-in-frame ,C ] + [ "Eval in Frame (pretty print)..." sly-db-pprint-eval-in-frame ,C ] + [ "Inspect In Frame..." sly-db-inspect-in-frame ,C ] + [ "Inspect Condition Object" sly-db-inspect-condition ,C ] + "--" + [ "Restart Frame" sly-db-restart-frame ,C ] + [ "Return from Frame..." sly-db-return-from-frame ,C ] + ("Invoke Restart" + [ "Continue" sly-db-continue ,C ] + [ "Abort" sly-db-abort ,C ] + [ "Step" sly-db-step ,C ] + [ "Step next" sly-db-next ,C ] + [ "Step out" sly-db-out ,C ] + ) + "--" + [ "Quit (throw)" sly-db-quit ,C ] + [ "Break With Default Debugger" sly-db-break-with-default-debugger ,C ]))) + +(easy-menu-define sly-inspector-menu sly-inspector-mode-map + "Menu for the SLY Inspector" + (let ((C '(sly-connected-p))) + `("SLY-Inspector" + [ "Pop Inspectee" sly-inspector-pop ,C ] + [ "Next Inspectee" sly-inspector-next ,C ] + [ "Describe this Inspectee" sly-inspector-describe ,C ] + [ "Eval in context" sly-inspector-eval ,C ] + [ "Show history" sly-inspector-history ,C ] + [ "Reinspect" sly-inspector-reinspect ,C ] + [ "Fetch all parts" sly-inspector-fetch-all ,C ] + [ "Quit" sly-inspector-quit ,C ]))) + + +;;;; Utilities (no not Paul Graham style) + +;;; FIXME: this looks almost sly `sly-alistify', perhaps the two +;;; functions can be merged. +(defun sly-group-similar (similar-p list) + "Return the list of lists of 'similar' adjacent elements of LIST. +The function SIMILAR-P is used to test for similarity. +The order of the input list is preserved." + (if (null list) + nil + (let ((accumulator (list (list (car list))))) + (dolist (x (cdr list)) + (if (funcall similar-p x (caar accumulator)) + (push x (car accumulator)) + (push (list x) accumulator))) + (nreverse (mapcar #'nreverse accumulator))))) + +(defun sly-alistify (list key test) + "Partition the elements of LIST into an alist. +KEY extracts the key from an element and TEST is used to compare +keys." + (let ((alist '())) + (dolist (e list) + (let* ((k (funcall key e)) + (probe (cl-assoc k alist :test test))) + (if probe + (push e (cdr probe)) + (push (cons k (list e)) alist)))) + ;; Put them back in order. + (nreverse (mapc (lambda (ent) + (setcdr ent (nreverse (cdr ent)))) + alist)))) + +;;;;; Misc. + +(defun sly-length= (list n) + "Return (= (length LIST) N)." + (if (zerop n) + (null list) + (let ((tail (nthcdr (1- n) list))) + (and tail (null (cdr tail)))))) + +(defun sly-length> (seq n) + "Return (> (length SEQ) N)." + (cl-etypecase seq + (list (nthcdr n seq)) + (sequence (> (length seq) n)))) + +(defun sly-trim-whitespace (str) + "Chomp leading and tailing whitespace from STR." + ;; lited from http://www.emacswiki.org/emacs/ElispCookbook + (replace-regexp-in-string (rx (or (: bos (* (any " \t\n"))) + (: (* (any " \t\n")) eos))) + "" + str)) + +;;;;; Buffer related + +(defun sly-column-max () + (save-excursion + (goto-char (point-min)) + (cl-loop for column = (prog2 (end-of-line) (current-column) (forward-line)) + until (= (point) (point-max)) + maximizing column))) + +;;;;; CL symbols vs. Elisp symbols. + +(defun sly-cl-symbol-name (symbol) + (let ((n (if (stringp symbol) symbol (symbol-name symbol)))) + (if (string-match ":\\([^:]*\\)$" n) + (let ((symbol-part (match-string 1 n))) + (if (string-match "^|\\(.*\\)|$" symbol-part) + (match-string 1 symbol-part) + symbol-part)) + n))) + +(defun sly-cl-symbol-package (symbol &optional default) + (let ((n (if (stringp symbol) symbol (symbol-name symbol)))) + (if (string-match "^\\([^:]*\\):" n) + (match-string 1 n) + default))) + +(defun sly-qualify-cl-symbol-name (symbol-or-name) + "Return a package-qualified string for SYMBOL-OR-NAME. +If SYMBOL-OR-NAME doesn't already have a package prefix the +current package is used." + (let ((s (if (stringp symbol-or-name) + symbol-or-name + (symbol-name symbol-or-name)))) + (if (sly-cl-symbol-package s) + s + (format "%s::%s" + (let* ((package (sly-current-package))) + ;; package is a string like ":cl-user" + ;; or "CL-USER", or "\"CL-USER\"". + (if package + (sly--pretty-package-name package) + "CL-USER")) + (sly-cl-symbol-name s))))) + +;;;;; Moving, CL idiosyncracies aware (reader conditionals &c.) + +(defmacro sly-point-moves-p (&rest body) + "Execute BODY and return true if the current buffer's point moved." + (declare (indent 0)) + (let ((pointvar (cl-gensym "point-"))) + `(let ((,pointvar (point))) + (save-current-buffer ,@body) + (/= ,pointvar (point))))) + +(defun sly-forward-sexp (&optional count) + "Like `forward-sexp', but understands reader-conditionals (#- and #+), +and skips comments." + (dotimes (_i (or count 1)) + (sly-forward-cruft) + (forward-sexp))) + +(defconst sly-reader-conditionals-regexp + ;; #!+, #!- are SBCL specific reader-conditional syntax. + ;; We need this for the source files of SBCL itself. + (regexp-opt '("#+" "#-" "#!+" "#!-"))) + +(defsubst sly-forward-reader-conditional () + "Move past any reader conditional (#+ or #-) at point." + (when (looking-at sly-reader-conditionals-regexp) + (goto-char (match-end 0)) + (let* ((plus-conditional-p (eq (char-before) ?+)) + (result (sly-eval-feature-expression + (condition-case e + (read (current-buffer)) + (invalid-read-syntax + (signal 'sly-unknown-feature-expression (cdr e))))))) + (unless (if plus-conditional-p result (not result)) + ;; skip this sexp + (sly-forward-sexp))))) + +(defun sly-forward-cruft () + "Move forward over whitespace, comments, reader conditionals." + (while (sly-point-moves-p (skip-chars-forward " \t\n") + (forward-comment (buffer-size)) + (sly-forward-reader-conditional)))) + +(defun sly-keywordify (symbol) + "Make a keyword out of the symbol SYMBOL." + (let ((name (downcase (symbol-name symbol)))) + (intern (if (eq ?: (aref name 0)) + name + (concat ":" name))))) + +(put 'sly-incorrect-feature-expression + 'error-conditions '(sly-incorrect-feature-expression error)) + +(put 'sly-unknown-feature-expression + 'error-conditions '(sly-unknown-feature-expression + sly-incorrect-feature-expression + error)) + +;; FIXME: let it crash +;; FIXME: the (null (cdr l)) constraint is bogus +(defun sly-eval-feature-expression (e) + "Interpret a reader conditional expression." + (cond ((symbolp e) + (memq (sly-keywordify e) (sly-lisp-features))) + ((and (consp e) (symbolp (car e))) + (funcall (let ((head (sly-keywordify (car e)))) + (cl-case head + (:and #'cl-every) + (:or #'cl-some) + (:not + (let ((feature-expression e)) + (lambda (f l) + (cond ((null l) t) + ((null (cdr l)) (not (apply f l))) + (t (signal 'sly-incorrect-feature-expression + feature-expression)))))) + (t (signal 'sly-unknown-feature-expression head)))) + #'sly-eval-feature-expression + (cdr e))) + (t (signal 'sly-incorrect-feature-expression e)))) + +;;;;; Extracting Lisp forms from the buffer or user + +(defun sly-region-for-defun-at-point (&optional pos) + "Return a list (START END) for the positions of defun at POS. +POS defaults to point" + (save-excursion + (save-match-data + (goto-char (or pos (point))) + (end-of-defun) + (let ((end (point))) + (beginning-of-defun) + (list (point) end))))) + +(defun sly-beginning-of-symbol () + "Move to the beginning of the CL-style symbol at point." + (while (re-search-backward "\\(\\sw\\|\\s_\\|\\s\\.\\|\\s\\\\|[#@|]\\)\\=" + (when (> (point) 2000) (- (point) 2000)) + t)) + (re-search-forward "\\=#[-+.<|]" nil t) + (when (and (eq (char-after) ?@) (eq (char-before) ?\,)) + (forward-char))) + +(defsubst sly-end-of-symbol () + "Move to the end of the CL-style symbol at point." + (re-search-forward "\\=\\(\\sw\\|\\s_\\|\\s\\.\\|#:\\|[@|]\\)*")) + +(put 'sly-symbol 'end-op 'sly-end-of-symbol) +(put 'sly-symbol 'beginning-op 'sly-beginning-of-symbol) + +(defun sly-symbol-start-pos () + "Return the starting position of the symbol under point. +The result is unspecified if there isn't a symbol under the point." + (save-excursion (sly-beginning-of-symbol) (point))) + +(defun sly-symbol-end-pos () + (save-excursion (sly-end-of-symbol) (point))) + +(defun sly-bounds-of-symbol-at-point () + "Return the bounds of the symbol around point. +The returned bounds are either nil or non-empty." + (let ((bounds (bounds-of-thing-at-point 'sly-symbol))) + (if (and bounds + (< (car bounds) + (cdr bounds))) + bounds))) + +(defun sly-symbol-at-point (&optional interactive) + "Return the name of the symbol at point, otherwise nil." + ;; (thing-at-point 'symbol) returns "" in empty buffers + (let ((bounds (sly-bounds-of-symbol-at-point))) + (when bounds + (let ((beg (car bounds)) (end (cdr bounds))) + (when interactive (sly-flash-region beg end)) + (buffer-substring-no-properties beg end))))) + +(defun sly-bounds-of-sexp-at-point (&optional interactive) + "Return the bounds sexp near point as a pair (or nil). +With non-nil INTERACTIVE, error if can't find such a thing." + (or (sly-bounds-of-symbol-at-point) + (and (equal (char-after) ?\() + (member (char-before) '(?\' ?\, ?\@)) + ;; hide stuff before ( to avoid quirks with '( etc. + (save-restriction + (narrow-to-region (point) (point-max)) + (bounds-of-thing-at-point 'sexp))) + (bounds-of-thing-at-point 'sexp) + (and (save-excursion + (and (ignore-errors + (backward-sexp 1) + t) + (bounds-of-thing-at-point 'sexp)))) + (when interactive + (user-error "No sexp near point")))) + +(cl-defun sly-sexp-at-point (&optional interactive stringp (errorp t)) + "Return the sexp at point as a string, otherwise nil. +With non-nil INTERACTIVE, flash the region and also error if no +sexp can be found, unless ERRORP, which defaults to t, is passed +as nil. With non-nil STRINGP, only look for strings" + (catch 'return + (let ((bounds (sly-bounds-of-sexp-at-point (and interactive + errorp)))) + (when bounds + (when (and stringp + (not (eq (syntax-class (syntax-after (car bounds))) + (char-syntax ?\")))) + (if (and interactive + interactive) + (user-error "No string at point") + (throw 'return nil))) + (when interactive + (sly-flash-region (car bounds) (cdr bounds))) + (buffer-substring-no-properties (car bounds) + (cdr bounds)))))) + +(defun sly-string-at-point (&optional interactive) + "Returns the string near point as a string, otherwise nil. +With non-nil INTERACTIVE, flash the region and error if no string +can be found." + (sly-sexp-at-point interactive 'stringp)) + +(defun sly-input-complete-p (start end) + "Return t if the region from START to END contains a complete sexp." + (save-excursion + (goto-char start) + (cond ((looking-at "\\s *['`#]?[(\"]") + (ignore-errors + (save-restriction + (narrow-to-region start end) + ;; Keep stepping over blanks and sexps until the end of + ;; buffer is reached or an error occurs. Tolerate extra + ;; close parens. + (cl-loop do (skip-chars-forward " \t\r\n)") + until (eobp) + do (forward-sexp)) + t))) + (t t)))) + + +;;;; sly.el in pretty colors + +(cl-loop for sym in (list 'sly-def-connection-var + 'sly-define-channel-type + 'sly-define-channel-method + 'define-sly-contrib) + for regexp = (format "(\\(%S\\)\\s +\\(\\(\\w\\|\\s_\\)+\\)" + sym) + do (font-lock-add-keywords + 'emacs-lisp-mode + `((,regexp (1 font-lock-keyword-face) + (2 font-lock-variable-name-face))))) + +;;;; Finishing up + +(defun sly--byte-compile (symbol) + (require 'bytecomp) ;; tricky interaction between autoload and let. + (let ((byte-compile-warnings '())) + (byte-compile symbol))) + +(defun sly-byte-compile-hotspots (syms) + (mapc (lambda (sym) + (cond ((fboundp sym) + (unless (or (byte-code-function-p (symbol-function sym)) + (subrp (symbol-function sym))) + (sly--byte-compile sym))) + (t (error "%S is not fbound" sym)))) + syms)) + +(sly-byte-compile-hotspots + '(sly-alistify + sly-log-event + sly--events-buffer + sly-process-available-input + sly-dispatch-event + sly-net-filter + sly-net-have-input-p + sly-net-decode-length + sly-net-read + sly-print-apropos + sly-insert-propertized + sly-beginning-of-symbol + sly-end-of-symbol + sly-eval-feature-expression + sly-forward-sexp + sly-forward-cruft + sly-forward-reader-conditional)) + +;;;###autoload +(add-hook 'lisp-mode-hook 'sly-editing-mode) + +(cond + ((or (not (memq 'slime-lisp-mode-hook lisp-mode-hook)) + noninteractive + (prog1 + (y-or-n-p "[sly] SLIME detected in `lisp-mode-hook', causes keybinding conflicts. Remove it for this Emacs session?") + (warn "To restore SLIME in this session, customize `lisp-mode-hook' +and replace `sly-editing-mode' with `slime-lisp-mode-hook'."))) + (remove-hook 'lisp-mode-hook 'slime-lisp-mode-hook) + (dolist (buffer (buffer-list)) + (with-current-buffer buffer + (when (eq major-mode 'lisp-mode) + (unless sly-editing-mode (sly-editing-mode 1)) + (ignore-errors (and (featurep 'slime) (funcall 'slime-mode -1))))))) + (t + (warn + "`sly.el' loaded OK. To use SLY, customize `lisp-mode-hook' and remove `slime-lisp-mode-hook'."))) + +(provide 'sly) + +;;; sly.el ends here +;; Local Variables: +;; coding: utf-8 +;; End: diff --git a/elpa/sly-20220302.1053/sly.info b/elpa/sly-20220302.1053/sly.info @@ -0,0 +1,3539 @@ +This is sly.info, produced by makeinfo version 6.7 from sly.texi. + +Written for SLIME Luke Gorrie and others, rewritten by João Távora for +SLY. + + This file has been placed in the public domain. +INFO-DIR-SECTION Emacs +START-INFO-DIR-ENTRY +* SLY: (sly). Common-Lisp IDE +END-INFO-DIR-ENTRY + + +File: sly.info, Node: Top, Next: Introduction, Up: (dir) + +SLY +*** + +SLY is a Common Lisp IDE for Emacs. This is the manual for version +1.0.42. (Last updated April 20, 2022) + + Written for SLIME Luke Gorrie and others, rewritten by João Távora +for SLY. + + This file has been placed in the public domain. + +* Menu: + +* Introduction:: +* Getting started:: +* A SLY tour for SLIME users:: +* Working with source files:: +* Common functionality:: +* The REPL and other special buffers:: +* Customization:: +* Tips and Tricks:: +* Extensions:: +* Credits:: +* Key Index:: +* Command Index:: +* Variable Index:: + + -- The Detailed Node Listing -- + +Getting started + +* Platforms:: +* Downloading:: +* Basic setup:: +* Running:: +* Basic customization:: +* Multiple Lisps:: + +Working with source files + +* Evaluation:: +* Compilation:: +* Autodoc:: +* Semantic indentation:: +* Reader conditionals:: +* Macro-expansion:: + +Common functionality + +* Finding definitions:: +* Cross-referencing:: +* Completion:: +* Interactive objects:: +* Documentation:: +* Multiple connections:: +* Disassembly:: +* Recovery:: +* Temporary buffers:: +* Multi-threading:: + +The REPL and other special buffers + +* REPL:: +* Inspector:: +* Debugger:: +* Trace Dialog:: +* Stickers:: + +The REPL: the "top level" + +* REPL commands:: +* REPL output:: +* REPL backreferences:: + +The SLY-DB Debugger + +* Examining frames:: +* Restarts:: +* Frame Navigation:: +* Miscellaneous:: + +Customization + +* Emacs-side:: +* Lisp-side customization:: + +Emacs-side + +* Keybindings:: +* Keymaps:: +* Defcustom variables:: +* Hooks:: + +Lisp-side (Slynk) + +* Communication style:: +* Other configurables:: + +Tips and Tricks + +* Connecting to a remote Lisp:: +* Loading Slynk faster:: +* Auto-SLY:: +* REPLs and game loops:: +* Controlling SLY from outside Emacs:: + +Connecting to a remote Lisp + +* Setting up the Lisp image:: +* Setting up Emacs:: +* Setting up pathname translations:: + +Extensions + +* Loading and unloading:: +* More contribs:: + +More contribs + +* TRAMP Support:: +* Scratch Buffer:: + + + +File: sly.info, Node: Introduction, Next: Getting started, Prev: Top, Up: Top + +1 Introduction +************** + +SLY is Sylvester the Cat's Common Lisp IDE. It extends Emacs with +support for interactive programming in Common Lisp. + + The features are centered around an Emacs minor-mode called +'sly-mode', which complements the standard major-mode 'lisp-mode' for +editing Lisp source files. 'sly-mode' adds support for interacting with +a running Common Lisp process for compilation, debugging, documentation +lookup, and so on. + + SLY attempts to follow the example of Emacs's own native Emacs-Lisp +environment. Many of the keybindings and interface concepts used to +interact with Emacs's Elisp machine are reused in SLY to interact with +the underlying Common Lisp run-times. Emacs makes requests to these +processes, asking them to compile files or code snippets; deliver +introspection information various objects; or invoke commands or +debugging restarts. + + Internally, SLY's user-interface, written in Emacs Lisp, is connected +via sockets to one or more instances of a server program called "Slynk" +that is running in the Lisp processes. + + The two sides communicate using a Remote Procedure Call (RPC) +protocol. The Lisp-side server is primarily written in portable Common +Lisp. However, because some non-standard functionality is provided +differently by each Lisp implementation (SBCL, CMUCL, Allegro, etc...) +the Lisp-side server is again split into two parts - portable and +non-portable implementation - which communicate using a well-defined +interface. Each Lisp implementation provides a separate implementation +of that interface, making SLY as a whole readily portable. + + SLY is a direct fork of SLIME, the "Superior Lisp Interaction Mode +for Emacs", which itself derived from previous Emacs programs such as +SLIM and ILISP. If you already know SLIME, SLY's closeness to it is +immediately apparent. However, where SLIME has traditionally focused on +the stability of its core functionality, SLY aims for a richer feature +set, a more consistent user interface, and an experience generally +closer to Emacs' own. + + To understand the differences between the two projects read SLY's +NEWS.md file. For a hand-on approach to these differences you might +want to *note A SLY tour for SLIME users::. + + +File: sly.info, Node: Getting started, Next: A SLY tour for SLIME users, Prev: Introduction, Up: Top + +2 Getting started +***************** + +This chapter tells you how to get SLY up and running. + +* Menu: + +* Platforms:: +* Downloading:: +* Basic setup:: +* Running:: +* Basic customization:: +* Multiple Lisps:: + + +File: sly.info, Node: Platforms, Next: Downloading, Up: Getting started + +2.1 Supported Platforms +======================= + +SLY supports a wide range of operating systems and Lisp implementations. +SLY runs on Unix systems, Mac OSX, and Microsoft Windows. GNU Emacs +versions 24.4 and above are supported. _XEmacs or Emacs 23 are notably +not supported_. + + The supported Lisp implementations, roughly ordered from the +best-supported, are: + + * CMU Common Lisp (CMUCL), 19d or newer + * Steel Bank Common Lisp (SBCL), 1.0 or newer + * Clozure Common Lisp (CCL), version 1.3 or newer + * LispWorks, version 4.3 or newer + * Allegro Common Lisp (ACL), version 6 or newer + * CLISP, version 2.35 or newer + * Armed Bear Common Lisp (ABCL) + * Scieneer Common Lisp (SCL), version 1.2.7 or newer + * Embedded Common Lisp (ECL) + * ManKai Common Lisp (MKCL) + * Clasp + + Most features work uniformly across implementations, but some are +prone to variation. These include the precision of placing +compiler-note annotations, XREF support, and fancy debugger commands +(like "restart frame"). + + +File: sly.info, Node: Downloading, Next: Basic setup, Prev: Platforms, Up: Getting started + +2.2 Downloading SLY +=================== + +By far the easiest method for getting SLY up and running is using Emacs’ +package system configured to the popular MELPA repository. This snippet +of code should already be in your configuration: + + (add-to-list 'package-archives + '("melpa" . "https://melpa.org/packages/")) + (package-initialize) + + You should now be able to issue the command 'M-x package-install', +choose 'sly' and have it be downloaded and installed automatically. If +you don’t find it in the list, ensure you run 'M-x +package-refresh-contents' first. + + In other situations, such as when developing SLY itself, you can +access the Git repository directly: + + git clone https://github.com/joaotavora/sly.git + + If you want to hack on SLY, use Github's _fork_ functionality and +submit a _pull request_. Be sure to first read the CONTRIBUTING.md file +first. + + +File: sly.info, Node: Basic setup, Next: Running, Prev: Downloading, Up: Getting started + +2.3 Basic setup +=============== + +If you installed SLY from MELPA, it is quite possible that you don’t +need any more configuration, provided that SLY can find a suitable Lisp +executable in your 'PATH' environment variable. + + Otherwise, you need to tell it where a Lisp program can be found, so +customize the variable 'inferior-lisp-program' (*note Defcustom +variables::) or add a line like this one to your '~/.emacs' or +'~/.emacs.d/init.el' (*note Emacs Init File::). + + (setq inferior-lisp-program "/opt/sbcl/bin/sbcl") + + After evaluating this, you should be able to execute 'M-x sly' and be +greeted with a REPL. + + If you cloned from the Git repository, you’ll have to add a couple of +more lines to your initialization file configuration: + + (add-to-list 'load-path "~/dir/to/cloned/sly") + (require 'sly-autoloads) + + +File: sly.info, Node: Running, Next: Basic customization, Prev: Basic setup, Up: Getting started + +2.4 Running SLY +=============== + +SLY can either ask Emacs to start its own Lisp subprocesss or connect to +a running process on a local or remote machine. + + The first alternative is more common for local development and is +started via 'M-x sly'. The "inferior" Lisp process thus started is told +to load the Lisp-side server known as "Slynk" and then a socket +connection is established between Emacs and Lisp. Finally a REPL buffer +is created where you can enter Lisp expressions for evaluation. + + The second alternative uses 'M-x sly-connect'. This assumes that +that a Slynk server is running on some local or remote host, and +listening on a given port. 'M-x sly-connect' prompts the user for these +values, and upon connection the REPL is established. + + +File: sly.info, Node: Basic customization, Next: Multiple Lisps, Prev: Running, Up: Getting started + +2.5 Basic customization +======================= + +A big part of Emacs, and Emacs’s extensions, are its near-infinite +customization possibilities. SLY is no exception, because it runs on +both Emacs and the Lisp process, there are layers of Emacs-side +customization and Lisp-side customization. But don’t be put off by +this! SLY tries hard to provide sensible defaults that don’t "hide" any +fanciness beneath layers of complicated code, so that even a setup with +no customization at all exposes SLY’s most important functionality. + + Emacs-side customization is usually done via Emacs-lisp code snippets +added to the user’s initialization file, usually '$HOME/.emacs' or +'$HOME/.emacs.d/init.el' (*note Emacs Init File::). + + 90% of Emacs-lisp customization happens in either "keymaps" or +"hooks" (*note Emacs-side::). Still on the Emacs side, there is also a +separate interface, appropriately called 'customize' (or sometimes just +'custom'), that uses a nicer UI with mouse-clickable buttons to set some +special variables. See *Note Defcustom variables::. + + Lisp-side customization is done exclusively via Common Lisp code +snippets added to the user’s '$HOME/.slynkrc' file. See *Note Lisp-side +customization::. + + As a preview, take this simple example of a frequently customized +part of SLY: its keyboard shortcuts, known as "keybindings". In the +following snippet 'M-h' is added to 'sly-prefix-map' thus yielding 'C-c +M-h' as a shortcut to the 'sly-documentation-lookup' command. + + (eval-after-load 'sly + `(define-key sly-prefix-map (kbd "M-h") 'sly-documentation-lookup)) + + +File: sly.info, Node: Multiple Lisps, Prev: Basic customization, Up: Getting started + +2.6 Multiple Lisps +================== + +By default, the command 'M-x sly' starts the program specified with +'inferior-lisp-program', a variable that you can customize (*note +Defcustom variables::). However, if you invoke 'M-x sly' with a _prefix +argument_, meaning you type 'C-u M-x sly' then Emacs prompts for the +program which should be started instead. + + If you need to do this frequently or if the command involves long +filenames it's more convenient to set the 'sly-lisp-implementations' +variable in your initialization file (*note Emacs Init File::). For +example here we define two programs: + + (setq sly-lisp-implementations + '((cmucl ("cmucl" "-quiet")) + (sbcl ("/opt/sbcl/bin/sbcl") :coding-system utf-8-unix))) + + Now, if you invoke SLY with a _negative_ prefix argument, 'M-- M-x +sly', you can select a program from that list. When called without a +prefix, either the name specified in 'sly-default-lisp', or the first +item of the list will be used. The elements of the list should look +like + + (NAME (PROGRAM PROGRAM-ARGS...) &key CODING-SYSTEM INIT INIT-FUNCTION ENV) + +'NAME' + is a symbol and is used to identify the program. +'PROGRAM' + is the filename of the program. Note that the filename can contain + spaces. +'PROGRAM-ARGS' + is a list of command line arguments. +'CODING-SYSTEM' + the coding system for the connection. (*note + sly-net-coding-system::)x +'INIT' + should be a function which takes two arguments: a filename and a + character encoding. The function should return a Lisp expression + as a string which instructs Lisp to start the Slynk server and to + write the port number to the file. At startup, SLY starts the Lisp + process and sends the result of this function to Lisp's standard + input. As default, 'sly-init-command' is used. An example is + shown in *note Loading Slynk faster: init-example. +'INIT-FUNCTION' + should be a function which takes no arguments. It is called after + the connection is established. (See also *note + sly-connected-hook::.) +'ENV' + specifies a list of environment variables for the subprocess. E.g. + (sbcl-cvs ("/home/me/sbcl-cvs/src/runtime/sbcl" + "--core" "/home/me/sbcl-cvs/output/sbcl.core") + :env ("SBCL_HOME=/home/me/sbcl-cvs/contrib/")) + initializes 'SBCL_HOME' in the subprocess. + + +File: sly.info, Node: A SLY tour for SLIME users, Next: Working with source files, Prev: Getting started, Up: Top + +3 A SLY tour for SLIME users +**************************** + +The chances are that if you’re into Common Lisp, you already know about +SLIME, the project that originated SLY. Itself originating in older +Emacs extensions SLIM and ILISP, SLIME has been around for at least a +decade longer than SLY and is quite an amazing IDE. It's likely that +most Lispers have some experience with it, making it a good idea to +provide, in the shape of a quick tutorial, a hands-on overview of some +of the improvements of SLY over SLIME. + + When you start SLY with 'M-x sly' (*note Basic setup::) you are +greeted with its REPL, a common starting point of Lisp hacking sessions. +This has been completely redesigned in SLY: you can spawn multiple REPL +sessions with 'sly-mrepl-new'; copy objects from most places directly +into it (with 'M-RET' and 'M-S-RET'); use powerful incremental history +search (with 'C-r') found in most modern shells; and get real-time +assistance when "backreferecing" previous evaluation values in your Lisp +input. + + + + + + Starting from the new REPL, let's showcase some of SLY’s features. +Let’s pretend we want to hack an existing Lisp project. We'll pick SLY +itself, or rather its Lisp server, called Slynk. Let's pretend we're +intrigued by the way its "flex"-style completion works. What is flex +completion, you ask? Well, if you're at the REPL you can try it now: +it's a way of 'TAB'-completing (*note Completion::) symbol names based +on educated guesses of a few letters. Thus if we type 'mvbind', SLY +guesses that we probably meant 'multiple-value-bind', and if we type +'domat' it might possibly guess 'cl-ppcre:do-matches'. Let's dig into +the code that makes this happen. + + But how? Where to begin, given we know so little about this project? + + Well, a good starting point is always the _apropos_ functionality, +which is a 'grep' of sorts, but aware of the symbols loaded in your +Lisp, rather the contents of text files. Furthermore, in SLY, +'sly-apropos' will do a regular-expression-enabled symbol search, which +will help us here since we don't yet know any symbols names of this +mysterious flex feature. + + To enable regular expression searches you need the 'CL-PPCRE' library +is loaded (else 'sly-apropos' falls back to regex-less mode). If you +have Quicklisp (https://www.quicklisp.org/beta/) installed (you do, +right?) you need only type '(ql:quickload :cl-ppcre)' now from the +REPL. + + Thus, if we want to hack SLY's flex completion, and _don't_ known any +of its symbol's names, we type 'C-c C-d C-z' (the shortcut for 'M-x +sly-apropos-all') and then type in "sly.*flex" at the prompt. We follow +with 'enter' or 'return' (abbreviated 'RET' or 'C-m'). SLY should now +present all Lisp symbols matching your search pattern. + + + + + + In the 'apropos' buffer, let’s grab the mouse and right-click the +symbol 'SLYNK-COMPLETIONS:FLEX-COMPLETIONS'. We’ll be presented with a +context menu with options for describing the symbol, inspecting it, or +navigating to its source definition. In general, the Lisp-side objects +that SLY presents -- symbols, CLOS objects, function calls, etc... -- +are right-clickable buttons with such a context menu (*note Interactive +objects::). For now, let’s navigate to the source definition of the +symbol by choosing "Go To source" from the menu. Alternatively, we +could also have just pressed 'M-.' on the symbol, of course. + + From the Lisp source buffer that we landed on (probably +'slynk-completion.lisp'), let’s _trace_ the newly found function +'SLYNK-COMPLETIONS:FLEX-COMPLETIONS'. However, instead of using the +regular 'CL:TRACE', we’ll use SLY’s Trace Dialog functionality. This is +how we set it up: + + 1. first type 'C-c C-t' on the function’s name, or enter that in the + minibuffer prompt; + + 2. now, open the Trace Dialog in a new window by typing 'C-c T' + (that’s a capital 'T'). We should already see our traced function + under the heading "Traced specs"; + + 3. thirdly, for good measure, let’s also trace the nearby function + 'SLYNK-COMPLETIONS::FLEX-SCORE' by also typing 'C-c C-t' on its + name, or just entering it in the minibuffer prompt. + + Now let’s return to the REPL by switching to its '*sly-mrepl ...' +buffer or typing 'C-c C-z'. To exercise the code we just traced, let’s +type something like 'desbind', followed by tab, and see if it suggest +'destructuring-bind' as the top match. We could now select some +completion from the list, but instead let's just type 'C-g' to dismiss +the completion, since we wanted to test completion, not write any actual +'destructuring-bind' expression. + + Remember the traced functions in the Trace Dialog? Time to see if we +got any traces. let's type 'C-c T' to switch to that buffer, and then +type capital 'G'. This should produce a fair number of traces organized +in a call graph. + + + + + + We can later learn more about this mode (*note Trace Dialog::), but +for now let’s again pretend we expected the function 'FLEX-SCORE' to +return a wildly different score for 'COMMON-LISP:DESTRUCTURING-BIND'. +In that case we should like to witness said 'FLEX-SCORE' function +respond to any implementation improvements we perform. To do so, it's +useful to be able to surgically re-run that function with those very +same arguments. Let's do this by finding the function call in the Trace +Dialog window, right-clicking it with the mouse and selecting "Copy call +to REPL". Pressing 'M-S-RET' on it should accomplish the same. We are +automatically transported to the REPL again, where the desired function +call has already been typed out for us at the command prompt, awaiting a +confirmation 'RET', which will run the function call: + + ; The actual arguments passed to trace 15 + "desbind" + "COMMON-LISP:DESTRUCTURING-BIND" + (12 13 14 26 27 28 29) + SLYNK-COMPLETION> (slynk-completion::flex-score #v1:0 #v1:1 #v1:2) + 0.003030303 (0.30303028%) + SLYNK-COMPLETION> + + + + + + If those '#v...''s look odd, here’s what’s going on: to copy the call +to the REPL, SLY first copied over its actual arguments, and then wrote +the function using special _backreferences_ to those arguments in the +correct place. These are the '#v4:0' and '#v4:1' bits seen at the +command prompt. If one puts the cursor on them or hovers with the +mouse, this highlights the corresponding object a few lines above in the +buffer. Later, you can also try typing "#v" at the REPL to +incrementally write your own backreferences (*note REPL +backreferences::). + + For one final demonstration, let’s now suppose say we are still +intrigued by how that function ('FLEX-SCORE') works internally. So +let's navigate to its definition using 'M-.' again (or just open the +'slynk-completion.lisp' buffer that you probably still have open). The +function’s code might look like this: + + (defun flex-score (pattern string indexes) + "Score the match of PATTERN on STRING. + INDEXES as calculated by FLEX-MATCHES" + ;; FIXME: hideously naive scoring + (declare (ignore pattern)) + (float + (/ 1 + (* (length string) + (max 1 + (reduce #'+ + (loop for (a b) on indexes + while b + collect (- b a 1)))))))) + + Can this function be working correctly? What do all those +expressions return? Should we reach for good old C-style 'printf'? +Let's try "stickers" instead. SLY's stickers are a form of +non-intrusive function instrumentation that work like carefully crafted +'print' or '(format t ...)'), but are much easier to work with. You can +later read more about them (*note Stickers::), but for now you can just +think of them as colorful labels placed on s-exp’s. Let’s place a bunch +here, like this: + + 1. on the last line of 'flex-score', place your cursor on the first + open parenthesis of that line (the opening parenthesis of the + expression '(- b a 1)') and press 'C-c C-s C-s'; + + 2. now do the same for the symbol 'indexes' a couple of lines above; + + 3. again, the same for the expressions '(loop...)', '(reduce...)', + '(max...)', '(length...)', '(*...)', '(/... )' and '(float...)'. + You could have done this in any order, by the way; + + Now let’s recompile this definition with 'C-c C-c'. Beside the +minibuffer note something about stickers being "armed" our function +should now look like a rainbow in blue. + + + + + + Now we return to the SLY REPL, but this time let’s use 'C-c ~' +(that’s 'C-c' followed by "tilde") to do so. This syncs the REPL’s +local package and local directory to the Lisp file that we’re visiting. +This is something not strictly necessary here but generally convenient +when hacking on a system, because you can now call functions from the +file you came from without package-qualification. + + Now, to re-run the newly instrumented function, by calling it with +the same arguments. No need to type all that again, because this REPL +supports reverse history i-search, remember? So just type the binding +'C-r' and then type something like 'scor' to search history backwards +and arrive at the function call copied to the REPL earlier. Type 'RET' +once to confirm that's the call your after, and 'RET' again to evaluate +it. Because those '#v...' backreferences are still trained specifically +on those very same function arguments, you can be sure that the function +call is equivalent. + + We can now use the 'C-c C-s C-r' to _replay_ the sticker recordings +of this last function call. This is a kind of slow walk-through +conducted in separate navigation window called '*sly-stickers-replay*' +which pops up. There we can see the Lisp value(s) that each sticker +'eval'’ed to each time (or a note if it exited non-locally). We can +navigate recordings with 'n' and 'p', and do the usual things allowed by +interactive objects like inspecting them and returning them to the REPL. +If you need help, toggle help by typing 'h'. There are lots of options +here for navigating stickers, ignoring some stickers, etc. When we’re +done in this window, we press 'q' to quit. + + + + + + Finally, we declare that we’re finished debugging 'FLEX-MATCHES'. +Even though stickers don’t get saved to the file in any way, we decide +we’re not interested in them anymore. So let’s open the "SLY" menu in +the menu bar, find the "Delete stickers from top-level form" option +under the "Stickers" sub-menu, and click it. Alternatively, we could +have typed 'C-u C-c C-s C-s'. + + +File: sly.info, Node: Working with source files, Next: Common functionality, Prev: A SLY tour for SLIME users, Up: Top + +4 Working with source files +*************************** + +SLY's commands when editing a Lisp file are provided via +'sly-editing-mode', a minor-mode used in conjunction with Emacs's +'lisp-mode'. + + This chapter describes SLY’s commands for editing and working in Lisp +source buffers. There are, of course, more SLY’s commands that also +apply to these buffers (*note Common functionality::), but with very few +exceptions these commands will always be run from a '.lisp' file. + +* Menu: + +* Evaluation:: +* Compilation:: +* Autodoc:: +* Semantic indentation:: +* Reader conditionals:: +* Macro-expansion:: + + +File: sly.info, Node: Evaluation, Next: Compilation, Up: Working with source files + +4.1 Evaluating code +=================== + +These commands each evaluate a Common Lisp expression in a different +way. Usually they mimic commands for evaluating Emacs Lisp code. By +default they show their results in the echo area, but a prefix argument +'C-u' inserts the results into the current buffer, while a negative +prefix argument 'M--' sends them to the kill ring. + +'C-x C-e' +'M-x sly-eval-last-expression' + + Evaluate the expression before point and show the result in the + echo area. + +'C-M-x' +'M-x sly-eval-defun' + Evaluate the current toplevel form and show the result in the echo + area. 'C-M-x' treats 'defvar' expressions specially. Normally, + evaluating a 'defvar' expression does nothing if the variable it + defines already has a value. But 'C-M-x' unconditionally resets + the variable to the initial value specified in the 'defvar' + expression. This special feature is convenient for debugging Lisp + programs. + + If 'C-M-x' or 'C-x C-e' is given a numeric argument, it inserts the +value into the current buffer, rather than displaying it in the echo +area. + +'C-c :' +'M-x sly-interactive-eval' + Evaluate an expression read from the minibuffer. + +'C-c C-r' +'M-x sly-eval-region' + Evaluate the region. + +'C-c C-p' +'M-x sly-pprint-eval-last-expression' + Evaluate the expression before point and pretty-print the result in + a fresh buffer. + +'C-c E' +'M-x sly-edit-value' + Edit the value of a setf-able form in a new buffer '*Edit <form>*'. + The value is inserted into a temporary buffer for editing and then + set in Lisp when committed with 'C-c C-c'. + +'C-c C-u' +'M-x sly-undefine-function' + Undefine the function, with 'fmakunbound', for the symbol at point. + + +File: sly.info, Node: Compilation, Next: Autodoc, Prev: Evaluation, Up: Working with source files + +4.2 Compiling functions and files +================================= + +SLY has fancy commands for compiling functions, files, and packages. +The fancy part is that notes and warnings offered by the Lisp compiler +are intercepted and annotated directly onto the corresponding +expressions in the Lisp source buffer. (Give it a try to see what this +means.) + +'C-c C-c' +'M-x sly-compile-defun' + Compile the top-level form at point. The region blinks shortly to + give some feedback which part was chosen. + + With (positive) prefix argument the form is compiled with maximal + debug settings ('C-u C-c C-c'). With negative prefix argument it + is compiled for speed ('M-- C-c C-c'). If a numeric argument is + passed set debug or speed settings to it depending on its sign. + + The code for the region is executed after compilation. In + principle, the command writes the region to a file, compiles that + file, and loads the resulting code. + + This compilation may arm stickers (*note Stickers::). + +'C-c C-k' +'M-x sly-compile-and-load-file' + Compile and load the current buffer's source file. If the + compilation step fails, the file is not loaded. It's not always + easy to tell whether the compilation failed: occasionally you may + end up in the debugger during the load step. + + With (positive) prefix argument the file is compiled with maximal + debug settings ('C-u C-c C-k'). With negative prefix argument it + is compiled for speed ('M-- C-c C-k'). If a numeric argument is + passed set debug or speed settings to it depending on its sign. + + This compilation may arm stickers (*note Stickers::). + +'C-c M-k' +'M-x sly-compile-file' + Compile (but don't load) the current buffer's source file. + +'C-c C-l' +'M-x sly-load-file' + Load a Lisp file. This command uses the Common Lisp LOAD function. + +'M-x sly-compile-region' + Compile the selected region. + + This compilation may arm stickers (*note Stickers::). + + The annotations are indicated as underlining on source forms. The +compiler message associated with an annotation can be read either by +placing the mouse over the text or with the selection commands below. + +'M-n' +'M-x sly-next-note' + Move the point to the next compiler note and displays the note. + +'M-p' +'M-x sly-previous-note' + Move the point to the previous compiler note and displays the note. + +'C-c M-c' +'M-x sly-remove-notes' + Remove all annotations from the buffer. + +'C-x `' +'M-x next-error' + Visit the next-error message. This is not actually a SLY command + but SLY creates a hidden buffer so that most of the Compilation + mode commands (*note (emacs)Compilation Mode::) work similarly for + Lisp as for batch compilers. + + +File: sly.info, Node: Autodoc, Next: Semantic indentation, Prev: Compilation, Up: Working with source files + +4.3 Autodoc +=========== + +SLY automatically shows information about symbols near the point. For +function names the argument list is displayed, and for global variables, +the value. Autodoc is implemented by means of 'eldoc-mode' of Emacs. + +'M-x sly-arglist NAME' + Show the argument list of the function NAME. + +'M-x sly-autodoc-mode' + Toggles autodoc-mode on or off according to the argument, and + toggles the mode when invoked without argument. +'M-x sly-autodoc-manually' + Like sly-autodoc, but when called twice, or after sly-autodoc was + already automatically called, display multiline arglist. + + If 'sly-autodoc-use-multiline-p' is set to non-nil, allow long +autodoc messages to resize echo area display. + + 'autodoc-mode' is a SLY extension and can be turned off if you so +wish (*note Extensions::) + + +File: sly.info, Node: Semantic indentation, Next: Reader conditionals, Prev: Autodoc, Up: Working with source files + +4.4 Semantic indentation +======================== + +SLY automatically discovers how to indent the macros in your Lisp +system. To do this the Lisp side scans all the macros in the system and +reports to Emacs all the ones with '&body' arguments. Emacs then +indents these specially, putting the first arguments four spaces in and +the "body" arguments just two spaces, as usual. + + This should "just work." If you are a lucky sort of person you +needn't read the rest of this section. + + To simplify the implementation, SLY doesn't distinguish between +macros with the same symbol-name but different packages. This makes it +fit nicely with Emacs's indentation code. However, if you do have +several macros with the same symbol-name then they will all be indented +the same way, arbitrarily using the style from one of their arglists. +You can find out which symbols are involved in collisions with: + + (slynk:print-indentation-lossage) + + If a collision causes you irritation, don't have a nervous breakdown, +just override the Elisp symbol's 'sly-common-lisp-indent-function' +property to your taste. SLY won't override your custom settings, it +just tries to give you good defaults. + + A more subtle issue is that imperfect caching is used for the sake of +performance. (1) + + In an ideal world, Lisp would automatically scan every symbol for +indentation changes after each command from Emacs. However, this is too +expensive to do every time. Instead Lisp usually just scans the symbols +whose home package matches the one used by the Emacs buffer where the +request comes from. That is sufficient to pick up the indentation of +most interactively-defined macros. To catch the rest we make a full +scan of every symbol each time a new Lisp package is created between +commands - that takes care of things like new systems being loaded. + + You can use 'M-x sly-update-indentation' to force all symbols to be +scanned for indentation information. + + ---------- Footnotes ---------- + + (1) _Of course_ we made sure it was actually too slow before making +the ugly optimization. + + +File: sly.info, Node: Reader conditionals, Next: Macro-expansion, Prev: Semantic indentation, Up: Working with source files + +4.5 Reader conditional fontification +==================================== + +SLY automatically evaluates reader-conditional expressions, like +'#+linux', in source buffers and "grays out" code that will be skipped +for the current Lisp connection. + + +File: sly.info, Node: Macro-expansion, Prev: Reader conditionals, Up: Working with source files + +4.6 Macro-expansion commands +============================ + +'C-c C-m' +'M-x sly-expand-1' + Macroexpand (or compiler-macroexpand) the expression at point once. + If invoked with a prefix argument use macroexpand instead or + macroexpand-1 (or compiler-macroexpand instead of + compiler-macroexpand-1). + +'M-x sly-macroexpand-1' + Macroexpand the expression at point once. If invoked with a prefix + argument, use macroexpand instead of macroexpand-1. + +'C-c M-m' +'M-x sly-macroexpand-all' + Fully macroexpand the expression at point. + +'M-x sly-compiler-macroexpand-1' + Display the compiler-macro expansion of sexp at point. + +'M-x sly-compiler-macroexpand' + Repeatedly expand compiler macros of sexp at point. + +'M-x sly-format-string-expand' + Expand the format-string at point and display it. With prefix arg, + or if no string at point, prompt the user for a string to expand. + + Within a sly macroexpansion buffer some extra commands are provided +(these commands are always available but are only bound to keys in a +macroexpansion buffer). + +'C-c C-m' +'M-x sly-macroexpand-1-inplace' + Just like sly-macroexpand-1 but the original form is replaced with + the expansion. + +'g' +'M-x sly-macroexpand-1-inplace' + The last macroexpansion is performed again, the current contents of + the macroexpansion buffer are replaced with the new expansion. + +'q' +'M-x sly-temp-buffer-quit' + Close the expansion buffer. + +'C-_' +'M-x sly-macroexpand-undo' + Undo last macroexpansion operation. + + +File: sly.info, Node: Common functionality, Next: The REPL and other special buffers, Prev: Working with source files, Up: Top + +5 Common functionality +********************** + +This chapter describes the commands available throughout SLY-enabled +buffers, which are not only Lisp source buffers, but every auxiliary +buffer created by SLY, such as the REPL, Inspector, etc (*note The REPL +and other special buffers::) In general, it’s a good bet that if the +buffer’s name starts with '*sly-...*', these commands and functionality +will be available there. + +* Menu: + +* Finding definitions:: +* Cross-referencing:: +* Completion:: +* Interactive objects:: +* Documentation:: +* Multiple connections:: +* Disassembly:: +* Recovery:: +* Temporary buffers:: +* Multi-threading:: + + +File: sly.info, Node: Finding definitions, Next: Cross-referencing, Up: Common functionality + +5.1 Finding definitions +======================= + +One of the most used keybindings across all of SLY is the familiar 'M-.' +binding for 'sly-edit-definition'. + + Here's the gist of it: when pressed with the cursor over a symbol +name, that symbol's name definition is looked up by the Lisp process, +thus producing a Lisp source location, which might be a file, or a +file-less buffer. For convenience, a type of "breadcrumb" is left +behind at the original location where 'M-.' was pressed, so that another +keybinding 'M-,' takes the user back to the original location. Thus +multiple 'M-.' trace a path through lisp sources that can be traced back +with an equal number of 'M-,'. + +'M-.' +'M-x sly-edit-definition' + Go to the definition of the symbol at point. + +'M-,' +'M-*' +'M-x sly-pop-find-definition-stack' + Go back to the point where 'M-.' was invoked. This gives + multi-level backtracking when 'M-.' has been used several times. + +'C-x 4 .' +'M-x sly-edit-definition-other-window' + Like 'sly-edit-definition' but switches to the other window to edit + the definition in. + +'C-x 5 .' +'M-x sly-edit-definition-other-frame' + Like 'sly-edit-definition' but opens another frame to edit the + definition in. + + The behaviour of the 'M-.' binding is sometimes affected by the type +of symbol you are giving it. + + * For single functions or variables, 'M-.' immediately switches the + current window's buffer and position to the target 'defun' or + 'defvar'. + + * For symbols with more than one associated definition, say, generic + functions, the same 'M-.' finds all methods and presents these + results in separate window displaying a special '*sly-xref*' buffer + (*note Cross-referencing::). + + +File: sly.info, Node: Cross-referencing, Next: Completion, Prev: Finding definitions, Up: Common functionality + +5.2 Cross-referencing +===================== + +Finding and presenting the definition of a function is actually the most +elementary aspect of broader _cross-referencing_ facilities framework in +SLY. There are other types of questions about the source code relations +that you can ask the Lisp process.(1) + + The following keybindings behave much like the 'M-.' keybinding +(*note Finding definitions::): when pressed as is they make a query +about the symbol at point, but with a 'C-u' prefix argument they prompt +the user for a symbol. Importantly, they always popup a transient +'*sly-xref*' buffer in a different window. + +'M-?' +'M-x sly-edit-uses' + Find all the references to this symbol, whatever the type of that + reference. + +'C-c C-w C-c' +'M-x sly-who-calls' + Show function callers. + +'C-c C-w C-w' +'M-x sly-calls-who' + Show all known callees. + +'C-c C-w C-r' +'M-x sly-who-references' + Show references to global variable. + +'C-c C-w C-b' +'M-x sly-who-binds' + Show bindings of a global variable. + +'C-c C-w C-s' +'M-x sly-who-sets' + Show assignments to a global variable. + +'C-c C-w C-m' +'M-x sly-who-macroexpands' + Show expansions of a macro. + +'M-x sly-who-specializes' + Show all known methods specialized on a class. + + There are two further "List callers/callees" commands that operate by +rummaging through function objects on the heap at a low-level to +discover the call graph. They are only available with some Lisp +systems, and are most useful as a fallback when precise XREF information +is unavailable. + +'C-c <' +'M-x sly-list-callers' + List callers of a function. + +'C-c >' +'M-x sly-list-callees' + List callees of a function. + + In the resulting '*sly-xref*' buffer, these commands are available: + +'RET' +'M-x sly-show-xref' + Show definition at point in the other window. Do not leave the + '*sly-xref' buffer. + +'Space' +'M-x sly-goto-xref' + Show definition at point in the other window and close the + '*sly-xref' buffer. + +'C-c C-c' +'M-x sly-recompile-xref' + Recompile definition at point. Uses prefix arguments like + 'sly-compile-defun'. + +'C-c C-k' +'M-x sly-recompile-all-xrefs' + Recompile all definitions. Uses prefix arguments like + 'sly-compile-defun'. + + ---------- Footnotes ---------- + + (1) This depends on the underlying implementation of some of these +facilities: for systems with no built-in XREF support SLY queries a +portable XREF package, which is taken from the 'CMU AI Repository' and +bundled with SLY. + + +File: sly.info, Node: Completion, Next: Interactive objects, Prev: Cross-referencing, Up: Common functionality + +5.3 Auto-completion +=================== + +Completion commands are used to complete a symbol or form based on what +is already present at point. Emacs has many completion mechanisms that +SLY tries to mimic as much as possible. + + SLY provides two styles of completion. The choice between them +happens in the Emacs customization variable *note +sly-complete-symbol-function::, which can be set to two values, or +methods: + + 1. 'sly-flex-completions' This method is speculative. It assumes that + the letters you've already typed aren't necessarily an exact prefix + of the symbol you're thinking of. Therefore, any possible + completion that contains these letters, in the order that you have + typed them, is potentially a match. Completion matches are then + sorted according to a score that should reflect the probability + that you really meant that them. + + Flex completion implies that the package-qualification needed to + access some symbols is automatically discovered for you. However, + to avoid searching too many symbols unnecessarily, this method + makes some minimal assumptions that you can override: it assumes, + for example, that you don't normally want to complete to fully + qualified internal symbols, but will do so if it finds two + consecutive colons ('::') in your initial pattern. Similarly, it + assumes that if you start a completion on a word starting ':', you + must mean a keyword (a symbol from the keyword package.) + + Here are the top results for some typical searches. + + CL-USER> (quiloa<TAB>) -> (ql:quickload) + CL-USER> (mvbind<TAB>) -> (multiple-value-bind) + CL-USER> (scan<TAB>) -> (ppcre:scan) + CL-USER> (p::scan<TAB>) -> (ppcre::scanner) + CL-USER> (setf locadirs<TAB>) -> (setf ql:*local-project-directories*) + CL-USER> foobar -> asdf:monolithic-binary-op + + 2. 'sly-simple-completions' This method uses "classical" completion on + an exact prefix. Although poorer, this is simpler, more + predictable and closer to the default Emacs completion method. You + type a prefix for a symbol reference and SLY let's you choose from + symbols whose beginnings match it exactly. + + As an enhancement in SLY over Emacs' built-in completion styles, when +the '*sly-completions*' buffer pops up, some keybindings are momentarily +diverted to it: + +'C-n' +'<down>' +'M-x sly-next-completion' + Select the next completion. + +'C-p' +'<up>' +'M-x sly-prev-completion' + Select the previous completion. + +'tab' +'RET' +'M-x sly-choose-completion' + Choose the currently selected completion and enter it at point. + + As soon as the user selects a completion or gives up by pressing +'C-g' or moves out of the symbol being completed, the +'*sly-completions*' buffer is closed. + + +File: sly.info, Node: Interactive objects, Next: Documentation, Prev: Completion, Up: Common functionality + +5.4 Interactive objects +======================= + +In many buffers and modes in SLY, there are snippets of text that +represent objects "living" in the Lisp process connected to SLY. These +regions are known in SLY as interactive values or objects. You can tell +these objects from regular text by their distinct "face", is Emacs +parlance for text colour, or decoration. Another way to check if bit of +text is an interactive object is to hover above it with the mouse and +right-click ('<mouse-3>') it: a context menu will appear listing actions +that you can take on that object. + + Depending on the mode, different actions may be active for different +types of objects. Actions can also be invoked using keybindings active +only when the cursor is on the button. + +'M-RET, ``Copy to REPL''' + + Copy the object to the main REPL (*note REPL output:: and *note + REPL backreferences::). + +'M-S-RET, ``Copy call to REPL''' + + An experimental feature. On some backtrace frames in the Debugger + (*note Debugger::) and Trace Dialog (*note Trace Dialog::), copy + the object to the main REPL. That’s _meta-shift-return_, by the + way, there’s no capital "S". + +'.,''Go To Source''' + + For function symbols, debugger frames, or traced function calls, go + to the Lisp source, much like with 'M-.'. + +'v,''Show Source''' + + For function symbols, debugger frames, or traced function calls, + show the Lisp source in another window, but don’t switch to it. + +'p,''Pretty Print''' + + Pretty print the object in a separate buffer, much like + 'sly-pprint-eval-last-expression'. + +'i,''Inspect''' + + Inspect the object in a separate inspector buffer (*note + Inspector::). + +'d,''Describe''' + + Describe the object in a separate buffer using Lisp’s + 'CL:DESCRIBE'. + + +File: sly.info, Node: Documentation, Next: Multiple connections, Prev: Interactive objects, Up: Common functionality + +5.5 Documentation commands +========================== + +SLY's online documentation commands follow the example of Emacs Lisp. +The commands all share the common prefix 'C-c C-d' and allow the final +key to be modified or unmodified (*note Keybindings::.) + +'M-x sly-info' + This command should land you in an electronic version of this very + manual that you can read inside Emacs. + +'C-c C-d C-d' +'M-x sly-describe-symbol' + Describe the symbol at point. + +'C-c C-d C-f' +'M-x sly-describe-function' + Describe the function at point. + +'C-c C-d C-a' +'M-x sly-apropos' + Perform an apropos search on Lisp symbol names for a regular + expression match and display their documentation strings. By + default the external symbols of all packages are searched. With a + prefix argument you can choose a specific package and whether to + include unexported symbols. + +'C-c C-d C-z' +'M-x sly-apropos-all' + Like 'sly-apropos' but also includes internal symbols by default. + +'C-c C-d C-p' +'M-x sly-apropos-package' + Show apropos results of all symbols in a package. This command is + for browsing a package at a high-level. With package-name + completion it also serves as a rudimentary Smalltalk-ish + image-browser. + +'C-c C-d C-h' +'M-x sly-hyperspec-lookup' + Lookup the symbol at point in the 'Common Lisp Hyperspec'. This + uses the familiar 'hyperspec.el' to show the appropriate section in + a web browser. The Hyperspec is found either on the Web or in + 'common-lisp-hyperspec-root', and the browser is selected by + 'browse-url-browser-function'. + + Note: this is one case where 'C-c C-d h' is _not_ the same as 'C-c + C-d C-h'. + +'C-c C-d ~' +'M-x hyperspec-lookup-format' + Lookup a _format character_ in the 'Common Lisp Hyperspec'. + +'C-c C-d #' +'M-x hyperspec-lookup-reader-macro' + Lookup a _reader macro_ in the 'Common Lisp Hyperspec'. + + +File: sly.info, Node: Multiple connections, Next: Disassembly, Prev: Documentation, Up: Common functionality + +5.6 Multiple connections +======================== + +SLY is able to connect to multiple Lisp processes at the same time. The +'M-x sly' command, when invoked with a prefix argument, will offer to +create an additional Lisp process if one is already running. This is +often convenient, but it requires some understanding to make sure that +your SLY commands execute in the Lisp that you expect them to. + + Some SLY buffers are tied to specific Lisp processes. It’s easy read +that from the buffer’s name which will usually be '*sly-<something> for +<connection>*', where 'connection' is the name of the connection. + + Each Lisp connection has its own main REPL buffer (*note REPL::), and +all expressions entered or SLY commands invoked in that buffer are sent +to the associated connection. Other buffers created by SLY are +similarly tied to the connections they originate from, including SLY-DB +buffers (*note Debugger::), apropos result listings, and so on. These +buffers are the result of some interaction with a Lisp process, so +commands in them always go back to that same process. + + Commands executed in other places, such as 'sly-mode' source buffers, +always use the "default" connection. Usually this is the most recently +established connection, but this can be reassigned via the "connection +list" buffer: + +'C-c C-x c' +'M-x sly-list-connections' + Pop up a buffer listing the established connections. + +'C-c C-x n' +'M-x sly-next-connection' + Switch to the next Lisp connection by cycling through all + connections. + +'C-c C-x p' +'M-x sly-prev-connection' + Switch to the previous Lisp connection by cycling through all + connections. + + The buffer displayed by 'sly-list-connections' gives a one-line +summary of each connection. The summary shows the connection's serial +number, the name of the Lisp implementation, and other details of the +Lisp process. The current "default" connection is indicated with an +asterisk. + + The commands available in the connection-list buffer are: + +'RET' +'M-x sly-goto-connection' + Pop to the REPL buffer of the connection at point. + +'d' +'M-x sly-connection-list-make-default' + Make the connection at point the "default" connection. It will + then be used for commands in 'sly-mode' source buffers. + +'g' +'M-x sly-update-connection-list' + Update the connection list in the buffer. + +'q' +'M-x sly-temp-buffer-quit' + Quit the connection list (kill buffer, restore window + configuration). + +'R' +'M-x sly-restart-connection-at-point' + Restart the Lisp process for the connection at point. + +'M-x sly-connect' + Connect to a running Slynk server. With prefix argument, asks if + all connections should be closed first. + +'M-x sly-disconnect' + Disconnect all connections. + +'M-x sly-abort-connection' + Abort the current attempt to connect. + + +File: sly.info, Node: Disassembly, Next: Recovery, Prev: Multiple connections, Up: Common functionality + +5.7 Disassembly commands +======================== + +'C-c M-d' +'M-x sly-disassemble-symbol' + Disassemble the function definition of the symbol at point. + +'C-c C-t' +'M-x sly-toggle-trace-fdefinition' + Toggle tracing of the function at point. If invoked with a prefix + argument, read additional information, like which particular method + should be traced. + +'M-x sly-untrace-all' + Untrace all functions. + + +File: sly.info, Node: Recovery, Next: Temporary buffers, Prev: Disassembly, Up: Common functionality + +5.8 Abort/Recovery commands +=========================== + +'C-c C-b' +'M-x sly-interrupt' + Interrupt Lisp (send 'SIGINT'). + +'M-x sly-restart-inferior-lisp' + Restart the 'inferior-lisp' process. + +'C-c ~' +'M-x sly-mrepl-sync' + Synchronize the current package and working directory from Emacs to + Lisp. + +'M-x sly-cd' + Set the current directory of the Lisp process. This also changes + the current directory of the REPL buffer. + +'M-x sly-pwd' + Print the current directory of the Lisp process. + + +File: sly.info, Node: Temporary buffers, Next: Multi-threading, Prev: Recovery, Up: Common functionality + +5.9 Temporary buffers +===================== + +Some SLY commands create temporary buffers to display their results. +Although these buffers usually have their own special-purpose +major-modes, certain conventions are observed throughout. + + Temporary buffers can be dismissed by pressing 'q'. This kills the +buffer and restores the window configuration as it was before the buffer +was displayed. Temporary buffers can also be killed with the usual +commands like 'kill-buffer', in which case the previous window +configuration won't be restored. + + Pressing 'RET' is supposed to "do the most obvious useful thing." +For instance, in an apropos buffer this prints a full description of the +symbol at point, and in an XREF buffer it displays the source code for +the reference at point. This convention is inherited from Emacs's own +buffers for apropos listings, compilation results, etc. + + Temporary buffers containing Lisp symbols use 'sly-mode' in addition +to any special mode of their own. This makes the usual SLY commands +available for describing symbols, looking up function definitions, and +so on. + + Initial focus of those "description" buffers depends on the variable +'sly-description-autofocus'. If 'nil' (the default), description +buffers do not receive focus automatically, and vice versa. + + +File: sly.info, Node: Multi-threading, Prev: Temporary buffers, Up: Common functionality + +5.10 Multi-threading +==================== + +If the Lisp system supports multi-threading, SLY spawns a new thread for +each request, e.g., 'C-x C-e' creates a new thread to evaluate the +expression. An exception to this rule are requests from the REPL: all +commands entered in the REPL buffer are evaluated in a dedicated REPL +thread. + + You can see a listing of the threads for the current connection with +the command 'M-x sly-list-threads', or 'C-c C-x t'. This pops open a +'*sly-threads*' buffer, where some keybindings to control threads are +active, if you know what you are doing. The most useful is probably 'k' +to kill a thread, but type 'C-h m' in that buffer to get a full listing. + + Some complications arise with multi-threading and special variables. +Non-global special bindings are thread-local, e.g., changing the value +of a let bound special variable in one thread has no effect on the +binding of the variables with the same name in other threads. This +makes it sometimes difficult to change the printer or reader behaviour +for new threads. The variable 'slynk:*default-worker-thread-bindings*' +was introduced for such situations: instead of modifying the global +value of a variable, add a binding the +'slynk:*default-worker-thread-bindings*'. E.g., with the following +code, new threads will read floating point values as doubles by default: + + (push '(*read-default-float-format* . double-float) + slynk:*default-worker-thread-bindings*). + + +File: sly.info, Node: The REPL and other special buffers, Next: Customization, Prev: Common functionality, Up: Top + +6 The REPL and other special buffers +************************************ + +* Menu: + +* REPL:: +* Inspector:: +* Debugger:: +* Trace Dialog:: +* Stickers:: + + +File: sly.info, Node: REPL, Next: Inspector, Up: The REPL and other special buffers + +6.1 The REPL: the "top level" +============================= + +SLY uses a custom Read-Eval-Print Loop (REPL, also known as a "top +level", or listener): + + * Conditions signalled in REPL expressions are debugged with the + integrated SLY debugger. + * Return values are interactive values (*note Interactive objects::) + distinguished from printed output by separate Emacs faces (colors). + * Output from the Lisp process is inserted in the right place, and + doesn't get mixed up with user input. + * Multiple REPLs are possible in the same Lisp connection. This is + useful for performing quick one-off experiments in different + packages or directories without disturbing the state of an existing + REPL. + * The REPL is a central hub for much of SLY's functionality, since + objects examined in the inspector (*note Inspector::), debugger + (*note Debugger::), and other extensions can be returned there. + + Switching to the REPL from anywhere in a SLY buffer is a very common +task. One way to do it is to find the '*sly-mrepl...*' buffer in +Emacs’s buffer list, but there are other ways to reach a REPL. + +'C-c C-z' +'M-x sly-mrepl' + Start or select an existing main REPL buffer. + +'M-x sly-mrepl-new' + Start a new secondary REPL session, prompting for a nickname. + +'C-c ~' +'M-x sly-mrepl-sync' + Go to the REPL, switching package and default directory as + applicable. More precisely the Lisp variables '*package*' and + '*default-pathname-defaults*' are affected by the location where + the command was issued. In a specific position of a '.lisp' file, + for instance the current package and that file’s directory are + chosen. + +* Menu: + +* REPL commands:: +* REPL output:: +* REPL backreferences:: + + +File: sly.info, Node: REPL commands, Next: REPL output, Up: REPL + +6.1.1 REPL commands +------------------- + +'RET' +'M-x sly-mrepl-return' + + Evaluate the expression at prompt and return the result. + +'TAB' +'M-x sly-mrepl-indent-and-complete-symbol' + + Indent the current line. If line already indented complete the + symbol at point (*note Completion::). If there is not symbol at + point show the argument list of the most recently enclosed function + or macro in the minibuffer. + +'M-p' +'M-x sly-mrepl-previous-input-or-button' + + When at the current prompt, fetches previous input from the + history, otherwise jumps to the previous interactive value (*note + Interactive objects::) representing a Lisp object. + +'M-n' +'M-x sly-mrepl-next-input-or-button' + + When at the current prompt, fetches next input from the history, + otherwise jumps to the previous interactive value representing a + Lisp object. + +'C-r' +'M-x isearch-backward' + + This regular Emacs keybinding, when invoked at the current REPL + prompt, starts a special transient mode turning the prompt into the + string "History-isearch backward". While in this mode, the user + can compose a string used to search backwards through history, and + reverse the direction of search by pressing 'C-s'. When invoked + outside the current REPL prompt, does a normal text search through + the buffer contents. + +'C-c C-b' +'M-x sly-interrupt' + + Interrupts the current thread of the inferior-lisp process. + + For convenience this function is also bound to 'C-c C-c'. + +'C-M-p' +'M-x sly-button-backward' + + Jump to the previous interactive value representing a Lisp object. + +'C-M-n' +'M-x sly-button-forward' + + Jump to the next interactive value representing a Lisp object. + +'C-c C-o' +'M-x sly-mrepl-clear-recent-output' + + Clear output between current and last REPL prompts, keeping + results. + +'C-c M-o' +'M-x sly-mrepl-clear-repl' + + Clear the whole REPL of output and results. + + +File: sly.info, Node: REPL output, Next: REPL backreferences, Prev: REPL commands, Up: REPL + +6.1.2 REPL output +----------------- + +REPLs wouldn’t be much use if they just took user input and didn’t print +anything back. In SLY the output printed to the REPL can come from four +different places: + + * A function’s return values. One line per return value is printed. + Each line of printed text, called a REPL result, persists after + more expressions are evaluated, and is actually a button (*note + Interactive objects::) presenting the Lisp-side object. You can, + for instance, inspect it (*note Inspector::) or re-return it to + right before the current command prompt so that you may conjure it + up again, as usual in Lisp REPLs, with the special variable '*'. + + In the SLY REPL, in addition to the '*', '**' and '***' special + variables, return values can also be accessed through a special + backreference (*note REPL backreferences::). + + * An object may be copied to the REPL from some other part in SLY, + such as the Inspector (*note Inspector::), Debugger (*note + Debugger::), etc. using the familiar 'M-RET' binding, or by + selecting "Copy to REPL" from the context menu of an interactive + object. Aside from not having been produced by the evaluation of a + Lisp form in the REPL, these objects behaves exactly like a REPL + result. + + * The characters printed to the standard Lisp streams + '*standard-output*', '*error-output*' and '*trace-output*' as a + _synchronous_ and direct result of the evaluation of an expression + in the REPL. + + * The characters printed to the standard Lisp streams + '*standard-output*', '*error-output*' and '*trace-output*' printed, + perhaps _asynchronously_, from others threads, for instance. This + feature is optional and controlled by the variable + 'SLYNK:*GLOBALLY-REDIRECT-IO*'. + +For advanced users, there are some Lisp-side Slynk variables affecting +the way Slynk transmits REPL output to SLY. + +'SLYNK:*GLOBALLY-REDIRECT-IO*' + + This variable controls the global redirection of the the standard + streams ('*standard-output*', etc) to the REPL in Emacs. The + default value is ':started-from-emacs', which means that + redirection should only take place upon 'M-x sly' invocations. + When 't', global redirection happens even for sessions started with + 'M-x sly-connect', meaning output may be diverted from wherever you + started the Lisp server originally. + + When 'NIL' these streams are only temporarily redirected to Emacs + using dynamic bindings while handling requests, meaning you only + see output caused by the commands you issued to the REPL. + + Note that '*standard-input*' is currently never globally redirected + into Emacs, because it can interact badly with the Lisp's native + REPL by having it try to read from the Emacs one. + + Also note that secondary REPLs (those started with 'sly-mrepl-new') + don’t receive any redirected output. + +'SLYNK:*USE-DEDICATED-OUTPUT-STREAM*' + + This variable controls whether to use a separate socket solely for + Lisp to send printed output to Emacs through, which is more + efficient than sending the output in protocol messages to Emacs. + + The default value is ':started-from-emacs', which means that the + socket should only be established upon 'M-x sly' invocations. When + 't', it's established even for sessions started with 'M-x + sly-connect'. When 'NIL' usual protocol messages are used for + sending input to the REPL. + + Notice that using a dedicated output stream makes it more difficult + to communicate to a Lisp running on a remote host via SSH (*note + Connecting to a remote Lisp::). If you connect via 'M-x + sly-connect', the default ':started-from-emacs' value should ensure + this isn't a problem. + +'SLYNK:*DEDICATED-OUTPUT-STREAM-PORT*' + + When '*USE-DEDICATED-OUTPUT-STREAM*' is 't' the stream will be + opened on this port. The default value, '0', means that the stream + will be opened on some random port. + +'SLYNK:*DEDICATED-OUTPUT-STREAM-BUFFERING*' + + For efficiency, some Lisps backends wait until a certain conditions + are met in a Lisp character stream before flushing that stream’s + contents, thus sending it to the SLY REPL. Be advised that this + sometimes works poorly on some implementations, so it’s probably + best to leave alone. Possible values are 'nil' (no buffering), 't' + (enable buffering) or ':line' (enable buffering on EOL) + + +File: sly.info, Node: REPL backreferences, Prev: REPL output, Up: REPL + +6.1.3 REPL backreferences +------------------------- + +In a regular Lisp REPL, the objects produced by evaluating expressions +at the command prompt can usually be referenced in future commands using +the special variables '*', '**' and '***'. This is also true of the SLY +REPL, but it also provides a different way to re-conjure these objects +through a special Lisp reader macro character available only in the +REPL. The macro character, which is '#v' by default takes, in a terse +syntax, two indexes specifying the precise objects in all of the SLY +REPL’s recorded history. + + Consider this fragment of a REPL session: + + ; Cleared REPL history + CL-USER> (values 'a 'b 'c) + A + B + C + CL-USER> (list #v0) + (A) + CL-USER> (list #v0:1 #v0:2) + (B C) + CL-USER> (append #v1:0 #v2:0) + (A B C) + CL-USER> + +Admittedly, while useful, this doesn’t seem terribly easy to use at +first sight. There are a couple of reasons, however, that should make +it worth considering: + + * Backreference annotation and highlighting + + As soon as the SLY REPL detects that you have pressed '#v', all the + REPL results that can possibly be referenced are temporarily + annotated on their left with two special numbers. These numbers + are in the syntax accepted by the '#v' macro-character, namely + '#vENTRY-IDX:VALUE-IDX'. + + Furthermore, as soon as you type a number for 'ENTRY-IDX', only + that entries values remain highlighted. Then, as you finish the + entry with 'VALUE-IDX', only that exact object remains highlighted. + If you make a mistake (say, by typing a letter or an invalid + number) while composing '#v' syntax, SLY lets you know by painting + the backreference red. + + Highlighting also happens when you place the cursor over existing + valid '#v' expressions. + + * Returning functions calls + + An experimental feature in SLY allows copying _function calls_ to + the REPL from the Debugger (*note Debugger::) and the Trace Dialog + (*note Trace Dialog::). In those buffers, pressing keybinding + 'M-S-RET' over objects that represent function calls will copy the + _call_, and not the object, to the REPL. This works by first + copying over the argument objects in order to the REPL results, and + then composing an input line that includes the called function's + name and backreferences to those arguments (*note REPL + backreferences::). + + Naturally, this call isn't _exactly_ the same because it doesn’t + evaluate in the same dynamic environment as the original one. But + it's a useful debug technique because backreferences are stable + (1), so repeating that very same function call with the very same + arguments is just a matter of textually copying the previous + expression into the command prompt, no matter how far ago it + happened. And that, in turn, is as easy as using 'C-r' and some + characters (*note REPL commands::) to arrive and repeat the desired + REPL history entry. + + ---------- Footnotes ---------- + + (1) until you clear the REPL’s output, that is + + +File: sly.info, Node: Inspector, Next: Debugger, Prev: REPL, Up: The REPL and other special buffers + +6.2 The Inspector +================= + +The SLY inspector is a Emacs-based alternative to the standard 'INSPECT' +function. The inspector presents objects in Emacs buffers using a +combination of plain text, hyperlinks to related objects. + + The inspector can easily be specialized for the objects in your own +programs. For details see the 'inspect-for-emacs' generic function in +'slynk-backend.lisp'. + +'C-c I' +'M-x sly-inspect' + Inspect the value of an expression entered in the minibuffer. + + The standard commands available in the inspector are: + +'RET' +'M-x sly-inspector-operate-on-point' + If point is on a value then recursively call the inspector on that + value. If point is on an action then call that action. + +'D' +'M-x sly-inspector-describe-inspectee' + Describe the slot at point. + +'e' +'M-x sly-inspector-eval' + Evaluate an expression in the context of the inspected object. The + variable '*' will be bound to the inspected object. + +'v' +'M-x sly-inspector-toggle-verbose' + Toggle between verbose and terse mode. Default is determined by + 'slynk:*inspector-verbose*'. + +'l' +'M-x sly-inspector-pop' + Go back to the previous object (return from 'RET'). + +'n' +'M-x sly-inspector-next' + The inverse of 'l'. Also bound to 'SPC'. + +'g' +'M-x sly-inspector-reinspect' + Reinspect. + +'h' +'M-x sly-inspector-history' + Show the previously inspected objects. + +'q' +'M-x sly-inspector-quit' + Dismiss the inspector buffer. + +'>' +'M-x sly-inspector-fetch-all' + Fetch all inspector contents and go to the end. + +'M-RET' +'M-x sly-mrepl-copy-part-to-repl' + Store the value under point in the variable '*'. This can then be + used to access the object in the REPL. + +'TAB, M-x forward-button' +'S-TAB, M-x backward-button' + + Jump to the next and previous inspectable object respectively. + + +File: sly.info, Node: Debugger, Next: Trace Dialog, Prev: Inspector, Up: The REPL and other special buffers + +6.3 The SLY-DB Debugger +======================= + +SLY has a custom Emacs-based debugger called SLY-DB. Conditions +signalled in the Lisp system invoke SLY-DB in Emacs by way of the Lisp +'*DEBUGGER-HOOK*'. + + SLY-DB pops up a buffer when a condition is signalled. The buffer +displays a description of the condition, a list of restarts, and a +backtrace. Commands are offered for invoking restarts, examining the +backtrace, and poking around in stack frames. + +* Menu: + +* Examining frames:: +* Restarts:: +* Frame Navigation:: +* Miscellaneous:: + + +File: sly.info, Node: Examining frames, Next: Restarts, Up: Debugger + +6.3.1 Examining frames +---------------------- + +Commands for examining the stack frame at point. + +'t' +'M-x sly-db-toggle-details' + Toggle display of local variables and 'CATCH' tags. + +'v' +'M-x sly-db-show-frame-source' + View the frame's current source expression. The expression is + presented in the Lisp source file's buffer. + +'e' +'M-x sly-db-eval-in-frame' + Evaluate an expression in the frame. The expression can refer to + the available local variables in the frame. + +'d' +'M-x sly-db-pprint-eval-in-frame' + Evaluate an expression in the frame and pretty-print the result in + a temporary buffer. + +'D' +'M-x sly-db-disassemble' + Disassemble the frame's function. Includes information such as the + instruction pointer within the frame. + +'i' +'M-x sly-db-inspect-in-frame' + Inspect the result of evaluating an expression in the frame. + +'C-c C-c' +'M-x sly-db-recompile-frame-source' + Recompile frame. 'C-u C-c C-c' for recompiling with maximum debug + settings. + + +File: sly.info, Node: Restarts, Next: Frame Navigation, Prev: Examining frames, Up: Debugger + +6.3.2 Invoking restarts +----------------------- + +'a' +'M-x sly-db-abort' + Invoke the 'ABORT' restart. + +'q' +'M-x sly-db-quit' + "Quit" - For SLY evaluation requests, invoke a restart which + restores to a known program state. For errors in other threads, + *Note *SLY-DB-QUIT-RESTART*::. + +'c' +'M-x sly-db-continue' + Invoke the 'CONTINUE' restart. + +'0 ... 9' +'M-x sly-db-invoke-restart-n' + Invoke a restart by number. + + Restarts can also be invoked by pressing 'RET' or 'Mouse-2' on them +in the buffer. + + +File: sly.info, Node: Frame Navigation, Next: Miscellaneous, Prev: Restarts, Up: Debugger + +6.3.3 Navigating between frames +------------------------------- + +'n, M-x sly-db-down' +'p, M-x sly-db-up' + Move between frames. + +'M-n, M-x sly-db-details-down' +'M-p, M-x sly-db-details-up' + Move between frames "with sugar": hide the details of the original + frame and display the details and source code of the next. Sugared + motion makes you see the details and source code for the current + frame only. + +'>' +'M-x sly-db-end-of-backtrace' + Fetch the entire backtrace and go to the last frame. + +'<' +'M-x sly-db-beginning-of-backtrace' + Go to the first frame. + + +File: sly.info, Node: Miscellaneous, Prev: Frame Navigation, Up: Debugger + +6.3.4 Miscellaneous Commands +---------------------------- + +'r' +'M-x sly-db-restart-frame' + Restart execution of the frame with the same arguments it was + originally called with. (This command is not available in all + implementations.) + +'R' +'M-x sly-db-return-from-frame' + Return from the frame with a value entered in the minibuffer. + (This command is not available in all implementations.) + +'B' +'M-x sly-db-break-with-default-debugger' + Exit SLY-DB and debug the condition using the Lisp system's default + debugger. + +'C' +'M-x sly-db-inspect-condition' + Inspect the condition currently being debugged. + +':' +'M-x sly-interactive-eval' + Evaluate an expression entered in the minibuffer. +'A' +'M-x sly-db-break-with-system-debugger' + Attach debugger (e.g. gdb) to the current lisp process. + + +File: sly.info, Node: Trace Dialog, Next: Stickers, Prev: Debugger, Up: The REPL and other special buffers + +6.4 Trace Dialog +================ + +The SLY Trace Dialog, in package 'sly-trace-dialog', is a tracing +facility, similar to Common Lisp's 'trace', but interactive rather than +purely textual. + + You use it just like you would regular 'trace': after tracing a +function, calling it causes interesting information about that +particular call to be reported. + + However, instead of printing the trace results to the the +'*trace-output*' stream (usually the REPL), the SLY Trace Dialog +collects and stores them in your Lisp environment until, on user's +request, they are fetched into Emacs and displayed in a dialog-like +interactive view. + + After starting up SLY, SLY's Trace Dialog installs a _Trace_ menu in +the menu-bar of any 'sly-mode' buffer and adds two new commands, with +respective key-bindings: + +'C-c C-t' +'M-x sly-trace-dialog-toggle-trace' + If point is on a symbol name, toggle tracing of its function + definition. If point is not on a symbol, prompt user for a + function. + + With a 'C-u' prefix argument, and if your lisp implementation + allows it, attempt to decipher lambdas, methods and other + complicated function signatures. + + The function is traced for the SLY Trace Dialog only, i.e. it is + not found in the list returned by Common Lisp's 'trace'. + +'C-c T' +'M-x sly-trace-dialog' + Pop to the interactive Trace Dialog buffer associated with the + current connection (*note Multiple connections::). + + Consider the (useless) program: + + (defun foo (n) (if (plusp n) (* n (bar (1- n))) 1)) + (defun bar (n) (if (plusp n) (* n (foo (1- n))) 1)) + + After tracing both 'foo' and 'bar' with 'C-c M-t', calling call '(foo +2)' and moving to the trace dialog with 'C-c T', we are presented with +this buffer. + + Traced specs (2) [refresh] + [untrace all] + [untrace] common-lisp-user::bar + [untrace] common-lisp-user::foo + + Trace collection status (3/3) [refresh] + [clear] + + 0 - common-lisp-user::foo + | > 2 + | < 2 + 1 `--- common-lisp-user::bar + | > 1 + | < 1 + 2 `-- common-lisp-user::foo + > 0 + < 1 + + The dialog is divided into sections displaying the functions already +traced, the trace collection progress and the actual trace tree that +follow your program's logic. The most important key-bindings in this +buffer are: + +'g' +'M-x sly-trace-dialog-fetch-status' + Update information on the trace collection and traced specs. +'G' +'M-x sly-trace-dialog-fetch-traces' + Fetch the next batch of outstanding (not fetched yet) traces. With + a 'C-u' prefix argument, repeat until no more outstanding traces. +'C-k' +'M-x sly-trace-dialog-clear-fetched-traces' + Prompt for confirmation, then clear all traces, both fetched and + outstanding. + + The arguments and return values below each entry are interactive +buttons. Clicking them opens the inspector (*note Inspector::). +Invoking 'M-RET' ('sly-trace-dialog-copy-down-to-repl') returns them to +the REPL for manipulation (*note REPL::). The number left of each entry +indicates its absolute position in the calling order, which might differ +from display order in case multiple threads call the same traced +function. + + 'sly-trace-dialog-hide-details-mode' hides arguments and return +values so you can concentrate on the calling logic. Additionally, +'sly-trace-dialog-autofollow-mode' will automatically display additional +detail about an entry when the cursor moves over it. + + +File: sly.info, Node: Stickers, Prev: Trace Dialog, Up: The REPL and other special buffers + +6.5 Stickers +============ + +SLY Stickers, implemented as the 'sly-stickers' contrib (*note +Extensions::), is a tool for "live" code annotations. It's an +alternative to the 'print' or 'break' statements you add to your code +when debugging. + + Contrary to these techniques, "stickers" are non-intrusive, meaning +that saving your file doesn't save your debug code along with it. + + Here's the general workflow: + + * In Lisp source files, using 'C-c C-s C-s' or 'M-x + sly-stickers-dwim' places a sticker on any Lisp form. Stickers can + exist inside other stickers. + + + + + + * Stickers are "armed" when a definition or a file is compiled with + the familiar 'C-c C-c' ('M-x sly-compile-defun') or 'C-c C-k' ('M-x + sly-compile-file') commands. An armed sticker changes color from + the default grey background to a blue background. + + + + + + From this point on, when the Lisp code is executed, the results of +evaluating the underlying forms are captured in the Lisp side. Stickers +help you examine your program's behaviour in three ways: + 1. 'C-c C-s C-r' (or 'M-x sly-stickers-replay') interactively walks + the user through recordings in the order that they occurred. In + the created '*sly-stickers-replay*' buffer, type 'h' for a list of + keybindings active in that buffer. + + + + + + 2. To step through stickers as your code is executed, ensure that + "breaking stickers" are enabled via 'M-x + sly-stickers-toggle-break-on-stickers'. Whenever a sticker-covered + expression is reached, the debugger comes up with useful restarts + and interactive for the values produced. You can tweak this + behaviour by setting the Lisp-side variable + 'SLYNK-STICKERS:*BREAK-ON-STICKERS*' to a list with the elements + ':before' and ':after', making SLY break before a sticker, after + it, or both. + + + + + + 3. 'C-c C-s S' ('M-x sly-stickers-fetch') populates the sticker + overlay with the latest captured results, called "recordings". If + a sticker has captured any recordings, it will turn green, + otherwise it will turn red. A sticker whose Lisp expression has + caused a non-local exit, will be also be marked with a special + face. + + + + + + At any point, stickers can be removed with the same +'sly-stickers-dwim' keybinding, by placing the cursor at the beginning +of a sticker. Additionally adding prefix arguments to +'sly-stickers-dwim' increase its scope, so 'C-u C-c C-s C-s' will remove +all stickers from the current function and 'C-u C-u C-c C-s C-s' will +remove all stickers from the current file. + + Stickers can be nested inside other stickers, so it is possible to +record the value of an expression inside another expression which is +also annotated. + + Stickers are interactive parts just like any other part in SLY that +represents Lisp-side objects, so they can be inspected and returned to +the REPL, for example. To move through the stickers with the keyboard +use the existing keybindings to move through compilation notes ('M-p' +and 'M-n') or use 'C-c C-s p' and 'C-c C-s n' +('sly-stickers-prev-sticker' and 'sly-stickers-next-sticker'). + + There are some caveats when using SLY Stickers: + + * Stickers on unevaluated forms (such as 'let' variable bindings, or + other constructs) are rejected, though the function is still + compiled as usual. To let the user know about this, these stickers + remain grey, and are marked as "disarmed". A message also appears + in the echo area. + * Stickers placed on expressions inside backquoted expressions in + macros are always armed, even though they may come to provoke a + runtime error when the macro's expansion is run. Think of this + when setting a sticker inside a macro definition. + + +File: sly.info, Node: Customization, Next: Tips and Tricks, Prev: The REPL and other special buffers, Up: Top + +7 Customization +*************** + +* Menu: + +* Emacs-side:: +* Lisp-side customization:: + + +File: sly.info, Node: Emacs-side, Next: Lisp-side customization, Up: Customization + +7.1 Emacs-side +============== + +* Menu: + +* Keybindings:: +* Keymaps:: +* Defcustom variables:: +* Hooks:: + + +File: sly.info, Node: Keybindings, Next: Keymaps, Up: Emacs-side + +7.1.1 Keybindings +----------------- + +In general we try to make our key bindings fit with the overall Emacs +style. + + We never bind 'C-h' anywhere in a key sequence. This is because +Emacs has a built-in default so that typing a prefix followed by 'C-h' +will display all bindings starting with that prefix, so 'C-c C-d C-h' +will actually list the bindings for all documentation commands. This +feature is just a bit too useful to clobber! + + "Are you deliberately spiting Emacs's brilliant online help + facilities? The gods will be angry!" + +This is a brilliant piece of advice. The Emacs online help facilities +are your most immediate, up-to-date and complete resource for keybinding +information. They are your friends: + +'C-h k <key>' + 'describe-key' "What does this key do?" + Describes current function bound to '<key>' for focus buffer. + +'C-h b' + 'describe-bindings' "Exactly what bindings are available?" + Lists the current key-bindings for the focus buffer. + +'C-h m' + 'describe-mode' "Tell me all about this mode" + Shows all the available major mode keys, then the minor mode keys, + for the modes of the focus buffer. + +'C-h l' + 'view-lossage' "Woah, what key chord did I just do?" + Shows you the literal sequence of keys you've pressed in order. + + For example, you can add one of the following to your Emacs init file +(usually '~/.emacs' or '~/.emacs.d/init.el', but *note Init File: +(emacs)Init File.). + + (eval-after-load 'sly + `(define-key sly-prefix-map (kbd "M-h") 'sly-documentation-lookup)) + + SLY comes bundled with many extensions (called "contribs" for +historical reasons, *note Extensions::) which you can customize just +like SLY's code. To make 'C-c C-c' clear the last REPL prompt's output, +for example, use + + (eval-after-load 'sly-mrepl + `(define-key sly-mrepl-mode-map (kbd "C-c C-k") + 'sly-mrepl-clear-recent-output)) + + +File: sly.info, Node: Keymaps, Next: Defcustom variables, Prev: Keybindings, Up: Emacs-side + +7.1.2 Keymaps +------------- + +Emacs’s keybindings "live" in keymap variables. To customize a +particular binding and keep it from trampling on other important keys +you should do it in one of SLY's keymaps. The following non-exhaustive +list of SLY-related keymaps is just a reference: the manual will go over +each associated functionality in detail. + +'sly-doc-map' + + Keymap for documentation commands (*note Documentation::) in + SLY-related buffers, accessible by the 'C-c C-d' prefix. + +'sly-who-map' + + Keymap for cross-referencing ("who-calls") commands (*note + Cross-referencing::) in SLY-related buffers, accessible by the 'C-c + C-w' prefix. + +'sly-selector-map' + + A keymap for SLY-related functionality that should be available in + globally in all Emacs buffers (not just SLY-related buffers). + +'sly-mode-map' + + A keymap for functionality available in all SLY-related buffers. + +'sly-editing-mode-map' + + A keymap for SLY functionality available in Lisp source files. + +'sly-popup-buffer-mode-map' + + A keymap for functionality available in the temporary "popup" + buffers that SLY displays (*note Temporary buffers::) + +'sly-apropos-mode-map' + + A keymap for functionality available in the temporary SLY "apropos" + buffers (*note Documentation::). + +'sly-xref-mode-map' + + A keymap for functionality available in the temporary 'xref' + buffers used by cross-referencing commands (*note + Cross-referencing::). + +'sly-macroexpansion-minor-mode-map' + + A keymap for functionality available in the temporary buffers used + for macroexpansion presentation (*note Macro-expansion::). + +'sly-db-mode-map' + + A keymap for functionality available in the debugger buffers used + to debug errors in the Lisp process (*note Debugger::). + +'sly-thread-control-mode-map' + + A keymap for functionality available in the SLY buffers dedicated + to controlling Lisp threads (*note Multi-threading::). + +'sly-connection-list-mode-map' + + A keymap for functionality available in the SLY buffers dedicated + to managing multiple Lisp connections (*note Multiple + connections::). + +'sly-inspector-mode-map' + + A keymap for functionality available in the SLY buffers dedicated + to inspecting Lisp objects (*note Inspector::). + +'sly-mrepl-mode-map' + + A keymap for functionality available in SLY’s REPL buffers (*note + REPL::). + +'sly-trace-dialog-mode-map' + + A keymap for functionality available in SLY’s "Trace Dialog" + buffers (*note Trace Dialog::). + + +File: sly.info, Node: Defcustom variables, Next: Hooks, Prev: Keymaps, Up: Emacs-side + +7.1.3 Defcustom variables +------------------------- + +The Emacs part of SLY can be configured with the Emacs 'customize' +system, just use 'M-x customize-group sly RET'. Because the customize +system is self-describing, we only cover a few important or obscure +configuration options here in the manual. + +'sly-truncate-lines' + The value to use for 'truncate-lines' in line-by-line summary + buffers popped up by SLY. This is 't' by default, which ensures + that lines do not wrap in backtraces, apropos listings, and so on. + It can however cause information to spill off the screen. + +'sly-complete-symbol-function' + The function to use for completion of Lisp symbols. Two completion + styles are available: 'sly-simple-completions' and + 'sly-flex-completions' (*note Completion::). + +'sly-filename-translations' + This variable controls filename translation between Emacs and the + Lisp system. It is useful if you run Emacs and Lisp on separate + machines which don't share a common file system or if they share + the filesystem but have different layouts, as is the case with + SMB-based file sharing. + +'sly-net-coding-system' + If you want to transmit Unicode characters between Emacs and the + Lisp system, you should customize this variable. E.g., if you use + SBCL, you can set: + (setq sly-net-coding-system 'utf-8-unix) + To actually display Unicode characters you also need appropriate + fonts, otherwise the characters will be rendered as hollow boxes. + If you are using Allegro CL and GNU Emacs, you can also use + 'emacs-mule-unix' as coding system. GNU Emacs has often nicer + fonts for the latter encoding. (Different encodings can be used + for different Lisps, see *note Multiple Lisps::.) + +'sly-keep-buffers-on-connection-close' + This variable holds a list of keywords indicating SLY buffer types + that should be kept around when a connection closes. For example, + if the variable's value includes ':mrepl' (which is the default), + REPL buffer is kept around while all other stale buffers (debugger, + inspector, etc..) are automatically killed. + + The following customization variables affect the behaviour of the +REPL (*note REPL::): + +'sly-mrepl-shortcut' + The key to use to trigger the REPL's "comma shortcut". We + recommend you keep the default setting which is the comma (',') + key, since there's special logic in the REPL to discern if you're + typing a comma inside a backquoted list or not. + +'sly-mrepl-prompt-formatter' + Holds a function that can be set from your Emacs init file (*note + Init File: (emacs)Init File.) to change the way the prompt is + rendered. It takes a number of arguments describing the prompt and + should return a propertized Elisp string. See the default value, + 'sly-mrepl-default-prompt', for how to implement such a prompt. + +'sly-mrepl-history-file-name' + Holds a string designating the file to use for keeping the shared + REPL histories persistently. The default is to use a hidden file + named '.sly-mrepl-history' in the user's home directory. + +'sly-mrepl-prevent-duplicate-history' + A symbol. If non-nil, prevent duplicate entries in input history. + If the non-nil value is the symbol 'move', the previously occuring + entry is moved to a more recent spot. + +'sly-mrepl-eli-like-history-navigation' + If non-NIL, navigate history like in ELI, Franz's Common Lisp IDE + for Emacs. + + +File: sly.info, Node: Hooks, Prev: Defcustom variables, Up: Emacs-side + +7.1.4 Hooks +----------- + +'sly-mode-hook' + This hook is run each time a buffer enters 'sly-mode'. It is most + useful for setting buffer-local configuration in your Lisp source + buffers. An example use is to enable 'sly-autodoc-mode' (*note + Autodoc::). + +'sly-connected-hook' + This hook is run when SLY establishes a connection to a Lisp + server. An example use is to pop to a new REPL. + +'sly-db-hook' + This hook is run after SLY-DB is invoked. The hook functions are + called from the SLY-DB buffer after it is initialized. An example + use is to add 'sly-db-print-condition' to this hook, which makes + all conditions debugged with SLY-DB be recorded in the REPL buffer. + + +File: sly.info, Node: Lisp-side customization, Prev: Emacs-side, Up: Customization + +7.2 Lisp-side (Slynk) +===================== + +The Lisp server side of SLY (known as "Slynk") offers several variables +to configure. The initialization file '~/.slynk.lisp' is automatically +evaluated at startup and can be used to set these variables. + +* Menu: + +* Communication style:: +* Other configurables:: + + +File: sly.info, Node: Communication style, Next: Other configurables, Up: Lisp-side customization + +7.2.1 Communication style +------------------------- + +The most important configurable is 'SLYNK:*COMMUNICATION-STYLE*', which +specifies the mechanism by which Lisp reads and processes protocol +messages from Emacs. The choice of communication style has a global +influence on SLY's operation. + + The available communication styles are: + +'NIL' + This style simply loops reading input from the communication socket + and serves SLY protocol events as they arise. The simplicity means + that the Lisp cannot do any other processing while under SLY's + control. + +':FD-HANDLER' + This style uses the classical Unix-style "'select()'-loop." Slynk + registers the communication socket with an event-dispatching + framework (such as 'SERVE-EVENT' in CMUCL and SBCL) and receives a + callback when data is available. In this style requests from Emacs + are only detected and processed when Lisp enters the event-loop. + This style is simple and predictable. + +':SIGIO' + This style uses "signal-driven I/O" with a 'SIGIO' signal handler. + Lisp receives requests from Emacs along with a signal, causing it + to interrupt whatever it is doing to serve the request. This style + has the advantage of responsiveness, since Emacs can perform + operations in Lisp even while it is busy doing other things. It + also allows Emacs to issue requests concurrently, e.g. to send one + long-running request (like compilation) and then interrupt that + with several short requests before it completes. The disadvantages + are that it may conflict with other uses of 'SIGIO' by Lisp code, + and it may cause untold havoc by interrupting Lisp at an awkward + moment. + +':SPAWN' + This style uses multiprocessing support in the Lisp system to + execute each request in a separate thread. This style has similar + properties to ':SIGIO', but it does not use signals and all + requests issued by Emacs can be executed in parallel. + + The default request handling style is chosen according to the +capabilities of your Lisp system. The general order of preference is +':SPAWN', then ':SIGIO', then ':FD-HANDLER', with 'NIL' as a last +resort. You can check the default style by calling +'SLYNK-BACKEND::PREFERRED-COMMUNICATION-STYLE'. You can also override +the default by setting 'SLYNK:*COMMUNICATION-STYLE*' in your Slynk init +file (*note Lisp-side customization::). + + +File: sly.info, Node: Other configurables, Prev: Communication style, Up: Lisp-side customization + +7.2.2 Other configurables +------------------------- + +These Lisp variables can be configured via your '~/.slynk.lisp' file: + +'SLYNK:*CONFIGURE-EMACS-INDENTATION*' + This variable controls whether indentation styles for + '&body'-arguments in macros are discovered and sent to Emacs. It + is enabled by default. + +'SLYNK:*GLOBAL-DEBUGGER*' + When true (the default) this causes '*DEBUGGER-HOOK*' to be + globally set to 'SLYNK:SLYNK-DEBUGGER-HOOK' and thus for SLY to + handle all debugging in the Lisp image. This is for debugging + multithreaded and callback-driven applications. + +'SLYNK:*SLY-DB-QUIT-RESTART*' + This variable names the restart that is invoked when pressing 'q' + (*note sly-db-quit::) in SLY-DB. For SLY evaluation requests this + is _unconditionally_ bound to a restart that returns to a safe + point. This variable is supposed to customize what 'q' does if an + application's thread lands into the debugger (see + 'SLYNK:*GLOBAL-DEBUGGER*'). + (setf slynk:*sly-db-quit-restart* 'sb-thread:terminate-thread) + +'SLYNK:*BACKTRACE-PRINTER-BINDINGS*' +'SLYNK:*MACROEXPAND-PRINTER-BINDINGS*' +'SLYNK:*SLY-DB-PRINTER-BINDINGS*' +'SLYNK:*SLYNK-PPRINT-BINDINGS*' + These variables can be used to customize the printer in various + situations. The values of the variables are association lists of + printer variable names with the corresponding value. E.g., to + enable the pretty printer for formatting backtraces in SLY-DB, you + can use: + + (push '(*print-pretty* . t) slynk:*sly-db-printer-bindings*). + + The fact that most SLY output (in the REPL for instance, *note + REPL::) uses 'SLYNK:*SLYNK-PPRINT-BINDINGS*' may surprise you if + you expected it to use a global setting for, say, '*PRINT-LENGTH*'. + The rationale for this decision is that output is a very basic + feature of SLY, and it should keep operating normally even if you + (mistakenly) set absurd values for some '*PRINT-...*' variable. + You, of course, override this protection: + + (setq slynk:*slynk-pprint-bindings* + (delete '*print-length* + slynk:*slynk-pprint-bindings* :key #'car)) + +'SLYNK:*STRING-ELISION-LENGTH*' +'SLYNK:*STRING-ELISION-LENGTH*' + + This variable controls the maximum length of strings before their + pretty printed representation in the Inspector, Debugger, REPL, etc + is elided. Don't set this variable directly, create a binding for + this variable in 'SLYNK:*SLYNK-PPRINT-BINDINGS*' instead. + +'SLYNK:*ECHO-NUMBER-ALIST*' +'SLYNK:*PRESENT-NUMBER-ALIST*' + These variables hold function designators used for displaying + numbers when SLY presents them in its interface. + + The difference between the two functions is that + '*PRESENT-NUMBER-ALIST*', if non-nil, overrides + '*ECHO-NUMBER-ALIST*' in the context of the REPL, Trace Dialog and + Stickers (see *note REPL::, *note Trace Dialog:: and *note + Stickers::), while the latter is used for commands like 'C-x C-e' + or the inspector (see *note Evaluation::, *note Inspector::). + + If in doubt, use '*ECHO-NUMBER-ALIST*'. + + Both variables have the same structure: each element in the alist + takes the form '(TYPE . FUNCTIONS)', where 'TYPE' is a type + designator and 'FUNCTIONS' is a list of function designators for + displaying that number in SLY. Each function takes the number as a + single argument and returns a string, or nil, if that particular + representation is to be disregarded. + + Additionally if a given function chooses to return 't' as its + optional second value, then all the remaining functions following + it in the list are disregarded. + + For integer numbers, the default value of this variable holds + function designators that echo an integer number in its binary, + hexadecimal and octal representation. However, if your application + is using integers to represent Unix Epoch Times you can use this + function to display a human-readable time whenever you evaluate an + integer. + + (defparameter *day-names* '("Monday" "Tuesday" "Wednesday" + "Thursday" "Friday" "Saturday" + "Sunday")) + + (defun fancy-unix-epoch-time (integer) + "Format INTEGER as a Unix Epoch Time if within 10 years from now." + (let ((now (get-universal-time)) + (tenyears (encode-universal-time 0 0 0 1 1 1910 0)) + (unix-to-universal + (+ integer + (encode-universal-time 0 0 0 1 1 1970 0)))) + (when (< (- now tenyears) unix-to-universal (+ now tenyears)) + (multiple-value-bind + (second minute hour date month year day-of-week dst-p tz) + (decode-universal-time unix-to-universal) + (declare (ignore dst-p)) + (format nil "~2,'0d:~2,'0d:~2,'0d on ~a, ~d/~2,'0d/~d (GMT~@d)" + hour minute second (nth day-of-week *day-names*) + month date year (- tz)))))) + + (pushnew 'fancy-unix-epoch-time + (cdr (assoc 'integer slynk:*echo-number-alist*))) + + 42 ; => 42 (6 bits, #x2A, #o52, #b101010) + 1451404675 ; => 1451404675 (15:57:55 on Tuesday, 12/29/2015 (GMT+0), 31 bits, #x5682AD83) + +'SLYNK-APROPOS:*PREFERRED-APROPOS-MATCHER*' + This variable holds a function used for performing apropos + searches. It defaults to 'SLYNK-APROPOS:MAKE-FLEX-MATCHER', but + can also be set to 'SLYNK-APROPOS:MAKE-CL-PPCRE-MATCHER' (to use a + regex-able matcher) or 'SLYNK-APROPOS:MAKE-PLAIN-MATCHER', for + example. + +'SLYNK:*LOG-EVENTS*' + Setting this variable to 't' causes all protocol messages exchanged + with Emacs to be printed to '*TERMINAL-IO*'. This is useful for + low-level debugging and for observing how SLY works "on the wire." + The output of '*TERMINAL-IO*' can be found in your Lisp system's + own listener, usually in the buffer '*inferior-lisp*'. + + +File: sly.info, Node: Tips and Tricks, Next: Extensions, Prev: Customization, Up: Top + +8 Tips and Tricks +***************** + +* Menu: + +* Connecting to a remote Lisp:: +* Loading Slynk faster:: +* Auto-SLY:: +* REPLs and game loops:: +* Controlling SLY from outside Emacs:: + + +File: sly.info, Node: Connecting to a remote Lisp, Next: Loading Slynk faster, Up: Tips and Tricks + +8.1 Connecting to a remote Lisp +=============================== + +One of the advantages of the way SLY is implemented is that we can +easily run the Emacs side ('sly.el' and friends) on one machine and the +Lisp backend (Slynk) on another. The basic idea is to start up Lisp on +the remote machine, load Slynk and wait for incoming SLY connections. +On the local machine we start up Emacs and tell SLY to connect to the +remote machine. The details are a bit messier but the underlying idea +is that simple. + +* Menu: + +* Setting up the Lisp image:: +* Setting up Emacs:: +* Setting up pathname translations:: + + +File: sly.info, Node: Setting up the Lisp image, Next: Setting up Emacs, Up: Connecting to a remote Lisp + +8.1.1 Setting up the Lisp image +------------------------------- + +The easiest way to load Slynk "standalone" (i.e. without having 'M-x +sly' start a Lisp that is subsidiary to a particular Emacs), is to load +the ASDF system definition for Slynk. + + Make sure the path to the directory containing Slynk's '.asd' file is +in 'ASDF:*CENTRAL-REGISTRY*'. This file lives in the 'slynk' +subdirectory of SLY. Type: + + (push #p"/path/to/sly/slynk/" ASDF:*CENTRAL-REGISTRY*) + (asdf:require-system :slynk) + + inside a running Lisp image(1). + + Now all we need to do is startup our Slynk server. A working example +uses the default settings: + + (slynk:create-server) + + This creates a "one-connection-only" server on port 4005 using the +preferred communication style for your Lisp system. The following +parameters to 'slynk:create-server' can be used to change that +behaviour: + +':PORT' + Port number for the server to listen on (default: 4005). +':DONT-CLOSE' + Boolean indicating if the server will continue to accept + connections after the first one (default: 'NIL'). For + "long-running" Lisp processes to which you want to be able to + connect from time to time, specify ':dont-close t' +':STYLE' + See *Note Communication style::. + + So a more complete example will be + (slynk:create-server :port 4006 :dont-close t) + + Finally, since section we're going to be tunneling our connection via +SSH(2) we'll only have one port open we must tell Slynk's REPL contrib +(see REPL) to not use an extra connection for output, which it will do +by default. + + (setf slynk:*use-dedicated-output-stream* nil) + + (3) + + ---------- Footnotes ---------- + + (1) SLY also SLIME's old-style 'slynk-loader.lisp' loader which does +the same thing, but ASDF is preferred + + (2) there is a way to connect without an SSH tunnel, but it has the +side-effect of giving the entire world access to your Lisp image, so +we're not going to talk about it + + (3) Alternatively, a separate tunnel for the port set in +'slynk:*dedicated-output-stream-port*' can also be used if a dedicated +output is essential. + + +File: sly.info, Node: Setting up Emacs, Next: Setting up pathname translations, Prev: Setting up the Lisp image, Up: Connecting to a remote Lisp + +8.1.2 Setting up Emacs +---------------------- + +Now we need to create the tunnel between the local machine and the +remote machine. Assuming a UNIX command-line, this can be done with: + + ssh -L4005:localhost:4005 youruser@remote.example.com + + This incantation creates a SSH tunnel between the port 4005 on our +local machine and the port 4005 on the remote machine, where 'youruser' +is expected to have an account. (1). + + Finally we start SLY with 'sly-connect' instead of the usual 'sly': + + M-x sly-connect RET RET + + The 'RET RET' sequence just means that we want to use the default +host ('localhost') and the default port ('4005'). Even though we're +connecting to a remote machine the SSH tunnel fools Emacs into thinking +it's actually 'localhost'. + + ---------- Footnotes ---------- + + (1) By default Slynk listens for incoming connections on port 4005, +had we passed a ':port' parameter to 'slynk:create-server' we'd be using +that port number instead + + +File: sly.info, Node: Setting up pathname translations, Prev: Setting up Emacs, Up: Connecting to a remote Lisp + +8.1.3 Setting up pathname translations +-------------------------------------- + +One of the main problems with running slynk remotely is that Emacs +assumes the files can be found using normal filenames. if we want +things like 'sly-compile-and-load-file' ('C-c C-k') and +'sly-edit-definition' ('M-.') to work correctly we need to find a way to +let our local Emacs refer to remote files. + + There are, mainly, two ways to do this. The first is to mount, using +NFS or similar, the remote machine's hard disk on the local machine's +file system in such a fashion that a filename like +'/opt/project/source.lisp' refers to the same file on both machines. +Unfortunately NFS is usually slow, often buggy, and not always feasible. +Fortunately we have an ssh connection and Emacs' 'tramp-mode' can do the +rest. (See *note TRAMP User Manual: (tramp)Top.) + + What we do is teach Emacs how to take a filename on the remote +machine and translate it into something that tramp can understand and +access (and vice versa). Assuming the remote machine's host name is +'remote.example.com', 'cl:machine-instance' returns "remote" and we +login as the user "user" we can use 'sly-tramp' contrib to setup the +proper translations by simply doing: + + (add-to-list 'sly-filename-translations + (sly-create-filename-translator + :machine-instance "remote" + :remote-host "remote.example.com" + :username "user")) + + +File: sly.info, Node: Loading Slynk faster, Next: Auto-SLY, Prev: Connecting to a remote Lisp, Up: Tips and Tricks + +8.2 Loading Slynk faster +======================== + +In this section, a technique to load Slynk faster on South Bank Common +Lisp (SBCL) is presented. Similar setups should also work for other +Lisp implementations. + + A pre-canned solution that automates this technique was developed by +Pierre Neidhardt (https://gitlab.com/ambrevar/lisp-repl-core-dumper). + + For SBCL, we recommend that you create a custom core file with socket +support and POSIX bindings included because those modules take the most +time to load. To create such a core, execute the following steps: + + shell$ sbcl + * (mapc 'require '(sb-bsd-sockets sb-posix sb-introspect sb-cltl2 asdf)) + * (save-lisp-and-die "sbcl.core-for-sly") + + After that, add something like this to your '~/.emacs' or +'~/.emacs.d/init.el' (*note Emacs Init File::): + + (setq sly-lisp-implementations '((sbcl ("sbcl" "--core" + "sbcl.core-for-sly")))) + + For maximum startup speed you can include the Slynk server directly +in a core file. The disadvantage of this approach is that the setup is +a bit more involved and that you need to create a new core file when you +want to update SLY or SBCL. The steps to execute are: + + shell$ sbcl + * (load ".../sly/slynk-loader.lisp") + * (slynk-loader:dump-image "sbcl.core-with-slynk") + +Then add this to the Emacs initializion file: + + (setq sly-lisp-implementations + '((sbcl ("sbcl" "--core" "sbcl.core-with-slynk") + :init (lambda (port-file _) + (format "(slynk:start-server %S)\n" port-file))))) + + +File: sly.info, Node: Auto-SLY, Next: REPLs and game loops, Prev: Loading Slynk faster, Up: Tips and Tricks + +8.3 Connecting to SLY automatically +=================================== + +To make SLY connect to your lisp whenever you open a lisp file just add +this to your '~/.emacs' or '~/.emacs.d/init.el' (*note Emacs Init +File::): + + (add-hook 'sly-mode-hook + (lambda () + (unless (sly-connected-p) + (save-excursion (sly))))) + + +File: sly.info, Node: REPLs and game loops, Next: Controlling SLY from outside Emacs, Prev: Auto-SLY, Up: Tips and Tricks + +8.4 REPLs and "Game Loops" +========================== + +When developing Common Lisp video games or graphical applications, a +REPL (*note REPL::) is just as useful as anywhere else. But it is often +the case that one needs to control exactly the timing of REPL requests +and ensure they do not interfere with the "game loop". In other +situations, the choice of communication style (*note Communication +style::) to the Slynk server may invalidate simultaneous multi-threaded +operation of REPL and game loop. + + Instead of giving up on the REPL or using a complicated solution, +SLY's REPL can be built into your game loop by using a couple of Slynk +Common Lisp functions, 'SLYNK-MREPL:SEND-PROMPT' and +'SLYNK:PROCESS-REQUESTS'. + + (defun my-repl-aware-game-loop () + (loop initially + (princ "Starting our game") + (slynk-mrepl:send-prompt) + for i from 0 + do (with-simple-restart (abort "Skip rest of this game loop iteration") + (when (zerop (mod i 10)) + (fresh-line) + (princ "doing high-priority 3D game loop stuff")) + (sleep 0.1) + ;; When you're ready to serve a potential waiting + ;; REPL request, just do this non-blocking thing: + (with-simple-restart (abort "Abort this game REPL evaluation") + (slynk:process-requests t))))) + + Note that this function is to be called _from the REPL_, and will +enter kind of "sub-REPL" inside it. It'll likely "just work" in this +situation. However, if you need you need to call this from anywhere +else (like, say, another thread), you must additionally arrange for the +variable 'SLYNK-API:*CHANNEL*' to be bound to the value it is bound to +in whatever SLY REPL you wish to interact with your game. + + +File: sly.info, Node: Controlling SLY from outside Emacs, Prev: REPLs and game loops, Up: Tips and Tricks + +8.5 Controlling SLY from outside Emacs +====================================== + +If your application has a non-SLY, non-Emacs user interface (graphical +or otherwise), you can use it to exert some control over SLY +functionality, such as its REPL (*note REPL::) and inspector (*note +Inspector::). This requires that you first set, in Emacs, variable +'sly-enable-evaluate-in-emacs' to non-nil. As the name suggests, it +lets outside Slynk servers evaluate code in your Elisp runtime. It is +set to 'nil' by default for security purposes. + + Once you've done that, you can call +'SLYNK-MREPL:COPY-TO-REPL-IN-EMACS' from your CL code with some objects +you'd like to manipulate in the REPL. Then you can have this code run +from some UI event handler: + + (lambda () + (slynk-mrepl:copy-to-repl-in-emacs + (list 42 'foo) + :blurb "Just a forty-two and a foo")) + + And see those objects pop up in your REPL for inspection and +manipulation. + + You can also use the functions 'SLYNK:INSPECT-IN-EMACS', +'SLYNK:ED-IN-EMACS', and in general, any exported function ending in +'IN-EMACS'. See their docstrings for details. + + +File: sly.info, Node: Extensions, Next: Credits, Prev: Tips and Tricks, Up: Top + +9 Extensions +************ + +* Menu: + +* Loading and unloading:: More contribs:: +* More contribs:: + +Extensions, also known as "contribs" are Emacs packages that extend +SLY’s functionality. Contrasting with its ancestor SLIME (*note +Introduction::), most contribs bundled with SLY are active by default, +since they are a decent way to split SLY into pluggable modules. The +auto-documentation (*note Autodoc::), trace (*note Trace Dialog::) and +Stickers (*note Stickers::) are contribs enabled by default, for +example. + + Usually, contribs differ from regular Emacs plugins in that they are +partly written in Emacs-lisp and partly in Common Lisp. The former is +usually the UI that queries the latter for information and then presents +it to the user. SLIME used to load all the contribs’ Common Lisp code +upfront, but SLY takes care to loading these two parts at the correct +time. In this way, developers can write third-party contribs that live +independently of SLY perhaps even in different code repositories. The +'sly-macrostep' contrib (<https://github.com/joaotavora/sly-macrostep>) +is one such example. + + A special 'sly-fancy' contrib package is the only one loaded by +default. You might never want to fiddle with it (it is the one that +contains the default extensions), but if you find that you don't like +some package or you are having trouble with a package, you can modify +your setup a bit. Generally, you set the variable 'sly-contribs' with +the list of package-names that you want to use. For example, a setup to +load only the 'sly-scratch' and 'sly-mrepl' packages looks like: + + ;; _Setup load-path and autoloads_ + (add-to-list 'load-path "~/dir/to/cloned/sly") + (require 'sly-autoloads) + + ;; _Set your lisp system and some contribs_ + (setq inferior-lisp-program "/opt/sbcl/bin/sbcl") + (setq sly-contribs '(sly-scratch sly-mrepl)) + + After starting SLY, the commands of both packages should be +available. + + +File: sly.info, Node: Loading and unloading, Next: More contribs, Up: Extensions + +9.1 Loading and unloading "on the fly" +====================================== + +We recommend that you setup the 'sly-contribs' variable _before_ +starting SLY via 'M-x sly', but if you want to enable more contribs +_after_ you that, you can set new 'sly-contribs' variable to another +value and call 'M-x sly-setup' or 'M-x sly-enable-contrib'. Note this +though: + + * If you've removed contribs from the list they won't be unloaded + automatically. + * If you have more than one SLY connection currently active, you must + manually repeat the 'sly-setup' step for each of them. + + Short of restarting Emacs, a reasonable way of unloading contribs is +by calling an Emacs Lisp function whose name is obtained by adding +'-unload' to the contrib's name, for every contrib you wish to unload. +So, to remove 'sly-mrepl', you must call 'sly-mrepl-unload'. Because +the unload function will only, if ever, unload the Emacs Lisp side of +the contrib, you may also need to restart your lisps. + + +File: sly.info, Node: More contribs, Prev: Loading and unloading, Up: Extensions + +9.2 More contribs +================= + +* Menu: + +* TRAMP Support:: +* Scratch Buffer:: + + +File: sly.info, Node: TRAMP Support, Next: Scratch Buffer, Up: More contribs + +9.2.1 TRAMP +----------- + +The package 'sly-tramp' provides some functions to set up filename +translations for TRAMP. (*note Setting up pathname translations::) + + +File: sly.info, Node: Scratch Buffer, Prev: TRAMP Support, Up: More contribs + +9.2.2 Scratch Buffer +-------------------- + +The SLY scratch buffer, in contrib package 'sly-scratch', imitates +Emacs' usual '*scratch*' buffer. If 'sly-scratch-file' is set, it is +used to back the scratch buffer, making it persistent. The buffer is +like any other Lisp buffer, except for the command bound to 'C-j'. + +'C-j' +'M-x sly-eval-print-last-expression' + Evaluate the expression sexp before point and insert a printed + representation of the return values into the current buffer. + +'M-x sly-scratch' + Create a '*sly-scratch*' buffer. In this buffer you can enter Lisp + expressions and evaluate them with 'C-j', like in Emacs's + '*scratch*' buffer. + + +File: sly.info, Node: Credits, Next: Key Index, Prev: Extensions, Up: Top + +10 Credits +********** + +_The soppy ending..._ + +Hackers of the good hack +======================== + +SLY is a fork of SLIME which is itself an Extension of SLIM by Eric +Marsden. At the time of writing, the authors and code-contributors of +SLY are: + +Helmut Eller João Távora Luke Gorrie +Tobias C. Rittweiler Stas Boukarev Marco Baringer +Matthias Koeppe Nikodemus Siivola Alan Ruttenberg +Attila Lendvai Luís Borges de Dan Barlow + Oliveira +Andras Simon Martin Simmons Geo Carncross +Christophe Rhodes Peter Seibel Mark Evenson +Juho Snellman Douglas Crosher Wolfgang Jenkner +R Primus Javier Olaechea Edi Weitz +Zach Shaftel James Bielman Daniel Kochmanski +Terje Norderhaug Vladimir Sedach Juan Jose Garcia + Ripoll +Alexander Artemenko Spenser Truex Nathan Trapuzzano +Brian Downing Mark Jeffrey Cunningham +Espen Wiborg Paul M. Rodriguez Masataro Asai +Jan Moringen Sébastien Villemot Samuel Freilich +Raymond Toy Pierre Neidhardt Phil Hargett +Paulo Madeira Kris Katterjohn Jonas Bernoulli +Ivan Shvedunov Gábor Melis Francois-Rene Rideau +Christophe Junke Bozhidar Batsov Bart Botta +Wilfredo Tianxiang Xiong Syohei YOSHIDA +Velázquez-Rodríguez +Stefan Monnier Rommel MARTINEZ Pavel Kulyov +Paul A. Patience Olof-Joachim Frahm Mike Clarke +Michał Herda Mark H. David Mario Lang +Manfred Bergmann Leo Liu Koga Kazuo +Jon Oddie John Stracke Joe Robertson +Grant Shangreaux Graham Dobbins Eric Timmons +Douglas Katzman Dmitry Igrishin Dmitrii Korobeinikov +Deokhwan Kim Denis Budyak Chunyang Xu +Cayman Angelo Rossi Andrew Kirkpatrick + + ... not counting the bundled code from 'hyperspec.el', 'CLOCC', and +the 'CMU AI Repository'. + + Many people on the 'sly-devel' mailing list have made non-code +contributions to SLY. Life is hard though: you gotta send code to get +your name in the manual. ':-)' + +Thanks! +======= + +We're indebted to the good people of 'common-lisp.net' for their hosting +and help, and for rescuing us from "Sourceforge hell." + + Implementors of the Lisps that we support have been a great help. +We'd like to thank the CMUCL maintainers for their helpful answers, +Craig Norvell and Kevin Layer at Franz providing Allegro CL licenses for +SLY development, and Peter Graves for his help to get SLY running with +ABCL. + + Most of all we're happy to be working with the Lisp implementors +who've joined in the SLY development: Dan Barlow and Christophe Rhodes +of SBCL, Gary Byers of OpenMCL, and Martin Simmons of LispWorks. Thanks +also to Alain Picard and Memetrics for funding Martin's initial work on +the LispWorks backend! + + +File: sly.info, Node: Key Index, Next: Command Index, Prev: Credits, Up: Top + +Key (Character) Index +********************* + + +* Menu: + +* 0 ... 9: Restarts. (line 22) +* :: Miscellaneous. (line 28) +* <: Frame Navigation. (line 23) +* >: Inspector. (line 61) +* > <1>: Frame Navigation. (line 19) +* a: Restarts. (line 8) +* A: Miscellaneous. (line 31) +* B: Miscellaneous. (line 19) +* c: Restarts. (line 18) +* C: Miscellaneous. (line 24) +* C-c :: Evaluation. (line 34) +* C-c <: Cross-referencing. (line 57) +* C-c >: Cross-referencing. (line 61) +* C-c C-b: Recovery. (line 8) +* C-c C-b <1>: REPL commands. (line 46) +* C-c C-c: Compilation. (line 14) +* C-c C-c <1>: Cross-referencing. (line 77) +* C-c C-c <2>: Examining frames. (line 38) +* C-c C-d #: Documentation. (line 58) +* C-c C-d C-a: Documentation. (line 24) +* C-c C-d C-d: Documentation. (line 16) +* C-c C-d C-f: Documentation. (line 20) +* C-c C-d C-h: Documentation. (line 43) +* C-c C-d C-p: Documentation. (line 36) +* C-c C-d C-z: Documentation. (line 32) +* C-c C-d ~: Documentation. (line 54) +* C-c C-k: Compilation. (line 30) +* C-c C-k <1>: Cross-referencing. (line 82) +* C-c C-l: Compilation. (line 48) +* C-c C-m: Macro-expansion. (line 8) +* C-c C-m <1>: Macro-expansion. (line 37) +* C-c C-o: REPL commands. (line 63) +* C-c C-p: Evaluation. (line 42) +* C-c C-r: Evaluation. (line 38) +* C-c C-t: Disassembly. (line 12) +* C-c C-t <1>: Trace Dialog. (line 26) +* C-c C-u: Evaluation. (line 53) +* C-c C-w C-b: Cross-referencing. (line 36) +* C-c C-w C-c: Cross-referencing. (line 24) +* C-c C-w C-m: Cross-referencing. (line 44) +* C-c C-w C-r: Cross-referencing. (line 32) +* C-c C-w C-s: Cross-referencing. (line 40) +* C-c C-w C-w: Cross-referencing. (line 28) +* C-c C-x c: Multiple connections. (line 31) +* C-c C-x n: Multiple connections. (line 35) +* C-c C-x p: Multiple connections. (line 40) +* C-c C-z: REPL. (line 29) +* C-c E: Evaluation. (line 47) +* C-c I: Inspector. (line 16) +* C-c M-c: Compilation. (line 69) +* C-c M-d: Disassembly. (line 8) +* C-c M-k: Compilation. (line 44) +* C-c M-m: Macro-expansion. (line 19) +* C-c M-o: REPL commands. (line 69) +* C-c T: Trace Dialog. (line 39) +* C-c ~: Recovery. (line 15) +* C-c ~ <1>: REPL. (line 36) +* C-j: Scratch Buffer. (line 13) +* C-k: Trace Dialog. (line 83) +* C-M-n: REPL commands. (line 58) +* C-M-p: REPL commands. (line 53) +* C-M-x: Evaluation. (line 20) +* C-n: Completion. (line 55) +* C-p: Completion. (line 60) +* C-r: REPL commands. (line 35) +* C-x 4 .: Finding definitions. (line 30) +* C-x 5 .: Finding definitions. (line 35) +* C-x C-e: Evaluation. (line 14) +* C-x `: Compilation. (line 73) +* C-_: Macro-expansion. (line 51) +* d: Multiple connections. (line 57) +* D: Inspector. (line 27) +* d <1>: Examining frames. (line 24) +* D <1>: Examining frames. (line 29) +* e: Inspector. (line 31) +* e <1>: Examining frames. (line 19) +* g: Macro-expansion. (line 42) +* g <1>: Multiple connections. (line 62) +* g <2>: Inspector. (line 49) +* g <3>: Trace Dialog. (line 76) +* G: Trace Dialog. (line 79) +* h: Inspector. (line 53) +* i: Examining frames. (line 34) +* l: Inspector. (line 41) +* M-,: Finding definitions. (line 25) +* M-.: Finding definitions. (line 20) +* M-?: Cross-referencing. (line 19) +* M-n: Compilation. (line 61) +* M-n <1>: REPL commands. (line 28) +* M-n <2>: Frame Navigation. (line 12) +* M-p: Compilation. (line 65) +* M-p <1>: REPL commands. (line 21) +* M-p <2>: Frame Navigation. (line 12) +* M-RET: Inspector. (line 65) +* n: Inspector. (line 45) +* n <1>: Frame Navigation. (line 8) +* p: Frame Navigation. (line 8) +* q: Macro-expansion. (line 47) +* q <1>: Multiple connections. (line 66) +* q <2>: Inspector. (line 57) +* q <3>: Restarts. (line 12) +* R: Multiple connections. (line 71) +* r: Miscellaneous. (line 8) +* R <1>: Miscellaneous. (line 14) +* RET: Cross-referencing. (line 67) +* RET <1>: Multiple connections. (line 53) +* RET <2>: REPL commands. (line 8) +* RET <3>: Inspector. (line 22) +* S-TAB: Inspector. (line 70) +* Space: Cross-referencing. (line 72) +* t: Examining frames. (line 10) +* tab: Completion. (line 65) +* TAB: REPL commands. (line 13) +* TAB <1>: Inspector. (line 70) +* v: Inspector. (line 36) +* v <1>: Examining frames. (line 14) + + +File: sly.info, Node: Command Index, Next: Variable Index, Prev: Key Index, Up: Top + +Command and Function Index +************************** + + +* Menu: + +* backward-button: Inspector. (line 70) +* forward-button: Inspector. (line 70) +* hyperspec-lookup-format: Documentation. (line 54) +* hyperspec-lookup-reader-macro: Documentation. (line 58) +* isearch-backward: REPL commands. (line 35) +* next-error: Compilation. (line 73) +* sly-abort-connection: Multiple connections. (line 81) +* sly-apropos: Documentation. (line 24) +* sly-apropos-all: Documentation. (line 32) +* sly-apropos-package: Documentation. (line 36) +* sly-arglist NAME: Autodoc. (line 11) +* sly-autodoc-manually: Autodoc. (line 17) +* sly-autodoc-mode: Autodoc. (line 14) +* sly-button-backward: REPL commands. (line 53) +* sly-button-forward: REPL commands. (line 58) +* sly-calls-who: Cross-referencing. (line 28) +* sly-cd: Recovery. (line 19) +* sly-choose-completion: Completion. (line 65) +* sly-compile-and-load-file: Compilation. (line 30) +* sly-compile-defun: Compilation. (line 14) +* sly-compile-file: Compilation. (line 44) +* sly-compile-region: Compilation. (line 51) +* sly-compiler-macroexpand: Macro-expansion. (line 25) +* sly-compiler-macroexpand-1: Macro-expansion. (line 22) +* sly-connect: Multiple connections. (line 74) +* sly-connection-list-make-default: Multiple connections. (line 57) +* sly-db-abort: Restarts. (line 8) +* sly-db-beginning-of-backtrace: Frame Navigation. (line 23) +* sly-db-break-with-default-debugger: Miscellaneous. (line 19) +* sly-db-break-with-system-debugger: Miscellaneous. (line 31) +* sly-db-continue: Restarts. (line 18) +* sly-db-details-down: Frame Navigation. (line 12) +* sly-db-details-up: Frame Navigation. (line 12) +* sly-db-disassemble: Examining frames. (line 29) +* sly-db-down: Frame Navigation. (line 8) +* sly-db-end-of-backtrace: Frame Navigation. (line 19) +* sly-db-eval-in-frame: Examining frames. (line 19) +* sly-db-inspect-condition: Miscellaneous. (line 24) +* sly-db-inspect-in-frame: Examining frames. (line 34) +* sly-db-invoke-restart-n: Restarts. (line 22) +* sly-db-pprint-eval-in-frame: Examining frames. (line 24) +* sly-db-quit: Restarts. (line 12) +* sly-db-recompile-frame-source: Examining frames. (line 38) +* sly-db-restart-frame: Miscellaneous. (line 8) +* sly-db-return-from-frame: Miscellaneous. (line 14) +* sly-db-show-frame-source: Examining frames. (line 14) +* sly-db-toggle-details: Examining frames. (line 10) +* sly-db-up: Frame Navigation. (line 8) +* sly-describe-function: Documentation. (line 20) +* sly-describe-symbol: Documentation. (line 16) +* sly-disassemble-symbol: Disassembly. (line 8) +* sly-disconnect: Multiple connections. (line 78) +* sly-edit-definition: Finding definitions. (line 20) +* sly-edit-definition-other-frame: Finding definitions. (line 35) +* sly-edit-definition-other-window: Finding definitions. (line 30) +* sly-edit-uses: Cross-referencing. (line 19) +* sly-edit-value: Evaluation. (line 47) +* sly-eval-defun: Evaluation. (line 20) +* sly-eval-last-expression: Evaluation. (line 14) +* sly-eval-print-last-expression: Scratch Buffer. (line 13) +* sly-eval-region: Evaluation. (line 38) +* sly-expand-1: Macro-expansion. (line 8) +* sly-format-string-expand: Macro-expansion. (line 28) +* sly-goto-connection: Multiple connections. (line 53) +* sly-goto-xref: Cross-referencing. (line 72) +* sly-hyperspec-lookup: Documentation. (line 43) +* sly-info: Documentation. (line 11) +* sly-inspect: Inspector. (line 16) +* sly-inspector-describe-inspectee: Inspector. (line 27) +* sly-inspector-eval: Inspector. (line 31) +* sly-inspector-fetch-all: Inspector. (line 61) +* sly-inspector-history: Inspector. (line 53) +* sly-inspector-next: Inspector. (line 45) +* sly-inspector-operate-on-point: Inspector. (line 22) +* sly-inspector-pop: Inspector. (line 41) +* sly-inspector-quit: Inspector. (line 57) +* sly-inspector-reinspect: Inspector. (line 49) +* sly-inspector-toggle-verbose: Inspector. (line 36) +* sly-interactive-eval: Evaluation. (line 34) +* sly-interactive-eval <1>: Miscellaneous. (line 28) +* sly-interrupt: Recovery. (line 8) +* sly-interrupt <1>: REPL commands. (line 46) +* sly-list-callees: Cross-referencing. (line 61) +* sly-list-callers: Cross-referencing. (line 57) +* sly-list-connections: Multiple connections. (line 31) +* sly-load-file: Compilation. (line 48) +* sly-macroexpand-1: Macro-expansion. (line 14) +* sly-macroexpand-1-inplace: Macro-expansion. (line 37) +* sly-macroexpand-1-inplace <1>: Macro-expansion. (line 42) +* sly-macroexpand-all: Macro-expansion. (line 19) +* sly-macroexpand-undo: Macro-expansion. (line 51) +* sly-mrepl: REPL. (line 29) +* sly-mrepl-clear-recent-output: REPL commands. (line 63) +* sly-mrepl-clear-repl: REPL commands. (line 69) +* sly-mrepl-copy-part-to-repl: Inspector. (line 65) +* sly-mrepl-indent-and-complete-symbol: REPL commands. (line 13) +* sly-mrepl-new: REPL. (line 32) +* sly-mrepl-next-input-or-button: REPL commands. (line 28) +* sly-mrepl-previous-input-or-button: REPL commands. (line 21) +* sly-mrepl-return: REPL commands. (line 8) +* sly-mrepl-sync: Recovery. (line 15) +* sly-mrepl-sync <1>: REPL. (line 36) +* sly-next-completion: Completion. (line 55) +* sly-next-connection: Multiple connections. (line 35) +* sly-next-note: Compilation. (line 61) +* sly-pop-find-definition-stack: Finding definitions. (line 25) +* sly-pprint-eval-last-expression: Evaluation. (line 42) +* sly-prev-completion: Completion. (line 60) +* sly-prev-connection: Multiple connections. (line 40) +* sly-previous-note: Compilation. (line 65) +* sly-pwd: Recovery. (line 23) +* sly-recompile-all-xrefs: Cross-referencing. (line 82) +* sly-recompile-xref: Cross-referencing. (line 77) +* sly-remove-notes: Compilation. (line 69) +* sly-restart-connection-at-point: Multiple connections. (line 71) +* sly-restart-inferior-lisp: Recovery. (line 11) +* sly-scratch: Scratch Buffer. (line 17) +* sly-show-xref: Cross-referencing. (line 67) +* sly-temp-buffer-quit: Macro-expansion. (line 47) +* sly-temp-buffer-quit <1>: Multiple connections. (line 66) +* sly-toggle-trace-fdefinition: Disassembly. (line 12) +* sly-trace-dialog: Trace Dialog. (line 39) +* sly-trace-dialog-clear-fetched-traces: Trace Dialog. (line 83) +* sly-trace-dialog-fetch-status: Trace Dialog. (line 76) +* sly-trace-dialog-fetch-traces: Trace Dialog. (line 79) +* sly-trace-dialog-toggle-trace: Trace Dialog. (line 26) +* sly-undefine-function: Evaluation. (line 53) +* sly-untrace-all: Disassembly. (line 17) +* sly-update-connection-list: Multiple connections. (line 62) +* sly-who-binds: Cross-referencing. (line 36) +* sly-who-calls: Cross-referencing. (line 24) +* sly-who-macroexpands: Cross-referencing. (line 44) +* sly-who-references: Cross-referencing. (line 32) +* sly-who-sets: Cross-referencing. (line 40) +* sly-who-specializes: Cross-referencing. (line 47) + + +File: sly.info, Node: Variable Index, Prev: Command Index, Up: Top + +Variable and Concept Index +************************** + + +* Menu: + +* ASCII: Defcustom variables. (line 29) +* Character Encoding: Defcustom variables. (line 29) +* Compilation: Compilation. (line 6) +* Compiling Functions: Compilation. (line 12) +* Completion: Completion. (line 6) +* Contribs: Extensions. (line 11) +* Contributions: Extensions. (line 11) +* Debugger: Debugger. (line 6) +* Extensions: Extensions. (line 11) +* LATIN-1: Defcustom variables. (line 29) +* Listener: REPL. (line 6) +* Macros: Macro-expansion. (line 6) +* Plugins: Extensions. (line 11) +* Symbol Completion: Completion. (line 6) +* TRAMP: TRAMP Support. (line 6) +* Unicode: Defcustom variables. (line 29) +* UTF-8: Defcustom variables. (line 29) + + + +Tag Table: +Node: Top294 +Node: Introduction2278 +Node: Getting started4597 +Node: Platforms4908 +Node: Downloading6008 +Node: Basic setup7008 +Node: Running7941 +Node: Basic customization8805 +Node: Multiple Lisps10521 +Node: A SLY tour for SLIME users13016 +Node: Working with source files23902 +Node: Evaluation24630 +Node: Compilation26457 +Node: Autodoc29310 +Node: Semantic indentation30252 +Ref: Semantic indentation-Footnote-132359 +Node: Reader conditionals32454 +Node: Macro-expansion32830 +Node: Common functionality34462 +Node: Finding definitions35233 +Node: Cross-referencing37063 +Ref: Cross-referencing-Footnote-139455 +Node: Completion39683 +Node: Interactive objects42675 +Node: Documentation44591 +Node: Multiple connections46625 +Node: Disassembly49576 +Node: Recovery50108 +Node: Temporary buffers50731 +Node: Multi-threading52147 +Node: The REPL and other special buffers53715 +Node: REPL53988 +Node: REPL commands55840 +Node: REPL output57855 +Node: REPL backreferences62460 +Ref: REPL backreferences-Footnote-165612 +Node: Inspector65665 +Node: Debugger67611 +Node: Examining frames68268 +Node: Restarts69352 +Ref: sly-db-quit69558 +Node: Frame Navigation69977 +Node: Miscellaneous70661 +Node: Trace Dialog71570 +Node: Stickers75354 +Node: Customization79468 +Node: Emacs-side79671 +Node: Keybindings79863 +Ref: describe-key80665 +Ref: describe-bindings80792 +Ref: describe-mode80923 +Ref: view-lossage81095 +Ref: Emacs Init File81231 +Node: Keymaps81863 +Node: Defcustom variables84500 +Ref: sly-complete-symbol-function85189 +Ref: sly-net-coding-system85737 +Node: Hooks88096 +Ref: sly-connected-hook88444 +Node: Lisp-side customization88887 +Node: Communication style89285 +Node: Other configurables91812 +Ref: *SLY-DB-QUIT-RESTART*92519 +Node: Tips and Tricks98053 +Node: Connecting to a remote Lisp98327 +Node: Setting up the Lisp image99034 +Ref: Setting up the Lisp image-Footnote-1100821 +Ref: Setting up the Lisp image-Footnote-2100932 +Ref: Setting up the Lisp image-Footnote-3101106 +Node: Setting up Emacs101259 +Ref: Setting up Emacs-Footnote-1102213 +Node: Setting up pathname translations102383 +Node: Loading Slynk faster103960 +Ref: init-example105437 +Node: Auto-SLY105659 +Node: REPLs and game loops106140 +Node: Controlling SLY from outside Emacs108107 +Node: Extensions109352 +Node: Loading and unloading111399 +Node: More contribs112475 +Node: TRAMP Support112646 +Node: Scratch Buffer112889 +Ref: sly-scratch113015 +Node: Credits113648 +Node: Key Index116917 +Node: Command Index125536 +Node: Variable Index135559 + +End Tag Table + + +Local Variables: +coding: utf-8 +End: diff --git a/elpa/sly-20211121.1002/slynk/backend/abcl.lisp b/elpa/sly-20220302.1053/slynk/backend/abcl.lisp diff --git a/elpa/sly-20211121.1002/slynk/backend/allegro.lisp b/elpa/sly-20220302.1053/slynk/backend/allegro.lisp diff --git a/elpa/sly-20211121.1002/slynk/backend/ccl.lisp b/elpa/sly-20220302.1053/slynk/backend/ccl.lisp diff --git a/elpa/sly-20211121.1002/slynk/backend/clasp.lisp b/elpa/sly-20220302.1053/slynk/backend/clasp.lisp diff --git a/elpa/sly-20211121.1002/slynk/backend/clisp.lisp b/elpa/sly-20220302.1053/slynk/backend/clisp.lisp diff --git a/elpa/sly-20211121.1002/slynk/backend/cmucl.lisp b/elpa/sly-20220302.1053/slynk/backend/cmucl.lisp diff --git a/elpa/sly-20211121.1002/slynk/backend/corman.lisp b/elpa/sly-20220302.1053/slynk/backend/corman.lisp diff --git a/elpa/sly-20211121.1002/slynk/backend/ecl.lisp b/elpa/sly-20220302.1053/slynk/backend/ecl.lisp diff --git a/elpa/sly-20211121.1002/slynk/backend/lispworks.lisp b/elpa/sly-20220302.1053/slynk/backend/lispworks.lisp diff --git a/elpa/sly-20211121.1002/slynk/backend/mkcl.lisp b/elpa/sly-20220302.1053/slynk/backend/mkcl.lisp diff --git a/elpa/sly-20211121.1002/slynk/backend/sbcl.lisp b/elpa/sly-20220302.1053/slynk/backend/sbcl.lisp diff --git a/elpa/sly-20211121.1002/slynk/backend/scl.lisp b/elpa/sly-20220302.1053/slynk/backend/scl.lisp diff --git a/elpa/sly-20211121.1002/slynk/metering.lisp b/elpa/sly-20220302.1053/slynk/metering.lisp diff --git a/elpa/sly-20211121.1002/slynk/slynk-apropos.lisp b/elpa/sly-20220302.1053/slynk/slynk-apropos.lisp diff --git a/elpa/sly-20211121.1002/slynk/slynk-backend.lisp b/elpa/sly-20220302.1053/slynk/slynk-backend.lisp diff --git a/elpa/sly-20211121.1002/slynk/slynk-completion.lisp b/elpa/sly-20220302.1053/slynk/slynk-completion.lisp diff --git a/elpa/sly-20211121.1002/slynk/slynk-gray.lisp b/elpa/sly-20220302.1053/slynk/slynk-gray.lisp diff --git a/elpa/sly-20211121.1002/slynk/slynk-loader.lisp b/elpa/sly-20220302.1053/slynk/slynk-loader.lisp diff --git a/elpa/sly-20211121.1002/slynk/slynk-match.lisp b/elpa/sly-20220302.1053/slynk/slynk-match.lisp diff --git a/elpa/sly-20211121.1002/slynk/slynk-rpc.lisp b/elpa/sly-20220302.1053/slynk/slynk-rpc.lisp diff --git a/elpa/sly-20211121.1002/slynk/slynk-source-file-cache.lisp b/elpa/sly-20220302.1053/slynk/slynk-source-file-cache.lisp diff --git a/elpa/sly-20211121.1002/slynk/slynk-source-path-parser.lisp b/elpa/sly-20220302.1053/slynk/slynk-source-path-parser.lisp diff --git a/elpa/sly-20220302.1053/slynk/slynk.asd b/elpa/sly-20220302.1053/slynk/slynk.asd @@ -0,0 +1,122 @@ +;;; -*- lisp -*- +(in-package :asdf) + +;; ASDF system definition for loading the Slynk server independently +;; of Emacs. +;; +;; Usage: +;; +;; (push #p"/path/to/this/file/" asdf:*central-registry*) +;; (asdf:load-system :slynk) +;; (slynk:create-server :port PORT) => ACTUAL-PORT +;; +;; (PORT can be zero to mean "any available port".) +;; Then the Slynk server is running on localhost:ACTUAL-PORT. You can +;; use `M-x sly-connect' to connect Emacs to it. +;; +;; This code has been placed in the Public Domain. All warranties +;; are disclaimed. + +(defsystem :slynk + :serial t + ;; See commit message and GitHub#502, GitHub#501 for the reason + ;; for this dedicated sbcl muffling. + #+sbcl + :around-compile + #+sbcl + (lambda (thunk) + (handler-bind (((and warning (not style-warning)) + (lambda (c) + (format *error-output* "~&~@<~S: ~3i~:_~A~:>~%" + (class-name (class-of c)) c) + (muffle-warning c)))) + (let ((sb-ext:*on-package-variance* '(:warn t))) + (funcall thunk)))) + :components + ((:file "slynk-backend") + ;; If/when we require ASDF3, we shall use :if-feature instead + #+(or cmu sbcl scl) + (:file "slynk-source-path-parser") + #+(or cmu ecl sbcl scl) + (:file "slynk-source-file-cache") + #+clisp + (:file "xref") + #+(or clisp clozure clasp) + (:file "metering") + (:module "backend" + :serial t + :components (#+allegro + (:file "allegro") + #+armedbear + (:file "abcl") + #+clisp + (:file "clisp") + #+clozure + (:file "ccl") + #+cmu + (:file "cmucl") + #+cormanlisp + (:file "corman") + #+ecl + (:file "ecl") + #+lispworks + (:file "lispworks") + #+sbcl + (:file "sbcl") + #+clasp + (:file "clasp") + #+scl + (:file "scl") + #+mkcl + (:file "mkcl"))) + #-armedbear + (:file "slynk-gray") + (:file "slynk-match") + (:file "slynk-rpc") + (:file "slynk") + (:file "slynk-completion") + (:file "slynk-apropos"))) + +(defmethod perform :after ((o load-op) (c (eql (find-system :slynk)))) + (format *debug-io* "~&SLYNK's ASDF loader finished.") + (funcall (read-from-string "slynk::init"))) + + +;;; Contrib systems (should probably go into their own file one day) +;;; +(defsystem :slynk/arglists + :depends-on (:slynk) + :components ((:file "../contrib/slynk-arglists"))) + +(defsystem :slynk/fancy-inspector + :depends-on (:slynk) + :components ((:file "../contrib/slynk-fancy-inspector"))) + +(defsystem :slynk/package-fu + :depends-on (:slynk) + :components ((:file "../contrib/slynk-package-fu"))) + +(defsystem :slynk/mrepl + :depends-on (:slynk) + :components ((:file "../contrib/slynk-mrepl"))) + +(defsystem :slynk/trace-dialog + :depends-on (:slynk) + :components ((:file "../contrib/slynk-trace-dialog"))) + +(defsystem :slynk/profiler + :depends-on (:slynk) + :components ((:file "../contrib/slynk-profiler"))) + +(defsystem :slynk/stickers + :depends-on (:slynk) + :components ((:file "../contrib/slynk-stickers"))) + +(defsystem :slynk/indentation + :depends-on (:slynk) + :components ((:file "../contrib/slynk-indentation"))) + +(defsystem :slynk/retro + :depends-on (:slynk) + :components ((:file "../contrib/slynk-retro"))) + diff --git a/elpa/sly-20211121.1002/slynk/slynk.lisp b/elpa/sly-20220302.1053/slynk/slynk.lisp diff --git a/elpa/sly-20211121.1002/slynk/start-slynk.lisp b/elpa/sly-20220302.1053/slynk/start-slynk.lisp diff --git a/elpa/sly-20211121.1002/slynk/xref.lisp b/elpa/sly-20220302.1053/slynk/xref.lisp
