1;;; sly.el --- Sylvester the Cat's Common Lisp IDE -*- lexical-binding: t; -*- 2 3;; Version: 1.0.43 4;; URL: https://github.com/joaotavora/sly 5;; Package-Requires: ((emacs "24.3")) 6;; Keywords: languages, lisp, sly 7 8;; Copyright (C) 2003 Eric Marsden, Luke Gorrie, Helmut Eller 9;; Copyright (C) 2004,2005,2006 Luke Gorrie, Helmut Eller 10;; Copyright (C) 2007,2008,2009 Helmut Eller, Tobias C. Rittweiler 11;; Copyright (C) 2014 João Távora 12;; For a detailed list of contributors, see the manual. 13 14;; This program is free software: you can redistribute it and/or modify 15;; it under the terms of the GNU General Public License as published by 16;; the Free Software Foundation, either version 3 of the License, or 17;; (at your option) any later version. 18 19;; This program is distributed in the hope that it will be useful, 20;; but WITHOUT ANY WARRANTY; without even the implied warranty of 21;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 22;; GNU General Public License for more details. 23 24;; You should have received a copy of the GNU General Public License 25;; along with this program. If not, see <http://www.gnu.org/licenses/>. 26 27;;; Commentary: 28;; 29;; _____ __ __ __ 30;; / ___/ / / \ \/ / |\ _,,,---,,_ 31;; \__ \ / / \ / /,`.-'`' -. ;-;;,_ 32;; ___/ / / /___ / / |,4- ) )-,_..;\ ( `'-' 33;; /____/ /_____/ /_/ '---''(_/--' `-'\_) 34;; 35;; 36;; SLY is Sylvester the Cat's Common Lisp IDE. 37;; 38;; SLY is a direct fork of SLIME, and contains the following 39;; improvements over it: 40;; 41;; * A full-featured REPL based on Emacs's `comint.el`; 42;; * Live code annotations via a new `sly-stickers` contrib; 43;; * Consistent button interface. Every Lisp object can be copied to the REPL; 44;; * flex-style completion out-of-the-box, using Emacs's completion API. 45;; Company, Helm, and others supported natively, no plugin required; 46;; * Cleanly ASDF-loaded by default, including contribs, enabled out-of-the-box; 47;; * Multiple inspectors and multiple REPLs; 48;; * An interactive trace dialog with interactive objects. Copies function calls 49;; to the REPL; 50;; * "Presentations" replaced by interactive backreferences which 51;; highlight the object and remain stable throughout the REPL session; 52;; 53;; SLY is a fork of SLIME. We track its bugfixes, particularly to the 54;; implementation backends. All SLIME's familar features (debugger, 55;; inspector, xref, etc...) are still available, with improved overall 56;; UX. 57;; 58;; See the NEWS.md file (should be sitting alongside this file) for 59;; more information 60 61;;; Code: 62 63(require 'cl-lib) 64 65(eval-and-compile 66 (if (version< emacs-version "24.3") 67 (error "Sly requires at least Emacs 24.3"))) 68 69(eval-and-compile 70 (or (require 'hyperspec nil t) 71 (require 'hyperspec "lib/hyperspec"))) 72(require 'thingatpt) 73(require 'comint) 74(require 'pp) 75(require 'easymenu) 76(require 'arc-mode) 77(require 'etags) 78(require 'apropos) 79(require 'bytecomp) ;; for `byte-compile-current-file' and 80;; `sly-byte-compile-hotspots'. 81 82(require 'sly-common "lib/sly-common") 83(require 'sly-messages "lib/sly-messages") 84(require 'sly-buttons "lib/sly-buttons") 85(require 'sly-completion "lib/sly-completion") 86 87(require 'gv) ; for gv--defsetter 88 89(eval-when-compile 90 (require 'compile) 91 (require 'gud)) 92 93(defvar sly-path nil 94 "Directory containing the SLY package. 95This is used to load the supporting Common Lisp library, Slynk. 96The default value is automatically computed from the location of the 97Emacs Lisp package.") 98 99;; Determine `sly-path' at load time, regardless of filename (.el or 100;; .elc) being loaded. 101;; 102(setq sly-path 103 (if load-file-name 104 (file-name-directory load-file-name) 105 (error "[sly] fatal: impossible to determine sly-path"))) 106 107(defun sly-slynk-path () 108 "Path where the bundled Slynk server is located." 109 (expand-file-name "slynk/" sly-path)) 110 111;;;###autoload 112(define-obsolete-variable-alias 'sly-setup-contribs 113 'sly-contribs "2.3.2") 114;;;###autoload 115(defvar sly-contribs '(sly-fancy) 116 "A list of contrib packages to load with SLY.") 117 118;;;###autoload 119(defun sly-setup (&optional contribs) 120 "Have SLY load and use extension modules CONTRIBS. 121CONTRIBS defaults to `sly-contribs' and is a list (LIB1 LIB2...) 122symbols of `provide'd and `require'd Elisp libraries. 123 124If CONTRIBS is nil, `sly-contribs' is *not* affected, otherwise 125it is set to CONTRIBS. 126 127However, after `require'ing LIB1, LIB2 ..., this command invokes 128additional initialization steps associated with each element 129LIB1, LIB2, which can theoretically be reverted by 130`sly-disable-contrib.' 131 132Notably, one of the extra initialization steps is affecting the 133value of `sly-required-modules' (which see) thus affecting the 134libraries loaded in the Slynk servers. 135 136If SLY is currently connected to a Slynk and a contrib in 137CONTRIBS has never been loaded, that Slynk is told to load the 138associated Slynk extension module. 139 140To ensure that a particular contrib is loaded, use 141`sly-enable-contrib' instead." 142 ;; FIXME: The contract should be like some hypothetical 143 ;; `sly-refresh-contribs' 144 ;; 145 (interactive) 146 (when contribs 147 (setq sly-contribs contribs)) 148 (sly--setup-contribs)) 149 150(defvaralias 'sly-required-modules 'sly-contrib--required-slynk-modules) 151 152(defvar sly-contrib--required-slynk-modules '() 153 "Alist of (MODULE . (WHERE CONTRIB)) for slynk-provided features. 154 155MODULE is a symbol naming a specific Slynk feature, WHERE is 156the full pathname to the directory where the file(s) 157providing the feature are found and CONTRIB is a symbol as found 158in `sly-contribs.'") 159 160(cl-defmacro sly--contrib-safe (contrib &body body) 161 "Run BODY catching and resignalling any errors for CONTRIB" 162 (declare (indent 1)) 163 `(condition-case-unless-debug e 164 (progn 165 ,@body) 166 (error (sly-error "There's an error in %s: %s" 167 ,contrib 168 e)))) 169 170(defun sly--setup-contribs () 171 "Load and initialize contribs." 172 ;; active != enabled 173 ;; ^ ^ 174 ;; | | 175 ;; v v 176 ;; forgotten != disabled 177 (add-to-list 'load-path (expand-file-name "contrib" sly-path)) 178 (mapc (lambda (c) 179 (sly--contrib-safe c (require c))) 180 sly-contribs) 181 (let* ((all-active-contribs 182 ;; these are the contribs the user chose to activate 183 ;; 184 (mapcar #'sly-contrib--find-contrib 185 (cl-reduce #'append (mapcar #'sly-contrib--all-dependencies 186 sly-contribs)))) 187 (defined-but-forgotten-contribs 188 ;; "forgotten contribs" are the ones the chose not to 189 ;; activate but whose definitions we have seen 190 ;; 191 (cl-remove-if #'(lambda (contrib) 192 (memq contrib all-active-contribs)) 193 (sly-contrib--all-contribs)))) 194 ;; Disable any forgotten contribs that are enabled right now. 195 ;; 196 (cl-loop for to-disable in defined-but-forgotten-contribs 197 when (sly--contrib-safe to-disable 198 (sly-contrib--enabled-p to-disable)) 199 do (funcall (sly-contrib--disable to-disable))) 200 ;; Enable any active contrib that is *not* enabled right now. 201 ;; 202 (cl-loop for to-enable in all-active-contribs 203 unless (sly--contrib-safe to-enable 204 (sly-contrib--enabled-p to-enable)) 205 do (funcall (sly-contrib--enable to-enable))) 206 ;; Some contribs add stuff to `sly-mode-hook' or 207 ;; `sly-editing-hook', so make sure we re-run those hooks now. 208 (when all-active-contribs 209 (defvar sly-editing-mode) ;FIXME: Forward reference! 210 (cl-loop for buffer in (buffer-list) 211 do (with-current-buffer buffer 212 (when sly-editing-mode (sly-editing-mode 1))))))) 213 214(eval-and-compile 215 (defun sly-version (&optional interactive file) 216 "Read SLY's version of its own sly.el file. 217If FILE is passed use that instead to discover the version." 218 (interactive "p") 219 (let ((version 220 (with-temp-buffer 221 (insert-file-contents 222 (or file 223 (expand-file-name "sly.el" sly-path)) 224 nil 0 200) 225 (and (search-forward-regexp 226 ";;[[:space:]]*Version:[[:space:]]*\\(.*\\)$" nil t) 227 (match-string 1))))) 228 (if interactive 229 (sly-message "SLY %s" version) 230 version)))) 231 232(defvar sly-protocol-version nil) 233 234(setq sly-protocol-version 235 ;; Compile the version string into the generated .elc file, but 236 ;; don't actualy affect `sly-protocol-version' until load-time. 237 ;; 238 (eval-when-compile (sly-version nil (or load-file-name 239 byte-compile-current-file)))) 240 241 242;;;; Customize groups 243;; 244;;;;; sly 245 246(defgroup sly nil 247 "Interaction with the Superior Lisp Environment." 248 :prefix "sly-" 249 :group 'applications) 250 251;;;;; sly-ui 252 253(defgroup sly-ui nil 254 "Interaction with the Superior Lisp Environment." 255 :prefix "sly-" 256 :group 'sly) 257 258(defcustom sly-truncate-lines t 259 "Set `truncate-lines' in popup buffers. 260This applies to buffers that present lines as rows of data, such as 261debugger backtraces and apropos listings." 262 :type 'boolean 263 :group 'sly-ui) 264 265(defcustom sly-kill-without-query-p nil 266 "If non-nil, kill SLY processes without query when quitting Emacs. 267This applies to the *inferior-lisp* buffer and the network connections." 268 :type 'boolean 269 :group 'sly-ui) 270 271;;;;; sly-lisp 272 273(defgroup sly-lisp nil 274 "Lisp server configuration." 275 :prefix "sly-" 276 :group 'sly) 277 278(defcustom sly-ignore-protocol-mismatches nil 279 "If non-nil, ignore protocol mismatches between SLY and Slynk. 280Programatically, this variable can be let-bound around calls to 281`sly' or `sly-connect'." 282 :type 'boolean 283 :group 'sly) 284 285(defcustom sly-init-function 'sly-init-using-asdf 286 "Function bootstrapping slynk on the remote. 287 288Value is a function of two arguments: SLYNK-PORTFILE and an 289ingored argument for backward compatibility. Function should 290return a string issuing very first commands issued by Sly to 291the remote-connection process. Some time after this there should 292be a port number ready in SLYNK-PORTFILE." 293 :type '(choice (const :tag "Use ASDF" 294 sly-init-using-asdf) 295 (const :tag "Use legacy slynk-loader.lisp" 296 sly-init-using-slynk-loader)) 297 :group 'sly-lisp) 298 299(define-obsolete-variable-alias 'sly-backend 300 'sly-slynk-loader-backend "3.0") 301 302(defcustom sly-slynk-loader-backend "slynk-loader.lisp" 303 "The name of the slynk-loader that loads the Slynk server. 304Only applicable if `sly-init-function' is set to 305`sly-init-using-slynk-loader'. This name is interpreted 306relative to the directory containing sly.el, but could also be 307set to an absolute filename." 308 :type 'string 309 :group 'sly-lisp) 310 311(defcustom sly-connected-hook nil 312 "List of functions to call when SLY connects to Lisp." 313 :type 'hook 314 :group 'sly-lisp) 315 316(defcustom sly-enable-evaluate-in-emacs nil 317 "*If non-nil, the inferior Lisp can evaluate arbitrary forms in Emacs. 318The default is nil, as this feature can be a security risk." 319 :type '(boolean) 320 :group 'sly-lisp) 321 322(defcustom sly-lisp-host "localhost" 323 "The default hostname (or IP address) to connect to." 324 :type 'string 325 :group 'sly-lisp) 326 327(defcustom sly-port 4005 328 "Port to use as the default for `sly-connect'." 329 :type 'integer 330 :group 'sly-lisp) 331 332(defvar sly-connect-host-history (list sly-lisp-host)) 333(defvar sly-connect-port-history (list (prin1-to-string sly-port))) 334 335(defvar sly-net-valid-coding-systems 336 '((iso-latin-1-unix nil "iso-latin-1-unix") 337 (iso-8859-1-unix nil "iso-latin-1-unix") 338 (binary nil "iso-latin-1-unix") 339 (utf-8-unix t "utf-8-unix") 340 (emacs-mule-unix t "emacs-mule-unix") 341 (euc-jp-unix t "euc-jp-unix")) 342 "A list of valid coding systems. 343Each element is of the form: (NAME MULTIBYTEP CL-NAME)") 344 345(defun sly-find-coding-system (name) 346 "Return the coding system for the symbol NAME. 347The result is either an element in `sly-net-valid-coding-systems' 348of nil." 349 (let ((probe (assq name sly-net-valid-coding-systems))) 350 (when (and probe (if (fboundp 'check-coding-system) 351 (ignore-errors (check-coding-system (car probe))) 352 (eq (car probe) 'binary))) 353 probe))) 354 355(defcustom sly-net-coding-system 356 (car (cl-find-if 'sly-find-coding-system 357 sly-net-valid-coding-systems :key 'car)) 358 "Coding system used for network connections. 359See also `sly-net-valid-coding-systems'." 360 :type (cons 'choice 361 (mapcar (lambda (x) 362 (list 'const (car x))) 363 sly-net-valid-coding-systems)) 364 :group 'sly-lisp) 365 366;;;;; sly-mode 367 368(defgroup sly-mode nil 369 "Settings for sly-mode Lisp source buffers." 370 :prefix "sly-" 371 :group 'sly) 372 373;;;;; sly-mode-faces 374 375(defgroup sly-mode-faces nil 376 "Faces in sly-mode source code buffers." 377 :prefix "sly-" 378 :group 'sly-mode) 379 380(defface sly-error-face 381 `((((class color) (background light)) 382 (:underline "tomato")) 383 (((class color) (background dark)) 384 (:underline "tomato")) 385 (t (:underline t))) 386 "Face for errors from the compiler." 387 :group 'sly-mode-faces) 388 389(defface sly-warning-face 390 `((((class color) (background light)) 391 (:underline "orange")) 392 (((class color) (background dark)) 393 (:underline "coral")) 394 (t (:underline t))) 395 "Face for warnings from the compiler." 396 :group 'sly-mode-faces) 397 398(defface sly-style-warning-face 399 `((((class color) (background light)) 400 (:underline "olive drab")) 401 (((class color) (background dark)) 402 (:underline "khaki")) 403 (t (:underline t))) 404 "Face for style-warnings from the compiler." 405 :group 'sly-mode-faces) 406 407(defface sly-note-face 408 `((((class color) (background light)) 409 (:underline "brown3")) 410 (((class color) (background dark)) 411 (:underline "light goldenrod")) 412 (t (:underline t))) 413 "Face for notes from the compiler." 414 :group 'sly-mode-faces) 415 416;;;;; sly-db 417 418(defgroup sly-debugger nil 419 "Backtrace options and fontification." 420 :prefix "sly-db-" 421 :group 'sly) 422 423(defmacro define-sly-db-faces (&rest faces) 424 "Define the set of SLY-DB faces. 425Each face specifiation is (NAME DESCRIPTION &optional PROPERTIES). 426NAME is a symbol; the face will be called sly-db-NAME-face. 427DESCRIPTION is a one-liner for the customization buffer. 428PROPERTIES specifies any default face properties." 429 `(progn ,@(cl-loop for face in faces 430 collect `(define-sly-db-face ,@face)))) 431 432(defmacro define-sly-db-face (name description &optional default) 433 (let ((facename (intern (format "sly-db-%s-face" (symbol-name name))))) 434 `(defface ,facename 435 (list (list t ,default)) 436 ,(format "Face for %s." description) 437 :group 'sly-debugger))) 438 439(define-sly-db-faces 440 (topline "the top line describing the error") 441 (condition "the condition class" '(:inherit error)) 442 (section "the labels of major sections in the debugger buffer" 443 '(:inherit header-line)) 444 (frame-label "backtrace frame numbers" 445 '(:inherit shadow)) 446 (restart "restart descriptions") 447 (restart-number "restart numbers (correspond to keystrokes to invoke)" 448 '(:inherit shadow)) 449 (frame-line "function names and arguments in the backtrace") 450 (restartable-frame-line 451 "frames which are surely restartable" 452 '(:inherit font-lock-constant-face)) 453 (non-restartable-frame-line 454 "frames which are surely not restartable") 455 (local-name "local variable names") 456 (catch-tag "catch tags")) 457 458 459;;;;; Key bindings 460(defvar sly-doc-map 461 (let ((map (make-sparse-keymap))) 462 (define-key map (kbd "C-a") 'sly-apropos) 463 (define-key map (kbd "C-z") 'sly-apropos-all) 464 (define-key map (kbd "C-p") 'sly-apropos-package) 465 (define-key map (kbd "C-d") 'sly-describe-symbol) 466 (define-key map (kbd "C-f") 'sly-describe-function) 467 (define-key map (kbd "C-h") 'sly-documentation-lookup) 468 (define-key map (kbd "~") 'common-lisp-hyperspec-format) 469 (define-key map (kbd "C-g") 'common-lisp-hyperspec-glossary-term) 470 (define-key map (kbd "#") 'common-lisp-hyperspec-lookup-reader-macro) 471 map)) 472 473(defvar sly-who-map 474 (let ((map (make-sparse-keymap))) 475 (define-key map (kbd "C-c") 'sly-who-calls) 476 (define-key map (kbd "C-w") 'sly-calls-who) 477 (define-key map (kbd "C-r") 'sly-who-references) 478 (define-key map (kbd "C-b") 'sly-who-binds) 479 (define-key map (kbd "C-s") 'sly-who-sets) 480 (define-key map (kbd "C-m") 'sly-who-macroexpands) 481 (define-key map (kbd "C-a") 'sly-who-specializes) 482 map)) 483 484(defvar sly-selector-map (let ((map (make-sparse-keymap))) 485 (define-key map "c" 'sly-list-connections) 486 (define-key map "t" 'sly-list-threads) 487 (define-key map "d" 'sly-db-pop-to-debugger-maybe) 488 (define-key map "e" 'sly-pop-to-events-buffer) 489 (define-key map "i" 'sly-inferior-lisp-buffer) 490 (define-key map "l" 'sly-switch-to-most-recent) 491 map) 492 "A keymap for frequently used SLY shortcuts. 493Access to this keymap can be installed in in 494`sly-mode-map', using something like 495 496 (global-set-key (kbd \"C-z\") sly-selector-map) 497 498This will bind C-z to this prefix map, one keystroke away from 499the available shortcuts: 500 501\\{sly-selector-map} 502As usual, users or extensions can plug in 503any command into it using 504 505 (define-key sly-selector-map (kbd \"k\") 'sly-command) 506 507Where \"k\" is the key to bind and \"sly-command\" is any 508interactive command.\".") 509 510(defvar sly-prefix-map 511 (let ((map (make-sparse-keymap))) 512 (define-key map (kbd "C-r") 'sly-eval-region) 513 (define-key map (kbd ":") 'sly-interactive-eval) 514 (define-key map (kbd "C-e") 'sly-interactive-eval) 515 (define-key map (kbd "E") 'sly-edit-value) 516 (define-key map (kbd "C-l") 'sly-load-file) 517 (define-key map (kbd "C-b") 'sly-interrupt) 518 (define-key map (kbd "M-d") 'sly-disassemble-symbol) 519 (define-key map (kbd "C-t") 'sly-toggle-trace-fdefinition) 520 (define-key map (kbd "I") 'sly-inspect) 521 (define-key map (kbd "C-x t") 'sly-list-threads) 522 (define-key map (kbd "C-x n") 'sly-next-connection) 523 (define-key map (kbd "C-x c") 'sly-list-connections) 524 (define-key map (kbd "C-x p") 'sly-prev-connection) 525 (define-key map (kbd "<") 'sly-list-callers) 526 (define-key map (kbd ">") 'sly-list-callees) 527 ;; Include DOC keys... 528 (define-key map (kbd "C-d") sly-doc-map) 529 ;; Include XREF WHO-FOO keys... 530 (define-key map (kbd "C-w") sly-who-map) 531 ;; `sly-selector-map' used to be bound to "C-c C-s" by default, 532 ;; but sly-stickers has a better binding for that. 533 ;; 534 ;; (define-key map (kbd "C-s") sly-selector-map) 535 map)) 536 537(defvar sly-mode-map 538 (let ((map (make-sparse-keymap))) 539 ;; These used to be a `sly-parent-map' 540 (define-key map (kbd "M-.") 'sly-edit-definition) 541 (define-key map (kbd "M-,") 'sly-pop-find-definition-stack) 542 (define-key map (kbd "M-_") 'sly-edit-uses) ; for German layout 543 (define-key map (kbd "M-?") 'sly-edit-uses) ; for USian layout 544 (define-key map (kbd "C-x 4 .") 'sly-edit-definition-other-window) 545 (define-key map (kbd "C-x 5 .") 'sly-edit-definition-other-frame) 546 (define-key map (kbd "C-x C-e") 'sly-eval-last-expression) 547 (define-key map (kbd "C-M-x") 'sly-eval-defun) 548 ;; Include PREFIX keys... 549 (define-key map (kbd "C-c") sly-prefix-map) 550 ;; Completion 551 (define-key map (kbd "C-c TAB") 'completion-at-point) 552 ;; Evaluating 553 (define-key map (kbd "C-c C-p") 'sly-pprint-eval-last-expression) 554 ;; Macroexpand 555 (define-key map (kbd "C-c C-m") 'sly-expand-1) 556 (define-key map (kbd "C-c M-m") 'sly-macroexpand-all) 557 ;; Misc 558 (define-key map (kbd "C-c C-u") 'sly-undefine-function) 559 map)) 560 561(defvar sly-editing-mode-map 562 (let ((map (make-sparse-keymap))) 563 (define-key map (kbd "M-p") 'sly-previous-note) 564 (define-key map (kbd "M-n") 'sly-next-note) 565 (define-key map (kbd "C-c M-c") 'sly-remove-notes) 566 (define-key map (kbd "C-c C-k") 'sly-compile-and-load-file) 567 (define-key map (kbd "C-c M-k") 'sly-compile-file) 568 (define-key map (kbd "C-c C-c") 'sly-compile-defun) 569 map)) 570 571(defvar sly-popup-buffer-mode-map 572 (let ((map (make-sparse-keymap))) 573 (define-key map (kbd "q") 'quit-window) 574 map)) 575 576 577;;;; Minor modes 578 579;;;;; sly-mode 580(defvar sly-buffer-connection) 581(defvar sly-dispatching-connection) 582(defvar sly-current-thread) 583 584;; exceptional forward decl 585(defvar company-tooltip-align-annotations) 586 587;;;###autoload 588(define-minor-mode sly-mode 589 "Minor mode for horizontal SLY functionality." 590 nil nil nil 591 ;; Company-mode should have this by default 592 ;; See gh#166 593 (set (make-local-variable 'company-tooltip-align-annotations) t)) 594 595;;;###autoload 596(define-minor-mode sly-editing-mode 597 "Minor mode for editing `lisp-mode' buffers." 598 nil nil nil 599 (sly-mode 1) 600 (setq-local lisp-indent-function 'sly-common-lisp-indent-function)) 601 602(define-minor-mode sly-popup-buffer-mode 603 "Minor mode for all read-only SLY buffers" 604 nil nil nil 605 (sly-mode 1) 606 (sly-interactive-buttons-mode 1) 607 (setq buffer-read-only t)) 608 609 610;;;;;; Mode-Line 611(defface sly-mode-line 612 '((t (:inherit font-lock-constant-face 613 :weight bold))) 614 "Face for package-name in SLY's mode line." 615 :group 'sly) 616 617(defvar sly--mode-line-format `(:eval (sly--mode-line-format))) 618 619(put 'sly--mode-line-format 'risky-local-variable t) 620 621(defvar sly-menu) ;; forward referenced 622 623(defvar sly-extra-mode-line-constructs nil 624 "A list of mode-line constructs to add to SLY's mode-line. 625Each construct is separated by a \"/\" and may be a regular 626mode-line construct or a symbol naming a function of no arguments 627that returns one such construct.") 628 629(defun sly--mode-line-format () 630 (let* ((conn (sly-current-connection)) 631 (conn (and (process-live-p conn) conn)) 632 (name (or (and conn 633 (sly-connection-name conn)) 634 "*")) 635 (pkg (sly-current-package)) 636 (format-number (lambda (n) (cond ((and n (not (zerop n))) 637 (format "%d" n)) 638 (n "-") 639 (t "*")))) 640 (package-name (and pkg 641 (sly--pretty-package-name pkg))) 642 (pending (and conn 643 (length (sly-rex-continuations conn)))) 644 (sly-dbs (and conn (length (sly-db-buffers conn))))) 645 `((:propertize "sly" 646 face sly-mode-line 647 keymap ,(let ((map (make-sparse-keymap))) 648 (define-key map [mode-line down-mouse-1] 649 sly-menu) 650 map) 651 mouse-face mode-line-highlight 652 help-echo "mouse-1: pop-up SLY menu" 653 ) 654 " " 655 (:propertize ,name 656 face sly-mode-line 657 keymap ,(let ((map (make-sparse-keymap))) 658 (define-key map [mode-line mouse-1] 'sly-prev-connection) 659 (define-key map [mode-line mouse-2] 'sly-list-connections) 660 (define-key map [mode-line mouse-3] 'sly-next-connection) 661 map) 662 mouse-face mode-line-highlight 663 help-echo ,(concat "mouse-1: previous connection\n" 664 "mouse-2: list connections\n" 665 "mouse-3: next connection")) 666 "/" 667 ,(or package-name "*") 668 "/" 669 (:propertize ,(funcall format-number pending) 670 help-echo ,(if conn (format "%s pending events outgoing\n%s" 671 pending 672 (concat "mouse-1: go to *sly-events* buffer" 673 "mouse-3: forget pending continuations")) 674 "No current connection") 675 mouse-face mode-line-highlight 676 face ,(cond ((and pending (cl-plusp pending)) 677 'warning) 678 (t 679 'sly-mode-line)) 680 keymap ,(let ((map (make-sparse-keymap))) 681 (define-key map [mode-line mouse-1] 'sly-pop-to-events-buffer) 682 (define-key map [mode-line mouse-3] 'sly-forget-pending-events) 683 map)) 684 "/" 685 (:propertize ,(funcall format-number sly-dbs) 686 help-echo ,(if conn (format "%s SLY-DB buffers waiting\n%s" 687 pending 688 "mouse-1: go to first one") 689 "No current connection") 690 mouse-face mode-line-highlight 691 face ,(cond ((and sly-dbs (cl-plusp sly-dbs)) 692 'warning) 693 (t 694 'sly-mode-line)) 695 keymap ,(let ((map (make-sparse-keymap))) 696 (define-key map [mode-line mouse-1] 'sly-db-pop-to-debugger) 697 map)) 698 ,@(cl-loop for construct in sly-extra-mode-line-constructs 699 collect "/" 700 collect (if (and (symbolp construct) 701 (fboundp construct)) 702 (condition-case _oops 703 (funcall construct) 704 (error "*sly-invalid*")) 705 construct))))) 706 707(defun sly--refresh-mode-line () 708 (force-mode-line-update t)) 709 710(defun sly--pretty-package-name (name) 711 "Return a pretty version of a package name NAME." 712 (cond ((string-match "^#?:\\(.*\\)$" name) 713 (match-string 1 name)) 714 ((string-match "^\"\\(.*\\)\"$" name) 715 (match-string 1 name)) 716 (t name))) 717 718(add-to-list 'mode-line-misc-info 719 `(sly-mode (" [" sly--mode-line-format "] "))) 720 721 722;;;; Framework'ey bits 723;;; 724;;; This section contains some standard SLY idioms: basic macros, 725;;; ways of showing messages to the user, etc. All the code in this 726;;; file should use these functions when applicable. 727;;; 728;;;;; Syntactic sugar 729 730(cl-defmacro sly--when-let ((var value) &rest body) 731 "Evaluate VALUE, if the result is non-nil bind it to VAR and eval BODY. 732 733\(fn (VAR VALUE) &rest BODY)" 734 (declare (indent 1)) 735 `(let ((,var ,value)) 736 (when ,var ,@body))) 737 738(cl-defmacro sly--when-let* (bindings &rest body) 739 "Same as `sly--when-let', but for multiple BINDINGS" 740 (declare (indent 1)) 741 (if bindings 742 `(sly--when-let ,(car bindings) 743 (sly--when-let* ,(cdr bindings) ,@body)) 744 `(progn ,@body))) 745 746(defmacro sly-dcase (value &rest patterns) 747 (declare (indent 1) 748 (debug (sexp &rest (sexp &rest form)))) 749 "Dispatch VALUE to one of PATTERNS. 750A cross between `case' and `destructuring-bind'. 751The pattern syntax is: 752 ((HEAD . ARGS) . BODY) 753The list of patterns is searched for a HEAD `eq' to the car of 754VALUE. If one is found, the BODY is executed with ARGS bound to the 755corresponding values in the CDR of VALUE." 756 (let ((operator (cl-gensym "op-")) 757 (operands (cl-gensym "rand-")) 758 (tmp (cl-gensym "tmp-"))) 759 `(let* ((,tmp ,value) 760 (,operator (car ,tmp)) 761 (,operands (cdr ,tmp))) 762 (cl-case ,operator 763 ,@(mapcar (lambda (clause) 764 (if (eq (car clause) t) 765 `(t ,@(cdr clause)) 766 (cl-destructuring-bind ((op &rest rands) &rest body) 767 clause 768 `(,op (cl-destructuring-bind ,rands ,operands 769 . ,(or body 770 '((ignore)) ; suppress some warnings 771 )))))) 772 patterns) 773 ,@(if (eq (caar (last patterns)) t) 774 '() 775 `((t (sly-error "Elisp sly-dcase failed: %S" ,tmp)))))))) 776 777;;;;; Very-commonly-used functions 778 779;; Interface 780(cl-defun sly-buffer-name (type &key connection hidden suffix) 781 (cl-assert (keywordp type)) 782 (mapconcat #'identity 783 `(,@(if hidden `(" ")) 784 "*sly-" 785 ,(downcase (substring (symbol-name type) 1)) 786 ,@(if connection 787 `(" for " 788 ,(sly-connection-name 789 (if (eq connection t) 790 (sly-current-connection) 791 connection)))) 792 ,@(if suffix 793 `(" (" 794 ,suffix 795 ")")) 796 "*") 797 "")) 798 799(defun sly-recenter (target &optional move-point) 800 "Make the region between point and TARGET visible. 801Minimize window motion if possible. If MOVE-POINT allow point to 802move to make TARGET visible." 803 (unless (pos-visible-in-window-p target) 804 (redisplay) 805 (let ((screen-line (- (line-number-at-pos) 806 (line-number-at-pos (window-start)))) 807 (window-end (line-number-at-pos (window-end))) 808 (window-start (line-number-at-pos (window-start))) 809 (target-line (line-number-at-pos target)) 810 recenter-arg) 811 (cond ((> (point) target) 812 (setq recenter-arg (+ screen-line (- window-start target-line))) 813 (if (or (not move-point) 814 (<= recenter-arg (window-height))) 815 (recenter recenter-arg) 816 (goto-char target) 817 (recenter -1) 818 (move-to-window-line -1))) 819 ((<= (point) target) 820 (setq recenter-arg (- screen-line (- target-line window-end))) 821 (if (or (not move-point) 822 (> recenter-arg 0)) 823 (recenter (max recenter-arg 0)) 824 (goto-char target) 825 (recenter 0) 826 (move-to-window-line 0))))))) 827 828;; Interface 829(defun sly-set-truncate-lines () 830 "Apply `sly-truncate-lines' to the current buffer." 831 (when sly-truncate-lines 832 (set (make-local-variable 'truncate-lines) t))) 833 834;; Interface 835(defun sly-read-package-name (prompt &optional initial-value allow-blank) 836 "Read a package name from the minibuffer, prompting with PROMPT. 837If ALLOW-BLANK may return nil to signal no particular package 838selected." 839 (let* ((completion-ignore-case t) 840 (res (sly-completing-read 841 (concat "[sly] " prompt) 842 (sly-eval 843 `(slynk:list-all-package-names t)) 844 nil (not allow-blank) initial-value))) 845 (unless (zerop (length res)) 846 res))) 847 848;; Interface 849(defmacro sly-propertize-region (props &rest body) 850 "Execute BODY and add PROPS to all the text it inserts. 851More precisely, PROPS are added to the region between the point's 852positions before and after executing BODY." 853 (declare (indent 1) (debug (sexp &rest form))) 854 (let ((start (cl-gensym))) 855 `(let ((,start (point))) 856 (prog1 (progn ,@body) 857 (add-text-properties ,start (point) ,props))))) 858 859(defun sly-add-face (face string) 860 (declare (indent 1)) 861 (add-text-properties 0 (length string) (list 'face face) string) 862 string) 863 864;; Interface 865(defsubst sly-insert-propertized (props &rest args) 866 "Insert all ARGS and then add text-PROPS to the inserted text." 867 (sly-propertize-region props (apply #'insert args))) 868 869(defmacro sly-with-rigid-indentation (level &rest body) 870 "Execute BODY and then rigidly indent its text insertions. 871Assumes all insertions are made at point." 872 (declare (indent 1)) 873 (let ((start (cl-gensym)) (l (cl-gensym))) 874 `(let ((,start (point)) (,l ,(or level '(current-column)))) 875 (prog1 (progn ,@body) 876 (sly-indent-rigidly ,start (point) ,l))))) 877 878(defun sly-indent-rigidly (start end column) 879 ;; Similar to `indent-rigidly' but doesn't inherit text props. 880 (let ((indent (make-string column ?\ ))) 881 (save-excursion 882 (goto-char end) 883 (beginning-of-line) 884 (while (and (<= start (point)) 885 (progn 886 (insert-before-markers indent) 887 (zerop (forward-line -1)))))))) 888 889(defun sly-insert-indented (&rest strings) 890 "Insert all arguments rigidly indented." 891 (sly-with-rigid-indentation nil 892 (apply #'insert strings))) 893 894(defun sly-compose (&rest functions) 895 "Compose unary FUNCTIONS right-associatively, returning a function" 896 #'(lambda (x) 897 (cl-reduce #'funcall functions :initial-value x :from-end t))) 898 899(defun sly-curry (fun &rest args) 900 "Partially apply FUN to ARGS. The result is a new function." 901 (lambda (&rest more) (apply fun (append args more)))) 902 903(defun sly-rcurry (fun &rest args) 904 "Like `sly-curry' but ARGS on the right are applied." 905 (lambda (&rest more) (apply fun (append more args)))) 906 907 908;;;;; Temporary popup buffers 909 910;; keep compiler quiet 911(defvar sly-buffer-package) 912(defvar sly-buffer-connection) 913 914 915;; Interface 916(cl-defmacro sly-with-popup-buffer ((name &key package connection select 917 same-window-p 918 mode) 919 &body body) 920 "Similar to `with-output-to-temp-buffer'. 921Bind standard-output and initialize some buffer-local variables. 922Restore window configuration when closed. NAME is the name of 923the buffer to be created. PACKAGE is the value 924`sly-buffer-package'. CONNECTION is the value for 925`sly-buffer-connection', if nil, no explicit connection is 926associated with the buffer. If t, the current connection is 927taken. MODE is the name of a major mode which will be enabled. 928Non-nil SELECT indicates the buffer should be switched to, unless 929it is `:hidden' meaning the buffer should not even be 930displayed. SELECT can also be `:raise' meaning the buffer should 931be switched to and the frame raised. SAME-WINDOW-P is a form 932indicating if the popup *can* happen in the same window. The 933forms SELECT and SAME-WINDOW-P are evaluated at runtime, not 934macroexpansion time. 935" 936 (declare (indent 1) 937 (debug (sexp &rest form))) 938 (let* ((package-sym (cl-gensym "package-")) 939 (connection-sym (cl-gensym "connection-")) 940 (select-sym (cl-gensym "select")) 941 (major-mode-sym (cl-gensym "select"))) 942 `(let ((,package-sym ,(if (eq package t) 943 `(sly-current-package) 944 package)) 945 (,connection-sym ,(if (eq connection t) 946 `(sly-current-connection) 947 connection)) 948 (,major-mode-sym major-mode) 949 (,select-sym ,select) 950 (view-read-only nil)) 951 (with-current-buffer (get-buffer-create ,name) 952 (let ((inhibit-read-only t) 953 (standard-output (current-buffer))) 954 (erase-buffer) 955 ,@(cond (mode 956 `((funcall ,mode))) 957 (t 958 `((sly-popup-buffer-mode 1)))) 959 (setq sly-buffer-package ,package-sym 960 sly-buffer-connection ,connection-sym) 961 (set-syntax-table lisp-mode-syntax-table) 962 ,@body 963 (unless (eq ,select-sym :hidden) 964 (let ((window (display-buffer 965 (current-buffer) 966 (if ,(cond (same-window-p same-window-p) 967 (mode `(eq ,major-mode-sym ,mode))) 968 nil 969 t)))) 970 (when ,select-sym 971 (if window 972 (select-window window t)))) 973 (if (eq ,select-sym :raise) (raise-frame))) 974 (current-buffer)))))) 975 976;;;;; Filename translation 977;;; 978;;; Filenames passed between Emacs and Lisp should be translated using 979;;; these functions. This way users who run Emacs and Lisp on separate 980;;; machines have a chance to integrate file operations somehow. 981 982(defvar sly-to-lisp-filename-function #'convert-standard-filename 983 "Function to translate Emacs filenames to CL namestrings.") 984(defvar sly-from-lisp-filename-function #'identity 985 "Function to translate CL namestrings to Emacs filenames.") 986 987(defun sly-to-lisp-filename (filename) 988 "Translate the string FILENAME to a Lisp filename." 989 (funcall sly-to-lisp-filename-function (substring-no-properties filename))) 990 991(defun sly-from-lisp-filename (filename) 992 "Translate the Lisp filename FILENAME to an Emacs filename." 993 (funcall sly-from-lisp-filename-function filename)) 994 995 996;;;; Starting SLY 997;;; 998;;; This section covers starting an inferior-lisp, compiling and 999;;; starting the server, initiating a network connection. 1000 1001;;;;; Entry points 1002 1003;; We no longer load inf-lisp, but we use this variable for backward 1004;; compatibility. 1005(defcustom inferior-lisp-program "lisp" 1006 "Program name for starting a Lisp subprocess to Emacs. 1007Can be a string naming a program, a whitespace-separated string 1008of \"EXECUTABLE ARG1 ARG2\" or a list (EXECUTABLE ARGS...) where 1009EXECUTABLE and ARGS are strings." 1010 :type 'string 1011 :group 'sly-lisp) 1012 1013(defvar sly-lisp-implementations nil 1014 "*A list of known Lisp implementations. 1015The list should have the form: 1016 ((NAME (PROGRAM PROGRAM-ARGS...) &key KEYWORD-ARGS) ...) 1017 1018NAME is a symbol for the implementation. 1019PROGRAM and PROGRAM-ARGS are strings used to start the Lisp process. 1020For KEYWORD-ARGS see `sly-start'. 1021 1022Here's an example: 1023 ((cmucl (\"/opt/cmucl/bin/lisp\" \"-quiet\") :init sly-init-command) 1024 (acl (\"acl7\") :coding-system emacs-mule))") 1025 1026(defcustom sly-command-switch-to-existing-lisp 'ask 1027 "Should the `sly' command start new lisp if one is available?" 1028 :type '(choice (const :tag "Ask the user" ask) 1029 (const :tag "Always" 'always) 1030 (const :tag "Never" 'never))) 1031 1032(defcustom sly-auto-select-connection 'ask 1033 "Controls auto selection after the default connection was closed." 1034 :group 'sly-mode 1035 :type '(choice (const never) 1036 (const always) 1037 (const ask))) 1038 1039(defcustom sly-default-lisp nil 1040 "A symbol naming the preferred Lisp implementation. 1041See `sly-lisp-implementations'" 1042 :type 'function 1043 :group 'sly-mode) 1044 1045;; dummy definitions for the compiler 1046(defvar sly-net-processes) 1047(defvar sly-default-connection) 1048 1049;;;###autoload 1050(cl-defun sly (&optional command coding-system interactive) 1051 "Start a Lisp implementation and connect to it. 1052 1053 COMMAND designates a the Lisp implementation to start as an 1054\"inferior\" process to the Emacs process. It is either a 1055pathname string pathname to a lisp executable, a list (EXECUTABLE 1056ARGS...), or a symbol indexing 1057`sly-lisp-implementations'. CODING-SYSTEM is a symbol overriding 1058`sly-net-coding-system'. 1059 1060Interactively, both COMMAND and CODING-SYSTEM are nil and the 1061prefix argument controls the precise behaviour: 1062 1063- With no prefix arg, try to automatically find a Lisp. First 1064 consult `sly-command-switch-to-existing-lisp' and analyse open 1065 connections to maybe switch to one of those. If a new lisp is 1066 to be created, first lookup `sly-lisp-implementations', using 1067 `sly-default-lisp' as a default strategy. Then try 1068 `inferior-lisp-program' if it looks like it points to a valid 1069 lisp. Failing that, guess the location of a lisp 1070 implementation. 1071 1072- With a positive prefix arg (one C-u), prompt for a command 1073 string that starts a Lisp implementation. 1074 1075- With a negative prefix arg (M-- M-x sly, for example) prompt 1076 for a symbol indexing one of the entries in 1077 `sly-lisp-implementations'" 1078 (interactive (list nil nil t)) 1079 (sly--when-let* 1080 ((active (and interactive 1081 (not current-prefix-arg) 1082 (sly--purge-connections))) 1083 (target (or (and (eq sly-command-switch-to-existing-lisp 'ask) 1084 (sly-prompt-for-connection 1085 "[sly] Switch to open connection?\n\ 1086 (Customize `sly-command-switch-to-existing-lisp' to avoid this prompt.)\n\ 1087 Connections: " nil "(start a new one)")) 1088 (and (eq sly-command-switch-to-existing-lisp 'always) 1089 (car active))))) 1090 (sly-message "Switching to `%s'" (sly-connection-name target)) 1091 (sly-connection-list-default-action target) 1092 (cl-return-from sly nil)) 1093 (let ((command (or command inferior-lisp-program)) 1094 (sly-net-coding-system (or coding-system sly-net-coding-system))) 1095 (apply #'sly-start 1096 (cond (interactive 1097 (sly--read-interactive-args)) 1098 (t 1099 (if sly-lisp-implementations 1100 (sly--lookup-lisp-implementation 1101 sly-lisp-implementations 1102 (or (and (symbolp command) command) 1103 sly-default-lisp 1104 (car (car sly-lisp-implementations)))) 1105 (let ((command-and-args (if (listp command) 1106 command 1107 (split-string command)))) 1108 `(:program ,(car command-and-args) 1109 :program-args ,(cdr command-and-args))))))))) 1110 1111(defvar sly-inferior-lisp-program-history '() 1112 "History list of command strings. Used by M-x sly.") 1113 1114(defun sly--read-interactive-args () 1115 "Return the list of args which should be passed to `sly-start'. 1116Helper for M-x sly" 1117 (cond ((not current-prefix-arg) 1118 (cond (sly-lisp-implementations 1119 (sly--lookup-lisp-implementation sly-lisp-implementations 1120 (or sly-default-lisp 1121 (car (car sly-lisp-implementations))))) 1122 (t (cl-destructuring-bind (program &rest args) 1123 (split-string-and-unquote 1124 (sly--guess-inferior-lisp-program t)) 1125 (list :program program :program-args args))))) 1126 ((eq current-prefix-arg '-) 1127 (let ((key (sly-completing-read 1128 "Lisp name: " (mapcar (lambda (x) 1129 (list (symbol-name (car x)))) 1130 sly-lisp-implementations) 1131 nil t))) 1132 (sly--lookup-lisp-implementation sly-lisp-implementations (intern key)))) 1133 (t 1134 (cl-destructuring-bind (program &rest program-args) 1135 (split-string-and-unquote 1136 (read-shell-command "[sly] Run lisp: " 1137 (sly--guess-inferior-lisp-program nil) 1138 'sly-inferior-lisp-program-history)) 1139 (let ((coding-system 1140 (if (eq 16 (prefix-numeric-value current-prefix-arg)) 1141 (read-coding-system "[sly] Set sly-coding-system: " 1142 sly-net-coding-system) 1143 sly-net-coding-system))) 1144 (list :program program :program-args program-args 1145 :coding-system coding-system)))))) 1146 1147 1148(defun sly--lookup-lisp-implementation (table name) 1149 (let ((arguments (cl-rest (assoc name table)))) 1150 (unless arguments 1151 (error "Could not find lisp implementation with the name '%S'" name)) 1152 (when (and (= (length arguments) 1) 1153 (functionp (cl-first arguments))) 1154 (setf arguments (funcall (cl-first arguments)))) 1155 (cl-destructuring-bind ((prog &rest args) &rest keys) arguments 1156 (cl-list* :name name :program prog :program-args args keys)))) 1157 1158(defun sly-inferior-lisp-buffer (sly-process-or-connection &optional pop-to-buffer) 1159 "Return PROCESS's buffer. With POP-TO-BUFFER, pop to it." 1160 (interactive (list (sly-process) t)) 1161 (let ((buffer (cond ((and sly-process-or-connection 1162 (process-get sly-process-or-connection 1163 'sly-inferior-lisp-process)) 1164 (process-buffer sly-process-or-connection)) 1165 (sly-process-or-connection 1166 ;; call ourselves recursively with a 1167 ;; sly-started process 1168 ;; 1169 (sly-inferior-lisp-buffer (sly-process sly-process-or-connection) 1170 pop-to-buffer ))))) 1171 (cond ((and buffer 1172 pop-to-buffer) 1173 (pop-to-buffer buffer)) 1174 ((and pop-to-buffer 1175 sly-process-or-connection) 1176 (sly-message "No *inferior lisp* process for current connection!")) 1177 (pop-to-buffer 1178 (sly-error "No *inferior lisp* buffer"))) 1179 buffer)) 1180 1181(defun sly--guess-inferior-lisp-program (&optional interactive) 1182 "Compute pathname to a seemingly valid lisp implementation. 1183If ERRORP, error if such a thing cannot be found" 1184 (let ((inferior-lisp-program-and-args 1185 (and inferior-lisp-program 1186 (if (listp inferior-lisp-program) 1187 inferior-lisp-program 1188 (split-string-and-unquote inferior-lisp-program))))) 1189 (if (and inferior-lisp-program-and-args 1190 (executable-find (car inferior-lisp-program-and-args))) 1191 (combine-and-quote-strings inferior-lisp-program-and-args) 1192 (let ((guessed (cl-some #'executable-find 1193 '("lisp" "sbcl" "clisp" "cmucl" 1194 "acl" "alisp")))) 1195 (cond ((and guessed 1196 (or (not interactive) 1197 noninteractive 1198 (sly-y-or-n-p 1199 "Can't find `inferior-lisp-program' (set to `%s'). Use `%s' instead? " 1200 inferior-lisp-program guessed))) 1201 guessed) 1202 (interactive 1203 (sly-error 1204 (substitute-command-keys 1205 "Can't find a suitable Lisp. Use \\[sly-info] to read about `Multiple Lisps'"))) 1206 (t 1207 nil)))))) 1208 1209(cl-defun sly-start (&key (program 1210 (sly-error "must supply :program")) 1211 program-args 1212 directory 1213 (coding-system sly-net-coding-system) 1214 (init sly-init-function) 1215 name 1216 (buffer (format "*sly-started inferior-lisp for %s*" 1217 (file-name-nondirectory program))) 1218 init-function 1219 env) 1220 "Start a Lisp process and connect to it. 1221This function is intended for programmatic use if `sly' is not 1222flexible enough. 1223 1224PROGRAM and PROGRAM-ARGS are the filename and argument strings 1225 for the subprocess. 1226INIT is a function that should return a string to load and start 1227 Slynk. The function will be called with the PORT-FILENAME and ENCODING as 1228 arguments. INIT defaults to `sly-init-function'. 1229CODING-SYSTEM a symbol for the coding system. The default is 1230 sly-net-coding-system 1231ENV environment variables for the subprocess (see `process-environment'). 1232INIT-FUNCTION function to call right after the connection is established. 1233BUFFER the name of the buffer to use for the subprocess. 1234NAME a symbol to describe the Lisp implementation 1235DIRECTORY change to this directory before starting the process. 1236" 1237 (let ((args (list :program program :program-args program-args :buffer buffer 1238 :coding-system coding-system :init init :name name 1239 :init-function init-function :env env))) 1240 (sly-check-coding-system coding-system) 1241 (let ((proc (sly-maybe-start-lisp program program-args env 1242 directory buffer))) 1243 (sly-inferior-connect proc args) 1244 (sly-inferior-lisp-buffer proc)))) 1245 1246;;;###autoload 1247(defun sly-connect (host port &optional _coding-system interactive-p) 1248 "Connect to a running Slynk server. Return the connection. 1249With prefix arg, asks if all connections should be closed 1250before." 1251 (interactive (list (read-from-minibuffer 1252 "[sly] Host: " (cl-first sly-connect-host-history) 1253 nil nil '(sly-connect-host-history . 1)) 1254 (string-to-number 1255 (read-from-minibuffer 1256 "[sly] Port: " (cl-first sly-connect-port-history) 1257 nil nil '(sly-connect-port-history . 1))) 1258 nil t)) 1259 (when (and interactive-p 1260 sly-net-processes 1261 current-prefix-arg 1262 (sly-y-or-n-p "[sly] Close all connections first? ")) 1263 (sly-disconnect-all)) 1264 (sly-message "Connecting to Slynk on port %S.." port) 1265 (let* ((process (sly-net-connect host port)) 1266 (sly-dispatching-connection process)) 1267 (sly-setup-connection process))) 1268 1269;;;;; Start inferior lisp 1270;;; 1271;;; Here is the protocol for starting SLY via `M-x sly': 1272;;; 1273;;; 1. Emacs starts an inferior Lisp process. 1274;;; 2. Emacs tells Lisp (via stdio) to load and start Slynk. 1275;;; 3. Lisp recompiles the Slynk if needed. 1276;;; 4. Lisp starts the Slynk server and writes its TCP port to a temp file. 1277;;; 5. Emacs reads the temp file to get the port and then connects. 1278;;; 6. Emacs prints a message of warm encouragement for the hacking ahead. 1279;;; 1280;;; Between steps 2-5 Emacs polls for the creation of the temp file so 1281;;; that it can make the connection. This polling may continue for a 1282;;; fair while if Slynk needs recompilation. 1283 1284(defvar sly-connect-retry-timer nil 1285 "Timer object while waiting for an inferior-lisp to start.") 1286 1287(defun sly-abort-connection () 1288 "Abort connection the current connection attempt." 1289 (interactive) 1290 (cond (sly-connect-retry-timer 1291 (sly-cancel-connect-retry-timer) 1292 (sly-message "Cancelled connection attempt.")) 1293 (t (error "Not connecting")))) 1294 1295;;; Starting the inferior Lisp and loading Slynk: 1296 1297(defun sly-maybe-start-lisp (program program-args env directory buffer) 1298 "Return a new or existing inferior lisp process." 1299 (cond ((not (comint-check-proc buffer)) 1300 (sly-start-lisp program program-args env directory buffer)) 1301 (t (sly-start-lisp program program-args env directory 1302 (generate-new-buffer-name buffer))))) 1303 1304(defvar sly-inferior-process-start-hook nil 1305 "Hook called whenever a new process gets started.") 1306 1307(defun sly-start-lisp (program program-args env directory buffer) 1308 "Does the same as `inferior-lisp' but less ugly. 1309Return the created process." 1310 (with-current-buffer (get-buffer-create buffer) 1311 (when directory 1312 (cd (expand-file-name directory))) 1313 (comint-mode) 1314 (let ((process-environment (append env process-environment)) 1315 (process-connection-type nil)) 1316 (comint-exec (current-buffer) "inferior-lisp" program nil program-args)) 1317 (lisp-mode-variables t) 1318 (let ((proc (get-buffer-process (current-buffer)))) 1319 (process-put proc 'sly-inferior-lisp-process t) 1320 (set-process-query-on-exit-flag proc (not sly-kill-without-query-p)) 1321 (run-hooks 'sly-inferior-process-start-hook) 1322 proc))) 1323 1324(defun sly-inferior-connect (process args) 1325 "Start a Slynk server in the inferior Lisp and connect." 1326 (sly-delete-slynk-port-file 'quiet) 1327 (sly-start-slynk-server process args) 1328 (sly-read-port-and-connect process)) 1329 1330(defun sly-start-slynk-server (inf-process args) 1331 "Start a Slynk server on the inferior lisp." 1332 (cl-destructuring-bind (&key coding-system init &allow-other-keys) args 1333 (with-current-buffer (process-buffer inf-process) 1334 (process-put inf-process 'sly-inferior-lisp-args args) 1335 (let ((str (funcall init (sly-slynk-port-file) coding-system))) 1336 (goto-char (process-mark inf-process)) 1337 (insert-before-markers str) 1338 (process-send-string inf-process str))))) 1339 1340(defun sly-inferior-lisp-args (inf-process) 1341 "Return the initial process arguments. 1342See `sly-start'." 1343 (process-get inf-process 'sly-inferior-lisp-args)) 1344 1345(defun sly-init-using-asdf (port-filename coding-system) 1346 "Return a string to initialize Lisp using ASDF. 1347Fall back to `sly-init-using-slynk-loader' if ASDF fails." 1348 (format "%S\n\n" 1349 `(cond ((ignore-errors 1350 (funcall 'require "asdf") 1351 (funcall (read-from-string "asdf:version-satisfies") 1352 (funcall (read-from-string "asdf:asdf-version")) 1353 "2.019")) 1354 (push (pathname ,(sly-to-lisp-filename (sly-slynk-path))) 1355 (symbol-value 1356 (read-from-string "asdf:*central-registry*"))) 1357 (funcall 1358 (read-from-string "asdf:load-system") 1359 :slynk) 1360 (funcall 1361 (read-from-string "slynk:start-server") 1362 ,(sly-to-lisp-filename port-filename))) 1363 (t 1364 ,(read (sly-init-using-slynk-loader port-filename 1365 coding-system)))))) 1366 1367;; XXX load-server & start-server used to be separated. maybe that was better. 1368(defun sly-init-using-slynk-loader (port-filename _coding-system) 1369 "Return a string to initialize Lisp." 1370 (let ((loader (sly-to-lisp-filename 1371 (expand-file-name sly-slynk-loader-backend (sly-slynk-path))))) 1372 ;; Return a single form to avoid problems with buffered input. 1373 (format "%S\n\n" 1374 `(progn 1375 (load ,loader :verbose t) 1376 (funcall (read-from-string "slynk-loader:init")) 1377 (funcall (read-from-string "slynk:start-server") 1378 ,port-filename))))) 1379 1380(defun sly-slynk-port-file () 1381 "Filename where the SLYNK server writes its TCP port number." 1382 (expand-file-name (format "sly.%S" (emacs-pid)) (sly-temp-directory))) 1383 1384(defun sly-temp-directory () 1385 (cond ((fboundp 'temp-directory) (temp-directory)) 1386 ((boundp 'temporary-file-directory) temporary-file-directory) 1387 (t "/tmp/"))) 1388 1389(defun sly-delete-slynk-port-file (&optional quiet) 1390 (condition-case data 1391 (delete-file (sly-slynk-port-file)) 1392 (error 1393 (cl-ecase quiet 1394 ((nil) (signal (car data) (cdr data))) 1395 (quiet) 1396 (sly-message (sly-message "Unable to delete slynk port file %S" 1397 (sly-slynk-port-file))))))) 1398 1399(defun sly-read-port-and-connect (inferior-process) 1400 (sly-attempt-connection inferior-process nil 1)) 1401 1402(defcustom sly-connection-poll-interval 0.3 1403 "Seconds to wait between connection attempts when first connecting." 1404 :type 'number 1405 :group 'sly-ui) 1406 1407(defun sly-attempt-connection (process retries attempt) 1408 ;; A small one-state machine to attempt a connection with 1409 ;; timer-based retries. 1410 (sly-cancel-connect-retry-timer) 1411 (let ((file (sly-slynk-port-file))) 1412 (unless (active-minibuffer-window) 1413 (sly-message "Polling %S .. %d (Abort with `M-x sly-abort-connection'.)" 1414 file attempt)) 1415 (cond ((and (file-exists-p file) 1416 (> (nth 7 (file-attributes file)) 0)) ; file size 1417 (let ((port (sly-read-slynk-port)) 1418 (args (sly-inferior-lisp-args process))) 1419 (sly-delete-slynk-port-file 'message) 1420 (let ((c (sly-connect sly-lisp-host port 1421 (plist-get args :coding-system)))) 1422 (sly-set-inferior-process c process)))) 1423 ((and retries (zerop retries)) 1424 (sly-message "Gave up connecting to Slynk after %d attempts." attempt)) 1425 ((eq (process-status process) 'exit) 1426 (sly-message "Failed to connect to Slynk: inferior process exited.")) 1427 (t 1428 (when (and (file-exists-p file) 1429 (zerop (nth 7 (file-attributes file)))) 1430 (sly-message "(Zero length port file)") 1431 ;; the file may be in the filesystem but not yet written 1432 (unless retries (setq retries 3))) 1433 (cl-assert (not sly-connect-retry-timer)) 1434 (setq sly-connect-retry-timer 1435 (run-with-timer 1436 sly-connection-poll-interval nil 1437 #'sly-timer-call #'sly-attempt-connection 1438 `((sly-ignore-protocol-mismatches . ,sly-ignore-protocol-mismatches)) 1439 process (and retries (1- retries)) 1440 (1+ attempt))))))) 1441 1442(defun sly-timer-call (fun env &rest args) 1443 "Call function FUN with ARGS, reporting all errors. 1444 1445FUN is called with the overriding dynamic environment in ENV, an 1446alist of bindings. 1447 1448The default condition handler for timer functions (see 1449`timer-event-handler') ignores errors." 1450 (condition-case data 1451 (cl-progv (mapcar #'car env) (mapcar #'cdr env) 1452 (apply fun args)) 1453 ((debug error) 1454 (debug nil (list "Error in timer" fun args data))))) 1455 1456(defun sly-cancel-connect-retry-timer () 1457 (when sly-connect-retry-timer 1458 (cancel-timer sly-connect-retry-timer) 1459 (setq sly-connect-retry-timer nil))) 1460 1461(defun sly-read-slynk-port () 1462 "Read the Slynk server port number from the `sly-slynk-port-file'." 1463 (save-excursion 1464 (with-temp-buffer 1465 (insert-file-contents (sly-slynk-port-file)) 1466 (goto-char (point-min)) 1467 (let ((port (read (current-buffer)))) 1468 (cl-assert (integerp port)) 1469 port)))) 1470 1471(defun sly-toggle-debug-on-slynk-error () 1472 (interactive) 1473 (if (sly-eval `(slynk:toggle-debug-on-slynk-error)) 1474 (sly-message "Debug on SLYNK error enabled.") 1475 (sly-message "Debug on SLYNK error disabled."))) 1476 1477;;; Words of encouragement 1478 1479(defun sly-user-first-name () 1480 (let ((name (if (string= (user-full-name) "") 1481 (user-login-name) 1482 (user-full-name)))) 1483 (string-match "^[^ ]*" name) 1484 (capitalize (match-string 0 name)))) 1485 1486(defvar sly-words-of-encouragement 1487 `("Let the hacking commence!" 1488 "Hacks and glory await!" 1489 "Hack and be merry!" 1490 "Your hacking starts... NOW!" 1491 "May the source be with you!" 1492 "Take this REPL, brother, and may it serve you well." 1493 "Lemonodor-fame is but a hack away!" 1494 "Are we consing yet?" 1495 ,(format "%s, this could be the start of a beautiful program." 1496 (sly-user-first-name))) 1497 "Scientifically-proven optimal words of hackerish encouragement.") 1498 1499(defun sly-random-words-of-encouragement () 1500 "Return a string of hackerish encouragement." 1501 (eval (nth (random (length sly-words-of-encouragement)) 1502 sly-words-of-encouragement) 1503 t)) 1504 1505 1506;;;; Networking 1507;;; 1508;;; This section covers the low-level networking: establishing 1509;;; connections and encoding/decoding protocol messages. 1510;;; 1511;;; Each SLY protocol message beings with a 6-byte header followed 1512;;; by an S-expression as text. The sexp must be readable both by 1513;;; Emacs and by Common Lisp, so if it contains any embedded code 1514;;; fragments they should be sent as strings: 1515;;; 1516;;; The set of meaningful protocol messages are not specified 1517;;; here. They are defined elsewhere by the event-dispatching 1518;;; functions in this file and in slynk.lisp. 1519 1520(defvar sly-net-processes nil 1521 "List of processes (sockets) connected to Lisps.") 1522 1523(defvar sly-net-process-close-hooks '() 1524 "List of functions called when a sly network connection closes. 1525The functions are called with the process as their argument.") 1526 1527(defun sly-secret () 1528 "Find the magic secret from the user's home directory. 1529Return nil if the file doesn't exist or is empty; otherwise the 1530first line of the file." 1531 (condition-case _err 1532 (with-temp-buffer 1533 (insert-file-contents "~/.sly-secret") 1534 (goto-char (point-min)) 1535 (buffer-substring (point-min) (line-end-position))) 1536 (file-error nil))) 1537 1538;;; Interface 1539(defvar sly--net-connect-counter 0) 1540 1541(defun sly-send-secret (proc) 1542 (sly--when-let (secret (sly-secret)) 1543 (let* ((payload (encode-coding-string secret 'utf-8-unix)) 1544 (string (concat (sly-net-encode-length (length payload)) 1545 payload))) 1546 (process-send-string proc string)))) 1547 1548(defun sly-net-connect (host port) 1549 "Establish a connection with a CL." 1550 (let* ((inhibit-quit nil) 1551 (name (format "sly-%s" (cl-incf sly--net-connect-counter))) 1552 (connection (open-network-stream name nil host port)) 1553 (buffer (sly-make-net-buffer (format " *%s*" name)))) 1554 (push connection sly-net-processes) 1555 (set-process-plist connection `(sly--net-connect-counter 1556 ,sly--net-connect-counter)) 1557 (set-process-buffer connection buffer) 1558 (set-process-filter connection 'sly-net-filter) 1559 (set-process-sentinel connection 'sly-net-sentinel) 1560 (set-process-query-on-exit-flag connection (not sly-kill-without-query-p)) 1561 (when (fboundp 'set-process-coding-system) 1562 (set-process-coding-system connection 'binary 'binary)) 1563 (sly-send-secret connection) 1564 connection)) 1565 1566(defun sly-make-net-buffer (name) 1567 "Make a buffer suitable for a network process." 1568 (let ((buffer (generate-new-buffer name))) 1569 (with-current-buffer buffer 1570 (buffer-disable-undo) 1571 (set (make-local-variable 'kill-buffer-query-functions) nil)) 1572 buffer)) 1573 1574;;;;; Coding system madness 1575 1576(defun sly-check-coding-system (coding-system) 1577 "Signal an error if CODING-SYSTEM isn't a valid coding system." 1578 (interactive) 1579 (let ((props (sly-find-coding-system coding-system))) 1580 (unless props 1581 (error "Invalid sly-net-coding-system: %s. %s" 1582 coding-system (mapcar #'car sly-net-valid-coding-systems))) 1583 (when (and (cl-second props) (boundp 'default-enable-multibyte-characters)) 1584 (cl-assert default-enable-multibyte-characters)) 1585 t)) 1586 1587(defun sly-coding-system-mulibyte-p (coding-system) 1588 (cl-second (sly-find-coding-system coding-system))) 1589 1590(defun sly-coding-system-cl-name (coding-system) 1591 (cl-third (sly-find-coding-system coding-system))) 1592 1593;;; Interface 1594(defvar sly-net-send-translator nil 1595 "If non-nil, function to translate outgoing sexps for the wire.") 1596 1597(defun sly--sanitize-or-lose (form) 1598 "Sanitize FORM for Slynk or error." 1599 (cl-typecase form 1600 (number) 1601 (symbol 'fonix) 1602 (string (set-text-properties 0 (length form) nil form)) 1603 (cons (sly--sanitize-or-lose (car form)) 1604 (sly--sanitize-or-lose (cdr form))) 1605 (t (sly-error "Can't serialize %s for Slynk." form))) 1606 form) 1607 1608(defun sly-net-send (sexp proc) 1609 "Send a SEXP to Lisp over the socket PROC. 1610This is the lowest level of communication. The sexp will be READ and 1611EVAL'd by Lisp." 1612 (let* ((print-circle nil) 1613 (print-quoted nil) 1614 (sexp (sly--sanitize-or-lose sexp)) 1615 (sexp (if (and sly-net-send-translator 1616 (fboundp sly-net-send-translator)) 1617 (funcall sly-net-send-translator sexp) 1618 sexp)) 1619 (payload (encode-coding-string 1620 (concat (sly-prin1-to-string sexp) "\n") 1621 'utf-8-unix)) 1622 (string (concat (sly-net-encode-length (length payload)) 1623 payload))) 1624 (sly-log-event sexp proc) 1625 (process-send-string proc string))) 1626 1627(defun sly-safe-encoding-p (coding-system string) 1628 "Return true iff CODING-SYSTEM can safely encode STRING." 1629 (or (let ((candidates (find-coding-systems-string string)) 1630 (base (coding-system-base coding-system))) 1631 (or (equal candidates '(undecided)) 1632 (memq base candidates))) 1633 (and (not (multibyte-string-p string)) 1634 (not (sly-coding-system-mulibyte-p coding-system))))) 1635 1636(defun sly-net-close (connection reason &optional debug _force) 1637 "Close the network connection CONNECTION because REASON." 1638 (process-put connection 'sly-net-close-reason reason) 1639 (setq sly-net-processes (remove connection sly-net-processes)) 1640 (when (eq connection sly-default-connection) 1641 (setq sly-default-connection nil)) 1642 ;; Run hooks 1643 ;; 1644 (unless debug 1645 (run-hook-with-args 'sly-net-process-close-hooks connection)) 1646 ;; We close the socket connection by killing its hidden 1647 ;; *sly-<number>* buffer, but we first unset the connection's 1648 ;; sentinel otherwise we could get a second `sly-net-close' call. In 1649 ;; case the buffer is already killed (we killed it manually), this 1650 ;; function is probably running as a result of that, and rekilling 1651 ;; it is harmless. 1652 ;; 1653 (set-process-sentinel connection nil) 1654 (when debug 1655 (set-process-filter connection nil)) 1656 (if debug 1657 (delete-process connection) ; leave the buffer 1658 (kill-buffer (process-buffer connection)))) 1659 1660(defun sly-net-sentinel (process message) 1661 (let ((reason (format "Lisp connection closed unexpectedly: %s" message))) 1662 (sly-message reason) 1663 (sly-net-close process reason))) 1664 1665;;; Socket input is handled by `sly-net-filter', which decodes any 1666;;; complete messages and hands them off to the event dispatcher. 1667 1668(defun sly-net-filter (process string) 1669 "Accept output from the socket and process all complete messages." 1670 (with-current-buffer (process-buffer process) 1671 (goto-char (point-max)) 1672 (insert string)) 1673 (sly-process-available-input process)) 1674 1675(defun sly-process-available-input (process) 1676 "Process all complete messages that have arrived from Lisp." 1677 (with-current-buffer (process-buffer process) 1678 (while (sly-net-have-input-p) 1679 (let ((event (sly-net-read-or-lose process)) 1680 (ok nil)) 1681 (sly-log-event event process) 1682 (unwind-protect 1683 (save-current-buffer 1684 (sly-dispatch-event event process) 1685 (setq ok t)) 1686 (unless ok 1687 (run-at-time 0 nil 'sly-process-available-input process))))))) 1688 1689(defsubst sly-net-decode-length () 1690 (string-to-number (buffer-substring (point) (+ (point) 6)) 1691 16)) 1692 1693(defun sly-net-have-input-p () 1694 "Return true if a complete message is available." 1695 (goto-char (point-min)) 1696 (and (>= (buffer-size) 6) 1697 (>= (- (buffer-size) 6) (sly-net-decode-length)))) 1698 1699(defun sly-handle-net-read-error (error) 1700 (let ((packet (buffer-string))) 1701 (sly-with-popup-buffer ((sly-buffer-name :error 1702 :connection (get-buffer-process (current-buffer)))) 1703 (princ (format "%s\nin packet:\n%s" (error-message-string error) packet)) 1704 (goto-char (point-min))) 1705 (cond ((sly-y-or-n-p "Skip this packet? ") 1706 `(:emacs-skipped-packet ,packet)) 1707 (t 1708 (when (sly-y-or-n-p "Enter debugger instead? ") 1709 (debug 'error error)) 1710 (signal (car error) (cdr error)))))) 1711 1712(defun sly-net-read-or-lose (process) 1713 (condition-case error 1714 (sly-net-read) 1715 (error 1716 (sly-net-close process "Fatal net-read error" t) 1717 (error "net-read error: %S" error)))) 1718 1719(defun sly-net-read () 1720 "Read a message from the network buffer." 1721 (goto-char (point-min)) 1722 (let* ((length (sly-net-decode-length)) 1723 (start (+ (point) 6)) 1724 (end (+ start length))) 1725 (cl-assert (cl-plusp length)) 1726 (prog1 (save-restriction 1727 (narrow-to-region start end) 1728 (condition-case error 1729 (progn 1730 (decode-coding-region start end 'utf-8-unix) 1731 (setq end (point-max)) 1732 (read (current-buffer))) 1733 (error 1734 (sly-handle-net-read-error error)))) 1735 (delete-region (point-min) end)))) 1736 1737(defun sly-net-encode-length (n) 1738 (format "%06x" n)) 1739 1740(defun sly-prin1-to-string (sexp) 1741 "Like `prin1-to-string' but don't octal-escape non-ascii characters. 1742This is more compatible with the CL reader." 1743 (let (print-escape-nonascii 1744 print-escape-newlines 1745 print-length 1746 print-level) 1747 (prin1-to-string sexp))) 1748 1749 1750;;;; Connections 1751;;; 1752;;; "Connections" are the high-level Emacs<->Lisp networking concept. 1753;;; 1754;;; Emacs has a connection to each Lisp process that it's interacting 1755;;; with. Typically there would only be one, but a user can choose to 1756;;; connect to many Lisps simultaneously. 1757;;; 1758;;; A connection consists of a control socket, optionally an extra 1759;;; socket dedicated to receiving Lisp output (an optimization), and a 1760;;; set of connection-local state variables. 1761;;; 1762;;; The state variables are stored as buffer-local variables in the 1763;;; control socket's process-buffer and are used via accessor 1764;;; functions. These variables include things like the *FEATURES* list 1765;;; and Unix Pid of the Lisp process. 1766;;; 1767;;; One connection is "current" at any given time. This is: 1768;;; `sly-dispatching-connection' if dynamically bound, or 1769;;; `sly-buffer-connection' if this is set buffer-local, or 1770;;; `sly-default-connection' otherwise. 1771;;; 1772;;; When you're invoking commands in your source files you'll be using 1773;;; `sly-default-connection'. This connection can be interactively 1774;;; reassigned via the connection-list buffer. 1775;;; 1776;;; When a command creates a new buffer it will set 1777;;; `sly-buffer-connection' so that commands in the new buffer will 1778;;; use the connection that the buffer originated from. For example, 1779;;; the apropos command creates the *Apropos* buffer and any command 1780;;; in that buffer (e.g. `M-.') will go to the same Lisp that did the 1781;;; apropos search. REPL buffers are similarly tied to their 1782;;; respective connections. 1783;;; 1784;;; When Emacs is dispatching some network message that arrived from a 1785;;; connection it will dynamically bind `sly-dispatching-connection' 1786;;; so that the event will be processed in the context of that 1787;;; connection. 1788;;; 1789;;; This is mostly transparent. The user should be aware that he can 1790;;; set the default connection to pick which Lisp handles commands in 1791;;; Lisp-mode source buffers, and sly hackers should be aware that 1792;;; they can tie a buffer to a specific connection. The rest takes 1793;;; care of itself. 1794 1795(defvar sly-dispatching-connection nil 1796 "Network process currently executing. 1797This is dynamically bound while handling messages from Lisp; it 1798overrides `sly-buffer-connection' and `sly-default-connection'.") 1799 1800(make-variable-buffer-local 1801 (defvar sly-buffer-connection nil 1802 "Network connection to use in the current buffer. 1803This overrides `sly-default-connection'.")) 1804 1805(defvar sly-default-connection nil 1806 "Network connection to use by default. 1807Used for all Lisp communication, except when overridden by 1808`sly-dispatching-connection' or `sly-buffer-connection'.") 1809 1810(defun sly-current-connection () 1811 "Return the connection to use for Lisp interaction. 1812Return nil if there's no connection." 1813 (or sly-dispatching-connection 1814 sly-buffer-connection 1815 sly-default-connection)) 1816 1817(defun sly-connection () 1818 "Return the connection to use for Lisp interaction. 1819Signal an error if there's no connection." 1820 (let ((conn (sly-current-connection))) 1821 (cond ((and (not conn) sly-net-processes) 1822 (or (sly-auto-select-connection) 1823 (error "Connections available, but none selected."))) 1824 ((not conn) 1825 (or (sly-auto-start) 1826 (error "No current SLY connection."))) 1827 ((not (process-live-p conn)) 1828 (error "Current connection %s is closed." conn)) 1829 (t conn)))) 1830 1831(define-obsolete-variable-alias 'sly-auto-connect 1832 'sly-auto-start "2.5") 1833(defcustom sly-auto-start 'never 1834 "Controls auto connection when information from lisp process is needed. 1835This doesn't mean it will connect right after SLY is loaded." 1836 :group 'sly-mode 1837 :type '(choice (const never) 1838 (const always) 1839 (const ask))) 1840 1841(defun sly-auto-start () 1842 (cond ((or (eq sly-auto-start 'always) 1843 (and (eq sly-auto-start 'ask) 1844 (sly-y-or-n-p "No connection. Start SLY? "))) 1845 (save-window-excursion 1846 (sly) 1847 (while (not (sly-current-connection)) 1848 (sleep-for 1)) 1849 (sly-connection))) 1850 (t nil))) 1851 1852(cl-defmacro sly-with-connection-buffer ((&optional process) &rest body) 1853 "Execute BODY in the process-buffer of PROCESS. 1854If PROCESS is not specified, `sly-connection' is used. 1855 1856\(fn (&optional PROCESS) &body BODY))" 1857 (declare (indent 1)) 1858 `(with-current-buffer 1859 (process-buffer (or ,process (sly-connection) 1860 (error "No connection"))) 1861 ,@body)) 1862 1863;;; Connection-local variables: 1864 1865(defmacro sly-def-connection-var (varname &rest initial-value-and-doc) 1866 "Define a connection-local variable. 1867The value of the variable can be read by calling the function of the 1868same name (it must not be accessed directly). The accessor function is 1869setf-able. 1870 1871The actual variable bindings are stored buffer-local in the 1872process-buffers of connections. The accessor function refers to 1873the binding for `sly-connection'." 1874 (declare (indent 2)) 1875 `(progn 1876 ;; Accessor 1877 (defun ,varname (&optional process) 1878 ,(cl-second initial-value-and-doc) 1879 (let ((process (or process 1880 (sly-current-connection) 1881 (error "Can't access prop %s for no connection" ',varname)))) 1882 (or (process-get process ',varname) 1883 (let ((once ,(cl-first initial-value-and-doc))) 1884 (process-put process ',varname once) 1885 once)))) 1886 ;; Setf 1887 (gv-define-setter ,varname (store &optional process) 1888 `(let ((process (or ,process 1889 (sly-current-connection) 1890 (error "Can't access prop %s for no connection" ',',varname))) 1891 (store-once ,store)) 1892 (process-put process ',',varname store-once) 1893 store-once)) 1894 '(\, varname))) 1895 1896(sly-def-connection-var sly-connection-number nil 1897 "Serial number of a connection. 1898Bound in the connection's process-buffer.") 1899 1900(sly-def-connection-var sly-lisp-features '() 1901 "The symbol-names of Lisp's *FEATURES*. 1902This is automatically synchronized from Lisp.") 1903 1904(sly-def-connection-var sly-lisp-modules '() 1905 "The strings of Lisp's *MODULES*.") 1906 1907(sly-def-connection-var sly-pid nil 1908 "The process id of the Lisp process.") 1909 1910(sly-def-connection-var sly-lisp-implementation-type nil 1911 "The implementation type of the Lisp process.") 1912 1913(sly-def-connection-var sly-lisp-implementation-version nil 1914 "The implementation type of the Lisp process.") 1915 1916(sly-def-connection-var sly-lisp-implementation-name nil 1917 "The short name for the Lisp implementation.") 1918 1919(sly-def-connection-var sly-lisp-implementation-program nil 1920 "The argv[0] of the process running the Lisp implementation.") 1921 1922(sly-def-connection-var sly-connection-name nil 1923 "The short name for connection.") 1924 1925(sly-def-connection-var sly-inferior-process nil 1926 "The inferior process for the connection if any.") 1927 1928(sly-def-connection-var sly-communication-style nil 1929 "The communication style.") 1930 1931(sly-def-connection-var sly-machine-instance nil 1932 "The name of the (remote) machine running the Lisp process.") 1933 1934(sly-def-connection-var sly-connection-coding-systems nil 1935 "Coding systems supported by the Lisp process.") 1936 1937;;;;; Connection setup 1938 1939(defvar sly-connection-counter 0 1940 "The number of SLY connections made. For generating serial numbers.") 1941 1942;;; Interface 1943(defun sly-setup-connection (process) 1944 "Make a connection out of PROCESS." 1945 (let ((sly-dispatching-connection process)) 1946 (sly-init-connection-state process) 1947 (sly-select-connection process) 1948 (sly--setup-contribs) 1949 process)) 1950 1951(defun sly-init-connection-state (proc) 1952 "Initialize connection state in the process-buffer of PROC." 1953 ;; To make life simpler for the user: if this is the only open 1954 ;; connection then reset the connection counter. 1955 (when (equal sly-net-processes (list proc)) 1956 (setq sly-connection-counter 0)) 1957 (sly-with-connection-buffer () 1958 (setq sly-buffer-connection proc)) 1959 (setf (sly-connection-number proc) (cl-incf sly-connection-counter)) 1960 ;; We do the rest of our initialization asynchronously. The current 1961 ;; function may be called from a timer, and if we setup the REPL 1962 ;; from a timer then it mysteriously uses the wrong keymap for the 1963 ;; first command. 1964 (let ((sly-current-thread t)) 1965 (sly-eval-async '(slynk:connection-info) 1966 (sly-curry #'sly-set-connection-info proc) 1967 nil 1968 `((sly-ignore-protocol-mismatches . ,sly-ignore-protocol-mismatches))))) 1969 1970(defun sly--trampling-rename-buffer (newname) 1971 "Rename current buffer NEWNAME, trampling over existing ones." 1972 (let ((existing (get-buffer newname))) 1973 (unless (eq existing 1974 (current-buffer)) 1975 ;; Trample over any existing buffers on reconnection 1976 (when existing 1977 (let ((kill-buffer-query-functions nil)) 1978 (kill-buffer existing))) 1979 (rename-buffer newname)))) 1980 1981(defun sly-set-connection-info (connection info) 1982 "Initialize CONNECTION with INFO received from Lisp." 1983 (let ((sly-dispatching-connection connection) 1984 (sly-current-thread t)) 1985 (cl-destructuring-bind (&key pid style lisp-implementation machine 1986 features version modules encoding 1987 &allow-other-keys) info 1988 (sly-check-version version connection) 1989 (setf (sly-pid) pid 1990 (sly-communication-style) style 1991 (sly-lisp-features) features 1992 (sly-lisp-modules) modules) 1993 (cl-destructuring-bind (&key type name version program) 1994 lisp-implementation 1995 (setf (sly-lisp-implementation-type) type 1996 (sly-lisp-implementation-version) version 1997 (sly-lisp-implementation-name) name 1998 (sly-lisp-implementation-program) program 1999 (sly-connection-name) (sly-generate-connection-name name))) 2000 (cl-destructuring-bind (&key instance ((:type _)) ((:version _))) machine 2001 (setf (sly-machine-instance) instance)) 2002 (cl-destructuring-bind (&key coding-systems) encoding 2003 (setf (sly-connection-coding-systems) coding-systems))) 2004 (let ((args (sly--when-let (p (sly-inferior-process)) 2005 (sly-inferior-lisp-args p)))) 2006 (sly--when-let (name (plist-get args ':name)) 2007 (unless (string= (sly-lisp-implementation-name) name) 2008 (setf (sly-connection-name) 2009 (sly-generate-connection-name (symbol-name name))))) 2010 (sly-contrib--load-slynk-dependencies) 2011 (run-hooks 'sly-connected-hook) 2012 (sly--when-let (fun (plist-get args ':init-function)) 2013 (funcall fun))) 2014 ;; Give the events buffer its final name 2015 (with-current-buffer (sly--events-buffer connection) 2016 (sly--trampling-rename-buffer (sly-buffer-name 2017 :events 2018 :connection connection))) 2019 ;; Rename the inferior lisp buffer if there is one (i.e. when 2020 ;; started via `M-x sly') 2021 ;; 2022 (let ((inferior-lisp-buffer (sly-inferior-lisp-buffer 2023 (sly-process connection)))) 2024 (when inferior-lisp-buffer 2025 (with-current-buffer inferior-lisp-buffer 2026 (sly--trampling-rename-buffer (sly-buffer-name 2027 :inferior-lisp 2028 :connection connection))))) 2029 (sly-message "Connected. %s" (sly-random-words-of-encouragement)))) 2030 2031(defun sly-check-version (version conn) 2032 (or (equal version sly-protocol-version) 2033 (null sly-protocol-version) 2034 sly-ignore-protocol-mismatches 2035 (sly-y-or-n-p 2036 (format "Versions differ: %s (sly) vs. %s (slynk). Continue? " 2037 sly-protocol-version version)) 2038 (sly-net-close conn "Versions differ") 2039 (top-level))) 2040 2041(defun sly-generate-connection-name (lisp-name) 2042 (when (file-exists-p lisp-name) 2043 (setq lisp-name (file-name-nondirectory lisp-name))) 2044 (cl-loop for i from 1 2045 for name = lisp-name then (format "%s<%d>" lisp-name i) 2046 while (cl-find name sly-net-processes 2047 :key #'sly-connection-name :test #'equal) 2048 finally (cl-return name))) 2049 2050(defun sly-select-new-default-connection (conn) 2051 "If dead CONN was the default connection, select a new one." 2052 (when (eq conn sly-default-connection) 2053 (when sly-net-processes 2054 (sly-select-connection (car sly-net-processes)) 2055 (sly-message "Default connection closed; default is now #%S (%S)" 2056 (sly-connection-number) 2057 (sly-connection-name))))) 2058 2059(defcustom sly-keep-buffers-on-connection-close '(:mrepl) 2060 "List of buffers to keep around after a connection closes." 2061 :group 'sly-mode 2062 :type '(repeat 2063 (choice 2064 (const :tag "Debugger" :db) 2065 (const :tag "Repl" :mrepl) 2066 (const :tag "Ispector" :inspector) 2067 (const :tag "Stickers replay" :stickers-replay) 2068 (const :tag "Error" :error) 2069 (const :tag "Source" :source) 2070 (const :tag "Compilation" :compilation) 2071 (const :tag "Apropos" :apropos) 2072 (const :tag "Xref" :xref) 2073 (const :tag "Macroexpansion" :macroexpansion) 2074 (symbol :tag "Other")))) 2075 2076(defun sly-kill-stale-connection-buffers (conn) ; 2077 "If CONN had some stale buffers, kill them. 2078Respect `sly-keep-buffers-on-connection-close'." 2079 (let ((buffer-list (buffer-list)) 2080 (matchers 2081 (mapcar 2082 (lambda (type) 2083 (format ".*%s.*$" 2084 ;; XXX: this is synched with `sly-buffer-name'. 2085 (regexp-quote (format "*sly-%s" 2086 (downcase (substring (symbol-name type) 2087 1)))))) 2088 (cl-set-difference '(:db 2089 :mrepl 2090 :inspector 2091 :stickers-replay 2092 :error 2093 :source 2094 :compilation 2095 :apropos 2096 :xref 2097 :macroexpansion) 2098 sly-keep-buffers-on-connection-close)))) 2099 (cl-loop for buffer in buffer-list 2100 when (and (cl-some (lambda (matcher) 2101 (string-match matcher (buffer-name buffer))) 2102 matchers) 2103 (with-current-buffer buffer 2104 (eq sly-buffer-connection conn))) 2105 do (kill-buffer buffer)))) 2106 2107(add-hook 'sly-net-process-close-hooks 'sly-select-new-default-connection) 2108(add-hook 'sly-net-process-close-hooks 'sly-kill-stale-connection-buffers 'append) 2109 2110;;;;; Commands on connections 2111 2112(defun sly--purge-connections () 2113 "Purge `sly-net-processes' of dead processes, return living." 2114 (cl-loop for process in sly-net-processes 2115 if (process-live-p process) 2116 collect process 2117 else do 2118 (sly-warning "process %s in `sly-net-processes' dead. Force closing..." process) 2119 (sly-net-close process "process state invalid" nil t))) 2120 2121(defun sly-prompt-for-connection (&optional prompt connections dont-require-match) 2122 (let* ((connections (or connections (sly--purge-connections))) 2123 (connection-names (cl-loop for process in 2124 (sort connections 2125 #'(lambda (p1 _p2) 2126 (eq p1 (sly-current-connection)))) 2127 collect (sly-connection-name process))) 2128 (connection-names (if dont-require-match 2129 (cons dont-require-match 2130 connection-names) 2131 connection-names)) 2132 (connection-name (and connection-names 2133 (sly-completing-read 2134 (or prompt "Connection: ") 2135 connection-names 2136 nil (not dont-require-match)))) 2137 (target (cl-find connection-name sly-net-processes :key #'sly-connection-name 2138 :test #'string=))) 2139 (cond (target target) 2140 ((and dont-require-match (or (zerop (length connection-name)) 2141 (string= connection-name dont-require-match))) 2142 nil) 2143 (connection-name 2144 (sly-error "No such connection")) 2145 (t 2146 (sly-error "No connections"))))) 2147 2148(defun sly-auto-select-connection () 2149 (let* ((c0 (car (sly--purge-connections))) 2150 (c (cond ((eq sly-auto-select-connection 'always) c0) 2151 ((and (eq sly-auto-select-connection 'ask) 2152 (sly-prompt-for-connection "Choose a new default connection: ")))))) 2153 (when c 2154 (sly-select-connection c) 2155 (sly-message "Switching to connection: %s" (sly-connection-name c)) 2156 c))) 2157 2158(defvar sly-select-connection-hook nil) 2159 2160(defun sly-select-connection (process) 2161 "Make PROCESS the default connection." 2162 (setq sly-default-connection process) 2163 (run-hooks 'sly-select-connection-hook)) 2164 2165(define-obsolete-function-alias 'sly-cycle-connections 'sly-next-connection "1.0.0-beta") 2166 2167(defun sly-next-connection (arg &optional dont-wrap) 2168 "Switch to the next SLY connection, cycling through all connections. 2169Skip ARG-1 connections. Negative ARG means cycle back. DONT-WRAP 2170means don't wrap around when last connection is reached." 2171 (interactive "p") 2172 (cl-labels ((connection-full-name 2173 (c) 2174 (format "%s %s" (sly-connection-name c) (process-contact c)))) 2175 (cond ((not sly-net-processes) 2176 (sly-error "No connections to cycle")) 2177 ((null (cdr sly-net-processes)) 2178 (sly-message "Only one connection: %s" (connection-full-name (car sly-net-processes)))) 2179 (t 2180 (let* ((dest (append (member (sly-current-connection) 2181 sly-net-processes) 2182 (unless dont-wrap sly-net-processes))) 2183 (len (length sly-net-processes)) 2184 (target (nth (mod arg len) 2185 dest))) 2186 (unless target 2187 (sly-error "No more connections")) 2188 (sly-select-connection target) 2189 (if (and sly-buffer-connection 2190 (not (eq sly-buffer-connection target))) 2191 (sly-message "switched to: %s but buffer remains in: %s" 2192 (connection-full-name target) 2193 (connection-full-name sly-buffer-connection)) 2194 (sly-message "switched to: %s (%s/%s)" (connection-full-name target) 2195 (1+ (cl-position target sly-net-processes)) 2196 len)) 2197 (sly--refresh-mode-line)))))) 2198 2199(defun sly-prev-connection (arg &optional dont-wrap) 2200 "Switch to the previous SLY connection, cycling through all connections. 2201See `sly-next-connection' for other args." 2202 (interactive "p") 2203 (sly-next-connection (- arg) dont-wrap)) 2204 2205(defun sly-disconnect (&optional interactive) 2206 "Close the current connection." 2207 (interactive (list t)) 2208 (let ((connection (if interactive 2209 (sly-prompt-for-connection "Connection to disconnect: ") 2210 (sly-current-connection)))) 2211 (sly-net-close connection "Disconnecting"))) 2212 2213(defun sly-disconnect-all () 2214 "Disconnect all connections." 2215 (interactive) 2216 (mapc #'(lambda (process) 2217 (sly-net-close process "Disconnecting all connections")) 2218 sly-net-processes)) 2219 2220(defun sly-connection-port (connection) 2221 "Return the remote port number of CONNECTION." 2222 (cadr (process-contact connection))) 2223 2224(defun sly-process (&optional connection) 2225 "Return the Lisp process for CONNECTION (default `sly-connection'). 2226Return nil if there's no process object for the connection." 2227 (let ((proc (sly-inferior-process connection))) 2228 (if (and proc 2229 (memq (process-status proc) '(run stop))) 2230 proc))) 2231 2232;; Non-macro version to keep the file byte-compilable. 2233(defun sly-set-inferior-process (connection process) 2234 (setf (sly-inferior-process connection) process)) 2235 2236(defun sly-use-sigint-for-interrupt (&optional connection) 2237 (let ((c (or connection (sly-connection)))) 2238 (cl-ecase (sly-communication-style c) 2239 ((:fd-handler nil) t) 2240 ((:spawn :sigio) nil)))) 2241 2242(defvar sly-inhibit-pipelining t 2243 "*If true, don't send background requests if Lisp is already busy.") 2244 2245(defun sly-background-activities-enabled-p () 2246 (and (let ((con (sly-current-connection))) 2247 (and con 2248 (eq (process-status con) 'open))) 2249 (or (not (sly-busy-p)) 2250 (not sly-inhibit-pipelining)))) 2251 2252 2253;;;; Communication protocol 2254 2255;;;;; Emacs Lisp programming interface 2256;;; 2257;;; The programming interface for writing Emacs commands is based on 2258;;; remote procedure calls (RPCs). The basic operation is to ask Lisp 2259;;; to apply a named Lisp function to some arguments, then to do 2260;;; something with the result. 2261;;; 2262;;; Requests can be either synchronous (blocking) or asynchronous 2263;;; (with the result passed to a callback/continuation function). If 2264;;; an error occurs during the request then the debugger is entered 2265;;; before the result arrives -- for synchronous evaluations this 2266;;; requires a recursive edit. 2267;;; 2268;;; You should use asynchronous evaluations (`sly-eval-async') for 2269;;; most things. Reserve synchronous evaluations (`sly-eval') for 2270;;; the cases where blocking Emacs is really appropriate (like 2271;;; completion) and that shouldn't trigger errors (e.g. not evaluate 2272;;; user-entered code). 2273;;; 2274;;; We have the concept of the "current Lisp package". RPC requests 2275;;; always say what package the user is making them from and the Lisp 2276;;; side binds that package to *BUFFER-PACKAGE* to use as it sees 2277;;; fit. The current package is defined as the buffer-local value of 2278;;; `sly-buffer-package' if set, and otherwise the package named by 2279;;; the nearest IN-PACKAGE as found by text search (cl-first backwards, 2280;;; then forwards). 2281;;; 2282;;; Similarly we have the concept of the current thread, i.e. which 2283;;; thread in the Lisp process should handle the request. The current 2284;;; thread is determined solely by the buffer-local value of 2285;;; `sly-current-thread'. This is usually bound to t meaning "no 2286;;; particular thread", but can also be used to nominate a specific 2287;;; thread. The REPL and the debugger both use this feature to deal 2288;;; with specific threads. 2289 2290(make-variable-buffer-local 2291 (defvar sly-current-thread t 2292 "The id of the current thread on the Lisp side. 2293t means the \"current\" thread; 2294fixnum a specific thread.")) 2295 2296(make-variable-buffer-local 2297 (defvar sly-buffer-package nil 2298 "The Lisp package associated with the current buffer. 2299This is set only in buffers bound to specific packages.")) 2300 2301;;; `sly-rex' is the RPC primitive which is used to implement both 2302;;; `sly-eval' and `sly-eval-async'. You can use it directly if 2303;;; you need to, but the others are usually more convenient. 2304 2305(defvar sly-rex-extra-options-functions nil 2306 "Functions returning extra options to send with `sly-rex'.") 2307 2308(cl-defmacro sly-rex ((&rest _) 2309 (sexp &optional 2310 (package '(sly-current-package)) 2311 (thread 'sly-current-thread)) 2312 &rest continuations) 2313 "(sly-rex (VAR ...) (SEXP &optional PACKAGE THREAD) CLAUSES ...) 2314 2315Remote EXecute SEXP. 2316 2317SEXP is evaluated and the princed version is sent to Lisp. 2318 2319PACKAGE is evaluated and Lisp binds *BUFFER-PACKAGE* to this package. 2320The default value is (sly-current-package). 2321 2322CLAUSES is a list of patterns with same syntax as 2323`sly-dcase'. The result of the evaluation of SEXP is 2324dispatched on CLAUSES. The result is either a sexp of the 2325form (:ok VALUE) or (:abort CONDITION). CLAUSES is executed 2326asynchronously. 2327 2328Note: don't use backquote syntax for SEXP, because various Emacs 2329versions cannot deal with that." 2330 (declare (indent 2) 2331 (debug (sexp (form &optional sexp sexp) 2332 &rest (sexp &rest form)))) 2333 (let ((result (cl-gensym))) 2334 `(sly-dispatch-event 2335 (cl-list* :emacs-rex ,sexp ,package ,thread 2336 (lambda (,result) 2337 (sly-dcase ,result 2338 ,@continuations)) 2339 (cl-loop for fn in sly-rex-extra-options-functions 2340 append (funcall fn)))))) 2341 2342;;; Interface 2343(defun sly-current-package () 2344 "Return the Common Lisp package in the current context. 2345If `sly-buffer-package' has a value then return that, otherwise 2346search for and read an `in-package' form." 2347 (or sly-buffer-package 2348 (save-restriction 2349 (widen) 2350 (sly-find-buffer-package)))) 2351 2352(defvar sly-find-buffer-package-function 'sly-search-buffer-package 2353 "*Function to use for `sly-find-buffer-package'. 2354The result should be the package-name (a string) 2355or nil if nothing suitable can be found.") 2356 2357(defun sly-find-buffer-package () 2358 "Figure out which Lisp package the current buffer is associated with." 2359 (funcall sly-find-buffer-package-function)) 2360 2361(make-variable-buffer-local 2362 (defvar sly-package-cache nil 2363 "Cons of the form (buffer-modified-tick . package)")) 2364 2365;; When modifing this code consider cases like: 2366;; (in-package #.*foo*) 2367;; (in-package #:cl) 2368;; (in-package :cl) 2369;; (in-package "CL") 2370;; (in-package |CL|) 2371;; (in-package #+ansi-cl :cl #-ansi-cl 'lisp) 2372 2373(defun sly-search-buffer-package () 2374 (let ((case-fold-search t) 2375 (regexp (concat "^[ \t]*(\\(cl:\\|common-lisp:\\)?in-package\\>[ \t']*" 2376 "\\([^)]+\\)[ \t]*)"))) 2377 (save-excursion 2378 (when (or (re-search-backward regexp nil t) 2379 (re-search-forward regexp nil t)) 2380 (match-string-no-properties 2))))) 2381 2382;;; Synchronous requests are implemented in terms of asynchronous 2383;;; ones. We make an asynchronous request with a continuation function 2384;;; that `throw's its result up to a `catch' and then enter a loop of 2385;;; handling I/O until that happens. 2386 2387(defvar sly--stack-eval-tags nil 2388 "List of stack-tags of waiting on the elisp stack. 2389This is used by the sly-db debugger to decide whether to enter a 2390`recursive-edit', so that if a synchronous `sly-eval' request 2391errors and brings us a Slynk debugger, we can fix the error, 2392invoke a restart and still get the return value of the `sly-eval' 2393as if nothing had happened.") 2394 2395(defun sly-eval (sexp &optional package cancel-on-input cancel-on-input-retval) 2396 "Evaluate SEXP in Slynk's PACKAGE and return the result. 2397If CANCEL-ON-INPUT cancel the request immediately if the user 2398wants to input, and return CANCEL-ON-INPUT-RETVAL." 2399 (when (null package) (setq package (sly-current-package))) 2400 (let* ((catch-tag (make-symbol (format "sly-result-%d" 2401 (sly-continuation-counter)))) 2402 (sly--stack-eval-tags (cons catch-tag sly--stack-eval-tags)) 2403 (cancelled nil) 2404 (check-conn 2405 (lambda () 2406 (unless (eq (process-status (sly-connection)) 'open) 2407 (error "Lisp connection closed unexpectedly")))) 2408 (retval 2409 (unwind-protect 2410 (catch catch-tag 2411 (sly-rex () 2412 (sexp package) 2413 ((:ok value) 2414 (unless cancelled 2415 (unless (member catch-tag sly--stack-eval-tags) 2416 (error "Reply to nested `sly-eval' request with tag=%S sexp=%S" 2417 catch-tag sexp)) 2418 (throw catch-tag (list #'identity value)))) 2419 ((:abort _condition) 2420 (unless cancelled 2421 (throw catch-tag 2422 (list #'error "Synchronous Lisp Evaluation aborted"))))) 2423 (cond (cancel-on-input 2424 ;; Setting `inhibit-quit' to t helps with 2425 ;; callers that wrap us in `while-no-input', 2426 ;; like `fido-mode' and Helm. It doesn't seem 2427 ;; to create any specific problems, since 2428 ;; `sit-for' exits immediately given input 2429 ;; anyway. This include the C-g input, and 2430 ;; thus even with `inhibit-quit' set to t, quit 2431 ;; happens immediately. 2432 (unwind-protect 2433 (let ((inhibit-quit t)) (while (sit-for 30))) 2434 (setq cancelled t)) 2435 (funcall check-conn)) 2436 (t 2437 (while t 2438 (funcall check-conn) 2439 (accept-process-output nil 30)))) 2440 (list #'identity cancel-on-input-retval)) 2441 ;; Protect against user quit during 2442 ;; `accept-process-output' or `sit-for', so that if the 2443 ;; Lisp is alive and replies, we don't get an error. 2444 (setq cancelled t)))) 2445 (apply (car retval) (cdr retval)))) 2446 2447(defun sly-eval-async (sexp &optional cont package env) 2448 "Evaluate SEXP on the superior Lisp and call CONT with the result. 2449 2450CONT is called with the overriding dynamic environment in ENV, an 2451alist of bindings" 2452 (declare (indent 1)) 2453 (let ((buffer (current-buffer))) 2454 (sly-rex () 2455 (sexp (or package (sly-current-package))) 2456 ((:ok result) 2457 (when cont 2458 (set-buffer buffer) 2459 (cl-progv (mapcar #'car env) (mapcar #'cdr env) 2460 (if debug-on-error 2461 (funcall cont result) 2462 (condition-case err 2463 (funcall cont result) 2464 (error 2465 (sly-message "`sly-eval-async' errored: %s" 2466 (if (and (eq 'error (car err)) 2467 (stringp (cadr err))) 2468 (cadr err) 2469 err)))))))) 2470 ((:abort condition) 2471 (sly-message "Evaluation aborted on %s." condition)))) 2472 ;; Guard against arbitrary return values which once upon a time 2473 ;; showed up in the minibuffer spuriously (due to a bug in 2474 ;; sly-autodoc.) If this ever happens again, returning the 2475 ;; following will make debugging much easier: 2476 :sly-eval-async) 2477 2478;;; These functions can be handy too: 2479 2480(defun sly-connected-p () 2481 "Return true if the Slynk connection is open." 2482 (not (null sly-net-processes))) 2483 2484(defun sly-check-connected () 2485 "Signal an error if we are not connected to Lisp." 2486 (unless (sly-connected-p) 2487 (error "Not connected. Use `%s' to start a Lisp." 2488 (substitute-command-keys "\\[sly]")))) 2489 2490;; UNUSED 2491(defun sly-debugged-connection-p (conn) 2492 ;; This previously was (AND (SLY-DB-DEBUGGED-CONTINUATIONS CONN) T), 2493 ;; but an SLY-DB buffer may exist without having continuations 2494 ;; attached to it, e.g. the one resulting from `sly-interrupt'. 2495 (cl-loop for b in (sly-db-buffers) 2496 thereis (with-current-buffer b 2497 (eq sly-buffer-connection conn)))) 2498 2499(defun sly-busy-p (&optional conn) 2500 "True if Lisp has outstanding requests. 2501Debugged requests are ignored." 2502 (let ((debugged (sly-db-debugged-continuations (or conn (sly-connection))))) 2503 (cl-remove-if (lambda (id) 2504 (memq id debugged)) 2505 (sly-rex-continuations) 2506 :key #'car))) 2507 2508(defun sly-sync () 2509 "Block until the most recent request has finished." 2510 (when (sly-rex-continuations) 2511 (let ((tag (caar (sly-rex-continuations)))) 2512 (while (cl-find tag (sly-rex-continuations) :key #'car) 2513 (accept-process-output nil 0.1))))) 2514 2515(defun sly-ping () 2516 "Check that communication works." 2517 (interactive) 2518 (sly-message "%s" (sly-eval "PONG"))) 2519 2520;;;;; Protocol event handler (the guts) 2521;;; 2522;;; This is the protocol in all its glory. The input to this function 2523;;; is a protocol event that either originates within Emacs or arrived 2524;;; over the network from Lisp. 2525;;; 2526;;; Each event is a list beginning with a keyword and followed by 2527;;; arguments. The keyword identifies the type of event. Events 2528;;; originating from Emacs have names starting with :emacs- and events 2529;;; from Lisp don't. 2530 2531(sly-def-connection-var sly-rex-continuations '() 2532 "List of (ID . FUNCTION) continuations waiting for RPC results.") 2533 2534(sly-def-connection-var sly-continuation-counter 0 2535 "Continuation serial number counter.") 2536 2537(defvar sly-event-hooks) 2538 2539(defun sly-dispatch-event (event &optional process) 2540 (let ((sly-dispatching-connection (or process (sly-connection)))) 2541 (or (run-hook-with-args-until-success 'sly-event-hooks event) 2542 (sly-dcase event 2543 ((:emacs-rex form package thread continuation &rest extra-options) 2544 (when (and (sly-use-sigint-for-interrupt) (sly-busy-p)) 2545 (sly-display-oneliner "; pipelined request... %S" form)) 2546 (let ((id (cl-incf (sly-continuation-counter)))) 2547 ;; JT@2020-12-10: FIXME: Force inhibit-quit here to 2548 ;; ensure atomicity between `sly-send' and the `push'? 2549 ;; See Github#385.. 2550 (sly-send `(:emacs-rex ,form ,package ,thread ,id ,@extra-options)) 2551 (push (cons id continuation) (sly-rex-continuations)) 2552 (sly--refresh-mode-line))) 2553 ((:return value id) 2554 (let ((rec (assq id (sly-rex-continuations)))) 2555 (cond (rec (setf (sly-rex-continuations) 2556 (remove rec (sly-rex-continuations))) 2557 (funcall (cdr rec) value) 2558 (sly--refresh-mode-line)) 2559 (t 2560 (error "Unexpected reply: %S %S" id value))))) 2561 ((:debug-activate thread level &optional _ignored) 2562 (cl-assert thread) 2563 (sly-db--ensure-initialized thread level)) 2564 ((:debug thread level condition restarts frames conts) 2565 (cl-assert thread) 2566 (sly-db-setup thread level condition restarts frames conts)) 2567 ((:debug-return thread level stepping) 2568 (cl-assert thread) 2569 (sly-db-exit thread level stepping)) 2570 ((:emacs-interrupt thread) 2571 (sly-send `(:emacs-interrupt ,thread))) 2572 ((:read-from-minibuffer thread tag prompt initial-value) 2573 (sly-read-from-minibuffer-for-slynk thread tag prompt 2574 initial-value)) 2575 ((:y-or-n-p thread tag question) 2576 (sly-remote-y-or-n-p thread tag question)) 2577 ((:emacs-return-string thread tag string) 2578 (sly-send `(:emacs-return-string ,thread ,tag ,string))) 2579 ((:new-features features) 2580 (setf (sly-lisp-features) features)) 2581 ((:indentation-update info) 2582 (sly-handle-indentation-update info)) 2583 ((:eval-no-wait form) 2584 (sly-check-eval-in-emacs-enabled) 2585 (eval (read form) t)) 2586 ((:eval thread tag form-string) 2587 (sly-check-eval-in-emacs-enabled) 2588 (sly-eval-for-lisp thread tag form-string)) 2589 ((:emacs-return thread tag value) 2590 (sly-send `(:emacs-return ,thread ,tag ,value))) 2591 ((:ed what) 2592 (sly-ed what)) 2593 ((:inspect what thread tag) 2594 (let ((hook (when (and thread tag) 2595 (sly-curry #'sly-send 2596 `(:emacs-return ,thread ,tag nil))))) 2597 (sly--open-inspector what :kill-hook hook :switch :raise))) 2598 ((:background-message message) 2599 (sly-temp-message 1 3 "[background-message] %s" message)) 2600 ((:debug-condition thread message) 2601 (cl-assert thread) 2602 (sly-message "[debug-condition] %s" message)) 2603 ((:ping thread tag) 2604 (sly-send `(:emacs-pong ,thread ,tag))) 2605 ((:reader-error packet condition) 2606 (sly-with-popup-buffer ((sly-buffer-name :error 2607 :connection sly-dispatching-connection)) 2608 (princ (format "Invalid protocol message:\n%s\n\n%s" 2609 condition packet)) 2610 (goto-char (point-min))) 2611 (error "Invalid protocol message")) 2612 ((:invalid-rpc id message) 2613 (setf (sly-rex-continuations) 2614 (cl-remove id (sly-rex-continuations) :key #'car)) 2615 (error "Invalid rpc: %s" message)) 2616 ((:emacs-skipped-packet _pkg)) 2617 ((:test-delay seconds) ; for testing only 2618 (sit-for seconds)) 2619 ((:channel-send id msg) 2620 (sly-channel-send (or (sly-find-channel id) 2621 (error "Invalid channel id: %S %S" id msg)) 2622 msg)) 2623 ((:emacs-channel-send id msg) 2624 (sly-send `(:emacs-channel-send ,id ,msg))) 2625 ((:invalid-channel channel-id reason) 2626 (error "Invalid remote channel %s: %s" channel-id reason)))))) 2627 2628(defvar sly--send-last-command nil 2629 "Value of `this-command' at time of last `sly-send' call.") 2630 2631(defun sly-send (sexp) 2632 "Send SEXP directly over the wire on the current connection." 2633 (setq sly--send-last-command this-command) 2634 (sly-net-send sexp (sly-connection))) 2635 2636(defun sly-reset () 2637 "Clear all pending continuations and erase connection buffer." 2638 (interactive) 2639 (setf (sly-rex-continuations) '()) 2640 (mapc #'kill-buffer (sly-db-buffers)) 2641 (sly-with-connection-buffer () 2642 (erase-buffer))) 2643 2644(defun sly-send-sigint () 2645 (interactive) 2646 (signal-process (sly-pid) 'SIGINT)) 2647 2648;;;;; Channels 2649 2650;;; A channel implements a set of operations. Those operations can be 2651;;; invoked by sending messages to the channel. Channels are used for 2652;;; protocols which can't be expressed naturally with RPCs, e.g. for 2653;;; streaming data over the wire. 2654;;; 2655;;; A channel can be "remote" or "local". Remote channels are 2656;;; represented by integers. Local channels are structures. Messages 2657;;; sent to a closed (remote) channel are ignored. 2658 2659(sly-def-connection-var sly-channels '() 2660 "Alist of the form (ID . CHANNEL).") 2661 2662(sly-def-connection-var sly-channels-counter 0 2663 "Channel serial number counter.") 2664 2665(cl-defstruct (sly-channel (:conc-name sly-channel.) 2666 (:constructor 2667 sly-make-channel% (operations name id plist))) 2668 operations name id plist) 2669 2670(defun sly-make-channel (operations &optional name) 2671 (let* ((id (cl-incf (sly-channels-counter))) 2672 (ch (sly-make-channel% operations name id nil))) 2673 (push (cons id ch) (sly-channels)) 2674 ch)) 2675 2676(defun sly-close-channel (channel) 2677 (setf (sly-channel.operations channel) 'closed-channel) 2678 (let ((probe (assq (sly-channel.id channel) 2679 (and (sly-current-connection) 2680 (sly-channels))))) 2681 (cond (probe (setf (sly-channels) (delete probe (sly-channels)))) 2682 (t (error "Can't close invalid channel: %s" channel))))) 2683 2684(defun sly-find-channel (id) 2685 (cdr (assq id (sly-channels)))) 2686 2687(defun sly-channel-send (channel message) 2688 (apply (or (gethash (car message) (sly-channel.operations channel)) 2689 (error "Unsupported operation %S for channel %d" 2690 (car message) 2691 (sly-channel.id channel))) 2692 channel (cdr message))) 2693 2694(defun sly-channel-put (channel prop value) 2695 (setf (sly-channel.plist channel) 2696 (plist-put (sly-channel.plist channel) prop value))) 2697 2698(defun sly-channel-get (channel prop) 2699 (plist-get (sly-channel.plist channel) prop)) 2700 2701(eval-and-compile 2702 (defun sly-channel-method-table-name (type) 2703 (intern (format "sly-%s-channel-methods" type)))) 2704 2705(defmacro sly-define-channel-type (name) 2706 (declare (indent defun)) 2707 (let ((tab (sly-channel-method-table-name name))) 2708 `(defvar ,tab (make-hash-table :size 10)))) 2709 2710(defmacro sly-define-channel-method (type method args &rest body) 2711 (declare (indent 3) (debug (&define sexp name lambda-list 2712 def-body))) 2713 `(puthash ',method 2714 (lambda (self . ,args) ,@body) 2715 ,(sly-channel-method-table-name type))) 2716 2717(defun sly-send-to-remote-channel (channel-id msg) 2718 (sly-dispatch-event `(:emacs-channel-send ,channel-id ,msg))) 2719 2720;;;;; Event logging to *sly-events* 2721;;; 2722;;; The *sly-events* buffer logs all protocol messages for debugging 2723;;; purposes. 2724 2725(defvar sly-log-events t 2726 "*Log protocol events to the *sly-events* buffer.") 2727 2728(defun sly-log-event (event process) 2729 "Record the fact that EVENT occurred in PROCESS." 2730 (when sly-log-events 2731 (with-current-buffer (sly--events-buffer process) 2732 ;; trim? 2733 (when (> (buffer-size) 100000) 2734 (goto-char (/ (buffer-size) 2)) 2735 (re-search-forward "^(" nil t) 2736 (delete-region (point-min) (point))) 2737 (goto-char (point-max)) 2738 (unless (bolp) (insert "\n")) 2739 (cond ((and (stringp event) 2740 (string-match "^;" event)) 2741 (insert-before-markers event)) 2742 (t 2743 (save-excursion 2744 (sly-pprint-event event (current-buffer))))) 2745 (goto-char (point-max))))) 2746 2747(defun sly-pprint-event (event buffer) 2748 "Pretty print EVENT in BUFFER with limited depth and width." 2749 (let ((print-length 20) 2750 (print-level 6) 2751 (pp-escape-newlines t)) 2752 ;; HACK workaround for gh#183 2753 (condition-case _oops (pp event buffer) (error (print event buffer))))) 2754 2755(defun sly--events-buffer (process) 2756 "Return or create the event log buffer." 2757 (let* ((probe (process-get process 'sly--events-buffer)) 2758 (buffer (or (and (buffer-live-p probe) 2759 probe) 2760 (let ((buffer (get-buffer-create 2761 (apply #'sly-buffer-name 2762 :events 2763 (if (sly-connection-name process) 2764 `(:connection ,process) 2765 `(:suffix ,(format "%s" process))))))) 2766 (with-current-buffer buffer 2767 (buffer-disable-undo) 2768 (when (fboundp 'lisp-data-mode) ; Emacs >= 28 only 2769 (funcall 'lisp-data-mode)) 2770 (set (make-local-variable 'sly-buffer-connection) process) 2771 (sly-mode 1)) 2772 (process-put process 'sly--events-buffer buffer) 2773 buffer)))) 2774 buffer)) 2775 2776(defun sly-pop-to-events-buffer (process) 2777 "Pop to the SLY events buffer for PROCESS" 2778 (interactive (list (sly-current-connection))) 2779 (pop-to-buffer (sly--events-buffer process))) 2780 2781(defun sly-switch-to-most-recent (mode) 2782 "Switch to most recent buffer in MODE, a major-mode symbol. 2783With prefix argument, prompt for MODE" 2784 (interactive 2785 (list (if current-prefix-arg 2786 (intern (sly-completing-read 2787 "Switch to most recent buffer in what mode? " 2788 (mapcar #'symbol-name '(lisp-mode 2789 emacs-lisp-mode)) 2790 nil t)) 2791 'lisp-mode))) 2792 (cl-loop for buffer in (buffer-list) 2793 when (and (with-current-buffer buffer (eq major-mode mode)) 2794 (not (eq buffer (current-buffer))) 2795 (not (string-match "^ " (buffer-name buffer)))) 2796 do (pop-to-buffer buffer) and return buffer)) 2797 2798(defun sly-forget-pending-events (process) 2799 "Forget any outgoing events for the PROCESS" 2800 (interactive (list (sly-current-connection))) 2801 (setf (sly-rex-continuations process) nil)) 2802 2803 2804;;;;; Cleanup after a quit 2805 2806(defun sly-restart-inferior-lisp () 2807 "Kill and restart the Lisp subprocess." 2808 (interactive) 2809 (cl-assert (sly-inferior-process) () "No inferior lisp process") 2810 (sly-quit-lisp-internal (sly-connection) 'sly-restart-sentinel t)) 2811 2812(defun sly-restart-sentinel (connection _message) 2813 "When CONNECTION dies, start a similar inferior lisp process. 2814Also rearrange windows." 2815 (cl-assert (process-status connection) 'closed) 2816 (let* ((moribund-proc (sly-inferior-process connection)) 2817 (args (sly-inferior-lisp-args moribund-proc)) 2818 (buffer (buffer-name (process-buffer moribund-proc)))) 2819 (sly-net-close connection "Restarting inferior lisp process") 2820 (sly-inferior-connect (sly-start-lisp (plist-get args :program) 2821 (plist-get args :program-args) 2822 (plist-get args :env) 2823 nil 2824 buffer) 2825 args))) 2826 2827 2828;;;; Compilation and the creation of compiler-note annotations 2829 2830(defvar sly-highlight-compiler-notes t 2831 "*When non-nil annotate buffers with compilation notes etc.") 2832 2833(defcustom sly-compilation-finished-hook '(sly-maybe-show-compilation-log) 2834 "Hook called after compilation. 2835Each function is called with four arguments (SUCCESSP NOTES BUFFER LOADP) 2836SUCCESSP indicates if the compilation was successful. 2837NOTES is a list of compilation notes. 2838BUFFER is the buffer just compiled, or nil if a string was compiled. 2839LOADP is the value of the LOAD flag passed to `sly-compile-file', or t 2840if a string." 2841 :group 'sly-mode 2842 :type 'hook 2843 :options '(sly-maybe-show-compilation-log 2844 sly-show-compilation-log 2845 sly-maybe-show-xrefs-for-notes 2846 sly-goto-first-note)) 2847 2848;; FIXME: I doubt that anybody uses this directly and it seems to be 2849;; only an ugly way to pass arguments. 2850(defvar sly-compilation-policy nil 2851 "When non-nil compile with these optimization settings.") 2852 2853(defun sly-compute-policy (arg) 2854 "Return the policy for the prefix argument ARG." 2855 (let ((between (lambda (min n max) 2856 (cond ((< n min) min) 2857 ((> n max) max) 2858 (t n))))) 2859 (let ((n (prefix-numeric-value arg))) 2860 (cond ((not arg) sly-compilation-policy) 2861 ((cl-plusp n) `((cl:debug . ,(funcall between 0 n 3)))) 2862 ((eq arg '-) `((cl:speed . 3))) 2863 (t `((cl:speed . ,(funcall between 0 (abs n) 3)))))))) 2864 2865(cl-defstruct (sly-compilation-result 2866 (:type list) 2867 (:conc-name sly-compilation-result.) 2868 (:constructor nil) 2869 (:copier nil)) 2870 tag notes successp duration loadp faslfile) 2871 2872(defvar sly-last-compilation-result nil 2873 "The result of the most recently issued compilation.") 2874 2875(defun sly-compiler-notes () 2876 "Return all compiler notes, warnings, and errors." 2877 (sly-compilation-result.notes sly-last-compilation-result)) 2878 2879(defun sly-compile-and-load-file (&optional policy) 2880 "Compile and load the buffer's file and highlight compiler notes. 2881 2882With (positive) prefix argument the file is compiled with maximal 2883debug settings (`C-u'). With negative prefix argument it is compiled for 2884speed (`M--'). If a numeric argument is passed set debug or speed settings 2885to it depending on its sign. 2886 2887Each source location that is the subject of a compiler note is 2888underlined and annotated with the relevant information. The commands 2889`sly-next-note' and `sly-previous-note' can be used to navigate 2890between compiler notes and to display their full details." 2891 (interactive "P") 2892 (sly-compile-file t (sly-compute-policy policy))) 2893 2894(defcustom sly-compile-file-options '() 2895 "Plist of additional options that C-c C-k should pass to Lisp. 2896Currently only :fasl-directory is supported." 2897 :group 'sly-lisp 2898 :type '(plist :key-type symbol :value-type (file :must-match t))) 2899 2900(defun sly-compile-file (&optional load policy) 2901 "Compile current buffer's file and highlight resulting compiler notes. 2902 2903See `sly-compile-and-load-file' for further details." 2904 (interactive) 2905 (unless buffer-file-name 2906 (error "Buffer %s is not associated with a file." (buffer-name))) 2907 (check-parens) 2908 (when (and (buffer-modified-p) 2909 (or (not compilation-ask-about-save) 2910 (sly-y-or-n-p (format "Save file %s? " (buffer-file-name))))) 2911 (save-buffer)) 2912 (let ((file (sly-to-lisp-filename (buffer-file-name))) 2913 (options (sly-simplify-plist `(,@sly-compile-file-options 2914 :policy ,policy)))) 2915 (sly-eval-async 2916 `(slynk:compile-file-for-emacs ,file ,(if load t nil) 2917 . ,(sly-hack-quotes options)) 2918 #'(lambda (result) 2919 (sly-compilation-finished result (current-buffer)))) 2920 (sly-message "Compiling %s..." file))) 2921 2922(defun sly-hack-quotes (arglist) 2923 ;; eval is the wrong primitive, we really want funcall 2924 (cl-loop for arg in arglist collect `(quote ,arg))) 2925 2926(defun sly-simplify-plist (plist) 2927 (cl-loop for (key val) on plist by #'cddr 2928 append (cond ((null val) '()) 2929 (t (list key val))))) 2930 2931(defun sly-compile-defun (&optional raw-prefix-arg) 2932 "Compile the current toplevel form. 2933 2934With (positive) prefix argument the form is compiled with maximal 2935debug settings (`C-u'). With negative prefix argument it is compiled for 2936speed (`M--'). If a numeric argument is passed set debug or speed settings 2937to it depending on its sign." 2938 (interactive "P") 2939 (let ((sly-compilation-policy (sly-compute-policy raw-prefix-arg))) 2940 (if (use-region-p) 2941 (sly-compile-region (region-beginning) (region-end)) 2942 (apply #'sly-compile-region (sly-region-for-defun-at-point))))) 2943 2944(defvar sly-compile-region-function 'sly-compile-region-as-string 2945 "Function called by `sly-compile-region' to do actual work.") 2946 2947(defun sly-compile-region (start end) 2948 "Compile the region." 2949 (interactive "r") 2950 ;; Check connection before running hooks things like 2951 ;; sly-flash-region don't make much sense if there's no connection 2952 (sly-connection) 2953 (funcall sly-compile-region-function start end)) 2954 2955(defun sly-compile-region-as-string (start end) 2956 (sly-flash-region start end) 2957 (sly-compile-string (buffer-substring-no-properties start end) start)) 2958 2959(defun sly-compile-string (string start-offset) 2960 (let* ((position (sly-compilation-position start-offset))) 2961 (sly-eval-async 2962 `(slynk:compile-string-for-emacs 2963 ,string 2964 ,(buffer-name) 2965 ',position 2966 ,(if (buffer-file-name) (sly-to-lisp-filename (buffer-file-name))) 2967 ',sly-compilation-policy) 2968 #'(lambda (result) 2969 (sly-compilation-finished result nil))))) 2970 2971(defun sly-compilation-position (start-offset) 2972 (let ((line (save-excursion 2973 (goto-char start-offset) 2974 (list (line-number-at-pos) (1+ (current-column)))))) 2975 `((:position ,start-offset) (:line ,@line)))) 2976 2977(defcustom sly-load-failed-fasl 'never 2978 "Which action to take when COMPILE-FILE set FAILURE-P to T. 2979NEVER doesn't load the fasl 2980ALWAYS loads the fasl 2981ASK asks the user." 2982 :type '(choice (const never) 2983 (const always) 2984 (const ask))) 2985 2986(defun sly-load-failed-fasl-p () 2987 (cl-ecase sly-load-failed-fasl 2988 (never nil) 2989 (always t) 2990 (ask (sly-y-or-n-p "Compilation failed. Load fasl file anyway? ")))) 2991 2992(defun sly-compilation-finished (result buffer &optional message) 2993 (let ((notes (sly-compilation-result.notes result)) 2994 (duration (sly-compilation-result.duration result)) 2995 (successp (sly-compilation-result.successp result)) 2996 (faslfile (sly-compilation-result.faslfile result)) 2997 (loadp (sly-compilation-result.loadp result))) 2998 (setf sly-last-compilation-result result) 2999 (sly-show-note-counts notes duration (cond ((not loadp) successp) 3000 (t (and faslfile successp))) 3001 (or (not buffer) loadp) 3002 message) 3003 (when sly-highlight-compiler-notes 3004 (sly-highlight-notes notes)) 3005 (when (and loadp faslfile 3006 (or successp 3007 (sly-load-failed-fasl-p))) 3008 (sly-eval-async `(slynk:load-file ,faslfile))) 3009 (run-hook-with-args 'sly-compilation-finished-hook successp notes buffer loadp))) 3010 3011(defun sly-show-note-counts (notes secs successp loadp &optional message) 3012 (sly-message (concat 3013 (cond ((and successp loadp) 3014 "Compiled and loaded") 3015 (successp "Compilation finished") 3016 (t (sly-add-face 'font-lock-warning-face 3017 "Compilation failed"))) 3018 (if (null notes) ". (No warnings)" ": ") 3019 (mapconcat 3020 (lambda (msgs) 3021 (cl-destructuring-bind (sev . notes) msgs 3022 (let ((len (length notes))) 3023 (format "%d %s%s" len (sly-severity-label sev) 3024 (if (= len 1) "" "s"))))) 3025 (sort (sly-alistify notes #'sly-note.severity #'eq) 3026 (lambda (x y) (sly-severity< (car y) (car x)))) 3027 " ") 3028 (if secs (format " [%.2f secs]" secs)) 3029 message))) 3030 3031(defun sly-highlight-notes (notes) 3032 "Highlight compiler notes, warnings, and errors in the buffer." 3033 (interactive (list (sly-compiler-notes))) 3034 (with-temp-message "Highlighting notes..." 3035 (save-excursion 3036 (save-restriction 3037 (widen) ; highlight notes on the whole buffer 3038 (sly-remove-notes (point-min) (point-max)) 3039 (mapc #'sly--add-in-buffer-note notes))))) 3040 3041 3042;;;;; Recompilation. 3043 3044;; FIXME: This whole idea is questionable since it depends so 3045;; crucially on precise source-locs. 3046 3047(defun sly-recompile-location (location) 3048 (save-excursion 3049 (sly-move-to-source-location location) 3050 (sly-compile-defun))) 3051 3052(defun sly-recompile-locations (locations cont) 3053 (sly-eval-async 3054 `(slynk:compile-multiple-strings-for-emacs 3055 ',(cl-loop for loc in locations collect 3056 (save-excursion 3057 (sly-move-to-source-location loc) 3058 (cl-destructuring-bind (start end) 3059 (sly-region-for-defun-at-point) 3060 (list (buffer-substring-no-properties start end) 3061 (buffer-name) 3062 (sly-current-package) 3063 start 3064 (if (buffer-file-name) 3065 (sly-to-lisp-filename (buffer-file-name)) 3066 nil))))) 3067 ',sly-compilation-policy) 3068 cont)) 3069 3070 3071;;;;; Compiler notes list 3072 3073(defun sly-one-line-ify (string) 3074 "Return a single-line version of STRING. 3075Each newlines and following indentation is replaced by a single space." 3076 (with-temp-buffer 3077 (insert string) 3078 (goto-char (point-min)) 3079 (while (re-search-forward "\n[\n \t]*" nil t) 3080 (replace-match " ")) 3081 (buffer-string))) 3082 3083(defun sly-xref--get-xrefs-for-notes (notes) 3084 (let ((xrefs)) 3085 (dolist (note notes) 3086 (let* ((location (cl-getf note :location)) 3087 (fn (cadr (assq :file (cdr location)))) 3088 (file (assoc fn xrefs)) 3089 (node 3090 (list (format "%s: %s" 3091 (cl-getf note :severity) 3092 (sly-one-line-ify (cl-getf note :message))) 3093 location))) 3094 (when fn 3095 (if file 3096 (push node (cdr file)) 3097 (setf xrefs (cl-acons fn (list node) xrefs)))))) 3098 xrefs)) 3099 3100(defun sly-maybe-show-xrefs-for-notes (_successp notes _buffer _loadp) 3101 "Show the compiler notes NOTES if they come from more than one file." 3102 (let ((xrefs (sly-xref--get-xrefs-for-notes notes))) 3103 (when (cdr xrefs) ; >1 file 3104 (sly-xref--show-results 3105 xrefs 'definition "Compiler notes" (sly-current-package))))) 3106 3107(defun sly-maybe-show-compilation-log (successp notes buffer loadp) 3108 "Display the log on failed compilations or if NOTES is non-nil." 3109 (sly-show-compilation-log successp notes buffer loadp 3110 (if successp :hidden nil))) 3111 3112(defun sly-show-compilation-log (successp notes buffer loadp &optional select) 3113 "Create and display the compilation log buffer." 3114 (interactive (list (sly-compiler-notes))) 3115 (sly-with-popup-buffer ((sly-buffer-name :compilation) 3116 :mode 'compilation-mode 3117 :select select) 3118 (sly--insert-compilation-log successp notes buffer loadp) 3119 (insert "Compilation " 3120 (if successp "successful" "failed") 3121 "."))) 3122 3123(defvar sly-compilation-log--notes (make-hash-table) 3124 "Hash-table (NOTE -> (BUFFER POSITION)) for finding notes in 3125 the SLY compilation log") 3126 3127(defun sly--insert-compilation-log (_successp notes _buffer _loadp) 3128 "Insert NOTES in format suitable for `compilation-mode'." 3129 (clrhash sly-compilation-log--notes) 3130 (cl-multiple-value-bind (grouped-notes canonicalized-locs-table) 3131 (sly-group-and-sort-notes notes) 3132 (with-temp-message "Preparing compilation log..." 3133 (let ((inhibit-read-only t) 3134 (inhibit-modification-hooks t)) ; inefficient font-lock-hook 3135 (insert (format "cd %s\n%d compiler notes:\n\n" 3136 default-directory (length notes))) 3137 (cl-loop for notes in grouped-notes 3138 for loc = (gethash (cl-first notes) canonicalized-locs-table) 3139 for start = (point) 3140 do 3141 (cl-loop for note in notes 3142 do (puthash note 3143 (cons (current-buffer) start) 3144 sly-compilation-log--notes)) 3145 (insert 3146 (sly--compilation-note-group-button 3147 (sly-canonicalized-location-to-string loc) notes) 3148 ":") 3149 (sly-insert-note-group notes) 3150 (insert "\n") 3151 (add-text-properties start (point) `(field ,notes)))) 3152 (set (make-local-variable 'compilation-skip-threshold) 0) 3153 (setq next-error-last-buffer (current-buffer))))) 3154 3155(defun sly-insert-note-group (notes) 3156 "Insert a group of compiler messages." 3157 (insert "\n") 3158 (dolist (note notes) 3159 (insert " " (sly-severity-label (sly-note.severity note)) ": ") 3160 (let ((start (point))) 3161 (insert (sly-note.message note)) 3162 (let ((ctx (sly-note.source-context note))) 3163 (if ctx (insert "\n" ctx))) 3164 (sly-indent-block start 4)) 3165 (insert "\n"))) 3166 3167(defun sly-indent-block (start column) 3168 "If the region back to START isn't a one-liner indent it." 3169 (when (< start (line-beginning-position)) 3170 (save-excursion 3171 (goto-char start) 3172 (insert "\n")) 3173 (sly-indent-rigidly start (point) column))) 3174 3175(defun sly-canonicalized-location (location) 3176 "Return a list (FILE LINE COLUMN) for sly-location LOCATION. 3177This is quite an expensive operation so use carefully." 3178 (save-excursion 3179 (sly-goto-location-buffer (sly-location.buffer location)) 3180 (save-excursion 3181 (sly-move-to-source-location location) 3182 (list (or (buffer-file-name) (buffer-name)) 3183 (save-restriction 3184 (widen) 3185 (line-number-at-pos)) 3186 (1+ (current-column)))))) 3187 3188(defun sly-canonicalized-location-to-string (loc) 3189 (if loc 3190 (cl-destructuring-bind (filename line col) loc 3191 (format "%s:%d:%d" 3192 (cond ((not filename) "") 3193 ((let ((rel (file-relative-name filename))) 3194 (if (< (length rel) (length filename)) 3195 rel))) 3196 (t filename)) 3197 line col)) 3198 (format "Unknown location"))) 3199 3200(defun sly-group-and-sort-notes (notes) 3201 "First sort, then group NOTES according to their canonicalized locs." 3202 (let ((locs (make-hash-table :test #'eq))) 3203 (mapc (lambda (note) 3204 (let ((loc (sly-note.location note))) 3205 (when (sly-location-p loc) 3206 (puthash note (sly-canonicalized-location loc) locs)))) 3207 notes) 3208 (cl-values (sly-group-similar 3209 (lambda (n1 n2) 3210 (equal (gethash n1 locs nil) (gethash n2 locs t))) 3211 (let* ((bottom most-negative-fixnum) 3212 (+default+ (list "" bottom bottom))) 3213 (sort notes 3214 (lambda (n1 n2) 3215 (cl-destructuring-bind (filename1 line1 col1) 3216 (gethash n1 locs +default+) 3217 (cl-destructuring-bind (filename2 line2 col2) 3218 (gethash n2 locs +default+) 3219 (cond ((string-lessp filename1 filename2) t) 3220 ((string-lessp filename2 filename1) nil) 3221 ((< line1 line2) t) 3222 ((> line1 line2) nil) 3223 (t (< col1 col2))))))))) 3224 locs))) 3225 3226(defun sly-note.severity (note) 3227 (plist-get note :severity)) 3228 3229(defun sly-note.message (note) 3230 (plist-get note :message)) 3231 3232(defun sly-note.source-context (note) 3233 (plist-get note :source-context)) 3234 3235(defun sly-note.location (note) 3236 (plist-get note :location)) 3237 3238(defun sly-severity-label (severity) 3239 (cl-subseq (symbol-name severity) 1)) 3240 3241 3242 3243;;;;; Adding a single compiler note 3244;;;;; 3245(defun sly-choose-overlay-region (note) 3246 "Choose the start and end points for an overlay over NOTE. 3247If the location's sexp is a list spanning multiple lines, then the 3248region around the first element is used. 3249Return nil if there's no useful source location." 3250 (let ((location (sly-note.location note))) 3251 (when location 3252 (sly-dcase location 3253 ((:error _)) ; do nothing 3254 ((:location file pos _hints) 3255 (cond ((eq (car file) ':source-form) nil) 3256 ((eq (sly-note.severity note) :read-error) 3257 (sly-choose-overlay-for-read-error location)) 3258 ((equal pos '(:eof)) 3259 (list (1- (point-max)) (point-max))) 3260 (t 3261 (sly-choose-overlay-for-sexp location)))))))) 3262 3263(defun sly-choose-overlay-for-read-error (location) 3264 (let ((pos (sly-location-offset location))) 3265 (save-excursion 3266 (goto-char pos) 3267 (cond ((sly-symbol-at-point) 3268 ;; package not found, &c. 3269 (list (sly-symbol-start-pos) (sly-symbol-end-pos))) 3270 (t 3271 (list pos (1+ pos))))))) 3272 3273(defun sly-choose-overlay-for-sexp (location) 3274 (sly-move-to-source-location location) 3275 (skip-chars-forward "'#`") 3276 (let ((start (point))) 3277 (ignore-errors (sly-forward-sexp)) 3278 (if (sly-same-line-p start (point)) 3279 (list start (point)) 3280 (list (1+ start) 3281 (progn (goto-char (1+ start)) 3282 (ignore-errors (forward-sexp 1)) 3283 (point)))))) 3284(defun sly-same-line-p (pos1 pos2) 3285 "Return t if buffer positions POS1 and POS2 are on the same line." 3286 (save-excursion (goto-char (min pos1 pos2)) 3287 (<= (max pos1 pos2) (line-end-position)))) 3288 3289(defvar sly-severity-face-plist 3290 (list :error 'sly-error-face 3291 :read-error 'sly-error-face 3292 :warning 'sly-warning-face 3293 :redefinition 'sly-style-warning-face 3294 :style-warning 'sly-style-warning-face 3295 :note 'sly-note-face)) 3296 3297(defun sly-severity-face (severity) 3298 "Return the name of the font-lock face representing SEVERITY." 3299 (or (plist-get sly-severity-face-plist severity) 3300 (error "No face for: %S" severity))) 3301 3302(defvar sly-severity-order 3303 '(:note :style-warning :redefinition :warning :error :read-error)) 3304 3305(defun sly-severity< (sev1 sev2) 3306 "Return true if SEV1 is less severe than SEV2." 3307 (< (cl-position sev1 sly-severity-order) 3308 (cl-position sev2 sly-severity-order))) 3309 3310(defun sly-forward-positioned-source-path (source-path) 3311 "Move forward through a sourcepath from a fixed position. 3312The point is assumed to already be at the outermost sexp, making the 3313first element of the source-path redundant." 3314 (ignore-errors 3315 (sly-forward-sexp) 3316 (beginning-of-defun)) 3317 (sly--when-let (source-path (cdr source-path)) 3318 (down-list 1) 3319 (sly-forward-source-path source-path))) 3320 3321(defun sly-forward-source-path (source-path) 3322 (let ((origin (point))) 3323 (condition-case nil 3324 (progn 3325 (cl-loop for (count . more) on source-path 3326 do (progn 3327 (sly-forward-sexp count) 3328 (when more (down-list 1)))) 3329 ;; Align at beginning 3330 (sly-forward-sexp) 3331 (beginning-of-sexp)) 3332 (error (goto-char origin))))) 3333 3334 3335;; FIXME: really fix this mess 3336;; FIXME: the check shouln't be done here anyway but by M-. itself. 3337 3338(defun sly-filesystem-toplevel-directory () 3339 ;; Windows doesn't have a true toplevel root directory, and all 3340 ;; filenames look like "c:/foo/bar/quux.baz" from an Emacs 3341 ;; perspective anyway. 3342 (if (memq system-type '(ms-dos windows-nt)) 3343 "" 3344 (file-name-as-directory "/"))) 3345 3346(defun sly-file-name-merge-source-root (target-filename buffer-filename) 3347 "Returns a filename where the source root directory of TARGET-FILENAME 3348is replaced with the source root directory of BUFFER-FILENAME. 3349 3350If no common source root could be determined, return NIL. 3351 3352E.g. (sly-file-name-merge-source-root 3353 \"/usr/local/src/joe/upstream/sbcl/code/late-extensions.lisp\" 3354 \"/usr/local/src/joe/hacked/sbcl/compiler/deftype.lisp\") 3355 3356 ==> \"/usr/local/src/joe/hacked/sbcl/code/late-extensions.lisp\" 3357" 3358 (let ((target-dirs (split-string (file-name-directory target-filename) 3359 "/" t)) 3360 (buffer-dirs (split-string (file-name-directory buffer-filename) 3361 "/" t))) 3362 ;; Starting from the end, we look if one of the TARGET-DIRS exists 3363 ;; in BUFFER-FILENAME---if so, it and everything left from that dirname 3364 ;; is considered to be the source root directory of BUFFER-FILENAME. 3365 (cl-loop with target-suffix-dirs = nil 3366 with buffer-dirs* = (reverse buffer-dirs) 3367 with target-dirs* = (reverse target-dirs) 3368 for target-dir in target-dirs* 3369 do (let ((concat-dirs (lambda (dirs) 3370 (apply #'concat 3371 (mapcar #'file-name-as-directory 3372 dirs)))) 3373 (pos (cl-position target-dir buffer-dirs* 3374 :test #'equal))) 3375 (if (not pos) ; TARGET-DIR not in BUFFER-FILENAME? 3376 (push target-dir target-suffix-dirs) 3377 (let* ((target-suffix 3378 ; PUSH reversed for us! 3379 (funcall concat-dirs target-suffix-dirs)) 3380 (buffer-root 3381 (funcall concat-dirs 3382 (reverse (nthcdr pos buffer-dirs*))))) 3383 (cl-return (concat (sly-filesystem-toplevel-directory) 3384 buffer-root 3385 target-suffix 3386 (file-name-nondirectory 3387 target-filename))))))))) 3388 3389(defun sly-highlight-differences-in-dirname (base-dirname contrast-dirname) 3390 "Returns a copy of BASE-DIRNAME where all differences between 3391BASE-DIRNAME and CONTRAST-DIRNAME are propertized with a 3392highlighting face." 3393 (setq base-dirname (file-name-as-directory base-dirname)) 3394 (setq contrast-dirname (file-name-as-directory contrast-dirname)) 3395 (let ((base-dirs (split-string base-dirname "/" t)) 3396 (contrast-dirs (split-string contrast-dirname "/" t))) 3397 (with-temp-buffer 3398 (cl-loop initially (insert (sly-filesystem-toplevel-directory)) 3399 for base-dir in base-dirs do 3400 (let ((pos (cl-position base-dir contrast-dirs :test #'equal))) 3401 (cond ((not pos) 3402 (sly-insert-propertized '(face highlight) base-dir) 3403 (insert "/")) 3404 (t 3405 (insert (file-name-as-directory base-dir)) 3406 (setq contrast-dirs 3407 (nthcdr (1+ pos) contrast-dirs)))))) 3408 (buffer-substring (point-min) (point-max))))) 3409 3410(defvar sly-warn-when-possibly-tricked-by-M-. t 3411 "When working on multiple source trees simultaneously, the way 3412`sly-edit-definition' (M-.) works can sometimes be confusing: 3413 3414`M-.' visits locations that are present in the current Lisp image, 3415which works perfectly well as long as the image reflects the source 3416tree that one is currently looking at. 3417 3418In the other case, however, one can easily end up visiting a file 3419in a different source root directory (the one corresponding to 3420the Lisp image), and is thus easily tricked to modify the wrong 3421source files---which can lead to quite some stressfull cursing. 3422 3423If this variable is T, a warning message is issued to raise the 3424user's attention whenever `M-.' is about opening a file in a 3425different source root that also exists in the source root 3426directory of the user's current buffer. 3427 3428There's no guarantee that all possible cases are covered, but 3429if you encounter such a warning, it's a strong indication that 3430you should check twice before modifying.") 3431 3432(defun sly-maybe-warn-for-different-source-root (target-filename 3433 buffer-filename) 3434 (let ((guessed-target (sly-file-name-merge-source-root target-filename 3435 buffer-filename))) 3436 (when (and guessed-target 3437 (not (equal guessed-target target-filename)) 3438 (file-exists-p guessed-target)) 3439 (sly-message "Attention: This is `%s'." 3440 (concat (sly-highlight-differences-in-dirname 3441 (file-name-directory target-filename) 3442 (file-name-directory guessed-target)) 3443 (file-name-nondirectory target-filename)))))) 3444 3445(defun sly-check-location-filename-sanity (filename) 3446 (when sly-warn-when-possibly-tricked-by-M-. 3447 (cl-macrolet ((truename-safe (file) `(and ,file (file-truename ,file)))) 3448 (let ((target-filename (truename-safe filename)) 3449 (buffer-filename (truename-safe (buffer-file-name)))) 3450 (when (and target-filename 3451 buffer-filename) 3452 (sly-maybe-warn-for-different-source-root 3453 target-filename buffer-filename)))))) 3454 3455(defun sly-check-location-buffer-name-sanity (buffer-name) 3456 (sly-check-location-filename-sanity 3457 (buffer-file-name (get-buffer buffer-name)))) 3458 3459 3460 3461(defun sly-goto-location-buffer (buffer) 3462 (sly-dcase buffer 3463 ((:file filename) 3464 (let ((filename (sly-from-lisp-filename filename))) 3465 (sly-check-location-filename-sanity filename) 3466 (set-buffer (or (get-file-buffer filename) 3467 (let ((find-file-suppress-same-file-warnings t)) 3468 (find-file-noselect filename)))))) 3469 ((:buffer buffer-name) 3470 (sly-check-location-buffer-name-sanity buffer-name) 3471 (set-buffer buffer-name)) 3472 ((:buffer-and-file buffer filename) 3473 (sly-goto-location-buffer 3474 (if (get-buffer buffer) 3475 (list :buffer buffer) 3476 (list :file filename)))) 3477 ((:source-form string) 3478 (set-buffer (get-buffer-create (sly-buffer-name :source))) 3479 (erase-buffer) 3480 (lisp-mode) 3481 (insert string) 3482 (goto-char (point-min))) 3483 ((:zip file entry) 3484 (require 'arc-mode) 3485 (set-buffer (find-file-noselect file t)) 3486 (goto-char (point-min)) 3487 (re-search-forward (concat " " entry "$")) 3488 (let ((buffer (save-window-excursion 3489 (archive-extract) 3490 (current-buffer)))) 3491 (set-buffer buffer) 3492 (goto-char (point-min)))))) 3493 3494(defun sly-goto-location-position (position) 3495 (sly-dcase position 3496 ((:position pos) 3497 (goto-char 1) 3498 (forward-char (- (1- pos) (sly-eol-conversion-fixup (1- pos))))) 3499 ((:offset start offset) 3500 (goto-char start) 3501 (forward-char offset)) 3502 ((:line start &optional column) 3503 (goto-char (point-min)) 3504 (beginning-of-line start) 3505 (cond (column (move-to-column column)) 3506 (t (skip-chars-forward " \t")))) 3507 ((:function-name name) 3508 (let ((case-fold-search t) 3509 (name (regexp-quote name))) 3510 (goto-char (point-min)) 3511 (when (or 3512 (re-search-forward 3513 (format "\\s *(def\\(\\s_\\|\\sw\\)*\\s +(*%s\\S_" 3514 (regexp-quote name)) nil t) 3515 (re-search-forward 3516 (format "[( \t]%s\\>\\(\\s \\|$\\)" name) nil t)) 3517 (goto-char (match-beginning 0))))) 3518 ((:method name specializers &rest qualifiers) 3519 (sly-search-method-location name specializers qualifiers)) 3520 ((:source-path source-path start-position) 3521 (cond (start-position 3522 (goto-char start-position) 3523 (sly-forward-positioned-source-path source-path)) 3524 (t 3525 (sly-forward-source-path source-path)))) 3526 ((:eof) 3527 (goto-char (point-max))))) 3528 3529(defun sly-eol-conversion-fixup (n) 3530 ;; Return the number of \r\n eol markers that we need to cross when 3531 ;; moving N chars forward. N is the number of chars but \r\n are 3532 ;; counted as 2 separate chars. 3533 (if (zerop n) 0 3534 (cl-case (coding-system-eol-type buffer-file-coding-system) 3535 ((1) 3536 (save-excursion 3537 (cl-do ((pos (+ (point) n)) 3538 (count 0 (1+ count))) 3539 ((>= (point) pos) (1- count)) 3540 (forward-line) 3541 (cl-decf pos)))) 3542 (t 0)))) 3543 3544(defun sly-search-method-location (name specializers qualifiers) 3545 ;; Look for a sequence of words (def<something> method name 3546 ;; qualifers specializers don't look for "T" since it isn't requires 3547 ;; (arg without t) as class is taken as such. 3548 (let* ((case-fold-search t) 3549 (name (regexp-quote name)) 3550 (qualifiers (mapconcat (lambda (el) (concat ".+?\\<" el "\\>")) 3551 qualifiers "")) 3552 (specializers (mapconcat 3553 (lambda (el) 3554 (if (eql (aref el 0) ?\() 3555 (let ((spec (read el))) 3556 (if (eq (car spec) 'EQL) 3557 (concat 3558 ".*?\\n\\{0,1\\}.*?(EQL.*?'\\{0,1\\}" 3559 (format "%s" (cl-second spec)) ")") 3560 (error "don't understand specializer: %s,%s" 3561 el (car spec)))) 3562 (concat ".+?\n\\{0,1\\}.+?\\<" el "\\>"))) 3563 (remove "T" specializers) "")) 3564 (regexp (format "\\s *(def\\(\\s_\\|\\sw\\)*\\s +%s\\s +%s%s" name 3565 qualifiers specializers))) 3566 (or (and (re-search-forward regexp nil t) 3567 (goto-char (match-beginning 0))) 3568 ;; (sly-goto-location-position `(:function-name ,name)) 3569 ))) 3570 3571(defun sly-search-call-site (fname) 3572 "Move to the place where FNAME called. 3573Don't move if there are multiple or no calls in the current defun." 3574 (save-restriction 3575 (narrow-to-defun) 3576 (let ((start (point)) 3577 (regexp (concat "(" fname "[)\n \t]")) 3578 (case-fold-search t)) 3579 (cond ((and (re-search-forward regexp nil t) 3580 (not (re-search-forward regexp nil t))) 3581 (goto-char (match-beginning 0))) 3582 (t (goto-char start)))))) 3583 3584(defun sly-search-edit-path (edit-path) 3585 "Move to EDIT-PATH starting at the current toplevel form." 3586 (when edit-path 3587 (unless (and (= (current-column) 0) 3588 (looking-at "(")) 3589 (beginning-of-defun)) 3590 (sly-forward-source-path edit-path))) 3591 3592(defun sly-move-to-source-location (location &optional noerror) 3593 "Move to the source location LOCATION. 3594If NOERROR don't signal an error, but return nil. 3595 3596Several kinds of locations are supported: 3597 3598<location> ::= (:location <buffer> <position> <hints>) 3599 | (:error <message>) 3600 3601<buffer> ::= (:file <filename>) 3602 | (:buffer <buffername>) 3603 | (:buffer-and-file <buffername> <filename>) 3604 | (:source-form <string>) 3605 | (:zip <file> <entry>) 3606 3607<position> ::= (:position <fixnum>) ; 1 based (for files) 3608 | (:offset <start> <offset>) ; start+offset (for C-c C-c) 3609 | (:line <line> [<column>]) 3610 | (:function-name <string>) 3611 | (:source-path <list> <start-position>) 3612 | (:method <name string> <specializers> . <qualifiers>)" 3613 (sly-dcase location 3614 ((:location buffer _position _hints) 3615 (sly-goto-location-buffer buffer) 3616 (let ((pos (sly-location-offset location))) 3617 (cond ((and (<= (point-min) pos) (<= pos (point-max)))) 3618 (widen-automatically (widen)) 3619 (t 3620 (error "Location is outside accessible part of buffer"))) 3621 (goto-char pos))) 3622 ((:error message) 3623 (cond (noerror 3624 (sly-message "%s" message) 3625 nil) 3626 (t 3627 (error "%s" message)))))) 3628 3629(defun sly--highlight-sexp (&optional start end) 3630 "Highlight the first sexp after point." 3631 (let ((start (or start (point))) 3632 (end (or end (save-excursion (ignore-errors (forward-sexp)) (point))))) 3633 (sly-flash-region start end))) 3634 3635(defun sly--highlight-line (&optional timeout) 3636 (sly-flash-region (+ (line-beginning-position) (current-indentation)) 3637 (line-end-position) 3638 :timeout timeout)) 3639 3640(make-variable-buffer-local 3641 (defvar sly-xref--popup-method nil 3642 "Helper for `sly--display-source-location'")) 3643 3644(cl-defun sly--display-source-location (source-location 3645 &optional noerror (method 'window)) 3646 "Display SOURCE-LOCATION in a window according to METHOD. 3647Highlight the resulting sexp. Return the window or raise an 3648error, unless NOERROR is nil, in which case return nil. METHOD 3649specifies how to behave when a reference is selected in an xref 3650buffer. If one of symbols `window' or `frame' just 3651`display-buffer' accordingly. If nil, just switch to buffer in 3652current window. If a cons (WINDOW . METHOD) consider WINDOW the 3653\"starting window\" and reconsider METHOD like above: If it is 3654nil try to use WINDOW exclusively for showing the location, 3655otherwise prevent that window from being reused when popping to a 3656new window or frame." 3657 (cl-labels 3658 ((pop-it 3659 (target-buffer method) 3660 (cond ((eq method 'window) 3661 (display-buffer target-buffer t)) 3662 ((eq method 'frame) 3663 (let ((pop-up-frames t)) 3664 (display-buffer target-buffer t))) 3665 ((consp method) 3666 (let* ((window (car method)) 3667 (sub-method (cdr method))) 3668 (cond ((not (window-live-p window)) 3669 ;; the original window has been deleted: all 3670 ;; bets are off! 3671 ;; 3672 (pop-it target-buffer sub-method)) 3673 (sub-method 3674 ;; shield window from reuse, but restoring 3675 ;; any dedicatedness 3676 ;; 3677 (let ((dedicatedness (window-dedicated-p window))) 3678 (unwind-protect 3679 (progn 3680 ;; (set-window-dedicated-p window 'soft) 3681 ;; 3682 ;; jt@2018-01-27 commented the line 3683 ;; above because since the fix to 3684 ;; emacs' bug#28814 in Emacs 26.1 3685 ;; (which I myself authored), it won't 3686 ;; work correctly. Best to disable it 3687 ;; for now and eventually copy Emacs's 3688 ;; approach to xref buffers, or better 3689 ;; yet, reuse it. 3690 (pop-it target-buffer sub-method)) 3691 (set-window-dedicated-p window dedicatedness)))) 3692 (t 3693 ;; make efforts to reuse the window, respecting 3694 ;; any `display-buffer' overrides 3695 ;; 3696 (display-buffer 3697 target-buffer 3698 `(,(lambda (buffer _alist) 3699 (when (window-live-p window) 3700 (set-window-buffer window buffer) 3701 window)))))))) 3702 (t 3703 (switch-to-buffer target-buffer) 3704 (selected-window))))) 3705 (when (eq method 'sly-xref) 3706 (setq method sly-xref--popup-method)) 3707 (when (sly-move-to-source-location source-location noerror) 3708 (let ((pos (point))) 3709 (with-selected-window (pop-it (current-buffer) method) 3710 (goto-char pos) 3711 (recenter (if (= (current-column) 0) 1)) 3712 (sly--highlight-sexp) 3713 (selected-window)))))) 3714 3715(defun sly--pop-to-source-location (source-location &optional method) 3716 "Pop to SOURCE-LOCATION using METHOD. 3717If called from an xref buffer, method will be `sly-xref' and 3718thus also honour `sly-xref--popup-method'." 3719 (let* ((xref-window (selected-window)) 3720 (xref-buffer (window-buffer xref-window))) 3721 (when (eq method 'sly-xref) 3722 (quit-restore-window xref-window 'bury)) 3723 (with-current-buffer xref-buffer 3724 ;; now pop to target 3725 ;; 3726 (select-window 3727 (sly--display-source-location source-location nil method))) 3728 (set-buffer (window-buffer (selected-window))))) 3729 3730(defun sly-location-offset (location) 3731 "Return the position, as character number, of LOCATION." 3732 (save-restriction 3733 (widen) 3734 (condition-case nil 3735 (sly-goto-location-position 3736 (sly-location.position location)) 3737 (error (goto-char 0))) 3738 (let ((hints (sly-location.hints location))) 3739 (sly--when-let (snippet (cl-getf hints :snippet)) 3740 (sly-isearch snippet)) 3741 (sly--when-let (snippet (cl-getf hints :edit-path)) 3742 (sly-search-edit-path snippet)) 3743 (sly--when-let (fname (cl-getf hints :call-site)) 3744 (sly-search-call-site fname)) 3745 (when (cl-getf hints :align) 3746 (sly-forward-sexp) 3747 (beginning-of-sexp))) 3748 (point))) 3749 3750 3751;;;;; Incremental search 3752;; 3753;; Search for the longest match of a string in either direction. 3754;; 3755;; This is for locating text that is expected to be near the point and 3756;; may have been modified (but hopefully not near the beginning!) 3757 3758(defun sly-isearch (string) 3759 "Find the longest occurence of STRING either backwards of forwards. 3760If multiple matches exist the choose the one nearest to point." 3761 (goto-char 3762 (let* ((start (point)) 3763 (len1 (sly-isearch-with-function 'search-forward string)) 3764 (pos1 (point))) 3765 (goto-char start) 3766 (let* ((len2 (sly-isearch-with-function 'search-backward string)) 3767 (pos2 (point))) 3768 (cond ((and len1 len2) 3769 ;; Have a match in both directions 3770 (cond ((= len1 len2) 3771 ;; Both are full matches -- choose the nearest. 3772 (if (< (abs (- start pos1)) 3773 (abs (- start pos2))) 3774 pos1 pos2)) 3775 ((> len1 len2) pos1) 3776 ((> len2 len1) pos2))) 3777 (len1 pos1) 3778 (len2 pos2) 3779 (t start)))))) 3780 3781(defun sly-isearch-with-function (search-fn string) 3782 "Search for the longest substring of STRING using SEARCH-FN. 3783SEARCH-FN is either the symbol `search-forward' or `search-backward'." 3784 (unless (string= string "") 3785 (cl-loop for i from 1 to (length string) 3786 while (funcall search-fn (substring string 0 i) nil t) 3787 for match-data = (match-data) 3788 do (cl-case search-fn 3789 (search-forward (goto-char (match-beginning 0))) 3790 (search-backward (goto-char (1+ (match-end 0))))) 3791 finally (cl-return (if (null match-data) 3792 nil 3793 ;; Finish based on the last successful match 3794 (store-match-data match-data) 3795 (goto-char (match-beginning 0)) 3796 (- (match-end 0) (match-beginning 0))))))) 3797 3798 3799;;;;; Visiting and navigating the overlays of compiler notes 3800(defun sly-note-button-p (button) 3801 (eq (button-type button) 'sly-in-buffer-note)) 3802 3803(defalias 'sly-next-note 'sly-button-forward) 3804(defalias 'sly-previous-note 'sly-button-backward) 3805 3806(put 'sly-next-note 'sly-button-navigation-command t) 3807(put 'sly-previous-note 'sly-button-navigation-command t) 3808 3809(defun sly-goto-first-note (_successp notes _buffer _loadp) 3810 "Go to the first note in the buffer." 3811 (interactive (list (sly-compiler-notes))) 3812 (when notes 3813 (goto-char (point-min)) 3814 (sly-next-note 1))) 3815 3816(defun sly-remove-notes (beg end) 3817 "Remove `sly-note' annotation buttons from BEG to END." 3818 (interactive (if (region-active-p) 3819 (list (region-beginning) (region-end)) 3820 (list (point-min) (point-max)))) 3821 (cl-loop for existing in (overlays-in beg end) 3822 when (sly-note-button-p existing) 3823 do (delete-overlay existing))) 3824 3825(defun sly-show-notes (button &rest more-buttons) 3826 "Present the details of a compiler note to the user." 3827 (interactive) 3828 (let ((notes (mapcar (sly-rcurry #'button-get 'sly-note) 3829 (cons button more-buttons)))) 3830 (sly-button-flash button :face (let ((color (face-underline-p (button-get button 'face)))) 3831 (if color `(:background ,color) 'highlight))) 3832 ;; If the compilation window is showing, try to land in a suitable 3833 ;; place there, too... 3834 ;; 3835 (let* ((anchor (car notes)) 3836 (compilation-buffer (sly-buffer-name :compilation)) 3837 (compilation-window (get-buffer-window compilation-buffer t))) 3838 (if compilation-window 3839 (with-current-buffer compilation-buffer 3840 (with-selected-window compilation-window 3841 (let ((buffer-and-pos (gethash anchor 3842 sly-compilation-log--notes))) 3843 (when buffer-and-pos 3844 (cl-assert (eq (car buffer-and-pos) (current-buffer))) 3845 (goto-char (cdr buffer-and-pos)) 3846 (let ((field-end (field-end (1+ (point))))) 3847 (sly-flash-region (point) field-end) 3848 (sly-recenter field-end)))) 3849 (sly-message "Showing note in %s" (current-buffer)))) 3850 ;; Else, do the next best thing, which is echo the messages. 3851 ;; 3852 (if (cdr notes) 3853 (sly-message "%s notes:\n%s" 3854 (length notes) 3855 (mapconcat #'sly-note.message notes "\n")) 3856 (sly-message "%s" (sly-note.message (car notes)))))))) 3857 3858(define-button-type 'sly-note :supertype 'sly-button) 3859 3860(define-button-type 'sly-in-buffer-note :supertype 'sly-note 3861 'keymap (let ((map (copy-keymap button-map))) 3862 (define-key map "RET" nil) 3863 map) 3864 'mouse-action 'sly-show-notes 3865 'sly-button-echo 'sly-show-notes 3866 'modification-hooks '(sly--in-buffer-note-modification)) 3867 3868(define-button-type 'sly-compilation-note-group :supertype 'sly-note 3869 'face nil) 3870 3871(defun sly--in-buffer-note-modification (button after? _beg _end &optional _len) 3872 (unless after? (delete-overlay button))) 3873 3874(defun sly--add-in-buffer-note (note) 3875 "Add NOTE as a `sly-in-buffer-note' button to the source buffer." 3876 (cl-destructuring-bind (&optional beg end) 3877 (sly-choose-overlay-region note) 3878 (when beg 3879 (let* ((contained (sly-button--overlays-between beg end)) 3880 (containers (cl-set-difference (sly-button--overlays-at beg) 3881 contained))) 3882 (cl-loop for ov in contained do (cl-incf (sly-button--level ov))) 3883 (let ((but (make-button beg 3884 end 3885 :type 'sly-in-buffer-note 3886 'sly-button-search-id (sly-button-next-search-id) 3887 'sly-note note 3888 'help-echo (format "[sly] %s" (sly-note.message note)) 3889 'face (sly-severity-face (sly-note.severity note))))) 3890 (setf (sly-button--level but) 3891 (1+ (cl-reduce #'max containers 3892 :key #'sly-button--level 3893 :initial-value 0)))))))) 3894 3895(defun sly--compilation-note-group-button (label notes) 3896 "Pepare notes as a `sly-compilation-note' button. 3897For insertion in the `compilation-mode' buffer" 3898 (sly--make-text-button label nil :type 'sly-compilation-note-group 'sly-notes-group notes)) 3899 3900 3901;;;; Basic arglisting 3902;;;; 3903(defun sly-show-arglist () 3904 (let ((op (ignore-errors 3905 (save-excursion 3906 (backward-up-list 1) 3907 (down-list 1) 3908 (sly-symbol-at-point))))) 3909 (when op 3910 (sly-eval-async `(slynk:operator-arglist ,op ,(sly-current-package)) 3911 (lambda (arglist) 3912 (when arglist 3913 (sly-message "%s" arglist))))))) 3914 3915 3916;;;; Edit definition 3917 3918(defun sly-push-definition-stack () 3919 "Add point to find-tag-marker-ring." 3920 (ring-insert find-tag-marker-ring (point-marker))) 3921 3922(defun sly-pop-find-definition-stack () 3923 "Pop the edit-definition stack and goto the location." 3924 (interactive) 3925 (pop-tag-mark)) 3926 3927(cl-defstruct (sly-xref (:conc-name sly-xref.) (:type list)) 3928 dspec location) 3929 3930(cl-defstruct (sly-location (:conc-name sly-location.) (:type list) 3931 (:constructor nil) 3932 (:copier nil)) 3933 tag buffer position hints) 3934 3935(defun sly-location-p (o) (and (consp o) (eq (car o) :location))) 3936 3937(defun sly-xref-has-location-p (xref) 3938 (sly-location-p (sly-xref.location xref))) 3939 3940(defun make-sly-buffer-location (buffer-name position &optional hints) 3941 `(:location (:buffer ,buffer-name) (:position ,position) 3942 ,(when hints `(:hints ,hints)))) 3943 3944(defun make-sly-file-location (file-name position &optional hints) 3945 `(:location (:file ,file-name) (:position ,position) 3946 ,(when hints `(:hints ,hints)))) 3947 3948 3949 3950(defun sly-edit-definition (&optional name method) 3951 "Lookup the definition of the name at point. 3952If there's no name at point, or a prefix argument is given, then 3953the function name is prompted. METHOD can be nil, or one of 3954`window' or `frame' to specify if the new definition should be 3955popped, respectively, in the current window, a new window, or a 3956new frame." 3957 (interactive (list (or (and (not current-prefix-arg) 3958 (sly-symbol-at-point t)) 3959 (sly-read-symbol-name "Edit Definition of: ")))) 3960 ;; The hooks might search for a name in a different manner, so don't 3961 ;; ask the user if it's missing before the hooks are run 3962 (let ((xrefs (sly-eval `(slynk:find-definitions-for-emacs ,name)))) 3963 (unless xrefs 3964 (error "No known definition for: %s (in %s)" 3965 name (sly-current-package))) 3966 (cl-destructuring-bind (1loc file-alist) 3967 (sly-analyze-xrefs xrefs) 3968 (cond (1loc 3969 (sly-push-definition-stack) 3970 (sly--pop-to-source-location 3971 (sly-xref.location (car xrefs)) method)) 3972 ((null (cdr xrefs)) ; ((:error "...")) 3973 (error "%s" xrefs)) 3974 (t 3975 (sly-push-definition-stack) 3976 (sly-xref--show-results file-alist 'definition name 3977 (sly-current-package) 3978 (cons (selected-window) 3979 method))))))) 3980 3981(defvar sly-edit-uses-xrefs 3982 '(:calls :macroexpands :binds :references :sets :specializes)) 3983 3984;;; FIXME. TODO: Would be nice to group the symbols (in each 3985;;; type-group) by their home-package. 3986(defun sly-edit-uses (symbol) 3987 "Lookup all the uses of SYMBOL." 3988 (interactive (list (sly-read-symbol-name "Edit Uses of: "))) 3989 (sly-xref--get-xrefs 3990 sly-edit-uses-xrefs 3991 symbol 3992 (lambda (xrefs type symbol package) 3993 (cond 3994 ((and (sly-length= xrefs 1) ; one group 3995 (sly-length= (cdar xrefs) 1)) ; one ref in group 3996 (cl-destructuring-bind (_ (_ loc)) (cl-first xrefs) 3997 (sly-push-definition-stack) 3998 (sly--pop-to-source-location loc))) 3999 (t 4000 (sly-push-definition-stack) 4001 (sly-xref--show-results xrefs type symbol package 'window)))))) 4002 4003(defun sly-analyze-xrefs (xrefs) 4004 "Find common filenames in XREFS. 4005Return a list (SINGLE-LOCATION FILE-ALIST). 4006SINGLE-LOCATION is true if all xrefs point to the same location. 4007FILE-ALIST is an alist of the form ((FILENAME . (XREF ...)) ...)." 4008 (list (and xrefs 4009 (let ((loc (sly-xref.location (car xrefs)))) 4010 (and (sly-location-p loc) 4011 (cl-every (lambda (x) (equal (sly-xref.location x) loc)) 4012 (cdr xrefs))))) 4013 (sly-alistify xrefs #'sly-xref-group #'equal))) 4014 4015(defun sly-xref-group (xref) 4016 (cond ((sly-xref-has-location-p xref) 4017 (sly-dcase (sly-location.buffer (sly-xref.location xref)) 4018 ((:file filename) filename) 4019 ((:buffer bufname) 4020 (let ((buffer (get-buffer bufname))) 4021 (if buffer 4022 (format "%S" buffer) ; "#<buffer foo.lisp>" 4023 (format "%s (previously existing buffer)" bufname)))) 4024 ((:buffer-and-file _buffer filename) filename) 4025 ((:source-form _) "(S-Exp)") 4026 ((:zip _zip entry) entry))) 4027 (t 4028 "(No location)"))) 4029 4030(defun sly-edit-definition-other-window (name) 4031 "Like `sly-edit-definition' but switch to the other window." 4032 (interactive (list (sly-read-symbol-name "Symbol: "))) 4033 (sly-edit-definition name 'window)) 4034 4035(defun sly-edit-definition-other-frame (name) 4036 "Like `sly-edit-definition' but switch to the other window." 4037 (interactive (list (sly-read-symbol-name "Symbol: "))) 4038 (sly-edit-definition name 'frame)) 4039 4040 4041 4042;;;;; first-change-hook 4043 4044(defun sly-first-change-hook () 4045 "Notify Lisp that a source file's buffer has been modified." 4046 ;; Be careful not to disturb anything! 4047 ;; In particular if we muck up the match-data then query-replace 4048 ;; breaks. -luke (26/Jul/2004) 4049 (save-excursion 4050 (save-match-data 4051 (when (and (buffer-file-name) 4052 (file-exists-p (buffer-file-name)) 4053 (sly-background-activities-enabled-p)) 4054 (let ((filename (sly-to-lisp-filename (buffer-file-name)))) 4055 (sly-eval-async `(slynk:buffer-first-change ,filename))))))) 4056 4057(defun sly-setup-first-change-hook () 4058 (add-hook 'first-change-hook #'sly-first-change-hook nil t)) 4059 4060(add-hook 'sly-mode-hook 'sly-setup-first-change-hook) 4061 4062 4063;;;; Eval for Lisp 4064 4065(defun sly-eval-for-lisp (thread tag form-string) 4066 (let ((ok nil) 4067 (value nil) 4068 (error nil) 4069 (c (sly-connection))) 4070 (unwind-protect 4071 (condition-case err 4072 (progn 4073 (sly-check-eval-in-emacs-enabled) 4074 (setq value (eval (read form-string) t)) 4075 (sly-check-eval-in-emacs-result value) 4076 (setq ok t)) 4077 ((debug error) 4078 (setq error err))) 4079 (let ((result (cond (ok `(:ok ,value)) 4080 (error `(:error ,(symbol-name (car error)) 4081 . ,(mapcar #'prin1-to-string 4082 (cdr error)))) 4083 (t `(:abort))))) 4084 (sly-dispatch-event `(:emacs-return ,thread ,tag ,result) c))))) 4085 4086(defun sly-check-eval-in-emacs-result (x) 4087 "Raise an error if X can't be marshaled." 4088 (or (stringp x) 4089 (memq x '(nil t)) 4090 (integerp x) 4091 (keywordp x) 4092 (and (consp x) 4093 (let ((l x)) 4094 (while (consp l) 4095 (sly-check-eval-in-emacs-result (car x)) 4096 (setq l (cdr l))) 4097 (sly-check-eval-in-emacs-result l))) 4098 (error "Non-serializable return value: %S" x))) 4099 4100(defun sly-check-eval-in-emacs-enabled () 4101 "Raise an error if `sly-enable-evaluate-in-emacs' isn't true." 4102 (unless sly-enable-evaluate-in-emacs 4103 (error (concat "sly-eval-in-emacs disabled for security." 4104 "Set sly-enable-evaluate-in-emacs true to enable it.")))) 4105 4106 4107;;;; `ED' 4108 4109(defvar sly-ed-frame nil 4110 "The frame used by `sly-ed'.") 4111 4112(defcustom sly-ed-use-dedicated-frame nil 4113 "*When non-nil, `sly-ed' will create and reuse a dedicated frame." 4114 :type 'boolean 4115 :group 'sly-mode) 4116 4117(cl-defun sly-ed (what ) 4118 "Edit WHAT. 4119 4120WHAT can be: 4121 A filename (string), 4122 A list (:filename FILENAME &key LINE COLUMN POSITION), 4123 A function name (:function-name STRING) 4124 nil. 4125 4126This is for use in the implementation of COMMON-LISP:ED." 4127 (when sly-ed-use-dedicated-frame 4128 (unless (and sly-ed-frame (frame-live-p sly-ed-frame)) 4129 (setq sly-ed-frame (make-frame))) 4130 (select-frame sly-ed-frame)) 4131 (raise-frame) 4132 (when what 4133 (sly-dcase what 4134 ((:filename file &key line column position bytep) 4135 (find-file (sly-from-lisp-filename file)) 4136 (when line (sly-goto-line line)) 4137 (when column (move-to-column column)) 4138 (when position 4139 (goto-char (if bytep 4140 (byte-to-position position) 4141 position)))) 4142 ((:function-name name) 4143 (sly-edit-definition name))))) 4144 4145(defun sly-goto-line (line-number) 4146 "Move to line LINE-NUMBER (1-based). 4147This is similar to `goto-line' but without pushing the mark and 4148the display stuff that we neither need nor want." 4149 (cl-assert (= (buffer-size) (- (point-max) (point-min))) () 4150 "sly-goto-line in narrowed buffer") 4151 (goto-char (point-min)) 4152 (forward-line (1- line-number))) 4153 4154(defun sly-remote-y-or-n-p (thread tag question) 4155 (sly-dispatch-event `(:emacs-return ,thread ,tag ,(sly-y-or-n-p question)))) 4156 4157(defun sly-read-from-minibuffer-for-slynk (thread tag prompt initial-value) 4158 (let ((answer (condition-case nil 4159 (sly-read-from-minibuffer prompt initial-value t) 4160 (quit nil)))) 4161 (sly-dispatch-event `(:emacs-return ,thread ,tag ,answer)))) 4162 4163;;;; Interactive evaluation. 4164 4165(defun sly-interactive-eval (string) 4166 "Read and evaluate STRING and print value in minibuffer. 4167 4168A prefix argument(`C-u') inserts the result into the current 4169buffer. A negative prefix argument (`M--') will sends it to the 4170kill ring." 4171 (interactive (list (sly-read-from-minibuffer "SLY Eval: "))) 4172 (cl-case current-prefix-arg 4173 ((nil) 4174 (sly-eval-with-transcript `(slynk:interactive-eval ,string))) 4175 ((-) 4176 (sly-eval-save string)) 4177 (t 4178 (sly-eval-print string)))) 4179 4180(defvar sly-transcript-start-hook nil 4181 "Hook run before start an evalution.") 4182(defvar sly-transcript-stop-hook nil 4183 "Hook run after finishing a evalution.") 4184 4185(defun sly-display-eval-result (value) 4186 ;; Use `message', not `sly-message' 4187 (with-temp-buffer 4188 (insert value) 4189 (goto-char (point-min)) 4190 (end-of-line 1) 4191 (if (or (< (1+ (point)) (point-max)) 4192 (>= (- (point) (point-min)) (frame-width))) 4193 (sly-show-description value (sly-current-package)) 4194 (message "=> %s" value)))) 4195 4196(defun sly-eval-with-transcript (form) 4197 "Eval FORM in Lisp. Display output, if any." 4198 (run-hooks 'sly-transcript-start-hook) 4199 (sly-rex () (form) 4200 ((:ok value) 4201 (run-hooks 'sly-transcript-stop-hook) 4202 (sly-display-eval-result value)) 4203 ((:abort condition) 4204 (run-hooks 'sly-transcript-stop-hook) 4205 (sly-message "Evaluation aborted on %s." condition)))) 4206 4207(defun sly-eval-print (string) 4208 "Eval STRING in Lisp; insert any output and the result at point." 4209 (sly-eval-async `(slynk:eval-and-grab-output ,string) 4210 (lambda (result) 4211 (cl-destructuring-bind (output value) result 4212 (push-mark) 4213 (let* ((start (point)) 4214 (ppss (syntax-ppss)) 4215 (string-or-comment-p (or (nth 3 ppss) (nth 4 ppss)))) 4216 (insert output (if string-or-comment-p 4217 "" 4218 " => ") value) 4219 (unless string-or-comment-p 4220 (comment-region start (point) 1))))))) 4221 4222(defun sly-eval-save (string) 4223 "Evaluate STRING in Lisp and save the result in the kill ring." 4224 (sly-eval-async `(slynk:eval-and-grab-output ,string) 4225 (lambda (result) 4226 (cl-destructuring-bind (output value) result 4227 (let ((string (concat output value))) 4228 (kill-new string) 4229 (sly-message "Evaluation finished; pushed result to kill ring.")))))) 4230 4231(defun sly-eval-describe (form) 4232 "Evaluate FORM in Lisp and display the result in a new buffer." 4233 (sly-eval-async form (sly-rcurry #'sly-show-description 4234 (sly-current-package)))) 4235 4236(defvar sly-description-autofocus nil 4237 "If non-nil select description windows on display.") 4238 4239(defun sly-show-description (string package) 4240 ;; So we can have one description buffer open per connection. Useful 4241 ;; for comparing the output of DISASSEMBLE across implementations. 4242 ;; FIXME: could easily be achieved with M-x rename-buffer 4243 (let ((bufname (sly-buffer-name :description))) 4244 (sly-with-popup-buffer (bufname :package package 4245 :connection t 4246 :select sly-description-autofocus 4247 :mode 'lisp-mode) 4248 (sly-popup-buffer-mode) 4249 (princ string) 4250 (goto-char (point-min))))) 4251 4252(defun sly-last-expression () 4253 (buffer-substring-no-properties 4254 (save-excursion (backward-sexp) (point)) 4255 (point))) 4256 4257(defun sly-eval-last-expression () 4258 "Evaluate the expression preceding point." 4259 (interactive) 4260 (sly-interactive-eval (sly-last-expression))) 4261 4262(defun sly-eval-defun () 4263 "Evaluate the current toplevel form. 4264Use `sly-re-evaluate-defvar' if the from starts with '(defvar'" 4265 (interactive) 4266 (let ((form (apply #'buffer-substring-no-properties 4267 (sly-region-for-defun-at-point)))) 4268 (cond ((string-match "^(defvar " form) 4269 (sly-re-evaluate-defvar form)) 4270 (t 4271 (sly-interactive-eval form))))) 4272 4273(defun sly-eval-region (start end) 4274 "Evaluate region." 4275 (interactive "r") 4276 (sly-eval-with-transcript 4277 `(slynk:interactive-eval-region 4278 ,(buffer-substring-no-properties start end)))) 4279 4280(defun sly-pprint-eval-region (start end) 4281 "Evaluate region; pprint the value in a buffer." 4282 (interactive "r") 4283 (sly-eval-describe 4284 `(slynk:pprint-eval 4285 ,(buffer-substring-no-properties start end)))) 4286 4287(defun sly-eval-buffer () 4288 "Evaluate the current buffer. 4289The value is printed in the echo area." 4290 (interactive) 4291 (sly-eval-region (point-min) (point-max))) 4292 4293(defun sly-re-evaluate-defvar (form) 4294 "Force the re-evaluaton of the defvar form before point. 4295 4296First make the variable unbound, then evaluate the entire form." 4297 (interactive (list (sly-last-expression))) 4298 (sly-eval-with-transcript `(slynk:re-evaluate-defvar ,form))) 4299 4300(defun sly-pprint-eval-last-expression () 4301 "Evaluate the form before point; pprint the value in a buffer." 4302 (interactive) 4303 (sly-eval-describe `(slynk:pprint-eval ,(sly-last-expression)))) 4304 4305(defun sly-eval-print-last-expression (string) 4306 "Evaluate sexp before point; print value into the current buffer" 4307 (interactive (list (sly-last-expression))) 4308 (insert "\n") 4309 (sly-eval-print string)) 4310 4311;;;; Edit Lisp value 4312;;; 4313(defun sly-edit-value (form-string) 4314 "\\<sly-edit-value-mode-map>\ 4315Edit the value of a setf'able form in a new buffer. 4316The value is inserted into a temporary buffer for editing and then set 4317in Lisp when committed with \\[sly-edit-value-commit]." 4318 (interactive 4319 (list (sly-read-from-minibuffer "Edit value (evaluated): " 4320 (sly-sexp-at-point)))) 4321 (sly-eval-async `(slynk:value-for-editing ,form-string) 4322 (let ((form-string form-string) 4323 (package (sly-current-package))) 4324 (lambda (result) 4325 (sly-edit-value-callback form-string result 4326 package))))) 4327 4328(make-variable-buffer-local 4329 (defvar sly-edit-form-string nil 4330 "The form being edited by `sly-edit-value'.")) 4331 4332(define-minor-mode sly-edit-value-mode 4333 "Mode for editing a Lisp value." 4334 nil 4335 " Edit-Value" 4336 '(("\C-c\C-c" . sly-edit-value-commit))) 4337 4338(defun sly-edit-value-callback (form-string current-value package) 4339 (let* ((name (generate-new-buffer-name (format "*Edit %s*" form-string))) 4340 (buffer (sly-with-popup-buffer (name :package package 4341 :connection t 4342 :select t 4343 :mode 'lisp-mode) 4344 (sly-mode 1) 4345 (sly-edit-value-mode 1) 4346 (setq sly-edit-form-string form-string) 4347 (insert current-value) 4348 (current-buffer)))) 4349 (with-current-buffer buffer 4350 (setq buffer-read-only nil) 4351 (sly-message "Type C-c C-c when done")))) 4352 4353(defun sly-edit-value-commit () 4354 "Commit the edited value to the Lisp image. 4355\\(See `sly-edit-value'.)" 4356 (interactive) 4357 (if (null sly-edit-form-string) 4358 (error "Not editing a value.") 4359 (let ((value (buffer-substring-no-properties (point-min) (point-max)))) 4360 (let ((buffer (current-buffer))) 4361 (sly-eval-async `(slynk:commit-edited-value ,sly-edit-form-string 4362 ,value) 4363 (lambda (_) 4364 (with-current-buffer buffer 4365 (quit-window t)))))))) 4366 4367;;;; Tracing 4368 4369(defun sly-untrace-all () 4370 "Untrace all functions." 4371 (interactive) 4372 (sly-eval `(slynk:untrace-all))) 4373 4374(defun sly-toggle-trace-fdefinition (spec) 4375 "Toggle trace." 4376 (interactive (list (sly-read-from-minibuffer 4377 "(Un)trace: " (sly-symbol-at-point)))) 4378 (sly-message "%s" (sly-eval `(slynk:slynk-toggle-trace ,spec)))) 4379 4380 4381 4382(defun sly-disassemble-symbol (symbol-name) 4383 "Display the disassembly for SYMBOL-NAME." 4384 (interactive (list (sly-read-symbol-name "Disassemble: "))) 4385 (sly-eval-describe `(slynk:disassemble-form ,(concat "'" symbol-name)))) 4386 4387(defun sly-undefine-function (symbol-name) 4388 "Unbind the function slot of SYMBOL-NAME." 4389 (interactive (list (sly-read-symbol-name "fmakunbound: " t))) 4390 (sly-eval-async `(slynk:undefine-function ,symbol-name) 4391 (lambda (result) (sly-message "%s" result)))) 4392 4393(defun sly-unintern-symbol (symbol-name package) 4394 "Unintern the symbol given with SYMBOL-NAME PACKAGE." 4395 (interactive (list (sly-read-symbol-name "Unintern symbol: " t) 4396 (sly-read-package-name "from package: " 4397 (sly-current-package)))) 4398 (sly-eval-async `(slynk:unintern-symbol ,symbol-name ,package) 4399 (lambda (result) (sly-message "%s" result)))) 4400 4401(defun sly-delete-package (package-name) 4402 "Delete the package with name PACKAGE-NAME." 4403 (interactive (list (sly-read-package-name "Delete package: " 4404 (sly-current-package)))) 4405 (sly-eval-async `(cl:delete-package 4406 (slynk::guess-package ,package-name)))) 4407 4408(defun sly-load-file (filename) 4409 "Load the Lisp file FILENAME." 4410 (interactive (list 4411 (read-file-name "[sly] Load file: " nil nil 4412 nil (if (buffer-file-name) 4413 (file-name-nondirectory 4414 (buffer-file-name)))))) 4415 (let ((lisp-filename (sly-to-lisp-filename (expand-file-name filename)))) 4416 (sly-eval-with-transcript `(slynk:load-file ,lisp-filename)))) 4417 4418(defvar sly-change-directory-hooks nil 4419 "Hook run by `sly-change-directory'. 4420The functions are called with the new (absolute) directory.") 4421 4422(defun sly-change-directory (directory) 4423 "Make DIRECTORY become Lisp's current directory. 4424Return whatever slynk:set-default-directory returns." 4425 (let ((dir (expand-file-name directory))) 4426 (prog1 (sly-eval `(slynk:set-default-directory 4427 ,(sly-to-lisp-filename dir))) 4428 (sly-with-connection-buffer nil (cd-absolute dir)) 4429 (run-hook-with-args 'sly-change-directory-hooks dir)))) 4430 4431(defun sly-cd (directory) 4432 "Make DIRECTORY become Lisp's current directory. 4433Return whatever slynk:set-default-directory returns." 4434 (interactive (list (read-directory-name "[sly] Directory: " nil nil t))) 4435 (sly-message "default-directory: %s" (sly-change-directory directory))) 4436 4437(defun sly-pwd () 4438 "Show Lisp's default directory." 4439 (interactive) 4440 (sly-message "Directory %s" (sly-eval `(slynk:default-directory)))) 4441 4442 4443;;;; Documentation 4444 4445(defvar sly-documentation-lookup-function 4446 'sly-hyperspec-lookup) 4447 4448(defun sly-documentation-lookup () 4449 "Generalized documentation lookup. Defaults to hyperspec lookup." 4450 (interactive) 4451 (call-interactively sly-documentation-lookup-function)) 4452 4453;;;###autoload 4454(defun sly-hyperspec-lookup (symbol-name) 4455 "A wrapper for `hyperspec-lookup'" 4456 (interactive (list (common-lisp-hyperspec-read-symbol-name 4457 (sly-symbol-at-point)))) 4458 (hyperspec-lookup symbol-name)) 4459 4460(defun sly-describe-symbol (symbol-name) 4461 "Describe the symbol at point." 4462 (interactive (list (sly-read-symbol-name "Describe symbol: "))) 4463 (when (not symbol-name) 4464 (error "No symbol given")) 4465 (sly-eval-describe `(slynk:describe-symbol ,symbol-name))) 4466 4467(defun sly-documentation (symbol-name) 4468 "Display function- or symbol-documentation for SYMBOL-NAME." 4469 (interactive (list (sly-read-symbol-name "Documentation for symbol: "))) 4470 (when (not symbol-name) 4471 (error "No symbol given")) 4472 (sly-eval-describe 4473 `(slynk:documentation-symbol ,symbol-name))) 4474 4475(defun sly-describe-function (symbol-name) 4476 (interactive (list (sly-read-symbol-name "Describe symbol's function: "))) 4477 (when (not symbol-name) 4478 (error "No symbol given")) 4479 (sly-eval-describe `(slynk:describe-function ,symbol-name))) 4480 4481(defface sly-apropos-symbol 4482 '((t (:inherit sly-part-button-face))) 4483 "Face for the symbol name in Apropos output." 4484 :group 'sly) 4485 4486(defface sly-apropos-label 4487 '((t (:inherit italic))) 4488 "Face for label (`Function', `Variable' ...) in Apropos output." 4489 :group 'sly) 4490 4491(defun sly-apropos-summary (string case-sensitive-p package only-external-p) 4492 "Return a short description for the performed apropos search." 4493 (concat (if case-sensitive-p "Case-sensitive " "") 4494 "Apropos for " 4495 (format "%S" string) 4496 (if package (format " in package %S" package) "") 4497 (if only-external-p " (external symbols only)" ""))) 4498 4499(defun sly-apropos (string &optional only-external-p package 4500 case-sensitive-p) 4501 "Show all bound symbols whose names match STRING. With prefix 4502arg, you're interactively asked for parameters of the search. 4503With M-- (negative) prefix arg, prompt for package only. " 4504 (interactive 4505 (cond ((eq '- current-prefix-arg) 4506 (list (sly-read-from-minibuffer "Apropos external symbols: ") 4507 t 4508 (sly-read-package-name "Package (blank for all): " 4509 nil 'allow-blank) 4510 nil)) 4511 (current-prefix-arg 4512 (list (sly-read-from-minibuffer "Apropos: ") 4513 (sly-y-or-n-p "External symbols only? ") 4514 (sly-read-package-name "Package (blank for all): " 4515 nil 'allow-blank) 4516 (sly-y-or-n-p "Case-sensitive? "))) 4517 (t 4518 (list (sly-read-from-minibuffer "Apropos external symbols: ") t nil nil)))) 4519 (sly-eval-async 4520 `(slynk-apropos:apropos-list-for-emacs ,string ,only-external-p 4521 ,case-sensitive-p ',package) 4522 (sly-rcurry #'sly-show-apropos string package 4523 (sly-apropos-summary string case-sensitive-p 4524 package only-external-p)))) 4525 4526(defun sly-apropos-all () 4527 "Shortcut for (sly-apropos <string> nil nil)" 4528 (interactive) 4529 (sly-apropos (sly-read-from-minibuffer "Apropos all symbols: ") nil nil)) 4530 4531(defun sly-apropos-package (package &optional internal) 4532 "Show apropos listing for symbols in PACKAGE. 4533With prefix argument include internal symbols." 4534 (interactive (list (let ((pkg (sly-read-package-name "Package: "))) 4535 (if (string= pkg "") (sly-current-package) pkg)) 4536 current-prefix-arg)) 4537 (sly-apropos "" (not internal) package)) 4538 4539(defvar sly-apropos-mode-map 4540 (let ((map (make-sparse-keymap))) 4541 map)) 4542 4543(define-derived-mode sly-apropos-mode apropos-mode "SLY-Apropos" 4544 "SLY Apropos Mode 4545 4546TODO" 4547 (sly-mode)) 4548 4549(defun sly-show-apropos (plists string package summary) 4550 (cond ((null plists) 4551 (sly-message "No apropos matches for %S" string)) 4552 (t 4553 (sly-with-popup-buffer ((sly-buffer-name :apropos 4554 :connection t) 4555 :package package :connection t 4556 :mode 'sly-apropos-mode) 4557 (if (boundp 'header-line-format) 4558 (setq header-line-format summary) 4559 (insert summary "\n\n")) 4560 (sly-set-truncate-lines) 4561 (sly-print-apropos plists (not package)) 4562 (set-syntax-table lisp-mode-syntax-table) 4563 (goto-char (point-min)))))) 4564 4565(define-button-type 'sly-apropos-symbol :supertype 'sly-part 4566 'face nil 4567 'action 'sly-button-goto-source ;default action 4568 'sly-button-inspect 4569 #'(lambda (name _type) 4570 (sly-inspect (format "(quote %s)" name))) 4571 'sly-button-goto-source 4572 #'(lambda (name _type) 4573 (sly-edit-definition name 'window)) 4574 'sly-button-describe 4575 #'(lambda (name _type) 4576 (sly-eval-describe `(slynk:describe-symbol ,name)))) 4577 4578(defun sly--package-designator-prefix (designator) 4579 (unless (listp designator) 4580 (error "unknown designator type")) 4581 (concat (cadr designator) 4582 (if (cl-caddr designator) ":" "::"))) 4583 4584(defun sly-apropos-designator-string (designator) 4585 (concat (sly--package-designator-prefix designator) 4586 (car designator))) 4587 4588(defun sly-apropos-insert-symbol (designator item bounds package-designator-searched-p) 4589 (let ((label (sly-apropos-designator-string designator))) 4590 (setq label 4591 (sly--make-text-button label nil 4592 'face 'sly-apropos-symbol 4593 'part-args (list item nil) 4594 'part-label "Symbol" 4595 :type 'sly-apropos-symbol)) 4596 (cl-loop 4597 with offset = (if package-designator-searched-p 4598 0 4599 (length (sly--package-designator-prefix designator))) 4600 for bound in bounds 4601 for (start end) = (if (listp bound) bound (list bound (1+ bound))) 4602 do 4603 (put-text-property (+ start offset) (+ end offset) 'face 'highlight label) 4604 finally (insert label)))) 4605 4606(defun sly-print-apropos (plists package-designator-searched-p) 4607 (cl-loop 4608 for plist in plists 4609 for designator = (plist-get plist :designator) 4610 for item = (substring-no-properties 4611 (sly-apropos-designator-string designator)) 4612 do 4613 (sly-apropos-insert-symbol designator item (plist-get plist :bounds) package-designator-searched-p) 4614 (terpri) 4615 (cl-loop for (prop value) on plist by #'cddr 4616 for start = (point) 4617 unless (memq prop '(:designator 4618 :package 4619 :bounds)) 4620 do 4621 (let ((namespace (upcase-initials 4622 (replace-regexp-in-string 4623 "-" " " (substring (symbol-name prop) 1))))) 4624 (princ " ") 4625 (insert (propertize namespace 4626 'face 'sly-apropos-label)) 4627 (princ ": ") 4628 (princ (cond ((and value 4629 (not (eq value :not-documented))) 4630 value) 4631 (t 4632 "(not documented)"))) 4633 (add-text-properties 4634 start (point) 4635 (list 'action 'sly-button-describe 4636 'sly-button-describe 4637 #'(lambda (name type) 4638 (sly-eval-describe `(slynk:describe-definition-for-emacs ,name 4639 ,type))) 4640 'part-args (list item prop) 4641 'button t 'apropos-label namespace)) 4642 (terpri))))) 4643 4644(defun sly-apropos-describe (name type) 4645 (sly-eval-describe `(slynk:describe-definition-for-emacs ,name ,type))) 4646 4647(require 'info) 4648(defun sly-info--file () 4649 (or (cl-some (lambda (subdir) 4650 (cl-flet ((existing-file 4651 (name) (let* ((path (expand-file-name subdir sly-path)) 4652 (probe (expand-file-name name path))) 4653 (and (file-exists-p probe) probe)))) 4654 (or (existing-file "sly.info") 4655 (existing-file "sly.info.gz")))) 4656 (append '("doc" ".") Info-directory-list)) 4657 (sly-error 4658 "No sly.info, run `make -C doc sly.info' from a SLY git checkout"))) 4659 4660(require 'info) 4661 4662(defvar sly-info--cached-node-names nil) 4663 4664(defun sly-info--node-names (file) 4665 (or sly-info--cached-node-names 4666 (setq sly-info--cached-node-names 4667 (with-temp-buffer 4668 (info file (current-buffer)) 4669 (ignore-errors 4670 (Info-build-node-completions)))))) 4671 4672;;;###autoload 4673(defun sly-info (file &optional node) 4674 "Read SLY manual" 4675 (interactive 4676 (let ((file (sly-info--file))) 4677 (list file 4678 (sly-completing-read "Manual node? (`Top' to read the whole manual): " 4679 (remove '("*") (sly-info--node-names file)) 4680 nil t)))) 4681 (info (if node (format "(%s)%s" file node) file))) 4682 4683 4684;;;; XREF: cross-referencing 4685 4686(defvar sly-xref-mode-map 4687 (let ((map (make-sparse-keymap))) 4688 (define-key map (kbd "RET") 'sly-xref-goto) 4689 (define-key map (kbd "SPC") 'sly-xref-show) 4690 (define-key map (kbd "n") 'sly-xref-next-line) 4691 (define-key map (kbd "p") 'sly-xref-prev-line) 4692 (define-key map (kbd ".") 'sly-xref-next-line) 4693 (define-key map (kbd ",") 'sly-xref-prev-line) 4694 (define-key map (kbd "C-c C-c") 'sly-recompile-xref) 4695 (define-key map (kbd "C-c C-k") 'sly-recompile-all-xrefs) 4696 4697 (define-key map (kbd "q") 'quit-window) 4698 (set-keymap-parent map button-buffer-map) 4699 4700 map)) 4701 4702(define-derived-mode sly-xref-mode lisp-mode "Xref" 4703 "sly-xref-mode: Major mode for cross-referencing. 4704\\<sly-xref-mode-map>\ 4705The most important commands: 4706\\[sly-xref-show] - Display referenced source and keep xref window. 4707\\[sly-xref-goto] - Jump to referenced source and dismiss xref window. 4708 4709\\{sly-xref-mode-map}" 4710 (setq font-lock-defaults nil) 4711 (setq delayed-mode-hooks nil) 4712 (setq buffer-read-only t) 4713 (sly-mode)) 4714 4715(defun sly-next-line/not-add-newlines () 4716 (interactive) 4717 (let ((next-line-add-newlines nil)) 4718 (forward-line 1))) 4719 4720 4721;;;;; XREF results buffer and window management 4722 4723(cl-defmacro sly-with-xref-buffer ((_xref-type _symbol &optional package) 4724 &body body) 4725 "Execute BODY in a xref buffer, then show that buffer." 4726 (declare (indent 1)) 4727 `(sly-with-popup-buffer ((sly-buffer-name :xref 4728 :connection t) 4729 :package ,package 4730 :connection t 4731 :select t 4732 :mode 'sly-xref-mode) 4733 (sly-set-truncate-lines) 4734 ,@body)) 4735 4736;; TODO: Have this button support more options, not just "show source" 4737;; and "goto-source" 4738(define-button-type 'sly-xref :supertype 'sly-part 4739 'action 'sly-button-goto-source ;default action 4740 'mouse-action 'sly-button-goto-source ;default action 4741 'sly-button-show-source #'(lambda (location) 4742 (sly-xref--show-location location)) 4743 'sly-button-goto-source #'(lambda (location) 4744 (sly--pop-to-source-location location 'sly-xref))) 4745 4746(defun sly-xref-button (label location) 4747 (sly--make-text-button label nil 4748 :type 'sly-xref 4749 'part-args (list location) 4750 'part-label "Location")) 4751 4752(defun sly-insert-xrefs (xref-alist) 4753 "Insert XREF-ALIST in the current-buffer. 4754XREF-ALIST is of the form ((GROUP . ((LABEL LOCATION) ...)) ...). 4755GROUP and LABEL are for decoration purposes. LOCATION is a 4756source-location." 4757 (cl-loop for (group . refs) in xref-alist do 4758 (sly-insert-propertized '(face bold) group "\n") 4759 (cl-loop for (label location) in refs 4760 for start = (point) 4761 do 4762 (insert 4763 " " 4764 (sly-xref-button (sly-one-line-ify label) location) 4765 "\n") 4766 (add-text-properties start (point) (list 'sly-location location)))) 4767 ;; Remove the final newline to prevent accidental window-scrolling 4768 (backward-delete-char 1)) 4769 4770(defun sly-xref-next-line (arg) 4771 (interactive "p") 4772 (let ((button (forward-button arg))) 4773 (when button (sly-button-show-source button)))) 4774 4775(defun sly-xref-prev-line (arg) 4776 (interactive "p") 4777 (sly-xref-next-line (- arg))) 4778 4779(defun sly-xref--show-location (loc) 4780 (cl-ecase (car loc) 4781 (:location (sly--display-source-location loc)) 4782 (:error (sly-message "%s" (cadr loc))) 4783 ((nil)))) 4784 4785(defun sly-xref--show-results (xrefs _type symbol package &optional method) 4786 "Maybe show a buffer listing the cross references XREFS. 4787METHOD is used to set `sly-xref--popup-method', which see." 4788 (cond ((null xrefs) 4789 (sly-message "No references found for %s." symbol) 4790 nil) 4791 (t 4792 (sly-with-xref-buffer (_type _symbol package) 4793 (sly-insert-xrefs xrefs) 4794 (setq sly-xref--popup-method method) 4795 (goto-char (point-min)) 4796 (current-buffer))))) 4797 4798 4799;;;;; XREF commands 4800 4801(defun sly-who-calls (symbol) 4802 "Show all known callers of the function SYMBOL. 4803This is implemented with special compiler support, see `sly-list-callers' for a 4804portable alternative." 4805 (interactive (list (sly-read-symbol-name "Who calls: " t))) 4806 (sly-xref :calls symbol)) 4807 4808(defun sly-calls-who (symbol) 4809 "Show all known functions called by the function SYMBOL. 4810This is implemented with special compiler support and may not be supported by 4811all implementations. 4812See `sly-list-callees' for a portable alternative." 4813 (interactive (list (sly-read-symbol-name "Who calls: " t))) 4814 (sly-xref :calls-who symbol)) 4815 4816(defun sly-who-references (symbol) 4817 "Show all known referrers of the global variable SYMBOL." 4818 (interactive (list (sly-read-symbol-name "Who references: " t))) 4819 (sly-xref :references symbol)) 4820 4821(defun sly-who-binds (symbol) 4822 "Show all known binders of the global variable SYMBOL." 4823 (interactive (list (sly-read-symbol-name "Who binds: " t))) 4824 (sly-xref :binds symbol)) 4825 4826(defun sly-who-sets (symbol) 4827 "Show all known setters of the global variable SYMBOL." 4828 (interactive (list (sly-read-symbol-name "Who sets: " t))) 4829 (sly-xref :sets symbol)) 4830 4831(defun sly-who-macroexpands (symbol) 4832 "Show all known expanders of the macro SYMBOL." 4833 (interactive (list (sly-read-symbol-name "Who macroexpands: " t))) 4834 (sly-xref :macroexpands symbol)) 4835 4836(defun sly-who-specializes (symbol) 4837 "Show all known methods specialized on class SYMBOL." 4838 (interactive (list (sly-read-symbol-name "Who specializes: " t))) 4839 (sly-xref :specializes symbol)) 4840 4841(defun sly-list-callers (symbol-name) 4842 "List the callers of SYMBOL-NAME in a xref window. 4843See `sly-who-calls' for an implementation-specific alternative." 4844 (interactive (list (sly-read-symbol-name "List callers: "))) 4845 (sly-xref :callers symbol-name)) 4846 4847(defun sly-list-callees (symbol-name) 4848 "List the callees of SYMBOL-NAME in a xref window. 4849See `sly-calls-who' for an implementation-specific alternative." 4850 (interactive (list (sly-read-symbol-name "List callees: "))) 4851 (sly-xref :callees symbol-name)) 4852 4853(defun sly-xref (type symbol &optional continuation) 4854 "Make an XREF request to Lisp." 4855 (sly-eval-async 4856 `(slynk:xref ',type ',symbol) 4857 (sly-rcurry (lambda (result type symbol package cont) 4858 (and (sly-xref-implemented-p type result) 4859 (let* ((file-alist (cadr (sly-analyze-xrefs result)))) 4860 (funcall (or cont 'sly-xref--show-results) 4861 file-alist type symbol package)))) 4862 type 4863 symbol 4864 (sly-current-package) 4865 continuation))) 4866 4867(defun sly-xref-implemented-p (type xrefs) 4868 "Tell if xref TYPE is available according to XREFS." 4869 (cond ((eq xrefs :not-implemented) 4870 (sly-display-oneliner "%s is not implemented yet on %s." 4871 (sly-xref-type type) 4872 (sly-lisp-implementation-name)) 4873 nil) 4874 (t t))) 4875 4876(defun sly-xref-type (type) 4877 "Return a human readable version of xref TYPE." 4878 (format "who-%s" (sly-cl-symbol-name type))) 4879 4880(defun sly-xref--get-xrefs (types symbol &optional continuation) 4881 "Make multiple XREF requests at once." 4882 (sly-eval-async 4883 `(slynk:xrefs ',types ',symbol) 4884 #'(lambda (result) 4885 (funcall (or continuation 4886 #'sly-xref--show-results) 4887 (cl-loop for (key . val) in result 4888 collect (cons (sly-xref-type key) val)) 4889 types symbol (sly-current-package))))) 4890 4891 4892;;;;; XREF navigation 4893 4894(defun sly-xref-location-at-point () 4895 (save-excursion 4896 ;; When the end of the last line is at (point-max) we can't find 4897 ;; the text property there. Going to bol avoids this problem. 4898 (beginning-of-line 1) 4899 (or (get-text-property (point) 'sly-location) 4900 (error "No reference at point.")))) 4901 4902(defun sly-xref-dspec-at-point () 4903 (save-excursion 4904 (beginning-of-line 1) 4905 (with-syntax-table lisp-mode-syntax-table 4906 (forward-sexp) ; skip initial whitespaces 4907 (backward-sexp) 4908 (sly-sexp-at-point)))) 4909 4910(defun sly-all-xrefs () 4911 (let ((xrefs nil)) 4912 (save-excursion 4913 (goto-char (point-min)) 4914 (while (zerop (forward-line 1)) 4915 (sly--when-let (loc (get-text-property (point) 'sly-location)) 4916 (let* ((dspec (sly-xref-dspec-at-point)) 4917 (xref (make-sly-xref :dspec dspec :location loc))) 4918 (push xref xrefs))))) 4919 (nreverse xrefs))) 4920 4921(defun sly-xref-goto () 4922 "Goto the cross-referenced location at point." 4923 (interactive) 4924 (sly--pop-to-source-location (sly-xref-location-at-point) 'sly-xref)) 4925 4926(defun sly-xref-show () 4927 "Display the xref at point in the other window." 4928 (interactive) 4929 (sly--display-source-location (sly-xref-location-at-point))) 4930 4931(defun sly-search-property (prop &optional backward prop-value-fn) 4932 "Search the next text range where PROP is non-nil. 4933Return the value of PROP. 4934If BACKWARD is non-nil, search backward. 4935If PROP-VALUE-FN is non-nil use it to extract PROP's value." 4936 (let ((next-candidate (if backward 4937 #'previous-single-char-property-change 4938 #'next-single-char-property-change)) 4939 (prop-value-fn (or prop-value-fn 4940 (lambda () 4941 (get-text-property (point) prop)))) 4942 (start (point)) 4943 (prop-value)) 4944 (while (progn 4945 (goto-char (funcall next-candidate (point) prop)) 4946 (not (or (setq prop-value (funcall prop-value-fn)) 4947 (eobp) 4948 (bobp))))) 4949 (cond (prop-value) 4950 (t (goto-char start) nil)))) 4951 4952(defun sly-recompile-xref (&optional raw-prefix-arg) 4953 "Recompile definition at point. 4954Uses prefix arguments like `sly-compile-defun'." 4955 (interactive "P") 4956 (let ((sly-compilation-policy (sly-compute-policy raw-prefix-arg))) 4957 (let ((location (sly-xref-location-at-point)) 4958 (dspec (sly-xref-dspec-at-point))) 4959 (sly-recompile-locations 4960 (list location) 4961 (sly-rcurry #'sly-xref-recompilation-cont 4962 (list dspec) (current-buffer)))))) 4963 4964(defun sly-recompile-all-xrefs (&optional raw-prefix-arg) 4965 "Recompile all definitions. 4966Uses prefix arguments like `sly-compile-defun'." 4967 (interactive "P") 4968 (let ((sly-compilation-policy (sly-compute-policy raw-prefix-arg))) 4969 (let ((dspecs) (locations)) 4970 (dolist (xref (sly-all-xrefs)) 4971 (when (sly-xref-has-location-p xref) 4972 (push (sly-xref.dspec xref) dspecs) 4973 (push (sly-xref.location xref) locations))) 4974 (sly-recompile-locations 4975 locations 4976 (sly-rcurry #'sly-xref-recompilation-cont 4977 dspecs (current-buffer)))))) 4978 4979(defun sly-xref-recompilation-cont (results dspecs buffer) 4980 ;; Extreme long-windedness to insert status of recompilation; 4981 ;; sometimes Elisp resembles more of an Ewwlisp. 4982 4983 ;; FIXME: Should probably throw out the whole recompilation cruft 4984 ;; anyway. -- helmut 4985 ;; TODO: next iteration of fixme cleanup this is going in a contrib -- jt 4986 (with-current-buffer buffer 4987 (sly-compilation-finished (sly-aggregate-compilation-results results) 4988 nil) 4989 (save-excursion 4990 (sly-xref-insert-recompilation-flags 4991 dspecs (cl-loop for r in results collect 4992 (or (sly-compilation-result.successp r) 4993 (and (sly-compilation-result.notes r) 4994 :complained))))))) 4995 4996(defun sly-aggregate-compilation-results (results) 4997 `(:compilation-result 4998 ,(cl-reduce #'append (mapcar #'sly-compilation-result.notes results)) 4999 ,(cl-every #'sly-compilation-result.successp results) 5000 ,(cl-reduce #'+ (mapcar #'sly-compilation-result.duration results)))) 5001 5002(defun sly-xref-insert-recompilation-flags (dspecs compilation-results) 5003 (let* ((buffer-read-only nil) 5004 (max-column (sly-column-max))) 5005 (goto-char (point-min)) 5006 (cl-loop for dspec in dspecs 5007 for result in compilation-results 5008 do (save-excursion 5009 (cl-loop for dspec2 = (progn (search-forward dspec) 5010 (sly-xref-dspec-at-point)) 5011 until (equal dspec2 dspec)) 5012 (end-of-line) ; skip old status information. 5013 (insert-char ?\ (1+ (- max-column (current-column)))) 5014 (insert (format "[%s]" 5015 (cl-case result 5016 ((t) :success) 5017 ((nil) :failure) 5018 (t result)))))))) 5019 5020 5021;;;; Macroexpansion 5022 5023(defvar sly-macroexpansion-minor-mode-map 5024 (let ((map (make-sparse-keymap))) 5025 (define-key map (kbd "g") 'sly-macroexpand-again) 5026 (define-key map (kbd "a") 'sly-macroexpand-all-inplace) 5027 (define-key map (kbd "q") 'quit-window) 5028 (define-key map [remap sly-macroexpand-1] 'sly-macroexpand-1-inplace) 5029 (define-key map [remap sly-macroexpand-all] 'sly-macroexpand-all-inplace) 5030 (define-key map [remap sly-compiler-macroexpand-1] 'sly-compiler-macroexpand-1-inplace) 5031 (define-key map [remap sly-expand-1] 'sly-expand-1-inplace) 5032 (define-key map [remap undo] 'sly-macroexpand-undo) 5033 map)) 5034 5035(define-minor-mode sly-macroexpansion-minor-mode 5036 "SLY mode for macroexpansion" 5037 nil 5038 " Macroexpand" 5039 nil 5040 (read-only-mode 1)) 5041 5042(defun sly-macroexpand-undo (&optional arg) 5043 (interactive) 5044 ;; Emacs 22.x introduced `undo-only' which 5045 ;; works by binding `undo-no-redo' to t. We do 5046 ;; it this way so we don't break prior Emacs 5047 ;; versions. 5048 (cl-macrolet ((undo-only (arg) `(let ((undo-no-redo t)) (undo ,arg)))) 5049 (let ((inhibit-read-only t)) 5050 (when (fboundp 'sly-remove-edits) 5051 (sly-remove-edits (point-min) (point-max))) 5052 (undo-only arg)))) 5053 5054(defvar sly-eval-macroexpand-expression nil 5055 "Specifies the last macroexpansion preformed. 5056This variable specifies both what was expanded and how.") 5057 5058(defun sly-eval-macroexpand (expander &optional string) 5059 (let ((string (or string 5060 (sly-sexp-at-point 'interactive)))) 5061 (setq sly-eval-macroexpand-expression `(,expander ,string)) 5062 (sly-eval-async sly-eval-macroexpand-expression 5063 #'sly-initialize-macroexpansion-buffer))) 5064 5065(defun sly-macroexpand-again () 5066 "Reperform the last macroexpansion." 5067 (interactive) 5068 (sly-eval-async sly-eval-macroexpand-expression 5069 (sly-rcurry #'sly-initialize-macroexpansion-buffer 5070 (current-buffer)))) 5071 5072(defun sly-initialize-macroexpansion-buffer (expansion &optional buffer) 5073 (pop-to-buffer (or buffer (sly-create-macroexpansion-buffer))) 5074 (setq buffer-undo-list nil) ; Get rid of undo information from 5075 ; previous expansions. 5076 (let ((inhibit-read-only t) 5077 (buffer-undo-list t)) ; Make the initial insertion not be undoable. 5078 (erase-buffer) 5079 (insert expansion) 5080 (goto-char (point-min)) 5081 (if (fboundp 'font-lock-ensure) 5082 (font-lock-ensure) 5083 (with-no-warnings (font-lock-fontify-buffer))))) 5084 5085(defun sly-create-macroexpansion-buffer () 5086 (let ((name (sly-buffer-name :macroexpansion))) 5087 (sly-with-popup-buffer (name :package t :connection t 5088 :mode 'lisp-mode) 5089 (sly-macroexpansion-minor-mode 1) 5090 (setq font-lock-keywords-case-fold-search t) 5091 (current-buffer)))) 5092 5093(defun sly-eval-macroexpand-inplace (expander) 5094 "Substitute the sexp at point with its macroexpansion. 5095 5096NB: Does not affect sly-eval-macroexpand-expression" 5097 (interactive) 5098 (let* ((bounds (sly-bounds-of-sexp-at-point 'interactive))) 5099 (let* ((start (copy-marker (car bounds))) 5100 (end (copy-marker (cdr bounds))) 5101 (point (point)) 5102 (buffer (current-buffer))) 5103 (sly-eval-async 5104 `(,expander ,(buffer-substring-no-properties start end)) 5105 (lambda (expansion) 5106 (with-current-buffer buffer 5107 (let ((buffer-read-only nil)) 5108 (when (fboundp 'sly-remove-edits) 5109 (sly-remove-edits (point-min) (point-max))) 5110 (goto-char start) 5111 (delete-region start end) 5112 (sly-insert-indented expansion) 5113 (goto-char point)))))))) 5114 5115(defun sly-macroexpand-1 (&optional repeatedly) 5116 "Display the macro expansion of the form at point. 5117The form is expanded with CL:MACROEXPAND-1 or, if a prefix 5118argument is given, with CL:MACROEXPAND." 5119 (interactive "P") 5120 (sly-eval-macroexpand 5121 (if repeatedly 'slynk:slynk-macroexpand 'slynk:slynk-macroexpand-1))) 5122 5123(defun sly-macroexpand-1-inplace (&optional repeatedly) 5124 (interactive "P") 5125 (sly-eval-macroexpand-inplace 5126 (if repeatedly 'slynk:slynk-macroexpand 'slynk:slynk-macroexpand-1))) 5127 5128(defun sly-macroexpand-all (&optional just-one) 5129 "Display the recursively macro expanded sexp at point. 5130With optional JUST-ONE prefix arg, use CL:MACROEXPAND-1." 5131 (interactive "P") 5132 (sly-eval-macroexpand (if just-one 5133 'slynk:slynk-macroexpand-1 5134 'slynk:slynk-macroexpand-all))) 5135 5136(defun sly-macroexpand-all-inplace () 5137 "Display the recursively macro expanded sexp at point." 5138 (interactive) 5139 (sly-eval-macroexpand-inplace 'slynk:slynk-macroexpand-all)) 5140 5141(defun sly-compiler-macroexpand-1 (&optional repeatedly) 5142 "Display the compiler-macro expansion of sexp at point." 5143 (interactive "P") 5144 (sly-eval-macroexpand 5145 (if repeatedly 5146 'slynk:slynk-compiler-macroexpand 5147 'slynk:slynk-compiler-macroexpand-1))) 5148 5149(defun sly-compiler-macroexpand-1-inplace (&optional repeatedly) 5150 "Display the compiler-macro expansion of sexp at point." 5151 (interactive "P") 5152 (sly-eval-macroexpand-inplace 5153 (if repeatedly 5154 'slynk:slynk-compiler-macroexpand 5155 'slynk:slynk-compiler-macroexpand-1))) 5156 5157(defun sly-expand-1 (&optional repeatedly) 5158 "Display the macro expansion of the form at point. 5159 5160The form is expanded with CL:MACROEXPAND-1 or, if a prefix 5161argument is given, with CL:MACROEXPAND. 5162 5163Contrary to `sly-macroexpand-1', if the form denotes a compiler 5164macro, SLYNK-BACKEND:COMPILER-MACROEXPAND or 5165SLYNK-BACKEND:COMPILER-MACROEXPAND-1 are used instead." 5166 (interactive "P") 5167 (sly-eval-macroexpand 5168 (if repeatedly 5169 'slynk:slynk-expand 5170 'slynk:slynk-expand-1))) 5171 5172(defun sly-expand-1-inplace (&optional repeatedly) 5173 "Display the macro expansion of the form at point. 5174The form is expanded with CL:MACROEXPAND-1 or, if a prefix 5175argument is given, with CL:MACROEXPAND." 5176 (interactive "P") 5177 (sly-eval-macroexpand-inplace 5178 (if repeatedly 5179 'slynk:slynk-expand 5180 'slynk:slynk-expand-1))) 5181 5182(defun sly-format-string-expand (&optional string) 5183 "Expand the format-string at point and display it. 5184With prefix arg, or if no string at point, prompt the user for a 5185string to expand. 5186" 5187 (interactive (list (or (and (not current-prefix-arg) 5188 (sly-string-at-point)) 5189 (sly-read-from-minibuffer "Expand format: " 5190 (sly-string-at-point))))) 5191 (sly-eval-macroexpand 'slynk:slynk-format-string-expand 5192 string)) 5193 5194 5195;;;; Subprocess control 5196 5197(defun sly-interrupt () 5198 "Interrupt Lisp." 5199 (interactive) 5200 (cond ((sly-use-sigint-for-interrupt) (sly-send-sigint)) 5201 (t (sly-dispatch-event `(:emacs-interrupt ,sly-current-thread))))) 5202 5203(defun sly-quit () 5204 (error "Not implemented properly. Use `sly-interrupt' instead.")) 5205 5206(defun sly-quit-lisp (&optional kill interactive) 5207 "Quit lisp, kill the inferior process and associated buffers." 5208 (interactive (list current-prefix-arg t)) 5209 (let ((connection (if interactive 5210 (sly-prompt-for-connection "Connection to quit: ") 5211 (sly-current-connection)))) 5212 (sly-quit-lisp-internal connection 'sly-quit-sentinel kill))) 5213 5214(defun sly-quit-lisp-internal (connection sentinel kill) 5215 "Kill SLY socket connection CONNECTION. 5216Do this by evaluating (SLYNK:QUIT-LISP) in it, and don't wait for 5217it to reply as usual with other evaluations. If it's non-nil, 5218setup SENTINEL to run on CONNECTION when it finishes dying. If 5219KILL is t, and there is such a thing, also kill the inferior lisp 5220process associated with CONNECTION." 5221 (let ((sly-dispatching-connection connection)) 5222 (sly-eval-async '(slynk:quit-lisp)) 5223 (set-process-filter connection nil) 5224 (let ((attempt 0) 5225 (dying-p nil)) 5226 (set-process-sentinel 5227 connection 5228 (lambda (connection status) 5229 (setq dying-p t) 5230 (sly-message "Connection %s is dying (%s)" connection status) 5231 (let ((inf-process (sly-inferior-process connection))) 5232 (cond ((and kill 5233 inf-process 5234 (not (memq (process-status inf-process) '(exit signal)))) 5235 (sly-message "Quitting %s: also killing the inferior process %s" 5236 connection inf-process) 5237 (kill-process inf-process)) 5238 ((and kill 5239 inf-process) 5240 (sly-message "Quitting %s: inferior process was already dead" 5241 connection 5242 inf-process)) 5243 ((and 5244 kill 5245 (not inf-process)) 5246 (sly-message "Quitting %s: No inferior process to kill!" 5247 connection 5248 inf-process)))) 5249 (when sentinel 5250 (funcall sentinel connection status)))) 5251 (sly-message 5252 "Waiting for connection %s to die by itself..." connection) 5253 (while (and (< (cl-incf attempt) 30) 5254 (not dying-p)) 5255 (sleep-for 0.1)) 5256 (unless dying-p 5257 (sly-message 5258 "Connection %s didn't die by itself. Killing it." connection) 5259 (delete-process connection))))) 5260 5261(defun sly-quit-sentinel (process _message) 5262 (cl-assert (process-status process) 'closed) 5263 (let* ((inferior (sly-inferior-process process)) 5264 (inferior-buffer (if inferior (process-buffer inferior)))) 5265 (when inferior (delete-process inferior)) 5266 (when inferior-buffer (kill-buffer inferior-buffer)) 5267 (sly-net-close process "Quitting lisp") 5268 (sly-message "Connection closed."))) 5269 5270 5271;;;; Debugger (SLY-DB) 5272 5273(defvar sly-db-hook nil 5274 "Hook run on entry to the debugger.") 5275 5276(defcustom sly-db-initial-restart-limit 6 5277 "Maximum number of restarts to display initially." 5278 :group 'sly-debugger 5279 :type 'integer) 5280 5281 5282;;;;; Local variables in the debugger buffer 5283 5284;; Small helper. 5285(defun sly-make-variables-buffer-local (&rest variables) 5286 (mapcar #'make-variable-buffer-local variables)) 5287 5288(sly-make-variables-buffer-local 5289 (defvar sly-db-condition nil 5290 "A list (DESCRIPTION TYPE) describing the condition being debugged.") 5291 5292 (defvar sly-db-restarts nil 5293 "List of (NAME DESCRIPTION) for each available restart.") 5294 5295 (defvar sly-db-level nil 5296 "Current debug level (recursion depth) displayed in buffer.") 5297 5298 (defvar sly-db-backtrace-start-marker nil 5299 "Marker placed at the first frame of the backtrace.") 5300 5301 (defvar sly-db-restart-list-start-marker nil 5302 "Marker placed at the first restart in the restart list.") 5303 5304 (defvar sly-db-continuations nil 5305 "List of ids for pending continuation.")) 5306 5307;;;;; SLY-DB macros 5308 5309;; some macros that we need to define before the first use 5310 5311(defmacro sly-db-in-face (name string) 5312 "Return STRING propertised with face sly-db-NAME-face." 5313 (declare (indent 1)) 5314 (let ((facename (intern (format "sly-db-%s-face" (symbol-name name)))) 5315 (var (cl-gensym "string"))) 5316 `(let ((,var ,string)) 5317 (sly-add-face ',facename ,var) 5318 ,var))) 5319 5320 5321;;;;; sly-db-mode 5322 5323(defvar sly-db-mode-syntax-table 5324 (let ((table (copy-syntax-table lisp-mode-syntax-table))) 5325 ;; We give < and > parenthesis syntax, so that #< ... > is treated 5326 ;; as a balanced expression. This enables autodoc-mode to match 5327 ;; #<unreadable> actual arguments in the backtraces with formal 5328 ;; arguments of the function. (For Lisp mode, this is not 5329 ;; desirable, since we do not wish to get a mismatched paren 5330 ;; highlighted everytime we type < or >.) 5331 (modify-syntax-entry ?< "(" table) 5332 (modify-syntax-entry ?> ")" table) 5333 table) 5334 "Syntax table for SLY-DB mode.") 5335 5336(defvar sly-db-mode-map 5337 (let ((map (make-sparse-keymap))) 5338 (define-key map "n" 'sly-db-down) 5339 (define-key map "p" 'sly-db-up) 5340 (define-key map "\M-n" 'sly-db-details-down) 5341 (define-key map "\M-p" 'sly-db-details-up) 5342 (define-key map "<" 'sly-db-beginning-of-backtrace) 5343 (define-key map ">" 'sly-db-end-of-backtrace) 5344 5345 (define-key map "a" 'sly-db-abort) 5346 (define-key map "q" 'sly-db-abort) 5347 (define-key map "c" 'sly-db-continue) 5348 (define-key map "A" 'sly-db-break-with-system-debugger) 5349 (define-key map "B" 'sly-db-break-with-default-debugger) 5350 (define-key map "P" 'sly-db-print-condition) 5351 (define-key map "I" 'sly-db-invoke-restart-by-name) 5352 (define-key map "C" 'sly-db-inspect-condition) 5353 (define-key map ":" 'sly-interactive-eval) 5354 (define-key map "Q" 'sly-db-quit) 5355 5356 (set-keymap-parent map button-buffer-map) 5357 map)) 5358 5359(define-derived-mode sly-db-mode fundamental-mode "sly-db" 5360 "Superior lisp debugger mode. 5361In addition to ordinary SLY commands, the following are 5362available:\\<sly-db-mode-map> 5363 5364Commands to invoke restarts: 5365 \\[sly-db-quit] - quit 5366 \\[sly-db-abort] - abort 5367 \\[sly-db-continue] - continue 5368 \\[sly-db-invoke-restart-0]-\\[sly-db-invoke-restart-9] - restart shortcuts 5369 \\[sly-db-invoke-restart-by-name] - invoke restart by name 5370 5371Navigation commands: 5372 \\[forward-button] - next interactive button 5373 \\[sly-db-down] - down 5374 \\[sly-db-up] - up 5375 \\[sly-db-details-down] - down, with details 5376 \\[sly-db-details-up] - up, with details 5377 \\[sly-db-beginning-of-backtrace] - beginning of backtrace 5378 \\[sly-db-end-of-backtrace] - end of backtrace 5379 5380Commands to examine and operate on the selected frame:\\<sly-db-frame-map> 5381 \\[sly-db-show-frame-source] - show frame source 5382 \\[sly-db-goto-source] - go to frame source 5383 \\[sly-db-toggle-details] - toggle details 5384 \\[sly-db-disassemble] - dissassemble frame 5385 \\[sly-db-eval-in-frame] - prompt for a form to eval in frame 5386 \\[sly-db-pprint-eval-in-frame] - eval in frame and pretty print result 5387 \\[sly-db-inspect-in-frame] - inspect in frame's context 5388 \\[sly-db-restart-frame] - restart frame 5389 \\[sly-db-return-from-frame] - return from frame 5390 5391Miscellaneous commands:\\<sly-db-mode-map> 5392 \\[sly-db-step] - step 5393 \\[sly-db-break-with-default-debugger] - switch to native debugger 5394 \\[sly-db-break-with-system-debugger] - switch to system debugger (gdb) 5395 \\[sly-interactive-eval] - eval 5396 \\[sly-db-inspect-condition] - inspect signalled condition 5397 5398Full list of commands: 5399 5400\\{sly-db-mode-map} 5401 5402Full list of frame-specific commands: 5403 5404\\{sly-db-frame-map}" 5405 (erase-buffer) 5406 (set-syntax-table sly-db-mode-syntax-table) 5407 (sly-set-truncate-lines) 5408 ;; Make original sly-connection "sticky" for SLY-DB commands in this buffer 5409 (setq sly-buffer-connection (sly-connection)) 5410 (setq buffer-read-only t) 5411 (sly-mode 1) 5412 (sly-interactive-buttons-mode 1)) 5413 5414;; Keys 0-9 are shortcuts to invoke particular restarts. 5415(dotimes (number 10) 5416 (let ((fname (intern (format "sly-db-invoke-restart-%S" number))) 5417 (docstring (format "Invoke restart numbered %S." number))) 5418 ;; FIXME: In Emacs≥25, you could avoid `eval' and use 5419 ;; (defalias .. (lambda .. (:documentation docstring) ...)) 5420 ;; instead! 5421 (eval `(defun ,fname () 5422 ,docstring 5423 (interactive) 5424 (sly-db-invoke-restart ,number)) 5425 t) 5426 (define-key sly-db-mode-map (number-to-string number) fname))) 5427 5428 5429;;;;; SLY-DB buffer creation & update 5430 5431(defcustom sly-db-focus-debugger 'auto 5432 "Control if debugger window gets focus immediately. 5433 5434If nil, the window is never focused automatically; if the symbol 5435`auto', the window is only focused if the user has performed no 5436other commands in the meantime (i.e. he/she is expecting a 5437possible debugger); any other non-nil value means to always 5438automatically focus the debugger window." 5439 :group 'sly-debugger 5440 :type '(choice (const always) (const never) (const auto))) 5441 5442(defun sly-filter-buffers (predicate) 5443 "Return a list of where PREDICATE returns true. 5444PREDICATE is executed in the buffer to test." 5445 (cl-remove-if-not (lambda (%buffer) 5446 (with-current-buffer %buffer 5447 (funcall predicate))) 5448 (buffer-list))) 5449 5450(defun sly-db-buffers (&optional connection) 5451 "Return a list of all sly-db buffers (belonging to CONNECTION.)" 5452 (if connection 5453 (sly-filter-buffers (lambda () 5454 (and (eq sly-buffer-connection connection) 5455 (eq major-mode 'sly-db-mode)))) 5456 (sly-filter-buffers (lambda () (eq major-mode 'sly-db-mode))))) 5457 5458(defun sly-db-find-buffer (thread &optional connection) 5459 (let ((connection (or connection (sly-connection)))) 5460 (cl-find-if (lambda (buffer) 5461 (with-current-buffer buffer 5462 (and (eq sly-buffer-connection connection) 5463 (eq sly-current-thread thread)))) 5464 (sly-db-buffers)))) 5465 5466(defun sly-db-pop-to-debugger-maybe (&optional _button) 5467 "Maybe pop to *sly-db* buffer for current context." 5468 (interactive) 5469 (let ((b (sly-db-find-buffer sly-current-thread))) 5470 (if b (pop-to-buffer b) 5471 (sly-error "Can't find a *sly-db* debugger for this context")))) 5472 5473(defsubst sly-db-get-default-buffer () 5474 "Get a sly-db buffer. 5475The chosen buffer the default connection's it if exists." 5476 (car (sly-db-buffers (sly-current-connection)))) 5477 5478(defun sly-db-pop-to-debugger () 5479 "Pop to the first *sly-db* buffer if at least one exists." 5480 (interactive) 5481 (let ((b (sly-db-get-default-buffer))) 5482 (if b (pop-to-buffer b) 5483 (sly-error "No *sly-db* debugger buffers for this connection")))) 5484 5485(defun sly-db-get-buffer (thread &optional connection) 5486 "Find or create a sly-db-buffer for THREAD." 5487 (let ((connection (or connection (sly-connection)))) 5488 (or (sly-db-find-buffer thread connection) 5489 (let ((name (sly-buffer-name :db :connection connection 5490 :suffix (format "thread %d" thread)))) 5491 (with-current-buffer (generate-new-buffer name) 5492 (setq sly-buffer-connection connection 5493 sly-current-thread thread) 5494 (current-buffer)))))) 5495 5496(defun sly-db-debugged-continuations (connection) 5497 "Return the all debugged continuations for CONNECTION across SLY-DB buffers." 5498 (cl-loop for b in (sly-db-buffers) 5499 append (with-current-buffer b 5500 (and (eq sly-buffer-connection connection) 5501 sly-db-continuations)))) 5502 5503(defun sly-db-confirm-buffer-kill () 5504 (when (or (not (process-live-p sly-buffer-connection)) 5505 (sly-y-or-n-p "Really kill sly-db buffer and throw to toplevel?")) 5506 (ignore-errors (sly-db-quit)) 5507 t)) 5508 5509(defun sly-db--display-debugger (_thread) 5510 "Display (or pop to) sly-db for THREAD as appropriate. 5511Also mark the window as a debugger window." 5512 (let* ((action '(sly-db--display-in-prev-sly-db-window)) 5513 (buffer (current-buffer)) 5514 (win 5515 (if (cond ((eq sly-db-focus-debugger 'auto) 5516 (eq sly--send-last-command last-command)) 5517 (t sly-db-focus-debugger)) 5518 (progn 5519 (pop-to-buffer buffer action) 5520 (selected-window)) 5521 (display-buffer buffer action)))) 5522 (set-window-parameter win 'sly-db buffer) 5523 win)) 5524 5525(defun sly-db-setup (thread level condition restarts frame-specs conts) 5526 "Setup a new SLY-DB buffer. 5527CONDITION is a string describing the condition to debug. 5528RESTARTS is a list of strings (NAME DESCRIPTION) for each 5529available restart. FRAME-SPECS is a list of (NUMBER DESCRIPTION 5530&optional PLIST) describing the initial portion of the 5531backtrace. Frames are numbered from 0. CONTS is a list of 5532pending Emacs continuations." 5533 (with-current-buffer (sly-db-get-buffer thread) 5534 (cl-assert (if (equal sly-db-level level) 5535 (equal sly-db-condition condition) 5536 t) 5537 () "Bug: sly-db-level is equal but condition differs\n%s\n%s" 5538 sly-db-condition condition) 5539 (with-selected-window (sly-db--display-debugger thread) 5540 (unless (equal sly-db-level level) 5541 (let ((inhibit-read-only t)) 5542 (sly-db-mode) 5543 (add-hook 'kill-buffer-query-functions 5544 #'sly-db-confirm-buffer-kill 5545 nil t) 5546 (setq sly-current-thread thread) 5547 (setq sly-db-level level) 5548 (setq mode-name (format "sly-db[%d]" sly-db-level)) 5549 (setq sly-db-condition condition) 5550 (setq sly-db-restarts restarts) 5551 (setq sly-db-continuations conts) 5552 (sly-db-insert-condition condition) 5553 (insert "\n\n" (sly-db-in-face section "Restarts:") "\n") 5554 (setq sly-db-restart-list-start-marker (point-marker)) 5555 (sly-db-insert-restarts restarts 0 sly-db-initial-restart-limit) 5556 (insert "\n" (sly-db-in-face section "Backtrace:") "\n") 5557 (setq sly-db-backtrace-start-marker (point-marker)) 5558 (save-excursion 5559 (if frame-specs 5560 (sly-db-insert-frames (sly-db-prune-initial-frames frame-specs) t) 5561 (insert "[No backtrace]"))) 5562 (run-hooks 'sly-db-hook) 5563 (set-syntax-table lisp-mode-syntax-table))) 5564 (sly-recenter (point-min) 'allow-moving-point) 5565 (when sly--stack-eval-tags 5566 (sly-message "Entering recursive edit..") 5567 (recursive-edit))))) 5568 5569(defun sly-db--display-in-prev-sly-db-window (buffer _alist) 5570 (let ((window 5571 (get-window-with-predicate 5572 #'(lambda (w) 5573 (let ((value (window-parameter w 'sly-db))) 5574 (and value 5575 (not (buffer-live-p value)))))))) 5576 (when window 5577 (display-buffer-record-window 'reuse window buffer) 5578 (set-window-buffer window buffer) 5579 window))) 5580 5581(defun sly-db--ensure-initialized (thread level) 5582 "Initialize debugger buffer for THREAD. 5583If such a buffer exists for LEVEL, it is assumed to have been 5584sufficiently initialized, and this function does nothing." 5585 (let ((buffer (sly-db-find-buffer thread))) 5586 (unless (and buffer 5587 (with-current-buffer buffer 5588 (equal sly-db-level level))) 5589 (sly-rex () 5590 ('(slynk:debugger-info-for-emacs 0 10) 5591 nil thread) 5592 ((:ok result) 5593 (apply #'sly-db-setup thread level result)))))) 5594 5595(defvar sly-db-exit-hook nil 5596 "Hooks run in the debugger buffer just before exit") 5597 5598(defun sly-db-exit (thread _level &optional stepping) 5599 "Exit from the debug level LEVEL." 5600 (sly--when-let (sly-db (sly-db-find-buffer thread)) 5601 (with-current-buffer sly-db 5602 (setq kill-buffer-query-functions 5603 (remove 'sly-db-confirm-buffer-kill kill-buffer-query-functions)) 5604 (run-hooks 'sly-db-exit-hook) 5605 (cond (stepping 5606 (setq sly-db-level nil) 5607 (run-with-timer 0.4 nil 'sly-db-close-step-buffer sly-db)) 5608 ((not (eq sly-db (window-buffer (selected-window)))) 5609 ;; A different window selection means an indirect, 5610 ;; non-interactive exit, we just kill the sly-db buffer. 5611 (kill-buffer)) 5612 (t 5613 (quit-window t)))))) 5614 5615(defun sly-db-close-step-buffer (buffer) 5616 (when (buffer-live-p buffer) 5617 (with-current-buffer buffer 5618 (when (not sly-db-level) 5619 (quit-window t))))) 5620 5621 5622;;;;;; SLY-DB buffer insertion 5623 5624(defun sly-db-insert-condition (condition) 5625 "Insert the text for CONDITION. 5626CONDITION should be a list (MESSAGE TYPE EXTRAS). 5627EXTRAS is currently used for the stepper." 5628 (cl-destructuring-bind (msg type extras) condition 5629 (insert (sly-db-in-face topline msg) 5630 "\n" 5631 (sly-db-in-face condition type)) 5632 (sly-db-dispatch-extras extras))) 5633 5634(defvar sly-db-extras-hooks nil 5635 "Handlers for the extra options sent in a debugger invocation. 5636Each function is called with one argument, a list (OPTION 5637VALUE). It should return non-nil iff it can handle OPTION, and 5638thus preventing other handlers from trying. 5639 5640Functions are run in the SLDB buffer.") 5641 5642(defun sly-db-dispatch-extras (extras) 5643 ;; this is (mis-)used for the stepper 5644 (dolist (extra extras) 5645 (sly-dcase extra 5646 ((:show-frame-source n) 5647 (sly-db-show-frame-source n)) 5648 (t 5649 (or (run-hook-with-args-until-success 'sly-db-extras-hooks extra) 5650 ;;(error "Unhandled extra element:" extra) 5651 ))))) 5652 5653(defun sly-db-insert-restarts (restarts start count) 5654 "Insert RESTARTS and add the needed text props 5655RESTARTS should be a list ((NAME DESCRIPTION) ...)." 5656 (let* ((len (length restarts)) 5657 (end (if count (min (+ start count) len) len))) 5658 (cl-loop for (name string) in (cl-subseq restarts start end) 5659 for number from start 5660 do (insert 5661 " " (sly-db-in-face restart-number (number-to-string number)) 5662 ": " (sly-make-action-button (format "[%s]" name) 5663 (let ((n number)) 5664 #'(lambda (_button) 5665 (sly-db-invoke-restart n))) 5666 'restart-number number) 5667 " " (sly-db-in-face restart string)) 5668 (insert "\n")) 5669 (when (< end len) 5670 (insert (sly-make-action-button 5671 " --more--" 5672 #'(lambda (button) 5673 (let ((inhibit-read-only t)) 5674 (delete-region (button-start button) 5675 (1+ (button-end button))) 5676 (sly-db-insert-restarts restarts end nil) 5677 (sly--when-let (win (get-buffer-window (current-buffer))) 5678 (with-selected-window win 5679 (sly-recenter (point-max)))))) 5680 'point-entered #'(lambda (_ new) (push-button new))) 5681 "\n")))) 5682 5683(defun sly-db-frame-restartable-p (frame-spec) 5684 (and (plist-get (cl-caddr frame-spec) :restartable) t)) 5685 5686(defun sly-db-prune-initial-frames (frame-specs) 5687 "Return the prefix of FRAMES-SPECS to initially present to the user. 5688Regexp heuristics are used to avoid showing SLYNK-internal frames." 5689 (let* ((case-fold-search t) 5690 (rx "^\\([() ]\\|lambda\\)*slynk\\>")) 5691 (or (cl-loop for frame-spec in frame-specs 5692 until (string-match rx (cadr frame-spec)) 5693 collect frame-spec) 5694 frame-specs))) 5695 5696(defun sly-db-insert-frames (frame-specs more) 5697 "Insert frames for FRAME-SPECS into buffer. 5698If MORE is non-nil, more frames are on the Lisp stack." 5699 (cl-loop 5700 for frame-spec in frame-specs 5701 do (sly-db-insert-frame frame-spec) 5702 finally 5703 (when more 5704 (insert (sly-make-action-button 5705 " --more--\n" 5706 (lambda (button) 5707 (let* ((inhibit-read-only t) 5708 (count 40) 5709 (from (1+ (car frame-spec))) 5710 (to (+ from count)) 5711 (frames (sly-eval `(slynk:backtrace ,from ,to))) 5712 (more (sly-length= frames count))) 5713 (delete-region (button-start button) 5714 (button-end button)) 5715 (save-excursion 5716 (sly-db-insert-frames frames more)) 5717 (sly--when-let (win (get-buffer-window (current-buffer))) 5718 (with-selected-window win 5719 (sly-recenter (point-max)))))) 5720 'point-entered #'(lambda (_ new) (push-button new))))))) 5721 5722(defvar sly-db-frame-map 5723 (let ((map (make-sparse-keymap))) 5724 (define-key map (kbd "t") 'sly-db-toggle-details) 5725 (define-key map (kbd "v") 'sly-db-show-frame-source) 5726 (define-key map (kbd ".") 'sly-db-goto-source) 5727 (define-key map (kbd "D") 'sly-db-disassemble) 5728 (define-key map (kbd "e") 'sly-db-eval-in-frame) 5729 (define-key map (kbd "d") 'sly-db-pprint-eval-in-frame) 5730 (define-key map (kbd "i") 'sly-db-inspect-in-frame) 5731 (define-key map (kbd "r") 'sly-db-restart-frame) 5732 (define-key map (kbd "R") 'sly-db-return-from-frame) 5733 (define-key map (kbd "RET") 'sly-db-toggle-details) 5734 5735 (define-key map "s" 'sly-db-step) 5736 (define-key map "x" 'sly-db-next) 5737 (define-key map "o" 'sly-db-out) 5738 (define-key map "b" 'sly-db-break-on-return) 5739 5740 (define-key map "\C-c\C-c" 'sly-db-recompile-frame-source) 5741 5742 (set-keymap-parent map sly-part-button-keymap) 5743 map)) 5744 5745(defvar sly-db-frame-menu-map 5746 (let ((map (make-sparse-keymap))) 5747 (cl-macrolet ((item (label sym) 5748 `(define-key map [,sym] '(menu-item ,label ,sym)))) 5749 (item "Dissassemble" sly-db-disassemble) 5750 (item "Eval In Context" sly-db-eval-in-frame) 5751 (item "Eval and Pretty Print In Context" sly-db-pprint-eval-in-frame) 5752 (item "Inspect In Context" sly-db-inspect-in-frame) 5753 (item "Restart" sly-db-restart-frame) 5754 (item "Return Value" sly-db-return-from-frame) 5755 (item "Toggle Details" sly-db-toggle-details) 5756 (item "Show Source" sly-db-show-frame-source) 5757 (item "Go To Source" sly-db-goto-source)) 5758 (set-keymap-parent map sly-button-popup-part-menu-keymap) 5759 map)) 5760 5761(define-button-type 'sly-db-frame :supertype 'sly-part 5762 'keymap sly-db-frame-map 5763 'part-menu-keymap sly-db-frame-menu-map 5764 'action 'sly-db-toggle-details 5765 'mouse-action 'sly-db-toggle-details) 5766 5767(defun sly-db--guess-frame-function (frame) 5768 (ignore-errors 5769 (car (car (read-from-string 5770 (replace-regexp-in-string "#" "" 5771 (cadr frame))))))) 5772 5773(defun sly-db-frame-button (label frame face &rest props) 5774 (apply #'sly--make-text-button label nil :type 'sly-db-frame 5775 'face face 5776 'field (car frame) 5777 'frame-number (car frame) 5778 'frame-string (cadr frame) 5779 'part-args (list (car frame) 5780 (sly-db--guess-frame-function frame)) 5781 'part-label (format "Frame %d" (car frame)) 5782 props)) 5783 5784(defun sly-db-frame-number-at-point () 5785 (let ((button (sly-db-frame-button-near-point))) 5786 (button-get button 'frame-number))) 5787 5788(defun sly-db-frame-button-near-point () 5789 (or (sly-button-at nil 'sly-db-frame 'no-error) 5790 (get-text-property (point) 'nearby-frame-button) 5791 (error "No frame button here"))) 5792 5793(defun sly-db-insert-frame (frame-spec) 5794 "Insert a frame for FRAME-SPEC." 5795 (let* ((number (car frame-spec)) 5796 (label (cadr frame-spec)) 5797 (origin (point))) 5798 (insert 5799 (propertize (format "%2d: " number) 5800 'face 'sly-db-frame-label-face) 5801 (sly-db-frame-button label frame-spec 5802 (if (sly-db-frame-restartable-p frame-spec) 5803 'sly-db-restartable-frame-line-face 5804 'sly-db-frame-line-face)) 5805 "\n") 5806 (add-text-properties 5807 origin (point) 5808 (list 'field number 5809 'keymap sly-db-frame-map 5810 'nearby-frame-button (button-at (- (point) 2)))))) 5811 5812 5813;;;;;; SLY-DB examining text props 5814(defun sly-db--goto-last-visible-frame () 5815 (goto-char (point-max)) 5816 (while (not (get-text-property (point) 'frame-string)) 5817 (goto-char (previous-single-property-change (point) 'frame-string)))) 5818 5819(defun sly-db-beginning-of-backtrace () 5820 "Goto the first frame." 5821 (interactive) 5822 (goto-char sly-db-backtrace-start-marker)) 5823 5824 5825;;;;; SLY-DB commands 5826(defun sly-db-cycle () 5827 "Cycle between restart list and backtrace." 5828 (interactive) 5829 (let ((pt (point))) 5830 (cond ((< pt sly-db-restart-list-start-marker) 5831 (goto-char sly-db-restart-list-start-marker)) 5832 ((< pt sly-db-backtrace-start-marker) 5833 (goto-char sly-db-backtrace-start-marker)) 5834 (t 5835 (goto-char sly-db-restart-list-start-marker))))) 5836 5837(defun sly-db-end-of-backtrace () 5838 "Fetch the entire backtrace and go to the last frame." 5839 (interactive) 5840 (sly-db--fetch-all-frames) 5841 (sly-db--goto-last-visible-frame)) 5842 5843(defun sly-db--fetch-all-frames () 5844 (let ((inhibit-read-only t) 5845 (inhibit-point-motion-hooks t)) 5846 (sly-db--goto-last-visible-frame) 5847 (let ((last (sly-db-frame-number-at-point))) 5848 (goto-char (next-single-char-property-change (point) 'frame-string)) 5849 (delete-region (point) (point-max)) 5850 (save-excursion 5851 (insert "\n") 5852 (sly-db-insert-frames (sly-eval `(slynk:backtrace ,(1+ last) nil)) 5853 nil))))) 5854 5855 5856;;;;;; SLY-DB show source 5857(defun sly-db-show-frame-source (frame-number) 5858 "Highlight FRAME-NUMBER's expression in a source code buffer." 5859 (interactive (list (sly-db-frame-number-at-point))) 5860 (sly-eval-async 5861 `(slynk:frame-source-location ,frame-number) 5862 (lambda (source-location) 5863 (sly-dcase source-location 5864 ((:error message) 5865 (sly-message "%s" message) 5866 (ding)) 5867 (t 5868 (sly--display-source-location source-location)))))) 5869 5870 5871;;;;;; SLY-DB toggle details 5872(define-button-type 'sly-db-local-variable :supertype 'sly-part 5873 'sly-button-inspect 5874 #'(lambda (frame-id var-id) 5875 (sly-eval-for-inspector `(slynk:inspect-frame-var ,frame-id 5876 ,var-id)) ) 5877 'sly-button-pretty-print 5878 #'(lambda (frame-id var-id) 5879 (sly-eval-describe `(slynk:pprint-frame-var ,frame-id 5880 ,var-id))) 5881 'sly-button-describe 5882 #'(lambda (frame-id var-id) 5883 (sly-eval-describe `(slynk:describe-frame-var ,frame-id 5884 ,var-id)))) 5885 5886(defun sly-db-local-variable-button (label frame-number var-id &rest props) 5887 (apply #'sly--make-text-button label nil 5888 :type 'sly-db-local-variable 5889 'part-args (list frame-number var-id) 5890 'part-label (format "Local Variable %d" var-id) props)) 5891 5892(defun sly-db-frame-details-region (frame-button) 5893 "Get (BEG END) for FRAME-BUTTON's details, or nil if hidden" 5894 (let ((beg (button-end frame-button)) 5895 (end (1- (field-end (button-start frame-button) 'escape)))) 5896 (unless (= beg end) (list beg end)))) 5897 5898(defun sly-db-toggle-details (frame-button) 5899 "Toggle display of details for the current frame. 5900The details include local variable bindings and CATCH-tags." 5901 (interactive (list (sly-db-frame-button-near-point))) 5902 (if (sly-db-frame-details-region frame-button) 5903 (sly-db-hide-frame-details frame-button) 5904 (sly-db-show-frame-details frame-button))) 5905 5906(defun sly-db-show-frame-details (frame-button) 5907 "Show details for FRAME-BUTTON" 5908 (interactive (list (sly-db-frame-button-near-point))) 5909 (cl-destructuring-bind (locals catches) 5910 (sly-eval `(slynk:frame-locals-and-catch-tags 5911 ,(button-get frame-button 'frame-number))) 5912 (let ((inhibit-read-only t) 5913 (inhibit-point-motion-hooks t)) 5914 (save-excursion 5915 (goto-char (button-end frame-button)) 5916 (let ((indent1 " ") 5917 (indent2 " ")) 5918 (insert "\n" indent1 5919 (sly-db-in-face section (if locals "Locals:" "[No Locals]"))) 5920 (cl-loop for i from 0 5921 for var in locals 5922 with frame-number = (button-get frame-button 'frame-number) 5923 do 5924 (cl-destructuring-bind (&key name id value) var 5925 (insert "\n" 5926 indent2 5927 (sly-db-in-face local-name 5928 (concat name (if (zerop id) 5929 "" 5930 (format "#%d" id)))) 5931 " = " 5932 (sly-db-local-variable-button value 5933 frame-number 5934 i)))) 5935 (when catches 5936 (insert "\n" indent1 (sly-db-in-face section "Catch-tags:")) 5937 (dolist (tag catches) 5938 (sly-propertize-region `(catch-tag ,tag) 5939 (insert "\n" indent2 (sly-db-in-face catch-tag 5940 (format "%s" tag)))))) 5941 ;; The whole details field is propertized accordingly... 5942 ;; 5943 (add-text-properties (button-start frame-button) (point) 5944 (list 'field (button-get frame-button 'field) 5945 'keymap sly-db-frame-map 5946 'nearby-frame-button frame-button)) 5947 ;; ...but we must remember to remove the 'keymap property from 5948 ;; any buttons inside the field 5949 ;; 5950 (cl-loop for pos = (point) then (button-start button) 5951 for button = (previous-button pos) 5952 while (and button 5953 (> (button-start button) 5954 (button-start frame-button))) 5955 do (remove-text-properties (button-start button) 5956 (button-end button) 5957 '(keymap nil)))))) 5958 (sly-recenter (field-end (button-start frame-button) 'escape)))) 5959 5960(defun sly-db-hide-frame-details (frame-button) 5961 (interactive (list (sly-db-frame-button-near-point))) 5962 (let* ((inhibit-read-only t) 5963 (to-delete (sly-db-frame-details-region frame-button))) 5964 (cl-assert to-delete) 5965 (when (and (< (car to-delete) (point)) 5966 (< (point) (cadr to-delete))) 5967 (goto-char (button-start frame-button))) 5968 (apply #'delete-region to-delete))) 5969 5970(defun sly-db-disassemble (frame-number) 5971 "Disassemble the code for frame with FRAME-NUMBER." 5972 (interactive (list (sly-db-frame-number-at-point))) 5973 (sly-eval-async `(slynk:sly-db-disassemble ,frame-number) 5974 (lambda (result) 5975 (sly-show-description result nil)))) 5976 5977 5978;;;;;; SLY-DB eval and inspect 5979 5980(defun sly-db-eval-in-frame (frame-number string package) 5981 "Prompt for an expression and evaluate it in the selected frame." 5982 (interactive (sly-db-frame-eval-interactive "Eval in frame (%s)> ")) 5983 (sly-eval-async `(slynk:eval-string-in-frame ,string ,frame-number ,package) 5984 'sly-display-eval-result)) 5985 5986(defun sly-db-pprint-eval-in-frame (frame-number string package) 5987 "Prompt for an expression, evaluate in selected frame, pretty-print result." 5988 (interactive (sly-db-frame-eval-interactive "Eval in frame (%s)> ")) 5989 (sly-eval-async 5990 `(slynk:pprint-eval-string-in-frame ,string ,frame-number ,package) 5991 (lambda (result) 5992 (sly-show-description result nil)))) 5993 5994(defun sly-db-frame-eval-interactive (fstring) 5995 (let* ((frame-number (sly-db-frame-number-at-point)) 5996 (pkg (sly-eval `(slynk:frame-package-name ,frame-number)))) 5997 (list frame-number 5998 (let ((sly-buffer-package pkg)) 5999 (sly-read-from-minibuffer (format fstring pkg))) 6000 pkg))) 6001 6002(defun sly-db-inspect-in-frame (frame-number string) 6003 "Prompt for an expression and inspect it in the selected frame." 6004 (interactive (list 6005 (sly-db-frame-number-at-point) 6006 (sly-read-from-minibuffer 6007 "Inspect in frame (evaluated): " 6008 (sly-sexp-at-point)))) 6009 (sly-eval-for-inspector `(slynk:inspect-in-frame ,string ,frame-number))) 6010 6011(defun sly-db-inspect-condition () 6012 "Inspect the current debugger condition." 6013 (interactive) 6014 (sly-eval-for-inspector '(slynk:inspect-current-condition))) 6015 6016(defun sly-db-print-condition () 6017 (interactive) 6018 (sly-eval-describe `(slynk:sdlb-print-condition))) 6019 6020 6021;;;;;; SLY-DB movement 6022 6023(defun sly-db-down (arg) 6024 "Move down ARG frames. With negative ARG, move up." 6025 (interactive "p") 6026 (cl-loop 6027 for i from 0 below (abs arg) 6028 do (cl-loop 6029 for tries from 0 below 2 6030 for pos = (point) then next-change 6031 for next-change = (funcall (if (cl-minusp arg) 6032 #'previous-single-char-property-change 6033 #'next-single-char-property-change) 6034 pos 'frame-number) 6035 for prop-value = (get-text-property next-change 'frame-number) 6036 when prop-value do (goto-char next-change) 6037 until prop-value))) 6038 6039(defun sly-db-up (arg) 6040 "Move up ARG frames. With negative ARG, move down." 6041 (interactive "p") 6042 (sly-db-down (- (or arg 1)))) 6043 6044(defun sly-db-sugar-move (move-fn arg) 6045 (let ((current-frame-button (sly-db-frame-button-near-point))) 6046 (when (and current-frame-button 6047 (sly-db-frame-details-region current-frame-button)) 6048 (sly-db-hide-frame-details current-frame-button))) 6049 (funcall move-fn arg) 6050 (let ((frame-button (sly-db-frame-button-near-point))) 6051 (when frame-button 6052 (sly-db-show-frame-source (button-get frame-button 'frame-number)) 6053 (sly-db-show-frame-details frame-button)))) 6054 6055(defun sly-db-details-up (arg) 6056 "Move up ARG frames and show details." 6057 (interactive "p") 6058 (sly-db-sugar-move 'sly-db-up arg)) 6059 6060(defun sly-db-details-down (arg) 6061 "Move down ARG frames and show details." 6062 (interactive "p") 6063 (sly-db-sugar-move 'sly-db-down arg)) 6064 6065 6066;;;;;; SLY-DB restarts 6067 6068(defun sly-db-quit () 6069 "Quit to toplevel." 6070 (interactive) 6071 (cl-assert sly-db-restarts () "sly-db-quit called outside of sly-db buffer") 6072 (sly-rex () ('(slynk:throw-to-toplevel)) 6073 ((:ok x) (error "sly-db-quit returned [%s]" x)) 6074 ((:abort _)))) 6075 6076(defun sly-db-continue () 6077 "Invoke the \"continue\" restart." 6078 (interactive) 6079 (cl-assert sly-db-restarts () "sly-db-continue called outside of sly-db buffer") 6080 (sly-rex () 6081 ('(slynk:sly-db-continue)) 6082 ((:ok _) 6083 (sly-message "No restart named continue") 6084 (ding)) 6085 ((:abort _)))) 6086 6087(defun sly-db-abort () 6088 "Invoke the \"abort\" restart." 6089 (interactive) 6090 (sly-eval-async '(slynk:sly-db-abort) 6091 (lambda (v) (sly-message "Restart returned: %S" v)))) 6092 6093(defun sly-db-invoke-restart (restart-number) 6094 "Invoke the restart number NUMBER. 6095Interactively get the number from a button at point." 6096 (interactive (button-get (sly-button-at (point)) 'restart-number)) 6097 (sly-rex () 6098 ((list 'slynk:invoke-nth-restart-for-emacs sly-db-level restart-number)) 6099 ((:ok value) (sly-message "Restart returned: %s" value)) 6100 ((:abort _)))) 6101 6102(defun sly-db-invoke-restart-by-name (restart-name) 6103 (interactive (list (let ((completion-ignore-case t)) 6104 (sly-completing-read "Restart: " sly-db-restarts nil t 6105 "" 6106 'sly-db-invoke-restart-by-name)))) 6107 (sly-db-invoke-restart (cl-position restart-name sly-db-restarts 6108 :test 'string= :key 'first))) 6109 6110(defun sly-db-break-with-default-debugger (&optional dont-unwind) 6111 "Enter default debugger." 6112 (interactive "P") 6113 (sly-rex () 6114 ((list 'slynk:sly-db-break-with-default-debugger 6115 (not (not dont-unwind))) 6116 nil sly-current-thread) 6117 ((:abort _)))) 6118 6119(defun sly-db-break-with-system-debugger (&optional lightweight) 6120 "Enter system debugger (gdb)." 6121 (interactive "P") 6122 (sly-attach-gdb sly-buffer-connection lightweight)) 6123 6124(defun sly-attach-gdb (connection &optional lightweight) 6125 "Run `gud-gdb'on the connection with PID `pid'. 6126 6127If `lightweight' is given, do not send any request to the 6128inferior Lisp (e.g. to obtain default gdb config) but only 6129operate from the Emacs side; intended for cases where the Lisp is 6130truly screwed up." 6131 (interactive 6132 (list (sly-read-connection "Attach gdb to: " (sly-connection)) "P")) 6133 (let ((pid (sly-pid connection)) 6134 (file (sly-lisp-implementation-program connection)) 6135 (commands (unless lightweight 6136 (let ((sly-dispatching-connection connection)) 6137 (sly-eval `(slynk:gdb-initial-commands)))))) 6138 (gud-gdb (format "gdb -p %d %s" pid (or file ""))) 6139 (with-current-buffer gud-comint-buffer 6140 (dolist (cmd commands) 6141 ;; First wait until gdb was initialized, then wait until current 6142 ;; command was processed. 6143 (while (not (looking-back comint-prompt-regexp (line-beginning-position) 6144 nil)) 6145 (sit-for 0.01)) 6146 ;; We do not use `gud-call' because we want the initial commands 6147 ;; to be displayed by the user so he knows what he's got. 6148 (insert cmd) 6149 (comint-send-input))))) 6150 6151(defun sly-read-connection (prompt &optional initial-value) 6152 "Read a connection from the minibuffer. 6153Return the net process, or nil." 6154 (cl-assert (memq initial-value sly-net-processes)) 6155 (let* ((to-string (lambda (p) 6156 (format "%s (pid %d)" 6157 (sly-connection-name p) (sly-pid p)))) 6158 (candidates (mapcar (lambda (p) (cons (funcall to-string p) p)) 6159 sly-net-processes))) 6160 (cdr (assoc (sly-completing-read prompt candidates 6161 nil t (funcall to-string initial-value)) 6162 candidates)))) 6163 6164(defun sly-db-step (frame-number) 6165 "Step to next basic-block boundary." 6166 (interactive (list (sly-db-frame-number-at-point))) 6167 (sly-eval-async `(slynk:sly-db-step ,frame-number))) 6168 6169(defun sly-db-next (frame-number) 6170 "Step over call." 6171 (interactive (list (sly-db-frame-number-at-point))) 6172 (sly-eval-async `(slynk:sly-db-next ,frame-number))) 6173 6174(defun sly-db-out (frame-number) 6175 "Resume stepping after returning from this function." 6176 (interactive (list (sly-db-frame-number-at-point))) 6177 (sly-eval-async `(slynk:sly-db-out ,frame-number))) 6178 6179(defun sly-db-break-on-return (frame-number) 6180 "Set a breakpoint at the current frame. 6181The debugger is entered when the frame exits." 6182 (interactive (list (sly-db-frame-number-at-point))) 6183 (sly-eval-async `(slynk:sly-db-break-on-return ,frame-number) 6184 (lambda (msg) (sly-message "%s" msg)))) 6185 6186(defun sly-db-break (name) 6187 "Set a breakpoint at the start of the function NAME." 6188 (interactive (list (sly-read-symbol-name "Function: " t))) 6189 (sly-eval-async `(slynk:sly-db-break ,name) 6190 (lambda (msg) (sly-message "%s" msg)))) 6191 6192(defun sly-db-return-from-frame (frame-number string) 6193 "Reads an expression in the minibuffer and causes the function to 6194return that value, evaluated in the context of the frame." 6195 (interactive (list (sly-db-frame-number-at-point) 6196 (sly-read-from-minibuffer "Return from frame: "))) 6197 (sly-rex () 6198 ((list 'slynk:sly-db-return-from-frame frame-number string)) 6199 ((:ok value) (sly-message "%s" value)) 6200 ((:abort _)))) 6201 6202(defun sly-db-restart-frame (frame-number) 6203 "Causes the frame to restart execution with the same arguments as it 6204was called originally." 6205 (interactive (list (sly-db-frame-number-at-point))) 6206 (sly-rex () 6207 ((list 'slynk:restart-frame frame-number)) 6208 ((:ok value) (sly-message "%s" value)) 6209 ((:abort _)))) 6210 6211(defun sly-toggle-break-on-signals () 6212 "Toggle the value of *break-on-signals*." 6213 (interactive) 6214 (sly-eval-async `(slynk:toggle-break-on-signals) 6215 (lambda (msg) (sly-message "%s" msg)))) 6216 6217 6218;;;;;; SLY-DB recompilation commands 6219 6220(defun sly-db-recompile-frame-source (frame-number &optional raw-prefix-arg) 6221 (interactive 6222 (list (sly-db-frame-number-at-point) current-prefix-arg)) 6223 (sly-eval-async 6224 `(slynk:frame-source-location ,frame-number) 6225 (let ((policy (sly-compute-policy raw-prefix-arg))) 6226 (lambda (source-location) 6227 (sly-dcase source-location 6228 ((:error message) 6229 (sly-message "%s" message) 6230 (ding)) 6231 (t 6232 (let ((sly-compilation-policy policy)) 6233 (sly-recompile-location source-location)))))))) 6234 6235 6236;;;; Thread control panel 6237 6238(defvar sly-threads-buffer-timer nil) 6239 6240(defcustom sly-threads-update-interval nil 6241 "Interval at which the list of threads will be updated." 6242 :type '(choice 6243 (number :value 0.5) 6244 (const nil)) 6245 :group 'sly-ui) 6246 6247(defun sly-list-threads () 6248 "Display a list of threads." 6249 (interactive) 6250 (let ((name (sly-buffer-name :threads 6251 :connection t))) 6252 (sly-with-popup-buffer (name :connection t 6253 :mode 'sly-thread-control-mode) 6254 (sly-update-threads-buffer (current-buffer)) 6255 (goto-char (point-min)) 6256 (when sly-threads-update-interval 6257 (when sly-threads-buffer-timer 6258 (cancel-timer sly-threads-buffer-timer)) 6259 (setq sly-threads-buffer-timer 6260 (run-with-timer 6261 sly-threads-update-interval 6262 sly-threads-update-interval 6263 'sly-update-threads-buffer 6264 (current-buffer)))) 6265 (add-hook 'kill-buffer-hook 'sly--threads-buffer-teardown 6266 'append 'local)))) 6267 6268(defun sly--threads-buffer-teardown () 6269 (when sly-threads-buffer-timer 6270 (cancel-timer sly-threads-buffer-timer)) 6271 (when (process-live-p sly-buffer-connection) 6272 (sly-eval-async `(slynk:quit-thread-browser)))) 6273 6274(defun sly-update-threads-buffer (&optional buffer) 6275 (interactive) 6276 (with-current-buffer (or buffer 6277 (current-buffer)) 6278 (sly-eval-async '(slynk:list-threads) 6279 #'(lambda (threads) 6280 (with-current-buffer (current-buffer) 6281 (sly--display-threads threads)))))) 6282 6283(defun sly-move-point (position) 6284 "Move point in the current buffer and in the window the buffer is displayed." 6285 (let ((window (get-buffer-window (current-buffer) t))) 6286 (goto-char position) 6287 (when window 6288 (set-window-point window position)))) 6289 6290(defun sly--display-threads (threads) 6291 (let* ((inhibit-read-only t) 6292 (old-thread-id (get-text-property (point) 'thread-id)) 6293 (old-line (line-number-at-pos)) 6294 (old-column (current-column))) 6295 (erase-buffer) 6296 (sly-insert-threads threads) 6297 (let ((new-line (cl-position old-thread-id (cdr threads) 6298 :key #'car :test #'equal))) 6299 (goto-char (point-min)) 6300 (forward-line (or new-line old-line)) 6301 (move-to-column old-column) 6302 (sly-move-point (point))))) 6303 6304(defun sly-transpose-lists (list-of-lists) 6305 (let ((ncols (length (car list-of-lists)))) 6306 (cl-loop for col-index below ncols 6307 collect (cl-loop for row in list-of-lists 6308 collect (elt row col-index))))) 6309 6310(defun sly-insert-table-row (line line-props col-props col-widths) 6311 (sly-propertize-region line-props 6312 (cl-loop for string in line 6313 for col-prop in col-props 6314 for width in col-widths do 6315 (sly-insert-propertized col-prop string) 6316 (insert-char ?\ (- width (length string)))))) 6317 6318(defun sly-insert-table (rows header row-properties column-properties) 6319 "Insert a \"table\" so that the columns are nicely aligned." 6320 (let* ((ncols (length header)) 6321 (lines (cons header rows)) 6322 (widths (cl-loop for columns in (sly-transpose-lists lines) 6323 collect (1+ (cl-loop for cell in columns 6324 maximize (length cell))))) 6325 (header-line (with-temp-buffer 6326 (sly-insert-table-row 6327 header nil (make-list ncols nil) widths) 6328 (buffer-string)))) 6329 (cond ((boundp 'header-line-format) 6330 (setq header-line-format header-line)) 6331 (t (insert header-line "\n"))) 6332 (cl-loop for line in rows for line-props in row-properties do 6333 (sly-insert-table-row line line-props column-properties widths) 6334 (insert "\n")))) 6335 6336(defvar sly-threads-table-properties 6337 '(nil (face bold))) 6338 6339(defun sly-insert-threads (threads) 6340 (let* ((labels (car threads)) 6341 (threads (cdr threads)) 6342 (header (cl-loop for label in labels collect 6343 (capitalize (substring (symbol-name label) 1)))) 6344 (rows (cl-loop for thread in threads collect 6345 (cl-loop for prop in thread collect 6346 (format "%s" prop)))) 6347 (line-props (cl-loop for (id) in threads for i from 0 6348 collect `(thread-index ,i thread-id ,id))) 6349 (col-props (cl-loop for nil in labels for i from 0 collect 6350 (nth i sly-threads-table-properties)))) 6351 (sly-insert-table rows header line-props col-props))) 6352 6353 6354;;;;; Major mode 6355(defvar sly-thread-control-mode-map 6356 (let ((map (make-sparse-keymap))) 6357 (define-key map "a" 'sly-thread-attach) 6358 (define-key map "d" 'sly-thread-debug) 6359 (define-key map "g" 'sly-update-threads-buffer) 6360 (define-key map "k" 'sly-thread-kill) 6361 (define-key map "q" 'quit-window) 6362 map)) 6363 6364(define-derived-mode sly-thread-control-mode fundamental-mode 6365 "Threads" 6366 "SLY Thread Control Panel Mode. 6367 6368\\{sly-thread-control-mode-map}" 6369 (when sly-truncate-lines 6370 (set (make-local-variable 'truncate-lines) t)) 6371 (read-only-mode 1) 6372 (sly-mode 1) 6373 (setq buffer-undo-list t)) 6374 6375(defun sly-thread-kill () 6376 (interactive) 6377 (sly-eval `(cl:mapc 'slynk:kill-nth-thread 6378 ',(sly-get-properties 'thread-index))) 6379 (call-interactively 'sly-update-threads-buffer)) 6380 6381(defun sly-get-region-properties (prop start end) 6382 (cl-loop for position = (if (get-text-property start prop) 6383 start 6384 (next-single-property-change start prop)) 6385 then (next-single-property-change position prop) 6386 while (<= position end) 6387 collect (get-text-property position prop))) 6388 6389(defun sly-get-properties (prop) 6390 (if (use-region-p) 6391 (sly-get-region-properties prop 6392 (region-beginning) 6393 (region-end)) 6394 (let ((value (get-text-property (point) prop))) 6395 (when value 6396 (list value))))) 6397 6398(defun sly-thread-attach () 6399 (interactive) 6400 (let ((id (get-text-property (point) 'thread-index)) 6401 (file (sly-slynk-port-file))) 6402 (sly-eval-async `(slynk:start-slynk-server-in-thread ,id ,file))) 6403 (sly-read-port-and-connect nil)) 6404 6405(defun sly-thread-debug () 6406 (interactive) 6407 (let ((id (get-text-property (point) 'thread-index))) 6408 (sly-eval-async `(slynk:debug-nth-thread ,id)))) 6409 6410 6411;;;;; Connection listing 6412 6413(defvar sly-connection-list-mode-map 6414 (let ((map (make-sparse-keymap))) 6415 (define-key map "d" 'sly-connection-list-make-default) 6416 (define-key map "g" 'sly-update-connection-list) 6417 (define-key map (kbd "RET") 'sly-connection-list-default-action) 6418 (define-key map (kbd "C-m") 'sly-connection-list-default-action) 6419 (define-key map (kbd "C-k") 'sly-quit-connection-at-point) 6420 (define-key map (kbd "R") 'sly-restart-connection-at-point) 6421 (define-key map (kbd "q") 'quit-window) 6422 map)) 6423 6424(define-derived-mode sly-connection-list-mode tabulated-list-mode 6425 "SLY-Connections" 6426 "SLY Connection List Mode. 6427 6428\\{sly-connection-list-mode-map}" 6429 (set (make-local-variable 'tabulated-list-format) 6430 `[("Default" 8) ("Name" 24 t) ("Host" 12) 6431 ("Port" 6) ("Pid" 6 t) ("Type" 1000 t)]) 6432 (tabulated-list-init-header)) 6433 6434(defun sly--connection-at-point () 6435 (or (get-text-property (point) 'tabulated-list-id) 6436 (error "No connection at point"))) 6437 6438(defvar sly-connection-list-button-action nil) 6439 6440(defun sly-connection-list-default-action (connection) 6441 (interactive (list (sly--connection-at-point))) 6442 (funcall sly-connection-list-button-action connection)) 6443 6444(defun sly-update-connection-list () 6445 (interactive) 6446 (set (make-local-variable 'tabulated-list-entries) 6447 (mapcar 6448 #'(lambda (p) 6449 (list p 6450 `[,(if (eq sly-default-connection p) "*" " ") 6451 (,(file-name-nondirectory (or (sly-connection-name p) 6452 "unknown")) 6453 action 6454 ,#'(lambda (_button) 6455 (and sly-connection-list-button-action 6456 (funcall sly-connection-list-button-action p)))) 6457 ,(car (process-contact p)) 6458 ,(format "%s" (cl-second (process-contact p))) 6459 ,(format "%s" (sly-pid p)) 6460 ,(or (sly-lisp-implementation-type p) 6461 "unknown")])) 6462 (reverse sly-net-processes))) 6463 (let ((p (point))) 6464 (tabulated-list-print) 6465 (goto-char p))) 6466 6467(defun sly-quit-connection-at-point (connection) 6468 (interactive (list (sly--connection-at-point))) 6469 (let ((sly-dispatching-connection connection) 6470 (end (time-add (current-time) (seconds-to-time 3)))) 6471 (sly-quit-lisp t) 6472 (while (memq connection sly-net-processes) 6473 (when (time-less-p end (current-time)) 6474 (sly-message "Quit timeout expired. Disconnecting.") 6475 (delete-process connection)) 6476 (sit-for 0 100))) 6477 (sly-update-connection-list)) 6478 6479(defun sly-restart-connection-at-point (connection) 6480 (interactive (list (sly--connection-at-point))) 6481 (let ((sly-dispatching-connection connection)) 6482 (sly-restart-inferior-lisp))) 6483 6484(defun sly-connection-list-make-default () 6485 "Make the connection at point the default connection." 6486 (interactive) 6487 (sly-select-connection (sly--connection-at-point)) 6488 (sly-update-connection-list)) 6489 6490(defun sly-list-connections () 6491 "Display a list of all connections." 6492 (interactive) 6493 (sly-with-popup-buffer ((sly-buffer-name :connections) 6494 :mode 'sly-connection-list-mode) 6495 (sly-update-connection-list))) 6496 6497 6498 6499;;;; Inspector 6500 6501(defgroup sly-inspector nil 6502 "Options for the SLY inspector." 6503 :prefix "sly-inspector-" 6504 :group 'sly) 6505 6506(defvar sly--this-inspector-name nil 6507 "Buffer-local inspector name (a string), or nil") 6508 6509(cl-defun sly-eval-for-inspector (slyfun-and-args 6510 &key (error-message "Couldn't inspect") 6511 restore-point 6512 save-selected-window 6513 (inspector-name sly--this-inspector-name) 6514 opener) 6515 (if (cl-some #'listp slyfun-and-args) 6516 (sly-warning 6517 "`sly-eval-for-inspector' not meant to be passed a generic form")) 6518 (let ((pos (and (eq major-mode 'sly-inspector-mode) 6519 (sly-inspector-position)))) 6520 (sly-eval-async `(slynk:eval-for-inspector 6521 ,sly--this-inspector-name ; current inspector, if any 6522 ,inspector-name ; target inspector, if any 6523 ',(car slyfun-and-args) 6524 ,@(cdr slyfun-and-args)) 6525 (or opener 6526 (lambda (results) 6527 (let ((opener (lambda () 6528 (sly--open-inspector 6529 results 6530 :point (and restore-point pos) 6531 :inspector-name inspector-name 6532 :switch (not save-selected-window))))) 6533 (cond (results 6534 (funcall opener)) 6535 (t 6536 (sly-message error-message))))))))) 6537 6538(defun sly-read-inspector-name () 6539 (let* ((names (cl-loop for b in (buffer-list) 6540 when (with-current-buffer b 6541 (and (eq sly-buffer-connection 6542 (sly-current-connection)) 6543 (eq major-mode 'sly-inspector-mode))) 6544 when (buffer-local-value 'sly--this-inspector-name b) 6545 collect it)) 6546 (result (sly-completing-read "Inspector name: " (cons "default" 6547 names) 6548 nil nil nil nil "default"))) 6549 (unless (string= result "default") 6550 result))) 6551 6552(defun sly-maybe-read-inspector-name () 6553 (or (and current-prefix-arg 6554 (sly-read-inspector-name)) 6555 sly--this-inspector-name)) 6556 6557(defun sly-inspect (string &optional inspector-name) 6558 "Eval an expression and inspect the result." 6559 (interactive 6560 (let* ((name (sly-maybe-read-inspector-name)) 6561 (string (sly-read-from-minibuffer 6562 (concat "Inspect value" 6563 (and name 6564 (format " in inspector \"%s\"" name)) 6565 " (evaluated): ") 6566 (sly-sexp-at-point 'interactive nil nil)))) 6567 (list string name))) 6568 (sly-eval-for-inspector `(slynk:init-inspector ,string) 6569 :inspector-name inspector-name)) 6570 6571(defvar sly-inspector-mode-map 6572 (let ((map (make-sparse-keymap))) 6573 (define-key map "l" 'sly-inspector-pop) 6574 (define-key map "n" 'sly-inspector-next) 6575 (define-key map [mouse-6] 'sly-inspector-pop) 6576 (define-key map [mouse-7] 'sly-inspector-next) 6577 6578 (define-key map " " 'sly-inspector-next) 6579 (define-key map "D" 'sly-inspector-describe-inspectee) 6580 (define-key map "e" 'sly-inspector-eval) 6581 (define-key map "h" 'sly-inspector-history) 6582 (define-key map "g" 'sly-inspector-reinspect) 6583 (define-key map ">" 'sly-inspector-fetch-all) 6584 (define-key map "q" 'sly-inspector-quit) 6585 6586 (set-keymap-parent map button-buffer-map) 6587 map)) 6588 6589(define-derived-mode sly-inspector-mode fundamental-mode 6590 "SLY-Inspector" 6591 " 6592\\{sly-inspector-mode-map}" 6593 (set-syntax-table lisp-mode-syntax-table) 6594 (sly-set-truncate-lines) 6595 (setq buffer-read-only t) 6596 (sly-mode 1)) 6597 6598(define-button-type 'sly-inspector-part :supertype 'sly-part 6599 'sly-button-inspect 6600 #'(lambda (id) 6601 (sly-eval-for-inspector `(slynk:inspect-nth-part ,id) 6602 :inspector-name (sly-maybe-read-inspector-name))) 6603 'sly-button-pretty-print 6604 #'(lambda (id) 6605 (sly-eval-describe `(slynk:pprint-inspector-part ,id))) 6606 'sly-button-describe 6607 #'(lambda (id) 6608 (sly-eval-describe `(slynk:describe-inspector-part ,id))) 6609 'sly-button-show-source 6610 #'(lambda (id) 6611 (sly-eval-async 6612 `(slynk:find-source-location-for-emacs '(:inspector ,id)) 6613 #'(lambda (result) 6614 (sly--display-source-location result 'noerror))))) 6615 6616(defun sly-inspector-part-button (label id &rest props) 6617 (apply #'sly--make-text-button 6618 label nil 6619 :type 'sly-inspector-part 6620 'part-args (list id) 6621 'part-label "Inspector Object" 6622 props)) 6623 6624(defmacro sly-inspector-fontify (face string) 6625 `(sly-add-face ',(intern (format "sly-inspector-%s-face" face)) ,string)) 6626 6627(cl-defun sly--open-inspector (inspected-parts 6628 &key point kill-hook inspector-name (switch t)) 6629 "Display INSPECTED-PARTS in a new inspector window. 6630Optionally set point to POINT. If KILL-HOOK is provided, it is 6631added to local KILL-BUFFER hooks for the inspector 6632buffer. INSPECTOR-NAME is the name of the target inspector, or 6633nil if the default one is to be used. SWITCH indicates the 6634buffer should be switched to (defaults to t)" 6635 (sly-with-popup-buffer ((sly-buffer-name :inspector 6636 :connection t 6637 :suffix inspector-name) 6638 :mode 'sly-inspector-mode 6639 :select switch 6640 :same-window-p 6641 (and (eq major-mode 'sly-inspector-mode) 6642 (or (null inspector-name) 6643 (eq sly--this-inspector-name inspector-name))) 6644 :connection t) 6645 (when kill-hook 6646 (add-hook 'kill-buffer-hook kill-hook t t)) 6647 (set (make-local-variable 'sly--this-inspector-name) inspector-name) 6648 (cl-destructuring-bind (&key id title content) inspected-parts 6649 (cl-macrolet ((fontify (face string) 6650 `(sly-inspector-fontify ,face ,string))) 6651 (insert (sly-inspector-part-button title id 'skip t)) 6652 (while (eq (char-before) ?\n) 6653 (backward-delete-char 1)) 6654 (insert "\n" (fontify label "--------------------") "\n") 6655 (save-excursion 6656 (sly-inspector-insert-content content)) 6657 (when point 6658 (cl-check-type point cons) 6659 (ignore-errors 6660 (goto-char (point-min)) 6661 (forward-line (1- (car point))) 6662 (move-to-column (cdr point)))))) 6663 (buffer-disable-undo))) 6664 6665(defvar sly-inspector-limit 500) 6666 6667(defun sly-inspector-insert-content (content) 6668 (sly-inspector-fetch-chunk 6669 content nil 6670 (lambda (chunk) 6671 (let ((inhibit-read-only t)) 6672 (sly-inspector-insert-chunk chunk t t))))) 6673 6674(defun sly-inspector-insert-chunk (chunk prev next) 6675 "Insert CHUNK at point. 6676If PREV resp. NEXT are true insert more-buttons as needed." 6677 (cl-destructuring-bind (ispecs len start end) chunk 6678 (when (and prev (> start 0)) 6679 (sly-inspector-insert-more-button start t)) 6680 (mapc #'sly-inspector-insert-ispec ispecs) 6681 (when (and next (< end len)) 6682 (sly-inspector-insert-more-button end nil)))) 6683 6684(defun sly-inspector-insert-ispec (ispec) 6685 (insert 6686 (if (stringp ispec) ispec 6687 (sly-dcase ispec 6688 ((:value string id) 6689 (sly-inspector-part-button string id)) 6690 ((:label string) 6691 (sly-inspector-fontify label string)) 6692 ((:action string id) 6693 (sly-make-action-button 6694 string 6695 #'(lambda (_button) 6696 (sly-eval-for-inspector `(slynk::inspector-call-nth-action ,id) 6697 :restore-point t)))))))) 6698 6699(defun sly-inspector-position () 6700 "Return a pair (Y-POSITION X-POSITION) representing the 6701position of point in the current buffer." 6702 ;; We make sure we return absolute coordinates even if the user has 6703 ;; narrowed the buffer. 6704 ;; FIXME: why would somebody narrow the buffer? 6705 (save-restriction 6706 (widen) 6707 (cons (line-number-at-pos) 6708 (current-column)))) 6709 6710(defun sly-inspector-pop () 6711 "Reinspect the previous object." 6712 (interactive) 6713 (sly-eval-for-inspector `(slynk:inspector-pop) 6714 :error-message "No previous object")) 6715 6716(defun sly-inspector-next () 6717 "Inspect the next object in the history." 6718 (interactive) 6719 (sly-eval-for-inspector `(slynk:inspector-next) 6720 :error-message "No next object")) 6721 6722(defun sly-inspector-quit (&optional reset) 6723 "Quit the inspector and kill the buffer. 6724With optional RESET (true with prefix arg), also reset the 6725inspector on the Lisp side." 6726 (interactive "P") 6727 (when reset (sly-eval-async `(slynk:quit-inspector))) 6728 (quit-window)) 6729 6730(defun sly-inspector-describe-inspectee () 6731 "Describe the currently inspected object" 6732 (interactive) 6733 (sly-eval-describe `(slynk:describe-inspectee))) 6734 6735(defun sly-inspector-eval (string) 6736 "Eval an expression in the context of the inspected object. 6737The `*' variable will be bound to the inspected object." 6738 (interactive (list (sly-read-from-minibuffer "Inspector eval: "))) 6739 (sly-eval-with-transcript `(slynk:inspector-eval ,string))) 6740 6741(defun sly-inspector-history () 6742 "Show the previously inspected objects." 6743 (interactive) 6744 (sly-eval-describe `(slynk:inspector-history))) 6745 6746(defun sly-inspector-reinspect (&optional inspector-name) 6747 (interactive (list (sly-maybe-read-inspector-name))) 6748 (sly-eval-for-inspector `(slynk:inspector-reinspect) 6749 :inspector-name inspector-name)) 6750 6751(defun sly-inspector-toggle-verbose () 6752 (interactive) 6753 (sly-eval-for-inspector `(slynk:inspector-toggle-verbose))) 6754 6755(defun sly-inspector-insert-more-button (index previous) 6756 (insert (sly-make-action-button 6757 (if previous " [--more--]\n" " [--more--]") 6758 #'sly-inspector-fetch-more 6759 'range-args (list index previous)))) 6760 6761(defun sly-inspector-fetch-all () 6762 "Fetch all inspector contents and go to the end." 6763 (interactive) 6764 (let ((button (button-at (1- (point-max))))) 6765 (cond ((and button 6766 (button-get button 'range-args)) 6767 (let (sly-inspector-limit) 6768 (sly-inspector-fetch-more button))) 6769 (t 6770 (sly-error "No more elements to fetch"))))) 6771 6772(defun sly-inspector-fetch-more (button) 6773 (cl-destructuring-bind (index prev) (button-get button 'range-args) 6774 (sly-inspector-fetch-chunk 6775 (list '() (1+ index) index index) prev 6776 (sly-rcurry 6777 (lambda (chunk prev) 6778 (let ((inhibit-read-only t)) 6779 (delete-region (button-start button) (button-end button)) 6780 (sly-inspector-insert-chunk chunk prev (not prev)))) 6781 prev)))) 6782 6783(defun sly-inspector-fetch-chunk (chunk prev cont) 6784 (sly-inspector-fetch chunk sly-inspector-limit prev cont)) 6785 6786(defun sly-inspector-fetch (chunk limit prev cont) 6787 (cl-destructuring-bind (from to) 6788 (sly-inspector-next-range chunk limit prev) 6789 (cond ((and from to) 6790 (sly-eval-for-inspector 6791 `(slynk:inspector-range ,from ,to) 6792 :opener (sly-rcurry (lambda (chunk2 chunk1 limit prev cont) 6793 (sly-inspector-fetch 6794 (sly-inspector-join-chunks chunk1 chunk2) 6795 limit prev cont)) 6796 chunk limit prev cont))) 6797 (t (funcall cont chunk))))) 6798 6799(defun sly-inspector-next-range (chunk limit prev) 6800 (cl-destructuring-bind (_ len start end) chunk 6801 (let ((count (- end start))) 6802 (cond ((and prev (< 0 start) (or (not limit) (< count limit))) 6803 (list (if limit (max (- end limit) 0) 0) start)) 6804 ((and (not prev) (< end len) (or (not limit) (< count limit))) 6805 (list end (if limit (+ start limit) most-positive-fixnum))) 6806 (t '(nil nil)))))) 6807 6808(defun sly-inspector-join-chunks (chunk1 chunk2) 6809 (cl-destructuring-bind (i1 _l1 s1 e1) chunk1 6810 (cl-destructuring-bind (i2 l2 s2 e2) chunk2 6811 (cond ((= e1 s2) 6812 (list (append i1 i2) l2 s1 e2)) 6813 ((= e2 s1) 6814 (list (append i2 i1) l2 s2 e1)) 6815 (t (error "Invalid chunks")))))) 6816 6817 6818;;;; Indentation 6819 6820(defun sly-update-indentation () 6821 "Update indentation for all macros defined in the Lisp system." 6822 (interactive) 6823 (sly-eval-async '(slynk:update-indentation-information))) 6824 6825(defvar sly-indentation-update-hooks) 6826 6827(defun sly-intern-indentation-spec (spec) 6828 (cond ((consp spec) 6829 (cons (sly-intern-indentation-spec (car spec)) 6830 (sly-intern-indentation-spec (cdr spec)))) 6831 ((stringp spec) 6832 (intern spec)) 6833 (t 6834 spec))) 6835 6836;; FIXME: restore the old version without per-package 6837;; stuff. sly-indentation.el should be able tho disable the simple 6838;; version if needed. 6839(defun sly-handle-indentation-update (alist) 6840 "Update Lisp indent information. 6841 6842ALIST is a list of (SYMBOL-NAME . INDENT-SPEC) of proposed indentation 6843settings for `sly-common-lisp-indent-function'. The appropriate property 6844is setup, unless the user already set one explicitly." 6845 (dolist (info alist) 6846 (let ((symbol (intern (car info))) 6847 (indent (sly-intern-indentation-spec (cl-second info))) 6848 (packages (cl-third info))) 6849 (if (and (boundp 'sly-common-lisp-system-indentation) 6850 (fboundp 'sly-update-system-indentation)) 6851 ;; A table provided by sly-cl-indent.el. 6852 (funcall #'sly-update-system-indentation symbol indent packages) 6853 ;; Does the symbol have an indentation value that we set? 6854 (when (equal (get symbol 'sly-common-lisp-indent-function) 6855 (get symbol 'sly-indent)) 6856 (put symbol 'sly-common-lisp-indent-function indent) 6857 (put symbol 'sly-indent indent))) 6858 (run-hook-with-args 'sly-indentation-update-hooks 6859 symbol indent packages)))) 6860 6861 6862;;;; Contrib modules 6863 6864(defun sly-contrib--load-slynk-dependencies () 6865 (let ((needed (cl-remove-if (lambda (s) 6866 (cl-find (symbol-name s) 6867 (sly-lisp-modules) 6868 :key #'downcase 6869 :test #'string=)) 6870 sly-contrib--required-slynk-modules 6871 :key #'car))) 6872 (when needed 6873 ;; No asynchronous request because with :SPAWN that could result 6874 ;; in the attempt to load modules concurrently which may not be 6875 ;; supported by the host Lisp. 6876 (sly-eval `(slynk:slynk-add-load-paths ',(cl-remove-duplicates 6877 (mapcar #'cl-second needed) 6878 :test #'string=))) 6879 (let* ((result (sly-eval 6880 `(slynk:slynk-require 6881 ',(mapcar #'symbol-name (mapcar #'cl-first needed))))) 6882 (all-modules (cl-first result)) 6883 (loaded-now (cl-second result))) 6884 ;; check if everything went OK 6885 ;; 6886 (cl-loop for n in needed 6887 unless (cl-find (cl-first n) loaded-now :test #'string=) 6888 6889 ;; string= compares symbols and strings nicely 6890 ;; 6891 do (when (y-or-n-p (format 6892 "\ 6893Watch out! SLY failed to load SLYNK module %s for contrib %s!\n 6894Disable it?" (cl-first n) (cl-third n))) 6895 (sly-disable-contrib (cl-third n)) 6896 (sly-temp-message 3 3 "\ 6897You'll need to re-enable %s manually with `sly-enable-contrib'\ 6898if/when you fix the error" (cl-third n)))) 6899 ;; Update the connection-local list of all *MODULES* 6900 ;; 6901 (setf (sly-lisp-modules) all-modules))))) 6902 6903(cl-defstruct (sly-contrib 6904 (:conc-name sly-contrib--)) 6905 enabled-p 6906 name 6907 sly-dependencies 6908 slynk-dependencies 6909 enable 6910 disable 6911 authors 6912 license) 6913 6914(defmacro define-sly-contrib (name _docstring &rest clauses) 6915 (declare (indent 1)) 6916 (cl-destructuring-bind (&key sly-dependencies 6917 slynk-dependencies 6918 on-load 6919 on-unload 6920 authors 6921 license) 6922 (cl-loop for (key . value) in clauses append `(,key ,value)) 6923 (cl-labels 6924 ((enable-fn (c) (intern (concat (symbol-name c) "-init"))) 6925 (disable-fn (c) (intern (concat (symbol-name c) "-unload"))) 6926 (path-sym (c) (intern (concat (symbol-name c) "--path"))) 6927 (contrib-sym (c) (intern (concat (symbol-name c) "--contrib")))) 6928 `(progn 6929 (defvar ,(path-sym name)) 6930 (defvar ,(contrib-sym name)) 6931 (setq ,(path-sym name) (and load-file-name 6932 (file-name-directory load-file-name))) 6933 (eval-when-compile 6934 (when byte-compile-current-file; protect against eager macro expansion 6935 (add-to-list 'load-path 6936 (file-name-as-directory 6937 (file-name-directory byte-compile-current-file))))) 6938 (setq ,(contrib-sym name) 6939 (put 'sly-contribs ',name 6940 (make-sly-contrib 6941 :name ',name :authors ',authors :license ',license 6942 :sly-dependencies ',sly-dependencies 6943 :slynk-dependencies ',slynk-dependencies 6944 :enable ',(enable-fn name) :disable ',(disable-fn name)))) 6945 ,@(mapcar (lambda (d) `(require ',d)) sly-dependencies) 6946 (defun ,(enable-fn name) () 6947 (mapc #'funcall (mapcar 6948 #'sly-contrib--enable 6949 (cl-remove-if #'sly-contrib--enabled-p 6950 (list ,@(mapcar #'contrib-sym 6951 sly-dependencies))))) 6952 (cl-loop for dep in ',slynk-dependencies 6953 do (cl-pushnew (list dep ,(path-sym name) ',name) 6954 sly-contrib--required-slynk-modules 6955 :key #'cl-first)) 6956 ;; FIXME: It's very tricky to do Slynk calls like 6957 ;; `sly-contrib--load-slynk-dependencies' here, and it this 6958 ;; should probably loop all connections. Anyway, we try 6959 ;; ensure this can only happen from an interactive 6960 ;; `sly-setup' call. 6961 ;; 6962 (when (and (eq this-command 'sly-setup) 6963 (sly-connected-p)) 6964 (sly-contrib--load-slynk-dependencies)) 6965 ,@on-load 6966 (setf (sly-contrib--enabled-p ,(contrib-sym name)) t)) 6967 (defun ,(disable-fn name) () 6968 ,@on-unload 6969 (cl-loop for dep in ',slynk-dependencies 6970 do (setq sly-contrib--required-slynk-modules 6971 (cl-remove dep sly-contrib--required-slynk-modules 6972 :key #'cl-first))) 6973 (sly-warning "Disabling contrib %s" ',name) 6974 (mapc #'funcall (mapcar 6975 #'sly-contrib--disable 6976 (cl-remove-if-not #'sly-contrib--enabled-p 6977 (list ,@(mapcar #'contrib-sym 6978 sly-dependencies))))) 6979 (setf (sly-contrib--enabled-p ,(contrib-sym name)) nil)))))) 6980 6981(defun sly-contrib--all-contribs () 6982 "All defined `sly-contrib' objects." 6983 (cl-loop for (nil val) on (symbol-plist 'sly-contribs) by #'cddr 6984 when (sly-contrib-p val) 6985 collect val)) 6986 6987(defun sly-contrib--all-dependencies (contrib) 6988 "Contrib names recursively needed by CONTRIB, including self." 6989 (sly--contrib-safe contrib 6990 (cons contrib 6991 (cl-mapcan #'sly-contrib--all-dependencies 6992 (sly-contrib--sly-dependencies 6993 (sly-contrib--find-contrib contrib)))))) 6994 6995(defun sly-contrib--find-contrib (designator) 6996 (if (sly-contrib-p designator) 6997 designator 6998 (or (get 'sly-contribs designator) 6999 (error "Unknown contrib: %S" designator)))) 7000 7001(defun sly-contrib--read-contrib-name () 7002 (let ((names (cl-loop for c in (sly-contrib--all-contribs) collect 7003 (symbol-name (sly-contrib--name c))))) 7004 (intern (sly-completing-read "Contrib: " names nil t)))) 7005 7006(defun sly-enable-contrib (name) 7007 "Attempt to enable contrib NAME." 7008 (interactive (list (sly-contrib--read-contrib-name))) 7009 (sly--contrib-safe name 7010 (funcall (sly-contrib--enable (sly-contrib--find-contrib name))))) 7011 7012(defun sly-disable-contrib (name) 7013 "Attempt to disable contrib NAME." 7014 (interactive (list (sly-contrib--read-contrib-name))) 7015 (sly--contrib-safe name 7016 (funcall (sly-contrib--disable (sly-contrib--find-contrib name))))) 7017 7018 7019;;;;; Pull-down menu 7020(easy-menu-define sly-menu sly-mode-map "SLY" 7021 (let ((C '(sly-connected-p))) 7022 `("SLY" 7023 [ "Edit Definition..." sly-edit-definition ,C ] 7024 [ "Return From Definition" sly-pop-find-definition-stack ,C ] 7025 [ "Complete Symbol" sly-complete-symbol ,C ] 7026 "--" 7027 ("Evaluation" 7028 [ "Eval Defun" sly-eval-defun ,C ] 7029 [ "Eval Last Expression" sly-eval-last-expression ,C ] 7030 [ "Eval And Pretty-Print" sly-pprint-eval-last-expression ,C ] 7031 [ "Eval Region" sly-eval-region ,C ] 7032 [ "Eval Region And Pretty-Print" sly-pprint-eval-region ,C ] 7033 [ "Interactive Eval..." sly-interactive-eval ,C ] 7034 [ "Edit Lisp Value..." sly-edit-value ,C ] 7035 [ "Call Defun" sly-call-defun ,C ]) 7036 ("Debugging" 7037 [ "Inspect..." sly-inspect ,C ] 7038 [ "Macroexpand Once..." sly-macroexpand-1 ,C ] 7039 [ "Macroexpand All..." sly-macroexpand-all ,C ] 7040 [ "Disassemble..." sly-disassemble-symbol ,C ]) 7041 ("Compilation" 7042 [ "Compile Defun" sly-compile-defun ,C ] 7043 [ "Compile and Load File" sly-compile-and-load-file ,C ] 7044 [ "Compile File" sly-compile-file ,C ] 7045 [ "Compile Region" sly-compile-region ,C ] 7046 "--" 7047 [ "Next Note" sly-next-note t ] 7048 [ "Previous Note" sly-previous-note t ] 7049 [ "Remove Notes" sly-remove-notes t ] 7050 [ "List notes" sly-show-compilation-log t ]) 7051 ("Cross Reference" 7052 [ "Who Calls..." sly-who-calls ,C ] 7053 [ "Who References... " sly-who-references ,C ] 7054 [ "Who Sets..." sly-who-sets ,C ] 7055 [ "Who Binds..." sly-who-binds ,C ] 7056 [ "Who Macroexpands..." sly-who-macroexpands ,C ] 7057 [ "Who Specializes..." sly-who-specializes ,C ] 7058 [ "List Callers..." sly-list-callers ,C ] 7059 [ "List Callees..." sly-list-callees ,C ] 7060 [ "Next Location" sly-next-location t ]) 7061 ("Editing" 7062 [ "Check Parens" check-parens t] 7063 [ "Update Indentation" sly-update-indentation ,C]) 7064 ("Documentation" 7065 [ "Describe Symbol..." sly-describe-symbol ,C ] 7066 [ "Lookup Documentation..." sly-documentation-lookup t ] 7067 [ "Apropos..." sly-apropos ,C ] 7068 [ "Apropos all..." sly-apropos-all ,C ] 7069 [ "Apropos Package..." sly-apropos-package ,C ] 7070 [ "Hyperspec..." sly-hyperspec-lookup t ]) 7071 "--" 7072 [ "Interrupt Command" sly-interrupt ,C ] 7073 [ "Abort Async. Command" sly-quit ,C ]))) 7074 7075(easy-menu-define sly-sly-db-menu sly-db-mode-map "SLY-DB Menu" 7076 (let ((C '(sly-connected-p))) 7077 `("SLY-DB" 7078 [ "Next Frame" sly-db-down t ] 7079 [ "Previous Frame" sly-db-up t ] 7080 [ "Toggle Frame Details" sly-db-toggle-details t ] 7081 [ "Next Frame (Details)" sly-db-details-down t ] 7082 [ "Previous Frame (Details)" sly-db-details-up t ] 7083 "--" 7084 [ "Eval Expression..." sly-interactive-eval ,C ] 7085 [ "Eval in Frame..." sly-db-eval-in-frame ,C ] 7086 [ "Eval in Frame (pretty print)..." sly-db-pprint-eval-in-frame ,C ] 7087 [ "Inspect In Frame..." sly-db-inspect-in-frame ,C ] 7088 [ "Inspect Condition Object" sly-db-inspect-condition ,C ] 7089 "--" 7090 [ "Restart Frame" sly-db-restart-frame ,C ] 7091 [ "Return from Frame..." sly-db-return-from-frame ,C ] 7092 ("Invoke Restart" 7093 [ "Continue" sly-db-continue ,C ] 7094 [ "Abort" sly-db-abort ,C ] 7095 [ "Step" sly-db-step ,C ] 7096 [ "Step next" sly-db-next ,C ] 7097 [ "Step out" sly-db-out ,C ] 7098 ) 7099 "--" 7100 [ "Quit (throw)" sly-db-quit ,C ] 7101 [ "Break With Default Debugger" sly-db-break-with-default-debugger ,C ]))) 7102 7103(easy-menu-define sly-inspector-menu sly-inspector-mode-map 7104 "Menu for the SLY Inspector" 7105 (let ((C '(sly-connected-p))) 7106 `("SLY-Inspector" 7107 [ "Pop Inspectee" sly-inspector-pop ,C ] 7108 [ "Next Inspectee" sly-inspector-next ,C ] 7109 [ "Describe this Inspectee" sly-inspector-describe ,C ] 7110 [ "Eval in context" sly-inspector-eval ,C ] 7111 [ "Show history" sly-inspector-history ,C ] 7112 [ "Reinspect" sly-inspector-reinspect ,C ] 7113 [ "Fetch all parts" sly-inspector-fetch-all ,C ] 7114 [ "Quit" sly-inspector-quit ,C ]))) 7115 7116 7117;;;; Utilities (no not Paul Graham style) 7118 7119;;; FIXME: this looks almost sly `sly-alistify', perhaps the two 7120;;; functions can be merged. 7121(defun sly-group-similar (similar-p list) 7122 "Return the list of lists of 'similar' adjacent elements of LIST. 7123The function SIMILAR-P is used to test for similarity. 7124The order of the input list is preserved." 7125 (if (null list) 7126 nil 7127 (let ((accumulator (list (list (car list))))) 7128 (dolist (x (cdr list)) 7129 (if (funcall similar-p x (caar accumulator)) 7130 (push x (car accumulator)) 7131 (push (list x) accumulator))) 7132 (nreverse (mapcar #'nreverse accumulator))))) 7133 7134(defun sly-alistify (list key test) 7135 "Partition the elements of LIST into an alist. 7136KEY extracts the key from an element and TEST is used to compare 7137keys." 7138 (let ((alist '())) 7139 (dolist (e list) 7140 (let* ((k (funcall key e)) 7141 (probe (cl-assoc k alist :test test))) 7142 (if probe 7143 (push e (cdr probe)) 7144 (push (cons k (list e)) alist)))) 7145 ;; Put them back in order. 7146 (nreverse (mapc (lambda (ent) 7147 (setcdr ent (nreverse (cdr ent)))) 7148 alist)))) 7149 7150;;;;; Misc. 7151 7152(defun sly-length= (list n) 7153 "Return (= (length LIST) N)." 7154 (if (zerop n) 7155 (null list) 7156 (let ((tail (nthcdr (1- n) list))) 7157 (and tail (null (cdr tail)))))) 7158 7159(defun sly-length> (seq n) 7160 "Return (> (length SEQ) N)." 7161 (cl-etypecase seq 7162 (list (nthcdr n seq)) 7163 (sequence (> (length seq) n)))) 7164 7165(defun sly-trim-whitespace (str) 7166 "Chomp leading and tailing whitespace from STR." 7167 ;; lited from http://www.emacswiki.org/emacs/ElispCookbook 7168 (replace-regexp-in-string (rx (or (: bos (* (any " \t\n"))) 7169 (: (* (any " \t\n")) eos))) 7170 "" 7171 str)) 7172 7173;;;;; Buffer related 7174 7175(defun sly-column-max () 7176 (save-excursion 7177 (goto-char (point-min)) 7178 (cl-loop for column = (prog2 (end-of-line) (current-column) (forward-line)) 7179 until (= (point) (point-max)) 7180 maximizing column))) 7181 7182;;;;; CL symbols vs. Elisp symbols. 7183 7184(defun sly-cl-symbol-name (symbol) 7185 (let ((n (if (stringp symbol) symbol (symbol-name symbol)))) 7186 (if (string-match ":\\([^:]*\\)$" n) 7187 (let ((symbol-part (match-string 1 n))) 7188 (if (string-match "^|\\(.*\\)|$" symbol-part) 7189 (match-string 1 symbol-part) 7190 symbol-part)) 7191 n))) 7192 7193(defun sly-cl-symbol-package (symbol &optional default) 7194 (let ((n (if (stringp symbol) symbol (symbol-name symbol)))) 7195 (if (string-match "^\\([^:]*\\):" n) 7196 (match-string 1 n) 7197 default))) 7198 7199(defun sly-qualify-cl-symbol-name (symbol-or-name) 7200 "Return a package-qualified string for SYMBOL-OR-NAME. 7201If SYMBOL-OR-NAME doesn't already have a package prefix the 7202current package is used." 7203 (let ((s (if (stringp symbol-or-name) 7204 symbol-or-name 7205 (symbol-name symbol-or-name)))) 7206 (if (sly-cl-symbol-package s) 7207 s 7208 (format "%s::%s" 7209 (let* ((package (sly-current-package))) 7210 ;; package is a string like ":cl-user" 7211 ;; or "CL-USER", or "\"CL-USER\"". 7212 (if package 7213 (sly--pretty-package-name package) 7214 "CL-USER")) 7215 (sly-cl-symbol-name s))))) 7216 7217;;;;; Moving, CL idiosyncracies aware (reader conditionals &c.) 7218 7219(defmacro sly-point-moves-p (&rest body) 7220 "Execute BODY and return true if the current buffer's point moved." 7221 (declare (indent 0)) 7222 (let ((pointvar (cl-gensym "point-"))) 7223 `(let ((,pointvar (point))) 7224 (save-current-buffer ,@body) 7225 (/= ,pointvar (point))))) 7226 7227(defun sly-forward-sexp (&optional count) 7228 "Like `forward-sexp', but understands reader-conditionals (#- and #+), 7229and skips comments." 7230 (dotimes (_i (or count 1)) 7231 (sly-forward-cruft) 7232 (forward-sexp))) 7233 7234(defconst sly-reader-conditionals-regexp 7235 ;; #!+, #!- are SBCL specific reader-conditional syntax. 7236 ;; We need this for the source files of SBCL itself. 7237 (regexp-opt '("#+" "#-" "#!+" "#!-"))) 7238 7239(defsubst sly-forward-reader-conditional () 7240 "Move past any reader conditional (#+ or #-) at point." 7241 (when (looking-at sly-reader-conditionals-regexp) 7242 (goto-char (match-end 0)) 7243 (let* ((plus-conditional-p (eq (char-before) ?+)) 7244 (result (sly-eval-feature-expression 7245 (condition-case e 7246 (read (current-buffer)) 7247 (invalid-read-syntax 7248 (signal 'sly-unknown-feature-expression (cdr e))))))) 7249 (unless (if plus-conditional-p result (not result)) 7250 ;; skip this sexp 7251 (sly-forward-sexp))))) 7252 7253(defun sly-forward-cruft () 7254 "Move forward over whitespace, comments, reader conditionals." 7255 (while (sly-point-moves-p (skip-chars-forward " \t\n") 7256 (forward-comment (buffer-size)) 7257 (sly-forward-reader-conditional)))) 7258 7259(defun sly-keywordify (symbol) 7260 "Make a keyword out of the symbol SYMBOL." 7261 (let ((name (downcase (symbol-name symbol)))) 7262 (intern (if (eq ?: (aref name 0)) 7263 name 7264 (concat ":" name))))) 7265 7266(put 'sly-incorrect-feature-expression 7267 'error-conditions '(sly-incorrect-feature-expression error)) 7268 7269(put 'sly-unknown-feature-expression 7270 'error-conditions '(sly-unknown-feature-expression 7271 sly-incorrect-feature-expression 7272 error)) 7273 7274;; FIXME: let it crash 7275;; FIXME: the (null (cdr l)) constraint is bogus 7276(defun sly-eval-feature-expression (e) 7277 "Interpret a reader conditional expression." 7278 (cond ((symbolp e) 7279 (memq (sly-keywordify e) (sly-lisp-features))) 7280 ((and (consp e) (symbolp (car e))) 7281 (funcall (let ((head (sly-keywordify (car e)))) 7282 (cl-case head 7283 (:and #'cl-every) 7284 (:or #'cl-some) 7285 (:not 7286 (let ((feature-expression e)) 7287 (lambda (f l) 7288 (cond ((null l) t) 7289 ((null (cdr l)) (not (apply f l))) 7290 (t (signal 'sly-incorrect-feature-expression 7291 feature-expression)))))) 7292 (t (signal 'sly-unknown-feature-expression head)))) 7293 #'sly-eval-feature-expression 7294 (cdr e))) 7295 (t (signal 'sly-incorrect-feature-expression e)))) 7296 7297;;;;; Extracting Lisp forms from the buffer or user 7298 7299(defun sly-region-for-defun-at-point (&optional pos) 7300 "Return a list (START END) for the positions of defun at POS. 7301POS defaults to point" 7302 (save-excursion 7303 (save-match-data 7304 (goto-char (or pos (point))) 7305 (end-of-defun) 7306 (let ((end (point))) 7307 (beginning-of-defun) 7308 (list (point) end))))) 7309 7310(defun sly-beginning-of-symbol () 7311 "Move to the beginning of the CL-style symbol at point." 7312 (while (re-search-backward "\\(\\sw\\|\\s_\\|\\s\\.\\|\\s\\\\|[#@|]\\)\\=" 7313 (when (> (point) 2000) (- (point) 2000)) 7314 t)) 7315 (re-search-forward "\\=#[-+.<|]" nil t) 7316 (when (and (eq (char-after) ?@) (eq (char-before) ?\,)) 7317 (forward-char))) 7318 7319(defsubst sly-end-of-symbol () 7320 "Move to the end of the CL-style symbol at point." 7321 (re-search-forward "\\=\\(\\sw\\|\\s_\\|\\s\\.\\|#:\\|[@|]\\)*")) 7322 7323(put 'sly-symbol 'end-op 'sly-end-of-symbol) 7324(put 'sly-symbol 'beginning-op 'sly-beginning-of-symbol) 7325 7326(defun sly-symbol-start-pos () 7327 "Return the starting position of the symbol under point. 7328The result is unspecified if there isn't a symbol under the point." 7329 (save-excursion (sly-beginning-of-symbol) (point))) 7330 7331(defun sly-symbol-end-pos () 7332 (save-excursion (sly-end-of-symbol) (point))) 7333 7334(defun sly-bounds-of-symbol-at-point () 7335 "Return the bounds of the symbol around point. 7336The returned bounds are either nil or non-empty." 7337 (let ((bounds (bounds-of-thing-at-point 'sly-symbol))) 7338 (if (and bounds 7339 (< (car bounds) 7340 (cdr bounds))) 7341 bounds))) 7342 7343(defun sly-symbol-at-point (&optional interactive) 7344 "Return the name of the symbol at point, otherwise nil." 7345 ;; (thing-at-point 'symbol) returns "" in empty buffers 7346 (let ((bounds (sly-bounds-of-symbol-at-point))) 7347 (when bounds 7348 (let ((beg (car bounds)) (end (cdr bounds))) 7349 (when interactive (sly-flash-region beg end)) 7350 (buffer-substring-no-properties beg end))))) 7351 7352(defun sly-bounds-of-sexp-at-point (&optional interactive) 7353 "Return the bounds sexp near point as a pair (or nil). 7354With non-nil INTERACTIVE, error if can't find such a thing." 7355 (or (sly-bounds-of-symbol-at-point) 7356 (and (equal (char-after) ?\() 7357 (member (char-before) '(?\' ?\, ?\@)) 7358 ;; hide stuff before ( to avoid quirks with '( etc. 7359 (save-restriction 7360 (narrow-to-region (point) (point-max)) 7361 (bounds-of-thing-at-point 'sexp))) 7362 (bounds-of-thing-at-point 'sexp) 7363 (and (save-excursion 7364 (and (ignore-errors 7365 (backward-sexp 1) 7366 t) 7367 (bounds-of-thing-at-point 'sexp)))) 7368 (when interactive 7369 (user-error "No sexp near point")))) 7370 7371(cl-defun sly-sexp-at-point (&optional interactive stringp (errorp t)) 7372 "Return the sexp at point as a string, otherwise nil. 7373With non-nil INTERACTIVE, flash the region and also error if no 7374sexp can be found, unless ERRORP, which defaults to t, is passed 7375as nil. With non-nil STRINGP, only look for strings" 7376 (catch 'return 7377 (let ((bounds (sly-bounds-of-sexp-at-point (and interactive 7378 errorp)))) 7379 (when bounds 7380 (when (and stringp 7381 (not (eq (syntax-class (syntax-after (car bounds))) 7382 (char-syntax ?\")))) 7383 (if (and interactive 7384 interactive) 7385 (user-error "No string at point") 7386 (throw 'return nil))) 7387 (when interactive 7388 (sly-flash-region (car bounds) (cdr bounds))) 7389 (buffer-substring-no-properties (car bounds) 7390 (cdr bounds)))))) 7391 7392(defun sly-string-at-point (&optional interactive) 7393 "Returns the string near point as a string, otherwise nil. 7394With non-nil INTERACTIVE, flash the region and error if no string 7395can be found." 7396 (sly-sexp-at-point interactive 'stringp)) 7397 7398(defun sly-input-complete-p (start end) 7399 "Return t if the region from START to END contains a complete sexp." 7400 (save-excursion 7401 (goto-char start) 7402 (cond ((looking-at "\\s *['`#]?[(\"]") 7403 (ignore-errors 7404 (save-restriction 7405 (narrow-to-region start end) 7406 ;; Keep stepping over blanks and sexps until the end of 7407 ;; buffer is reached or an error occurs. Tolerate extra 7408 ;; close parens. 7409 (cl-loop do (skip-chars-forward " \t\r\n)") 7410 until (eobp) 7411 do (forward-sexp)) 7412 t))) 7413 (t t)))) 7414 7415 7416;;;; sly.el in pretty colors 7417 7418(cl-loop for sym in (list 'sly-def-connection-var 7419 'sly-define-channel-type 7420 'sly-define-channel-method 7421 'define-sly-contrib) 7422 for regexp = (format "(\\(%S\\)\\s +\\(\\(\\w\\|\\s_\\)+\\)" 7423 sym) 7424 do (font-lock-add-keywords 7425 'emacs-lisp-mode 7426 `((,regexp (1 font-lock-keyword-face) 7427 (2 font-lock-variable-name-face))))) 7428 7429;;;; Finishing up 7430 7431(defun sly--byte-compile (symbol) 7432 (require 'bytecomp) ;; tricky interaction between autoload and let. 7433 (let ((byte-compile-warnings '())) 7434 (byte-compile symbol))) 7435 7436(defun sly-byte-compile-hotspots (syms) 7437 (mapc (lambda (sym) 7438 (cond ((fboundp sym) 7439 (unless (byte-code-function-p (symbol-function sym)) 7440 (sly--byte-compile sym))) 7441 (t (error "%S is not fbound" sym)))) 7442 syms)) 7443 7444(sly-byte-compile-hotspots 7445 '(sly-alistify 7446 sly-log-event 7447 sly--events-buffer 7448 sly-process-available-input 7449 sly-dispatch-event 7450 sly-net-filter 7451 sly-net-have-input-p 7452 sly-net-decode-length 7453 sly-net-read 7454 sly-print-apropos 7455 sly-insert-propertized 7456 sly-beginning-of-symbol 7457 sly-end-of-symbol 7458 sly-eval-feature-expression 7459 sly-forward-sexp 7460 sly-forward-cruft 7461 sly-forward-reader-conditional)) 7462 7463;;;###autoload 7464(add-hook 'lisp-mode-hook 'sly-editing-mode) 7465 7466(let ((proceed-p 7467 (if noninteractive 7468 (lambda () t) 7469 (let (asked resp) 7470 (lambda () 7471 (unless asked 7472 (setq resp 7473 (y-or-n-p 7474 (eval-when-compile 7475 (concat "[sly] SLIME detected. Try to disable it " 7476 "for this Emacs session?"))) 7477 asked t)) 7478 resp))))) 7479 (when (and (memq 'slime-lisp-mode-hook lisp-mode-hook) 7480 (funcall proceed-p)) 7481 (warn "To restore SLIME in this session, customize `lisp-mode-hook' and 7482replace `sly-editing-mode' with `slime-lisp-mode-hook'.") 7483 (remove-hook 'lisp-mode-hook 'slime-lisp-mode-hook)) 7484 (dolist (buffer (buffer-list)) 7485 (with-current-buffer buffer 7486 (when (eq major-mode 'lisp-mode) 7487 (when (and (boundp 'slime-mode) slime-mode (funcall proceed-p)) 7488 (ignore-errors (funcall 'slime-mode -1))) 7489 (sly-editing-mode 1))))) 7490 7491(provide 'sly) 7492 7493;;; sly.el ends here 7494;; Local Variables: 7495;; coding: utf-8 7496;; End: 7497