├── NEWS.md ├── lib ├── .nosearch ├── sly-common.el └── sly-messages.el ├── doc ├── images │ ├── tutorial-1.png │ ├── tutorial-2.png │ ├── tutorial-3.png │ ├── tutorial-4.png │ ├── tutorial-5.png │ ├── tutorial-6.png │ ├── stickers-1-placed-stickers.png │ ├── stickers-2-armed-stickers.png │ ├── stickers-3-replay-stickers.png │ ├── stickers-4-breaking-stickers.png │ └── stickers-5-fetch-recordings.png ├── animations │ ├── backreferences.gif │ ├── reverse-isearch.gif │ ├── stickers-example.gif │ └── company-flex-completion.gif ├── texinfo-tabulate.awk ├── sly.css ├── contributors.texi ├── sly-refcard.tex └── Makefile ├── .dir-locals.el ├── .gitignore ├── contrib ├── sly-fancy-inspector.el ├── sly-fancy.el ├── sly-retro.el ├── sly-indentation.el ├── sly-scratch.el ├── slynk-retro.lisp ├── slynk-package-fu.lisp ├── sly-fancy-trace.el ├── sly-tramp.el ├── sylvesters.txt ├── sly-profiler.el ├── slynk-indentation.lisp ├── slynk-profiler.lisp ├── sly-autodoc.el ├── sly-fontifying-fu.el └── slynk-trace-dialog.lisp ├── slynk ├── start-slynk.lisp ├── slynk.asd ├── slynk-source-file-cache.lisp ├── slynk-apropos.lisp ├── slynk-gray.lisp ├── slynk-rpc.lisp ├── slynk-match.lisp └── slynk-source-path-parser.lisp ├── sly-autoloads.el ├── test ├── sly-package-fu-tests.el ├── sly-parse-tests.el ├── sly-mrepl-tests.el ├── sly-fontifying-fu-tests.el ├── sly-indentation-tests.el ├── sly-stickers-tests.el └── sly-autodoc-tests.el ├── .github └── workflows │ └── ci.yml ├── PROBLEMS.md ├── Makefile ├── README.md └── CONTRIBUTING.md /NEWS.md: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/joaotavora/sly/HEAD/NEWS.md -------------------------------------------------------------------------------- /lib/.nosearch: -------------------------------------------------------------------------------- 1 | ;; normal-top-level-add-subdirs-to-load-path needs this file 2 | -------------------------------------------------------------------------------- /doc/images/tutorial-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/joaotavora/sly/HEAD/doc/images/tutorial-1.png -------------------------------------------------------------------------------- /doc/images/tutorial-2.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/joaotavora/sly/HEAD/doc/images/tutorial-2.png -------------------------------------------------------------------------------- /doc/images/tutorial-3.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/joaotavora/sly/HEAD/doc/images/tutorial-3.png -------------------------------------------------------------------------------- /doc/images/tutorial-4.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/joaotavora/sly/HEAD/doc/images/tutorial-4.png -------------------------------------------------------------------------------- /doc/images/tutorial-5.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/joaotavora/sly/HEAD/doc/images/tutorial-5.png -------------------------------------------------------------------------------- /doc/images/tutorial-6.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/joaotavora/sly/HEAD/doc/images/tutorial-6.png -------------------------------------------------------------------------------- /doc/animations/backreferences.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/joaotavora/sly/HEAD/doc/animations/backreferences.gif -------------------------------------------------------------------------------- /doc/animations/reverse-isearch.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/joaotavora/sly/HEAD/doc/animations/reverse-isearch.gif -------------------------------------------------------------------------------- /doc/animations/stickers-example.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/joaotavora/sly/HEAD/doc/animations/stickers-example.gif -------------------------------------------------------------------------------- /doc/images/stickers-1-placed-stickers.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/joaotavora/sly/HEAD/doc/images/stickers-1-placed-stickers.png -------------------------------------------------------------------------------- /doc/images/stickers-2-armed-stickers.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/joaotavora/sly/HEAD/doc/images/stickers-2-armed-stickers.png -------------------------------------------------------------------------------- /doc/images/stickers-3-replay-stickers.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/joaotavora/sly/HEAD/doc/images/stickers-3-replay-stickers.png -------------------------------------------------------------------------------- /doc/animations/company-flex-completion.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/joaotavora/sly/HEAD/doc/animations/company-flex-completion.gif -------------------------------------------------------------------------------- /doc/images/stickers-4-breaking-stickers.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/joaotavora/sly/HEAD/doc/images/stickers-4-breaking-stickers.png -------------------------------------------------------------------------------- /doc/images/stickers-5-fetch-recordings.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/joaotavora/sly/HEAD/doc/images/stickers-5-fetch-recordings.png -------------------------------------------------------------------------------- /.dir-locals.el: -------------------------------------------------------------------------------- 1 | ;;; Directory Local Variables -*- no-byte-compile: t -*- 2 | ;;; For more information see (info "(emacs) Directory Variables") 3 | 4 | ((nil . ((require-final-newline . t) 5 | (eval . (add-hook 'before-save-hook 'delete-trailing-whitespace nil t)))) 6 | ("lib" . 7 | ((emacs-lisp-mode . ((elisp-flymake-byte-compile-load-path . ("./" "../")))))) 8 | ("contrib" . 9 | ((emacs-lisp-mode . ((elisp-flymake-byte-compile-load-path . ("./" "../")))))) 10 | ("test" . 11 | ((emacs-lisp-mode . ((elisp-flymake-byte-compile-load-path . ("./" "../"))))))) 12 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | ChangeLog 2 | *.x86f 3 | *.fasl* 4 | *.abcl 5 | *.dfsl 6 | *.lx64fsl 7 | *.dx64fsl 8 | *.elc 9 | *.cls 10 | *~ 11 | \#*\# 12 | .\#* 13 | .DS_Store 14 | # for the doc 15 | # 16 | doc/*.html 17 | doc/html 18 | doc/*.info 19 | doc/*.pdf 20 | doc/*.ps 21 | doc/*.dvi 22 | doc/*.aux 23 | doc/*.cp 24 | doc/*.cps 25 | doc/*.fn 26 | doc/*.fns 27 | doc/*.ky 28 | doc/*.kys 29 | doc/*.log 30 | doc/*.pg 31 | doc/*.toc 32 | doc/*.tp 33 | doc/*.vr 34 | doc/*.op 35 | doc/*.ops 36 | doc/*.pgs 37 | doc/*.vrs 38 | doc/*.tgz 39 | doc/gh-pages 40 | /dist/ 41 | /sly-pkg.el 42 | /sly-autoloads.el 43 | *.abcl-tmp 44 | -------------------------------------------------------------------------------- /doc/texinfo-tabulate.awk: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env awk -f 2 | # 3 | # Format input lines into a multi-column texinfo table. 4 | # Note: does not do texinfo-escaping of the input. 5 | 6 | # This code has been placed in the Public Domain. All warranties 7 | # are disclaimed. 8 | 9 | BEGIN { 10 | columns = 3; 11 | printf("@multitable @columnfractions"); 12 | for (i = 0; i < columns; i++) 13 | printf(" %f", 1.0/columns); 14 | print 15 | } 16 | 17 | { if (NR % columns == 1) printf("\n@item %s", $0); 18 | else printf(" @tab %s", $0); } 19 | 20 | END { printf("\n@end multitable\n"); } 21 | -------------------------------------------------------------------------------- /contrib/sly-fancy-inspector.el: -------------------------------------------------------------------------------- 1 | ;; -*- lexical-binding: t; -*- 2 | (require 'sly) 3 | (require 'sly-parse "lib/sly-parse") 4 | 5 | (define-sly-contrib sly-fancy-inspector 6 | "Fancy inspector for CLOS objects." 7 | (:authors "Marco Baringer and others") 8 | (:license "GPL") 9 | (:slynk-dependencies slynk/fancy-inspector)) 10 | 11 | (defun sly-inspect-definition () 12 | "Inspect definition at point" 13 | (interactive) 14 | (sly-inspect (sly-definition-at-point))) 15 | 16 | (defun sly-disassemble-definition () 17 | "Disassemble definition at point" 18 | (interactive) 19 | (sly-eval-describe `(slynk:disassemble-form 20 | ,(sly-definition-at-point t)))) 21 | 22 | (provide 'sly-fancy-inspector) 23 | -------------------------------------------------------------------------------- /slynk/start-slynk.lisp: -------------------------------------------------------------------------------- 1 | ;;; This file is intended to be loaded by an implementation to 2 | ;;; get a running slynk server 3 | ;;; e.g. sbcl --load start-slynk.lisp 4 | ;;; 5 | ;;; Default port is 4005 6 | 7 | ;;; For additional slynk-side configurations see 8 | ;;; 6.2 section of the Slime user manual. 9 | 10 | (load (make-pathname :name "slynk-loader" :type "lisp" 11 | :defaults *load-truename*)) 12 | 13 | (slynk-loader:init 14 | :delete nil ; delete any existing SLYNK packages 15 | :reload nil) ; reload SLYNK, even if the SLYNK package already exists 16 | 17 | 18 | (slynk:create-server :port 4005 19 | ;; if non-nil the connection won't be closed 20 | ;; after connecting 21 | :dont-close t) 22 | -------------------------------------------------------------------------------- /contrib/sly-fancy.el: -------------------------------------------------------------------------------- 1 | ;; -*- lexical-binding: t; -*- 2 | (require 'sly) 3 | 4 | (define-sly-contrib sly-fancy 5 | "Make SLY fancy." 6 | (:authors "Matthias Koeppe " 7 | "Tobias C Rittweiler ") 8 | (:license "GPL") 9 | (:sly-dependencies sly-mrepl 10 | sly-autodoc 11 | sly-fancy-inspector 12 | sly-fancy-trace 13 | sly-scratch 14 | sly-package-fu 15 | sly-fontifying-fu 16 | sly-trace-dialog 17 | ;; sly-profiler ;; not ready for prime-time yet 18 | sly-stickers 19 | sly-indentation 20 | sly-tramp)) 21 | 22 | (provide 'sly-fancy) 23 | -------------------------------------------------------------------------------- /contrib/sly-retro.el: -------------------------------------------------------------------------------- 1 | ;; -*- lexical-binding: t; -*- 2 | (require 'sly) 3 | 4 | (define-sly-contrib sly-retro 5 | "Enable SLIME to connect to a SLY-started SLYNK" 6 | (:slynk-dependencies slynk/retro) 7 | (:on-load (setq sly-net-send-translator #'sly-retro-slynk-to-swank)) 8 | (:on-unload (setq sly-net-send-translator nil))) 9 | 10 | (defun sly-retro-slynk-to-swank (sexp) 11 | (cond ((and sexp 12 | (symbolp sexp) 13 | (string-match "^slynk\\(.*\\)$" (symbol-name sexp))) 14 | (intern (format "swank%s" (match-string 1 (symbol-name sexp))))) 15 | ((and sexp (listp sexp)) 16 | (cl-loop for (x . rest) on sexp 17 | append (list (sly-retro-slynk-to-swank x)) into foo 18 | finally (return (append foo (sly-retro-slynk-to-swank rest))))) 19 | (t 20 | sexp))) 21 | 22 | (provide 'sly-retro) 23 | -------------------------------------------------------------------------------- /doc/sly.css: -------------------------------------------------------------------------------- 1 | body { font-family: Georgia, serif; 2 | line-height: 1.3; 3 | padding-left: 5em; padding-right: 1em; 4 | padding-bottom: 1em; max-width: 60em; } 5 | table { border-collapse: collapse } 6 | span.roman { font-family: century schoolbook, serif; font-weight: normal; } 7 | h1, h2, h3, h4, h5, h6 { font-family: Helvetica, sans-serif } 8 | h4 { margin-top: 2.5em; } 9 | dfn { font-family: inherit; font-variant: italic; font-weight: bolder } 10 | var { font-variant: slanted; } 11 | td { padding-right: 1em; padding-left: 1em } 12 | sub { font-size: smaller } 13 | .node { padding: 0; margin: 0 } 14 | dd { padding-top: 1em; padding-bottom: 2em } 15 | pre.example { 16 | font-family: monospace; 17 | background-color: #E9FFE9; border: 1px solid #9D9; 18 | padding-top: 0.5em; padding-bottom: 0.5em; } 19 | a:link { color: #383; text-decoration: none; padding: 1px 2px 1px 2px; } 20 | a:visited { color: #161; text-decoration: none; padding: 1px 2px 1px 2px; } 21 | a:hover { color: #161; text-decoration: none; padding: 1px 1px 1px 1px; border: 1px solid #666; } 22 | a:focus { color: #161; text-decoration: none; padding: 1px 2px 1px 2px; border: none; } 23 | -------------------------------------------------------------------------------- /contrib/sly-indentation.el: -------------------------------------------------------------------------------- 1 | ;; -*- lexical-binding: t; -*- 2 | (require 'sly) 3 | (require 'cl-lib) 4 | (require 'sly-cl-indent "lib/sly-cl-indent") 5 | 6 | (define-sly-contrib sly-indentation 7 | "Contrib interfacing `sly-cl-indent' and SLY." 8 | (:slynk-dependencies slynk/indentation) 9 | (:on-load 10 | (setq sly--lisp-indent-current-package-function 'sly-current-package))) 11 | 12 | (defun sly-update-system-indentation (symbol indent packages) 13 | (let ((list (gethash symbol sly-common-lisp-system-indentation)) 14 | (ok nil)) 15 | (if (not list) 16 | (puthash symbol (list (cons indent packages)) 17 | sly-common-lisp-system-indentation) 18 | (dolist (spec list) 19 | (cond ((equal (car spec) indent) 20 | (dolist (p packages) 21 | (unless (member p (cdr spec)) 22 | (push p (cdr spec)))) 23 | (setf ok t)) 24 | (t 25 | (setf (cdr spec) 26 | (cl-set-difference (cdr spec) packages :test 'equal))))) 27 | (unless ok 28 | (puthash symbol (cons (cons indent packages) list) 29 | sly-common-lisp-system-indentation))))) 30 | 31 | (provide 'sly-indentation) 32 | -------------------------------------------------------------------------------- /contrib/sly-scratch.el: -------------------------------------------------------------------------------- 1 | ;;; sly-scratch.el -*- lexical-binding: t; -*- 2 | 3 | (require 'sly) 4 | (require 'cl-lib) 5 | 6 | (define-sly-contrib sly-scratch 7 | "Imitate Emacs' *scratch* buffer" 8 | (:authors "Helmut Eller ") 9 | (:on-load 10 | (define-key sly-selector-map (kbd "s") 'sly-scratch)) 11 | (:license "GPL")) 12 | 13 | 14 | ;;; Code 15 | 16 | (defvar sly-scratch-mode-map 17 | (let ((map (make-sparse-keymap))) 18 | (set-keymap-parent map lisp-mode-map) 19 | (define-key map "\C-j" 'sly-eval-print-last-expression) 20 | map)) 21 | 22 | (defun sly-scratch () 23 | (interactive) 24 | (sly-switch-to-scratch-buffer)) 25 | 26 | (defun sly-switch-to-scratch-buffer () 27 | (set-buffer (sly-scratch-buffer)) 28 | (unless (eq (current-buffer) (window-buffer)) 29 | (pop-to-buffer (current-buffer) t))) 30 | 31 | (defvar sly-scratch-file nil) 32 | 33 | (defun sly-scratch-buffer () 34 | "Return the scratch buffer, create it if necessary." 35 | (or (get-buffer (sly-buffer-name :scratch)) 36 | (with-current-buffer (if sly-scratch-file 37 | (find-file sly-scratch-file) 38 | (get-buffer-create (sly-buffer-name :scratch))) 39 | (rename-buffer (sly-buffer-name :scratch)) 40 | (lisp-mode) 41 | (use-local-map sly-scratch-mode-map) 42 | (sly-mode t) 43 | (current-buffer)))) 44 | 45 | (provide 'sly-scratch) 46 | -------------------------------------------------------------------------------- /sly-autoloads.el: -------------------------------------------------------------------------------- 1 | ;;; sly-autoloads.el --- autoload definitions for SLY -*- no-byte-compile: t -*- 2 | 3 | ;; Copyright (C) 2007 Helmut Eller 4 | ;; Copyright (C) 2014-2020 João Távora 5 | 6 | ;; This file is protected by the GNU GPLv2 (or later), as distributed 7 | ;; with GNU Emacs. 8 | 9 | ;;; Commentary: 10 | 11 | ;; This code defines the necessary autoloads, so that we don't need to 12 | ;; load everything from .emacs. 13 | ;; 14 | ;; JT@14/01/09: FIXME: This file should be auto-generated with 15 | ;; autoload cookies. 16 | 17 | ;;; Code: 18 | 19 | (add-to-list 'load-path (directory-file-name 20 | (or (file-name-directory #$) (car load-path)))) 21 | 22 | (autoload 'sly "sly" 23 | "Start a Lisp subprocess and connect to its Slynk server." t) 24 | 25 | (autoload 'sly-mode "sly" 26 | "SLY: The Superior Lisp Interaction (Minor) Mode for Emacs." t) 27 | 28 | (autoload 'sly-connect "sly" 29 | "Connect to a running Slynk server." t) 30 | 31 | (autoload 'hyperspec-lookup "lib/hyperspec" nil t) 32 | 33 | (autoload 'sly-editing-mode "sly" "SLY" t) 34 | 35 | (defvar sly-contribs '(sly-fancy) 36 | "A list of contrib packages to load with SLY.") 37 | 38 | (autoload 'sly-setup "sly" 39 | "Setup some SLY contribs.") 40 | 41 | (define-obsolete-variable-alias 'sly-setup-contribs 42 | 'sly-contribs "2.3.2") 43 | 44 | (add-hook 'lisp-mode-hook 'sly-editing-mode) 45 | 46 | (provide 'sly-autoloads) 47 | 48 | ;;; sly-autoloads.el ends here 49 | -------------------------------------------------------------------------------- /test/sly-package-fu-tests.el: -------------------------------------------------------------------------------- 1 | ;; -*- lexical-binding: t; -*- 2 | (require 'sly-package-fu "contrib/sly-package-fu") 3 | (require 'sly-tests "lib/sly-tests") 4 | 5 | (def-sly-test package-fu-import (initial final symbol-to-import) 6 | "Check if importing `import` on `initial-defpackage` results in `final-defpackage." 7 | '((((defpackage :foo) (in-package :foo)) 8 | ((defpackage :foo (:import-from :cl :find)) (in-package :foo)) 9 | cl:find) 10 | (((defpackage :foo (:import-from :cl :find)) (in-package :foo)) 11 | ((defpackage :foo (:import-from :cl :position :find)) (in-package :foo)) 12 | cl:position) 13 | (((defpackage :foo (:import-from :bknr.datastore-dummy :find)) (in-package :foo)) 14 | ((defpackage :foo (:import-from :bknr.datastore-dummy 15 | :position 16 | :find)) 17 | (in-package :foo)) 18 | bknr.datastore-dummy::position)) 19 | (let ((file (make-temp-file "sly-package-fu--fixture"))) 20 | (with-temp-buffer 21 | (find-file file) 22 | (lisp-mode) 23 | (setq indent-tabs-mode nil) 24 | (dolist (f initial) (insert (pp-to-string f))) 25 | ;; FIXME: using internal implementation detail 26 | (sly-package-fu--add-or-update-import-from-form 27 | (pp-to-string symbol-to-import)) 28 | (should (equal final 29 | (cl-loop initially (goto-char (point-min)) 30 | for f = (ignore-errors (read (current-buffer))) 31 | while f collect f)))))) 32 | 33 | 34 | 35 | (provide 'sly-package-fu-tests) 36 | -------------------------------------------------------------------------------- /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | 3 | on: 4 | push: 5 | branches: [master] 6 | pull_request: 7 | branches: [master] 8 | 9 | jobs: 10 | test: 11 | name: Emacs ${{matrix.emacs_version}} | ${{matrix.lisp}} | ${{matrix.os}} 12 | runs-on: ${{matrix.os}} 13 | timeout-minutes: 15 14 | 15 | strategy: 16 | fail-fast: false 17 | matrix: 18 | os: [ubuntu-latest, macos-latest] 19 | lisp: [sbcl, ccl] 20 | # Use Emacs "LTS" versions (the last release of every major one). 21 | emacs_version: [24.5, 25.3, 26.3, 27.2, 28.2, 29.4, 30.2] 22 | exclude: 23 | # Nix doesn't provide CCL for aarch64-darwin. 24 | - os: macos-latest 25 | lisp: ccl 26 | # purcell/setup-emacs provides: 27 | # (Intel MacOS) Emacs >=24.3 28 | # (ARM MacOS) Emacs >=28.1 29 | - os: macos-latest 30 | emacs_version: 24.5 31 | - os: macos-latest 32 | emacs_version: 25.3 33 | - os: macos-latest 34 | emacs_version: 26.3 35 | - os: macos-latest 36 | emacs_version: 27.2 37 | 38 | steps: 39 | - uses: actions/checkout@v5 40 | - uses: cachix/install-nix-action@v31 41 | with: 42 | nix_path: nixpkgs=channel:nixos-25.05 43 | - uses: purcell/setup-emacs@master 44 | with: 45 | version: ${{matrix.emacs_version}} 46 | 47 | # - run: nix-shell -p ${{matrix.lisp}} --run "${{matrix.lisp}} --version" 48 | # - run: nix-shell -p ${{matrix.lisp}} --run "emacs --version" 49 | - run: nix-shell -p ${{matrix.lisp}} --run "LISP=${{matrix.lisp}} make check" 50 | -------------------------------------------------------------------------------- /contrib/slynk-retro.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :slynk-retro 2 | (:use :cl :slynk :slynk-api)) 3 | 4 | (in-package :slynk-retro) 5 | 6 | (defun ensure-slynk-package-nicknames (&rest ignored) 7 | "Nickname all SLYNK-* package to SWANK-*" 8 | (declare (ignore ignored)) 9 | (loop for package in (list-all-packages) 10 | for package-name = (package-name package) 11 | when (search "SLYNK" package-name :test #'char-equal) 12 | do (rename-package package 13 | package-name 14 | (remove-duplicates 15 | (cons 16 | (format nil "SWANK~a" 17 | (subseq package-name 5)) 18 | (package-nicknames package)) 19 | :test #'string-equal)))) 20 | 21 | (defun load-swankrcs-maybe () 22 | (find-if (lambda (homedir-file) 23 | (load (merge-pathnames (user-homedir-pathname) 24 | homedir-file) 25 | :if-does-not-exist nil)) 26 | (list (make-pathname :name ".swank" :type "lisp") 27 | (make-pathname :name ".swankrc")))) 28 | 29 | (setq slynk-rpc:*translating-swank-to-slynk* nil) 30 | (push #'ensure-slynk-package-nicknames 31 | slynk-api:*slynk-require-hook*) 32 | 33 | (ensure-slynk-package-nicknames) 34 | ;;; Take this chance to load ~/.swank.lisp and ~/.swankrc if no 35 | ;;; ~/.slynk.lisp or ~/.slynkrc have already been loaded. 36 | ;;; 37 | (unless slynk-api:*loaded-user-init-file* 38 | (setq slynk-api:*loaded-user-init-file* 39 | (load-swankrcs-maybe))) 40 | 41 | (provide :slynk/retro) 42 | -------------------------------------------------------------------------------- /doc/contributors.texi: -------------------------------------------------------------------------------- 1 | @multitable @columnfractions 0.333333 0.333333 0.333333 2 | 3 | @item Helmut Eller @tab João Távora @tab Luke Gorrie 4 | @item Tobias C. Rittweiler @tab Stas Boukarev @tab Marco Baringer 5 | @item Matthias Koeppe @tab Nikodemus Siivola @tab Alan Ruttenberg 6 | @item Attila Lendvai @tab Luís Borges de Oliveira @tab Dan Barlow 7 | @item Andras Simon @tab Martin Simmons @tab Geo Carncross 8 | @item Christophe Rhodes @tab Peter Seibel @tab Mark Evenson 9 | @item Juho Snellman @tab Douglas Crosher @tab Wolfgang Jenkner 10 | @item R Primus @tab Javier Olaechea @tab Edi Weitz 11 | @item Zach Shaftel @tab James Bielman @tab Daniel Kochmanski 12 | @item Terje Norderhaug @tab Vladimir Sedach @tab Juan Jose Garcia Ripoll 13 | @item Alexander Artemenko @tab Spenser Truex @tab Nathan Trapuzzano 14 | @item Brian Downing @tab Mark @tab Jeffrey Cunningham 15 | @item Espen Wiborg @tab Paul M. Rodriguez @tab Masataro Asai 16 | @item Jan Moringen @tab Sébastien Villemot @tab Samuel Freilich 17 | @item Raymond Toy @tab Pierre Neidhardt @tab Phil Hargett 18 | @item Paulo Madeira @tab Kris Katterjohn @tab Jonas Bernoulli 19 | @item Ivan Shvedunov @tab Gábor Melis @tab Francois-Rene Rideau 20 | @item Christophe Junke @tab Bozhidar Batsov @tab Bart Botta 21 | @item Wilfredo Velázquez-Rodríguez @tab Tianxiang Xiong @tab Syohei YOSHIDA 22 | @item Stefan Monnier @tab Rommel MARTINEZ @tab Pavel Kulyov 23 | @item Paul A. Patience @tab Olof-Joachim Frahm @tab Mike Clarke 24 | @item Michał Herda @tab Mark H. David @tab Mario Lang 25 | @item Manfred Bergmann @tab Leo Liu @tab Koga Kazuo 26 | @item Jon Oddie @tab John Stracke @tab Joe Robertson 27 | @item Grant Shangreaux @tab Graham Dobbins @tab Eric Timmons 28 | @item Douglas Katzman @tab Dmitry Igrishin @tab Dmitrii Korobeinikov 29 | @item Deokhwan Kim @tab Denis Budyak @tab Chunyang Xu 30 | @item Cayman @tab Angelo Rossi @tab Andrew Kirkpatrick 31 | @end multitable 32 | -------------------------------------------------------------------------------- /test/sly-parse-tests.el: -------------------------------------------------------------------------------- 1 | ;; -*- lexical-binding: t; -*- 2 | (require 'sly-parse "lib/sly-parse") 3 | (require 'sly-tests "lib/sly-tests") 4 | 5 | (def-sly-test form-up-to-point.1 6 | (buffer-sexpr result-form &optional skip-trailing-test-p) 7 | "" 8 | `(("(char= #\\(*HERE*" 9 | ("char=" "#\\(" ,sly-cursor-marker)) 10 | ("(char= #\\( *HERE*" 11 | ("char=" "#\\(" "" ,sly-cursor-marker)) 12 | ("(char= #\\) *HERE*" 13 | ("char=" "#\\)" "" ,sly-cursor-marker)) 14 | ("(char= #\\*HERE*" 15 | ("char=" "#\\" ,sly-cursor-marker) t) 16 | ("(defun*HERE*" 17 | ("defun" ,sly-cursor-marker)) 18 | ("(defun foo*HERE*" 19 | ("defun" "foo" ,sly-cursor-marker)) 20 | ("(defun foo (x y)*HERE*" 21 | ("defun" "foo" 22 | ("x" "y") ,sly-cursor-marker)) 23 | ("(defun foo (x y*HERE*" 24 | ("defun" "foo" 25 | ("x" "y" ,sly-cursor-marker))) 26 | ("(apply 'foo*HERE*" 27 | ("apply" "'foo" ,sly-cursor-marker)) 28 | ("(apply #'foo*HERE*" 29 | ("apply" "#'foo" ,sly-cursor-marker)) 30 | ("(declare ((vector bit *HERE*" 31 | ("declare" (("vector" "bit" "" ,sly-cursor-marker)))) 32 | ("(with-open-file (*HERE*" 33 | ("with-open-file" ("" ,sly-cursor-marker))) 34 | ("(((*HERE*" 35 | ((("" ,sly-cursor-marker)))) 36 | ("(defun #| foo #| *HERE*" 37 | ("defun" "" ,sly-cursor-marker)) 38 | ("(defun #-(and) (bar) f*HERE*" 39 | ("defun" "f" ,sly-cursor-marker)) 40 | ("(remove-if (lambda (x)*HERE*" 41 | ("remove-if" ("lambda" ("x") ,sly-cursor-marker))) 42 | ("`(remove-if ,(lambda (x)*HERE*" 43 | ("remove-if" ("lambda" ("x") ,sly-cursor-marker))) 44 | ("`(remove-if ,@(lambda (x)*HERE*" 45 | ("remove-if" ("lambda" ("x") ,sly-cursor-marker)))) 46 | (sly-check-top-level) 47 | (with-temp-buffer 48 | (lisp-mode) 49 | (insert buffer-sexpr) 50 | (search-backward "*HERE*") 51 | (delete-region (match-beginning 0) (match-end 0)) 52 | (should (equal result-form 53 | (sly-parse-form-upto-point 10))) 54 | (unless skip-trailing-test-p 55 | (insert ")") (backward-char) 56 | (should (equal result-form 57 | (sly-parse-form-upto-point 10)))))) 58 | 59 | (provide 'sly-parse-tests) 60 | -------------------------------------------------------------------------------- /lib/sly-common.el: -------------------------------------------------------------------------------- 1 | ;;; sly-common.el --- common utils for SLY and its contribs -*- lexical-binding: t; -*- 2 | 3 | ;; Copyright (C) 2016 João Távora 4 | 5 | ;; Author: João Távora 6 | ;; Keywords: 7 | 8 | ;; This program is free software; you can redistribute it and/or modify 9 | ;; it under the terms of the GNU General Public License as published by 10 | ;; the Free Software Foundation, either version 3 of the License, or 11 | ;; (at your option) any later version. 12 | 13 | ;; This program is distributed in the hope that it will be useful, 14 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 15 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 16 | ;; GNU General Public License for more details. 17 | 18 | ;; You should have received a copy of the GNU General Public License 19 | ;; along with this program. If not, see . 20 | 21 | ;;; Commentary: 22 | 23 | ;; Common utilities for SLY and its contribs 24 | 25 | ;;; Code: 26 | (require 'cl-lib) 27 | 28 | (defun sly--call-refreshing (buffer 29 | overlay 30 | dont-erase 31 | recover-point-p 32 | flash-p 33 | fn) 34 | (with-current-buffer buffer 35 | (let ((inhibit-point-motion-hooks t) 36 | (inhibit-read-only t) 37 | (saved (point))) 38 | (save-restriction 39 | (when overlay 40 | (narrow-to-region (overlay-start overlay) 41 | (overlay-end overlay))) 42 | (unwind-protect 43 | (if dont-erase 44 | (goto-char (point-max)) 45 | (delete-region (point-min) (point-max))) 46 | (funcall fn) 47 | (when recover-point-p 48 | (goto-char saved))) 49 | (when flash-p 50 | (sly-flash-region (point-min) (point-max))))) 51 | buffer)) 52 | 53 | (cl-defmacro sly-refreshing ((&key 54 | overlay 55 | dont-erase 56 | (recover-point-p t) 57 | flash-p 58 | buffer) 59 | &rest body) 60 | "Delete a buffer region and run BODY which presumably refreshes it. 61 | Region is OVERLAY or the whole buffer. 62 | Recover point position if RECOVER-POINT-P. 63 | Flash the resulting region if FLASH-P" 64 | (declare (indent 1) 65 | (debug (sexp &rest form))) 66 | `(sly--call-refreshing ,(or buffer 67 | `(current-buffer)) 68 | ,overlay 69 | ,dont-erase 70 | ,recover-point-p 71 | ,flash-p 72 | (lambda () ,@body))) 73 | 74 | 75 | (provide 'sly-common) 76 | ;;; sly-common.el ends here 77 | -------------------------------------------------------------------------------- /contrib/slynk-package-fu.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :slynk) 3 | 4 | (defslyfun package= (string1 string2) 5 | (let* ((pkg1 (guess-package string1)) 6 | (pkg2 (guess-package string2))) 7 | (and pkg1 pkg2 (eq pkg1 pkg2)))) 8 | 9 | (defslyfun export-symbol-for-emacs (symbol-str package-str) 10 | (let ((package (guess-package package-str))) 11 | (when package 12 | (let ((*buffer-package* package)) 13 | (export `(,(from-string symbol-str)) package))))) 14 | 15 | (defslyfun import-symbol-for-emacs (symbol-str 16 | destination-package-str 17 | origin-package-str) 18 | (let ((destination (guess-package destination-package-str)) 19 | (origin (guess-package origin-package-str))) 20 | (when (and destination origin) 21 | (let* ((*buffer-package* origin) 22 | (symbol (from-string symbol-str))) 23 | (when symbol 24 | (import symbol destination)))))) 25 | 26 | (defslyfun unexport-symbol-for-emacs (symbol-str package-str) 27 | (let ((package (guess-package package-str))) 28 | (when package 29 | (let ((*buffer-package* package)) 30 | (unexport `(,(from-string symbol-str)) package))))) 31 | 32 | #+sbcl 33 | (defun list-structure-symbols (name) 34 | (let ((dd (sb-kernel:find-defstruct-description name ))) 35 | (list* name 36 | (sb-kernel:dd-default-constructor dd) 37 | (sb-kernel:dd-predicate-name dd) 38 | (sb-kernel::dd-copier-name dd) 39 | (mapcar #'sb-kernel:dsd-accessor-name 40 | (sb-kernel:dd-slots dd))))) 41 | 42 | #+ccl 43 | (defun list-structure-symbols (name) 44 | (let ((definition (gethash name ccl::%defstructs%))) 45 | (list* name 46 | (ccl::sd-constructor definition) 47 | (ccl::sd-refnames definition)))) 48 | 49 | (defun list-class-symbols (name) 50 | (let* ((class (find-class name)) 51 | (slots (slynk-mop:class-direct-slots class))) 52 | (labels ((extract-symbol (name) 53 | (if (and (consp name) (eql (car name) 'setf)) 54 | (cadr name) 55 | name)) 56 | (slot-accessors (slot) 57 | (nintersection (copy-list (slynk-mop:slot-definition-readers slot)) 58 | (copy-list (slynk-mop:slot-definition-readers slot)) 59 | :key #'extract-symbol))) 60 | (list* (class-name class) 61 | (mapcan #'slot-accessors slots))))) 62 | 63 | (defslyfun export-structure (name package) 64 | (let ((*package* (guess-package package))) 65 | (when *package* 66 | (let* ((name (from-string name)) 67 | (symbols (cond #+(or sbcl ccl) 68 | ((or (not (find-class name nil)) 69 | (subtypep name 'structure-object)) 70 | (list-structure-symbols name)) 71 | (t 72 | (list-class-symbols name))))) 73 | (export symbols) 74 | symbols)))) 75 | 76 | (provide :slynk/package-fu) 77 | -------------------------------------------------------------------------------- /contrib/sly-fancy-trace.el: -------------------------------------------------------------------------------- 1 | ;; -*- lexical-binding: t; -*- 2 | (require 'sly) 3 | (require 'sly-parse "lib/sly-parse") 4 | 5 | (define-sly-contrib sly-fancy-trace 6 | "Enhanced version of sly-trace capable of tracing local functions, 7 | methods, setf functions, and other entities supported by specific 8 | slynk:slynk-toggle-trace backends. Invoke via C-u C-t." 9 | (:authors "Matthias Koeppe " 10 | "Tobias C. Rittweiler ") 11 | (:license "GPL")) 12 | 13 | (defun sly-trace-query (spec) 14 | "Ask the user which function to trace; SPEC is the default. 15 | The result is a string." 16 | (cond ((null spec) 17 | (sly-read-from-minibuffer "(Un)trace: ")) 18 | ((stringp spec) 19 | (sly-read-from-minibuffer "(Un)trace: " spec)) 20 | ((symbolp spec) ; `sly-extract-context' can return symbols. 21 | (sly-read-from-minibuffer "(Un)trace: " (prin1-to-string spec))) 22 | (t 23 | (sly-dcase spec 24 | ((setf _n) 25 | (sly-read-from-minibuffer "(Un)trace: " (prin1-to-string spec))) 26 | ((:defun n) 27 | (sly-read-from-minibuffer "(Un)trace: " (prin1-to-string n))) 28 | ((:defgeneric n) 29 | (let* ((name (prin1-to-string n)) 30 | (answer (sly-read-from-minibuffer "(Un)trace: " name))) 31 | (cond ((and (string= name answer) 32 | (y-or-n-p (concat "(Un)trace also all " 33 | "methods implementing " 34 | name "? "))) 35 | (prin1-to-string `(:defgeneric ,n))) 36 | (t 37 | answer)))) 38 | ((:defmethod &rest _) 39 | (sly-read-from-minibuffer "(Un)trace: " (prin1-to-string spec))) 40 | ((:call caller callee) 41 | (let* ((callerstr (prin1-to-string caller)) 42 | (calleestr (prin1-to-string callee)) 43 | (answer (sly-read-from-minibuffer "(Un)trace: " 44 | calleestr))) 45 | (cond ((and (string= calleestr answer) 46 | (y-or-n-p (concat "(Un)trace only when " calleestr 47 | " is called by " callerstr "? "))) 48 | (prin1-to-string `(:call ,caller ,callee))) 49 | (t 50 | answer)))) 51 | (((:labels :flet) &rest _) 52 | (sly-read-from-minibuffer "(Un)trace local function: " 53 | (prin1-to-string spec))) 54 | (t (error "Don't know how to trace the spec %S" spec)))))) 55 | 56 | (defun sly-toggle-fancy-trace (&optional using-context-p) 57 | "Toggle trace." 58 | (interactive "P") 59 | (let* ((spec (if using-context-p 60 | (sly-extract-context) 61 | (sly-symbol-at-point))) 62 | (spec (sly-trace-query spec))) 63 | (sly-message "%s" (sly-eval `(slynk:slynk-toggle-trace ,spec))))) 64 | 65 | ;; override sly-toggle-trace-fdefinition 66 | (define-key sly-prefix-map "\C-t" 'sly-toggle-fancy-trace) 67 | 68 | (provide 'sly-fancy-trace) 69 | -------------------------------------------------------------------------------- /PROBLEMS.md: -------------------------------------------------------------------------------- 1 | Known problems with SLY 2 | ----------------------- 3 | 4 | ## Common to all backends 5 | 6 | ### Caution: network security 7 | 8 | The `M-x sly` command has Lisp listen on a TCP socket and wait for 9 | Emacs to connect, which typically takes on the order of one second. If 10 | someone else were to connect to this socket then they could use the 11 | SLY protocol to control the Lisp process. 12 | 13 | The listen socket is bound on the loopback interface in all Lisps that 14 | support this. This way remote hosts are unable to connect. 15 | 16 | ### READ-CHAR-NO-HANG is broken 17 | 18 | `READ-CHAR-NO-HANG` doesn't work properly for sly-input-streams. Due 19 | to the way we request input from Emacs it's not possible to repeatedly 20 | poll for input. To get any input you have to call `READ-CHAR` (or a 21 | function which calls `READ-CHAR`). 22 | 23 | ## Backend-specific problems 24 | 25 | ### CMUCL 26 | 27 | The default communication style `:SIGIO` is reportedly unreliable with 28 | certain libraries (like libSDL) and certain platforms (like Solaris on 29 | Sparc). It generally works very well on x86 so it remains the default. 30 | 31 | ### SBCL 32 | 33 | The latest released version of SBCL at the time of packaging should 34 | work. Older or newer SBCLs may or may not work. Do not use 35 | multithreading with unpatched 2.4 Linux kernels. There are also 36 | problems with kernel versions 2.6.5 - 2.6.10. 37 | 38 | The (v)iew-source command can only locate exact source forms for code 39 | compiled at (debug 2) or higher. The default level is lower and SBCL 40 | itself is compiled at a lower setting. Thus only defun-granularity is 41 | available with default policies. 42 | 43 | ### LispWorks 44 | 45 | On Windows, SLY hangs when calling foreign functions or certain 46 | other functions. The reason for this problem is unknown. 47 | 48 | We only support latin1 encoding. (Unicode wouldn't be hard to add.) 49 | 50 | ### Allegro CL 51 | 52 | Interrupting Allegro with C-c C-b can be slow. This is caused by the 53 | a relatively large process-quantum: 2 seconds by default. Allegro 54 | responds much faster if `MP:*DEFAULT-PROCESS-QUANTUM*` is set to 0.1. 55 | 56 | ### CLISP 57 | 58 | We require version 2.49 or higher. We also require socket support, so 59 | you may have to start CLISP with `clisp -K full`. 60 | 61 | Under Windows, interrupting (with C-c C-b) doesn't work. Emacs sends 62 | a SIGINT signal, but the signal is either ignored or CLISP exits 63 | immediately. 64 | 65 | On Windows, CLISP may refuse to parse filenames like 66 | "C:\\DOCUME~1\\johndoe\\LOCALS~1\\Temp\\sly.1424" when we actually 67 | mean C:\Documents and Settings\johndoe\Local Settings\sly.1424. As 68 | a workaround, you could set sly-to-lisp-filename-function to some 69 | function that returns a string that is accepted by CLISP. 70 | 71 | Function arguments and local variables aren't displayed properly in 72 | the backtrace. Changes to CLISP's C code are needed to fix this 73 | problem. Interpreted code is usually easer to debug. 74 | 75 | `M-.` (find-definition) only works if the fasl file is in the same 76 | directory as the source file. 77 | 78 | The arglist doesn't include the proper names only "fake symbols" like 79 | `arg1`. 80 | 81 | ### Armed Bear Common Lisp 82 | 83 | The ABCL support is still new and experimental. 84 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | ### Makefile for SLY 2 | # 3 | # This file is in the public domain. 4 | 5 | # Variables 6 | # 7 | EMACS ?= emacs 8 | LISP ?= sbcl 9 | 10 | LOAD_PATH=-L . -L contrib/ 11 | 12 | ELFILES := sly.el sly-autoloads.el $(wildcard lib/*.el) 13 | ELCFILES := $(ELFILES:.el=.elc) 14 | 15 | CONTRIBS = $(patsubst contrib/sly-%.el,%,$(wildcard contrib/sly-*.el)) 16 | 17 | CONTRIB_ELFILES := $(wildcard contrib/*.el) 18 | CONTRIB_ELCFILES := $(CONTRIB_ELFILES:.el=.elc) 19 | 20 | TEST_ELFILES := $(wildcard test/*.el) 21 | TEST_ELCFILES := $(TEST_ELFILES:.el=.elc) 22 | 23 | all: compile compile-contrib 24 | 25 | # Compilation 26 | # 27 | sly.elc: sly.el lib/hyperspec.elc 28 | 29 | %.elc: %.el 30 | $(EMACS) -Q $(LOAD_PATH) --batch -f batch-byte-compile $< 31 | 32 | compile: $(ELCFILES) 33 | compile-contrib: $(CONTRIB_ELCFILES) 34 | compile-test: $(TEST_ELCFILES) 35 | 36 | # Automated tests 37 | # 38 | check: check-core check-fancy 39 | 40 | check-core: SELECTOR=t 41 | check-core: compile 42 | $(EMACS) -Q --batch $(LOAD_PATH) \ 43 | --eval "(require 'sly-tests \"lib/sly-tests\")" \ 44 | --eval "(setq inferior-lisp-program \"$(LISP)\")" \ 45 | --eval '(sly-batch-test (quote $(SELECTOR)))' 46 | 47 | check-%: CONTRIB_NAME=$(patsubst check-%,sly-%,$@) 48 | check-%: SELECTOR=(tag contrib) 49 | check-%: compile contrib/sly-%.elc test/sly-%-tests.elc 50 | $(EMACS) -Q --batch $(LOAD_PATH) -L test \ 51 | --eval "(require (quote sly))" \ 52 | --eval "(setq sly-contribs (quote ($(CONTRIB_NAME))))" \ 53 | --eval "(require \ 54 | (intern \ 55 | (format \ 56 | \"%s-tests\" (quote $(CONTRIB_NAME)))))" \ 57 | --eval "(setq inferior-lisp-program \"$(LISP)\")" \ 58 | --eval '(sly-batch-test (quote $(SELECTOR)))' 59 | 60 | check-fancy: SELECTOR=(tag contrib) 61 | check-fancy: compile compile-contrib 62 | $(EMACS) -Q --batch $(LOAD_PATH) -L test \ 63 | --eval "(require (quote sly))" \ 64 | --eval "(sly-setup (quote (sly-fancy)))" \ 65 | --eval "(mapc (lambda (sym) \ 66 | (require \ 67 | (intern (format \"%s-tests\" sym)) \ 68 | nil t)) \ 69 | (sly-contrib--all-dependencies \ 70 | (quote sly-fancy)))" \ 71 | --eval '(setq inferior-lisp-program "$(LISP)")' \ 72 | --eval '(sly-batch-test (quote $(SELECTOR)))' 73 | 74 | 75 | # Cleanup 76 | # 77 | FASLREGEX = .*\.\(fasl\|ufasl\|sse2f\|lx32fsl\|abcl\|fas\|lib\|trace\)$$ 78 | 79 | clean-fasls: 80 | find . -regex '$(FASLREGEX)' -exec rm -v {} \; 81 | [ -d ~/.sly/fasl ] && rm -rf ~/.sly/fasl || true 82 | 83 | clean: clean-fasls 84 | find . -iname '*.elc' -exec rm {} \; 85 | 86 | # Doc 87 | # 88 | doc-%: 89 | $(MAKE) -C doc $(@:doc-%=%) 90 | doc: doc-help 91 | 92 | # Help 93 | # 94 | help: 95 | @printf "\ 96 | Main targets\n\ 97 | all -- compile all .el files\n\ 98 | compile -- compile just core SLY\n\ 99 | compile-contrib -- compile just contribs\n\ 100 | check -- run tests in batch mode\n\ 101 | clean -- delete generated files\n\ 102 | doc-help -- print help about doc targets\n\ 103 | help-vars -- print info about variables\n\ 104 | help -- print this message\n" 105 | 106 | help-vars: 107 | @printf "\ 108 | Main make variables:\n\ 109 | EMACS -- program to start Emacs ($(EMACS))\n\ 110 | LISP -- program to start Lisp ($(LISP))\n\ 111 | SELECTOR -- selector for ERT tests ($(SELECTOR))\n" 112 | 113 | .PHONY: all clean compile compile-contrib check check-core \ 114 | check-fancy dochelp help-vars 115 | -------------------------------------------------------------------------------- /doc/sly-refcard.tex: -------------------------------------------------------------------------------- 1 | \documentclass[a4paper,10pt]{article} 2 | 3 | \usepackage{textcomp} 4 | \usepackage{fullpage} 5 | \pagestyle{empty} 6 | 7 | 8 | \newcommand{\group}[1]{\bigskip\par\noindent\textbf{\large#1}\medskip} 9 | \newcommand{\subgroup}[1]{\medskip\par\noindent\textbf{#1}\smallskip} 10 | \newcommand{\key}[2]{\par\noindent\textbf{#1}\hfill{#2}} 11 | \newcommand{\meta}[1]{\textlangle{#1}\textrangle} 12 | 13 | \begin{document} 14 | 15 | \twocolumn[\LARGE\centering{SLY Quick Reference Card}\vskip1cm] 16 | 17 | \group{Getting help in Emacs} 18 | 19 | \key{C-h \meta{key}}{describe function bound to \meta{key}} 20 | \key{C-h b}{list the current key-bindings for the focus buffer} 21 | \key{C-h m}{describe mode} 22 | \key{C-h l}{shows the keys you have pressed} 23 | \key{\meta{key} l}{what starts with \meta{key}} 24 | 25 | \group{Programming} 26 | 27 | \subgroup{Completion} 28 | 29 | \key{C-c tab}{complete symbol} 30 | 31 | \subgroup{Closure} 32 | 33 | \key{C-c C-q}{close parens at point} 34 | \key{C-]}{close all sexp} 35 | 36 | \subgroup{Indentation} 37 | 38 | \key{C-c M-q}{reindent defun} 39 | \key{C-M-q}{indent sexp} 40 | 41 | \subgroup{Documentation} 42 | 43 | \key{spc}{insert a space, display argument list} 44 | \key{C-c C-d C-d}{describe symbol} 45 | \key{C-c C-d C-f}{describe function} 46 | \key{C-c C-d C-a}{apropos search for regexp} 47 | \key{C-c C-d C-z}{apropos with internal symbols} 48 | \key{C-c C-d C-p}{apropos in package} 49 | \key{C-c C-d C-h}{hyperspec lookup} 50 | \key{C-c C-d C-\~}{format character hyperspec lookup} 51 | 52 | 53 | \subgroup{Cross reference} 54 | 55 | \key{C-c C-w C-c}{show function callers} 56 | \key{C-c C-w C-r}{show references to global variable} 57 | \key{C-c C-w C-b}{show bindings of a global variable} 58 | \key{C-c C-w C-s}{show assignments to a global variable} 59 | \key{C-c C-w C-m}{show expansions of a macro} 60 | \key{C-c \textless}{list callers of a function} 61 | \key{C-c \textgreater}{list callees of a function} 62 | 63 | \subgroup{Finding definitions} 64 | 65 | \key{M-.}{edit definition} 66 | \key{M-, or M-*}{pop definition stack} 67 | \key{C-x 4 .}{edit definition in other window} 68 | \key{C-x 5 .}{edit definition in other frame} 69 | 70 | \newpage 71 | 72 | \subgroup{Macro expansion commands} 73 | 74 | \key{C-c C-m or C-c RET}{macroexpand-1} 75 | \key{C-c M-m}{macroexpand-all} 76 | \key{C-c C-t}{toggle tracing of the function at point} 77 | 78 | \subgroup{Disassembly} 79 | 80 | \key{C-c M-d}{disassemble function definition} 81 | 82 | \group{Compilation} 83 | 84 | \key{C-c C-c}{compile defun} 85 | \key{C-c C-y}{call defun} 86 | \key{C-c C-k}{compile and load file} 87 | \key{C-c M-k}{compile file} 88 | \key{C-c C-l}{load file} 89 | \key{C-c C-z}{switch to output buffer} 90 | \key{M-n}{next note} 91 | \key{M-p}{previous note} 92 | \key{C-c M-c}{remove notes} 93 | 94 | \group{Evaluation} 95 | 96 | \key{C-M-x}{eval defun} 97 | \key{C-x C-e}{eval last expression} 98 | \key{C-c C-p}{eval \& pretty print last expression} 99 | \key{C-c C-r}{eval region} 100 | \key{C-x M-e}{eval last expression, display output} 101 | \key{C-c :}{interactive eval} 102 | \key{C-c E}{edit value} 103 | \key{C-c C-u}{undefine function} 104 | 105 | \group{Abort/Recovery} 106 | 107 | \key{C-c C-b}{interrupt (send SIGINT)} 108 | \key{C-c \~}{sync the current package and working directory} 109 | \key{C-c M-p}{set package in REPL} 110 | 111 | \group{Inspector} 112 | 113 | \key{C-c I}{inspect (from minibuffer)} 114 | \key{ret}{operate on point} 115 | \key{d}{describe} 116 | \key{l}{pop} 117 | \key{n}{next} 118 | \key{q}{quit} 119 | \key{M-ret}{copy down} 120 | 121 | \end{document} 122 | -------------------------------------------------------------------------------- /test/sly-mrepl-tests.el: -------------------------------------------------------------------------------- 1 | ;; -*- lexical-binding: t; -*- 2 | (require 'sly-mrepl "contrib/sly-mrepl") 3 | (require 'sly-tests "lib/sly-tests") 4 | (require 'cl-lib) 5 | (require 'ert-x) 6 | 7 | 8 | (cl-defun sly-mrepl-tests--assert-prompt (&optional (prompt "CL-USER>")) 9 | (let ((proper-prompt-p nil)) 10 | (cl-loop 11 | repeat 5 12 | when (looking-back (format "%s $" prompt) (- (point) 100)) 13 | do (setq proper-prompt-p t) 14 | (cl-return) 15 | do (sit-for 0.3)) 16 | (or proper-prompt-p 17 | (ert-fail (format "Proper prompt not seen in time (saw last 20 chars as \"%s\")" 18 | (buffer-substring-no-properties (max (point-min) 19 | (- (point-max) 20 | 20)) 21 | (point-max))))))) 22 | 23 | (defun sly-mrepl-tests--assert-dedicated-stream () 24 | (let ((dedicated-stream nil)) 25 | (cl-loop 26 | repeat 5 27 | when (and sly-mrepl--dedicated-stream 28 | (processp sly-mrepl--dedicated-stream) 29 | (process-live-p sly-mrepl--dedicated-stream)) 30 | do (setq dedicated-stream t) 31 | (cl-return) 32 | do (sleep-for 0 300)) 33 | (or dedicated-stream 34 | (ert-fail "Dedicated stream not setup correctly")))) 35 | 36 | (defvar sly-mrepl-tests--debug nil) 37 | (setq sly-mrepl-tests--debug nil) 38 | 39 | (defmacro sly-mrepl-tests--with-basic-repl-setup (&rest body) 40 | (declare (debug (&rest form))) 41 | `(let ((sly-buffer-package "COMMON-LISP-USER")) 42 | (with-current-buffer (sly-mrepl-new (sly-current-connection) 43 | "test-only-repl") 44 | (unwind-protect 45 | (progn 46 | (sly-mrepl-tests--assert-prompt) 47 | (sly-mrepl-tests--assert-dedicated-stream) 48 | ,@body) 49 | (unless sly-mrepl-tests--debug 50 | (kill-buffer (current-buffer))))))) 51 | 52 | (defun sly-mrepl-tests--current-input-string () 53 | (buffer-substring-no-properties (sly-mrepl--mark) (point-max))) 54 | 55 | (define-sly-ert-test basic-repl-setup () 56 | (sly-mrepl-tests--with-basic-repl-setup)) 57 | 58 | (define-sly-ert-test repl-values-and-button-navigation () 59 | (sly-mrepl-tests--with-basic-repl-setup 60 | (insert "(values (list 1 2 3) #(1 2 3))") 61 | (sly-mrepl-return) 62 | (sly-mrepl-tests--assert-prompt) 63 | (ert-simulate-command '(sly-button-backward 1)) 64 | (ert-simulate-command '(sly-button-backward 1)) 65 | (should-error 66 | (ert-simulate-command '(sly-button-backward 1))) 67 | (ert-simulate-command '(sly-button-forward 1)))) 68 | 69 | (when (>= emacs-major-version 25) 70 | (define-sly-ert-test repl-completion-pop-up-window () 71 | (sly-mrepl-tests--with-basic-repl-setup 72 | (insert "(setq echonumberli)") 73 | (backward-char 1) 74 | (ert-simulate-command '(completion-at-point)) 75 | (should (get-buffer-window "*sly-completions*")))) 76 | 77 | (define-sly-ert-test repl-completion-choose-candidates () 78 | (sly-mrepl-tests--with-basic-repl-setup 79 | (let ((symbol-snippet "multiple-value-t")) 80 | (insert "'()") 81 | (backward-char 1) 82 | (insert symbol-snippet) 83 | (ert-simulate-command '(completion-at-point)) 84 | (should (get-buffer-window "*sly-completions*")) 85 | (ert-simulate-command '(sly-choose-completion)) 86 | (should (string= "'(multiple-value-setq)" 87 | (sly-mrepl-tests--current-input-string))) 88 | (backward-sexp) 89 | (kill-sexp) 90 | (insert symbol-snippet) 91 | (ert-simulate-command '(completion-at-point)) 92 | (ert-simulate-command '(sly-next-completion 1)) 93 | (ert-simulate-command '(sly-choose-completion)) 94 | (should (string= "'(multiple-value-list)" 95 | (sly-mrepl-tests--current-input-string))))))) 96 | 97 | (provide 'sly-mrepl-tests) 98 | -------------------------------------------------------------------------------- /test/sly-fontifying-fu-tests.el: -------------------------------------------------------------------------------- 1 | ;; -*- lexical-binding: t; -*- 2 | (require 'sly-fontifying-fu "contrib/sly-fontifying-fu") 3 | (require 'sly-tests "lib/sly-tests") 4 | (require 'sly-autodoc "contrib/sly-autodoc") 5 | 6 | (cl-defun sly-initialize-lisp-buffer-for-test-suite 7 | (&key (font-lock-magic t) (autodoc t)) 8 | (let ((hook lisp-mode-hook)) 9 | (unwind-protect 10 | (progn 11 | (set (make-local-variable 'sly-highlight-suppressed-forms) 12 | font-lock-magic) 13 | (setq lisp-mode-hook nil) 14 | (lisp-mode) 15 | (sly-mode 1) 16 | (when (boundp 'sly-autodoc-mode) 17 | (if autodoc 18 | (sly-autodoc-mode 1) 19 | (sly-autodoc-mode -1)))) 20 | (setq lisp-mode-hook hook)))) 21 | 22 | (def-sly-test font-lock-magic (buffer-content) 23 | "Some testing for the font-lock-magic. *YES* should be 24 | highlighted as a suppressed form, *NO* should not." 25 | 26 | '(("(defun *NO* (x y) (+ x y))") 27 | ("(defun *NO*") 28 | ("*NO*) #-(and) (*YES*) (*NO* *NO*") 29 | ("\( 30 | \(defun *NO*") 31 | ("\) 32 | \(defun *NO* 33 | \( 34 | \)") 35 | ("#+#.foo 36 | \(defun *NO* (x y) (+ x y))") 37 | ("#+#.foo 38 | \(defun *NO* (x ") 39 | ("#+( 40 | \(defun *NO* (x ") 41 | ("#+(test) 42 | \(defun *NO* (x ") 43 | 44 | ("(eval-when (...) 45 | \(defun *NO* (x ") 46 | 47 | ("(eval-when (...) 48 | #+(and) 49 | \(defun *NO* (x ") 50 | 51 | ("#-(and) (defun *YES* (x y) (+ x y))") 52 | (" 53 | #-(and) (defun *YES* (x y) (+ x y)) 54 | #+(and) (defun *NO* (x y) (+ x y))") 55 | 56 | ("#+(and) (defun *NO* (x y) #-(and) (+ *YES* y))") 57 | ("#| #+(or) |# *NO*") 58 | ("#| #+(or) x |# *NO*") 59 | ("*NO* \"#| *NO* #+(or) x |# *NO*\" *NO*") 60 | ("#+#.foo (defun foo (bar)) 61 | #-(and) *YES* *NO* bar 62 | ") 63 | ("#+(foo) (defun foo (bar)) 64 | #-(and) *YES* *NO* bar") 65 | ("#| #+(or) |# *NO* foo 66 | #-(and) *YES* *NO*") 67 | ("#- (and) 68 | \(*YES*) 69 | \(*NO*) 70 | #-(and) 71 | \(*YES*) 72 | \(*NO*)") 73 | ("#+nil (foo) 74 | 75 | #-(and) 76 | #+nil ( 77 | asdf *YES* a 78 | fsdfad) 79 | 80 | \( asdf *YES* 81 | 82 | ) 83 | \(*NO*) 84 | 85 | ") 86 | ("*NO* 87 | 88 | #-(and) \(progn 89 | #-(and) 90 | (defun *YES* ...) 91 | 92 | #+(and) 93 | (defun *YES* ...) 94 | 95 | (defun *YES* ...) 96 | 97 | *YES* 98 | 99 | *YES* 100 | 101 | *YES* 102 | 103 | *YES* 104 | \) 105 | 106 | *NO*") 107 | ("#-(not) *YES* *NO* 108 | 109 | *NO* 110 | 111 | #+(not) *NO* *NO* 112 | 113 | *NO* 114 | 115 | #+(not a b c) *NO* *NO* 116 | 117 | *NO*")) 118 | (sly-check-top-level) 119 | (with-temp-buffer 120 | (insert buffer-content) 121 | (sly-initialize-lisp-buffer-for-test-suite 122 | :autodoc t :font-lock-magic t) 123 | ;; Can't use `font-lock-fontify-buffer' because for the case when 124 | ;; `jit-lock-mode' is enabled. Jit-lock-mode fontifies only on 125 | ;; actual display. 126 | (font-lock-default-fontify-buffer) 127 | (when (search-backward "*NO*" nil t) 128 | (sly-test-expect "Not suppressed by reader conditional?" 129 | 'sly-reader-conditional-face 130 | (get-text-property (point) 'face) 131 | (lambda (x y) 132 | (let ((y (if (listp y) y (list y)))) 133 | (not (memq x y)))))) 134 | (goto-char (point-max)) 135 | (when (search-backward "*YES*" nil t) 136 | (sly-test-expect "Suppressed by reader conditional?" 137 | 'sly-reader-conditional-face 138 | (get-text-property (point) 'face) 139 | (lambda (x y) 140 | (let ((y (if (listp y) y (list y)))) 141 | (memq x y))))))) 142 | 143 | (provide 'sly-fontifying-fu-tests) 144 | -------------------------------------------------------------------------------- /slynk/slynk.asd: -------------------------------------------------------------------------------- 1 | ;;; -*- lisp -*- 2 | (in-package :asdf) 3 | 4 | ;; ASDF system definition for loading the Slynk server independently 5 | ;; of Emacs. 6 | ;; 7 | ;; Usage: 8 | ;; 9 | ;; (push #p"/path/to/this/file/" asdf:*central-registry*) 10 | ;; (asdf:load-system :slynk) 11 | ;; (slynk:create-server :port PORT) => ACTUAL-PORT 12 | ;; 13 | ;; (PORT can be zero to mean "any available port".) 14 | ;; Then the Slynk server is running on localhost:ACTUAL-PORT. You can 15 | ;; use `M-x sly-connect' to connect Emacs to it. 16 | ;; 17 | ;; This code has been placed in the Public Domain. All warranties 18 | ;; are disclaimed. 19 | 20 | (defsystem :slynk 21 | :serial t 22 | ;; See commit message and GitHub#502, GitHub#501 for the reason 23 | ;; for this dedicated sbcl muffling. 24 | #+sbcl 25 | :around-compile 26 | #+sbcl 27 | (lambda (thunk) 28 | (handler-bind (((and warning (not style-warning)) 29 | (lambda (c) 30 | (format *error-output* "~&~@<~S: ~3i~:_~A~:>~%" 31 | (class-name (class-of c)) c) 32 | (muffle-warning c)))) 33 | (let ((sb-ext:*on-package-variance* '(:warn t))) 34 | (funcall thunk)))) 35 | :components 36 | ((:file "slynk-match") 37 | (:file "slynk-backend") 38 | ;; If/when we require ASDF3, we shall use :if-feature instead 39 | #+(or cmu sbcl scl) 40 | (:file "slynk-source-path-parser") 41 | #+(or cmu ecl sbcl scl) 42 | (:file "slynk-source-file-cache") 43 | #+clisp 44 | (:file "xref") 45 | #+(or clisp clozure clasp) 46 | (:file "metering") 47 | (:module "backend" 48 | :serial t 49 | :components (#+allegro 50 | (:file "allegro") 51 | #+armedbear 52 | (:file "abcl") 53 | #+clisp 54 | (:file "clisp") 55 | #+clozure 56 | (:file "ccl") 57 | #+cmu 58 | (:file "cmucl") 59 | #+cormanlisp 60 | (:file "corman") 61 | #+ecl 62 | (:file "ecl") 63 | #+lispworks 64 | (:file "lispworks") 65 | #+sbcl 66 | (:file "sbcl") 67 | #+clasp 68 | (:file "clasp") 69 | #+scl 70 | (:file "scl") 71 | #+mkcl 72 | (:file "mkcl"))) 73 | #-armedbear 74 | (:file "slynk-gray") 75 | (:file "slynk-rpc") 76 | (:file "slynk") 77 | (:file "slynk-completion") 78 | (:file "slynk-apropos"))) 79 | 80 | (defmethod perform :after ((o load-op) (c (eql (find-system :slynk)))) 81 | (format *debug-io* "~&SLYNK's ASDF loader finished.") 82 | (funcall (with-standard-io-syntax (read-from-string "slynk::init")))) 83 | 84 | 85 | ;;; Contrib systems (should probably go into their own file one day) 86 | ;;; 87 | (defsystem :slynk/arglists 88 | :depends-on (:slynk) 89 | :components ((:file "../contrib/slynk-arglists"))) 90 | 91 | (defsystem :slynk/fancy-inspector 92 | :depends-on (:slynk) 93 | :components ((:file "../contrib/slynk-fancy-inspector"))) 94 | 95 | (defsystem :slynk/package-fu 96 | :depends-on (:slynk) 97 | :components ((:file "../contrib/slynk-package-fu"))) 98 | 99 | (defsystem :slynk/mrepl 100 | :depends-on (:slynk) 101 | :components ((:file "../contrib/slynk-mrepl"))) 102 | 103 | (defsystem :slynk/trace-dialog 104 | :depends-on (:slynk) 105 | :components ((:file "../contrib/slynk-trace-dialog"))) 106 | 107 | (defsystem :slynk/profiler 108 | :depends-on (:slynk) 109 | :components ((:file "../contrib/slynk-profiler"))) 110 | 111 | (defsystem :slynk/stickers 112 | :depends-on (:slynk) 113 | :components ((:file "../contrib/slynk-stickers"))) 114 | 115 | (defsystem :slynk/indentation 116 | :depends-on (:slynk) 117 | :components ((:file "../contrib/slynk-indentation"))) 118 | 119 | (defsystem :slynk/retro 120 | :depends-on (:slynk) 121 | :components ((:file "../contrib/slynk-retro"))) 122 | -------------------------------------------------------------------------------- /doc/Makefile: -------------------------------------------------------------------------------- 1 | # This file has been placed in the public domain. 2 | # 3 | # Where to put the info file(s). NB: the GNU Coding Standards (GCS) 4 | # and the Filesystem Hierarchy Standard (FHS) differ on where info 5 | # files belong. The GCS says /usr/local/info; the FHS says 6 | # /usr/local/share/info. Many distros obey the FHS, but people who 7 | # installed their emacs from source probably have a GCS-ish file 8 | # hierarchy. 9 | infodir=/usr/local/info 10 | 11 | # What command to use to install info file(s) 12 | INSTALL_CMD=install -m 644 13 | 14 | # Info files generated here. 15 | infofiles=sly.info 16 | 17 | TEXI = sly.texi 18 | 19 | help: 20 | @echo -e "\ 21 | Most important targets:\n\ 22 | all generate info, pdf, and html documents\n\ 23 | sly.info generate the sly.info file\n\ 24 | sly.html generate a single html file\n\ 25 | html/index.html generate on html file per node in html/ directory\n\ 26 | html.tgz create a tarball of all html files\n\ 27 | clean remove generated files" 28 | 29 | all: sly.info sly.pdf html/index.html 30 | 31 | sly.dvi: $(TEXI) 32 | texi2dvi sly.texi 33 | 34 | sly.ps: sly.dvi 35 | dvips -o $@ $< 36 | 37 | sly.info: $(TEXI) 38 | makeinfo $< 39 | 40 | sly.html: $(TEXI) 41 | texi2html --css-include=sly.css $< 42 | 43 | html/index.html: $(TEXI) 44 | makeinfo -o html --css-include=sly.css --html $< 45 | 46 | html.tgz: html/index.html 47 | tar -czf $@ html 48 | 49 | DOCDIR=/project/sly/public_html/doc 50 | 51 | gh-pages: 52 | git clone git@github.com:joaotavora/sly.git --branch gh-pages --single-branch gh-pages 53 | 54 | publish: sly.html gh-pages 55 | cp sly.html gh-pages/index.html 56 | cp -Rf images/*.png gh-pages/images 57 | cd gh-pages \ 58 | && git add index.html images/* \ 59 | && git commit -a -m "Automatic documentation update" \ 60 | && git pull --rebase \ 61 | && git push origin gh-pages 62 | 63 | sly.pdf: $(TEXI) 64 | texi2pdf $< 65 | 66 | sly-refcard.pdf: sly-refcard.tex 67 | texi2pdf $< 68 | 69 | install: install-info 70 | 71 | uninstall: uninstall-info 72 | 73 | # Create contributors.texi, a texinfo table listing all known 74 | # contributors of code. 75 | # 76 | # Explicitly includes Eric Marsden (pre-ChangeLog hacker) 77 | # 78 | # The gist of this horror show is that the contributor list is piped 79 | # into texinfo-tabulate.awk with one name per line, sorted 80 | # alphabetically. 81 | contributors.texi: Makefile texinfo-tabulate.awk 82 | git log --format='%aN' | \ 83 | sort | \ 84 | uniq -c | \ 85 | LC_ALL=C sort -nr | \ 86 | sed -e 's/^[^A-Z]*//; /^$$/d' | \ 87 | LC_ALL=C awk -f texinfo-tabulate.awk \ 88 | > $@ 89 | 90 | #.INTERMEDIATE: contributors.texi 91 | 92 | optimize-png: 93 | optipng -clobber -o 7 images/*.png 94 | 95 | # Debian's install-info wants a --section argument. 96 | install-info: section=$(shell grep INFO-DIR-SECTION $(infofiles) | sed 's/INFO-DIR-SECTION //') 97 | install-info: sly.info 98 | mkdir -p $(infodir) 99 | $(INSTALL_CMD) $(infofiles) $(infodir)/$(infofiles) 100 | @if (install-info --version && \ 101 | install-info --version 2>&1 | sed 1q | grep -i -v debian) >/dev/null 2>&1; then \ 102 | echo "install-info --info-dir=$(infodir) $(infodir)/$(infofiles)";\ 103 | install-info --info-dir="$(infodir)" "$(infodir)/$(infofiles)" || :;\ 104 | else \ 105 | echo "install-info --infodir=$(infodir) --section $(section) $(section) $(infodir)/$(infofiles)" && \ 106 | install-info --infodir="$(infodir)" --section $(section) ${section} "$(infodir)/$(infofiles)" || :; fi 107 | 108 | uninstall-info: 109 | @if (install-info --version && \ 110 | install-info --version 2>&1 | sed 1q | grep -i -v debian) >/dev/null 2>&1; then \ 111 | echo "install-info --info-dir=$(infodir) --remove $(infodir)/$(infofiles)";\ 112 | install-info --info-dir="$(infodir)" --remove "$(infodir)/$(infofiles)" || :;\ 113 | else \ 114 | echo "install-info --infodir=$(infodir) --remove $(infodir)/$(infofiles)";\ 115 | install-info --infodir="$(infodir)" --remove "$(infodir)/$(infofiles)" || :; fi 116 | rm -f $(infodir)/$(infofiles) 117 | 118 | clean: 119 | rm -f contributors.texi 120 | rm -f sly.aux sly.cp sly.cps sly.fn sly.fns sly.ky 121 | rm -f sly.kys sly.log sly.pg sly.tmp sly.toc sly.tp 122 | rm -f sly.vr sly.vrs 123 | rm -f sly.info sly.pdf sly.dvi sly.ps sly.html 124 | rm -f sly-refcard.pdf sly-refcard.log sly-refcard.aux 125 | rm -rf html html.tgz 126 | -------------------------------------------------------------------------------- /test/sly-indentation-tests.el: -------------------------------------------------------------------------------- 1 | ;; -*- lexical-binding: t; -*- 2 | (require 'sly-indentation "contrib/sly-indentation") 3 | (require 'sly-tests "lib/sly-tests") 4 | 5 | (sly-define-common-lisp-style "common-lisp-indent-test" 6 | ;; Used to specify a few complex indentation specs for testing. 7 | ;; (:inherit "basic") ; Commented: unnecessatily messes up test 58 8 | (:indentation 9 | (complex-indent.1 ((&whole 4 (&whole 1 1 1 1 (&whole 1 1) &rest 1) 10 | &body) &body)) 11 | (complex-indent.2 (4 (&whole 4 &rest 1) &body)) 12 | (complex-indent.3 (4 &body)))) 13 | 14 | (defun sly-indentation-mess-up-indentation () 15 | (while (not (eobp)) 16 | (forward-line 1) 17 | (unless (looking-at "^$") 18 | (cl-case (random 2) 19 | (0 20 | ;; Delete all leading whitespace -- except for 21 | ;; comment lines. 22 | (while (and (looking-at " ") (not (looking-at " ;"))) 23 | (delete-char 1))) 24 | (1 25 | ;; Insert whitespace random. 26 | (let ((n (1+ (random 24)))) 27 | (while (> n 0) (cl-decf n) (insert " "))))))) 28 | (buffer-string)) 29 | 30 | (defvar sly-indentation--test-function nil 31 | "Can be set indentation tests to `indent-region' if need be.") 32 | 33 | (defun sly-indentation-test--1 (bindings expected) 34 | (cl-flet ((count-leading 35 | (line) 36 | (cl-loop for char across line 37 | while (eq char ? ) 38 | count 1))) 39 | (with-temp-buffer 40 | (lisp-mode) 41 | (setq indent-tabs-mode nil) 42 | (sly-common-lisp-set-style "common-lisp-indent-test") 43 | (cl-loop for (sym value) in bindings 44 | do (set (make-local-variable sym) value)) 45 | (insert expected) 46 | (goto-char (point-min)) 47 | (let ((mess (sly-indentation-mess-up-indentation))) 48 | (when (string= mess expected) 49 | (ert-fail "Could not mess up indentation?")) 50 | (goto-char (point-min)) 51 | (indent-region (point-min) (point-max)) ;; Used to be 52 | ;; ‘indent-sexp’, but 53 | ;; was super unstable 54 | ;; on travis, for 55 | ;; some reason. 56 | (delete-trailing-whitespace) 57 | (let ((expected-lines (split-string expected "\n")) 58 | (observed-lines (split-string (buffer-string) "\n"))) 59 | (should (= (length expected-lines) 60 | (length observed-lines))) 61 | (cl-loop for expected in expected-lines 62 | for observed in observed-lines 63 | for n-expected = (count-leading expected) 64 | for n-observed = (count-leading observed) 65 | unless (= n-expected n-observed) 66 | do (message "Starting with this mess:\n%s" mess) 67 | (message "\nGot this result:\n%s" (buffer-string)) 68 | (ert-fail 69 | (format 70 | "Expected line `%s' to have %d leading spaces. Got %d" 71 | expected n-expected n-observed))) 72 | ;; (should (equal expected (buffer-string))) 73 | ))))) 74 | 75 | (eval-and-compile 76 | (defun sly-indentation-test-form (test-name bindings expected) 77 | `(define-sly-ert-test ,test-name () 78 | ,(format "An indentation test named `%s'" test-name) 79 | (sly-indentation-test--1 ',bindings ,expected))) 80 | 81 | (defun sly-indentation-test-forms-for-file (file) 82 | (with-current-buffer 83 | (find-file-noselect (expand-file-name file sly-path)) 84 | (goto-char (point-min)) 85 | (cl-loop 86 | while (re-search-forward ";;; Test:[\t\n\s]*\\(.*\\)[\t\n\s]" nil t) 87 | for test-name = (intern (match-string-no-properties 1)) 88 | for bindings = 89 | (save-restriction 90 | (narrow-to-region (point) 91 | (progn (forward-comment 92 | (point-max)) 93 | (point))) 94 | (save-excursion 95 | (goto-char (point-min)) 96 | (cl-loop while 97 | (re-search-forward 98 | "\\([^\s]*\\)[\t\n\s]*:[\t\n\s]*\\(.*\\)[\t\n\s]" nil t) 99 | collect (list 100 | (intern (match-string-no-properties 1)) 101 | (car 102 | (read-from-string (match-string-no-properties 2))))))) 103 | for expected = (buffer-substring-no-properties (point) 104 | (scan-sexps (point) 105 | 1)) 106 | collect (sly-indentation-test-form test-name bindings expected))))) 107 | 108 | (defmacro sly-indentation-define-tests () 109 | `(progn 110 | ,@(sly-indentation-test-forms-for-file "test/sly-cl-indent-test.txt"))) 111 | 112 | (sly-indentation-define-tests) 113 | 114 | (provide 'sly-indentation-tests) 115 | -------------------------------------------------------------------------------- /contrib/sly-tramp.el: -------------------------------------------------------------------------------- 1 | ;; -*- lexical-binding: t; -*- 2 | (require 'sly) 3 | (require 'tramp) 4 | (require 'cl-lib) 5 | 6 | (define-sly-contrib sly-tramp 7 | "Filename translations for tramp" 8 | (:authors "Marco Baringer ") 9 | (:license "GPL") 10 | (:on-load 11 | (setq sly-to-lisp-filename-function #'sly-tramp-to-lisp-filename) 12 | (setq sly-from-lisp-filename-function #'sly-tramp-from-lisp-filename))) 13 | 14 | (defcustom sly-filename-translations nil 15 | "Assoc list of hostnames and filename translation functions. 16 | Each element is of the form (HOSTNAME-REGEXP TO-LISP FROM-LISP). 17 | 18 | HOSTNAME-REGEXP is a regexp which is applied to the connection's 19 | sly-machine-instance. If HOSTNAME-REGEXP maches then the 20 | corresponding TO-LISP and FROM-LISP functions will be used to 21 | translate emacs filenames and lisp filenames. 22 | 23 | TO-LISP will be passed the filename of an emacs buffer and must 24 | return a string which the underlying lisp understandas as a 25 | pathname. FROM-LISP will be passed a pathname as returned by the 26 | underlying lisp and must return something that emacs will 27 | understand as a filename (this string will be passed to 28 | find-file). 29 | 30 | This list will be traversed in order, so multiple matching 31 | regexps are possible. 32 | 33 | Example: 34 | 35 | Assuming you run emacs locally and connect to sly running on 36 | the machine 'soren' and you can connect with the username 37 | 'animaliter': 38 | 39 | (push (list \"^soren$\" 40 | (lambda (emacs-filename) 41 | (subseq emacs-filename (length \"/ssh:animaliter@soren:\"))) 42 | (lambda (lisp-filename) 43 | (concat \"/ssh:animaliter@soren:\" lisp-filename))) 44 | sly-filename-translations) 45 | 46 | See also `sly-create-filename-translator'." 47 | :type '(repeat (list :tag "Host description" 48 | (regexp :tag "Hostname regexp") 49 | (function :tag "To lisp function") 50 | (function :tag "From lisp function"))) 51 | :group 'sly-lisp) 52 | 53 | (defun sly-find-filename-translators (hostname) 54 | (cond ((cdr (cl-assoc-if (lambda (regexp) (string-match regexp hostname)) 55 | sly-filename-translations))) 56 | (t (list #'identity #'identity)))) 57 | 58 | (defun sly-make-tramp-file-name (username remote-host lisp-filename) 59 | "Tramp compatability function. 60 | 61 | Handles the signature of `tramp-make-tramp-file-name' changing 62 | over time." 63 | (cond 64 | ((>= emacs-major-version 26) 65 | ;; Emacs 26 requires the method to be provided and the signature of 66 | ;; `tramp-make-tramp-file-name' has changed. 67 | (tramp-make-tramp-file-name (tramp-find-method nil username remote-host) 68 | username 69 | nil 70 | remote-host 71 | nil 72 | lisp-filename)) 73 | ((boundp 'tramp-multi-methods) 74 | (tramp-make-tramp-file-name nil nil 75 | username 76 | remote-host 77 | lisp-filename)) 78 | (t 79 | (tramp-make-tramp-file-name nil 80 | username 81 | remote-host 82 | lisp-filename)))) 83 | 84 | (cl-defun sly-create-filename-translator (&key machine-instance 85 | remote-host 86 | username) 87 | "Creates a three element list suitable for push'ing onto 88 | sly-filename-translations which uses Tramp to load files on 89 | hostname using username. MACHINE-INSTANCE is a required 90 | parameter, REMOTE-HOST defaults to MACHINE-INSTANCE and USERNAME 91 | defaults to (user-login-name). 92 | 93 | MACHINE-INSTANCE is the value returned by sly-machine-instance, 94 | which is just the value returned by cl:machine-instance on the 95 | remote lisp. REMOTE-HOST is the fully qualified domain name (or 96 | just the IP) of the remote machine. USERNAME is the username we 97 | should login with. 98 | The functions created here expect your tramp-default-method or 99 | tramp-default-method-alist to be setup correctly." 100 | (let ((remote-host (or remote-host machine-instance)) 101 | (username (or username (user-login-name)))) 102 | (list (concat "^" machine-instance "$") 103 | (lambda (emacs-filename) 104 | (tramp-file-name-localname 105 | (tramp-dissect-file-name emacs-filename))) 106 | `(lambda (lisp-filename) 107 | (sly-make-tramp-file-name 108 | ,username 109 | ,remote-host 110 | lisp-filename))))) 111 | 112 | (defun sly-tramp-to-lisp-filename (filename) 113 | (funcall (if (let ((conn (sly-current-connection))) 114 | (and conn (process-live-p conn))) 115 | (cl-first (sly-find-filename-translators (sly-machine-instance))) 116 | 'identity) 117 | (expand-file-name filename))) 118 | 119 | (defun sly-tramp-from-lisp-filename (filename) 120 | (funcall (cl-second (sly-find-filename-translators (sly-machine-instance))) 121 | filename)) 122 | 123 | (provide 'sly-tramp) 124 | -------------------------------------------------------------------------------- /contrib/sylvesters.txt: -------------------------------------------------------------------------------- 1 | ( \ 2 | \ \ 3 | / / |\\ 4 | / / .-`````-. / ^`-. 5 | \ \ / \_/ {|} `o 6 | \ \ / .---. \\ _ ,--' 7 | \ \/ / \, \( `^^^ @@@@ 8 | \ \/\ (\ ) 9 | \ ) \ ) \ \ 10 | ) /__ \__ ) (\ \___ 11 | jgs (___)))__))(__))(__))) 12 | 13 | _,'| _.-''``-...___..--';) 14 | /_ \'. __..-' , ,--...--''' 15 | <\ .`--''' ` /' 16 | fxlee `-';' ; ; ; 17 | __...--'' ___...--_..' .;.' 18 | (,__....----''' (,..--'' @@@@ 19 | 20 | 21 | @@@@ 22 | . 23 | ("`-''-/").___..--''"`-._ 24 | `6_ 6 ) `-. ( ).`-.__.`) 25 | (_Y_.)' ._ ) `._ `. ``-..-' 26 | _..`--'_..-_/ /--'_.' ,' 27 | (il),-'' (li),' ((!.-' fxlee 28 | 29 | 30 | @@@@ 31 | |\ _,,,---,,_ 32 | /,`.-'`' -. ;-;;,_ 33 | |,4- ) )-,_..;\ ( `'-' 34 | '---''(_/--' `-'\_) 35 | fxlee 36 | 37 | @@@@ 38 | . 39 | __..--''``\--....___ _..,_ 40 | _.-' .-/"; ` ``<._ ``-+'~=. 41 | _.-' _..--.'_ \ `(^) ) 42 | ((..-' (< _ ;_..__ ; `' 43 | `-._,_)' ``--...____..-' 44 | fxlee 45 | 46 | (`.-,') 47 | .-' ; 48 | _.-' , `,- 49 | fxlee _ _.-' .' /._ 50 | .' ` _.-. / ,'._;) 51 | ( . )-| ( 52 | )`,_ ,'_,' \_;) @@@@ 53 | ('_ _,'.' (___,)) 54 | `-:;.-' 55 | 56 | |\___/| 57 | ) ( . ' 58 | =\ /= 59 | )===( * 60 | / \ 61 | | | @@@@ 62 | / \ 63 | \ / 64 | jgs_/\_/\__ _/_/\_/\_/\_/\_/\_/\_/\_/\_/\_ 65 | | | | |( ( | | | | | | | | | | 66 | | | | | ) ) | | | | | | | | | | 67 | | | | |(_( | | | | | | | | | | 68 | | | | | | | | | | | | | | | | 69 | | | | | | | | | | | | | | | | 70 | 71 | |\___/| 72 | =) ^Y^ (= . ' 73 | \ ^ / 74 | )=*=( * 75 | / \ 76 | | | 77 | /| | | |\ @@@@ 78 | \| | |_|/\ 79 | jgs_/\_//_// ___/\_/\_/\_/\_/\_/\_/\_/\_/\_ 80 | | | | | \_) | | | | | | | | | | 81 | | | | | | | | | | | | | | | | 82 | | | | | | | | | | | | | | | | 83 | | | | | | | | | | | | | | | | 84 | | | | | | | | | | | | | | | | 85 | 86 | * 87 | @@@@ 88 | . . 89 | * _ 90 | |\___/| \\ 91 | =) ^Y^ (= |\_/| || ' 92 | \ ^ / )a a '._.-""""-. // 93 | )=*=( =\T_= / ~ ~ \// 94 | / \ `"`\ ~ / ~ / 95 | | | |~ \ | ~/ 96 | /| | | |\ \ ~/- \ ~\ 97 | \| | |_|/| || | // /` 98 | jgs_/\_//_// __//\_/\_/\_((_|\((_//\_/\_/\_ 99 | | | | | \_) | | | | | | | | | | 100 | | | | | | | | | | | | | | | | 101 | | | | | | | | | | | | | | | | 102 | | | | | | | | | | | | | | | | 103 | | | | | | | | | | | | | | | | 104 | 105 | * 106 | @@@@ 107 | . . 108 | * 109 | |\___/| /\___/\ 110 | ) ( ) ~( . ' 111 | =\ /= =\~ /= 112 | )===( ) ~ ( 113 | / \ / \ 114 | | | ) ~ ( 115 | / \ / ~ \ 116 | \ / \~ ~/ 117 | jgs_/\_/\__ _/_/\_/\__~__/_/\_/\_/\_/\_/\_ 118 | | | | |( ( | | | )) | | | | | | 119 | | | | | ) ) | | |//| | | | | | | 120 | | | | |(_( | | (( | | | | | | | 121 | | | | | | | | |\)| | | | | | | 122 | | | | | | | | | | | | | | | | 123 | 124 | * 125 | @@@@ 126 | . . 127 | * 128 | /\/|_ __/\\ 129 | / -\ /- ~\ . ' 130 | \ = Y =T_ = / 131 | )==*(` `) ~ \ 132 | / \ / \ 133 | | | ) ~ ( 134 | / \ / ~ \ 135 | \ / \~ ~/ 136 | jgs_/\_/\__ _/_/\_/\__~__/_/\_/\_/\_/\_/\_ 137 | | | | | ) ) | | | (( | | | | | | 138 | | | | |( ( | | | \\ | | | | | | 139 | | | | | )_) | | | |))| | | | | | 140 | | | | | | | | | (/ | | | | | | 141 | | | | | | | | | | | | | | | | 142 | 143 | |\_._/| 144 | | o o | 145 | ( T ) 146 | .^`-^-'^. @@@@ 147 | `. ; .' 148 | | | | | | 149 | ((_((|))_)) 150 | hjw 151 | 152 | |,\__/| 153 | | o o| 154 | ( T ) @@@@ 155 | .^`--^'^. 156 | `. ; .' 157 | | | | | | 158 | ((_((|))_)) 159 | hjw 160 | 161 | |\__/,| 162 | |o o | 163 | ( T ) 164 | .^`^--'^. @@@@ 165 | `. ; .' 166 | | | | | | 167 | ((_((|))_)) 168 | hjw 169 | 170 | |\_._/| 171 | | 0 0 | 172 | ( T ) @@@@ 173 | .^`-^-'^. 174 | `. ; .' 175 | | | | | | 176 | ((_((|))_)) 177 | hjw 178 | -------------------------------------------------------------------------------- /lib/sly-messages.el: -------------------------------------------------------------------------------- 1 | ;;; sly-messages.el --- Messages, errors, echo-area and visual feedback utils for SLY -*- lexical-binding: t; -*- 2 | 3 | ;; Copyright (C) 2014 João Távora 4 | 5 | ;; Author: João Távora 6 | ;; Keywords: 7 | 8 | ;; This program is free software; you can redistribute it and/or modify 9 | ;; it under the terms of the GNU General Public License as published by 10 | ;; the Free Software Foundation, either version 3 of the License, or 11 | ;; (at your option) any later version. 12 | 13 | ;; This program is distributed in the hope that it will be useful, 14 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 15 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 16 | ;; GNU General Public License for more details. 17 | 18 | ;; You should have received a copy of the GNU General Public License 19 | ;; along with this program. If not, see . 20 | 21 | ;;; Commentary: 22 | 23 | ;; 24 | 25 | ;;; Code: 26 | 27 | (require 'cl-lib) 28 | 29 | (defvar sly--last-message nil) 30 | 31 | (defun sly-message (format-string &rest args) 32 | "Like `message', but use a prefix." 33 | (let ((body (apply #'format format-string args))) 34 | (setq sly--last-message (format "[sly] %s" body)) 35 | (message "%s" sly--last-message))) 36 | 37 | (add-hook 'echo-area-clear-hook 38 | 'sly--message-clear-last-message) 39 | 40 | (defun sly--message-clear-last-message () 41 | (setq sly--last-message nil)) 42 | 43 | (defun sly-temp-message (wait sit-for format &rest args) 44 | "Wait WAIT seconds then display a message for SIT-FOR seconds. 45 | A nil value for WAIT means \"now\". 46 | SIT-FOR is has the semantincs of `minibuffer-message-timeout', which see." 47 | (run-with-timer 48 | wait nil 49 | (lambda () 50 | (let ((existing sly--last-message) 51 | (text (apply #'format format args))) 52 | (if (minibuffer-window-active-p (minibuffer-window)) 53 | (let ((minibuffer-message-timeout sit-for)) 54 | (minibuffer-message "[sly] %s" text)) 55 | (message "[sly] %s" text) ; don't sly-message here 56 | (run-with-timer 57 | sit-for 58 | nil 59 | (lambda () 60 | ;; restore the message 61 | (when existing 62 | (message "%s" existing))))))))) 63 | 64 | (defun sly-warning (format-string &rest args) 65 | (display-warning '(sly warning) (apply #'format format-string args))) 66 | 67 | (defun sly-error (format-string &rest args) 68 | (apply #'error (format "[sly] %s" format-string) args)) 69 | 70 | (defun sly-user-error (format-string &rest args) 71 | (apply #'user-error (format "[sly] %s" format-string) args)) 72 | 73 | (defun sly-display-oneliner (format-string &rest format-args) 74 | (let* ((msg (apply #'format format-string format-args))) 75 | (unless (minibuffer-window-active-p (minibuffer-window)) 76 | (sly-message (sly-oneliner msg))))) 77 | 78 | (defun sly-oneliner (string) 79 | "Return STRING truncated to fit in a single echo-area line." 80 | (substring string 0 (min (length string) 81 | (or (cl-position ?\n string) most-positive-fixnum) 82 | (1- (window-width (minibuffer-window)))))) 83 | 84 | (defun sly-y-or-n-p (format-string &rest args) 85 | (let ((prompt (apply #'format (concat "[sly] " 86 | format-string) 87 | args))) 88 | (y-or-n-p prompt))) 89 | 90 | 91 | ;;; Flashing the region 92 | ;;; 93 | (defvar sly-flash-inhibit nil 94 | "If non-nil `sly-flash-region' does nothing") 95 | 96 | (defvar sly--flash-overlay (make-overlay 0 0)) 97 | (overlay-put sly--flash-overlay 'priority 1000) 98 | 99 | (cl-defun sly-flash-region (start end &key 100 | timeout 101 | face 102 | times 103 | (pattern '(0.2))) 104 | "Temporarily highlight region from START to END." 105 | (if pattern 106 | (cl-assert (and (null times) (null timeout)) 107 | nil 108 | "If PATTERN is supplied, don't supply TIMES or TIMEOUT") 109 | (setq pattern (make-list (* 2 times) timeout))) 110 | (unless sly-flash-inhibit 111 | (let ((buffer (current-buffer))) 112 | (move-overlay sly--flash-overlay start end buffer) 113 | (cl-labels 114 | ((on () (overlay-put sly--flash-overlay 'face (or face 'highlight))) 115 | (off () (overlay-put sly--flash-overlay 'face nil)) 116 | (relevant-p () 117 | (equal (list start end buffer) 118 | (list (overlay-start sly--flash-overlay) 119 | (overlay-end sly--flash-overlay) 120 | (overlay-buffer sly--flash-overlay)))) 121 | (onoff () 122 | (when (and pattern (relevant-p)) 123 | (on) 124 | (run-with-timer (pop pattern) 125 | nil 126 | (lambda () 127 | (when (relevant-p) 128 | (off) 129 | (when pattern 130 | (run-with-timer 131 | (pop pattern) 132 | nil 133 | (lambda () (onoff)))))))))) 134 | (onoff))))) 135 | 136 | (provide 'sly-messages) 137 | ;;; sly-messages.el ends here 138 | -------------------------------------------------------------------------------- /slynk/slynk-source-file-cache.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Source-file cache 2 | ;;; 3 | ;;; To robustly find source locations in CMUCL and SBCL it's useful to 4 | ;;; have the exact source code that the loaded code was compiled from. 5 | ;;; In this source we can accurately find the right location, and from 6 | ;;; that location we can extract a "snippet" of code to show what the 7 | ;;; definition looks like. Emacs can use this snippet in a best-match 8 | ;;; search to locate the right definition, which works well even if 9 | ;;; the buffer has been modified. 10 | ;;; 11 | ;;; The idea is that if a definition previously started with 12 | ;;; `(define-foo bar' then it probably still does. 13 | ;;; 14 | ;;; Whenever we see that the file on disk has the same 15 | ;;; `file-write-date' as a location we're looking for we cache the 16 | ;;; whole file inside Lisp. That way we will still have the matching 17 | ;;; version even if the file is later modified on disk. If the file is 18 | ;;; later recompiled and reloaded then we replace our cache entry. 19 | ;;; 20 | ;;; This code has been placed in the Public Domain. All warranties 21 | ;;; are disclaimed. 22 | 23 | (defpackage slynk-source-file-cache 24 | (:use cl slynk-backend) 25 | (:import-from slynk-backend 26 | defimplementation buffer-first-change) 27 | (:export 28 | get-source-code 29 | source-cache-get ;FIXME: isn't it odd that both are exported? 30 | 31 | *source-snippet-size* 32 | read-snippet 33 | read-snippet-from-string 34 | )) 35 | 36 | (in-package slynk-source-file-cache) 37 | 38 | (defvar *cache-sourcecode* t 39 | "When true complete source files are cached. 40 | The cache is used to keep known good copies of the source text which 41 | correspond to the loaded code. Finding definitions is much more 42 | reliable when the exact source is available, so we cache it in case it 43 | gets edited on disk later.") 44 | 45 | (defvar *source-file-cache* (make-hash-table :test 'equal) 46 | "Cache of source file contents. 47 | Maps from truename to source-cache-entry structure.") 48 | 49 | (defstruct (source-cache-entry 50 | (:conc-name source-cache-entry.) 51 | (:constructor make-source-cache-entry (text date))) 52 | text date) 53 | 54 | (defimplementation buffer-first-change (filename) 55 | "Load a file into the cache when the user modifies its buffer. 56 | This is a win if the user then saves the file and tries to M-. into it." 57 | (unless (source-cached-p filename) 58 | (ignore-errors 59 | (source-cache-get filename (file-write-date filename)))) 60 | nil) 61 | 62 | (defun get-source-code (filename code-date) 63 | "Return the source code for FILENAME as written on DATE in a string. 64 | If the exact version cannot be found then return the current one from disk." 65 | (or (source-cache-get filename code-date) 66 | (read-file filename))) 67 | 68 | (defun source-cache-get (filename date) 69 | "Return the source code for FILENAME as written on DATE in a string. 70 | Return NIL if the right version cannot be found." 71 | (when *cache-sourcecode* 72 | (let ((entry (gethash filename *source-file-cache*))) 73 | (cond ((and entry (equal date (source-cache-entry.date entry))) 74 | ;; Cache hit. 75 | (source-cache-entry.text entry)) 76 | ((or (null entry) 77 | (not (equal date (source-cache-entry.date entry)))) 78 | ;; Cache miss. 79 | (if (equal (file-write-date filename) date) 80 | ;; File on disk has the correct version. 81 | (let ((source (read-file filename))) 82 | (setf (gethash filename *source-file-cache*) 83 | (make-source-cache-entry source date)) 84 | source) 85 | nil)))))) 86 | 87 | (defun source-cached-p (filename) 88 | "Is any version of FILENAME in the source cache?" 89 | (if (gethash filename *source-file-cache*) t)) 90 | 91 | (defun read-file (filename) 92 | "Return the entire contents of FILENAME as a string." 93 | (with-open-file (s filename :direction :input 94 | :external-format (or (guess-external-format filename) 95 | (find-external-format "latin-1") 96 | :default)) 97 | (let* ((string (make-string (file-length s))) 98 | (length (read-sequence string s))) 99 | (subseq string 0 length)))) 100 | 101 | ;;;; Snippets 102 | 103 | (defvar *source-snippet-size* 256 104 | "Maximum number of characters in a snippet of source code. 105 | Snippets at the beginning of definitions are used to tell Emacs what 106 | the definitions looks like, so that it can accurately find them by 107 | text search.") 108 | 109 | (defun read-snippet (stream &optional position) 110 | "Read a string of upto *SOURCE-SNIPPET-SIZE* characters from STREAM. 111 | If POSITION is given, set the STREAM's file position first." 112 | (when position 113 | (file-position stream position)) 114 | #+sbcl (skip-comments-and-whitespace stream) 115 | (read-upto-n-chars stream *source-snippet-size*)) 116 | 117 | (defun read-snippet-from-string (string &optional position) 118 | (with-input-from-string (s string) 119 | (read-snippet s position))) 120 | 121 | (defun skip-comments-and-whitespace (stream) 122 | (case (peek-char nil stream nil nil) 123 | ((#\Space #\Tab #\Newline #\Linefeed #\Page) 124 | (read-char stream) 125 | (skip-comments-and-whitespace stream)) 126 | (#\; 127 | (read-line stream) 128 | (skip-comments-and-whitespace stream)))) 129 | 130 | (defun read-upto-n-chars (stream n) 131 | "Return a string of upto N chars from STREAM." 132 | (let* ((string (make-string n)) 133 | (chars (read-sequence string stream))) 134 | (subseq string 0 chars))) 135 | -------------------------------------------------------------------------------- /contrib/sly-profiler.el: -------------------------------------------------------------------------------- 1 | ;;; -*- coding: utf-8; lexical-binding: t -*- 2 | ;;; 3 | ;;; sly-profiler.el -- a navigable dialog of inspectable timing entries 4 | ;;; 5 | (eval-and-compile 6 | (require 'sly) 7 | (require 'sly-parse "lib/sly-parse")) 8 | 9 | (define-sly-contrib sly-profiler 10 | "Provide an interfactive timing dialog buffer for managing and 11 | inspecting details of timing functions. Invoke this dialog with C-c Y." 12 | (:authors "João Távora ") 13 | (:license "GPL") 14 | (:slynk-dependencies slynk/profiler) 15 | (:on-load (add-hook 'sly-mode-hook 'sly-profiler-enable)) 16 | (:on-unload (remove-hook 'sly-mode-hook 'sly-profiler-enable))) 17 | 18 | 19 | ;;;; Modes and mode maps 20 | ;;; 21 | (defvar sly-profiler-mode-map 22 | (let ((map (make-sparse-keymap))) 23 | (define-key map (kbd "G") 'sly-profiler-fetch-timings) 24 | (define-key map (kbd "C-k") 'sly-profiler-clear-fetched-timings) 25 | (define-key map (kbd "g") 'sly-profiler-fetch-status) 26 | (define-key map (kbd "q") 'quit-window) 27 | map)) 28 | 29 | (define-derived-mode sly-profiler-mode fundamental-mode 30 | "SLY Timing Dialog" "Mode for controlling SLY's Timing Dialog" 31 | (set-syntax-table lisp-mode-syntax-table) 32 | (read-only-mode 1)) 33 | 34 | (defvar sly-profiler-shortcut-mode-map 35 | (let ((map (make-sparse-keymap))) 36 | (define-key map (kbd "C-c Y") 'sly-profiler) 37 | (define-key map (kbd "C-c C-y") 'sly-profiler-toggle-timing) 38 | map)) 39 | 40 | (define-minor-mode sly-profiler-shortcut-mode 41 | "Add keybindings for accessing SLY's Profiler.") 42 | 43 | (defun sly-profiler-enable () (sly-profiler-shortcut-mode 1)) 44 | 45 | 46 | ;;;; Helpers 47 | ;;; 48 | (defun sly-profiler--get-buffer () 49 | (let* ((name (format "*profiler for %s*" 50 | (sly-connection-name sly-default-connection))) 51 | (existing (get-buffer name))) 52 | (cond ((and existing 53 | (buffer-live-p existing) 54 | (with-current-buffer existing 55 | (memq sly-buffer-connection sly-net-processes))) 56 | existing) 57 | (t 58 | (if existing (kill-buffer existing)) 59 | (with-current-buffer (get-buffer-create name) 60 | (sly-profiler-mode) 61 | (setq sly-buffer-connection sly-default-connection) 62 | (pop-to-buffer (current-buffer))))))) 63 | 64 | (defun sly-profiler--clear-local-tree () 65 | (erase-buffer) 66 | (insert "Cleared timings!")) 67 | 68 | (defun sly-profiler--render-timings (timing-specs) 69 | (let ((inhibit-read-only t)) 70 | (erase-buffer) 71 | (let ((standard-output (current-buffer))) 72 | (cl-loop for spec in timing-specs 73 | do (princ spec) (terpri))))) 74 | 75 | ;;;; Interactive functions 76 | ;;; 77 | ;; (defun sly-profiler-fetch-specs () 78 | ;; "Refresh just list of timing specs." 79 | ;; (interactive) 80 | ;; (sly-eval-async `(slynk-profiler:report-specs) 81 | ;; #'sly-profiler--open-specs)) 82 | 83 | (defun sly-profiler-clear-fetched-timings (&optional interactive) 84 | "Clear local and remote timings collected so far" 85 | (interactive "p") 86 | (when (or (not interactive) 87 | (y-or-n-p "Clear all collected and fetched timings?")) 88 | (sly-eval-async 89 | '(slynk-profiler:clear-timing-tree) 90 | #'sly-profiler--clear-local-tree))) 91 | 92 | (defun sly-profiler-fetch-timings () 93 | (interactive) 94 | (sly-eval-async `(slynk-profiler:report-latest-timings) 95 | #'sly-profiler--render-timings)) 96 | 97 | (defun sly-profiler-fetch-status () 98 | (interactive) 99 | (sly-profiler-fetch-timings)) 100 | 101 | (defun sly-profiler-toggle-timing (&optional using-context-p) 102 | "Toggle the dialog-timing of the spec at point. 103 | 104 | When USING-CONTEXT-P, attempt to decipher lambdas. methods and 105 | other complicated function specs." 106 | (interactive "P") 107 | ;; Notice the use of "spec strings" here as opposed to the 108 | ;; proper cons specs we use on the slynk side. 109 | ;; 110 | ;; Notice the conditional use of `sly-trace-query' found in 111 | ;; slynk-fancy-trace.el 112 | ;; 113 | (let* ((spec-string (if using-context-p 114 | (sly-extract-context) 115 | (sly-symbol-at-point))) 116 | (spec-string (read-from-minibuffer "(Un)time: " (format "%s" spec-string)))) 117 | (message "%s" (sly-eval `(slynk-profiler:toggle-timing 118 | (slynk::from-string ,spec-string)))))) 119 | 120 | (defun sly-profiler (&optional refresh) 121 | "Show timing dialog and refresh timing collection status. 122 | 123 | With optional CLEAR-AND-FETCH prefix arg, clear the current tree 124 | and fetch a first batch of timings." 125 | (interactive "P") 126 | (sly-with-popup-buffer ((sly-buffer-name :profiler :connection sly-default-connection) 127 | :mode 'sly-profiler-mode 128 | :select t) 129 | (when refresh (sly-profiler-fetch-timings)))) 130 | 131 | 132 | ;;;; Menu 133 | ;;; 134 | (easy-menu-define sly-profiler--shortcut-menu nil 135 | "Menu setting traces from anywhere in SLY." 136 | (let* ((in-dialog '(eq major-mode 'sly-profiler-mode)) 137 | (_dialog-live `(and ,in-dialog 138 | (memq sly-buffer-connection sly-net-processes))) 139 | (connected '(sly-connected-p))) 140 | `("Profiling" 141 | ["(Un)Profile definition" sly-profiler-toggle-timing ,connected] 142 | ["Open Profiler Dialog" sly-profiler (and ,connected (not ,in-dialog))]))) 143 | 144 | (easy-menu-add-item sly-menu nil sly-profiler--shortcut-menu "Documentation") 145 | 146 | (defvar sly-profiler--easy-menu 147 | (let ((condition '(memq sly-buffer-connection sly-net-processes))) 148 | `("Timing" 149 | [ "Clear fetched timings" sly-profiler-clear-fetched-timings ,condition] 150 | [ "Fetch timings" sly-profiler-fetch-timings ,condition]))) 151 | 152 | (easy-menu-define my-menu sly-profiler-mode-map "Timing" 153 | sly-profiler--easy-menu) 154 | 155 | (provide 'sly-profiler) 156 | -------------------------------------------------------------------------------- /contrib/slynk-indentation.lisp: -------------------------------------------------------------------------------- 1 | (in-package :slynk) 2 | 3 | (defvar *application-hints-tables* '() 4 | "A list of hash tables mapping symbols to indentation hints (lists 5 | of symbols and numbers as per cl-indent.el). Applications can add hash 6 | tables to the list to change the auto indentation sly sends to 7 | emacs.") 8 | 9 | (defun has-application-indentation-hint-p (symbol) 10 | (let ((default (load-time-value (gensym)))) 11 | (dolist (table *application-hints-tables*) 12 | (let ((indentation (gethash symbol table default))) 13 | (unless (eq default indentation) 14 | (return-from has-application-indentation-hint-p 15 | (values indentation t)))))) 16 | (values nil nil)) 17 | 18 | (defun application-indentation-hint (symbol) 19 | (let ((indentation (has-application-indentation-hint-p symbol))) 20 | (labels ((walk (indentation-spec) 21 | (etypecase indentation-spec 22 | (null nil) 23 | (number indentation-spec) 24 | (symbol (string-downcase indentation-spec)) 25 | (cons (cons (walk (car indentation-spec)) 26 | (walk (cdr indentation-spec))))))) 27 | (walk indentation)))) 28 | 29 | ;;; override slynk version of this function 30 | (defun symbol-indentation (symbol) 31 | "Return a form describing the indentation of SYMBOL. 32 | 33 | The form is to be used as the `sly-common-lisp-indent-function' property 34 | in Emacs." 35 | (cond 36 | ((has-application-indentation-hint-p symbol) 37 | (application-indentation-hint symbol)) 38 | ((and (macro-function symbol) 39 | (not (known-to-emacs-p symbol))) 40 | (let ((arglist (arglist symbol))) 41 | (etypecase arglist 42 | ((member :not-available) 43 | nil) 44 | (list 45 | (macro-indentation arglist))))) 46 | (t nil))) 47 | 48 | ;;; More complex version. 49 | (defun macro-indentation (arglist) 50 | (labels ((frob (list &optional base) 51 | (if (every (lambda (x) 52 | (member x '(nil "&rest") :test #'equal)) 53 | list) 54 | ;; If there was nothing interesting, don't return anything. 55 | nil 56 | ;; Otherwise substitute leading NIL's with 4 or 1. 57 | (let ((ok t)) 58 | (substitute-if (if base 59 | 4 60 | 1) 61 | (lambda (x) 62 | (if (and ok (not x)) 63 | t 64 | (setf ok nil))) 65 | list)))) 66 | (walk (list level &optional firstp) 67 | (when (consp list) 68 | (let ((head (car list))) 69 | (if (consp head) 70 | (let ((indent (frob (walk head (+ level 1) t)))) 71 | (cons (list* "&whole" (if (zerop level) 72 | 4 73 | 1) 74 | indent) (walk (cdr list) level))) 75 | (case head 76 | ;; &BODY is &BODY, this is clear. 77 | (&body 78 | '("&body")) 79 | ;; &KEY is tricksy. If it's at the base level, we want 80 | ;; to indent them normally: 81 | ;; 82 | ;; (foo bar quux 83 | ;; :quux t 84 | ;; :zot nil) 85 | ;; 86 | ;; If it's at a destructuring level, we want indent of 1: 87 | ;; 88 | ;; (with-foo (var arg 89 | ;; :foo t 90 | ;; :quux nil) 91 | ;; ...) 92 | (&key 93 | (if (zerop level) 94 | '("&rest" nil) 95 | '("&rest" 1))) 96 | ;; &REST is tricksy. If it's at the front of 97 | ;; destructuring, we want to indent by 1, otherwise 98 | ;; normally: 99 | ;; 100 | ;; (foo (bar quux 101 | ;; zot) 102 | ;; ...) 103 | ;; 104 | ;; but 105 | ;; 106 | ;; (foo bar quux 107 | ;; zot) 108 | (&rest 109 | (if (and (plusp level) firstp) 110 | '("&rest" 1) 111 | '("&rest" nil))) 112 | ;; &WHOLE and &ENVIRONMENT are skipped as if they weren't there 113 | ;; at all. 114 | ((&whole &environment) 115 | (walk (cddr list) level firstp)) 116 | ;; &OPTIONAL is indented normally -- and the &OPTIONAL marker 117 | ;; itself is not counted. 118 | (&optional 119 | (walk (cdr list) level)) 120 | ;; Indent normally, walk the tail -- but 121 | ;; unknown lambda-list keywords terminate the walk. 122 | (otherwise 123 | (unless (member head lambda-list-keywords) 124 | (cons nil (walk (cdr list) level)))))))))) 125 | (frob (walk arglist 0 t) t))) 126 | 127 | #+nil 128 | (progn 129 | (assert (equal '(4 4 ("&whole" 4 "&rest" 1) "&body") 130 | (macro-indentation '(bar quux (&rest slots) &body body)))) 131 | (assert (equal nil 132 | (macro-indentation '(a b c &rest more)))) 133 | (assert (equal '(4 4 4 "&body") 134 | (macro-indentation '(a b c &body more)))) 135 | (assert (equal '(("&whole" 4 1 1 "&rest" 1) "&body") 136 | (macro-indentation '((name zot &key foo bar) &body body)))) 137 | (assert (equal nil 138 | (macro-indentation '(x y &key z))))) 139 | 140 | (provide :slynk/indentation) 141 | -------------------------------------------------------------------------------- /slynk/slynk-apropos.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :slynk-apropos 2 | (:use #:cl #:slynk-api) 3 | (:export 4 | #:apropos-list-for-emacs 5 | #:*preferred-apropos-matcher*)) 6 | 7 | (in-package :slynk-apropos) 8 | 9 | (defparameter *preferred-apropos-matcher* 'make-cl-ppcre-matcher 10 | "Preferred matcher for apropos searches. 11 | Value is a function of three arguments , PATTERN, CASE-SENSITIVE and 12 | SYMBOL-NAME-FN that should return a function, called MATCHER of one 13 | argument, a SYMBOL. MATCHER should return non-nil if PATTERN somehow 14 | matches the result of applying SYMBOL-NAME-FN to SYMBOL, according to 15 | CASE-SENSITIVE. The non-nil return value can be a list of integer or 16 | a list of lists of integers.") 17 | 18 | (defslyfun apropos-list-for-emacs (pattern &optional external-only 19 | case-sensitive package) 20 | "Make an apropos search for Emacs. 21 | The result is a list of property lists." 22 | (let ((package (if package 23 | (or (parse-package package) 24 | (error "No such package: ~S" package))))) 25 | ;; The MAPCAN will filter all uninteresting symbols, i.e. those 26 | ;; who cannot be meaningfully described. 27 | ;; 28 | ;; *BUFFER-PACKAGE* is exceptionally set so that the symbol 29 | ;; listing will only omit package qualifier iff the user specified 30 | ;; PACKAGE. 31 | (let* ((*buffer-package* (or package 32 | slynk::*slynk-io-package*)) 33 | (matcher (funcall *preferred-apropos-matcher* 34 | pattern 35 | case-sensitive)) 36 | (seen (make-hash-table)) 37 | result) 38 | 39 | (do-all-symbols (sym) 40 | (let ((external (symbol-external-p sym))) 41 | (multiple-value-bind (bounds score) 42 | (and 43 | (symbol-package sym) ; see github#266 44 | (funcall matcher 45 | (if package 46 | (string sym) 47 | (concatenate 'string 48 | (package-name (symbol-package sym)) 49 | (if external ":" "::") 50 | (symbol-name sym))))) 51 | (unless (gethash sym seen) 52 | (when bounds 53 | (unless (or (and external-only 54 | (not external)) 55 | (and package 56 | (not (eq package (symbol-package sym))))) 57 | (push `(,sym :bounds ,bounds 58 | ,@(and score `(:flex-score ,score)) 59 | :external-p ,external) 60 | result))) 61 | (setf (gethash sym seen) t))))) 62 | (loop for (symbol . extra) 63 | in (sort result 64 | (lambda (x y) 65 | (let ((scorex (getf (cdr x) :flex-score)) 66 | (scorey (getf (cdr y) :flex-score))) 67 | (if (and scorex scorey) 68 | (> scorex scorey) 69 | (present-symbol-before-p (car x) (car y)))))) 70 | for short = (briefly-describe-symbol-for-emacs 71 | symbol (getf extra :external-p)) 72 | for score = (getf extra :flex-score) 73 | when score 74 | do (setf (getf extra :flex-score) 75 | (format nil "~2$%" 76 | (* 100 score))) 77 | do (remf extra :external-p) 78 | when short 79 | collect (append short extra))))) 80 | 81 | (defun briefly-describe-symbol-for-emacs (symbol external-p) 82 | "Return a property list describing SYMBOL. 83 | Like `describe-symbol-for-emacs' but with at most one line per item." 84 | (flet ((first-line (string) 85 | (let ((pos (position #\newline string))) 86 | (if (null pos) string (subseq string 0 pos))))) 87 | (let ((desc (map-if #'stringp #'first-line 88 | (slynk-backend:describe-symbol-for-emacs symbol)))) 89 | (if desc 90 | `(:designator ,(list (symbol-name symbol) 91 | (let ((package (symbol-package symbol))) 92 | (and package 93 | (package-name package))) 94 | external-p) 95 | ,@desc 96 | ,@(let ((arglist (and (fboundp symbol) 97 | (slynk-backend:arglist symbol)))) 98 | (when (and arglist 99 | (not (eq arglist :not-available))) 100 | `(:arglist ,(princ-to-string arglist))))))))) 101 | 102 | (defun present-symbol-before-p (x y) 103 | "Return true if X belongs before Y in a printed summary of symbols. 104 | Sorted alphabetically by package name and then symbol name, except 105 | that symbols accessible in the current package go first." 106 | (declare (type symbol x y)) 107 | (flet ((accessible (s) 108 | ;; Test breaks on NIL for package that does not inherit it 109 | (eq (find-symbol (symbol-name s) *buffer-package*) s))) 110 | (let ((ax (accessible x)) (ay (accessible y))) 111 | (cond ((and ax ay) (string< (symbol-name x) (symbol-name y))) 112 | (ax t) 113 | (ay nil) 114 | (t (let ((px (symbol-package x)) (py (symbol-package y))) 115 | (if (eq px py) 116 | (string< (symbol-name x) (symbol-name y)) 117 | (string< (package-name px) (package-name py))))))))) 118 | 119 | (defun make-cl-ppcre-matcher (pattern case-sensitive) 120 | (if (not (every #'alpha-char-p pattern)) 121 | (cond ((find-package :cl-ppcre) 122 | (background-message "Using CL-PPCRE for apropos on regexp \"~a\"" pattern) 123 | 124 | (let ((matcher (funcall (slynk-backend:find-symbol2 "cl-ppcre:create-scanner") 125 | pattern 126 | :case-insensitive-mode (not case-sensitive)))) 127 | (lambda (symbol-name) 128 | (multiple-value-bind (beg end) 129 | (funcall (slynk-backend:find-symbol2 "cl-ppcre:scan") 130 | matcher 131 | symbol-name) 132 | (when beg `((,beg ,end))))))) 133 | (t 134 | (background-message "Using plain apropos. Load CL-PPCRE to enable regexps") 135 | (make-plain-matcher pattern case-sensitive))) 136 | (make-plain-matcher pattern case-sensitive))) 137 | 138 | (defun make-plain-matcher (pattern case-sensitive) 139 | (let ((chr= (if case-sensitive #'char= #'char-equal))) 140 | (lambda (symbol-name) 141 | (let ((beg (search pattern 142 | symbol-name 143 | :test chr=))) 144 | (when beg 145 | `((,beg ,(+ beg (length pattern))))))))) 146 | 147 | (defun make-flex-matcher (pattern case-sensitive) 148 | (if (zerop (length pattern)) 149 | (make-plain-matcher pattern case-sensitive) 150 | (let ((chr= (if case-sensitive #'char= #'char-equal))) 151 | (lambda (symbol-name) 152 | (slynk-completion:flex-matches 153 | pattern symbol-name chr=))))) 154 | -------------------------------------------------------------------------------- /contrib/slynk-profiler.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :slynk-profiler 2 | (:use :cl) 3 | (:import-from :slynk :defslyfun :from-string :to-string) 4 | (:export #:toggle-timing 5 | #:untime-spec 6 | #:clear-timing-tree 7 | #:untime-all 8 | #:timed-spec-p 9 | #:time-spec)) 10 | 11 | (in-package :slynk-profiler) 12 | 13 | (defvar *timing-lock* (slynk-backend:make-lock :name "slynk-timings lock")) 14 | 15 | (defvar *current-timing* nil) 16 | 17 | (defvar *timed-spec-lists* (make-array 10 18 | :fill-pointer 0 19 | :adjustable t)) 20 | 21 | (defun started-timing ()) 22 | 23 | (defmethod timed-specs () 24 | (aref *timed-spec-lists* (1- (fill-pointer *timed-spec-lists*)))) 25 | 26 | (defmethod (setf timed-specs) (value) 27 | (setf (aref *timed-spec-lists* (1- (fill-pointer *timed-spec-lists*))) value)) 28 | 29 | (defclass timing () 30 | ((parent :reader parent-of :initform *current-timing* ) 31 | (origin :initarg :origin :reader origin-of 32 | :initform (error "must provide an ORIGIN for this TIMING")) 33 | (start :reader start-of :initform (get-internal-real-time)) 34 | (end :accessor end-of :initform nil))) 35 | 36 | (defclass timed-spec () 37 | ((spec :initarg :spec :accessor spec-of 38 | :initform (error "must provide a spec")) 39 | (stats :accessor stats-of) 40 | (total :accessor total-of) 41 | (subtimings :accessor subtimings-of) 42 | (owntimings :accessor owntimings-of))) 43 | 44 | (defun get-singleton-create (spec) 45 | (let ((existing (find spec (timed-specs) :test #'equal :key #'spec-of))) 46 | (if existing 47 | (reinitialize-instance existing) 48 | (let ((new (make-instance 'timed-spec :spec spec))) 49 | (push new (timed-specs)) 50 | new)))) 51 | 52 | (defmethod shared-initialize :after ((ts timed-spec) slot-names &rest initargs) 53 | (declare (ignore slot-names)) 54 | (setf (stats-of ts) (make-hash-table) 55 | (total-of ts) 0 56 | (subtimings-of ts) nil 57 | (owntimings-of ts) nil) 58 | (loop for otherts in (remove ts (timed-specs)) 59 | do (setf (gethash ts (stats-of otherts)) 0) 60 | (setf (gethash otherts (stats-of ts)) 0))) 61 | 62 | (defmethod initialize-instance :after ((tm timing) &rest initargs) 63 | (declare (ignore initargs)) 64 | (push tm (owntimings-of (origin-of tm))) 65 | (let ((parent (parent-of tm))) 66 | (when parent 67 | (push tm (subtimings-of (origin-of parent)))))) 68 | 69 | (defmethod (setf end-of) :after (value (tm timing)) 70 | (let* ((parent (parent-of tm)) 71 | (parent-origin (and parent (origin-of parent))) 72 | (origin (origin-of tm)) 73 | (tm1 (pop (owntimings-of origin))) 74 | (tm2 (and parent 75 | (pop (subtimings-of parent-origin)))) 76 | (delta (- value (start-of tm)))) 77 | (assert (eq tm tm1) nil "Hmm something's gone wrong in the owns") 78 | (assert (or (null tm2) 79 | (eq tm tm2)) nil "Something's gone wrong in the subs") 80 | (when (null (owntimings-of origin)) 81 | (incf (total-of origin) delta)) 82 | (when (and parent-origin 83 | (null (subtimings-of parent-origin))) 84 | (incf (gethash origin (stats-of parent-origin)) 85 | delta)))) 86 | 87 | (defmethod duration ((tm timing)) 88 | (/ (- (or (end-of tm) 89 | (get-internal-real-time)) 90 | (start-of tm)) 91 | internal-time-units-per-second)) 92 | 93 | (defmethod print-object ((tm timing) stream) 94 | (print-unreadable-object (tm stream :type t :identity t) 95 | (format stream "~a: ~f~a" 96 | (spec-of (origin-of tm)) 97 | (duration tm) 98 | (if (not (end-of tm)) "(unfinished)" "")))) 99 | 100 | (defmethod print-object ((e timed-spec) stream) 101 | (print-unreadable-object (e stream :type t) 102 | (format stream "~a ~fs" (spec-of e) 103 | (/ (total-of e) 104 | internal-time-units-per-second)))) 105 | 106 | (defslyfun time-spec (spec) 107 | (when (timed-spec-p spec) 108 | (warn "~a is apparently already timed! Untiming and retiming." spec) 109 | (untime-spec spec)) 110 | (let ((timed-spec (get-singleton-create spec))) 111 | (flet ((before-hook (args) 112 | (declare (ignore args)) 113 | (setf *current-timing* 114 | (make-instance 'timing :origin timed-spec))) 115 | (after-hook (retlist) 116 | (declare (ignore retlist)) 117 | (let* ((timing *current-timing*)) 118 | (when timing 119 | (setf (end-of timing) (get-internal-real-time)) 120 | (setf *current-timing* (parent-of timing)))))) 121 | (slynk-backend:wrap spec 'timings 122 | :before #'before-hook 123 | :after #'after-hook) 124 | (format nil "~a is now timed for timing dialog" spec)))) 125 | 126 | (defslyfun untime-spec (spec) 127 | (slynk-backend:unwrap spec 'timings) 128 | (let ((moribund (find spec (timed-specs) :test #'equal :key #'spec-of))) 129 | (setf (timed-specs) (remove moribund (timed-specs))) 130 | (loop for otherts in (timed-specs) 131 | do (remhash moribund (stats-of otherts)))) 132 | (format nil "~a is now untimed for timing dialog" spec)) 133 | 134 | (defslyfun toggle-timing (spec) 135 | 136 | (if (timed-spec-p spec) 137 | (untime-spec spec) 138 | (time-spec spec))) 139 | 140 | (defslyfun timed-spec-p (spec) 141 | (find spec (timed-specs) :test #'equal :key #'spec-of)) 142 | 143 | (defslyfun untime-all () 144 | (mapcar #'untime-spec (timed-specs))) 145 | 146 | 147 | ;;;; Reporting to emacs 148 | ;;; 149 | (defun describe-timing-for-emacs (timed-spec) 150 | (declare (ignore timed-spec)) 151 | `not-implemented) 152 | 153 | (defslyfun report-latest-timings () 154 | (loop for spec in (timed-specs) 155 | append (loop for partial being the hash-values of (stats-of spec) 156 | for path being the hash-keys of (stats-of spec) 157 | collect (list (slynk-api:slynk-pprint-to-line spec) partial 158 | (slynk-api:slynk-pprint-to-line path))))) 159 | 160 | (defun print-tree () 161 | (loop for ts in (timed-specs) 162 | for total = (total-of ts) 163 | do (format t "~%~a~%~%" ts) 164 | (when (plusp total) 165 | (loop for partial being the hash-values of (stats-of ts) 166 | for path being the hash-keys of (stats-of ts) 167 | when (plusp partial) 168 | sum partial into total-partials 169 | and 170 | do (format t " ~8fs ~4f% ~a ~%" 171 | (/ partial 172 | internal-time-units-per-second) 173 | (* 100 (/ partial 174 | total)) 175 | (spec-of path)) 176 | finally 177 | (format t " ~8fs ~4f% ~a ~%" 178 | (/ (- total total-partials) 179 | internal-time-units-per-second) 180 | (* 100 (/ (- total total-partials) 181 | total)) 182 | 'other))))) 183 | 184 | (defslyfun clear-timing-tree () 185 | (setq *current-timing* nil) 186 | (loop for ts in (timed-specs) 187 | do (reinitialize-instance ts))) 188 | 189 | (provide :slynk/profiler) 190 | -------------------------------------------------------------------------------- /contrib/sly-autodoc.el: -------------------------------------------------------------------------------- 1 | ;;; -*-lexical-binding:t-*- 2 | ;;; (require 'sly) 3 | (require 'eldoc) 4 | (require 'cl-lib) 5 | (require 'sly-parse "lib/sly-parse") 6 | 7 | (define-sly-contrib sly-autodoc 8 | "Show fancy arglist in echo area." 9 | (:license "GPL") 10 | (:authors "Luke Gorrie " 11 | "Lawrence Mitchell " 12 | "Matthias Koeppe " 13 | "Tobias C. Rittweiler ") 14 | (:slynk-dependencies slynk/arglists) 15 | (:on-load (add-hook 'sly-editing-mode-hook 'sly-autodoc-mode) 16 | (add-hook 'sly-mrepl-mode-hook 'sly-autodoc-mode) 17 | (add-hook 'sly-minibuffer-setup-hook 'sly-autodoc-mode)) 18 | (:on-unload (remove-hook 'sly-editing-mode-hook 'sly-autodoc-mode) 19 | (remove-hook 'sly-mrepl-mode-hook 'sly-autodoc-mode) 20 | (remove-hook 'sly-minibuffer-setup-hook 'sly-autodoc-mode))) 21 | 22 | (defcustom sly-autodoc-accuracy-depth 10 23 | "Number of paren levels that autodoc takes into account for 24 | context-sensitive arglist display (local functions. etc)" 25 | :type 'integer 26 | :group 'sly-ui) 27 | 28 | 29 | 30 | (defun sly-arglist (name) 31 | "Show the argument list for NAME." 32 | (interactive (list (sly-read-symbol-name "Arglist of: " t))) 33 | (let ((arglist (sly-autodoc--retrieve-arglist name))) 34 | (if (eq arglist :not-available) 35 | (error "Arglist not available") 36 | (message "%s" (sly-autodoc--fontify arglist))))) 37 | 38 | (defun sly-autodoc--retrieve-arglist (name) 39 | (let ((name (cl-etypecase name 40 | (string name) 41 | (symbol (symbol-name name))))) 42 | (car (sly-eval `(slynk:autodoc '(,name ,sly-cursor-marker)))))) 43 | 44 | (defun sly-autodoc-manually () 45 | "Like autodoc information forcing multiline display." 46 | (interactive) 47 | (let ((doc (sly-autodoc t))) 48 | (cond (doc (eldoc-message (format "%s" doc))) 49 | (t (eldoc-message nil))))) 50 | 51 | ;; Must call eldoc-add-command otherwise (eldoc-display-message-p) 52 | ;; returns nil and eldoc clears the echo area instead. 53 | (eldoc-add-command 'sly-autodoc-manually) 54 | 55 | (defun sly-autodoc-space (n) 56 | "Like `sly-space' but nicer." 57 | (interactive "p") 58 | (self-insert-command n) 59 | (let ((doc (sly-autodoc))) 60 | (when doc 61 | (eldoc-message (format "%s" doc))))) 62 | 63 | (eldoc-add-command 'sly-autodoc-space) 64 | 65 | 66 | ;;;; Autodoc cache 67 | 68 | (defvar sly-autodoc--cache-last-context nil) 69 | (defvar sly-autodoc--cache-last-autodoc nil) 70 | 71 | 72 | ;;;; Formatting autodoc 73 | 74 | (defsubst sly-autodoc--canonicalize-whitespace (string) 75 | (replace-regexp-in-string "[ \n\t]+" " " string)) 76 | 77 | (defvar sly-autodoc-preamble nil) 78 | 79 | (defun sly-autodoc--format (doc multilinep) 80 | (let* ((strings (delete nil 81 | (list sly-autodoc-preamble 82 | (and doc 83 | (sly-autodoc--fontify doc))))) 84 | (message (and strings (mapconcat #'identity strings "\n")))) 85 | (when message 86 | (cond (multilinep message) 87 | (t (sly-oneliner (sly-autodoc--canonicalize-whitespace message))))))) 88 | 89 | (defalias 'sly--font-lock-ensure ; `font-lock-ensure' is not in Emacs 24.5. 90 | (if (fboundp 'font-lock-ensure) 91 | #'font-lock-ensure 92 | (with-no-warnings 93 | (lambda (&optional _beg _end) 94 | (when font-lock-mode 95 | (font-lock-fontify-buffer)))))) 96 | 97 | (defun sly-autodoc--fontify (string) 98 | "Fontify STRING as `font-lock-mode' does in Lisp mode." 99 | (with-current-buffer (get-buffer-create (sly-buffer-name :fontify :hidden t)) 100 | (erase-buffer) 101 | (unless (eq major-mode 'lisp-mode) 102 | ;; Just calling (lisp-mode) will turn sly-mode on in that buffer, 103 | ;; which may interfere with this function 104 | (setq major-mode 'lisp-mode) 105 | (lisp-mode-variables t)) 106 | (insert string) 107 | (let ((font-lock-verbose nil)) 108 | (sly--font-lock-ensure)) 109 | (goto-char (point-min)) 110 | (when (re-search-forward "===> \\(\\(.\\|\n\\)*\\) <===" nil t) 111 | (let ((highlight (match-string 1))) 112 | ;; Can't use (replace-match highlight) here -- broken in Emacs 21 113 | (delete-region (match-beginning 0) (match-end 0)) 114 | (sly-insert-propertized '(face eldoc-highlight-function-argument) 115 | highlight))) 116 | (buffer-substring (point-min) (point-max)))) 117 | 118 | 119 | ;;;; Autodocs (automatic context-sensitive help) 120 | 121 | (defun sly-autodoc (&optional force-multiline) 122 | "Returns the cached arglist information as string, or nil. 123 | If it's not in the cache, the cache will be updated asynchronously." 124 | (interactive "P") 125 | (save-excursion 126 | (save-match-data 127 | ;; See github#385 and 128 | ;; https://debbugs.gnu.org/cgi/bugreport.cgi?bug=45117 129 | (let* ((inhibit-quit t) 130 | (context 131 | (cons 132 | (sly-current-connection) 133 | (sly-autodoc--parse-context)))) 134 | (when (car context) 135 | (let* ((cached (and (equal context sly-autodoc--cache-last-context) 136 | sly-autodoc--cache-last-autodoc)) 137 | (multilinep (or force-multiline 138 | eldoc-echo-area-use-multiline-p))) 139 | (cond (cached (sly-autodoc--format cached multilinep)) 140 | (t 141 | (when (sly-background-activities-enabled-p) 142 | (sly-autodoc--async context multilinep)) 143 | nil)))))))) 144 | 145 | ;; Return the context around point that can be passed to 146 | ;; slynk:autodoc. nil is returned if nothing reasonable could be 147 | ;; found. 148 | (defun sly-autodoc--parse-context () 149 | (and (not (sly-inside-string-or-comment-p)) 150 | (sly-parse-form-upto-point sly-autodoc-accuracy-depth))) 151 | 152 | (defun sly-autodoc--async (context multilinep) 153 | (sly-eval-async 154 | `(slynk:autodoc ',(cdr context) ;; FIXME: misuse of quote 155 | :print-right-margin ,(window-width (minibuffer-window))) 156 | (sly-curry #'sly-autodoc--async% context multilinep))) 157 | 158 | (defun sly-autodoc--async% (context multilinep doc) 159 | (cl-destructuring-bind (doc &optional cache-p) doc 160 | (unless (eq doc :not-available) 161 | (when cache-p 162 | (setq sly-autodoc--cache-last-context context) 163 | (setq sly-autodoc--cache-last-autodoc doc)) 164 | ;; Now that we've got our information, 165 | ;; get it to the user ASAP. 166 | (when (eldoc-display-message-p) 167 | (eldoc-message (format "%s" (sly-autodoc--format doc multilinep))))))) 168 | 169 | 170 | ;;; Minor mode definition 171 | (defvar sly-autodoc-mode-map 172 | (let ((map (make-sparse-keymap))) 173 | (define-key map (kbd "C-c C-d A") 'sly-autodoc) 174 | map)) 175 | 176 | (define-minor-mode sly-autodoc-mode 177 | "Toggle echo area display of Lisp objects at point." 178 | nil nil nil 179 | (cond (sly-autodoc-mode 180 | (set (make-local-variable 'eldoc-documentation-function) 'sly-autodoc) 181 | (set (make-local-variable 'eldoc-minor-mode-string) "") 182 | (eldoc-mode sly-autodoc-mode)) 183 | (t 184 | (eldoc-mode -1) 185 | (set (make-local-variable 'eldoc-documentation-function) nil) 186 | (set (make-local-variable 'eldoc-minor-mode-string) " ElDoc")))) 187 | 188 | (provide 'sly-autodoc) 189 | -------------------------------------------------------------------------------- /slynk/slynk-gray.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- 2 | ;;; 3 | ;;; slynk-gray.lisp --- Gray stream based IO redirection. 4 | ;;; 5 | ;;; Created 2003 6 | ;;; 7 | ;;; This code has been placed in the Public Domain. All warranties 8 | ;;; are disclaimed. 9 | ;;; 10 | 11 | (in-package slynk-backend) 12 | 13 | #.(progn 14 | (defvar *gray-stream-symbols* 15 | '(fundamental-character-output-stream 16 | stream-write-char 17 | stream-write-string 18 | stream-fresh-line 19 | stream-force-output 20 | stream-finish-output 21 | 22 | fundamental-character-input-stream 23 | stream-read-char 24 | stream-peek-char 25 | stream-read-line 26 | stream-listen 27 | stream-unread-char 28 | stream-clear-input 29 | stream-line-column 30 | stream-read-char-no-hang)) 31 | nil) 32 | 33 | (defpackage slynk-gray 34 | (:use cl slynk-backend) 35 | (:import-from #.(gray-package-name) . #.*gray-stream-symbols*) 36 | (:export . #.*gray-stream-symbols*)) 37 | 38 | (in-package slynk-gray) 39 | 40 | (defclass sly-output-stream (fundamental-character-output-stream) 41 | ((output-fn :initarg :output-fn) 42 | (buffer :initform (make-string 8000)) 43 | (fill-pointer :initform 0) 44 | (column :initform 0) 45 | (lock :initform (make-lock :name "buffer write lock")) 46 | (flush-thread :initarg :flush-thread 47 | :initform nil 48 | :accessor flush-thread) 49 | (flush-scheduled :initarg :flush-scheduled 50 | :initform nil 51 | :accessor flush-scheduled))) 52 | 53 | (defun maybe-schedule-flush (stream) 54 | (when (and (flush-thread stream) 55 | (not (flush-scheduled stream))) 56 | (setf (flush-scheduled stream) t) 57 | (send (flush-thread stream) t))) 58 | 59 | (defmacro with-sly-output-stream (stream &body body) 60 | `(with-slots (lock output-fn buffer fill-pointer column) ,stream 61 | (call-with-lock-held lock (lambda () ,@body)))) 62 | 63 | (defmethod stream-write-char ((stream sly-output-stream) char) 64 | (with-sly-output-stream stream 65 | (setf (schar buffer fill-pointer) char) 66 | (incf fill-pointer) 67 | (incf column) 68 | (when (char= #\newline char) 69 | (setf column 0)) 70 | (if (= fill-pointer (length buffer)) 71 | (finish-output stream) 72 | (maybe-schedule-flush stream))) 73 | char) 74 | 75 | (defmethod stream-write-string ((stream sly-output-stream) string 76 | &optional start end) 77 | (with-sly-output-stream stream 78 | (let* ((start (or start 0)) 79 | (end (or end (length string))) 80 | (len (length buffer)) 81 | (count (- end start)) 82 | (free (- len fill-pointer))) 83 | (when (>= count free) 84 | (stream-finish-output stream)) 85 | (cond ((< count len) 86 | (replace buffer string :start1 fill-pointer 87 | :start2 start :end2 end) 88 | (incf fill-pointer count) 89 | (maybe-schedule-flush stream)) 90 | (t 91 | (funcall output-fn (subseq string start end)))) 92 | (let ((last-newline (position #\newline string :from-end t 93 | :start start :end end))) 94 | (setf column (if last-newline 95 | (- end last-newline 1) 96 | (+ column count)))))) 97 | string) 98 | 99 | (defmethod stream-line-column ((stream sly-output-stream)) 100 | (with-sly-output-stream stream column)) 101 | 102 | (defmethod reset-stream-line-column ((stream sly-output-stream)) 103 | (with-sly-output-stream stream (setf column 0))) 104 | 105 | #+sbcl 106 | (defmethod reset-stream-line-column ((stream sb-sys:fd-stream)) 107 | (with-slots (sb-impl::output-column) stream 108 | (setf sb-impl::output-column 0))) 109 | 110 | #+cmucl 111 | (defmethod reset-stream-line-column ((stream system:fd-stream)) 112 | (with-slots (lisp::char-pos) stream 113 | (setf lisp::char-pos 0))) 114 | 115 | (defmethod stream-finish-output ((stream sly-output-stream)) 116 | (with-sly-output-stream stream 117 | (unless (zerop fill-pointer) 118 | (funcall output-fn (subseq buffer 0 fill-pointer)) 119 | (setf fill-pointer 0)) 120 | (setf (flush-scheduled stream) nil)) 121 | nil) 122 | 123 | #+(and sbcl sb-thread) 124 | (defmethod stream-force-output :around ((stream sly-output-stream)) 125 | ;; Workaround for deadlocks between the world-lock and auto-flush-thread 126 | ;; buffer write lock. 127 | ;; 128 | ;; Another alternative would be to grab the world-lock here, but that's less 129 | ;; future-proof, and could introduce other lock-ordering issues in the 130 | ;; future. 131 | (handler-case 132 | (sb-sys:with-deadline (:seconds 0.1) 133 | (call-next-method)) 134 | (sb-sys:deadline-timeout () 135 | nil))) 136 | 137 | (defmethod stream-force-output ((stream sly-output-stream)) 138 | (stream-finish-output stream)) 139 | 140 | (defmethod stream-fresh-line ((stream sly-output-stream)) 141 | (with-sly-output-stream stream 142 | (cond ((zerop column) nil) 143 | (t (terpri stream) t)))) 144 | 145 | (defclass sly-input-stream (fundamental-character-input-stream) 146 | ((input-fn :initarg :input-fn) 147 | (buffer :initform "") (index :initform 0) 148 | (lock :initform (make-lock :name "buffer read lock")))) 149 | 150 | (defmethod stream-read-char ((s sly-input-stream)) 151 | (call-with-lock-held 152 | (slot-value s 'lock) 153 | (lambda () 154 | (with-slots (buffer index input-fn) s 155 | (when (= index (length buffer)) 156 | (let ((string (funcall input-fn))) 157 | (cond ((zerop (length string)) 158 | (return-from stream-read-char :eof)) 159 | (t 160 | (setf buffer string) 161 | (setf index 0))))) 162 | (assert (plusp (length buffer))) 163 | (prog1 (aref buffer index) (incf index)))))) 164 | 165 | (defmethod stream-listen ((s sly-input-stream)) 166 | (call-with-lock-held 167 | (slot-value s 'lock) 168 | (lambda () 169 | (with-slots (buffer index) s 170 | (< index (length buffer)))))) 171 | 172 | (defmethod stream-unread-char ((s sly-input-stream) char) 173 | (call-with-lock-held 174 | (slot-value s 'lock) 175 | (lambda () 176 | (with-slots (buffer index) s 177 | (decf index) 178 | (cond ((eql (aref buffer index) char) 179 | (setf (aref buffer index) char)) 180 | (t 181 | (warn "stream-unread-char: ignoring ~S (expected ~S)" 182 | char (aref buffer index))))))) 183 | nil) 184 | 185 | (defmethod stream-clear-input ((s sly-input-stream)) 186 | (call-with-lock-held 187 | (slot-value s 'lock) 188 | (lambda () 189 | (with-slots (buffer index) s 190 | (setf buffer "" 191 | index 0)))) 192 | nil) 193 | 194 | (defmethod stream-line-column ((s sly-input-stream)) 195 | nil) 196 | 197 | (defmethod stream-read-char-no-hang ((s sly-input-stream)) 198 | (call-with-lock-held 199 | (slot-value s 'lock) 200 | (lambda () 201 | (with-slots (buffer index) s 202 | (when (< index (length buffer)) 203 | (prog1 (aref buffer index) (incf index))))))) 204 | 205 | 206 | ;;; 207 | 208 | (defimplementation make-auto-flush-thread (stream) 209 | (if (typep stream 'sly-output-stream) 210 | (setf (flush-thread stream) 211 | (spawn (lambda () (auto-flush-loop stream 0.08 t)) 212 | :name "auto-flush-thread")) 213 | (spawn (lambda () (auto-flush-loop stream *auto-flush-interval*)) 214 | :name "auto-flush-thread"))) 215 | 216 | (defimplementation make-output-stream (write-string) 217 | (make-instance 'sly-output-stream :output-fn write-string)) 218 | 219 | (defimplementation make-input-stream (read-string) 220 | (make-instance 'sly-input-stream :input-fn read-string)) 221 | -------------------------------------------------------------------------------- /slynk/slynk-rpc.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- indent-tabs-mode: nil; coding: latin-1-unix -*- 2 | ;;; 3 | ;;; slynk-rpc.lisp -- Pass remote calls and responses between lisp systems. 4 | ;;; 5 | ;;; Created 2010, Terje Norderhaug 6 | ;;; 7 | ;;; This code has been placed in the Public Domain. All warranties 8 | ;;; are disclaimed. 9 | ;;; 10 | 11 | (defpackage #:slynk-rpc 12 | (:use :cl) 13 | (:export 14 | #:read-message 15 | #:read-packet 16 | #:slynk-reader-error 17 | #:slynk-reader-error.packet 18 | #:slynk-reader-error.cause 19 | #:write-message 20 | #:*translating-swank-to-slynk*)) 21 | 22 | (in-package :slynk-rpc) 23 | 24 | 25 | ;;;;; Input 26 | 27 | (define-condition slynk-reader-error (reader-error) 28 | ((packet :type string :initarg :packet 29 | :reader slynk-reader-error.packet) 30 | (cause :type reader-error :initarg :cause 31 | :reader slynk-reader-error.cause))) 32 | 33 | (defun read-message (stream package) 34 | (let ((packet (read-packet stream))) 35 | (handler-case (values (read-form packet package)) 36 | (reader-error (c) 37 | (error 'slynk-reader-error 38 | :packet packet :cause c))))) 39 | 40 | (defun read-packet (stream) 41 | (let* ((length (parse-header stream)) 42 | (octets (read-chunk stream length))) 43 | (handler-case (slynk-backend:utf8-to-string octets) 44 | (error (c) 45 | (error 'slynk-reader-error 46 | :packet (asciify octets) 47 | :cause c))))) 48 | 49 | (defun asciify (packet) 50 | (with-output-to-string (*standard-output*) 51 | (loop for code across (etypecase packet 52 | (string (map 'vector #'char-code packet)) 53 | (vector packet)) 54 | do (cond ((<= code #x7f) (write-char (code-char code))) 55 | (t (format t "\\x~x" code)))))) 56 | 57 | (defun parse-header (stream) 58 | (parse-integer (map 'string #'code-char (read-chunk stream 6)) 59 | :radix 16)) 60 | 61 | (defun read-chunk (stream length) 62 | (let* ((buffer (make-array length :element-type '(unsigned-byte 8))) 63 | (count (read-sequence buffer stream))) 64 | (cond ((= count length) 65 | buffer) 66 | ((zerop count) 67 | (error 'end-of-file :stream stream)) 68 | (t 69 | (error "Short read: length=~D count=~D" length count))))) 70 | 71 | (defparameter *translating-swank-to-slynk* t 72 | "Set to true to ensure SWANK*::SYMBOL is interned SLYNK*::SYMBOL. 73 | Set by default to T to ensure that bootstrapping can occur from 74 | clients sending strings like this on the wire. 75 | 76 | (:EMACS-REX (SWANK:CONNECTION-INFO) NIL T 1) 77 | 78 | *before* the slynk-retro.lisp contrib kicks in and renames SLYNK* 79 | packages to SWANK*. After this happens, this variable is set to NIL, 80 | since the translation is no longer necessary. 81 | 82 | The user that is completely sure that Slynk will always be contacted 83 | by SLY clients **without** the sly-retro.el contrib, can also set this 84 | to NIL in her ~/.swankrc. Generally best left alone.") 85 | 86 | (defun read-form (string package) 87 | (with-standard-io-syntax 88 | (let ((*package* package)) 89 | (if *translating-swank-to-slynk* 90 | (with-input-from-string (*standard-input* string) 91 | (translating-read)) 92 | (read-from-string string))))) 93 | 94 | (defun maybe-convert-package-designator (string) 95 | (let ((colon-pos (position #\: string)) 96 | (search (search "SWANK" string :test #'char-equal))) 97 | (if (and search colon-pos) 98 | (nstring-upcase (replace string "SLYNK")) 99 | string))) 100 | 101 | (defun translating-read () 102 | "Read a form that conforms to the protocol, otherwise signal an error." 103 | (flet ((chomp () 104 | (loop for ch = (read-char nil t) 105 | while (eq ch #\space) 106 | finally (unread-char ch)))) 107 | (chomp) 108 | (let ((c (read-char))) 109 | (case c 110 | (#\" (with-output-to-string (*standard-output*) 111 | (loop for c = (read-char) do 112 | (case c 113 | (#\" (return)) 114 | (#\\ (write-char (read-char))) 115 | (t (write-char c)))))) 116 | (#\( 117 | (chomp) 118 | (loop with dotread = nil 119 | with retval = nil 120 | for read = (read-char) 121 | while (case read 122 | (#\) nil) 123 | (#\. (setq dotread t) t) 124 | (t (progn (unread-char read) t))) 125 | 126 | when (eq dotread 'should-error) 127 | do (error 'reader-error :format-arguments "Too many things after dot") 128 | when dotread 129 | do (setq dotread 'should-error) 130 | do (setq retval (nconc retval 131 | (if dotread 132 | (translating-read) 133 | (list (translating-read))))) 134 | (chomp) 135 | finally (return retval))) 136 | (#\' `(quote ,(translating-read))) 137 | (t (let ((string (with-output-to-string (*standard-output*) 138 | (loop for ch = c then (read-char nil nil) do 139 | (case ch 140 | ((nil) (return)) 141 | (#\\ (write-char (read-char))) 142 | ((#\" #\( #\space #\)) (unread-char ch)(return)) 143 | (t (write-char ch))))))) 144 | (read-from-string 145 | (maybe-convert-package-designator string)))))))) 146 | 147 | 148 | ;;;;; Output 149 | 150 | (defun write-message (message package stream) 151 | (let* ((string (prin1-to-string-for-emacs message package)) 152 | (octets (handler-case (slynk-backend:string-to-utf8 string) 153 | (error (c) (encoding-error c string)))) 154 | (length (length octets))) 155 | (write-header stream length) 156 | (write-sequence octets stream) 157 | (finish-output stream))) 158 | 159 | ;; FIXME: for now just tell emacs that we and an encoding problem. 160 | (defun encoding-error (condition string) 161 | (slynk-backend:string-to-utf8 162 | (prin1-to-string-for-emacs 163 | `(:reader-error 164 | ,(asciify string) 165 | ,(format nil "Error during string-to-utf8: ~a" 166 | (or (ignore-errors (asciify (princ-to-string condition))) 167 | (asciify (princ-to-string (type-of condition)))))) 168 | (find-package :cl)))) 169 | 170 | (defun write-header (stream length) 171 | (declare (type (unsigned-byte 24) length)) 172 | ;;(format *trace-output* "length: ~d (#x~x)~%" length length) 173 | (loop for c across (format nil "~6,'0x" length) 174 | do (write-byte (char-code c) stream))) 175 | 176 | (defun switch-to-double-floats (x) 177 | (typecase x 178 | (double-float x) 179 | (float (coerce x 'double-float)) 180 | (null x) 181 | (list (loop for (x . cdr) on x 182 | collect (switch-to-double-floats x) into result 183 | until (atom cdr) 184 | finally (return (append result (switch-to-double-floats cdr))))) 185 | (t x))) 186 | 187 | (defun prin1-to-string-for-emacs (object package) 188 | (with-standard-io-syntax 189 | (let ((*print-case* :downcase) 190 | (*print-readably* nil) 191 | (*print-pretty* nil) 192 | (*package* package) 193 | ;; Emacs has only double floats. 194 | (*read-default-float-format* 'double-float)) 195 | (prin1-to-string (switch-to-double-floats object))))) 196 | 197 | 198 | #| TEST/DEMO: 199 | 200 | (defparameter *transport* 201 | (with-output-to-string (out) 202 | (write-message '(:message (hello "world")) *package* out) 203 | (write-message '(:return 5) *package* out) 204 | (write-message '(:emacs-rex NIL) *package* out))) 205 | 206 | *transport* 207 | 208 | (with-input-from-string (in *transport*) 209 | (loop while (peek-char T in NIL) 210 | collect (read-message in *package*))) 211 | 212 | |# 213 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | [![Tests](https://github.com/joaotavora/sly/actions/workflows/ci.yml/badge.svg?branch=master)](https://github.com/joaotavora/sly/actions/workflows/ci.yml) 2 | [![MELPA Stable](https://stable.melpa.org/packages/sly-badge.svg)](https://stable.melpa.org/#/sly) 3 | [![MELPA](https://melpa.org/packages/sly-badge.svg)](https://melpa.org/#/sly) 4 | 5 | ```lisp 6 | _____ __ __ __ 7 | / ___/ / / \ \/ / |\ _,,,---,,_ 8 | \__ \ / / \ / /,`.-'`' -. ;-;;,_ 9 | ___/ / / /___ / / |,4- ) )-,_..;\ ( `'-' 10 | /____/ /_____/ /_/ '---''(_/--' `-'\_) 11 | 12 | ``` 13 | 14 | SLY is Sylvester the Cat's Common Lisp IDE for Emacs: 15 | 16 | * 🤔 Read [a short illustrated guide][tutorial] 17 | * 📽️ Scroll down this README for some [pretty gifs](#animated_gifs) 18 | * 📣 Read the [NEWS][6] file 19 | * 📚 Read the [manual][documentation] 20 | 21 | SLY's highlights are: 22 | 23 | * A [full-featured REPL](#repl) based on Emacs's `comint.el`. Everything can be 24 | copied to the REPL; 25 | * [Stickers](#stickers), or live code annotations that record values as code 26 | traverses them. 27 | * [Flex-style completion](#company-flex-completion) out-of-the-box, using 28 | Emacs's completion API. Company, Helm, and other [supported 29 | natively](#completion), no plugin required; 30 | * An interactive [Trace Dialog][trace-dialog]; 31 | * Cleanly ASDF-loaded by default, including contribs, enabled out-of-the-box; 32 | * Multiple inspectors and multiple REPLs; 33 | * "Presentations" replaced by [interactive backreferences](#repl) which 34 | highlight the object and remain stable throughout the REPL session; 35 | * Support for [NAMED-READTABLES][11], [macrostep.el][12] and [quicklisp][13] 36 | * A [portable, annotation-based stepper][16] in [early][17] but functional 37 | prototype stage. 38 | 39 | SLY is a fork of [SLIME][1]. We tracks its bugfixes, particularly to the 40 | implementation backends. All SLIME's familar features (debugger, inspector, 41 | xref, etc...) are still available, with improved overall UX. 42 | 43 | Installation 44 | ------------ 45 | 46 | Ensure that [MELPA][10] is setup as usual and ask `M-x package-install` to 47 | install the package `sly`. 48 | 49 | *That's it*. `sly-mode` will automatically come up in every `.lisp` file. To 50 | fire up SLY, connect to a Lisp and get a friendly REPL, use `M-x sly`. 51 | 52 | Even if you already have SLIME installed, SLY will ask you and temporarily 53 | disable it for the Emacs session. 54 | 55 | 56 | _Obligatory animated gif section_ 57 | ----------------------------------- 58 | 59 | 60 | [Flex completion](https://joaotavora.github.io/sly/#Completion) 61 | 62 | ![company-flex-completion](./doc/animations/company-flex-completion.gif) 63 | 64 | 65 | [Backreferences](https://joaotavora.github.io/sly/#REPL-backreferences) 66 | 67 | ![backreferences](./doc/animations/backreferences.gif) 68 | 69 | [Reverse i-search](https://joaotavora.github.io/sly/#REPL-commands) 70 | 71 | ![reverse-isearch](./doc/animations/reverse-isearch.gif) 72 | 73 | 74 | [Stickers](https://joaotavora.github.io/sly/#Stickers) 75 | 76 | ![stickers-example](./doc/animations/stickers-example.gif) 77 | 78 | Install from git 79 | ------------------- 80 | 81 | Clone this repository, add this to your `~/.emacs` file and fill in the 82 | appropriate file names: 83 | 84 | ```el 85 | (add-to-list 'load-path "~/dir/to/cloned/sly") 86 | (require 'sly-autoloads) 87 | (setq inferior-lisp-program "/opt/sbcl/bin/sbcl") 88 | ``` 89 | 90 | If you wish to byte-compile SLY yourself (not needed generally) you can do `make 91 | compile compile-contrib` in the dir where you cloned SLY. 92 | 93 | Running the server standalone 94 | ----------------------------- 95 | 96 | This also works 97 | ``` 98 | $ sbcl 99 | ... 100 | * (push #p"~/dir/to/sly" asdf:*central-registry*) 101 | * (asdf:load-system :slynk) 102 | * (slynk:create-server :port 4008) 103 | ``` 104 | 105 | Now in Emacs you can do `sly-connect` and give it the host and the 4008 port as 106 | a destination. 107 | 108 | Faster startup 109 | -------------- 110 | 111 | If the Lisp program doesn't start fast enough for you, look in [the 112 | manual][instasly], for ways to make it faster. 113 | 114 | Additional Contribs 115 | ------------------- 116 | 117 | * https://github.com/joaotavora/sly-quicklisp 118 | * https://github.com/joaotavora/sly-named-readtables 119 | * https://github.com/joaotavora/sly-macrostep 120 | * https://github.com/joaotavora/sly-stepper 121 | * https://github.com/mmgeorge/sly-asdf 122 | * https://github.com/40ants/sly-package-inferred 123 | 124 | 125 | Completion UIs 126 | -------------- 127 | 128 | SLY works with most Emacs "completion UIs" out of the box, providing completion 129 | in source files and inputting Common Lisp symbol names from the minibuffer. 130 | [Company][14], Emacs 27's Fido-mode, and Helm are well-supported, as is 131 | "vanilla" completion. For consistency, SLY defaults to its own UI, 132 | `sly-symbol-completion-mode`, useful if you don't have or like any of those. 133 | You can turn it off. Also, if you use Helm and wish to have even more 134 | Helm-based fanciness, you can use [helm-sly][15]. 135 | 136 | License 137 | ------- 138 | 139 | SLY is free software. All files, unless explicitly stated otherwise, are public 140 | domain. ASCII artwork is copyright by Felix Lee, Joan G. Stark and Hayley Jane 141 | Wakenshaw. 142 | 143 | Fork 144 | ---- 145 | 146 | SLIME is the work of Eric Marsden, Luke Gorrie, Helmut Eller, Tobias 147 | C. Rittweiler and [many others][8]. I forked SLIME because I used it daily, 148 | for work, had a long list of hacks developed for myself, and wanted to share 149 | them with others. 150 | 151 | In 2013, SLIME development was stalling, patches and issues rotting. In early 152 | 2014, Luís Oliveira and myself moved SLIME to Github and set up its Travis CI 153 | system. I brought in the old bug reports from the Launchpad tracker, fixed 154 | long-standing problems and submitted many changes, particularly to the 155 | under-curated but popular "contrib" section. 156 | 157 | Now, the changes that SLY brings to the table are too deep at the Elisp and Lisp 158 | level to be accepted to SLIME, given its current focus on stability (for the 159 | record, I find this perfectly reasonable). The new features, such as stickers or 160 | multiple inspectors, cannot be realized well using only the existing "contrib" 161 | system. Finally, SLY frees itself from the shackles of Emacs 23 and supports 162 | Emacs 24.5+ only, allowing for much cleaner code and liberal use of lexical 163 | binding. 164 | 165 | The list of technical reasons is bigger than this though, and you can read up on 166 | them in the [CONTRIBUTING.md][9] file. 167 | 168 | Contributing 169 | ------------ 170 | 171 | [Open an issue or a pull request][4], but at least have a quick look at the 172 | first part [CONTRIBUTING.md][5] file for instructions on how to contribute. 173 | 174 | [1]: https://www.common-lisp.net/project/slime/ 175 | [2]: https://github.com/joaotavora/sly/blob/master/README.md#fork 176 | [4]: https://github.com/joaotavora/sly/issues 177 | [5]: https://github.com/joaotavora/sly/blob/master/CONTRIBUTING.md 178 | [6]: https://github.com/joaotavora/sly/blob/master/NEWS.md 179 | [7]: https://www.youtube.com/watch?v=xqWkVvubnSI 180 | [8]: https://common-lisp.net/project/slime/doc/html/Credits.html#Credits 181 | [9]: https://github.com/joaotavora/sly/blob/master/CONTRIBUTING.md#architecture 182 | [10]: https://github.com/milkypostman/melpa 183 | [11]: https://github.com/joaotavora/sly-named-readtables 184 | [12]: https://github.com/joaotavora/sly-macrostep 185 | [13]: https://github.com/joaotavora/sly-quicklisp 186 | [14]: https://github.com/company-mode/company-mode 187 | [15]: https://github.com/emacs-helm/helm-sly 188 | [16]: https://zenodo.org/record/3742759 189 | [17]: https://github.com/joaotavora/sly-stepper 190 | [documentation]: https://joaotavora.github.io/sly 191 | [instasly]: https://joaotavora.github.io/sly/#Loading-Slynk-faster 192 | [trace-dialog]: https://joaotavora.github.io/sly/#Trace-Dialog 193 | [tutorial]: https://joaotavora.github.io/sly/#A-SLY-tour-for-SLIME-users 194 | 195 | 196 | 197 | 198 | -------------------------------------------------------------------------------- /test/sly-stickers-tests.el: -------------------------------------------------------------------------------- 1 | ;; -*- lexical-binding: t; -*- 2 | (require 'sly-stickers "contrib/sly-stickers") 3 | (require 'sly-tests "lib/sly-tests") 4 | (require 'cl-lib) 5 | (require 'ert-x) 6 | 7 | (defvar sly-stickers--test-debug nil) 8 | 9 | (defun sly-stickers--call-with-fixture (function forms sticker-prefixes) 10 | (let ((file (make-temp-file "sly-stickers--fixture")) 11 | (sly-flash-inhibit t) 12 | ;; important HACK so this doesn't fail with the `sly-retro' 13 | ;; contrib. 14 | (sly-net-send-translator nil)) 15 | (sly-eval-async '(cl:ignore-errors (cl:delete-package :slynk-stickers-fixture))) 16 | (sly-sync-to-top-level 1) 17 | (unwind-protect 18 | (with-current-buffer 19 | (find-file file) 20 | (lisp-mode) 21 | (insert (mapconcat #'pp-to-string 22 | (append '((defpackage :slynk-stickers-fixture (:use :cl)) 23 | (in-package :slynk-stickers-fixture)) 24 | forms) 25 | "\n")) 26 | (write-file file) 27 | (cl-loop for prefix in sticker-prefixes 28 | do 29 | (goto-char (point-max)) 30 | (search-backward prefix) 31 | (call-interactively 'sly-stickers-dwim)) 32 | (funcall function) 33 | (sly-sync-to-top-level 1)) 34 | (if sly-stickers--test-debug 35 | (sly-message "leaving file %s" file) 36 | (let ((visitor (find-buffer-visiting file))) 37 | (when visitor (kill-buffer visitor))) 38 | (delete-file file)) 39 | ))) 40 | 41 | (cl-defmacro sly-stickers--with-fixture ((forms sticker-prefixes) &rest body) 42 | (declare (indent defun) (debug (sexp &rest form))) 43 | `(sly-stickers--call-with-fixture (lambda () ,@body) ,forms ,sticker-prefixes)) 44 | 45 | (defun sly-stickers--topmost-sticker () 46 | (car (sly-button--overlays-at 47 | (point) (lambda (o) (eq (button-type o) 'sly-stickers-sticker))))) 48 | 49 | (defun sly-stickers--base-face (sticker) 50 | (let ((face (overlay-get sticker 'face))) 51 | (if (atom face) 52 | face 53 | (plist-get face :inherit)))) 54 | 55 | (defun sly-stickers--face-p (face) 56 | (let* ((sticker (sly-stickers--topmost-sticker)) 57 | (actual (sly-stickers--base-face sticker))) 58 | (eq face actual))) 59 | 60 | (define-sly-ert-test stickers-basic-navigation () 61 | "Test that setting stickers and navigating to them works" 62 | (sly-stickers--with-fixture ('((defun foo () (bar (baz))) 63 | (defun quux () (coiso (cena)))) 64 | '("(bar" "(baz" "(coiso")) 65 | (goto-char (point-min)) 66 | (ert-simulate-command '(sly-stickers-next-sticker 1)) 67 | (save-excursion 68 | (should (equal (read (current-buffer)) '(bar (baz))))) 69 | (ert-simulate-command '(sly-stickers-next-sticker 1)) 70 | (save-excursion 71 | (should (equal (read (current-buffer)) '(baz)))) 72 | (ert-simulate-command '(sly-stickers-next-sticker 1)) 73 | (save-excursion 74 | (should (equal (read (current-buffer)) '(coiso (cena))))) 75 | (should (eq 'sly-stickers-placed-face 76 | (sly-stickers--base-face (sly-stickers--topmost-sticker)))))) 77 | 78 | (define-sly-ert-test stickers-should-stick () 79 | "Test trying to compile the buffer and checking that stickers stuck" 80 | (sly-stickers--with-fixture ('((defun foo () (bar (baz))) 81 | (defun quux () (coiso (cena)))) 82 | '("(bar" "(baz" "(coiso")) 83 | (call-interactively 'sly-compile-defun) 84 | (sly-sync-to-top-level 1) 85 | (unless (sly-stickers--face-p 'sly-stickers-armed-face) 86 | (ert-fail "Expected QUUX stickers to be armed")) 87 | (ert-simulate-command '(sly-stickers-prev-sticker 1)) 88 | (unless (sly-stickers--face-p 'sly-stickers-placed-face) 89 | (ert-fail "Compiled just the QUUX defun, didn't expect FOO stickers to arm.")) 90 | (call-interactively 'sly-compile-defun) 91 | (sly-sync-to-top-level 1) 92 | (unless (sly-stickers--face-p 'sly-stickers-armed-face) 93 | (ert-fail "Expected innermost FOO sticker to be armed by now.")) 94 | (ert-simulate-command '(sly-stickers-prev-sticker 1)) 95 | (unless (sly-stickers--face-p 'sly-stickers-armed-face) 96 | (ert-fail "Expected outermost FOO sticker to also be armed by now.")))) 97 | 98 | (define-sly-ert-test stickers-when-invalid-dont-stick () 99 | "Test trying to make invalid stickers stick" 100 | (sly-stickers--with-fixture ('((defun foo () (bar (baz)))) 101 | '("(bar" "(baz" "foo")) 102 | (goto-char (point-min)) 103 | (ert-simulate-command '(sly-stickers-next-sticker 1)) 104 | (unless (sly-stickers--face-p 'sly-stickers-placed-face) 105 | (ert-fail "Expected FOO sticker to be unarmed")) 106 | (call-interactively 'sly-compile-defun) 107 | (sly-sync-to-top-level 1) 108 | (unless (sly-stickers--face-p 'sly-stickers-placed-face) 109 | (ert-fail "Expected invalid FOO sticker to remain unarmed")) 110 | (ert-simulate-command '(sly-stickers-next-sticker 1)) 111 | (unless (sly-stickers--face-p 'sly-stickers-placed-face) 112 | (ert-fail "Expected valid BAR sticker to remain unarmed")) 113 | (ert-simulate-command '(sly-stickers-next-sticker 1)) 114 | (unless (sly-stickers--face-p 'sly-stickers-placed-face) 115 | (ert-fail "Expected valid BAZ sticker to remain unarmed")))) 116 | 117 | (define-sly-ert-test stickers-in-a-file 118 | "Test compiling a file with some valid and invalid stickers." 119 | (sly-stickers--with-fixture ('((defun foo () (bar (baz))) 120 | (defun bar (x) (values (list x) 'bar)) 121 | (defun baz () 42) 122 | (defun xpto () (let ((coiso)) coiso))) 123 | '("(bar" "(baz" "(coiso")) 124 | 125 | (goto-char (point-min)) 126 | (call-interactively 'sly-compile-and-load-file) 127 | (sly-sync-to-top-level 1) 128 | (ert-simulate-command '(sly-stickers-next-sticker 1)) 129 | (unless (sly-stickers--face-p 'sly-stickers-armed-face) 130 | (ert-fail "Expected BAR sticker to be armed")) 131 | (ert-simulate-command '(sly-stickers-next-sticker 1)) 132 | (unless (sly-stickers--face-p 'sly-stickers-armed-face) 133 | (ert-fail "Expected BAZ sticker to be armed")) 134 | (ert-simulate-command '(sly-stickers-next-sticker 1)) 135 | (unless (sly-stickers--face-p 'sly-stickers-placed-face) 136 | (ert-fail "Didn't expect COISO sticker to be armed")))) 137 | 138 | (define-sly-ert-test stickers-record-stuff () 139 | "Test actually checking stickers' values." 140 | (sly-stickers--with-fixture ('((defun foo () (bar (baz))) 141 | (defun bar (x) (values (list x) 'bar)) 142 | (defun baz () 42)) 143 | '("(bar" "(baz")) 144 | 145 | (goto-char (point-min)) 146 | (call-interactively 'sly-compile-and-load-file) 147 | (sly-sync-to-top-level 1) 148 | (ert-simulate-command '(sly-stickers-next-sticker 1)) 149 | (unless (sly-stickers--face-p 'sly-stickers-armed-face) 150 | (ert-fail "Expected BAR sticker to be armed by now")) 151 | (sly-eval-async '(slynk-stickers-fixture::foo)) 152 | (sly-sync-to-top-level 1) 153 | (call-interactively 'sly-stickers-fetch) 154 | (sly-sync-to-top-level 1) 155 | (unless (sly-stickers--face-p 'sly-stickers-recordings-face) 156 | (ert-fail "Expected BAR sticker to have some information")) 157 | 158 | ;; This part still needs work 159 | ;; 160 | ;; (ert-simulate-command '(sly-stickers-next-sticker 1)) 161 | ;; (ert-simulate-command '(sly-stickers-next-sticker 1)) 162 | ;; (call-interactively 'sly-compile-defun) 163 | ;; (sly-sync-to-top-level 1) 164 | ;; (unless (sly-stickers--face-p 'sly-stickers-armed-face) 165 | ;; (ert-fail "Expected QUUX sticker to be armed")) 166 | ;; (sly-eval-async '(cl:ignore-errors (slynk-stickers-fixture::quux))) 167 | ;; (call-interactively 'sly-stickers-fetch) 168 | ;; (sly-sync-to-top-level 1) 169 | ;; (unless (sly-stickers--face-p 'sly-stickers-exited-non-locally-face) 170 | ;; (ert-fail "Expected QUXX sticker COISO to have exited non-locally")) 171 | )) 172 | 173 | (provide 'sly-stickers-tests) 174 | -------------------------------------------------------------------------------- /test/sly-autodoc-tests.el: -------------------------------------------------------------------------------- 1 | ;; -*- lexical-binding: t; -*- 2 | (require 'sly-autodoc "contrib/sly-autodoc") 3 | (require 'sly-tests "lib/sly-tests") 4 | (require 'cl-lib) 5 | 6 | (defun sly-autodoc-to-string () 7 | "Retrieve and return autodoc for form at point." 8 | (let ((autodoc (car (sly-eval 9 | `(slynk:autodoc 10 | ',(sly-autodoc--parse-context) 11 | :print-right-margin 12 | ,(window-width (minibuffer-window))))))) 13 | (if (eq autodoc :not-available) 14 | :not-available 15 | (sly-autodoc--canonicalize-whitespace autodoc)))) 16 | 17 | (defun sly-check-autodoc-at-point (arglist) 18 | (sly-test-expect (format "Autodoc in `%s' (at %d) is as expected" 19 | (buffer-string) (point)) 20 | arglist 21 | (sly-autodoc-to-string))) 22 | 23 | (defmacro define-autodoc-tests (&rest specs) 24 | `(progn 25 | ,@(cl-loop 26 | for (buffer-sexpr wished-arglist . options) 27 | in specs 28 | for fails-for = (plist-get options :fails-for) 29 | for skip-trailing-test-p = (plist-get options :skip-trailing-test-p) 30 | for i from 1 31 | when (featurep 'ert) 32 | collect `(define-sly-ert-test ,(intern (format "autodoc-tests-%d" i)) 33 | () 34 | ,(format "Check autodoc works ok for %s" buffer-sexpr) 35 | ,@(if fails-for 36 | `(:expected-result 37 | '(satisfies 38 | (lambda (result) 39 | (ert-test-result-type-p 40 | result 41 | (if (member (sly-lisp-implementation-name) 42 | ',fails-for) 43 | :failed 44 | :passed)))))) 45 | (sly-sync-to-top-level 0.3) 46 | (sly-check-top-level) 47 | (with-temp-buffer 48 | (setq sly-buffer-package "COMMON-LISP-USER") 49 | (lisp-mode) 50 | (insert ,buffer-sexpr) 51 | (search-backward "*HERE*") 52 | (delete-region (match-beginning 0) (match-end 0)) 53 | (should (equal ,wished-arglist 54 | (sly-autodoc-to-string))) 55 | (unless ,skip-trailing-test-p 56 | (insert ")") (backward-char) 57 | (should (equal ,wished-arglist 58 | (sly-autodoc-to-string))))) 59 | (sly-sync-to-top-level 0.3))))) 60 | 61 | (define-autodoc-tests 62 | ;; Test basics 63 | ("(slynk::emacs-connected*HERE*" "(emacs-connected)") 64 | ("(slynk::emacs-connected *HERE*" "(emacs-connected)") 65 | ("(slynk::create-socket*HERE*" 66 | "(create-socket host port &key backlog)") 67 | ("(slynk::create-socket *HERE*" 68 | "(create-socket ===> host <=== port &key backlog)") 69 | ("(slynk::create-socket foo *HERE*" 70 | "(create-socket host ===> port <=== &key backlog)") 71 | 72 | ;; Test that autodoc differentiates between exported and 73 | ;; unexported symbols. 74 | ("(slynk:create-socket*HERE*" :not-available) 75 | 76 | ;; Test if cursor is on non-existing required parameter 77 | ("(slynk::create-socket foo bar *HERE*" 78 | "(create-socket host port &key backlog)") 79 | 80 | ;; Test cursor in front of opening parenthesis 81 | ("(slynk::with-struct *HERE*(foo. x y) *struct* body1)" 82 | "(with-struct (conc-name &rest names) obj &body body)" 83 | :skip-trailing-test-p t) 84 | 85 | ;; Test variable content display 86 | ("(progn slynk::default-server-port*HERE*" 87 | "DEFAULT-SERVER-PORT => 4005") 88 | 89 | ;; Test that "variable content display" is not triggered for 90 | ;; trivial constants. 91 | ("(slynk::create-socket t*HERE*" 92 | "(create-socket ===> host <=== port &key backlog)") 93 | ("(slynk::create-socket :foo*HERE*" 94 | "(create-socket ===> host <=== port &key backlog)") 95 | 96 | ;; Test with syntactic sugar 97 | ("(lambda () (slynk::create-socket*HERE*" 98 | "(create-socket host port &key backlog)") 99 | ("`(lambda () ,(slynk::create-socket*HERE*" 100 | "(create-socket host port &key backlog)") 101 | ("(remove-if (lambda () (slynk::create-socket*HERE*" 102 | "(create-socket host port &key backlog)") 103 | ("`(remove-if (lambda () ,@(slynk::create-socket*HERE*" 104 | "(create-socket host port &key backlog)") 105 | 106 | ;; Test &optional 107 | ("(slynk::symbol-status foo *HERE*" 108 | "(symbol-status symbol &optional\ 109 | ===> (package (symbol-package symbol)) <===)" :fails-for ("allegro" "ccl")) 110 | 111 | ;; Test context-sensitive autodoc (DEFMETHOD) 112 | ("(defmethod slynk::arglist-dispatch (*HERE*" 113 | "(defmethod arglist-dispatch\ 114 | (===> operator <=== arguments) &body body)") 115 | ("(defmethod slynk::arglist-dispatch :before (*HERE*" 116 | "(defmethod arglist-dispatch :before\ 117 | (===> operator <=== arguments) &body body)") 118 | 119 | ;; Test context-sensitive autodoc (APPLY) 120 | ("(apply 'slynk::eval-for-emacs*HERE*" 121 | "(apply 'eval-for-emacs &optional form buffer-package id &rest args)") 122 | ("(apply #'slynk::eval-for-emacs*HERE*" 123 | "(apply #'eval-for-emacs &optional form buffer-package id &rest args)" :fails-for ("ccl")) 124 | ("(apply 'slynk::eval-for-emacs foo *HERE*" 125 | "(apply 'eval-for-emacs &optional form\ 126 | ===> buffer-package <=== id &rest args)") 127 | ("(apply #'slynk::eval-for-emacs foo *HERE*" 128 | "(apply #'eval-for-emacs &optional form\ 129 | ===> buffer-package <=== id &rest args)" :fails-for ("ccl")) 130 | 131 | ;; Test context-sensitive autodoc (ERROR, CERROR) 132 | ("(error 'simple-condition*HERE*" 133 | "(error 'simple-condition &rest arguments\ 134 | &key format-arguments format-control)" :fails-for ("ccl")) 135 | ("(cerror \"Foo\" 'simple-condition*HERE*" 136 | "(cerror \"Foo\" 'simple-condition\ 137 | &rest arguments &key format-arguments format-control)" 138 | :fails-for ("ccl")) 139 | 140 | ;; Test &KEY and nested arglists 141 | ("(slynk::with-retry-restart (:msg *HERE*" 142 | "(with-retry-restart (&key ===> (msg \"Retry.\") <===) &body body)" 143 | :fails-for ("allegro")) 144 | ("(slynk::with-retry-restart (:msg *HERE*(foo" 145 | "(with-retry-restart (&key ===> (msg \"Retry.\") <===) &body body)" 146 | :skip-trailing-test-p t 147 | :fails-for ("allegro")) 148 | ("(slynk::start-server \"/tmp/foo\" :dont-close *HERE*" 149 | "(start-server port-file &key (style slynk:*communication-style*)\ 150 | ===> (dont-close slynk:*dont-close*) <===)" 151 | :fails-for ("allegro" "ccl")) 152 | 153 | ;; Test declarations and type specifiers 154 | ("(declare (string *HERE*" 155 | "(declare (string &rest ===> variables <===))" 156 | :fails-for ("allegro") :fails-for ("ccl")) 157 | ("(declare ((string *HERE*" 158 | "(declare ((string &optional ===> size <===) &rest variables))") 159 | ("(declare (type (string *HERE*" 160 | "(declare (type (string &optional ===> size <===) &rest variables))") 161 | 162 | ;; Test local functions 163 | ("(flet ((foo (x y) (+ x y))) (foo *HERE*" "(foo ===> x <=== y)") 164 | ("(macrolet ((foo (x y) `(+ ,x ,y))) (foo *HERE*" "(foo ===> x <=== y)") 165 | ("(labels ((foo (x y) (+ x y))) (foo *HERE*" "(foo ===> x <=== y)") 166 | ("(labels ((foo (x y) (+ x y)) 167 | (bar (y) (foo *HERE*" 168 | "(foo ===> x <=== y)" :fails-for ("cmucl" "sbcl" "allegro" "ccl"))) 169 | 170 | (def-sly-test autodoc-space 171 | (input-keys expected-message) 172 | "Emulate the inserting something followed by the space key 173 | event and verify that the right thing appears in the echo 174 | area (after a short delay)." 175 | '(("( s l y n k : : o p e r a t o r - a r g l i s t SPC" 176 | "(operator-arglist name package)")) 177 | (when noninteractive 178 | (sly-skip-test "Can't use unread-command-events in batch mode")) 179 | (let* ((keys (eval `(kbd ,input-keys))) 180 | (tag (cons nil nil)) 181 | (timerfun (lambda (tag) (throw tag nil))) 182 | (timer (run-with-timer 1 nil timerfun tag))) 183 | (with-temp-buffer 184 | (lisp-mode) 185 | (unwind-protect 186 | (catch tag 187 | (message nil) 188 | (select-window (display-buffer (current-buffer) t)) 189 | (setq unread-command-events (listify-key-sequence keys)) 190 | (accept-process-output) 191 | (recursive-edit)) 192 | (setq unread-command-events nil) 193 | (cancel-timer timer)) 194 | (sly-test-expect "Message after SPC" 195 | expected-message (current-message)) 196 | (accept-process-output nil (* eldoc-idle-delay 2)) 197 | (sly-test-expect "Message after edloc delay" 198 | expected-message (current-message))))) 199 | 200 | (provide 'sly-autodoc-tests) 201 | -------------------------------------------------------------------------------- /contrib/sly-fontifying-fu.el: -------------------------------------------------------------------------------- 1 | ;; -*- lexical-binding: t; -*- 2 | (require 'sly) 3 | (require 'sly-parse "lib/sly-parse") 4 | (require 'font-lock) 5 | (require 'cl-lib) 6 | 7 | ;;; Fontify WITH-FOO, DO-FOO, and DEFINE-FOO like standard macros. 8 | ;;; Fontify CHECK-FOO like CHECK-TYPE. 9 | (defvar sly-additional-font-lock-keywords 10 | '(("(\\(\\(\\s_\\|\\w\\)*:\\(define-\\|do-\\|with-\\|without-\\)\\(\\s_\\|\\w\\)*\\)" 1 font-lock-keyword-face) 11 | ("(\\(\\(define-\\|do-\\|with-\\)\\(\\s_\\|\\w\\)*\\)" 1 font-lock-keyword-face) 12 | ("(\\(check-\\(\\s_\\|\\w\\)*\\)" 1 font-lock-warning-face) 13 | ("(\\(assert-\\(\\s_\\|\\w\\)*\\)" 1 font-lock-warning-face))) 14 | 15 | ;;;; Specially fontify forms suppressed by a reader conditional. 16 | (defcustom sly-highlight-suppressed-forms t 17 | "Display forms disabled by reader conditionals as comments." 18 | :type '(choice (const :tag "Enable" t) (const :tag "Disable" nil)) 19 | :group 'sly-mode) 20 | 21 | (define-sly-contrib sly-fontifying-fu 22 | "Additional fontification tweaks: 23 | Fontify WITH-FOO, DO-FOO, DEFINE-FOO like standard macros. 24 | Fontify CHECK-FOO like CHECK-TYPE." 25 | (:authors "Tobias C. Rittweiler ") 26 | (:license "GPL") 27 | (:on-load 28 | (font-lock-add-keywords 29 | 'lisp-mode sly-additional-font-lock-keywords) 30 | (when sly-highlight-suppressed-forms 31 | (sly-activate-font-lock-magic))) 32 | (:on-unload 33 | ;; FIXME: remove `sly-search-suppressed-forms', and remove the 34 | ;; extend-region hook. 35 | (font-lock-remove-keywords 36 | 'lisp-mode sly-additional-font-lock-keywords))) 37 | 38 | (defface sly-reader-conditional-face 39 | '((t (:inherit font-lock-comment-face))) 40 | "Face for compiler notes while selected." 41 | :group 'sly-mode-faces) 42 | 43 | (defvar sly-search-suppressed-forms-match-data (list nil nil)) 44 | 45 | (defun sly-search-suppressed-forms-internal (limit) 46 | (when (search-forward-regexp sly-reader-conditionals-regexp limit t) 47 | (let ((start (match-beginning 0)) ; save match data 48 | (state (sly-current-parser-state))) 49 | (if (or (nth 3 state) (nth 4 state)) ; inside string or comment? 50 | (sly-search-suppressed-forms-internal limit) 51 | (let* ((char (char-before)) 52 | (expr (read (current-buffer))) 53 | (val (sly-eval-feature-expression expr))) 54 | (when (<= (point) limit) 55 | (if (or (and (eq char ?+) (not val)) 56 | (and (eq char ?-) val)) 57 | ;; If `sly-extend-region-for-font-lock' did not 58 | ;; fully extend the region, the assertion below may 59 | ;; fail. This should only happen on XEmacs and older 60 | ;; versions of GNU Emacs. 61 | (ignore-errors 62 | (forward-sexp) (backward-sexp) 63 | ;; Try to suppress as far as possible. 64 | (sly-forward-sexp) 65 | (cl-assert (<= (point) limit)) 66 | (let ((md (match-data nil sly-search-suppressed-forms-match-data))) 67 | (setf (cl-first md) start) 68 | (setf (cl-second md) (point)) 69 | (set-match-data md) 70 | t)) 71 | (sly-search-suppressed-forms-internal limit)))))))) 72 | 73 | (defun sly-search-suppressed-forms (limit) 74 | "Find reader conditionalized forms where the test is false." 75 | (when (and sly-highlight-suppressed-forms 76 | (sly-connected-p)) 77 | (let ((result 'retry)) 78 | (while (and (eq result 'retry) (<= (point) limit)) 79 | (condition-case condition 80 | (setq result (sly-search-suppressed-forms-internal limit)) 81 | (end-of-file ; e.g. #+( 82 | (setq result nil)) 83 | ;; We found a reader conditional we couldn't process for 84 | ;; some reason; however, there may still be other reader 85 | ;; conditionals before `limit'. 86 | (invalid-read-syntax ; e.g. #+#.foo 87 | (setq result 'retry)) 88 | (scan-error ; e.g. #+nil (foo ... 89 | (setq result 'retry)) 90 | (sly-incorrect-feature-expression ; e.g. #+(not foo bar) 91 | (setq result 'retry)) 92 | (sly-unknown-feature-expression ; e.g. #+(foo) 93 | (setq result 'retry)) 94 | (error 95 | (setq result nil) 96 | (sly-warning 97 | (concat "Caught error during fontification while searching for forms\n" 98 | "that are suppressed by reader-conditionals. The error was: %S.") 99 | condition)))) 100 | result))) 101 | 102 | 103 | (defun sly-search-directly-preceding-reader-conditional () 104 | "Search for a directly preceding reader conditional. Return its 105 | position, or nil." 106 | ;; We search for a preceding reader conditional. Then we check that 107 | ;; between the reader conditional and the point where we started is 108 | ;; no other intervening sexp, and we check that the reader 109 | ;; conditional is at the same nesting level. 110 | (condition-case nil 111 | (let* ((orig-pt (point)) 112 | (reader-conditional-pt 113 | (search-backward-regexp sly-reader-conditionals-regexp 114 | ;; We restrict the search to the 115 | ;; beginning of the /previous/ defun. 116 | (save-excursion 117 | (beginning-of-defun) 118 | (point)) 119 | t))) 120 | (when reader-conditional-pt 121 | (let* ((parser-state 122 | (parse-partial-sexp 123 | (progn (goto-char (+ reader-conditional-pt 2)) 124 | (forward-sexp) ; skip feature expr. 125 | (point)) 126 | orig-pt)) 127 | (paren-depth (car parser-state)) 128 | (last-sexp-pt (cl-caddr parser-state))) 129 | (if (and paren-depth 130 | (not (cl-plusp paren-depth)) ; no '(' in between? 131 | (not last-sexp-pt)) ; no complete sexp in between? 132 | reader-conditional-pt 133 | nil)))) 134 | (scan-error nil))) ; improper feature expression 135 | 136 | 137 | ;;; We'll push this onto `font-lock-extend-region-functions'. In past, 138 | ;;; we didn't do so which made our reader-conditional font-lock magic 139 | ;;; pretty unreliable (it wouldn't highlight all suppressed forms, and 140 | ;;; worked quite non-deterministic in general.) 141 | ;;; 142 | ;;; Cf. _Elisp Manual_, 23.6.10 Multiline Font Lock Constructs. 143 | ;;; 144 | ;;; We make sure that `font-lock-beg' and `font-lock-end' always point 145 | ;;; to the beginning or end of a toplevel form. So we never miss a 146 | ;;; reader-conditional, or point in mid of one. 147 | (defvar font-lock-beg) ; shoosh compiler 148 | (defvar font-lock-end) 149 | 150 | (defun sly-extend-region-for-font-lock () 151 | (when sly-highlight-suppressed-forms 152 | (condition-case c 153 | (let (changedp) 154 | (cl-multiple-value-setq (changedp font-lock-beg font-lock-end) 155 | (sly-compute-region-for-font-lock font-lock-beg font-lock-end)) 156 | changedp) 157 | (error 158 | (sly-warning 159 | (concat "Caught error when trying to extend the region for fontification.\n" 160 | "The error was: %S\n" 161 | "Further: font-lock-beg=%d, font-lock-end=%d.") 162 | c font-lock-beg font-lock-end))))) 163 | 164 | (defsubst sly-beginning-of-tlf () 165 | (let ((pos (syntax-ppss-toplevel-pos (sly-current-parser-state)))) 166 | (if pos (goto-char pos)))) 167 | 168 | (defun sly-compute-region-for-font-lock (orig-beg orig-end) 169 | (let ((beg orig-beg) 170 | (end orig-end)) 171 | (goto-char beg) 172 | (sly-beginning-of-tlf) 173 | (cl-assert (not (cl-plusp (nth 0 (sly-current-parser-state))))) 174 | (setq beg (let ((pt (point))) 175 | (cond ((> (- beg pt) 20000) beg) 176 | ((sly-search-directly-preceding-reader-conditional)) 177 | (t pt)))) 178 | (goto-char end) 179 | (while (search-backward-regexp sly-reader-conditionals-regexp beg t) 180 | (setq end (max end (save-excursion 181 | (ignore-errors (sly-forward-reader-conditional)) 182 | (point))))) 183 | (cl-values (or (/= beg orig-beg) (/= end orig-end)) beg end))) 184 | 185 | 186 | (defun sly-activate-font-lock-magic () 187 | (font-lock-add-keywords 188 | 'lisp-mode 189 | `((sly-search-suppressed-forms 0 ,''sly-reader-conditional-face t))) 190 | 191 | (add-hook 'lisp-mode-hook 192 | (lambda () 193 | (add-hook 'font-lock-extend-region-functions 194 | 'sly-extend-region-for-font-lock t t)))) 195 | 196 | 197 | ;;; Compile hotspots 198 | ;;; 199 | (sly-byte-compile-hotspots 200 | '(sly-extend-region-for-font-lock 201 | sly-compute-region-for-font-lock 202 | sly-search-directly-preceding-reader-conditional 203 | sly-search-suppressed-forms 204 | sly-beginning-of-tlf)) 205 | 206 | (provide 'sly-fontifying-fu) 207 | -------------------------------------------------------------------------------- /slynk/slynk-match.lisp: -------------------------------------------------------------------------------- 1 | ;; 2 | ;; SELECT-MATCH macro (and IN macro) 3 | ;; 4 | ;; Copyright 1990 Stephen Adams 5 | ;; 6 | ;; You are free to copy, distribute and make derivative works of this 7 | ;; source provided that this copyright notice is displayed near the 8 | ;; beginning of the file. No liability is accepted for the 9 | ;; correctness or performance of the code. If you modify the code 10 | ;; please indicate this fact both at the place of modification and in 11 | ;; this copyright message. 12 | ;; 13 | ;; Stephen Adams 14 | ;; Department of Electronics and Computer Science 15 | ;; University of Southampton 16 | ;; SO9 5NH, UK 17 | ;; 18 | ;; sra@ecs.soton.ac.uk 19 | ;; 20 | 21 | ;; 22 | ;; Synopsis: 23 | ;; 24 | ;; (select-match expression 25 | ;; (pattern action+)*) 26 | ;; 27 | ;; --- or --- 28 | ;; 29 | ;; (select-match expression 30 | ;; pattern => expression 31 | ;; pattern => expression 32 | ;; ...) 33 | ;; 34 | ;; pattern -> constant ;egs 1, #\x, #c(1.0 1.1) 35 | ;; | symbol ;matches anything 36 | ;; | 'anything ;must be EQUAL 37 | ;; | (pattern = pattern) ;both patterns must match 38 | ;; | (#'function pattern) ;predicate test 39 | ;; | (pattern . pattern) ;cons cell 40 | ;; 41 | 42 | ;; Example 43 | ;; 44 | ;; (select-match item 45 | ;; (('if e1 e2 e3) 'if-then-else) ;(1) 46 | ;; ((#'oddp k) 'an-odd-integer) ;(2) 47 | ;; (((#'treep tree) = (hd . tl)) 'something-else) ;(3) 48 | ;; (other 'anything-else)) ;(4) 49 | ;; 50 | ;; Notes 51 | ;; 52 | ;; . Each pattern is tested in turn. The first match is taken. 53 | ;; 54 | ;; . If no pattern matches, an error is signalled. 55 | ;; 56 | ;; . Constant patterns (things X for which (CONSTANTP X) is true, i.e. 57 | ;; numbers, strings, characters, etc.) match things which are EQUAL. 58 | ;; 59 | ;; . Quoted patterns (which are CONSTANTP) are constants. 60 | ;; 61 | ;; . Symbols match anything. The symbol is bound to the matched item 62 | ;; for the execution of the actions. 63 | ;; For example, (SELECT-MATCH '(1 2 3) 64 | ;; (1 . X) => X) 65 | ;; returns (2 3) because X is bound to the cdr of the candidate. 66 | ;; 67 | ;; . The two pattern match (p1 = p2) can be used to name parts 68 | ;; of the matched structure. For example, (ALL = (HD . TL)) 69 | ;; matches a cons cell. ALL is bound to the cons cell, HD to its car 70 | ;; and TL to its tail. 71 | ;; 72 | ;; . A predicate test applies the predicate to the item being matched. 73 | ;; If the predicate returns NIL then the match fails. 74 | ;; If it returns truth, then the nested pattern is matched. This is 75 | ;; often just a symbol like K in the example. 76 | ;; 77 | ;; . Care should be taken with the domain values for predicate matches. 78 | ;; If, in the above eg, item is not an integer, an error would occur 79 | ;; during the test. A safer pattern would be 80 | ;; (#'integerp (#'oddp k)) 81 | ;; This would only test for oddness of the item was an integer. 82 | ;; 83 | ;; . A single symbol will match anything so it can be used as a default 84 | ;; case, like OTHER above. 85 | ;; 86 | 87 | (defpackage :slynk-match 88 | (:use :cl) 89 | (:export #:match)) 90 | 91 | (in-package :slynk-match) 92 | 93 | (defmacro match (expression &body patterns) 94 | `(select-match ,expression ,@patterns)) 95 | 96 | (defmacro select-match (expression &rest patterns) 97 | (let* ((do-let (not (atom expression))) 98 | (key (if do-let (gensym) expression)) 99 | (cbody (expand-select-patterns key patterns)) 100 | (cform `(cond . ,cbody))) 101 | (if do-let 102 | `(let ((,key ,expression)) ,cform) 103 | cform))) 104 | 105 | (defun expand-select-patterns (key patterns) 106 | (if (eq (second patterns) '=>) 107 | (expand-select-patterns-style-2 key patterns) 108 | (expand-select-patterns-style-1 key patterns))) 109 | 110 | (defun expand-select-patterns-style-1 (key patterns) 111 | (if (null patterns) 112 | `((t (error "Case select pattern match failure on ~S" ,key))) 113 | (let* ((pattern (caar patterns)) 114 | (actions (cdar patterns)) 115 | (rest (cdr patterns)) 116 | (test (compile-select-test key pattern)) 117 | (bindings (compile-select-bindings key pattern actions))) 118 | `(,(if bindings `(,test (let ,bindings . ,actions)) 119 | `(,test . ,actions)) 120 | . ,(unless (eq test t) 121 | (expand-select-patterns-style-1 key rest)))))) 122 | 123 | (defun expand-select-patterns-style-2 (key patterns) 124 | (cond ((null patterns) 125 | `((t (error "Case select pattern match failure on ~S" ,key)))) 126 | (t (when (or (< (length patterns) 3) 127 | (not (eq (second patterns) '=>))) 128 | (error "Illegal patterns: ~S" patterns)) 129 | (let* ((pattern (first patterns)) 130 | (actions (list (third patterns))) 131 | (rest (cdddr patterns)) 132 | (test (compile-select-test key pattern)) 133 | (bindings (compile-select-bindings key pattern actions))) 134 | `(,(if bindings `(,test (let ,bindings . ,actions)) 135 | `(,test . ,actions)) 136 | . ,(unless (eq test t) 137 | (expand-select-patterns-style-2 key rest))))))) 138 | 139 | (defun compile-select-test (key pattern) 140 | (let ((tests (remove t (compile-select-tests key pattern)))) 141 | (cond 142 | ;; note AND does this anyway, but this allows us to tell if 143 | ;; the pattern will always match. 144 | ((null tests) t) 145 | ((= (length tests) 1) (car tests)) 146 | (t `(and . ,tests))))) 147 | 148 | (defun compile-select-tests (key pattern) 149 | (cond ((constantp pattern) `((,(cond ((numberp pattern) 'eql) 150 | ((symbolp pattern) 'eq) 151 | (t 'equal)) 152 | ,key ,pattern))) 153 | ((symbolp pattern) '(t)) 154 | ((select-double-match? pattern) 155 | (append 156 | (compile-select-tests key (first pattern)) 157 | (compile-select-tests key (third pattern)))) 158 | ((select-predicate? pattern) 159 | (append 160 | `((,(second (first pattern)) ,key)) 161 | (compile-select-tests key (second pattern)))) 162 | ((consp pattern) 163 | (append 164 | `((consp ,key)) 165 | (compile-select-tests (cs-car key) (car 166 | pattern)) 167 | (compile-select-tests (cs-cdr key) (cdr 168 | pattern)))) 169 | (t (error "Illegal select pattern: ~S" pattern)))) 170 | 171 | 172 | (defun compile-select-bindings (key pattern action) 173 | (cond ((constantp pattern) '()) 174 | ((symbolp pattern) 175 | (if (select-in-tree pattern action) 176 | `((,pattern ,key)) 177 | '())) 178 | ((select-double-match? pattern) 179 | (append 180 | (compile-select-bindings key (first pattern) action) 181 | (compile-select-bindings key (third pattern) action))) 182 | ((select-predicate? pattern) 183 | (compile-select-bindings key (second pattern) action)) 184 | ((consp pattern) 185 | (append 186 | (compile-select-bindings (cs-car key) (car pattern) 187 | action) 188 | (compile-select-bindings (cs-cdr key) (cdr pattern) 189 | action))))) 190 | 191 | (defun select-in-tree (atom tree) 192 | (or (eq atom tree) 193 | (if (consp tree) 194 | (or (select-in-tree atom (car tree)) 195 | (select-in-tree atom (cdr tree)))))) 196 | 197 | (defun select-double-match? (pattern) 198 | ;; ( = ) 199 | (and (consp pattern) (consp (cdr pattern)) (consp (cddr pattern)) 200 | (null (cdddr pattern)) 201 | (eq (second pattern) '=))) 202 | 203 | (defun select-predicate? (pattern) 204 | ;; ((function ) ) 205 | (and (consp pattern) 206 | (consp (cdr pattern)) 207 | (null (cddr pattern)) 208 | (consp (first pattern)) 209 | (consp (cdr (first pattern))) 210 | (null (cddr (first pattern))) 211 | (eq (caar pattern) 'function))) 212 | 213 | (defun cs-car (exp) 214 | (cs-car/cdr 'car exp 215 | '((car . caar) (cdr . cadr) (caar . caaar) (cadr . caadr) 216 | (cdar . cadar) (cddr . caddr) 217 | (caaar . caaaar) (caadr . caaadr) (cadar . caadar) 218 | (caddr . caaddr) (cdaar . cadaar) (cdadr . cadadr) 219 | (cddar . caddar) (cdddr . cadddr)))) 220 | 221 | (defun cs-cdr (exp) 222 | (cs-car/cdr 'cdr exp 223 | '((car . cdar) (cdr . cddr) (caar . cdaar) (cadr . cdadr) 224 | (cdar . cddar) (cddr . cdddr) 225 | (caaar . cdaaar) (caadr . cdaadr) (cadar . cdadar) 226 | (caddr . cdaddr) (cdaar . cddaar) (cdadr . cddadr) 227 | (cddar . cdddar) (cdddr . cddddr)))) 228 | 229 | (defun cs-car/cdr (op exp table) 230 | (if (and (consp exp) (= (length exp) 2)) 231 | (let ((replacement (assoc (car exp) table))) 232 | (if replacement 233 | `(,(cdr replacement) ,(second exp)) 234 | `(,op ,exp))) 235 | `(,op ,exp))) 236 | 237 | ;; (setf c1 '(select-match x (a 1) (b 2 3 4))) 238 | ;; (setf c2 '(select-match (car y) 239 | ;; (1 (print 100) 101) (2 200) ("hello" 5) (:x 20) (else (1+ 240 | ;; else)))) 241 | ;; (setf c3 '(select-match (caddr y) 242 | ;; ((all = (x y)) (list x y all)) 243 | ;; ((a '= b) (list 'assign a b)) 244 | ;; ((#'oddp k) (1+ k))))) 245 | -------------------------------------------------------------------------------- /slynk/slynk-source-path-parser.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Source-paths 2 | 3 | ;;; CMUCL/SBCL use a data structure called "source-path" to locate 4 | ;;; subforms. The compiler assigns a source-path to each form in a 5 | ;;; compilation unit. Compiler notes usually contain the source-path 6 | ;;; of the error location. 7 | ;;; 8 | ;;; Compiled code objects don't contain source paths, only the 9 | ;;; "toplevel-form-number" and the (sub-) "form-number". To get from 10 | ;;; the form-number to the source-path we need the entire toplevel-form 11 | ;;; (i.e. we have to read the source code). CMUCL has already some 12 | ;;; utilities to do this translation, but we use some extended 13 | ;;; versions, because we need more exact position info. Apparently 14 | ;;; Hemlock is happy with the position of the toplevel-form; we also 15 | ;;; need the position of subforms. 16 | ;;; 17 | ;;; We use a special readtable to get the positions of the subforms. 18 | ;;; The readtable stores the start and end position for each subform in 19 | ;;; hashtable for later retrieval. 20 | ;;; 21 | ;;; This code has been placed in the Public Domain. All warranties 22 | ;;; are disclaimed. 23 | 24 | ;;; Taken from slynk-cmucl.lisp, by Helmut Eller 25 | 26 | (defpackage slynk-source-path-parser 27 | (:use cl) 28 | (:export 29 | read-source-form 30 | source-path-string-position 31 | source-path-file-position 32 | source-path-source-position 33 | 34 | sexp-in-bounds-p 35 | sexp-ref) 36 | (:shadow ignore-errors)) 37 | 38 | (in-package slynk-source-path-parser) 39 | 40 | ;; Some test to ensure the required conformance 41 | (let ((rt (copy-readtable nil))) 42 | (assert (or (not (get-macro-character #\space rt)) 43 | (nth-value 1 (get-macro-character #\space rt)))) 44 | (assert (not (get-macro-character #\\ rt)))) 45 | 46 | (eval-when (:compile-toplevel) 47 | (defmacro ignore-errors (&rest forms) 48 | ;;`(progn . ,forms) ; for debugging 49 | `(cl:ignore-errors . ,forms))) 50 | 51 | (defun make-sharpdot-reader (orig-sharpdot-reader) 52 | (lambda (s c n) 53 | ;; We want things like M-. to work regardless of any #.-fu in 54 | ;; the source file that is to be visited. (For instance, when a 55 | ;; file contains #. forms referencing constants that do not 56 | ;; currently exist in the image.) 57 | (ignore-errors (funcall orig-sharpdot-reader s c n)))) 58 | 59 | (defun make-source-recorder (fn source-map) 60 | "Return a macro character function that does the same as FN, but 61 | additionally stores the result together with the stream positions 62 | before and after of calling FN in the hashtable SOURCE-MAP." 63 | (lambda (stream char) 64 | (let ((start (1- (file-position stream))) 65 | (values (multiple-value-list (funcall fn stream char))) 66 | (end (file-position stream))) 67 | #+(or) 68 | (format t "[~D \"~{~A~^, ~}\" ~D ~D ~S]~%" 69 | start values end (char-code char) char) 70 | (when values 71 | (destructuring-bind (&optional existing-start &rest existing-end) 72 | (car (gethash (car values) source-map)) 73 | ;; Some macros may return what a sub-call to another macro 74 | ;; produced, e.g. "#+(and) (a)" may end up saving (a) twice, 75 | ;; once from #\# and once from #\(. If the saved form 76 | ;; is a subform, don't save it again. 77 | (unless (and existing-start existing-end 78 | (<= start existing-start end) 79 | (<= start existing-end end)) 80 | (push (cons start end) (gethash (car values) source-map))))) 81 | (values-list values)))) 82 | 83 | (defun make-source-recording-readtable (readtable source-map) 84 | (declare (type readtable readtable) (type hash-table source-map)) 85 | "Return a source position recording copy of READTABLE. 86 | The source locations are stored in SOURCE-MAP." 87 | (flet ((install-special-sharpdot-reader (rt) 88 | (let ((fun (ignore-errors 89 | (get-dispatch-macro-character #\# #\. rt)))) 90 | (when fun 91 | (let ((wrapper (make-sharpdot-reader fun))) 92 | (set-dispatch-macro-character #\# #\. wrapper rt))))) 93 | (install-wrappers (rt) 94 | (dotimes (code 128) 95 | (let ((char (code-char code))) 96 | (multiple-value-bind (fun nt) (get-macro-character char rt) 97 | (when fun 98 | (let ((wrapper (make-source-recorder fun source-map))) 99 | (set-macro-character char wrapper nt rt)))))))) 100 | (let ((rt (copy-readtable readtable))) 101 | (install-special-sharpdot-reader rt) 102 | (install-wrappers rt) 103 | rt))) 104 | 105 | ;; FIXME: try to do this with *READ-SUPPRESS* = t to avoid interning. 106 | ;; Should be possible as we only need the right "list structure" and 107 | ;; not the right atoms. 108 | (defun read-and-record-source-map (stream) 109 | "Read the next object from STREAM. 110 | Return the object together with a hashtable that maps 111 | subexpressions of the object to stream positions." 112 | (let* ((source-map (make-hash-table :test #'eq)) 113 | (*readtable* (make-source-recording-readtable *readtable* source-map)) 114 | (*read-suppress* nil) 115 | (start (file-position stream)) 116 | (form (ignore-errors (read stream))) 117 | (end (file-position stream))) 118 | ;; ensure that at least FORM is in the source-map 119 | (unless (gethash form source-map) 120 | (push (cons start end) (gethash form source-map))) 121 | (values form source-map))) 122 | 123 | (defun starts-with-p (string prefix) 124 | (declare (type string string prefix)) 125 | (not (mismatch string prefix 126 | :end1 (min (length string) (length prefix)) 127 | :test #'char-equal))) 128 | 129 | (defun extract-package (line) 130 | (declare (type string line)) 131 | (let ((name (cadr (read-from-string line)))) 132 | (find-package name))) 133 | 134 | #+(or) 135 | (progn 136 | (assert (extract-package "(in-package cl)")) 137 | (assert (extract-package "(cl:in-package cl)")) 138 | (assert (extract-package "(in-package \"CL\")")) 139 | (assert (extract-package "(in-package #:cl)"))) 140 | 141 | ;; FIXME: do something cleaner than this. 142 | (defun readtable-for-package (package) 143 | ;; KLUDGE: due to the load order we can't reference the slynk 144 | ;; package. 145 | (funcall (slynk-backend:find-symbol2 "slynk::guess-buffer-readtable") 146 | (string-upcase (package-name package)))) 147 | 148 | ;; Search STREAM for a "(in-package ...)" form. Use that to derive 149 | ;; the values for *PACKAGE* and *READTABLE*. 150 | ;; 151 | ;; IDEA: move GUESS-READER-STATE to slynk.lisp so that all backends 152 | ;; use the same heuristic and to avoid the need to access 153 | ;; slynk::guess-buffer-readtable from here. 154 | (defun guess-reader-state (stream) 155 | (let* ((point (file-position stream)) 156 | (pkg *package*)) 157 | (file-position stream 0) 158 | (loop for read-line = (read-line stream nil nil) 159 | for line = (and read-line 160 | (string-trim '(#\Space #\Tab #\Linefeed #\Page #\Return #\Rubout) 161 | read-line)) 162 | do 163 | (when (not line) (return)) 164 | (when (or (starts-with-p line "(in-package ") 165 | (starts-with-p line "(cl:in-package ")) 166 | (let ((p (extract-package line))) 167 | (when p (setf pkg p))) 168 | (return))) 169 | (file-position stream point) 170 | (values (readtable-for-package pkg) pkg))) 171 | 172 | (defun skip-whitespace (stream) 173 | (peek-char t stream nil nil)) 174 | 175 | ;; Skip over N toplevel forms. 176 | (defun skip-toplevel-forms (n stream) 177 | (let ((*read-suppress* t)) 178 | (dotimes (i n) 179 | (read stream)) 180 | (skip-whitespace stream))) 181 | 182 | (defun read-source-form (n stream) 183 | "Read the Nth toplevel form number with source location recording. 184 | Return the form and the source-map." 185 | (multiple-value-bind (*readtable* *package*) (guess-reader-state stream) 186 | (let (#+sbcl 187 | (*features* (append *features* 188 | (symbol-value (find-symbol "+INTERNAL-FEATURES+" 'sb-impl))))) 189 | (skip-toplevel-forms n stream) 190 | (read-and-record-source-map stream)))) 191 | 192 | (defun source-path-stream-position (path stream) 193 | "Search the source-path PATH in STREAM and return its position." 194 | (check-source-path path) 195 | (destructuring-bind (tlf-number . path) path 196 | (multiple-value-bind (form source-map) (read-source-form tlf-number stream) 197 | (source-path-source-position (cons 0 path) form source-map)))) 198 | 199 | (defun check-source-path (path) 200 | (unless (and (consp path) 201 | (every #'integerp path)) 202 | (error "The source-path ~S is not valid." path))) 203 | 204 | (defun source-path-string-position (path string) 205 | (with-input-from-string (s string) 206 | (source-path-stream-position path s))) 207 | 208 | (defun source-path-file-position (path filename) 209 | ;; We go this long way round, and don't directly operate on the file 210 | ;; stream because FILE-POSITION (used above) is not totally savy even 211 | ;; on file character streams; on SBCL, FILE-POSITION returns the binary 212 | ;; offset, and not the character offset---screwing up on Unicode. 213 | (let ((toplevel-number (first path)) 214 | (buffer)) 215 | (with-open-file (file filename) 216 | (skip-toplevel-forms (1+ toplevel-number) file) 217 | (let ((endpos (file-position file))) 218 | (setq buffer (make-array (list endpos) :element-type 'character 219 | :initial-element #\Space)) 220 | (assert (file-position file 0)) 221 | (read-sequence buffer file :end endpos))) 222 | (source-path-string-position path buffer))) 223 | 224 | (defgeneric sexp-in-bounds-p (sexp i) 225 | (:method ((list list) i) 226 | (< i (loop for e on list 227 | count t))) 228 | (:method ((sexp t) i) nil)) 229 | 230 | (defgeneric sexp-ref (sexp i) 231 | (:method ((s list) i) (elt s i))) 232 | 233 | (defun source-path-source-position (path form source-map) 234 | "Return the start position of PATH from FORM and SOURCE-MAP. All 235 | subforms along the path are considered and the start and end position 236 | of the deepest (i.e. smallest) possible form is returned." 237 | ;; compute all subforms along path 238 | (let ((forms (loop for i in path 239 | for f = form then (if (sexp-in-bounds-p f i) 240 | (sexp-ref f i)) 241 | collect f))) 242 | ;; select the first subform present in source-map 243 | (loop for form in (nreverse forms) 244 | for ((start . end) . rest) = (gethash form source-map) 245 | when (and start end (not rest)) 246 | return (return (values start end))))) 247 | -------------------------------------------------------------------------------- /contrib/slynk-trace-dialog.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :slynk-trace-dialog 2 | (:use :cl :slynk-api) 3 | (:export #:clear-trace-tree 4 | #:dialog-toggle-trace 5 | #:dialog-trace 6 | #:dialog-traced-p 7 | #:dialog-untrace 8 | #:dialog-untrace-all 9 | #:inspect-trace-part 10 | #:report-partial-tree 11 | #:report-specs 12 | #:report-total 13 | #:report-specs 14 | #:trace-format 15 | #:still-inside 16 | #:exited-non-locally 17 | #:*record-backtrace* 18 | #:*traces-per-report* 19 | #:*dialog-trace-follows-trace* 20 | #:instrument 21 | 22 | #:pprint-trace-part 23 | #:describe-trace-part 24 | #:trace-part-or-lose 25 | #:inspect-trace 26 | #:trace-or-lose 27 | #:trace-arguments-or-lose 28 | #:trace-location)) 29 | 30 | (in-package :slynk-trace-dialog) 31 | 32 | (defparameter *record-backtrace* nil 33 | "Record a backtrace of the last 20 calls for each trace. 34 | 35 | Beware that this may have a drastic performance impact on your 36 | program.") 37 | 38 | (defparameter *traces-per-report* 150 39 | "Number of traces to report to emacs in each batch.") 40 | 41 | (defparameter *dialog-trace-follows-trace* nil) 42 | 43 | (defvar *traced-specs* '()) 44 | 45 | (defparameter *visitor-idx* 0) 46 | 47 | (defparameter *visitor-key* nil) 48 | 49 | (defvar *unfinished-traces* '()) 50 | 51 | 52 | ;;;; `trace-entry' model 53 | ;;;; 54 | (defvar *traces* (make-array 1000 :fill-pointer 0 55 | :adjustable t)) 56 | 57 | (defvar *trace-lock* (slynk-backend:make-lock :name "slynk-trace-dialog lock")) 58 | 59 | (defvar *current-trace-by-thread* (make-hash-table)) 60 | 61 | (defclass trace-entry () 62 | ((id :reader id-of) 63 | (children :accessor children-of :initform nil) 64 | (backtrace :accessor backtrace-of :initform (when *record-backtrace* 65 | (useful-backtrace))) 66 | 67 | (spec :initarg :spec :accessor spec-of 68 | :initform (error "must provide a spec")) 69 | (function :initarg :function :accessor function-of) 70 | (args :initarg :args :reader args-of 71 | :initform (error "must provide args")) 72 | (printed-args) 73 | (parent :initarg :parent :reader parent-of 74 | :initform (error "must provide a parent, even if nil")) 75 | (retlist :initarg :retlist :accessor retlist-of 76 | :initform 'still-inside) 77 | (printed-retlist :initform ":STILL-INSIDE"))) 78 | 79 | (defmethod initialize-instance :after ((entry trace-entry) &key) 80 | (with-slots (parent id printed-args args) entry 81 | (if parent 82 | (nconc (children-of parent) (list entry))) 83 | (setf printed-args 84 | (mapcar (lambda (arg) 85 | (present-for-emacs arg #'slynk-pprint-to-line)) 86 | args)) 87 | (slynk-backend:call-with-lock-held 88 | *trace-lock* 89 | (lambda () 90 | (setf (slot-value entry 'id) (fill-pointer *traces*)) 91 | (vector-push-extend entry *traces*))))) 92 | 93 | (defmethod print-object ((entry trace-entry) stream) 94 | (print-unreadable-object (entry stream) 95 | (format stream "~a=~a" (id-of entry) (spec-of entry)))) 96 | 97 | (defun completed-p (trace) (not (eq (retlist-of trace) 'still-inside))) 98 | 99 | (defun trace-arguments (trace-id) 100 | (values-list (args-of (trace-or-lose trace-id)))) 101 | 102 | (defun useful-backtrace () 103 | (slynk-backend:call-with-debugging-environment 104 | (lambda () 105 | (loop for i from 0 106 | for frame in (slynk-backend:compute-backtrace 0 20) 107 | collect (list i (slynk::frame-to-string frame)))))) 108 | 109 | (defun current-trace () 110 | (gethash (slynk-backend:current-thread) *current-trace-by-thread*)) 111 | 112 | (defun (setf current-trace) (trace) 113 | (setf (gethash (slynk-backend:current-thread) *current-trace-by-thread*) 114 | trace)) 115 | 116 | 117 | ;;;; Helpers 118 | ;;;; 119 | (defun describe-trace-for-emacs (trace) 120 | (with-slots (id args parent spec printed-args retlist printed-retlist) trace 121 | `(,id 122 | ,(and parent (id-of parent)) 123 | ,(cons (string-downcase (present-for-emacs spec)) spec) 124 | ,(loop for arg in args 125 | for printed-arg in printed-args 126 | for i from 0 127 | collect (list i printed-arg)) 128 | ,(loop for retval in (slynk::ensure-list retlist) 129 | for printed-retval in (slynk::ensure-list printed-retlist) 130 | for i from 0 131 | collect (list i printed-retval))))) 132 | 133 | 134 | ;;;; slyfuns 135 | ;;;; 136 | (defslyfun trace-format (format-spec &rest format-args) 137 | "Make a string from FORMAT-SPEC and FORMAT-ARGS and as a trace." 138 | (let* ((line (apply #'format nil format-spec format-args))) 139 | (make-instance 'trace-entry :spec line 140 | :args format-args 141 | :parent (current-trace) 142 | :retlist nil))) 143 | 144 | (defslyfun trace-or-lose (id) 145 | (when (<= 0 id (1- (length *traces*))) 146 | (or (aref *traces* id) 147 | (error "No trace with id ~a" id)))) 148 | 149 | (defslyfun report-partial-tree (key) 150 | (unless (equal key *visitor-key*) 151 | (setq *visitor-idx* 0 152 | *visitor-key* key)) 153 | (let* ((recently-finished 154 | (loop with i = 0 155 | for trace in *unfinished-traces* 156 | while (< i *traces-per-report*) 157 | when (completed-p trace) 158 | collect trace 159 | and do 160 | (incf i) 161 | (setq *unfinished-traces* 162 | (remove trace *unfinished-traces*)))) 163 | (new (loop for i 164 | from (length recently-finished) 165 | below *traces-per-report* 166 | while (< *visitor-idx* (length *traces*)) 167 | for trace = (aref *traces* *visitor-idx*) 168 | collect trace 169 | unless (completed-p trace) 170 | do (push trace *unfinished-traces*) 171 | do (incf *visitor-idx*)))) 172 | (list 173 | (mapcar #'describe-trace-for-emacs 174 | (append recently-finished new)) 175 | (- (length *traces*) *visitor-idx*) 176 | key))) 177 | 178 | (defslyfun report-specs () 179 | (mapcar (lambda (spec) 180 | (cons (string-downcase (present-for-emacs spec)) 181 | spec)) 182 | (sort (copy-list *traced-specs*) 183 | #'string< 184 | :key #'princ-to-string))) 185 | 186 | (defslyfun report-total () 187 | (length *traces*)) 188 | 189 | (defslyfun clear-trace-tree () 190 | (setf *current-trace-by-thread* (clrhash *current-trace-by-thread*) 191 | *visitor-key* nil 192 | *unfinished-traces* nil) 193 | (slynk-backend:call-with-lock-held 194 | *trace-lock* 195 | (lambda () (setf (fill-pointer *traces*) 0))) 196 | nil) 197 | 198 | (defslyfun trace-part-or-lose (id part-id type) 199 | (let* ((trace (trace-or-lose id)) 200 | (l (ecase type 201 | (:arg (args-of trace)) 202 | (:retval (slynk::ensure-list (retlist-of trace)))))) 203 | (or (nth part-id l) 204 | (error "Cannot find a trace part with id ~a and part-id ~a" 205 | id part-id)))) 206 | 207 | (defslyfun trace-arguments-or-lose (trace-id) 208 | (values-list (args-of (trace-or-lose trace-id)))) 209 | 210 | (defslyfun inspect-trace-part (trace-id part-id type) 211 | (slynk::inspect-object 212 | (trace-part-or-lose trace-id part-id type))) 213 | 214 | (defslyfun pprint-trace-part (trace-id part-id type) 215 | (slynk::slynk-pprint (list (trace-part-or-lose trace-id part-id type)))) 216 | 217 | (defslyfun describe-trace-part (trace-id part-id type) 218 | (slynk::describe-to-string (trace-part-or-lose trace-id part-id type))) 219 | 220 | (defslyfun inspect-trace (trace-id) 221 | (slynk::inspect-object (trace-or-lose trace-id))) 222 | 223 | (defslyfun trace-location (trace-id) 224 | (slynk-backend:find-source-location (function-of (trace-or-lose trace-id)))) 225 | 226 | (defslyfun dialog-trace (spec) 227 | (let ((function nil)) 228 | (flet ((before-hook (args) 229 | (setf (current-trace) (make-instance 'trace-entry 230 | :spec spec 231 | :function (or function 232 | spec) 233 | :args args 234 | :parent (current-trace)))) 235 | (after-hook (returned-values) 236 | (let ((trace (current-trace))) 237 | (when trace 238 | (with-slots (retlist parent printed-retlist) trace 239 | ;; the current trace might have been wiped away if the 240 | ;; user cleared the tree in the meantime. no biggie, 241 | ;; don't do anything. 242 | ;; 243 | (setf retlist returned-values 244 | printed-retlist 245 | (mapcar (lambda (obj) 246 | (present-for-emacs obj #'slynk-pprint-to-line)) 247 | (slynk::ensure-list retlist)) 248 | (current-trace) parent)))))) 249 | (when (dialog-traced-p spec) 250 | (warn "~a is apparently already traced! Untracing and retracing." spec) 251 | (dialog-untrace spec)) 252 | (setq function 253 | (slynk-backend:wrap spec 'trace-dialog 254 | :before #'before-hook 255 | :after #'after-hook)) 256 | (pushnew spec *traced-specs*) 257 | (format nil "~a is now traced for trace dialog" spec)))) 258 | 259 | (defslyfun dialog-untrace (spec) 260 | (with-simple-restart 261 | (continue "Never mind, i really want this trace to go away") 262 | (slynk-backend:unwrap spec 'trace-dialog)) 263 | (setq *traced-specs* (remove spec *traced-specs* :test #'equal)) 264 | (format nil "~a is now untraced for trace dialog" spec)) 265 | 266 | (defslyfun dialog-toggle-trace (spec) 267 | (if (dialog-traced-p spec) 268 | (dialog-untrace spec) 269 | (dialog-trace spec))) 270 | 271 | (defslyfun dialog-traced-p (spec) 272 | (find spec *traced-specs* :test #'equal)) 273 | 274 | (defslyfun dialog-untrace-all () 275 | (let ((regular (length (trace))) 276 | (dialog (length *traced-specs*))) 277 | (untrace) 278 | (mapcar #'dialog-untrace *traced-specs*) 279 | (cons regular dialog))) 280 | 281 | 282 | 283 | 284 | ;;;; Hook onto emacs 285 | ;;;; 286 | (setq slynk:*after-toggle-trace-hook* 287 | (lambda (spec traced-p) 288 | (when *dialog-trace-follows-trace* 289 | (cond (traced-p 290 | (dialog-trace spec) 291 | "traced for trace dialog as well") 292 | (t 293 | (dialog-untrace spec) 294 | "untraced for the trace dialog as well"))))) 295 | 296 | 297 | ;;;; Instrumentation 298 | ;;;; 299 | (defmacro instrument (x &optional (id (gensym "EXPLICIT-INSTRUMENT-")) ) 300 | (let ((values-sym (gensym))) 301 | `(let ((,values-sym (multiple-value-list ,x))) 302 | (trace-format (format nil "~a: ~a" ',id "~a => ~{~a~^, ~}") ',x 303 | ,values-sym) 304 | (values-list ,values-sym)))) 305 | 306 | (provide :slynk/trace-dialog) 307 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | # The SLY Hacker's Handbook 2 | 3 | ## Reporting bugs 4 | 5 | The most important thing when reporting bugs is making sure that the 6 | developer has a way to reproduce it. To do this, he needs to rule out 7 | interference from external factors like other Emacs extensions or 8 | other Lisp-side code. Here's a great example of a bug report 9 | 10 | ``` 11 | $ emacs --version 12 | Emacs 24.3 13 | $ sbcl --version 14 | SBCL 1.2.1 15 | $ cd sly 16 | sly $ emacs -Q -L . -l sly-autoloads --eval '(setq inferior-lisp-program "sbcl")' -f sly 17 | 18 | I get the REPL but when I try to X, I get Y 19 | OR 20 | I don't get the REPL at all because frankinbogen! 21 | ``` 22 | 23 | 24 | ## Coding style 25 | 26 | This section is very empty, in the meantime try to be sensible and 27 | emulate or improve on SLY's existing style. 28 | 29 | ### Commit messages 30 | 31 | ChangeLog files are gone! However, the syntax of ChangeLogs is very 32 | useful to everybody and Emacs supports it perfectly: 33 | 34 | * in Emacs, for every snippet that you've changed, type `C-x 4 a` (or 35 | `add-change-log-entry-other-window`) 36 | 37 | * Emacs will open up a ChangeLog buffer, but this is just a dummy 38 | buffer that you can ignore. However, the content inside it should be 39 | pasted (sans indentation) to the commit message. 40 | 41 | * As an added bonus, if you are using Emacs >= 24.4 and `vc-dir` to 42 | prepare your commits, Emacs does that for you automatically. 43 | 44 | The benefits of this format are great. One can still use `M-x 45 | vc-print-log` in a source file and browse through its ChangeLog 46 | without the hassle of ChangeLog conflicts. 47 | 48 | ### General philosophy 49 | 50 | I keep a sentence of the previous Coding Guide that I like very much. 51 | 52 | > Remember that to rewrite a program better is the sincerest form of 53 | > code appreciation. When you can see a way to rewrite a part of SLY 54 | > better, please do so! 55 | 56 | 57 | ## Lisp code file structure 58 | 59 | The code is organized into these files: 60 | 61 | * `slynk/slynk-backend.lisp`: Definition of the interface to non-portable 62 | features. Stand-alone. 63 | 64 | * `slynk/backend/slynk-.lisp`: Back-end implementation 65 | for a specific Common Lisp system. Uses slynk-backend.lisp. 66 | 67 | * `slynk/slynk.lisp`: The top-level server program, built from the other 68 | components. Uses `slynk-backend.lisp` as an interface to the actual 69 | backends. 70 | 71 | * `sly.el`: The Emacs front-end that the user actually interacts 72 | with and that connects to the Slynk server to send expressions to, and 73 | retrieve information from the running Common Lisp system. 74 | 75 | * `contrib/sly-.el`: Elisp code for SLY extensions. 76 | 77 | * `contrib/slynk-.lisp`: Supporting Common Lisp related 78 | code for a particular extension. 79 | 80 | 81 | ## SLY-Slynk RPC protocol 82 | 83 | The info in this section would be something for a future "Slynk 84 | Programmer's Guide" to be included in the regular manual or a separate 85 | one. 86 | 87 | Follows a brief description of the SLY-Slynk protocol. The protocol is 88 | *s-exp messages* over *s-exp primitives* over *UTF-8* over *TCP*. 89 | Let's start top-down: 90 | 91 | ### S-exp messages 92 | 93 | Most messages in the top group look like Lisp function calls. The 94 | functions are known as "Slyfuns" and are defined with a `DEFSLYFUN` 95 | operator in the `slynk-*.lisp` side. These are the "remote procedures" 96 | of the RPC protocol. There must be about 100 or so of them, maybe 97 | more, I haven't counted. Slyfuns appear in both Slynk's core and in 98 | supporting contrib's Slynk code. 99 | 100 | For a future reference manual, I think there has to be a way to 101 | automatically harvest the `DEFSLYFUN` definitions and their 102 | docstrings. 103 | 104 | Another type of message contains calls to "channel methods". These are 105 | slightly different from Slyfuns. Their return value is ignored, but 106 | otherwise they also work like function calls. They're good for 107 | expressing a reply-free evaluation in the context of a "channel". 108 | 109 | These are defined with `sly-define-channel-method` and 110 | `DEFINE-CHANNEL-METHOD` and on the SLY and Slynk sides, respectively. 111 | 112 | The only use right now is in `sly-mrepl.el`, 113 | 114 | ### S-exp primitives 115 | 116 | This is a much smaller set of primitives, the most common is 117 | `:EMACS-REX`, "rex" is for "Remote EXecution". 118 | 119 | Informally it's saying: "here is Slyfun X's call number 3487 with 120 | argumentss Y, for evaluation in thread Z" ). The asynchronous reply 121 | `:RETURN`, if it ever arrives, will be "your call 3487 returned the 122 | following sexp". 123 | 124 | ```lisp 125 | (:emacs-rex 126 | (slynk:connection-info) 127 | nil t 1) 128 | (:return 129 | (:ok 130 | (:pid 16576 :style :spawn :encoding 131 | :lisp-implementation 132 | (:type "International Allegro CL Enterprise Edition" :name "allegro" :version "8.1 [Windows] (Sep 3, 2008 19:38)" :program nil) 133 | :package 134 | (:name "COMMON-LISP-USER" :prompt "CL-USER") 135 | :version "1.0.0-alpha")) 136 | 1) 137 | ``` 138 | 139 | The return value, read into Elisp sexps is what is passed to the 140 | callback argument to the Elisp function `sly-eval-async`. Here's the 141 | way to get the PID of the underlying Slynk process. 142 | 143 | ```elisp 144 | (sly-eval-async '(slynk:connection-info) 145 | (lambda (info) (plist-get info :pid))) 146 | ``` 147 | 148 | The primitives `:CHANNEL-SEND` and `:EMACS-CHANNEL-SEND` implement 149 | channel methods. Channels are named by number, and normally have a 150 | special serving thread in the Common Lisp implementation of 151 | Slynk. Here is an extract showing the `:PROCESS`, `:WRITE-VALUES` and 152 | `:PROMPT` channel methods for the REPL. 153 | 154 | ```lisp 155 | (:emacs-channel-send 1 156 | (:process "(list 1 2 3)")) 157 | (:channel-send 1 158 | (:write-values 159 | (("(1 2 3)" 2)))) 160 | (:channel-send 1 161 | (:prompt "COMMON-LISP-USER" "CL-USER" 0)) 162 | ``` 163 | 164 | There are also debugger-specific primitives, like `:DEBUG-ACTIVATE` 165 | and `:DEBUG-RETURN`. Then there are indentation-specific primitives 166 | like `:INDENTATION-UPDATE`. These could/should become 167 | `:EMACS-CHANNEL-SEND`s in the future (but that would probably finally 168 | break Swank compatibility). 169 | 170 | ### UTF-8 and TCP 171 | 172 | UTF-8 is relevant because the information in the wire are text-encoded 173 | sexp's that sometimes carry strings with chunks of code, for example, 174 | and these can have funky characters. 175 | 176 | TCP is well TCP, a host and a port and reliable transfer make SLY work 177 | well over any IP network. 178 | 179 | ### Common Lisp bias 180 | 181 | *Note: This section is very incomplete* 182 | 183 | SLY has is primarily a Common-Lisp IDE and the supporting Slynk have 184 | strong Common-lisp bias. There have been many attempts, some quite 185 | successful at creating Slynk backends for other languages. 186 | 187 | I believe that some of the Slyfuns will always be Common-Lisp specific 188 | and should be marked as such. Others can perhaps be more naturally 189 | adapted to other languages. 190 | 191 | It's very important that a future reference manual have this in 192 | consideration: remove the CL bias from the protocol's description, at 193 | least from some of its layers, so that things like 194 | [swank-js](https://github.com/swank-js/swank-js) can one day be more 195 | easily implemented. 196 | 197 | 198 | ## Architecture changes from SLIME to SLY 199 | 200 | As of time of writing (SLY 1.0, SLIME 2.9) the following list 201 | summarizes the main architecture differences between SLY and SLIME. If 202 | it's not mentioned here, it's a safe bet that some particular 203 | mechanism you're interested in stayed the same and any SLIME 204 | documentation is applicable to SLY. 205 | 206 | ### Swank is now called Slynk 207 | 208 | SLY can be loaded alongside SLIME both in the same Emacs or Lisp 209 | image. This interoperability meant that SLY's Lisp server had to be 210 | renamed to "Slynk". 211 | 212 | SLY can still speak the Swank protocol, and should be able to connect 213 | to any other non-Lisp backends such as Christopher Rhodes' [swankr][4] 214 | or have non-SLIME clients connect to it such as Robert Brown's 215 | [swank-client][5]. 216 | 217 | This is done via a contrib called `sly-retro` and its `slynk-retro` 218 | counterpart. The contrib's code is loaded by `M-x sly` or `M-x 219 | sly-connect` *on demand*, meaning that it is possible to start the 220 | Slynk server without the contrib's Lisp counterpart. See the section 221 | called "Slynk-loading method"" for how this works in SLY. 222 | 223 | *If* it is loaded, `sly-retro` ensures that messages leaving SLY still 224 | look like 225 | 226 | (:emacs-rex (swank:connection-info) nil t 1) 227 | 228 | It also ensures that incoming messages are directed to the `SLYNK` and 229 | `SLYNK-BACKEND` packages. This particular redirection is done via 230 | package nicknames and a trick in `lib/lisp/slynk-rpc.lisp`. The trick 231 | is necessary only for the first bootstrapping messages, because on 232 | startup the `sly-retro` contrib hasn't kicked in and nicknames are not 233 | immediately setup. 234 | 235 | The nicknames pose a compatibility hazard if the user tries to load 236 | SLIME's Swank server into the Lisp image where Slynk is already 237 | setup. Therefore, users wishing to run both servers alongside in the 238 | same Lisp image must ensure that the `sly-retro` contrib is not in 239 | `sly-contribs`. 240 | 241 | (setq sly-contribs (delq 'sly-retro sly-contribs)) 242 | 243 | [4]: https://github.com/gigamonkey/swankr 244 | [5]: https://github.com/brown/swank-client 245 | 246 | ### Slynk-loading method 247 | 248 | In SLIME, `M-x slime` immediately tells the Lisp process started by 249 | Emacs to use SLIME's own `swank-loader.lisp` program to compile and 250 | load all possibly available lisp under its directory (including 251 | contrib's) before the Swank server is created with 252 | `SWANK:CREATE-SERVER`. 253 | 254 | In SLY, the elisp variable `sly-init-function` is set to 255 | `sly-init-using-asdf` by default, meaning that `M-x sly` will try to 256 | load Slynk (the SLY equivalent to Swank) via `ASDF:LOAD-SYSTEM`. But 257 | this will load only Slynk and no contribs. 258 | 259 | Slynk contribs are also represented as ASDF systems. Internally the 260 | function `sly-contrib--load-slynk-dependencies` will ask Slynk to put 261 | the contrib's path to the ASDF load path. The `SLYNK:REQUIRE-MODULE` 262 | abstraction will then call `ASDF:LOAD-SYSTEM`. 263 | 264 | In SLY, a contrib's associated Slynk modules is loaded on demand, not 265 | forced on the user's Lisp run-time. 266 | 267 | This also allows the developer to write completely independent 268 | third-party extensions to SLY, with both Emacs and Lisp parts. See the 269 | URL https://github.com/joaotavora/sly-hello-world for an example 270 | extension. 271 | 272 | Additionally, if SLY detects that ASDF is not available in the Lisp 273 | run-time, it will fallback to the old `slynk-loader.lisp` mechanism, 274 | which has also been revised to support the previous two use cases. Any 275 | of the two methods is transparent from Emacs's perspective. 276 | 277 | ### mREPL 278 | 279 | `slime-mrepl` is an experimental SLIME contrib that inspired 280 | `sly-mrepl`, which is a much enhanced version of it and the default 281 | REPL for SLY. The main difference to the popular `slime-repl` contrib 282 | is that `sly-mrepl` is based on Emacs's own `comint.el` so that that 283 | SLY does not need to worry about functionality like history navigation 284 | and persistent history, which are consistent with other Emacs modes 285 | based on `comint.el`. 286 | 287 | `sly-mrepl` allows multiple REPLs through the use of channels, which 288 | are abstraction pioneered in SLIME. Channels are like separate 289 | mailboxes in the Lisp run-time, and it's slightly different from the 290 | regular `:emacs-rex` RPC calls in that they directly invoke a remote 291 | method but expect no reply. 292 | 293 | In `slynk-mrepl.lisp`, the `mrepl` class multiple inherits from 294 | `slynk:channel` and `slynk:listener`. The first takes care of 295 | channel-based communication and the second has the REPL-specific 296 | context. 297 | 298 | See the section on the "RPC protocl" and switch to the `*sly-events*` 299 | buffer to see what's going on. 300 | 301 | ### Display-related code 302 | 303 | SLIME's age and historical compatibility with XEmacs means it 304 | reinvented (and possibly invented) many buffer/window/display managing 305 | techniques that are available today in GNU Emacs's core. Interactive 306 | buttons, display-related and completion-code have all been pruned as 307 | much as possible and now reuse Emacs' own libraries. 308 | 309 | Hopefully this will make SLY's code focus on SLY's "business logic" 310 | and easier to read. 311 | 312 | ### Channels 313 | 314 | TODO 315 | 316 | ### Listeners 317 | 318 | TODO 319 | 320 | 321 | ## Pull requests 322 | 323 | * Read [how to properly contribute to open source projects on Github][1]. 324 | * Use a topic branch to easily amend a pull request later, if necessary. 325 | * Commit messages should use the syntax of [GNU ChangeLog entries][2]. 326 | * Open a [pull request][3] that relates to *only* one subject with a 327 | clear title and description in grammatically correct, complete 328 | sentences. 329 | 330 | [1]: https://gun.io/blog/how-to-github-fork-branch-and-pull-request 331 | [2]: https://www.gnu.org/prep/standards/html_node/Style-of-Change-Logs.html#Style-of-Change-Logs 332 | [3]: https://help.github.com/articles/using-pull-requests 333 | --------------------------------------------------------------------------------