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