mprodrigues/emacs.d
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Update all my elpa files

Browse Source
This commit is contained in:
Mateus Pinto Rodrigues
2018-05-17 18:02:17 -03:00
parent 216ee979b9
commit 0024c08036
860 changed files with 8617 additions and 7072 deletions
Download Patch File Download Diff File Expand all files Collapse all files

92
elpa/slime-20180413.1720/contrib/Makefile Normal file
View File

@@ -0,0 +1,92 @@
### Makefile for contribs
#
# This file is in the public domain.
EMACS=emacs
LISP=sbcl
LOAD_PATH=-L . -L ..
CONTRIBS = $(patsubst slime-%.el,%,$(wildcard slime-*.el))
CONTRIB_TESTS = $(patsubst test/slime-%-tests.el,%,$(wildcard test/slime-*.el))
SLIME_VERSION=$(shell grep "Version:" ../slime.el | grep -E -o "[0-9.]+$$")
ELFILES := $(shell find . -type f -iname "*.el")
ELCFILES := $(patsubst %.el,%.elc,$(ELFILES))
%.elc: %.el
$(EMACS) -Q $(LOAD_PATH) --batch -f batch-byte-compile $<
compile: $(ELCFILES)
$(EMACS) -Q --batch $(LOAD_PATH) \
--eval "(batch-byte-recompile-directory 0)" .
# ELPA builds for contribs
#
$(CONTRIBS:%=elpa-%): CONTRIB=$(@:elpa-%=%)
$(CONTRIBS:%=elpa-%): CONTRIB_EL=$(CONTRIB:%=slime-%.el)
$(CONTRIBS:%=elpa-%): CONTRIB_CL=$(CONTRIB:%=swank-%.lisp)
$(CONTRIBS:%=elpa-%): CONTRIB_VERSION=$(shell ( \
grep "Version:" $(CONTRIB_EL) \
|| echo $(SLIME_VERSION) \
) | grep -E -o "[0-9.]+$$" )
$(CONTRIBS:%=elpa-%): PACKAGE=$(CONTRIB:%=slime-%-$(CONTRIB_VERSION))
$(CONTRIBS:%=elpa-%): PACKAGE_EL=$(CONTRIB:%=slime-%-pkg.el)
$(CONTRIBS:%=elpa-%): ELPA_DIR=elpa/$(PACKAGE)
$(CONTRIBS:%=elpa-%): compile
elpa_dir=$(ELPA_DIR)
mkdir -p $$elpa_dir; \
emacs --batch $(CONTRIB_EL) \
--eval "(require 'cl-lib)" \
--eval "(search-forward \"define-slime-contrib\")" \
--eval "(up-list -1)" \
--eval "(pp \
(pcase (read (point-marker)) \
(\`(define-slime-contrib ,name ,docstring . ,rest) \
\`(define-package ,name \"$(CONTRIB_VERSION)\" \
,docstring \
,(cons '(slime \"$(SLIME_VERSION)\") \
(cl-loop for form in rest \
when (eq :slime-dependencies (car form)) \
append (cl-loop for contrib in (cdr form) \
if (atom contrib) \
collect \
\`(,contrib \"$(SLIME_VERSION)\") \
else \
collect contrib))))))))" > \
$$elpa_dir/$(PACKAGE_EL); \
cp $(CONTRIB_EL) $$elpa_dir; \
[ -r $(CONTRIB_CL) ] && cp $(CONTRIB_CL) $$elpa_dir; \
ls $$elpa_dir
cd elpa && tar cvf $(PACKAGE).tar $(PACKAGE)
rm -rf $(ELPA_DIR)
elpa-all: $(CONTRIBS:%=elpa-%)
$(CONTRIB_TESTS:%=check-%): CONTRIB_NAME=$(patsubst check-%,slime-%,$@)
$(CONTRIB_TESTS:%=check-%): SELECTOR=(quote (tag contrib))
$(CONTRIB_TESTS:%=check-%): compile
$(EMACS) -Q --batch $(LOAD_PATH) -L test \
--eval "(require (quote slime))" \
--eval "(slime-setup (quote ($(CONTRIB_NAME))))" \
--eval "(require \
(intern \
(format \"%s-tests\" (quote $(CONTRIB_NAME)))))" \
--eval '(setq inferior-lisp-program "$(LISP)")' \
--eval "(slime-batch-test $(SELECTOR))"
check-all: $(CONTRIB_TESTS:%=check-%)
check-fancy: compile
$(EMACS) -Q --batch $(LOAD_PATH) -L test \
--eval "(setq debug-on-error t)" \
--eval "(require (quote slime))" \
--eval "(slime-setup (quote (slime-fancy)))" \
--eval "(mapc (lambda (sym) \
(require \
(intern (format \"%s-tests\" sym)) \
nil t)) \
(slime-contrib-all-dependencies \
(quote slime-fancy)))" \
--eval '(setq inferior-lisp-program "$(LISP)")' \
--eval '(slime-batch-test (quote (tag contrib)))'

14
elpa/slime-20180413.1720/contrib/README.md Normal file
View File

@@ -0,0 +1,14 @@
This directory contains source code which may be useful to some Slime
users. `*.el` files are Emacs Lisp source and `*.lisp` files contain
Common Lisp source code. If not otherwise stated in the file itself,
the files are placed in the Public Domain.
The components in this directory are more or less detached from the
rest of Slime. They are essentially "add-ons". But Slime can also be
used without them. The code is maintained by the respective authors.
See the top level README.md for how to use packages in this directory.
Finally, the contrib `slime-fancy` is specially noteworthy, as it
represents a meta-contrib that'll load a bunch of commonly used
contribs. Look into `slime-fancy.el` to find out which.

472
elpa/slime-20180413.1720/contrib/bridge.el Normal file
View File

@@ -0,0 +1,472 @@
;;; -*-Emacs-Lisp-*-
;;;%Header
;;; Bridge process filter, V1.0
;;; Copyright (C) 1991 Chris McConnell, ccm@cs.cmu.edu
;;;
;;; Send mail to ilisp@cons.org if you have problems.
;;;
;;; Send mail to majordomo@cons.org if you want to be on the
;;; ilisp mailing list.
;;; This file is part of GNU Emacs.
;;; GNU Emacs is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY. No author or distributor
;;; accepts responsibility to anyone for the consequences of using it
;;; or for whether it serves any particular purpose or works at all,
;;; unless he says so in writing. Refer to the GNU Emacs General Public
;;; License for full details.
;;; Everyone is granted permission to copy, modify and redistribute
;;; GNU Emacs, but only under the conditions described in the
;;; GNU Emacs General Public License. A copy of this license is
;;; supposed to have been given to you along with GNU Emacs so you
;;; can know your rights and responsibilities. It should be in a
;;; file named COPYING. Among other things, the copyright notice
;;; and this notice must be preserved on all copies.
;;; Send any bugs or comments. Thanks to Todd Kaufmann for rewriting
;;; the process filter for continuous handlers.
;;; USAGE: M-x install-bridge will add a process output filter to the
;;; current buffer. Any output that the process does between
;;; bridge-start-regexp and bridge-end-regexp will be bundled up and
;;; passed to the first handler on bridge-handlers that matches the
;;; output using string-match. If bridge-prompt-regexp shows up
;;; before bridge-end-regexp, the bridge will be cancelled. If no
;;; handler matches the output, the first symbol in the output is
;;; assumed to be a buffer name and the rest of the output will be
;;; sent to that buffer's process. This can be used to communicate
;;; between processes or to set up two way interactions between Emacs
;;; and an inferior process.
;;; You can write handlers that process the output in special ways.
;;; See bridge-send-handler for the default handler. The command
;;; hand-bridge is useful for testing. Keep in mind that all
;;; variables are buffer local.
;;; YOUR .EMACS FILE:
;;;
;;; ;;; Set up load path to include bridge
;;; (setq load-path (cons "/bridge-directory/" load-path))
;;; (autoload 'install-bridge "bridge" "Install a process bridge." t)
;;; (setq bridge-hook
;;; '(lambda ()
;;; ;; Example options
;;; (setq bridge-source-insert nil) ;Don't insert in source buffer
;;; (setq bridge-destination-insert nil) ;Don't insert in dest buffer
;;; ;; Handle copy-it messages yourself
;;; (setq bridge-handlers
;;; '(("copy-it" . my-copy-handler)))))
;;; EXAMPLE:
;;; # This pipes stdin to the named buffer in a Unix shell
;;; alias devgnu '(echo -n "\!* "; cat -; echo -n "")'
;;;
;;; ls | devgnu *scratch*
(eval-when-compile
(require 'cl))
;;;%Parameters
(defvar bridge-hook nil
"Hook called when a bridge is installed by install-hook.")
(defvar bridge-start-regexp ""
"*Regular expression to match the start of a process bridge in
process output. It should be followed by a buffer name, the data to
be sent and a bridge-end-regexp.")
(defvar bridge-end-regexp ""
"*Regular expression to match the end of a process bridge in process
output.")
(defvar bridge-prompt-regexp nil
"*Regular expression for detecting a prompt. If there is a
comint-prompt-regexp, it will be initialized to that. A prompt before
a bridge-end-regexp will stop the process bridge.")
(defvar bridge-handlers nil
"Alist of (regexp . handler) for handling process output delimited
by bridge-start-regexp and bridge-end-regexp. The first entry on the
list whose regexp matches the output will be called on the process and
the delimited output.")
(defvar bridge-source-insert t
"*T to insert bridge input in the source buffer minus delimiters.")
(defvar bridge-destination-insert t
"*T for bridge-send-handler to insert bridge input into the
destination buffer minus delimiters.")
(defvar bridge-chunk-size 512
"*Long inputs send to comint processes are broken up into chunks of
this size. If your process is choking on big inputs, try lowering the
value.")
;;;%Internal variables
(defvar bridge-old-filter nil
"Old filter for a bridged process buffer.")
(defvar bridge-string nil
"The current output in the process bridge.")
(defvar bridge-in-progress nil
"The current handler function, if any, that bridge passes strings on to,
or nil if none.")
(defvar bridge-leftovers nil
"Because of chunking you might get an incomplete bridge signal - start but the end is in the next packet. Save the overhanging text here.")
(defvar bridge-send-to-buffer nil
"The buffer that the default bridge-handler (bridge-send-handler) is
currently sending to, or nil if it hasn't started yet. Your handler
function can use this variable also.")
(defvar bridge-last-failure ()
"Last thing that broke the bridge handler. First item is function call
(eval'able); last item is error condition which resulted. This is provided
to help handler-writers in their debugging.")
(defvar bridge-insert-function nil
"If non-nil use this instead of `bridge-insert'")
;;;%Utilities
(defun bridge-insert (output &optional _dummy)
"Insert process OUTPUT into the current buffer."
(if bridge-insert-function
(funcall bridge-insert-function output)
(if output
(let* ((buffer (current-buffer))
(process (get-buffer-process buffer))
(mark (process-mark process))
(window (selected-window))
(at-end nil))
(if (eq (window-buffer window) buffer)
(setq at-end (= (point) mark))
(setq window (get-buffer-window buffer)))
(save-excursion
(goto-char mark)
(insert output)
(set-marker mark (point)))
(if window
(progn
(if at-end (goto-char mark))
(if (not (pos-visible-in-window-p (point) window))
(let ((original (selected-window)))
(save-excursion
(select-window window)
(recenter '(center))
(select-window original))))))))))
;;;
;(defun bridge-send-string (process string)
; "Send PROCESS the contents of STRING as input.
;This is equivalent to process-send-string, except that long input strings
;are broken up into chunks of size comint-input-chunk-size. Processes
;are given a chance to output between chunks. This can help prevent processes
;from hanging when you send them long inputs on some OS's."
; (let* ((len (length string))
; (i (min len bridge-chunk-size)))
; (process-send-string process (substring string 0 i))
; (while (< i len)
; (let ((next-i (+ i bridge-chunk-size)))
; (accept-process-output)
; (process-send-string process (substring string i (min len next-i)))
; (setq i next-i)))))
;;;
(defun bridge-call-handler (handler proc string)
"Funcall HANDLER on PROC, STRING carefully. Error is caught if happens,
and user is signaled. State is put in bridge-last-failure. Returns t if
handler executed without error."
(let ((inhibit-quit nil)
(failed nil))
(condition-case err
(funcall handler proc string)
(error
(ding)
(setq failed t)
(message "bridge-handler \"%s\" failed %s (see bridge-last-failure)"
handler err)
(setq bridge-last-failure
`((funcall ',handler ',proc ,string)
"Caused: "
,err))))
(not failed)))
;;;%Handlers
(defun bridge-send-handler (process input)
"Send PROCESS INPUT to the buffer name found at the start of the
input. The input after the buffer name is sent to the buffer's
process if it has one. If bridge-destination-insert is T, the input
will be inserted into the buffer. If it does not have a process, it
will be inserted at the end of the buffer."
(if (null input)
(setq bridge-send-to-buffer nil) ; end of bridge
(let (buffer-and-start buffer-name dest to)
;; if this is first time, get the buffer out of the first line
(cond ((not bridge-send-to-buffer)
(setq buffer-and-start (read-from-string input)
buffer-name (format "%s" (car (read-from-string input)))
dest (get-buffer buffer-name)
to (get-buffer-process dest)
input (substring input (cdr buffer-and-start)))
(setq bridge-send-to-buffer dest))
(t
(setq buffer-name bridge-send-to-buffer
dest (get-buffer buffer-name)
to (get-buffer-process dest)
)))
(if dest
(let ((buffer (current-buffer)))
(if bridge-destination-insert
(unwind-protect
(progn
(set-buffer dest)
(if to
(bridge-insert process input)
(goto-char (point-max))
(insert input)))
(set-buffer buffer)))
(if to
;; (bridge-send-string to input)
(process-send-string to input)
))
(error "%s is not a buffer" buffer-name)))))
;;;%Filter
(defun bridge-filter (process output)
"Given PROCESS and some OUTPUT, check for the presence of
bridge-start-regexp. Everything prior to this will be passed to the
normal filter function or inserted in the buffer if it is nil. The
output up to bridge-end-regexp will be sent to the first handler on
bridge-handlers that matches the string. If no handlers match, the
input will be sent to bridge-send-handler. If bridge-prompt-regexp is
encountered before the bridge-end-regexp, the bridge will be cancelled."
(let ((inhibit-quit t)
(match-data (match-data))
(buffer (current-buffer))
(process-buffer (process-buffer process))
(case-fold-search t)
(start 0) (end 0)
function
b-start b-start-end b-end)
(set-buffer process-buffer) ;; access locals
;; Handle bridge messages that straddle a packet by prepending
;; them to this packet.
(when bridge-leftovers
(setq output (concat bridge-leftovers output))
(setq bridge-leftovers nil))
(setq function bridge-in-progress)
;; How it works:
;;
;; start, end delimit the part of string we are interested in;
;; initially both 0; after an iteration we move them to next string.
;; b-start, b-end delimit part of string to bridge (possibly whole string);
;; this will be string between corresponding regexps.
;; There are two main cases when we come into loop:
;; bridge in progress
;;0 setq b-start = start
;;1 setq b-end (or end-pattern end)
;;4 process string
;;5 remove handler if end found
;; no bridge in progress
;;0 setq b-start if see start-pattern
;;1 setq b-end if bstart to (or end-pattern end)
;;2 send (substring start b-start) to normal place
;;3 find handler (in b-start, b-end) if not set
;;4 process string
;;5 remove handler if end found
;; equivalent sections have the same numbers here;
;; we fold them together in this code.
(block bridge-filter
(unwind-protect
(while (< end (length output))
;;0 setq b-start if find
(setq b-start
(cond (bridge-in-progress
(setq b-start-end start)
start)
((string-match bridge-start-regexp output start)
(setq b-start-end (match-end 0))
(match-beginning 0))
(t nil)))
;;1 setq b-end
(setq b-end
(if b-start
(let ((end-seen (string-match bridge-end-regexp
output b-start-end)))
(if end-seen (setq end (match-end 0)))
end-seen)))
;; Detect and save partial bridge messages
(when (and b-start b-start-end (not b-end))
(setq bridge-leftovers (substring output b-start))
)
(if (and b-start (not b-end))
(setq end b-start)
(if (not b-end)
(setq end (length output))))
;;1.5 - if see prompt before end, remove current
(if (and b-start b-end)
(let ((prompt (string-match bridge-prompt-regexp
output b-start-end)))
(if (and prompt (<= (match-end 0) b-end))
(setq b-start nil ; b-start-end start
b-end start
end (match-end 0)
bridge-in-progress nil
))))
;;2 send (substring start b-start) to old filter, if any
(when (not (equal start (or b-start end))) ; don't bother on empty string
(let ((pass-on (substring output start (or b-start end))))
(if bridge-old-filter
(let ((old bridge-old-filter))
(store-match-data match-data)
(funcall old process pass-on)
;; if filter changed, re-install ourselves
(let ((new (process-filter process)))
(if (not (eq new 'bridge-filter))
(progn (setq bridge-old-filter new)
(set-process-filter process 'bridge-filter)))))
(set-buffer process-buffer)
(bridge-insert pass-on))))
(if (and b-start-end (not b-end))
(return-from bridge-filter t) ; when last bit has prematurely ending message, exit early.
(progn
;;3 find handler (in b-start, b-end) if none current
(if (and b-start (not bridge-in-progress))
(let ((handlers bridge-handlers))
(while (and handlers (not function))
(let* ((handler (car handlers))
(m (string-match (car handler) output b-start-end)))
(if (and m (< m b-end))
(setq function (cdr handler))
(setq handlers (cdr handlers)))))
;; Set default handler if none
(if (null function)
(setq function 'bridge-send-handler))
(setq bridge-in-progress function)))
;;4 process strin
(if function
(let ((ok t))
(if (/= b-start-end b-end)
(let ((send (substring output b-start-end b-end)))
;; also, insert the stuff in buffer between
;; iff bridge-source-insert.
(if bridge-source-insert (bridge-insert send))
;; call handler on string
(setq ok (bridge-call-handler function process send))))
;;5 remove handler if end found
;; if function removed then tell it that's all
(if (or (not ok) (/= b-end end)) ;; saw end before end-of-string
(progn
(bridge-call-handler function process nil)
;; have to remove function too for next time around
(setq function nil
bridge-in-progress nil)
))
))
;; continue looping, in case there's more string
(setq start end))
))
;; protected forms: restore buffer, match-data
(set-buffer buffer)
(store-match-data match-data)
))))
;;;%Interface
(defun install-bridge ()
"Set up a process bridge in the current buffer."
(interactive)
(if (not (get-buffer-process (current-buffer)))
(error "%s does not have a process" (buffer-name (current-buffer)))
(make-local-variable 'bridge-start-regexp)
(make-local-variable 'bridge-end-regexp)
(make-local-variable 'bridge-prompt-regexp)
(make-local-variable 'bridge-handlers)
(make-local-variable 'bridge-source-insert)
(make-local-variable 'bridge-destination-insert)
(make-local-variable 'bridge-chunk-size)
(make-local-variable 'bridge-old-filter)
(make-local-variable 'bridge-string)
(make-local-variable 'bridge-in-progress)
(make-local-variable 'bridge-send-to-buffer)
(make-local-variable 'bridge-leftovers)
(setq bridge-string nil bridge-in-progress nil
bridge-send-to-buffer nil)
(if (boundp 'comint-prompt-regexp)
(setq bridge-prompt-regexp comint-prompt-regexp))
(let ((process (get-buffer-process (current-buffer))))
(if process
(if (not (eq (process-filter process) 'bridge-filter))
(progn
(setq bridge-old-filter (process-filter process))
(set-process-filter process 'bridge-filter)))
(error "%s does not have a process"
(buffer-name (current-buffer)))))
(run-hooks 'bridge-hook)
(message "Process bridge is installed")))
;;;
(defun reset-bridge ()
"Must be called from the process's buffer. Removes any active bridge."
(interactive)
;; for when things get wedged
(if bridge-in-progress
(unwind-protect
(funcall bridge-in-progress (get-buffer-process
(current-buffer))
nil)
(setq bridge-in-progress nil))
(message "No bridge in progress.")))
;;;
(defun remove-bridge ()
"Remove bridge from the current buffer."
(interactive)
(let ((process (get-buffer-process (current-buffer))))
(if (or (not process) (not (eq (process-filter process) 'bridge-filter)))
(error "%s has no bridge" (buffer-name (current-buffer)))
;; remove any bridge-in-progress
(reset-bridge)
(set-process-filter process bridge-old-filter)
(funcall bridge-old-filter process bridge-string)
(message "Process bridge is removed."))))
;;;% Utility for testing
(defun hand-bridge (start end)
"With point at bridge-start, sends bridge-start + string +
bridge-end to bridge-filter. With prefix, use current region to send."
(interactive "r")
(let ((p0 (if current-prefix-arg (min start end)
(if (looking-at bridge-start-regexp) (point)
(error "Not looking at bridge-start-regexp"))))
(p1 (if current-prefix-arg (max start end)
(if (re-search-forward bridge-end-regexp nil t)
(point) (error "Didn't see bridge-end-regexp")))))
(bridge-filter (get-buffer-process (current-buffer))
(buffer-substring-no-properties p0 p1))
))
(provide 'bridge)

BIN
elpa/slime-20180413.1720/contrib/bridge.elc Normal file
View File

Binary file not shown.

133
elpa/slime-20180413.1720/contrib/inferior-slime.el Normal file
View File

@@ -0,0 +1,133 @@
;;; inferior-slime.el --- Minor mode with Slime keys for comint buffers
;;
;; Author: Luke Gorrie <luke@synap.se>
;; License: GNU GPL (same license as Emacs)
;;
;;; Installation:
;;
;; Add something like this to your .emacs:
;;
;; (add-to-list 'load-path "<directory-of-this-file>")
;; (add-hook 'slime-load-hook (lambda () (require 'inferior-slime)))
;; (add-hook 'inferior-lisp-mode-hook (lambda () (inferior-slime-mode 1)))
(require 'slime)
(require 'cl-lib)
(define-minor-mode inferior-slime-mode
"\\<slime-mode-map>\
Inferior SLIME mode: The Inferior Superior Lisp Mode for Emacs.
This mode is intended for use with `inferior-lisp-mode'. It provides a
subset of the bindings from `slime-mode'.
\\{inferior-slime-mode-map}"
:keymap
;; Fake binding to coax `define-minor-mode' to create the keymap
'((" " 'undefined))
(slime-setup-completion)
(setq-local tab-always-indent 'complete))
(defun inferior-slime-return ()
"Handle the return key in the inferior-lisp buffer.
The current input should only be sent if a whole expression has been
entered, i.e. the parenthesis are matched.
A prefix argument disables this behaviour."
(interactive)
(if (or current-prefix-arg (inferior-slime-input-complete-p))
(comint-send-input)
(insert "\n")
(inferior-slime-indent-line)))
(defun inferior-slime-indent-line ()
"Indent the current line, ignoring everything before the prompt."
(interactive)
(save-restriction
(let ((indent-start
(save-excursion
(goto-char (process-mark (get-buffer-process (current-buffer))))
(let ((inhibit-field-text-motion t))
(beginning-of-line 1))
(point))))
(narrow-to-region indent-start (point-max)))
(lisp-indent-line)))
(defun inferior-slime-input-complete-p ()
"Return true if the input is complete in the inferior lisp buffer."
(slime-input-complete-p (process-mark (get-buffer-process (current-buffer)))
(point-max)))
(defun inferior-slime-closing-return ()
"Send the current expression to Lisp after closing any open lists."
(interactive)
(goto-char (point-max))
(save-restriction
(narrow-to-region (process-mark (get-buffer-process (current-buffer)))
(point-max))
(while (ignore-errors (save-excursion (backward-up-list 1) t))
(insert ")")))
(comint-send-input))
(defun inferior-slime-change-directory (directory)
"Set default-directory in the *inferior-lisp* buffer to DIRECTORY."
(let* ((proc (slime-process))
(buffer (and proc (process-buffer proc))))
(when buffer
(with-current-buffer buffer
(cd-absolute directory)))))
(defun inferior-slime-init-keymap ()
(let ((map inferior-slime-mode-map))
(set-keymap-parent map slime-parent-map)
(slime-define-keys map
([return] 'inferior-slime-return)
([(control return)] 'inferior-slime-closing-return)
([(meta control ?m)] 'inferior-slime-closing-return)
;;("\t" 'slime-indent-and-complete-symbol)
(" " 'slime-space))))
(inferior-slime-init-keymap)
(defun inferior-slime-hook-function ()
(inferior-slime-mode 1))
(defun inferior-slime-switch-to-repl-buffer ()
(switch-to-buffer (process-buffer (slime-inferior-process))))
(defun inferior-slime-show-transcript (string)
(remove-hook 'comint-output-filter-functions
'inferior-slime-show-transcript t)
(with-current-buffer (process-buffer (slime-inferior-process))
(let ((window (display-buffer (current-buffer) t)))
(set-window-point window (point-max)))))
(defun inferior-slime-start-transcript ()
(let ((proc (slime-inferior-process)))
(when proc
(with-current-buffer (process-buffer proc)
(add-hook 'comint-output-filter-functions
'inferior-slime-show-transcript
nil t)))))
(defun inferior-slime-stop-transcript ()
(let ((proc (slime-inferior-process)))
(when proc
(with-current-buffer (process-buffer (slime-inferior-process))
(run-with-timer 0.2 nil
(lambda (buffer)
(with-current-buffer buffer
(remove-hook 'comint-output-filter-functions
'inferior-slime-show-transcript t)))
(current-buffer))))))
(defun inferior-slime-init ()
(add-hook 'slime-inferior-process-start-hook 'inferior-slime-hook-function)
(add-hook 'slime-change-directory-hooks 'inferior-slime-change-directory)
(add-hook 'slime-transcript-start-hook 'inferior-slime-start-transcript)
(add-hook 'slime-transcript-stop-hook 'inferior-slime-stop-transcript)
(def-slime-selector-method ?r
"SLIME Read-Eval-Print-Loop."
(process-buffer (slime-inferior-process))))
(provide 'inferior-slime)

BIN
elpa/slime-20180413.1720/contrib/inferior-slime.elc Normal file
View File

Binary file not shown.

313
elpa/slime-20180413.1720/contrib/slime-asdf.el Normal file
View File

@@ -0,0 +1,313 @@
(require 'slime)
(require 'cl-lib)
(require 'grep)
(define-slime-contrib slime-asdf
"ASDF support."
(:authors "Daniel Barlow <dan@telent.net>"
"Marco Baringer <mb@bese.it>"
"Edi Weitz <edi@agharta.de>"
"Stas Boukarev <stassats@gmail.com>"
"Tobias C Rittweiler <tcr@freebits.de>")
(:license "GPL")
(:slime-dependencies slime-repl)
(:swank-dependencies swank-asdf)
(:on-load
(add-to-list 'slime-edit-uses-xrefs :depends-on t)
(define-key slime-who-map [?d] 'slime-who-depends-on)))
;;; NOTE: `system-name' is a predefined variable in Emacs. Try to
;;; avoid it as local variable name.
;;; Utilities
(defgroup slime-asdf nil
"ASDF support for Slime."
:prefix "slime-asdf-"
:group 'slime)
(defvar slime-system-history nil
"History list for ASDF system names.")
(defun slime-read-system-name (&optional prompt
default-value
determine-default-accurately)
"Read a system name from the minibuffer, prompting with PROMPT.
If no `default-value' is given, one is tried to be determined: if
`determine-default-accurately' is true, by an RPC request which
grovels through all defined systems; if it's not true, by looking
in the directory of the current buffer."
(let* ((completion-ignore-case nil)
(prompt (or prompt "System"))
(system-names (slime-eval `(swank:list-asdf-systems)))
(default-value
(or default-value
(if determine-default-accurately
(slime-determine-asdf-system (buffer-file-name)
(slime-current-package))
(slime-find-asd-file (or default-directory
(buffer-file-name))
system-names))))
(prompt (concat prompt (if default-value
(format " (default `%s'): " default-value)
": "))))
(completing-read prompt (slime-bogus-completion-alist system-names)
nil nil nil
'slime-system-history default-value)))
(defun slime-find-asd-file (directory system-names)
"Tries to find an ASDF system definition file in the
`directory' and returns it if it's in `system-names'."
(let ((asd-files
(directory-files (file-name-directory directory) nil "\.asd$")))
(cl-loop for system in asd-files
for candidate = (file-name-sans-extension system)
when (cl-find candidate system-names :test #'string-equal)
do (cl-return candidate))))
(defun slime-determine-asdf-system (filename buffer-package)
"Try to determine the asdf system that `filename' belongs to."
(slime-eval
`(swank:asdf-determine-system ,(and filename
(slime-to-lisp-filename filename))
,buffer-package)))
(defun slime-who-depends-on-rpc (system)
(slime-eval `(swank:who-depends-on ,system)))
(defcustom slime-asdf-collect-notes t
"Collect and display notes produced by the compiler.
See also `slime-highlight-compiler-notes' and
`slime-compilation-finished-hook'."
:group 'slime-asdf)
(defun slime-asdf-operation-finished-function (system)
(if slime-asdf-collect-notes
#'slime-compilation-finished
(slime-curry (lambda (system result)
(let (slime-highlight-compiler-notes
slime-compilation-finished-hook)
(slime-compilation-finished result)))
system)))
(defun slime-oos (system operation &rest keyword-args)
"Operate On System."
(slime-save-some-lisp-buffers)
(slime-display-output-buffer)
(message "Performing ASDF %S%s on system %S"
operation (if keyword-args (format " %S" keyword-args) "")
system)
(slime-repl-shortcut-eval-async
`(swank:operate-on-system-for-emacs ,system ',operation ,@keyword-args)
(slime-asdf-operation-finished-function system)))
;;; Interactive functions
(defun slime-load-system (&optional system)
"Compile and load an ASDF system.
Default system name is taken from first file matching *.asd in current
buffer's working directory"
(interactive (list (slime-read-system-name)))
(slime-oos system 'load-op))
(defun slime-open-system (name &optional load interactive)
"Open all files in an ASDF system."
(interactive (list (slime-read-system-name) nil t))
(when (or load
(and interactive
(not (slime-eval `(swank:asdf-system-loaded-p ,name)))
(y-or-n-p "Load it? ")))
(slime-load-system name))
(slime-eval-async
`(swank:asdf-system-files ,name)
(lambda (files)
(when files
(let ((files (mapcar 'slime-from-lisp-filename
(nreverse files))))
(find-file-other-window (car files))
(mapc 'find-file (cdr files)))))))
(defun slime-browse-system (name)
"Browse files in an ASDF system using Dired."
(interactive (list (slime-read-system-name)))
(slime-eval-async `(swank:asdf-system-directory ,name)
(lambda (directory)
(when directory
(dired (slime-from-lisp-filename directory))))))
(if (fboundp 'rgrep)
(defun slime-rgrep-system (sys-name regexp)
"Run `rgrep' on the base directory of an ASDF system."
(interactive (progn (grep-compute-defaults)
(list (slime-read-system-name nil nil t)
(grep-read-regexp))))
(rgrep regexp "*.lisp"
(slime-from-lisp-filename
(slime-eval `(swank:asdf-system-directory ,sys-name)))))
(defun slime-rgrep-system ()
(interactive)
(error "This command is only supported on GNU Emacs >21.x.")))
(if (boundp 'multi-isearch-next-buffer-function)
(defun slime-isearch-system (sys-name)
"Run `isearch-forward' on the files of an ASDF system."
(interactive (list (slime-read-system-name nil nil t)))
(let* ((files (mapcar 'slime-from-lisp-filename
(slime-eval `(swank:asdf-system-files ,sys-name))))
(multi-isearch-next-buffer-function
(lexical-let*
((buffers-forward (mapcar #'find-file-noselect files))
(buffers-backward (reverse buffers-forward)))
#'(lambda (current-buffer wrap)
;; Contrarily to the docstring of
;; `multi-isearch-next-buffer-function', the first
;; arg is not necessarily a buffer. Report sent
;; upstream. (2009-11-17)
(setq current-buffer (or current-buffer (current-buffer)))
(let* ((buffers (if isearch-forward
buffers-forward
buffers-backward)))
(if wrap
(car buffers)
(second (memq current-buffer buffers))))))))
(isearch-forward)))
(defun slime-isearch-system ()
(interactive)
(error "This command is only supported on GNU Emacs >23.1.x.")))
(defun slime-read-query-replace-args (format-string &rest format-args)
(let* ((minibuffer-setup-hook (slime-minibuffer-setup-hook))
(minibuffer-local-map slime-minibuffer-map)
(common (query-replace-read-args (apply #'format format-string
format-args)
t t)))
(list (nth 0 common) (nth 1 common) (nth 2 common))))
(defun slime-query-replace-system (name from to &optional delimited)
"Run `query-replace' on an ASDF system."
(interactive (let ((system (slime-read-system-name nil nil t)))
(cons system (slime-read-query-replace-args
"Query replace throughout `%s'" system))))
(condition-case c
;; `tags-query-replace' actually uses `query-replace-regexp'
;; internally.
(tags-query-replace (regexp-quote from) to delimited
'(mapcar 'slime-from-lisp-filename
(slime-eval `(swank:asdf-system-files ,name))))
(error
;; Kludge: `tags-query-replace' does not actually return but
;; signals an unnamed error with the below error
;; message. (<=23.1.2, at least.)
(unless (string-equal (error-message-string c) "All files processed")
(signal (car c) (cdr c))) ; resignal
t)))
(defun slime-query-replace-system-and-dependents
(name from to &optional delimited)
"Run `query-replace' on an ASDF system and all the systems
depending on it."
(interactive (let ((system (slime-read-system-name nil nil t)))
(cons system (slime-read-query-replace-args
"Query replace throughout `%s'+dependencies"
system))))
(slime-query-replace-system name from to delimited)
(dolist (dep (slime-who-depends-on-rpc name))
(when (y-or-n-p (format "Descend into system `%s'? " dep))
(slime-query-replace-system dep from to delimited))))
(defun slime-delete-system-fasls (name)
"Delete FASLs produced by compiling a system."
(interactive (list (slime-read-system-name)))
(slime-repl-shortcut-eval-async
`(swank:delete-system-fasls ,name)
'message))
(defun slime-reload-system (system)
"Reload an ASDF system without reloading its dependencies."
(interactive (list (slime-read-system-name)))
(slime-save-some-lisp-buffers)
(slime-display-output-buffer)
(message "Performing ASDF LOAD-OP on system %S" system)
(slime-repl-shortcut-eval-async
`(swank:reload-system ,system)
(slime-asdf-operation-finished-function system)))
(defun slime-who-depends-on (system-name)
(interactive (list (slime-read-system-name)))
(slime-xref :depends-on system-name))
(defun slime-save-system (system)
"Save files belonging to an ASDF system."
(interactive (list (slime-read-system-name)))
(slime-eval-async
`(swank:asdf-system-files ,system)
(lambda (files)
(dolist (file files)
(let ((buffer (get-file-buffer (slime-from-lisp-filename file))))
(when buffer
(with-current-buffer buffer
(save-buffer buffer)))))
(message "Done."))))
;;; REPL shortcuts
(defslime-repl-shortcut slime-repl-load/force-system ("force-load-system")
(:handler (lambda ()
(interactive)
(slime-oos (slime-read-system-name) 'load-op :force t)))
(:one-liner "Recompile and load an ASDF system."))
(defslime-repl-shortcut slime-repl-load-system ("load-system")
(:handler (lambda ()
(interactive)
(slime-oos (slime-read-system-name) 'load-op)))
(:one-liner "Compile (as needed) and load an ASDF system."))
(defslime-repl-shortcut slime-repl-test/force-system ("force-test-system")
(:handler (lambda ()
(interactive)
(slime-oos (slime-read-system-name) 'test-op :force t)))
(:one-liner "Recompile and test an ASDF system."))
(defslime-repl-shortcut slime-repl-test-system ("test-system")
(:handler (lambda ()
(interactive)
(slime-oos (slime-read-system-name) 'test-op)))
(:one-liner "Compile (as needed) and test an ASDF system."))
(defslime-repl-shortcut slime-repl-compile-system ("compile-system")
(:handler (lambda ()
(interactive)
(slime-oos (slime-read-system-name) 'compile-op)))
(:one-liner "Compile (but not load) an ASDF system."))
(defslime-repl-shortcut slime-repl-compile/force-system
("force-compile-system")
(:handler (lambda ()
(interactive)
(slime-oos (slime-read-system-name) 'compile-op :force t)))
(:one-liner "Recompile (but not completely load) an ASDF system."))
(defslime-repl-shortcut slime-repl-open-system ("open-system")
(:handler 'slime-open-system)
(:one-liner "Open all files in an ASDF system."))
(defslime-repl-shortcut slime-repl-browse-system ("browse-system")
(:handler 'slime-browse-system)
(:one-liner "Browse files in an ASDF system using Dired."))
(defslime-repl-shortcut slime-repl-delete-system-fasls ("delete-system-fasls")
(:handler 'slime-delete-system-fasls)
(:one-liner "Delete FASLs of an ASDF system."))
(defslime-repl-shortcut slime-repl-reload-system ("reload-system")
(:handler 'slime-reload-system)
(:one-liner "Recompile and load an ASDF system."))
(provide 'slime-asdf)

BIN
elpa/slime-20180413.1720/contrib/slime-asdf.elc Normal file
View File

Binary file not shown.

216
elpa/slime-20180413.1720/contrib/slime-autodoc.el Normal file
View File

@@ -0,0 +1,216 @@
(require 'slime)
(require 'eldoc)
(require 'cl-lib)
(require 'slime-parse)
(define-slime-contrib slime-autodoc
"Show fancy arglist in echo area."
(:license "GPL")
(:authors "Luke Gorrie <luke@bluetail.com>"
"Lawrence Mitchell <wence@gmx.li>"
"Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de>"
"Tobias C. Rittweiler <tcr@freebits.de>")
(:slime-dependencies slime-parse)
(:swank-dependencies swank-arglists)
(:on-load (slime-autodoc--enable))
(:on-unload (slime-autodoc--disable)))
(defcustom slime-autodoc-accuracy-depth 10
"Number of paren levels that autodoc takes into account for
context-sensitive arglist display (local functions. etc)"
:type 'integer
:group 'slime-ui)
;;;###autoload
(defcustom slime-autodoc-mode-string (purecopy " adoc")
"String to display in mode line when Autodoc Mode is enabled; nil for none."
:type '(choice string (const :tag "None" nil))
:group 'slime-ui)
(defun slime-arglist (name)
"Show the argument list for NAME."
(interactive (list (slime-read-symbol-name "Arglist of: " t)))
(let ((arglist (slime-retrieve-arglist name)))
(if (eq arglist :not-available)
(error "Arglist not available")
(message "%s" (slime-autodoc--fontify arglist)))))
;; used also in slime-c-p-c.el.
(defun slime-retrieve-arglist (name)
(let ((name (cl-etypecase name
(string name)
(symbol (symbol-name name)))))
(car (slime-eval `(swank:autodoc '(,name ,slime-cursor-marker))))))
(defun slime-autodoc-manually ()
"Like autodoc informtion forcing multiline display."
(interactive)
(let ((doc (slime-autodoc t)))
(cond (doc (eldoc-message doc))
(t (eldoc-message nil)))))
;; Must call eldoc-add-command otherwise (eldoc-display-message-p)
;; returns nil and eldoc clears the echo area instead.
(eldoc-add-command 'slime-autodoc-manually)
(defun slime-autodoc-space (n)
"Like `slime-space' but nicer."
(interactive "p")
(self-insert-command n)
(let ((doc (slime-autodoc)))
(when doc
(eldoc-message doc))))
(eldoc-add-command 'slime-autodoc-space)
;;;; Autodoc cache
(defvar slime-autodoc--cache-last-context nil)
(defvar slime-autodoc--cache-last-autodoc nil)
(defun slime-autodoc--cache-get (context)
"Return the cached autodoc documentation for `context', or nil."
(and (equal context slime-autodoc--cache-last-context)
slime-autodoc--cache-last-autodoc))
(defun slime-autodoc--cache-put (context autodoc)
"Update the autodoc cache for CONTEXT with AUTODOC."
(setq slime-autodoc--cache-last-context context)
(setq slime-autodoc--cache-last-autodoc autodoc))
;;;; Formatting autodoc
(defsubst slime-autodoc--canonicalize-whitespace (string)
(replace-regexp-in-string "[ \n\t]+" " " string))
(defun slime-autodoc--format (doc multilinep)
(let ((doc (slime-autodoc--fontify doc)))
(cond (multilinep doc)
(t (slime-oneliner (slime-autodoc--canonicalize-whitespace doc))))))
(defun slime-autodoc--fontify (string)
"Fontify STRING as `font-lock-mode' does in Lisp mode."
(with-current-buffer (get-buffer-create (slime-buffer-name :fontify 'hidden))
(erase-buffer)
(unless (eq major-mode 'lisp-mode)
;; Just calling (lisp-mode) will turn slime-mode on in that buffer,
;; which may interfere with this function
(setq major-mode 'lisp-mode)
(lisp-mode-variables t))
(insert string)
(let ((font-lock-verbose nil))
(font-lock-fontify-buffer))
(goto-char (point-min))
(when (re-search-forward "===> \\(\\(.\\|\n\\)*\\) <===" nil t)
(let ((highlight (match-string 1)))
;; Can't use (replace-match highlight) here -- broken in Emacs 21
(delete-region (match-beginning 0) (match-end 0))
(slime-insert-propertized '(face eldoc-highlight-function-argument) highlight)))
(buffer-substring (point-min) (point-max))))
(define-obsolete-function-alias 'slime-fontify-string
'slime-autodoc--fontify
"SLIME 2.10")
;;;; Autodocs (automatic context-sensitive help)
(defun slime-autodoc (&optional force-multiline)
"Returns the cached arglist information as string, or nil.
If it's not in the cache, the cache will be updated asynchronously."
(save-excursion
(save-match-data
(let ((context (slime-autodoc--parse-context)))
(when context
(let* ((cached (slime-autodoc--cache-get context))
(multilinep (or force-multiline
eldoc-echo-area-use-multiline-p)))
(cond (cached (slime-autodoc--format cached multilinep))
(t
(when (slime-background-activities-enabled-p)
(slime-autodoc--async context multilinep))
nil))))))))
;; Return the context around point that can be passed to
;; swank:autodoc. nil is returned if nothing reasonable could be
;; found.
(defun slime-autodoc--parse-context ()
(and (slime-autodoc--parsing-safe-p)
(let ((levels slime-autodoc-accuracy-depth))
(slime-parse-form-upto-point levels))))
(defun slime-autodoc--parsing-safe-p ()
(cond ((fboundp 'slime-repl-inside-string-or-comment-p)
(not (slime-repl-inside-string-or-comment-p)))
(t
(not (slime-inside-string-or-comment-p)))))
(defun slime-autodoc--async (context multilinep)
(slime-eval-async
`(swank:autodoc ',context ;; FIXME: misuse of quote
:print-right-margin ,(window-width (minibuffer-window)))
(slime-curry #'slime-autodoc--async% context multilinep)))
(defun slime-autodoc--async% (context multilinep doc)
(cl-destructuring-bind (doc cache-p) doc
(unless (eq doc :not-available)
(when cache-p
(slime-autodoc--cache-put context doc))
;; Now that we've got our information,
;; get it to the user ASAP.
(when (eldoc-display-message-p)
(eldoc-message (slime-autodoc--format doc multilinep))))))
;;; Minor mode definition
;; Compute the prefix for slime-doc-map, usually this is C-c C-d.
(defun slime-autodoc--doc-map-prefix ()
(concat
(car (rassoc '(slime-prefix-map) slime-parent-bindings))
(car (rassoc '(slime-doc-map) slime-prefix-bindings))))
(define-minor-mode slime-autodoc-mode
"Toggle echo area display of Lisp objects at point."
:lighter slime-autodoc-mode-string
:keymap (let ((prefix (slime-autodoc--doc-map-prefix)))
`((,(concat prefix "A") . slime-autodoc-manually)
(,(concat prefix (kbd "C-A")) . slime-autodoc-manually)
(,(kbd "SPC") . slime-autodoc-space)))
(set (make-local-variable 'eldoc-documentation-function) 'slime-autodoc)
(set (make-local-variable 'eldoc-minor-mode-string) nil)
(setq slime-autodoc-mode (eldoc-mode arg))
(when (called-interactively-p 'interactive)
(message "Slime autodoc mode %s."
(if slime-autodoc-mode "enabled" "disabled"))))
;;; Noise to enable/disable slime-autodoc-mode
(defun slime-autodoc--on () (slime-autodoc-mode 1))
(defun slime-autodoc--off () (slime-autodoc-mode 0))
(defvar slime-autodoc--relevant-hooks
'(slime-mode-hook slime-repl-mode-hook sldb-mode-hook))
(defun slime-autodoc--enable ()
(dolist (h slime-autodoc--relevant-hooks)
(add-hook h 'slime-autodoc--on))
(dolist (b (buffer-list))
(with-current-buffer b
(when slime-mode
(slime-autodoc--on)))))
(defun slime-autodoc--disable ()
(dolist (h slime-autodoc--relevant-hooks)
(remove-hook h 'slime-autodoc--on))
(dolist (b (buffer-list))
(with-current-buffer b
(when slime-autodoc-mode
(slime-autodoc--off)))))
(provide 'slime-autodoc)

BIN
elpa/slime-20180413.1720/contrib/slime-autodoc.elc Normal file
View File

Binary file not shown.

35
elpa/slime-20180413.1720/contrib/slime-banner.el Normal file
View File

@@ -0,0 +1,35 @@
(require 'slime)
(require 'slime-repl)
(define-slime-contrib slime-banner
"Persistent header line and startup animation."
(:authors "Helmut Eller <heller@common-lisp.net>"
"Luke Gorrie <luke@synap.se>")
(:license "GPL")
(:on-load (setq slime-repl-banner-function 'slime-startup-message))
(:on-unload (setq slime-repl-banner-function 'slime-repl-insert-banner)))
(defcustom slime-startup-animation (fboundp 'animate-string)
"Enable the startup animation."
:type '(choice (const :tag "Enable" t) (const :tag "Disable" nil))
:group 'slime-ui)
(defcustom slime-header-line-p (boundp 'header-line-format)
"If non-nil, display a header line in Slime buffers."
:type 'boolean
:group 'slime-repl)
(defun slime-startup-message ()
(when slime-header-line-p
(setq header-line-format
(format "%s Port: %s Pid: %s"
(slime-lisp-implementation-type)
(slime-connection-port (slime-connection))
(slime-pid))))
(when (zerop (buffer-size))
(let ((welcome (concat "; SLIME " slime-version)))
(if slime-startup-animation
(animate-string welcome 0 0)
(insert welcome)))))
(provide 'slime-banner)

BIN
elpa/slime-20180413.1720/contrib/slime-banner.elc Normal file
View File

Binary file not shown.

305
elpa/slime-20180413.1720/contrib/slime-c-p-c.el Normal file
View File

@@ -0,0 +1,305 @@
(require 'slime)
(require 'cl-lib)
(defvar slime-c-p-c-init-undo-stack nil)
(define-slime-contrib slime-c-p-c
"ILISP style Compound Prefix Completion."
(:authors "Luke Gorrie <luke@synap.se>"
"Edi Weitz <edi@agharta.de>"
"Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de>"
"Tobias C. Rittweiler <tcr@freebits.de>")
(:license "GPL")
(:slime-dependencies slime-parse slime-editing-commands slime-autodoc)
(:swank-dependencies swank-c-p-c)
(:on-load
(push
`(progn
(remove-hook 'slime-completion-at-point-functions
#'slime-c-p-c-completion-at-point)
(remove-hook 'slime-connected-hook 'slime-c-p-c-on-connect)
,@(when (featurep 'slime-repl)
`((define-key slime-mode-map "\C-c\C-s"
',(lookup-key slime-mode-map "\C-c\C-s"))
(define-key slime-repl-mode-map "\C-c\C-s"
',(lookup-key slime-repl-mode-map "\C-c\C-s")))))
slime-c-p-c-init-undo-stack)
(add-hook 'slime-completion-at-point-functions
#'slime-c-p-c-completion-at-point)
(define-key slime-mode-map "\C-c\C-s" 'slime-complete-form)
(when (featurep 'slime-repl)
(define-key slime-repl-mode-map "\C-c\C-s" 'slime-complete-form)))
(:on-unload
(while slime-c-p-c-init-undo-stack
(eval (pop slime-c-p-c-init-undo-stack)))))
(defcustom slime-c-p-c-unambiguous-prefix-p t
"If true, set point after the unambigous prefix.
If false, move point to the end of the inserted text."
:type 'boolean
:group 'slime-ui)
(defcustom slime-complete-symbol*-fancy nil
"Use information from argument lists for DWIM'ish symbol completion."
:group 'slime-mode
:type 'boolean)
;; FIXME: this is the old code to display completions. Remove it once
;; `slime-complete-symbol*' and `slime-fuzzy-complete-symbol' can be
;; used together with `completion-at-point'.
(defvar slime-completions-buffer-name "*Completions*")
;; FIXME: can probably use quit-window instead
(make-variable-buffer-local
(defvar slime-complete-saved-window-configuration nil
"Window configuration before we show the *Completions* buffer.
This is buffer local in the buffer where the completion is
performed."))
(make-variable-buffer-local
(defvar slime-completions-window nil
"The window displaying *Completions* after saving window configuration.
If this window is no longer active or displaying the completions
buffer then we can ignore `slime-complete-saved-window-configuration'."))
(defun slime-complete-maybe-save-window-configuration ()
"Maybe save the current window configuration.
Return true if the configuration was saved."
(unless (or slime-complete-saved-window-configuration
(get-buffer-window slime-completions-buffer-name))
(setq slime-complete-saved-window-configuration
(current-window-configuration))
t))
(defun slime-complete-delay-restoration ()
(add-hook 'pre-command-hook
'slime-complete-maybe-restore-window-configuration
'append
'local))
(defun slime-complete-forget-window-configuration ()
(setq slime-complete-saved-window-configuration nil)
(setq slime-completions-window nil))
(defun slime-complete-restore-window-configuration ()
"Restore the window config if available."
(remove-hook 'pre-command-hook
'slime-complete-maybe-restore-window-configuration)
(when (and slime-complete-saved-window-configuration
(slime-completion-window-active-p))
(save-excursion (set-window-configuration
slime-complete-saved-window-configuration))
(setq slime-complete-saved-window-configuration nil)
(when (buffer-live-p slime-completions-buffer-name)
(kill-buffer slime-completions-buffer-name))))
(defun slime-complete-maybe-restore-window-configuration ()
"Restore the window configuration, if the following command
terminates a current completion."
(remove-hook 'pre-command-hook
'slime-complete-maybe-restore-window-configuration)
(condition-case err
(cond ((cl-find last-command-event "()\"'`,# \r\n:")
(slime-complete-restore-window-configuration))
((not (slime-completion-window-active-p))
(slime-complete-forget-window-configuration))
(t
(slime-complete-delay-restoration)))
(error
;; Because this is called on the pre-command-hook, we mustn't let
;; errors propagate.
(message "Error in slime-complete-restore-window-configuration: %S"
err))))
(defun slime-completion-window-active-p ()
"Is the completion window currently active?"
(and (window-live-p slime-completions-window)
(equal (buffer-name (window-buffer slime-completions-window))
slime-completions-buffer-name)))
(defun slime-display-completion-list (completions base)
(let ((savedp (slime-complete-maybe-save-window-configuration)))
(with-output-to-temp-buffer slime-completions-buffer-name
(display-completion-list completions)
(let ((offset (- (point) 1 (length base))))
(with-current-buffer standard-output
(setq completion-base-position offset)
(set-syntax-table lisp-mode-syntax-table))))
(when savedp
(setq slime-completions-window
(get-buffer-window slime-completions-buffer-name)))))
(defun slime-display-or-scroll-completions (completions base)
(cond ((and (eq last-command this-command)
(slime-completion-window-active-p))
(slime-scroll-completions))
(t
(slime-display-completion-list completions base)))
(slime-complete-delay-restoration))
(defun slime-scroll-completions ()
(let ((window slime-completions-window))
(with-current-buffer (window-buffer window)
(if (pos-visible-in-window-p (point-max) window)
(set-window-start window (point-min))
(save-selected-window
(select-window window)
(scroll-up))))))
(defun slime-minibuffer-respecting-message (format &rest format-args)
"Display TEXT as a message, without hiding any minibuffer contents."
(let ((text (format " [%s]" (apply #'format format format-args))))
(if (minibuffer-window-active-p (minibuffer-window))
(minibuffer-message text)
(message "%s" text))))
(defun slime-maybe-complete-as-filename ()
"If point is at a string starting with \", complete it as filename.
Return nil if point is not at filename."
(when (save-excursion (re-search-backward "\"[^ \t\n]+\\="
(max (point-min)
(- (point) 1000)) t))
(let ((comint-completion-addsuffix '("/" . "\"")))
(comint-replace-by-expanded-filename)
t)))
(defun slime-complete-symbol* ()
"Expand abbreviations and complete the symbol at point."
;; NB: It is only the name part of the symbol that we actually want
;; to complete -- the package prefix, if given, is just context.
(or (slime-maybe-complete-as-filename)
(slime-expand-abbreviations-and-complete)))
(defun slime-c-p-c-completion-at-point ()
#'slime-complete-symbol*)
;; FIXME: factorize
(defun slime-expand-abbreviations-and-complete ()
(let* ((end (move-marker (make-marker) (slime-symbol-end-pos)))
(beg (move-marker (make-marker) (slime-symbol-start-pos)))
(prefix (buffer-substring-no-properties beg end))
(completion-result (slime-contextual-completions beg end))
(completion-set (cl-first completion-result))
(completed-prefix (cl-second completion-result)))
(if (null completion-set)
(progn (slime-minibuffer-respecting-message
"Can't find completion for \"%s\"" prefix)
(ding)
(slime-complete-restore-window-configuration))
;; some XEmacs issue makes this distinction necessary
(cond ((> (length completed-prefix) (- end beg))
(goto-char end)
(insert-and-inherit completed-prefix)
(delete-region beg end)
(goto-char (+ beg (length completed-prefix))))
(t nil))
(cond ((and (member completed-prefix completion-set)
(slime-length= completion-set 1))
(slime-minibuffer-respecting-message "Sole completion")
(when slime-complete-symbol*-fancy
(slime-complete-symbol*-fancy-bit))
(slime-complete-restore-window-configuration))
;; Incomplete
(t
(when (member completed-prefix completion-set)
(slime-minibuffer-respecting-message
"Complete but not unique"))
(when slime-c-p-c-unambiguous-prefix-p
(let ((unambiguous-completion-length
(cl-loop for c in completion-set
minimizing (or (cl-mismatch completed-prefix c)
(length completed-prefix)))))
(goto-char (+ beg unambiguous-completion-length))))
(slime-display-or-scroll-completions completion-set
completed-prefix))))))
(defun slime-complete-symbol*-fancy-bit ()
"Do fancy tricks after completing a symbol.
\(Insert a space or close-paren based on arglist information.)"
(let ((arglist (slime-retrieve-arglist (slime-symbol-at-point))))
(unless (eq arglist :not-available)
(let ((args
;; Don't intern these symbols
(let ((obarray (make-vector 10 0)))
(cdr (read arglist))))
(function-call-position-p
(save-excursion
(backward-sexp)
(equal (char-before) ?\())))
(when function-call-position-p
(if (null args)
(execute-kbd-macro ")")
(execute-kbd-macro " ")
(when (and (slime-background-activities-enabled-p)
(not (minibuffer-window-active-p (minibuffer-window))))
(slime-echo-arglist))))))))
(cl-defun slime-contextual-completions (beg end)
"Return a list of completions of the token from BEG to END in the
current buffer."
(let ((token (buffer-substring-no-properties beg end)))
(cond
((and (< beg (point-max))
(string= (buffer-substring-no-properties beg (1+ beg)) ":"))
;; Contextual keyword completion
(let ((completions
(slime-completions-for-keyword token
(save-excursion
(goto-char beg)
(slime-parse-form-upto-point)))))
(when (cl-first completions)
(cl-return-from slime-contextual-completions completions))
;; If no matching keyword was found, do regular symbol
;; completion.
))
((and (>= (length token) 2)
(string= (cl-subseq token 0 2) "#\\"))
;; Character name completion
(cl-return-from slime-contextual-completions
(slime-completions-for-character token))))
;; Regular symbol completion
(slime-completions token)))
(defun slime-completions (prefix)
(slime-eval `(swank:completions ,prefix ',(slime-current-package))))
(defun slime-completions-for-keyword (prefix buffer-form)
(slime-eval `(swank:completions-for-keyword ,prefix ',buffer-form)))
(defun slime-completions-for-character (prefix)
(cl-labels ((append-char-syntax (string) (concat "#\\" string)))
(let ((result (slime-eval `(swank:completions-for-character
,(cl-subseq prefix 2)))))
(when (car result)
(list (mapcar #'append-char-syntax (car result))
(append-char-syntax (cadr result)))))))
;;; Complete form
(defun slime-complete-form ()
"Complete the form at point.
This is a superset of the functionality of `slime-insert-arglist'."
(interactive)
;; Find the (possibly incomplete) form around point.
(let ((buffer-form (slime-parse-form-upto-point)))
(let ((result (slime-eval `(swank:complete-form ',buffer-form))))
(if (eq result :not-available)
(error "Could not generate completion for the form `%s'" buffer-form)
(progn
(just-one-space (if (looking-back "\\s(" (1- (point)))
0
1))
(save-excursion
(insert result)
(let ((slime-close-parens-limit 1))
(slime-close-all-parens-in-sexp)))
(save-excursion
(backward-up-list 1)
(indent-sexp)))))))
(provide 'slime-c-p-c)

BIN
elpa/slime-20180413.1720/contrib/slime-c-p-c.elc Normal file
View File

Binary file not shown.

1798
elpa/slime-20180413.1720/contrib/slime-cl-indent.el Normal file
View File

File diff suppressed because it is too large Load Diff

BIN
elpa/slime-20180413.1720/contrib/slime-cl-indent.elc Normal file
View File

Binary file not shown.

172
elpa/slime-20180413.1720/contrib/slime-clipboard.el Normal file
View File

@@ -0,0 +1,172 @@
(require 'slime)
(require 'slime-repl)
(require 'cl-lib)
(eval-when-compile
(require 'cl)) ; lexical-let
(define-slime-contrib slime-clipboard
"This add a few commands to put objects into a clipboard and to
insert textual references to those objects.
The clipboard command prefix is C-c @.
C-c @ + adds an object to the clipboard
C-c @ @ inserts a reference to an object in the clipboard
C-c @ ? displays the clipboard
This package also also binds the + key in the inspector and
debugger to add the object at point to the clipboard."
(:authors "Helmut Eller <heller@common-lisp.net>")
(:license "GPL")
(:swank-dependencies swank-clipboard))
(define-derived-mode slime-clipboard-mode fundamental-mode
"Slime-Clipboard"
"SLIME Clipboad Mode.
\\{slime-clipboard-mode-map}")
(slime-define-keys slime-clipboard-mode-map
("g" 'slime-clipboard-redisplay)
((kbd "C-k") 'slime-clipboard-delete-entry)
("i" 'slime-clipboard-inspect))
(defvar slime-clipboard-map (make-sparse-keymap))
(slime-define-keys slime-clipboard-map
("?" 'slime-clipboard-display)
("+" 'slime-clipboard-add)
("@" 'slime-clipboard-ref))
(define-key slime-mode-map (kbd "C-c @") slime-clipboard-map)
(define-key slime-repl-mode-map (kbd "C-c @") slime-clipboard-map)
(slime-define-keys slime-inspector-mode-map
("+" 'slime-clipboard-add-from-inspector))
(slime-define-keys sldb-mode-map
("+" 'slime-clipboard-add-from-sldb))
(defun slime-clipboard-add (exp package)
"Add an object to the clipboard."
(interactive (list (slime-read-from-minibuffer
"Add to clipboard (evaluated): "
(slime-sexp-at-point))
(slime-current-package)))
(slime-clipboard-add-internal `(:string ,exp ,package)))
(defun slime-clipboard-add-internal (datum)
(slime-eval-async `(swank-clipboard:add ',datum)
(lambda (result) (message "%s" result))))
(defun slime-clipboard-display ()
"Display the content of the clipboard."
(interactive)
(slime-eval-async `(swank-clipboard:entries)
#'slime-clipboard-display-entries))
(defun slime-clipboard-display-entries (entries)
(slime-with-popup-buffer ((slime-buffer-name :clipboard)
:mode 'slime-clipboard-mode)
(slime-clipboard-insert-entries entries)))
(defun slime-clipboard-insert-entries (entries)
(let ((fstring "%2s %3s %s\n"))
(insert (format fstring "Nr" "Id" "Value")
(format fstring "--" "--" "-----" ))
(save-excursion
(cl-loop for i from 0 for (ref . value) in entries do
(slime-insert-propertized `(slime-clipboard-entry ,i
slime-clipboard-ref ,ref)
(format fstring i ref value))))))
(defun slime-clipboard-redisplay ()
"Update the clipboard buffer."
(interactive)
(lexical-let ((saved (point)))
(slime-eval-async
`(swank-clipboard:entries)
(lambda (entries)
(let ((inhibit-read-only t))
(erase-buffer)
(slime-clipboard-insert-entries entries)
(when (< saved (point-max))
(goto-char saved)))))))
(defun slime-clipboard-entry-at-point ()
(or (get-text-property (point) 'slime-clipboard-entry)
(error "No clipboard entry at point")))
(defun slime-clipboard-ref-at-point ()
(or (get-text-property (point) 'slime-clipboard-ref)
(error "No clipboard ref at point")))
(defun slime-clipboard-inspect (&optional entry)
"Inspect the current clipboard entry."
(interactive (list (slime-clipboard-ref-at-point)))
(slime-inspect (prin1-to-string `(swank-clipboard::clipboard-ref ,entry))))
(defun slime-clipboard-delete-entry (&optional entry)
"Delete the current entry from the clipboard."
(interactive (list (slime-clipboard-entry-at-point)))
(slime-eval-async `(swank-clipboard:delete-entry ,entry)
(lambda (result)
(slime-clipboard-redisplay)
(message "%s" result))))
(defun slime-clipboard-ref ()
"Ask for a clipboard entry number and insert a reference to it."
(interactive)
(slime-clipboard-read-entry-number #'slime-clipboard-insert-ref))
;; insert a reference to clipboard entry ENTRY at point. The text
;; receives a special 'display property to make it look nicer. We
;; remove this property in a modification when a user tries to modify
;; he real text.
(defun slime-clipboard-insert-ref (entry)
(cl-destructuring-bind (ref . string)
(slime-eval `(swank-clipboard:entry-to-ref ,entry))
(slime-insert-propertized
`(display ,(format "#@%d%s" ref string)
modification-hooks (slime-clipboard-ref-modified)
rear-nonsticky t)
(format "(swank-clipboard::clipboard-ref %d)" ref))))
(defun slime-clipboard-ref-modified (start end)
(when (get-text-property start 'display)
(let ((inhibit-modification-hooks t))
(save-excursion
(goto-char start)
(cl-destructuring-bind (dstart dend) (slime-property-bounds 'display)
(unless (and (= start dstart) (= end dend))
(remove-list-of-text-properties
dstart dend '(display modification-hooks))))))))
;; Read a entry number.
;; Written in CPS because the display the clipboard before reading.
(defun slime-clipboard-read-entry-number (k)
(slime-eval-async
`(swank-clipboard:entries)
(slime-rcurry
(lambda (entries window-config k)
(slime-clipboard-display-entries entries)
(let ((entry (unwind-protect
(read-from-minibuffer "Entry number: " nil nil t)
(set-window-configuration window-config))))
(funcall k entry)))
(current-window-configuration)
k)))
(defun slime-clipboard-add-from-inspector ()
(interactive)
(let ((part (or (get-text-property (point) 'slime-part-number)
(error "No part at point"))))
(slime-clipboard-add-internal `(:inspector ,part))))
(defun slime-clipboard-add-from-sldb ()
(interactive)
(slime-clipboard-add-internal
`(:sldb ,(sldb-frame-number-at-point)
,(sldb-var-number-at-point))))
(provide 'slime-clipboard)

BIN
elpa/slime-20180413.1720/contrib/slime-clipboard.elc Normal file
View File

Binary file not shown.

184
elpa/slime-20180413.1720/contrib/slime-compiler-notes-tree.el Normal file
View File

@@ -0,0 +1,184 @@
(require 'slime)
(require 'cl-lib)
(define-slime-contrib slime-compiler-notes-tree
"Display compiler messages in tree layout.
M-x slime-list-compiler-notes display the compiler notes in a tree
grouped by severity.
`slime-maybe-list-compiler-notes' can be used as
`slime-compilation-finished-hook'.
"
(:authors "Helmut Eller <heller@common-lisp.net>")
(:license "GPL"))
(defun slime-maybe-list-compiler-notes (notes)
"Show the compiler notes if appropriate."
;; don't pop up a buffer if all notes are already annotated in the
;; buffer itself
(unless (cl-every #'slime-note-has-location-p notes)
(slime-list-compiler-notes notes)))
(defun slime-list-compiler-notes (notes)
"Show the compiler notes NOTES in tree view."
(interactive (list (slime-compiler-notes)))
(with-temp-message "Preparing compiler note tree..."
(slime-with-popup-buffer ((slime-buffer-name :notes)
:mode 'slime-compiler-notes-mode)
(when (null notes)
(insert "[no notes]"))
(let ((collapsed-p))
(dolist (tree (slime-compiler-notes-to-tree notes))
(when (slime-tree.collapsed-p tree) (setf collapsed-p t))
(slime-tree-insert tree "")
(insert "\n"))
(goto-char (point-min))))))
(defvar slime-tree-printer 'slime-tree-default-printer)
(defun slime-tree-for-note (note)
(make-slime-tree :item (slime-note.message note)
:plist (list 'note note)
:print-fn slime-tree-printer))
(defun slime-tree-for-severity (severity notes collapsed-p)
(make-slime-tree :item (format "%s (%d)"
(slime-severity-label severity)
(length notes))
:kids (mapcar #'slime-tree-for-note notes)
:collapsed-p collapsed-p))
(defun slime-compiler-notes-to-tree (notes)
(let* ((alist (slime-alistify notes #'slime-note.severity #'eq))
(collapsed-p (slime-length> alist 1)))
(cl-loop for (severity . notes) in alist
collect (slime-tree-for-severity severity notes
collapsed-p))))
(defvar slime-compiler-notes-mode-map)
(define-derived-mode slime-compiler-notes-mode fundamental-mode
"Compiler-Notes"
"\\<slime-compiler-notes-mode-map>\
\\{slime-compiler-notes-mode-map}
\\{slime-popup-buffer-mode-map}
"
(slime-set-truncate-lines))
(slime-define-keys slime-compiler-notes-mode-map
((kbd "RET") 'slime-compiler-notes-default-action-or-show-details)
([return] 'slime-compiler-notes-default-action-or-show-details)
([mouse-2] 'slime-compiler-notes-default-action-or-show-details/mouse))
(defun slime-compiler-notes-default-action-or-show-details/mouse (event)
"Invoke the action pointed at by the mouse, or show details."
(interactive "e")
(cl-destructuring-bind (mouse-2 (w pos &rest _) &rest __) event
(save-excursion
(goto-char pos)
(let ((fn (get-text-property (point)
'slime-compiler-notes-default-action)))
(if fn (funcall fn) (slime-compiler-notes-show-details))))))
(defun slime-compiler-notes-default-action-or-show-details ()
"Invoke the action at point, or show details."
(interactive)
(let ((fn (get-text-property (point) 'slime-compiler-notes-default-action)))
(if fn (funcall fn) (slime-compiler-notes-show-details))))
(defun slime-compiler-notes-show-details ()
(interactive)
(let* ((tree (slime-tree-at-point))
(note (plist-get (slime-tree.plist tree) 'note))
(inhibit-read-only t))
(cond ((not (slime-tree-leaf-p tree))
(slime-tree-toggle tree))
(t
(slime-show-source-location (slime-note.location note) t)))))
;;;;;; Tree Widget
(cl-defstruct (slime-tree (:conc-name slime-tree.))
item
(print-fn #'slime-tree-default-printer :type function)
(kids '() :type list)
(collapsed-p t :type boolean)
(prefix "" :type string)
(start-mark nil)
(end-mark nil)
(plist '() :type list))
(defun slime-tree-leaf-p (tree)
(not (slime-tree.kids tree)))
(defun slime-tree-default-printer (tree)
(princ (slime-tree.item tree) (current-buffer)))
(defun slime-tree-decoration (tree)
(cond ((slime-tree-leaf-p tree) "-- ")
((slime-tree.collapsed-p tree) "[+] ")
(t "-+ ")))
(defun slime-tree-insert-list (list prefix)
"Insert a list of trees."
(cl-loop for (elt . rest) on list
do (cond (rest
(insert prefix " |")
(slime-tree-insert elt (concat prefix " |"))
(insert "\n"))
(t
(insert prefix " `")
(slime-tree-insert elt (concat prefix " "))))))
(defun slime-tree-insert-decoration (tree)
(insert (slime-tree-decoration tree)))
(defun slime-tree-indent-item (start end prefix)
"Insert PREFIX at the beginning of each but the first line.
This is used for labels spanning multiple lines."
(save-excursion
(goto-char end)
(beginning-of-line)
(while (< start (point))
(insert-before-markers prefix)
(forward-line -1))))
(defun slime-tree-insert (tree prefix)
"Insert TREE prefixed with PREFIX at point."
(with-struct (slime-tree. print-fn kids collapsed-p start-mark end-mark) tree
(let ((line-start (line-beginning-position)))
(setf start-mark (point-marker))
(slime-tree-insert-decoration tree)
(funcall print-fn tree)
(slime-tree-indent-item start-mark (point) (concat prefix " "))
(add-text-properties line-start (point) (list 'slime-tree tree))
(set-marker-insertion-type start-mark t)
(when (and kids (not collapsed-p))
(terpri (current-buffer))
(slime-tree-insert-list kids prefix))
(setf (slime-tree.prefix tree) prefix)
(setf end-mark (point-marker)))))
(defun slime-tree-at-point ()
(cond ((get-text-property (point) 'slime-tree))
(t (error "No tree at point"))))
(defun slime-tree-delete (tree)
"Delete the region for TREE."
(delete-region (slime-tree.start-mark tree)
(slime-tree.end-mark tree)))
(defun slime-tree-toggle (tree)
"Toggle the visibility of TREE's children."
(with-struct (slime-tree. collapsed-p start-mark end-mark prefix) tree
(setf collapsed-p (not collapsed-p))
(slime-tree-delete tree)
(insert-before-markers " ") ; move parent's end-mark
(backward-char 1)
(slime-tree-insert tree prefix)
(delete-char 1)
(goto-char start-mark)))
(provide 'slime-compiler-notes-tree)

BIN
elpa/slime-20180413.1720/contrib/slime-compiler-notes-tree.elc Normal file
View File

Binary file not shown.

183
elpa/slime-20180413.1720/contrib/slime-editing-commands.el Normal file
View File

@@ -0,0 +1,183 @@
(require 'slime)
(require 'slime-repl)
(require 'cl-lib)
(define-slime-contrib slime-editing-commands
"Editing commands without server interaction."
(:authors "Thomas F. Burdick <tfb@OCF.Berkeley.EDU>"
"Luke Gorrie <luke@synap.se>"
"Bill Clementson <billclem@gmail.com>"
"Tobias C. Rittweiler <tcr@freebits.de>")
(:license "GPL")
(:on-load
(define-key slime-mode-map "\M-\C-a" 'slime-beginning-of-defun)
(define-key slime-mode-map "\M-\C-e" 'slime-end-of-defun)
(define-key slime-mode-map "\C-c\M-q" 'slime-reindent-defun)
(define-key slime-mode-map "\C-c\C-]" 'slime-close-all-parens-in-sexp)))
(defun slime-beginning-of-defun ()
(interactive)
(if (and (boundp 'slime-repl-input-start-mark)
slime-repl-input-start-mark)
(slime-repl-beginning-of-defun)
(let ((this-command 'beginning-of-defun)) ; needed for push-mark
(call-interactively 'beginning-of-defun))))
(defun slime-end-of-defun ()
(interactive)
(if (eq major-mode 'slime-repl-mode)
(slime-repl-end-of-defun)
(end-of-defun)))
(defvar slime-comment-start-regexp
"\\(\\(^\\|[^\n\\\\]\\)\\([\\\\][\\\\]\\)*\\);+[ \t]*"
"Regexp to match the start of a comment.")
(defun slime-beginning-of-comment ()
"Move point to beginning of comment.
If point is inside a comment move to beginning of comment and return point.
Otherwise leave point unchanged and return NIL."
(let ((boundary (point)))
(beginning-of-line)
(cond ((re-search-forward slime-comment-start-regexp boundary t)
(point))
(t (goto-char boundary)
nil))))
(defvar slime-close-parens-limit nil
"Maxmimum parens for `slime-close-all-sexp' to insert. NIL
means to insert as many parentheses as necessary to correctly
close the form.")
(defun slime-close-all-parens-in-sexp (&optional region)
"Balance parentheses of open s-expressions at point.
Insert enough right parentheses to balance unmatched left parentheses.
Delete extra left parentheses. Reformat trailing parentheses
Lisp-stylishly.
If REGION is true, operate on the region. Otherwise operate on
the top-level sexp before point."
(interactive "P")
(let ((sexp-level 0)
point)
(save-excursion
(save-restriction
(when region
(narrow-to-region (region-beginning) (region-end))
(goto-char (point-max)))
;; skip over closing parens, but not into comment
(skip-chars-backward ") \t\n")
(when (slime-beginning-of-comment)
(forward-line)
(skip-chars-forward " \t"))
(setq point (point))
;; count sexps until either '(' or comment is found at first column
(while (and (not (looking-at "^[(;]"))
(ignore-errors (backward-up-list 1) t))
(incf sexp-level))))
(when (> sexp-level 0)
;; insert correct number of right parens
(goto-char point)
(dotimes (i sexp-level) (insert ")"))
;; delete extra right parens
(setq point (point))
(skip-chars-forward " \t\n)")
(skip-chars-backward " \t\n")
(let* ((deleted-region (delete-and-extract-region point (point)))
(deleted-text (substring-no-properties deleted-region))
(prior-parens-count (cl-count ?\) deleted-text)))
;; Remember: we always insert as many parentheses as necessary
;; and only afterwards delete the superfluously-added parens.
(when slime-close-parens-limit
(let ((missing-parens (- sexp-level prior-parens-count
slime-close-parens-limit)))
(dotimes (i (max 0 missing-parens))
(delete-char -1))))))))
(defun slime-insert-balanced-comments (arg)
"Insert a set of balanced comments around the s-expression
containing the point. If this command is invoked repeatedly
\(without any other command occurring between invocations), the
comment progressively moves outward over enclosing expressions.
If invoked with a positive prefix argument, the s-expression arg
expressions out is enclosed in a set of balanced comments."
(interactive "*p")
(save-excursion
(when (eq last-command this-command)
(when (search-backward "#|" nil t)
(save-excursion
(delete-char 2)
(while (and (< (point) (point-max)) (not (looking-at " *|#")))
(forward-sexp))
(replace-match ""))))
(while (> arg 0)
(backward-char 1)
(cond ((looking-at ")") (incf arg))
((looking-at "(") (decf arg))))
(insert "#|")
(forward-sexp)
(insert "|#")))
(defun slime-remove-balanced-comments ()
"Remove a set of balanced comments enclosing point."
(interactive "*")
(save-excursion
(when (search-backward "#|" nil t)
(delete-char 2)
(while (and (< (point) (point-max)) (not (looking-at " *|#")))
(forward-sexp))
(replace-match ""))))
;; SLIME-CLOSE-PARENS-AT-POINT is obsolete:
;; It doesn't work correctly on the REPL, because there
;; BEGINNING-OF-DEFUN-FUNCTION and END-OF-DEFUN-FUNCTION is bound to
;; SLIME-REPL-MODE-BEGINNING-OF-DEFUN (and
;; SLIME-REPL-MODE-END-OF-DEFUN respectively) which compromises the
;; way how they're expect to work (i.e. END-OF-DEFUN does not signal
;; an UNBOUND-PARENTHESES error.)
;; Use SLIME-CLOSE-ALL-PARENS-IN-SEXP instead.
;; (defun slime-close-parens-at-point ()
;; "Close parenthesis at point to complete the top-level-form. Simply
;; inserts ')' characters at point until `beginning-of-defun' and
;; `end-of-defun' execute without errors, or `slime-close-parens-limit'
;; is exceeded."
;; (interactive)
;; (loop for i from 1 to slime-close-parens-limit
;; until (save-excursion
;; (slime-beginning-of-defun)
;; (ignore-errors (slime-end-of-defun) t))
;; do (insert ")")))
(defun slime-reindent-defun (&optional force-text-fill)
"Reindent the current defun, or refill the current paragraph.
If point is inside a comment block, the text around point will be
treated as a paragraph and will be filled with `fill-paragraph'.
Otherwise, it will be treated as Lisp code, and the current defun
will be reindented. If the current defun has unbalanced parens,
an attempt will be made to fix it before reindenting.
When given a prefix argument, the text around point will always
be treated as a paragraph. This is useful for filling docstrings."
(interactive "P")
(save-excursion
(if (or force-text-fill (slime-beginning-of-comment))
(fill-paragraph nil)
(let ((start (progn (unless (or (and (zerop (current-column))
(eq ?\( (char-after)))
(and slime-repl-input-start-mark
(slime-repl-at-prompt-start-p)))
(slime-beginning-of-defun))
(point)))
(end (ignore-errors (slime-end-of-defun) (point))))
(unless end
(forward-paragraph)
(slime-close-all-parens-in-sexp)
(slime-end-of-defun)
(setf end (point)))
(indent-region start end nil)))))
(provide 'slime-editing-commands)

BIN
elpa/slime-20180413.1720/contrib/slime-editing-commands.elc Normal file
View File

Binary file not shown.

226
elpa/slime-20180413.1720/contrib/slime-enclosing-context.el Normal file
View File

@@ -0,0 +1,226 @@
(require 'slime)
(require 'slime-parse)
(require 'cl-lib)
(define-slime-contrib slime-enclosing-context
"Utilities on top of slime-parse."
(:authors "Tobias C. Rittweiler <tcr@freebits.de>")
(:license "GPL"))
(defun slime-parse-sexp-at-point (&optional n)
"Returns the sexps at point as a list of strings, otherwise nil.
\(If there are not as many sexps as N, a list with < N sexps is
returned.\)
If SKIP-BLANKS-P is true, leading whitespaces &c are skipped.
"
(interactive "p") (or n (setq n 1))
(save-excursion
(let ((result nil))
(dotimes (i n)
;; Is there an additional sexp in front of us?
(save-excursion
(unless (slime-point-moves-p (ignore-errors (forward-sexp)))
(cl-return)))
(push (slime-sexp-at-point) result)
;; Skip current sexp
(ignore-errors (forward-sexp) (skip-chars-forward "[:space:]")))
(nreverse result))))
(defun slime-has-symbol-syntax-p (string)
(if (and string (not (zerop (length string))))
(member (char-syntax (aref string 0))
'(?w ?_ ?\' ?\\))))
(defun slime-beginning-of-string ()
(let* ((parser-state (slime-current-parser-state))
(inside-string-p (nth 3 parser-state))
(string-start-pos (nth 8 parser-state)))
(if inside-string-p
(goto-char string-start-pos)
(error "We're not within a string"))))
(defun slime-enclosing-form-specs (&optional max-levels)
"Return the list of ``raw form specs'' of all the forms
containing point from right to left.
As a secondary value, return a list of indices: Each index tells
for each corresponding form spec in what argument position the
user's point is.
As tertiary value, return the positions of the operators that are
contained in the returned form specs.
When MAX-LEVELS is non-nil, go up at most this many levels of
parens.
\(See SWANK::PARSE-FORM-SPEC for more information about what
exactly constitutes a ``raw form specs'')
Examples:
A return value like the following
(values ((\"quux\") (\"bar\") (\"foo\")) (3 2 1) (p1 p2 p3))
can be interpreted as follows:
The user point is located in the 3rd argument position of a
form with the operator name \"quux\" (which starts at P1.)
This form is located in the 2nd argument position of a form
with the operator name \"bar\" (which starts at P2.)
This form again is in the 1st argument position of a form
with the operator name \"foo\" (which itself begins at P3.)
For instance, the corresponding buffer content could have looked
like `(foo (bar arg1 (quux 1 2 |' where `|' denotes point.
"
(let ((level 1)
(parse-sexp-lookup-properties nil)
(initial-point (point))
(result '()) (arg-indices '()) (points '()))
;; The expensive lookup of syntax-class text properties is only
;; used for interactive balancing of #<...> in presentations; we
;; do not need them in navigating through the nested lists.
;; This speeds up this function significantly.
(ignore-errors
(save-excursion
;; Make sure we get the whole thing at point.
(if (not (slime-inside-string-p))
(slime-end-of-symbol)
(slime-beginning-of-string)
(forward-sexp))
(save-restriction
;; Don't parse more than 20000 characters before point, so we don't spend
;; too much time.
(narrow-to-region (max (point-min) (- (point) 20000)) (point-max))
(narrow-to-region (save-excursion (beginning-of-defun) (point))
(min (1+ (point)) (point-max)))
(while (or (not max-levels)
(<= level max-levels))
(let ((arg-index 0))
;; Move to the beginning of the current sexp if not already there.
(if (or (and (char-after)
(member (char-syntax (char-after)) '(?\( ?')))
(member (char-syntax (char-before)) '(?\ ?>)))
(cl-incf arg-index))
(ignore-errors (backward-sexp 1))
(while (and (< arg-index 64)
(ignore-errors (backward-sexp 1)
(> (point) (point-min))))
(cl-incf arg-index))
(backward-up-list 1)
(when (member (char-syntax (char-after)) '(?\( ?'))
(cl-incf level)
(forward-char 1)
(let ((name (slime-symbol-at-point)))
(push (and name `(,name)) result)
(push arg-index arg-indices)
(push (point) points))
(backward-up-list 1)))))))
(cl-values
(nreverse result)
(nreverse arg-indices)
(nreverse points))))
(defvar slime-variable-binding-ops-alist
'((let &bindings &body)
(let* &bindings &body)))
(defvar slime-function-binding-ops-alist
'((flet &bindings &body)
(labels &bindings &body)
(macrolet &bindings &body)))
(defun slime-lookup-binding-op (op &optional binding-type)
(cl-labels ((lookup-in (list) (cl-assoc op list :test 'cl-equalp :key 'symbol-name)))
(cond ((eq binding-type :variable) (lookup-in slime-variable-binding-ops-alist))
((eq binding-type :function) (lookup-in slime-function-binding-ops-alist))
(t (or (lookup-in slime-variable-binding-ops-alist)
(lookup-in slime-function-binding-ops-alist))))))
(defun slime-binding-op-p (op &optional binding-type)
(and (slime-lookup-binding-op op binding-type) t))
(defun slime-binding-op-body-pos (op)
(let ((special-lambda-list (slime-lookup-binding-op op)))
(if special-lambda-list (cl-position '&body special-lambda-list))))
(defun slime-binding-op-bindings-pos (op)
(let ((special-lambda-list (slime-lookup-binding-op op)))
(if special-lambda-list (cl-position '&bindings special-lambda-list))))
(defun slime-enclosing-bound-names ()
"Returns all bound function names as first value, and the
points where their bindings are established as second value."
(cl-multiple-value-call #'slime-find-bound-names
(slime-enclosing-form-specs)))
(defun slime-find-bound-names (ops indices points)
(let ((binding-names) (binding-start-points))
(save-excursion
(cl-loop for (op . nil) in ops
for index in indices
for point in points
do (when (and (slime-binding-op-p op)
;; Are the bindings of OP in scope?
(>= index (slime-binding-op-body-pos op)))
(goto-char point)
(forward-sexp (slime-binding-op-bindings-pos op))
(down-list)
(ignore-errors
(cl-loop
(down-list)
(push (slime-symbol-at-point) binding-names)
(push (save-excursion (backward-up-list) (point))
binding-start-points)
(up-list)))))
(cl-values (nreverse binding-names) (nreverse binding-start-points)))))
(defun slime-enclosing-bound-functions ()
(cl-multiple-value-call #'slime-find-bound-functions
(slime-enclosing-form-specs)))
(defun slime-find-bound-functions (ops indices points)
(let ((names) (arglists) (start-points))
(save-excursion
(cl-loop for (op . nil) in ops
for index in indices
for point in points
do (when (and (slime-binding-op-p op :function)
;; Are the bindings of OP in scope?
(>= index (slime-binding-op-body-pos op)))
(goto-char point)
(forward-sexp (slime-binding-op-bindings-pos op))
(down-list)
;; If we're at the end of the bindings, an error will
;; be signalled by the `down-list' below.
(ignore-errors
(cl-loop
(down-list)
(cl-destructuring-bind (name arglist)
(slime-parse-sexp-at-point 2)
(cl-assert (slime-has-symbol-syntax-p name))
(cl-assert arglist)
(push name names)
(push arglist arglists)
(push (save-excursion (backward-up-list) (point))
start-points))
(up-list)))))
(cl-values (nreverse names)
(nreverse arglists)
(nreverse start-points)))))
(defun slime-enclosing-bound-macros ()
(cl-multiple-value-call #'slime-find-bound-macros
(slime-enclosing-form-specs)))
(defun slime-find-bound-macros (ops indices points)
;; Kludgy!
(let ((slime-function-binding-ops-alist '((macrolet &bindings &body))))
(slime-find-bound-functions ops indices points)))
(provide 'slime-enclosing-context)

BIN
elpa/slime-20180413.1720/contrib/slime-enclosing-context.elc Normal file
View File

Binary file not shown.

42
elpa/slime-20180413.1720/contrib/slime-fancy-inspector.el Normal file
View File

@@ -0,0 +1,42 @@
(eval-and-compile
(require 'slime))
(define-slime-contrib slime-fancy-inspector
"Fancy inspector for CLOS objects."
(:authors "Marco Baringer <mb@bese.it> and others")
(:license "GPL")
(:slime-dependencies slime-parse)
(:swank-dependencies swank-fancy-inspector)
(:on-load
(add-hook 'slime-edit-definition-hooks 'slime-edit-inspector-part))
(:on-unload
(remove-hook 'slime-edit-definition-hooks 'slime-edit-inspector-part)))
(defun slime-inspect-definition ()
"Inspect definition at point"
(interactive)
(slime-inspect (slime-definition-at-point)))
(defun slime-disassemble-definition ()
"Disassemble definition at point"
(interactive)
(slime-eval-describe `(swank:disassemble-form
,(slime-definition-at-point t))))
(defun slime-edit-inspector-part (name &optional where)
(and (eq major-mode 'slime-inspector-mode)
(cl-destructuring-bind (&optional property value)
(slime-inspector-property-at-point)
(when (eq property 'slime-part-number)
(let ((location (slime-eval `(swank:find-definition-for-thing
(swank:inspector-nth-part ,value))))
(name (format "Inspector part %s" value)))
(when (and (consp location)
(not (eq (car location) :error)))
(slime-edit-definition-cont
(list (make-slime-xref :dspec `(,name)
:location location))
name
where)))))))
(provide 'slime-fancy-inspector)

BIN
elpa/slime-20180413.1720/contrib/slime-fancy-inspector.elc Normal file
View File

Binary file not shown.

68
elpa/slime-20180413.1720/contrib/slime-fancy-trace.el Normal file
View File

@@ -0,0 +1,68 @@
(eval-and-compile
(require 'slime))
(define-slime-contrib slime-fancy-trace
"Enhanced version of slime-trace capable of tracing local functions,
methods, setf functions, and other entities supported by specific
swank:swank-toggle-trace backends. Invoke via C-u C-t."
(:authors "Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de>"
"Tobias C. Rittweiler <tcr@freebits.de>")
(:license "GPL")
(:slime-dependencies slime-parse))
(defun slime-trace-query (spec)
"Ask the user which function to trace; SPEC is the default.
The result is a string."
(cond ((null spec)
(slime-read-from-minibuffer "(Un)trace: "))
((stringp spec)
(slime-read-from-minibuffer "(Un)trace: " spec))
((symbolp spec) ; `slime-extract-context' can return symbols.
(slime-read-from-minibuffer "(Un)trace: " (prin1-to-string spec)))
(t
(slime-dcase spec
((setf n)
(slime-read-from-minibuffer "(Un)trace: " (prin1-to-string spec)))
((:defun n)
(slime-read-from-minibuffer "(Un)trace: " (prin1-to-string n)))
((:defgeneric n)
(let* ((name (prin1-to-string n))
(answer (slime-read-from-minibuffer "(Un)trace: " name)))
(cond ((and (string= name answer)
(y-or-n-p (concat "(Un)trace also all "
"methods implementing "
name "? ")))
(prin1-to-string `(:defgeneric ,n)))
(t
answer))))
((:defmethod &rest _)
(slime-read-from-minibuffer "(Un)trace: " (prin1-to-string spec)))
((:call caller callee)
(let* ((callerstr (prin1-to-string caller))
(calleestr (prin1-to-string callee))
(answer (slime-read-from-minibuffer "(Un)trace: "
calleestr)))
(cond ((and (string= calleestr answer)
(y-or-n-p (concat "(Un)trace only when " calleestr
" is called by " callerstr "? ")))
(prin1-to-string `(:call ,caller ,callee)))
(t
answer))))
(((:labels :flet) &rest _)
(slime-read-from-minibuffer "(Un)trace local function: "
(prin1-to-string spec)))
(t (error "Don't know how to trace the spec %S" spec))))))
(defun slime-toggle-fancy-trace (&optional using-context-p)
"Toggle trace."
(interactive "P")
(let* ((spec (if using-context-p
(slime-extract-context)
(slime-symbol-at-point)))
(spec (slime-trace-query spec)))
(message "%s" (slime-eval `(swank:swank-toggle-trace ,spec)))))
;; override slime-toggle-trace-fdefinition
(define-key slime-prefix-map "\C-t" 'slime-toggle-fancy-trace)
(provide 'slime-fancy-trace)

BIN
elpa/slime-20180413.1720/contrib/slime-fancy-trace.elc Normal file
View File

Binary file not shown.

38
elpa/slime-20180413.1720/contrib/slime-fancy.el Normal file
View File

@@ -0,0 +1,38 @@
(require 'slime)
(define-slime-contrib slime-fancy
"Make SLIME fancy."
(:authors "Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de>"
"Tobias C Rittweiler <tcr@freebits.de>")
(:license "GPL")
(:slime-dependencies slime-repl
slime-autodoc
slime-c-p-c
slime-editing-commands
slime-fancy-inspector
slime-fancy-trace
slime-fuzzy
slime-mdot-fu
slime-macrostep
slime-presentations
slime-scratch
slime-references
slime-package-fu
slime-fontifying-fu
slime-trace-dialog)
(:on-load
(slime-trace-dialog-init)
(slime-repl-init)
(slime-autodoc-init)
(slime-c-p-c-init)
(slime-editing-commands-init)
(slime-fancy-inspector-init)
(slime-fancy-trace-init)
(slime-fuzzy-init)
(slime-presentations-init)
(slime-scratch-init)
(slime-references-init)
(slime-package-fu-init)
(slime-fontifying-fu-init)))
(provide 'slime-fancy)

BIN
elpa/slime-20180413.1720/contrib/slime-fancy.elc Normal file
View File

Binary file not shown.

231
elpa/slime-20180413.1720/contrib/slime-fontifying-fu.el Normal file
View File

@@ -0,0 +1,231 @@
(require 'slime)
(require 'slime-parse)
(require 'slime-autodoc)
(require 'font-lock)
(require 'cl-lib)
;;; Fontify WITH-FOO, DO-FOO, and DEFINE-FOO like standard macros.
;;; Fontify CHECK-FOO like CHECK-TYPE.
(defvar slime-additional-font-lock-keywords
'(("(\\(\\(\\s_\\|\\w\\)*:\\(define-\\|do-\\|with-\\|without-\\)\\(\\s_\\|\\w\\)*\\)" 1 font-lock-keyword-face)
("(\\(\\(define-\\|do-\\|with-\\)\\(\\s_\\|\\w\\)*\\)" 1 font-lock-keyword-face)
("(\\(check-\\(\\s_\\|\\w\\)*\\)" 1 font-lock-warning-face)
("(\\(assert-\\(\\s_\\|\\w\\)*\\)" 1 font-lock-warning-face)))
;;;; Specially fontify forms suppressed by a reader conditional.
(defcustom slime-highlight-suppressed-forms t
"Display forms disabled by reader conditionals as comments."
:type '(choice (const :tag "Enable" t) (const :tag "Disable" nil))
:group 'slime-mode)
(define-slime-contrib slime-fontifying-fu
"Additional fontification tweaks:
Fontify WITH-FOO, DO-FOO, DEFINE-FOO like standard macros.
Fontify CHECK-FOO like CHECK-TYPE."
(:authors "Tobias C. Rittweiler <tcr@freebits.de>")
(:license "GPL")
(:on-load
(font-lock-add-keywords
'lisp-mode slime-additional-font-lock-keywords)
(when slime-highlight-suppressed-forms
(slime-activate-font-lock-magic)))
(:on-unload
;; FIXME: remove `slime-search-suppressed-forms', and remove the
;; extend-region hook.
(font-lock-remove-keywords
'lisp-mode slime-additional-font-lock-keywords)))
(defface slime-reader-conditional-face
'((t (:inherit font-lock-comment-face)))
"Face for compiler notes while selected."
:group 'slime-mode-faces)
(defvar slime-search-suppressed-forms-match-data (list nil nil))
(defun slime-search-suppressed-forms-internal (limit)
(when (search-forward-regexp slime-reader-conditionals-regexp limit t)
(let ((start (match-beginning 0)) ; save match data
(state (slime-current-parser-state)))
(if (or (nth 3 state) (nth 4 state)) ; inside string or comment?
(slime-search-suppressed-forms-internal limit)
(let* ((char (char-before))
(expr (read (current-buffer)))
(val (slime-eval-feature-expression expr)))
(when (<= (point) limit)
(if (or (and (eq char ?+) (not val))
(and (eq char ?-) val))
;; If `slime-extend-region-for-font-lock' did not
;; fully extend the region, the assertion below may
;; fail. This should only happen on XEmacs and older
;; versions of GNU Emacs.
(ignore-errors
(forward-sexp) (backward-sexp)
;; Try to suppress as far as possible.
(slime-forward-sexp)
(cl-assert (<= (point) limit))
(let ((md (match-data nil slime-search-suppressed-forms-match-data)))
(setf (cl-first md) start)
(setf (cl-second md) (point))
(set-match-data md)
t))
(slime-search-suppressed-forms-internal limit))))))))
(defun slime-search-suppressed-forms (limit)
"Find reader conditionalized forms where the test is false."
(when (and slime-highlight-suppressed-forms
(slime-connected-p))
(let ((result 'retry))
(while (and (eq result 'retry) (<= (point) limit))
(condition-case condition
(setq result (slime-search-suppressed-forms-internal limit))
(end-of-file ; e.g. #+(
(setq result nil))
;; We found a reader conditional we couldn't process for
;; some reason; however, there may still be other reader
;; conditionals before `limit'.
(invalid-read-syntax ; e.g. #+#.foo
(setq result 'retry))
(scan-error ; e.g. #+nil (foo ...
(setq result 'retry))
(slime-incorrect-feature-expression ; e.g. #+(not foo bar)
(setq result 'retry))
(slime-unknown-feature-expression ; e.g. #+(foo)
(setq result 'retry))
(error
(setq result nil)
(slime-display-warning
(concat "Caught error during fontification while searching for forms\n"
"that are suppressed by reader-conditionals. The error was: %S.")
condition))))
result)))
(defun slime-search-directly-preceding-reader-conditional ()
"Search for a directly preceding reader conditional. Return its
position, or nil."
;;; We search for a preceding reader conditional. Then we check that
;;; between the reader conditional and the point where we started is
;;; no other intervening sexp, and we check that the reader
;;; conditional is at the same nesting level.
(condition-case nil
(let* ((orig-pt (point))
(reader-conditional-pt
(search-backward-regexp slime-reader-conditionals-regexp
;; We restrict the search to the
;; beginning of the /previous/ defun.
(save-excursion
(beginning-of-defun)
(point))
t)))
(when reader-conditional-pt
(let* ((parser-state
(parse-partial-sexp
(progn (goto-char (+ reader-conditional-pt 2))
(forward-sexp) ; skip feature expr.
(point))
orig-pt))
(paren-depth (car parser-state))
(last-sexp-pt (cl-caddr parser-state)))
(if (and paren-depth
(not (cl-plusp paren-depth)) ; no '(' in between?
(not last-sexp-pt)) ; no complete sexp in between?
reader-conditional-pt
nil))))
(scan-error nil))) ; improper feature expression
;;; We'll push this onto `font-lock-extend-region-functions'. In past,
;;; we didn't do so which made our reader-conditional font-lock magic
;;; pretty unreliable (it wouldn't highlight all suppressed forms, and
;;; worked quite non-deterministic in general.)
;;;
;;; Cf. _Elisp Manual_, 23.6.10 Multiline Font Lock Constructs.
;;;
;;; We make sure that `font-lock-beg' and `font-lock-end' always point
;;; to the beginning or end of a toplevel form. So we never miss a
;;; reader-conditional, or point in mid of one.
(defvar font-lock-beg) ; shoosh compiler
(defvar font-lock-end)
(defun slime-extend-region-for-font-lock ()
(when slime-highlight-suppressed-forms
(condition-case c
(let (changedp)
(cl-multiple-value-setq (changedp font-lock-beg font-lock-end)
(slime-compute-region-for-font-lock font-lock-beg font-lock-end))
changedp)
(error
(slime-display-warning
(concat "Caught error when trying to extend the region for fontification.\n"
"The error was: %S\n"
"Further: font-lock-beg=%d, font-lock-end=%d.")
c font-lock-beg font-lock-end)))))
(defun slime-beginning-of-tlf ()
(let ((pos (syntax-ppss-toplevel-pos (slime-current-parser-state))))
(if pos (goto-char pos))))
(defun slime-compute-region-for-font-lock (orig-beg orig-end)
(let ((beg orig-beg)
(end orig-end))
(goto-char beg)
(inline (slime-beginning-of-tlf))
(cl-assert (not (cl-plusp (nth 0 (slime-current-parser-state)))))
(setq beg (let ((pt (point)))
(cond ((> (- beg pt) 20000) beg)
((slime-search-directly-preceding-reader-conditional))
(t pt))))
(goto-char end)
(while (search-backward-regexp slime-reader-conditionals-regexp beg t)
(setq end (max end (save-excursion
(ignore-errors (slime-forward-reader-conditional))
(point)))))
(cl-values (or (/= beg orig-beg) (/= end orig-end)) beg end)))
(defun slime-activate-font-lock-magic ()
(if (featurep 'xemacs)
(let ((pattern `((slime-search-suppressed-forms
(0 slime-reader-conditional-face t)))))
(dolist (sym '(lisp-font-lock-keywords
lisp-font-lock-keywords-1
lisp-font-lock-keywords-2))
(set sym (append (symbol-value sym) pattern))))
(font-lock-add-keywords
'lisp-mode
`((slime-search-suppressed-forms 0 ,''slime-reader-conditional-face t)))
(add-hook 'lisp-mode-hook
#'(lambda ()
(add-hook 'font-lock-extend-region-functions
'slime-extend-region-for-font-lock t t)))))
(let ((byte-compile-warnings '()))
(mapc (lambda (sym)
(cond ((fboundp sym)
(unless (byte-code-function-p (symbol-function sym))
(byte-compile sym)))
(t (error "%S is not fbound" sym))))
'(slime-extend-region-for-font-lock
slime-compute-region-for-font-lock
slime-search-directly-preceding-reader-conditional
slime-search-suppressed-forms
slime-beginning-of-tlf)))
(cl-defun slime-initialize-lisp-buffer-for-test-suite
(&key (font-lock-magic t) (autodoc t))
(let ((hook lisp-mode-hook))
(unwind-protect
(progn
(set (make-local-variable 'slime-highlight-suppressed-forms)
font-lock-magic)
(setq lisp-mode-hook nil)
(lisp-mode)
(slime-mode 1)
(when (boundp 'slime-autodoc-mode)
(if autodoc
(slime-autodoc-mode 1)
(slime-autodoc-mode -1))))
(setq lisp-mode-hook hook))))
(provide 'slime-fontifying-fu)

BIN
elpa/slime-20180413.1720/contrib/slime-fontifying-fu.elc Normal file
View File

Binary file not shown.

604
elpa/slime-20180413.1720/contrib/slime-fuzzy.el Normal file
View File

@@ -0,0 +1,604 @@
(require 'slime)
(require 'slime-repl)
(require 'slime-c-p-c)
(require 'cl-lib)
(define-slime-contrib slime-fuzzy
"Fuzzy symbol completion."
(:authors "Brian Downing <bdowning@lavos.net>"
"Tobias C. Rittweiler <tcr@freebits.de>"
"Attila Lendvai <attila.lendvai@gmail.com>")
(:license "GPL")
(:swank-dependencies swank-fuzzy)
(:on-load
(define-key slime-mode-map "\C-c\M-i" 'slime-fuzzy-complete-symbol)
(when (featurep 'slime-repl)
(define-key slime-repl-mode-map "\C-c\M-i"
'slime-fuzzy-complete-symbol))))
(defcustom slime-fuzzy-completion-in-place t
"When non-NIL the fuzzy symbol completion is done in place as
opposed to moving the point to the completion buffer."
:group 'slime-mode
:type 'boolean)
(defcustom slime-fuzzy-completion-limit 300
"Only return and present this many symbols from swank."
:group 'slime-mode
:type 'integer)
(defcustom slime-fuzzy-completion-time-limit-in-msec 1500
"Limit the time spent (given in msec) in swank while gathering
completions."
:group 'slime-mode
:type 'integer)
(defcustom slime-when-complete-filename-expand nil
"Use comint-replace-by-expanded-filename instead of
comint-filename-completion to complete file names"
:group 'slime-mode
:type 'boolean)
(defvar slime-fuzzy-target-buffer nil
"The buffer that is the target of the completion activities.")
(defvar slime-fuzzy-saved-window-configuration nil
"The saved window configuration before the fuzzy completion
buffer popped up.")
(defvar slime-fuzzy-start nil
"The beginning of the completion slot in the target buffer.
This is a non-advancing marker.")
(defvar slime-fuzzy-end nil
"The end of the completion slot in the target buffer.
This is an advancing marker.")
(defvar slime-fuzzy-original-text nil
"The original text that was in the completion slot in the
target buffer. This is what is put back if completion is
aborted.")
(defvar slime-fuzzy-text nil
"The text that is currently in the completion slot in the
target buffer. If this ever doesn't match, the target buffer has
been modified and we abort without touching it.")
(defvar slime-fuzzy-first nil
"The position of the first completion in the completions buffer.
The descriptive text and headers are above this.")
(defvar slime-fuzzy-last nil
"The position of the last completion in the completions buffer.
If the time limit has exhausted during generation possible completion
choices inside SWANK, an indication is printed below this.")
(defvar slime-fuzzy-current-completion nil
"The current completion object. If this is the same before and
after point moves in the completions buffer, the text is not
replaced in the target for efficiency.")
(defvar slime-fuzzy-current-completion-overlay nil
"The overlay representing the current completion in the completion
buffer. This is used to hightlight the text.")
;;;;;;; slime-target-buffer-fuzzy-completions-mode
;; NOTE: this mode has to be able to override key mappings in slime-mode
(defvar slime-target-buffer-fuzzy-completions-map
(let ((map (make-sparse-keymap)))
(cl-labels ((def (keys command)
(unless (listp keys)
(setq keys (list keys)))
(dolist (key keys)
(define-key map key command))))
(def `([remap keyboard-quit]
,(kbd "C-g"))
'slime-fuzzy-abort)
(def `([remap slime-fuzzy-indent-and-complete-symbol]
[remap slime-indent-and-complete-symbol]
,(kbd "<tab>"))
'slime-fuzzy-select-or-update-completions)
(def `([remap previous-line]
,(kbd "<up>"))
'slime-fuzzy-prev)
(def `([remap next-line]
,(kbd "<down>"))
'slime-fuzzy-next)
(def `([remap isearch-forward]
,(kbd "C-s"))
'slime-fuzzy-continue-isearch-in-fuzzy-buffer)
;; some unconditional direct bindings
(def (list (kbd "<return>") (kbd "RET") (kbd "<SPC>") "(" ")" "[" "]")
'slime-fuzzy-select-and-process-event-in-target-buffer))
map)
"Keymap for slime-target-buffer-fuzzy-completions-mode.
This will override the key bindings in the target buffer
temporarily during completion.")
;; Make sure slime-fuzzy-target-buffer-completions-mode's map is
;; before everything else.
(setf minor-mode-map-alist
(cl-stable-sort minor-mode-map-alist
(lambda (a b)
(eq a 'slime-fuzzy-target-buffer-completions-mode))
:key #'car))
(defun slime-fuzzy-continue-isearch-in-fuzzy-buffer ()
(interactive)
(select-window (get-buffer-window (slime-get-fuzzy-buffer)))
(call-interactively 'isearch-forward))
(define-minor-mode slime-fuzzy-target-buffer-completions-mode
"This minor mode is intented to override key bindings during
fuzzy completions in the target buffer. Most of the bindings will
do an implicit select in the completion window and let the
keypress be processed in the target buffer."
nil
nil
slime-target-buffer-fuzzy-completions-map)
(add-to-list 'minor-mode-alist
'(slime-fuzzy-target-buffer-completions-mode
" Fuzzy Target Buffer Completions"))
(defvar slime-fuzzy-completions-map
(let ((map (make-sparse-keymap)))
(cl-labels ((def (keys command)
(unless (listp keys)
(setq keys (list keys)))
(dolist (key keys)
(define-key map key command))))
(def `([remap keyboard-quit]
"q"
,(kbd "C-g"))
'slime-fuzzy-abort)
(def `([remap previous-line]
"p"
"\M-p"
,(kbd "<up>"))
'slime-fuzzy-prev)
(def `([remap next-line]
"n"
"\M-n"
,(kbd "<down>"))
'slime-fuzzy-next)
(def "\d" 'scroll-down)
(def `([remap slime-fuzzy-indent-and-complete-symbol]
[remap slime-indent-and-complete-symbol]
,(kbd "<tab>"))
'slime-fuzzy-select)
(def (kbd "<mouse-2>") 'slime-fuzzy-select/mouse)
(def `(,(kbd "RET")
,(kbd "<SPC>"))
'slime-fuzzy-select))
map)
"Keymap for slime-fuzzy-completions-mode when in the completion buffer.")
(define-derived-mode slime-fuzzy-completions-mode
fundamental-mode "Fuzzy Completions"
"Major mode for presenting fuzzy completion results.
When you run `slime-fuzzy-complete-symbol', the symbol token at
point is completed using the Fuzzy Completion algorithm; this
means that the token is taken as a sequence of characters and all
the various possibilities that this sequence could meaningfully
represent are offered as selectable choices, sorted by how well
they deem to be a match for the token. (For instance, the first
choice of completing on \"mvb\" would be \"multiple-value-bind\".)
Therefore, a new buffer (*Fuzzy Completions*) will pop up that
contains the different completion choices. Simultaneously, a
special minor-mode will be temporarily enabled in the original
buffer where you initiated fuzzy completion (also called the
``target buffer'') in order to navigate through the *Fuzzy
Completions* buffer without leaving.
With focus in *Fuzzy Completions*:
Type `n' and `p' (`UP', `DOWN') to navigate between completions.
Type `RET' or `TAB' to select the completion near point.
Type `q' to abort.
With focus in the target buffer:
Type `UP' and `DOWN' to navigate between completions.
Type a character that does not constitute a symbol name
to insert the current choice and then that character (`(', `)',
`SPACE', `RET'.) Use `TAB' to simply insert the current choice.
Use C-g to abort.
Alternatively, you can click <mouse-2> on a completion to select it.
Complete listing of keybindings within the target buffer:
\\<slime-target-buffer-fuzzy-completions-map>\
\\{slime-target-buffer-fuzzy-completions-map}
Complete listing of keybindings with *Fuzzy Completions*:
\\<slime-fuzzy-completions-map>\
\\{slime-fuzzy-completions-map}"
(use-local-map slime-fuzzy-completions-map)
(set (make-local-variable 'slime-fuzzy-current-completion-overlay)
(make-overlay (point) (point) nil t nil)))
(defun slime-fuzzy-completions (prefix &optional default-package)
"Get the list of sorted completion objects from completing
`prefix' in `package' from the connected Lisp."
(let ((prefix (cl-etypecase prefix
(symbol (symbol-name prefix))
(string prefix))))
(slime-eval `(swank:fuzzy-completions ,prefix
,(or default-package
(slime-current-package))
:limit ,slime-fuzzy-completion-limit
:time-limit-in-msec
,slime-fuzzy-completion-time-limit-in-msec))))
(defun slime-fuzzy-selected (prefix completion)
"Tell the connected Lisp that the user selected completion
`completion' as the completion for `prefix'."
(let ((no-properties (copy-sequence prefix)))
(set-text-properties 0 (length no-properties) nil no-properties)
(slime-eval `(swank:fuzzy-completion-selected ,no-properties
',completion))))
(defun slime-fuzzy-indent-and-complete-symbol ()
"Indent the current line and perform fuzzy symbol completion. First
indent the line. If indenting doesn't move point, complete the
symbol. If there's no symbol at the point, show the arglist for the
most recently enclosed macro or function."
(interactive)
(let ((pos (point)))
(unless (get-text-property (line-beginning-position) 'slime-repl-prompt)
(lisp-indent-line))
(when (= pos (point))
(cond ((save-excursion (re-search-backward "[^() \n\t\r]+\\=" nil t))
(slime-fuzzy-complete-symbol))
((memq (char-before) '(?\t ?\ ))
(slime-echo-arglist))))))
(cl-defun slime-fuzzy-complete-symbol ()
"Fuzzily completes the abbreviation at point into a symbol."
(interactive)
(when (save-excursion (re-search-backward "\"[^ \t\n]+\\=" nil t))
(cl-return-from slime-fuzzy-complete-symbol
;; don't add space after completion
(let ((comint-completion-addsuffix '("/" . "")))
(if slime-when-complete-filename-expand
(comint-replace-by-expanded-filename)
;; FIXME: use `comint-filename-completion' when dropping emacs23
(funcall (if (>= emacs-major-version 24)
'comint-filename-completion
'comint-dynamic-complete-as-filename))))))
(let* ((end (move-marker (make-marker) (slime-symbol-end-pos)))
(beg (move-marker (make-marker) (slime-symbol-start-pos)))
(prefix (buffer-substring-no-properties beg end)))
(cl-destructuring-bind (completion-set interrupted-p)
(slime-fuzzy-completions prefix)
(if (null completion-set)
(progn (slime-minibuffer-respecting-message
"Can't find completion for \"%s\"" prefix)
(ding)
(slime-fuzzy-done))
(goto-char end)
(cond ((slime-length= completion-set 1)
;; insert completed string
(insert-and-inherit (caar completion-set))
(delete-region beg end)
(goto-char (+ beg (length (caar completion-set))))
(slime-minibuffer-respecting-message "Sole completion")
(slime-fuzzy-done))
;; Incomplete
(t
(slime-fuzzy-choices-buffer completion-set interrupted-p
beg end)
(slime-minibuffer-respecting-message
"Complete but not unique")))))))
(defun slime-get-fuzzy-buffer ()
(get-buffer-create "*Fuzzy Completions*"))
(defvar slime-fuzzy-explanation
"For help on how the use this buffer, see `slime-fuzzy-completions-mode'.
Flags: boundp fboundp generic-function class macro special-operator package
\n"
"The explanation that gets inserted at the beginning of the
*Fuzzy Completions* buffer.")
(defun slime-fuzzy-insert-completion-choice (completion max-length)
"Inserts the completion object `completion' as a formatted
completion choice into the current buffer, and mark it with the
proper text properties."
(cl-destructuring-bind (symbol-name score chunks classification-string)
completion
(let ((start (point))
(end))
(insert symbol-name)
(setq end (point))
(dolist (chunk chunks)
(put-text-property (+ start (cl-first chunk))
(+ start (cl-first chunk)
(length (cl-second chunk)))
'face 'bold))
(put-text-property start (point) 'mouse-face 'highlight)
(dotimes (i (- max-length (- end start)))
(insert " "))
(insert (format " %s %s\n"
classification-string
score))
(put-text-property start (point) 'completion completion))))
(defun slime-fuzzy-insert (text)
"Inserts `text' into the target buffer in the completion slot.
If the buffer has been modified in the meantime, abort the
completion process. Otherwise, update all completion variables
so that the new text is present."
(with-current-buffer slime-fuzzy-target-buffer
(cond
((not (string-equal slime-fuzzy-text
(buffer-substring slime-fuzzy-start
slime-fuzzy-end)))
(slime-fuzzy-done)
(beep)
(message "Target buffer has been modified!"))
(t
(goto-char slime-fuzzy-start)
(delete-region slime-fuzzy-start slime-fuzzy-end)
(insert-and-inherit text)
(setq slime-fuzzy-text text)
(goto-char slime-fuzzy-end)))))
(defun slime-minibuffer-p (buffer)
(if (featurep 'xemacs)
(eq buffer (window-buffer (minibuffer-window)))
(minibufferp buffer)))
(defun slime-fuzzy-choices-buffer (completions interrupted-p start end)
"Creates (if neccessary), populates, and pops up the *Fuzzy
Completions* buffer with the completions from `completions' and
the completion slot in the current buffer bounded by `start' and
`end'. This saves the window configuration before popping the
buffer so that it can possibly be restored when the user is
done."
(let ((new-completion-buffer (not slime-fuzzy-target-buffer))
(connection (slime-connection)))
(when new-completion-buffer
(setq slime-fuzzy-saved-window-configuration
(current-window-configuration)))
(slime-fuzzy-enable-target-buffer-completions-mode)
(setq slime-fuzzy-target-buffer (current-buffer))
(setq slime-fuzzy-start (move-marker (make-marker) start))
(setq slime-fuzzy-end (move-marker (make-marker) end))
(set-marker-insertion-type slime-fuzzy-end t)
(setq slime-fuzzy-original-text (buffer-substring start end))
(setq slime-fuzzy-text slime-fuzzy-original-text)
(slime-fuzzy-fill-completions-buffer completions interrupted-p)
(pop-to-buffer (slime-get-fuzzy-buffer))
(slime-fuzzy-next)
(setq slime-buffer-connection connection)
(when new-completion-buffer
;; Hook to nullify window-config restoration if the user changes
;; the window configuration himself.
(when (boundp 'window-configuration-change-hook)
(add-hook 'window-configuration-change-hook
'slime-fuzzy-window-configuration-change))
(add-hook 'kill-buffer-hook 'slime-fuzzy-abort 'append t)
(set (make-local-variable 'cursor-type) nil)
(setq buffer-quit-function 'slime-fuzzy-abort)) ; M-Esc Esc
(when slime-fuzzy-completion-in-place
;; switch back to the original buffer
(if (slime-minibuffer-p slime-fuzzy-target-buffer)
(select-window (minibuffer-window))
(switch-to-buffer-other-window slime-fuzzy-target-buffer)))))
(defun slime-fuzzy-fill-completions-buffer (completions interrupted-p)
"Erases and fills the completion buffer with the given completions."
(with-current-buffer (slime-get-fuzzy-buffer)
(setq buffer-read-only nil)
(erase-buffer)
(slime-fuzzy-completions-mode)
(insert slime-fuzzy-explanation)
(let ((max-length 12))
(dolist (completion completions)
(setf max-length (max max-length (length (cl-first completion)))))
(insert "Completion:")
(dotimes (i (- max-length 10)) (insert " "))
;; Flags: Score:
;; ... ------- --------
;; bfgctmsp
(let* ((example-classification-string (cl-fourth (cl-first completions)))
(classification-length (length example-classification-string))
(spaces (- classification-length (length "Flags:"))))
(insert "Flags:")
(dotimes (i spaces) (insert " "))
(insert " Score:\n")
(dotimes (i max-length) (insert "-"))
(insert " ")
(dotimes (i classification-length) (insert "-"))
(insert " --------\n")
(setq slime-fuzzy-first (point)))
(dolist (completion completions)
(setq slime-fuzzy-last (point)) ; will eventually become the last entry
(slime-fuzzy-insert-completion-choice completion max-length))
(when interrupted-p
(insert "...\n")
(insert "[Interrupted: time limit exhausted]"))
(setq buffer-read-only t))
(setq slime-fuzzy-current-completion
(caar completions))
(goto-char 0)))
(defun slime-fuzzy-enable-target-buffer-completions-mode ()
"Store the target buffer's local map, so that we can restore it."
(unless slime-fuzzy-target-buffer-completions-mode
; (slime-log-event "Enabling target buffer completions mode")
(slime-fuzzy-target-buffer-completions-mode 1)))
(defun slime-fuzzy-disable-target-buffer-completions-mode ()
"Restores the target buffer's local map when completion is finished."
(when slime-fuzzy-target-buffer-completions-mode
; (slime-log-event "Disabling target buffer completions mode")
(slime-fuzzy-target-buffer-completions-mode 0)))
(defun slime-fuzzy-insert-from-point ()
"Inserts the completion that is under point in the completions
buffer into the target buffer. If the completion in question had
already been inserted, it does nothing."
(with-current-buffer (slime-get-fuzzy-buffer)
(let ((current-completion (get-text-property (point) 'completion)))
(when (and current-completion
(not (eq slime-fuzzy-current-completion
current-completion)))
(slime-fuzzy-insert
(cl-first (get-text-property (point) 'completion)))
(setq slime-fuzzy-current-completion
current-completion)))))
(defun slime-fuzzy-post-command-hook ()
"The post-command-hook for the *Fuzzy Completions* buffer.
This makes sure the completion slot in the target buffer matches
the completion that point is on in the completions buffer."
(condition-case err
(when slime-fuzzy-target-buffer
(slime-fuzzy-insert-from-point))
(error
;; Because this is called on the post-command-hook, we mustn't let
;; errors propagate.
(message "Error in slime-fuzzy-post-command-hook: %S" err))))
(defun slime-fuzzy-next ()
"Moves point directly to the next completion in the completions
buffer."
(interactive)
(with-current-buffer (slime-get-fuzzy-buffer)
(let ((point (next-single-char-property-change
(point) 'completion nil slime-fuzzy-last)))
(set-window-point (get-buffer-window (current-buffer)) point)
(goto-char point))
(slime-fuzzy-highlight-current-completion)))
(defun slime-fuzzy-prev ()
"Moves point directly to the previous completion in the
completions buffer."
(interactive)
(with-current-buffer (slime-get-fuzzy-buffer)
(let ((point (previous-single-char-property-change
(point)
'completion nil slime-fuzzy-first)))
(set-window-point (get-buffer-window (current-buffer)) point)
(goto-char point))
(slime-fuzzy-highlight-current-completion)))
(defun slime-fuzzy-highlight-current-completion ()
"Highlights the current completion,
so that the user can see it on the screen."
(let ((pos (point)))
(when (overlayp slime-fuzzy-current-completion-overlay)
(move-overlay slime-fuzzy-current-completion-overlay
(point) (1- (search-forward " ")))
(overlay-put slime-fuzzy-current-completion-overlay
'face 'secondary-selection))
(goto-char pos)))
(defun slime-fuzzy-abort ()
"Aborts the completion process, setting the completions slot in
the target buffer back to its original contents."
(interactive)
(when slime-fuzzy-target-buffer
(slime-fuzzy-done)))
(defun slime-fuzzy-select ()
"Selects the current completion, making sure that it is inserted
into the target buffer. This tells the connected Lisp what completion
was selected."
(interactive)
(when slime-fuzzy-target-buffer
(with-current-buffer (slime-get-fuzzy-buffer)
(let ((completion (get-text-property (point) 'completion)))
(when completion
(slime-fuzzy-insert (cl-first completion))
(slime-fuzzy-selected slime-fuzzy-original-text
completion)
(slime-fuzzy-done))))))
(defun slime-fuzzy-select-or-update-completions ()
"If there were no changes since the last time fuzzy completion was started
this function will select the current completion.
Otherwise refreshes the completion list based on the changes made."
(interactive)
; (slime-log-event "Selecting or updating completions")
(if (string-equal slime-fuzzy-original-text
(buffer-substring slime-fuzzy-start
slime-fuzzy-end))
(slime-fuzzy-select)
(slime-fuzzy-complete-symbol)))
(defun slime-fuzzy-process-event-in-completions-buffer ()
"Simply processes the event in the target buffer"
(interactive)
(with-current-buffer (slime-get-fuzzy-buffer)
(push last-input-event unread-command-events)))
(defun slime-fuzzy-select-and-process-event-in-target-buffer ()
"Selects the current completion, making sure that it is inserted
into the target buffer and processes the event in the target buffer."
(interactive)
; (slime-log-event "Selecting and processing event in target buffer")
(when slime-fuzzy-target-buffer
(let ((buff slime-fuzzy-target-buffer))
(slime-fuzzy-select)
(with-current-buffer buff
(slime-fuzzy-disable-target-buffer-completions-mode)
(push last-input-event unread-command-events)))))
(defun slime-fuzzy-select/mouse (event)
"Handle a mouse-2 click on a completion choice as if point were
on the completion choice and the slime-fuzzy-select command was
run."
(interactive "e")
(with-current-buffer (window-buffer (posn-window (event-end event)))
(save-excursion
(goto-char (posn-point (event-end event)))
(when (get-text-property (point) 'mouse-face)
(slime-fuzzy-insert-from-point)
(slime-fuzzy-select)))))
(defun slime-fuzzy-done ()
"Cleans up after the completion process. This removes all hooks,
and attempts to restore the window configuration. If this fails,
it just burys the completions buffer and leaves the window
configuration alone."
(when slime-fuzzy-target-buffer
(set-buffer slime-fuzzy-target-buffer)
(slime-fuzzy-disable-target-buffer-completions-mode)
(if (slime-fuzzy-maybe-restore-window-configuration)
(bury-buffer (slime-get-fuzzy-buffer))
;; We couldn't restore the windows, so just bury the fuzzy
;; completions buffer and let something else fill it in.
(pop-to-buffer (slime-get-fuzzy-buffer))
(bury-buffer))
(if (slime-minibuffer-p slime-fuzzy-target-buffer)
(select-window (minibuffer-window))
(pop-to-buffer slime-fuzzy-target-buffer))
(goto-char slime-fuzzy-end)
(setq slime-fuzzy-target-buffer nil)
(remove-hook 'window-configuration-change-hook
'slime-fuzzy-window-configuration-change)))
(defun slime-fuzzy-maybe-restore-window-configuration ()
"Restores the saved window configuration if it has not been
nullified."
(when (boundp 'window-configuration-change-hook)
(remove-hook 'window-configuration-change-hook
'slime-fuzzy-window-configuration-change))
(if (not slime-fuzzy-saved-window-configuration)
nil
(set-window-configuration slime-fuzzy-saved-window-configuration)
(setq slime-fuzzy-saved-window-configuration nil)
t))
(defun slime-fuzzy-window-configuration-change ()
"Called on window-configuration-change-hook. Since the window
configuration was changed, we nullify our saved configuration."
(setq slime-fuzzy-saved-window-configuration nil))
(provide 'slime-fuzzy)

BIN
elpa/slime-20180413.1720/contrib/slime-fuzzy.elc Normal file
View File

Binary file not shown.

81
elpa/slime-20180413.1720/contrib/slime-highlight-edits.el Normal file
View File

@@ -0,0 +1,81 @@
(require 'slime)
(require 'slime-parse)
(define-slime-contrib slime-highlight-edits
"Highlight edited, i.e. not yet compiled, code."
(:authors "William Bland <doctorbill.news@gmail.com>")
(:license "GPL")
(:on-load (add-hook 'slime-mode-hook 'slime-activate-highlight-edits))
(:on-unload (remove-hook 'slime-mode-hook 'slime-activate-highlight-edits)))
(defun slime-activate-highlight-edits ()
(slime-highlight-edits-mode 1))
(defface slime-highlight-edits-face
`((((class color) (background light))
(:background "lightgray"))
(((class color) (background dark))
(:background "dimgray"))
(t (:background "yellow")))
"Face for displaying edit but not compiled code."
:group 'slime-mode-faces)
(define-minor-mode slime-highlight-edits-mode
"Minor mode to highlight not-yet-compiled code." nil)
(add-hook 'slime-highlight-edits-mode-on-hook
'slime-highlight-edits-init-buffer)
(add-hook 'slime-highlight-edits-mode-off-hook
'slime-highlight-edits-reset-buffer)
(defun slime-highlight-edits-init-buffer ()
(make-local-variable 'after-change-functions)
(add-to-list 'after-change-functions
'slime-highlight-edits)
(add-to-list 'slime-before-compile-functions
'slime-highlight-edits-compile-hook))
(defun slime-highlight-edits-reset-buffer ()
(setq after-change-functions
(remove 'slime-highlight-edits after-change-functions))
(slime-remove-edits (point-min) (point-max)))
;; FIXME: what's the LEN arg for?
(defun slime-highlight-edits (beg end &optional len)
(save-match-data
(when (and (slime-connected-p)
(not (slime-inside-comment-p))
(not (slime-only-whitespace-p beg end)))
(let ((overlay (make-overlay beg end)))
(overlay-put overlay 'face 'slime-highlight-edits-face)
(overlay-put overlay 'slime-edit t)))))
(defun slime-remove-edits (start end)
"Delete the existing Slime edit hilights in the current buffer."
(save-excursion
(goto-char start)
(while (< (point) end)
(dolist (o (overlays-at (point)))
(when (overlay-get o 'slime-edit)
(delete-overlay o)))
(goto-char (next-overlay-change (point))))))
(defun slime-highlight-edits-compile-hook (start end)
(when slime-highlight-edits-mode
(let ((start (save-excursion (goto-char start)
(skip-chars-backward " \t\n\r")
(point)))
(end (save-excursion (goto-char end)
(skip-chars-forward " \t\n\r")
(point))))
(slime-remove-edits start end))))
(defun slime-only-whitespace-p (beg end)
"Contains the region from BEG to END only whitespace?"
(save-excursion
(goto-char beg)
(skip-chars-forward " \n\t\r" end)
(<= end (point))))
(provide 'slime-highlight-edits)

BIN
elpa/slime-20180413.1720/contrib/slime-highlight-edits.elc Normal file
View File

Binary file not shown.

48
elpa/slime-20180413.1720/contrib/slime-hyperdoc.el Normal file
View File

@@ -0,0 +1,48 @@
(require 'slime)
(require 'url-http)
(require 'browse-url)
(eval-when-compile (require 'cl)) ; lexical-let
(defvar slime-old-documentation-lookup-function
slime-documentation-lookup-function)
(define-slime-contrib slime-hyperdoc
"Extensible C-c C-d h."
(:authors "Tobias C Rittweiler <tcr@freebits.de>")
(:license "GPL")
(:swank-dependencies swank-hyperdoc)
(:on-load
(setq slime-documentation-lookup-function 'slime-hyperdoc-lookup))
(:on-unload
(setq slime-documentation-lookup-function
slime-old-documentation-lookup-function)))
;;; TODO: `url-http-file-exists-p' is slow, make it optional behaviour.
(defun slime-hyperdoc-lookup-rpc (symbol-name)
(slime-eval-async `(swank:hyperdoc ,symbol-name)
(lexical-let ((symbol-name symbol-name))
#'(lambda (result)
(slime-log-event result)
(cl-loop with foundp = nil
for (doc-type . url) in result do
(when (and url (stringp url)
(let ((url-show-status nil))
(url-http-file-exists-p url)))
(message "Visiting documentation for %s `%s'..."
(substring (symbol-name doc-type) 1)
symbol-name)
(browse-url url)
(setq foundp t))
finally
(unless foundp
(error "Could not find documentation for `%s'."
symbol-name)))))))
(defun slime-hyperdoc-lookup (symbol-name)
(interactive (list (slime-read-symbol-name "Symbol: ")))
(if (memq :hyperdoc (slime-lisp-features))
(slime-hyperdoc-lookup-rpc symbol-name)
(slime-hyperspec-lookup symbol-name)))
(provide 'slime-hyperdoc)

BIN
elpa/slime-20180413.1720/contrib/slime-hyperdoc.elc Normal file
View File

Binary file not shown.

31
elpa/slime-20180413.1720/contrib/slime-indentation.el Normal file
View File

@@ -0,0 +1,31 @@
(require 'slime)
(require 'slime-cl-indent)
(require 'cl-lib)
(define-slime-contrib slime-indentation
"Contrib interfacing `slime-cl-indent' and SLIME."
(:swank-dependencies swank-indentation)
(:on-load
(setq common-lisp-current-package-function 'slime-current-package)))
(defun slime-update-system-indentation (symbol indent packages)
(let ((list (gethash symbol common-lisp-system-indentation))
(ok nil))
(if (not list)
(puthash symbol (list (cons indent packages))
common-lisp-system-indentation)
(dolist (spec list)
(cond ((equal (car spec) indent)
(dolist (p packages)
(unless (member p (cdr spec))
(push p (cdr spec))))
(setf ok t))
(t
(setf (cdr spec)
(cl-set-difference (cdr spec) packages :test 'equal)))))
(unless ok
(puthash symbol (cons (cons indent packages)
list)
common-lisp-system-indentation)))))
(provide 'slime-indentation)

BIN
elpa/slime-20180413.1720/contrib/slime-indentation.elc Normal file
View File

Binary file not shown.

11
elpa/slime-20180413.1720/contrib/slime-listener-hooks.el Normal file
View File

@@ -0,0 +1,11 @@
(require 'slime)
(require 'cl-lib)
(define-slime-contrib slime-listener-hooks
"Enable slime integration in an application'w event loop"
(:authors "Alan Ruttenberg <alanr-l@mumble.net>, R. Mattes <rm@seid-online.de>")
(:license "GPL")
(:slime-dependencies slime-repl)
(:swank-dependencies swank-listener-hooks))
(provide 'slime-listener-hooks)

BIN
elpa/slime-20180413.1720/contrib/slime-listener-hooks.elc Normal file
View File

Binary file not shown.

129
elpa/slime-20180413.1720/contrib/slime-macrostep.el Normal file
View File

@@ -0,0 +1,129 @@
;;; slime-macrostep.el -- fancy macro-expansion via macrostep.el
;; Authors: Luís Oliveira <luismbo@gmail.com>
;; Jon Oddie <j.j.oddie@gmail.com
;;
;; License: GNU GPL (same license as Emacs)
;;; Description:
;; Fancier in-place macro-expansion using macrostep.el (originally
;; written for Emacs Lisp). To use, position point before the
;; open-paren of the macro call in a SLIME source or REPL buffer, and
;; type `C-c M-e' or `M-x macrostep-expand'. The pretty-printed
;; result of `macroexpand-1' will be inserted inline in the current
;; buffer, which is temporarily read-only while macro expansions are
;; visible. If the expansion is itself a macro call, expansion can be
;; continued by typing `e'. Expansions are collapsed to their
;; original macro forms by typing `c' or `q'. Other macro- and
;; compiler-macro calls in the expansion will be font-locked
;; differently, and point can be moved there quickly by typing `n' or
;; `p'. For more details, see the documentation of
;; `macrostep-expand'.
;;; Code:
(require 'slime)
(eval-and-compile
(require 'macrostep nil t)
;; Use bundled version if not separately installed
(require 'macrostep "../lib/macrostep"))
(eval-when-compile (require 'cl-lib))
(defvar slime-repl-mode-hook)
(defvar slime-repl-mode-map)
(define-slime-contrib slime-macrostep
"Interactive macro expansion via macrostep.el."
(:authors "Luís Oliveira <luismbo@gmail.com>"
"Jon Oddie <j.j.oddie@gmail.com>")
(:license "GPL")
(:swank-dependencies swank-macrostep)
(:on-load
(easy-menu-add-item slime-mode-map '(menu-bar SLIME Debugging)
["Macro stepper..." macrostep-expand (slime-connected-p)]
"Create Trace Buffer")
(add-hook 'slime-mode-hook #'macrostep-slime-mode-hook)
(define-key slime-mode-map (kbd "C-c M-e") #'macrostep-expand)
(eval-after-load 'slime-repl
'(progn
(add-hook 'slime-repl-mode-hook #'macrostep-slime-mode-hook)
(define-key slime-repl-mode-map (kbd "C-c M-e") #'macrostep-expand)))))
(defun macrostep-slime-mode-hook ()
(setq macrostep-sexp-at-point-function #'macrostep-slime-sexp-at-point)
(setq macrostep-environment-at-point-function #'macrostep-slime-context)
(setq macrostep-expand-1-function #'macrostep-slime-expand-1)
(setq macrostep-print-function #'macrostep-slime-insert)
(setq macrostep-macro-form-p-function #'macrostep-slime-macro-form-p))
(defun macrostep-slime-sexp-at-point (&rest _ignore)
(slime-sexp-at-point))
(defun macrostep-slime-context ()
(let (defun-start defun-end)
(save-excursion
(while
(condition-case nil
(progn (backward-up-list) t)
(scan-error nil)))
(setq defun-start (point))
(setq defun-end (scan-sexps (point) 1)))
(list (buffer-substring-no-properties
defun-start (point))
(buffer-substring-no-properties
(scan-sexps (point) 1) defun-end))))
(defun macrostep-slime-expand-1 (string context)
(slime-dcase
(slime-eval
`(swank-macrostep:macrostep-expand-1
,string ,macrostep-expand-compiler-macros ',context))
((:error error-message)
(error "%s" error-message))
((:ok expansion positions)
(list expansion positions))))
(defun macrostep-slime-insert (result _ignore)
"Insert RESULT at point, indenting to match the current column."
(cl-destructuring-bind (expansion positions) result
(let ((start (point))
(column-offset (current-column)))
(insert expansion)
(macrostep-slime--propertize-macros start positions)
(indent-rigidly start (point) column-offset))))
(defun macrostep-slime--propertize-macros (start-offset positions)
"Put text properties on macro forms."
(dolist (position positions)
(cl-destructuring-bind (operator type start)
position
(let ((open-paren-position
(+ start-offset start)))
(put-text-property open-paren-position
(1+ open-paren-position)
'macrostep-macro-start
t)
;; this assumes that the operator starts right next to the
;; opening parenthesis. We could probably be more robust.
(let ((op-start (1+ open-paren-position)))
(put-text-property op-start
(+ op-start (length operator))
'font-lock-face
(if (eq type :macro)
'macrostep-macro-face
'macrostep-compiler-macro-face)))))))
(defun macrostep-slime-macro-form-p (string context)
(slime-dcase
(slime-eval
`(swank-macrostep:macro-form-p
,string ,macrostep-expand-compiler-macros ',context))
((:error error-message)
(error "%s" error-message))
((:ok result)
result)))
(provide 'slime-macrostep)

BIN
elpa/slime-20180413.1720/contrib/slime-macrostep.elc Normal file
View File

Binary file not shown.

31
elpa/slime-20180413.1720/contrib/slime-mdot-fu.el Normal file
View File

@@ -0,0 +1,31 @@
(require 'slime)
(require 'cl-lib)
(define-slime-contrib slime-mdot-fu
"Making M-. work on local functions."
(:authors "Tobias C. Rittweiler <tcr@freebits.de>")
(:license "GPL")
(:slime-dependencies slime-enclosing-context)
(:on-load
(add-hook 'slime-edit-definition-hooks 'slime-edit-local-definition))
(:on-unload
(remove-hook 'slime-edit-definition-hooks 'slime-edit-local-definition)))
(defun slime-edit-local-definition (name &optional where)
"Like `slime-edit-definition', but tries to find the definition
in a local function binding near point."
(interactive (list (slime-read-symbol-name "Name: ")))
(cl-multiple-value-bind (binding-name point)
(cl-multiple-value-call #'cl-some #'(lambda (binding-name point)
(when (cl-equalp binding-name name)
(cl-values binding-name point)))
(slime-enclosing-bound-names))
(when (and binding-name point)
(slime-edit-definition-cont
`((,binding-name
,(make-slime-buffer-location (buffer-name (current-buffer)) point)))
name
where))))
(provide 'slime-mdot-fu)

BIN
elpa/slime-20180413.1720/contrib/slime-mdot-fu.elc Normal file
View File

Binary file not shown.

46
elpa/slime-20180413.1720/contrib/slime-media.el Normal file
View File

@@ -0,0 +1,46 @@
(eval-and-compile
(require 'slime))
(define-slime-contrib slime-media
"Display things other than text in SLIME buffers"
(:authors "Christophe Rhodes <csr21@cantab.net>")
(:license "GPL")
(:slime-dependencies slime-repl)
(:swank-dependencies swank-media)
(:on-load
(add-hook 'slime-event-hooks 'slime-dispatch-media-event)))
(defun slime-media-decode-image (image)
(mapcar (lambda (image)
(if (plist-get image :data)
(plist-put image :data (base64-decode-string (plist-get image :data)))
image))
image))
(defun slime-dispatch-media-event (event)
(slime-dcase event
((:write-image image string)
(let ((img (or (find-image (slime-media-decode-image image))
(create-image image))))
(slime-media-insert-image img string))
t)
((:popup-buffer bufname string mode)
(slime-with-popup-buffer (bufname :connection t :package t)
(when mode (funcall mode))
(princ string)
(goto-char (point-min)))
t)
(t nil)))
(defun slime-media-insert-image (image string &optional bol)
(with-current-buffer (slime-output-buffer)
(let ((marker (slime-output-target-marker :repl-result)))
(goto-char marker)
(slime-propertize-region `(face slime-repl-result-face
rear-nonsticky (face))
(insert-image image string))
;; Move the input-start marker after the REPL result.
(set-marker marker (point)))
(slime-repl-show-maximum-output)))
(provide 'slime-media)

BIN
elpa/slime-20180413.1720/contrib/slime-media.elc Normal file
View File

Binary file not shown.

150
elpa/slime-20180413.1720/contrib/slime-mrepl.el Normal file
View File

@@ -0,0 +1,150 @@
;; An experimental implementation of multiple REPLs multiplexed over a
;; single Slime socket. M-x slime-new-mrepl creates a new REPL buffer.
;;
(require 'slime)
(require 'inferior-slime) ; inferior-slime-indent-lime
(require 'cl-lib)
(define-slime-contrib slime-mrepl
"Multiple REPLs."
(:authors "Helmut Eller <heller@common-lisp.net>")
(:license "GPL")
(:swank-dependencies swank-mrepl))
(require 'comint)
(defvar slime-mrepl-remote-channel nil)
(defvar slime-mrepl-expect-sexp nil)
(define-derived-mode slime-mrepl-mode comint-mode "mrepl"
;; idea lifted from ielm
(unless (get-buffer-process (current-buffer))
(let* ((process-connection-type nil)
(proc (start-process "mrepl (dummy)" (current-buffer) "hexl")))
(set-process-query-on-exit-flag proc nil)))
(set (make-local-variable 'comint-use-prompt-regexp) nil)
(set (make-local-variable 'comint-inhibit-carriage-motion) t)
(set (make-local-variable 'comint-input-sender) 'slime-mrepl-input-sender)
(set (make-local-variable 'comint-output-filter-functions) nil)
(set (make-local-variable 'slime-mrepl-expect-sexp) t)
;;(set (make-local-variable 'comint-get-old-input) 'ielm-get-old-input)
(set-syntax-table lisp-mode-syntax-table)
)
(slime-define-keys slime-mrepl-mode-map
((kbd "RET") 'slime-mrepl-return)
([return] 'slime-mrepl-return)
;;((kbd "TAB") 'slime-indent-and-complete-symbol)
((kbd "C-c C-b") 'slime-interrupt)
((kbd "C-c C-c") 'slime-interrupt))
(defun slime-mrepl-process% () (get-buffer-process (current-buffer))) ;stupid
(defun slime-mrepl-mark () (process-mark (slime-mrepl-process%)))
(defun slime-mrepl-insert (string)
(comint-output-filter (slime-mrepl-process%) string))
(slime-define-channel-type listener)
(slime-define-channel-method listener :prompt (package prompt)
(with-current-buffer (slime-channel-get self 'buffer)
(slime-mrepl-prompt package prompt)))
(defun slime-mrepl-prompt (package prompt)
(setf slime-buffer-package package)
(slime-mrepl-insert (format "%s%s> "
(cl-case (current-column)
(0 "")
(t "\n"))
prompt))
(slime-mrepl-recenter))
(defun slime-mrepl-recenter ()
(when (get-buffer-window)
(recenter -1)))
(slime-define-channel-method listener :write-result (result)
(with-current-buffer (slime-channel-get self 'buffer)
(goto-char (point-max))
(slime-mrepl-insert result)))
(slime-define-channel-method listener :evaluation-aborted ()
(with-current-buffer (slime-channel-get self 'buffer)
(goto-char (point-max))
(slime-mrepl-insert "; Evaluation aborted\n")))
(slime-define-channel-method listener :write-string (string)
(slime-mrepl-write-string self string))
(defun slime-mrepl-write-string (self string)
(with-current-buffer (slime-channel-get self 'buffer)
(goto-char (slime-mrepl-mark))
(slime-mrepl-insert string)))
(slime-define-channel-method listener :set-read-mode (mode)
(with-current-buffer (slime-channel-get self 'buffer)
(cl-ecase mode
(:read (setq slime-mrepl-expect-sexp nil)
(message "[Listener is waiting for input]"))
(:eval (setq slime-mrepl-expect-sexp t)))))
(defun slime-mrepl-return (&optional end-of-input)
(interactive "P")
(slime-check-connected)
(goto-char (point-max))
(cond ((and slime-mrepl-expect-sexp
(or (slime-input-complete-p (slime-mrepl-mark) (point))
end-of-input))
(comint-send-input))
((not slime-mrepl-expect-sexp)
(unless end-of-input
(insert "\n"))
(comint-send-input t))
(t
(insert "\n")
(inferior-slime-indent-line)
(message "[input not complete]")))
(slime-mrepl-recenter))
(defun slime-mrepl-input-sender (proc string)
(slime-mrepl-send-string (substring-no-properties string)))
(defun slime-mrepl-send-string (string &optional command-string)
(slime-mrepl-send `(:process ,string)))
(defun slime-mrepl-send (msg)
"Send MSG to the remote channel."
(slime-send-to-remote-channel slime-mrepl-remote-channel msg))
(defun slime-new-mrepl ()
"Create a new listener window."
(interactive)
(let ((channel (slime-make-channel slime-listener-channel-methods)))
(slime-eval-async
`(swank-mrepl:create-mrepl ,(slime-channel.id channel))
(slime-rcurry
(lambda (result channel)
(cl-destructuring-bind (remote thread-id package prompt) result
(pop-to-buffer (generate-new-buffer (slime-buffer-name :mrepl)))
(slime-mrepl-mode)
(setq slime-current-thread thread-id)
(setq slime-buffer-connection (slime-connection))
(set (make-local-variable 'slime-mrepl-remote-channel) remote)
(slime-channel-put channel 'buffer (current-buffer))
(slime-channel-send channel `(:prompt ,package ,prompt))))
channel))))
(defun slime-mrepl ()
(let ((conn (slime-connection)))
(cl-find-if (lambda (x)
(with-current-buffer x
(and (eq major-mode 'slime-mrepl-mode)
(eq (slime-current-connection) conn))))
(buffer-list))))
(def-slime-selector-method ?m
"First mrepl-buffer"
(or (slime-mrepl)
(error "No mrepl buffer (%s)" (slime-connection-name))))
(provide 'slime-mrepl)

BIN
elpa/slime-20180413.1720/contrib/slime-mrepl.elc Normal file
View File

Binary file not shown.

320
elpa/slime-20180413.1720/contrib/slime-package-fu.el Normal file
View File

@@ -0,0 +1,320 @@
(require 'slime)
(require 'slime-c-p-c)
(require 'slime-parse)
(defvar slime-package-fu-init-undo-stack nil)
(define-slime-contrib slime-package-fu
"Exporting/Unexporting symbols at point."
(:authors "Tobias C. Rittweiler <tcr@freebits.de>")
(:license "GPL")
(:swank-dependencies swank-package-fu)
(:on-load
(push `(progn (define-key slime-mode-map "\C-cx"
',(lookup-key slime-mode-map "\C-cx")))
slime-package-fu-init-undo-stack)
(define-key slime-mode-map "\C-cx" 'slime-export-symbol-at-point))
(:on-unload
(while slime-c-p-c-init-undo-stack
(eval (pop slime-c-p-c-init-undo-stack)))))
(defvar slime-package-file-candidates
(mapcar #'file-name-nondirectory
'("package.lisp" "packages.lisp" "pkgdcl.lisp"
"defpackage.lisp")))
(defvar slime-export-symbol-representation-function
#'(lambda (n) (format "#:%s" n)))
(defvar slime-export-symbol-representation-auto t
"Determine automatically which style is used for symbols, #: or :
If it's mixed or no symbols are exported so far,
use `slime-export-symbol-representation-function'.")
(defvar slime-export-save-file nil
"Save the package file after each automatic modification")
(defvar slime-defpackage-regexp
"^(\\(cl:\\|common-lisp:\\)?defpackage\\>[ \t']*")
(defun slime-find-package-definition-rpc (package)
(slime-eval `(swank:find-definition-for-thing
(swank::guess-package ,package))))
(defun slime-find-package-definition-regexp (package)
(save-excursion
(save-match-data
(goto-char (point-min))
(cl-block nil
(while (re-search-forward slime-defpackage-regexp nil t)
(when (slime-package-equal package (slime-sexp-at-point))
(backward-sexp)
(cl-return (make-slime-file-location (buffer-file-name)
(1- (point))))))))))
(defun slime-package-equal (designator1 designator2)
;; First try to be lucky and compare the strings themselves (for the
;; case when one of the designated packages isn't loaded in the
;; image.) Then try to do it properly using the inferior Lisp which
;; will also resolve nicknames for us &c.
(or (cl-equalp (slime-cl-symbol-name designator1)
(slime-cl-symbol-name designator2))
(slime-eval `(swank:package= ,designator1 ,designator2))))
(defun slime-export-symbol (symbol package)
"Unexport `symbol' from `package' in the Lisp image."
(slime-eval `(swank:export-symbol-for-emacs ,symbol ,package)))
(defun slime-unexport-symbol (symbol package)
"Export `symbol' from `package' in the Lisp image."
(slime-eval `(swank:unexport-symbol-for-emacs ,symbol ,package)))
(defun slime-find-possible-package-file (buffer-file-name)
(cl-labels ((file-name-subdirectory (dirname)
(expand-file-name
(concat (file-name-as-directory (slime-to-lisp-filename dirname))
(file-name-as-directory ".."))))
(try (dirname)
(cl-dolist (package-file-name slime-package-file-candidates)
(let ((f (slime-to-lisp-filename
(concat dirname package-file-name))))
(when (file-readable-p f)
(cl-return f))))))
(when buffer-file-name
(let ((buffer-cwd (file-name-directory buffer-file-name)))
(or (try buffer-cwd)
(try (file-name-subdirectory buffer-cwd))
(try (file-name-subdirectory
(file-name-subdirectory buffer-cwd))))))))
(defun slime-goto-package-source-definition (package)
"Tries to find the DEFPACKAGE form of `package'. If found,
places the cursor at the start of the DEFPACKAGE form."
(cl-labels ((try (location)
(when (slime-location-p location)
(slime-goto-source-location location)
t)))
(or (try (slime-find-package-definition-rpc package))
(try (slime-find-package-definition-regexp package))
(try (let ((package-file (slime-find-possible-package-file
(buffer-file-name))))
(when package-file
(with-current-buffer (find-file-noselect package-file t)
(slime-find-package-definition-regexp package)))))
(error "Couldn't find source definition of package: %s" package))))
(defun slime-at-expression-p (pattern)
(when (ignore-errors
;; at a list?
(= (point) (progn (down-list 1)
(backward-up-list 1)
(point))))
(save-excursion
(down-list 1)
(slime-in-expression-p pattern))))
(defun slime-goto-next-export-clause ()
;; Assumes we're inside the beginning of a DEFPACKAGE form.
(let ((point))
(save-excursion
(cl-block nil
(while (ignore-errors (slime-forward-sexp) t)
(skip-chars-forward " \n\t")
(when (slime-at-expression-p '(:export *))
(setq point (point))
(cl-return)))))
(if point
(goto-char point)
(error "No next (:export ...) clause found"))))
(defun slime-search-exports-in-defpackage (symbol-name)
"Look if `symbol-name' is mentioned in one of the :EXPORT clauses."
;; Assumes we're inside the beginning of a DEFPACKAGE form.
(cl-labels ((target-symbol-p (symbol)
(string-match-p (format "^\\(\\(#:\\)\\|:\\)?%s$"
(regexp-quote symbol-name))
symbol)))
(save-excursion
(cl-block nil
(while (ignore-errors (slime-goto-next-export-clause) t)
(let ((clause-end (save-excursion (forward-sexp) (point))))
(save-excursion
(while (search-forward symbol-name clause-end t)
(when (target-symbol-p (slime-symbol-at-point))
(cl-return (if (slime-inside-string-p)
;; Include the following "
(1+ (point))
(point))))))))))))
(defun slime-export-symbols ()
"Return a list of symbols inside :export clause of a defpackage."
;; Assumes we're at the beginning of :export
(cl-labels ((read-sexp ()
(ignore-errors
(forward-comment (point-max))
(buffer-substring-no-properties
(point) (progn (forward-sexp) (point))))))
(save-excursion
(cl-loop for sexp = (read-sexp) while sexp collect sexp))))
(defun slime-defpackage-exports ()
"Return a list of symbols inside :export clause of a defpackage."
;; Assumes we're inside the beginning of a DEFPACKAGE form.
(cl-labels ((normalize-name (name)
(if (string-prefix-p "\"" name)
(read name)
(replace-regexp-in-string "^\\(\\(#:\\)\\|:\\)"
"" name))))
(save-excursion
(mapcar #'normalize-name
(cl-loop while (ignore-errors (slime-goto-next-export-clause) t)
do (down-list) (forward-sexp)
append (slime-export-symbols)
do (up-list) (backward-sexp))))))
(defun slime-symbol-exported-p (name symbols)
(cl-member name symbols :test 'cl-equalp))
(defun slime-frob-defpackage-form (current-package do-what symbols)
"Adds/removes `symbol' from the DEFPACKAGE form of `current-package'
depending on the value of `do-what' which can either be `:export',
or `:unexport'.
Returns t if the symbol was added/removed. Nil if the symbol was
already exported/unexported."
(save-excursion
(slime-goto-package-source-definition current-package)
(down-list 1) ; enter DEFPACKAGE form
(forward-sexp) ; skip DEFPACKAGE symbol
;; Don't or will fail if (:export ...) is immediately following
;; (forward-sexp) ; skip package name
(let ((exported-symbols (slime-defpackage-exports))
(symbols (if (consp symbols)
symbols
(list symbols)))
(number-of-actions 0))
(cl-ecase do-what
(:export
(slime-add-export)
(dolist (symbol symbols)
(let ((symbol-name (slime-cl-symbol-name symbol)))
(unless (slime-symbol-exported-p symbol-name exported-symbols)
(cl-incf number-of-actions)
(slime-insert-export symbol-name)))))
(:unexport
(dolist (symbol symbols)
(let ((symbol-name (slime-cl-symbol-name symbol)))
(when (slime-symbol-exported-p symbol-name exported-symbols)
(slime-remove-export symbol-name)
(cl-incf number-of-actions))))))
(when slime-export-save-file
(save-buffer))
number-of-actions)))
(defun slime-add-export ()
(let (point)
(save-excursion
(while (ignore-errors (slime-goto-next-export-clause) t)
(setq point (point))))
(cond (point
(goto-char point)
(down-list)
(slime-end-of-list))
(t
(slime-end-of-list)
(unless (looking-back "^\\s-*")
(newline-and-indent))
(insert "(:export ")
(save-excursion (insert ")"))))))
(defun slime-determine-symbol-style ()
;; Assumes we're inside :export
(save-excursion
(slime-beginning-of-list)
(slime-forward-sexp)
(let ((symbols (slime-export-symbols)))
(cond ((null symbols)
slime-export-symbol-representation-function)
((cl-every (lambda (x)
(string-match "^:" x))
symbols)
(lambda (n) (format ":%s" n)))
((cl-every (lambda (x)
(string-match "^#:" x))
symbols)
(lambda (n) (format "#:%s" n)))
((cl-every (lambda (x)
(string-prefix-p "\"" x))
symbols)
(lambda (n) (prin1-to-string (upcase (substring-no-properties n)))))
(t
slime-export-symbol-representation-function)))))
(defun slime-format-symbol-for-defpackage (symbol-name)
(funcall (if slime-export-symbol-representation-auto
(slime-determine-symbol-style)
slime-export-symbol-representation-function)
symbol-name))
(defun slime-insert-export (symbol-name)
;; Assumes we're at the inside :export after the last symbol
(let ((symbol-name (slime-format-symbol-for-defpackage symbol-name)))
(unless (looking-back "^\\s-*")
(newline-and-indent))
(insert symbol-name)))
(defun slime-remove-export (symbol-name)
;; Assumes we're inside the beginning of a DEFPACKAGE form.
(let ((point))
(while (setq point (slime-search-exports-in-defpackage symbol-name))
(save-excursion
(goto-char point)
(backward-sexp)
(delete-region (point) point)
(beginning-of-line)
(when (looking-at "^\\s-*$")
(join-line)
(delete-trailing-whitespace (point) (line-end-position)))))))
(defun slime-export-symbol-at-point ()
"Add the symbol at point to the defpackage source definition
belonging to the current buffer-package. With prefix-arg, remove
the symbol again. Additionally performs an EXPORT/UNEXPORT of the
symbol in the Lisp image if possible."
(interactive)
(let ((package (slime-current-package))
(symbol (slime-symbol-at-point)))
(unless symbol (error "No symbol at point."))
(cond (current-prefix-arg
(if (cl-plusp (slime-frob-defpackage-form package :unexport symbol))
(message "Symbol `%s' no longer exported form `%s'"
symbol package)
(message "Symbol `%s' is not exported from `%s'"
symbol package))
(slime-unexport-symbol symbol package))
(t
(if (cl-plusp (slime-frob-defpackage-form package :export symbol))
(message "Symbol `%s' now exported from `%s'"
symbol package)
(message "Symbol `%s' already exported from `%s'"
symbol package))
(slime-export-symbol symbol package)))))
(defun slime-export-class (name)
"Export acessors, constructors, etc. associated with a structure or a class"
(interactive (list (slime-read-from-minibuffer "Export structure named: "
(slime-symbol-at-point))))
(let* ((package (slime-current-package))
(symbols (slime-eval `(swank:export-structure ,name ,package))))
(message "%s symbols exported from `%s'"
(slime-frob-defpackage-form package :export symbols)
package)))
(defalias 'slime-export-structure 'slime-export-class)
(provide 'slime-package-fu)
;; Local Variables:
;; indent-tabs-mode: nil
;; End:

BIN
elpa/slime-20180413.1720/contrib/slime-package-fu.elc Normal file
View File

Binary file not shown.

358
elpa/slime-20180413.1720/contrib/slime-parse.el Normal file
View File

@@ -0,0 +1,358 @@
(require 'slime)
(require 'cl-lib)
(define-slime-contrib slime-parse
"Utility contrib containg functions to parse forms in a buffer."
(:authors "Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de>"
"Tobias C. Rittweiler <tcr@freebits.de>")
(:license "GPL"))
(defun slime-parse-form-until (limit form-suffix)
"Parses form from point to `limit'."
;; For performance reasons, this function does not use recursion.
(let ((todo (list (point))) ; stack of positions
(sexps) ; stack of expressions
(cursexp)
(curpos)
(depth 1)) ; This function must be called from the
; start of the sexp to be parsed.
(while (and (setq curpos (pop todo))
(progn
(goto-char curpos)
;; (Here we also move over suppressed
;; reader-conditionalized code! Important so CL-side
;; of autodoc won't see that garbage.)
(ignore-errors (slime-forward-cruft))
(< (point) limit)))
(setq cursexp (pop sexps))
(cond
;; End of an sexp?
((or (looking-at "\\s)") (eolp))
(cl-decf depth)
(push (nreverse cursexp) (car sexps)))
;; Start of a new sexp?
((looking-at "\\s'*\\s(")
(let ((subpt (match-end 0)))
(ignore-errors
(forward-sexp)
;; (In case of error, we're at an incomplete sexp, and
;; nothing's left todo after it.)
(push (point) todo))
(push cursexp sexps)
(push subpt todo) ; to descend into new sexp
(push nil sexps)
(cl-incf depth)))
;; In mid of an sexp..
(t
(let ((pt1 (point))
(pt2 (condition-case e
(progn (forward-sexp) (point))
(scan-error
(cl-fourth e))))) ; end of sexp
(push (buffer-substring-no-properties pt1 pt2) cursexp)
(push pt2 todo)
(push cursexp sexps)))))
(when sexps
(setf (car sexps) (cl-nreconc form-suffix (car sexps)))
(while (> depth 1)
(push (nreverse (pop sexps)) (car sexps))
(cl-decf depth))
(nreverse (car sexps)))))
(defun slime-compare-char-syntax (get-char-fn syntax &optional unescaped)
"Returns t if the character that `get-char-fn' yields has
characer syntax of `syntax'. If `unescaped' is true, it's ensured
that the character is not escaped."
(let ((char (funcall get-char-fn (point)))
(char-before (funcall get-char-fn (1- (point)))))
(if (and char (eq (char-syntax char) (aref syntax 0)))
(if unescaped
(or (null char-before)
(not (eq (char-syntax char-before) ?\\)))
t)
nil)))
(defconst slime-cursor-marker 'swank::%cursor-marker%)
(defun slime-parse-form-upto-point (&optional max-levels)
(save-restriction
;; Don't parse more than 500 lines before point, so we don't spend
;; too much time. NB. Make sure to go to beginning of line, and
;; not possibly anywhere inside comments or strings.
(narrow-to-region (line-beginning-position -500) (point-max))
(save-excursion
(let ((suffix (list slime-cursor-marker)))
(cond ((slime-compare-char-syntax #'char-after "(" t)
;; We're at the start of some expression, so make sure
;; that SWANK::%CURSOR-MARKER% will come after that
;; expression. If the expression is not balanced, make
;; still sure that the marker does *not* come directly
;; after the preceding expression.
(or (ignore-errors (forward-sexp) t)
(push "" suffix)))
((or (bolp) (slime-compare-char-syntax #'char-before " " t))
;; We're after some expression, so we have to make sure
;; that %CURSOR-MARKER% does *not* come directly after
;; that expression.
(push "" suffix))
((slime-compare-char-syntax #'char-before "(" t)
;; We're directly after an opening parenthesis, so we
;; have to make sure that something comes before
;; %CURSOR-MARKER%.
(push "" suffix))
(t
;; We're at a symbol, so make sure we get the whole symbol.
(slime-end-of-symbol)))
(let ((pt (point)))
(ignore-errors (up-list (if max-levels (- max-levels) -5)))
(ignore-errors (down-list))
(slime-parse-form-until pt suffix))))))
(require 'bytecomp)
(mapc (lambda (sym)
(cond ((fboundp sym)
(unless (byte-code-function-p (symbol-function sym))
(byte-compile sym)))
(t (error "%S is not fbound" sym))))
'(slime-parse-form-upto-point
slime-parse-form-until
slime-compare-char-syntax))
;;;; Test cases
(defun slime-extract-context ()
"Parse the context for the symbol at point.
Nil is returned if there's no symbol at point. Otherwise we detect
the following cases (the . shows the point position):
(defun n.ame (...) ...) -> (:defun name)
(defun (setf n.ame) (...) ...) -> (:defun (setf name))
(defmethod n.ame (...) ...) -> (:defmethod name (...))
(defun ... (...) (labels ((n.ame (...) -> (:labels (:defun ...) name)
(defun ... (...) (flet ((n.ame (...) -> (:flet (:defun ...) name)
(defun ... (...) ... (n.ame ...) ...) -> (:call (:defun ...) name)
(defun ... (...) ... (setf (n.ame ...) -> (:call (:defun ...) (setf name))
(defmacro n.ame (...) ...) -> (:defmacro name)
(defsetf n.ame (...) ...) -> (:defsetf name)
(define-setf-expander n.ame (...) ...) -> (:define-setf-expander name)
(define-modify-macro n.ame (...) ...) -> (:define-modify-macro name)
(define-compiler-macro n.ame (...) ...) -> (:define-compiler-macro name)
(defvar n.ame (...) ...) -> (:defvar name)
(defparameter n.ame ...) -> (:defparameter name)
(defconstant n.ame ...) -> (:defconstant name)
(defclass n.ame ...) -> (:defclass name)
(defstruct n.ame ...) -> (:defstruct name)
(defpackage n.ame ...) -> (:defpackage name)
For other contexts we return the symbol at point."
(let ((name (slime-symbol-at-point)))
(if name
(let ((symbol (read name)))
(or (progn ;;ignore-errors
(slime-parse-context symbol))
symbol)))))
(defun slime-parse-context (name)
(save-excursion
(cond ((slime-in-expression-p '(defun *)) `(:defun ,name))
((slime-in-expression-p '(defmacro *)) `(:defmacro ,name))
((slime-in-expression-p '(defgeneric *)) `(:defgeneric ,name))
((slime-in-expression-p '(setf *))
;;a setf-definition, but which?
(backward-up-list 1)
(slime-parse-context `(setf ,name)))
((slime-in-expression-p '(defmethod *))
(unless (looking-at "\\s ")
(forward-sexp 1)) ; skip over the methodname
(let (qualifiers arglist)
(cl-loop for e = (read (current-buffer))
until (listp e) do (push e qualifiers)
finally (setq arglist e))
`(:defmethod ,name ,@qualifiers
,(slime-arglist-specializers arglist))))
((and (symbolp name)
(slime-in-expression-p `(,name)))
;; looks like a regular call
(let ((toplevel (ignore-errors (slime-parse-toplevel-form))))
(cond ((slime-in-expression-p `(setf (*))) ;a setf-call
(if toplevel
`(:call ,toplevel (setf ,name))
`(setf ,name)))
((not toplevel)
name)
((slime-in-expression-p `(labels ((*))))
`(:labels ,toplevel ,name))
((slime-in-expression-p `(flet ((*))))
`(:flet ,toplevel ,name))
(t
`(:call ,toplevel ,name)))))
((slime-in-expression-p '(define-compiler-macro *))
`(:define-compiler-macro ,name))
((slime-in-expression-p '(define-modify-macro *))
`(:define-modify-macro ,name))
((slime-in-expression-p '(define-setf-expander *))
`(:define-setf-expander ,name))
((slime-in-expression-p '(defsetf *))
`(:defsetf ,name))
((slime-in-expression-p '(defvar *)) `(:defvar ,name))
((slime-in-expression-p '(defparameter *)) `(:defparameter ,name))
((slime-in-expression-p '(defconstant *)) `(:defconstant ,name))
((slime-in-expression-p '(defclass *)) `(:defclass ,name))
((slime-in-expression-p '(defpackage *)) `(:defpackage ,name))
((slime-in-expression-p '(defstruct *))
`(:defstruct ,(if (consp name)
(car name)
name)))
(t
name))))
(defun slime-in-expression-p (pattern)
"A helper function to determine the current context.
The pattern can have the form:
pattern ::= () ;matches always
| (*) ;matches inside a list
| (<symbol> <pattern>) ;matches if the first element in
; the current list is <symbol> and
; if <pattern> matches.
| ((<pattern>)) ;matches if we are in a nested list."
(save-excursion
(let ((path (reverse (slime-pattern-path pattern))))
(cl-loop for p in path
always (ignore-errors
(cl-etypecase p
(symbol (slime-beginning-of-list)
(eq (read (current-buffer)) p))
(number (backward-up-list p)
t)))))))
(defun slime-pattern-path (pattern)
;; Compute the path to the * in the pattern to make matching
;; easier. The path is a list of symbols and numbers. A number
;; means "(down-list <n>)" and a symbol "(look-at <sym>)")
(if (null pattern)
'()
(cl-etypecase (car pattern)
((member *) '())
(symbol (cons (car pattern) (slime-pattern-path (cdr pattern))))
(cons (cons 1 (slime-pattern-path (car pattern)))))))
(defun slime-beginning-of-list (&optional up)
"Move backward to the beginning of the current expression.
Point is placed before the first expression in the list."
(backward-up-list (or up 1))
(down-list 1)
(skip-syntax-forward " "))
(defun slime-end-of-list (&optional up)
(backward-up-list (or up 1))
(forward-list 1)
(down-list -1))
(defun slime-parse-toplevel-form ()
(ignore-errors ; (foo)
(save-excursion
(goto-char (car (slime-region-for-defun-at-point)))
(down-list 1)
(forward-sexp 1)
(slime-parse-context (read (current-buffer))))))
(defun slime-arglist-specializers (arglist)
(cond ((or (null arglist)
(member (cl-first arglist) '(&optional &key &rest &aux)))
(list))
((consp (cl-first arglist))
(cons (cl-second (cl-first arglist))
(slime-arglist-specializers (cl-rest arglist))))
(t
(cons 't
(slime-arglist-specializers (cl-rest arglist))))))
(defun slime-definition-at-point (&optional only-functional)
"Return object corresponding to the definition at point."
(let ((toplevel (slime-parse-toplevel-form)))
(if (or (symbolp toplevel)
(and only-functional
(not (member (car toplevel)
'(:defun :defgeneric :defmethod
:defmacro :define-compiler-macro)))))
(error "Not in a definition")
(slime-dcase toplevel
(((:defun :defgeneric) symbol)
(format "#'%s" symbol))
(((:defmacro :define-modify-macro) symbol)
(format "(macro-function '%s)" symbol))
((:define-compiler-macro symbol)
(format "(compiler-macro-function '%s)" symbol))
((:defmethod symbol &rest args)
(declare (ignore args))
(format "#'%s" symbol))
(((:defparameter :defvar :defconstant) symbol)
(format "'%s" symbol))
(((:defclass :defstruct) symbol)
(format "(find-class '%s)" symbol))
((:defpackage symbol)
(format "(or (find-package '%s) (error \"Package %s not found\"))"
symbol symbol))
(t
(error "Not in a definition"))))))
(defsubst slime-current-parser-state ()
;; `syntax-ppss' does not save match data as it invokes
;; `beginning-of-defun' implicitly which does not save match
;; data. This issue has been reported to the Emacs maintainer on
;; Feb27.
(syntax-ppss))
(defun slime-inside-string-p ()
(nth 3 (slime-current-parser-state)))
(defun slime-inside-comment-p ()
(nth 4 (slime-current-parser-state)))
(defun slime-inside-string-or-comment-p ()
(let ((state (slime-current-parser-state)))
(or (nth 3 state) (nth 4 state))))
;;; The following two functions can be handy when inspecting
;;; source-location while debugging `M-.'.
;;;
(defun slime-current-tlf-number ()
"Return the current toplevel number."
(interactive)
(let ((original-pos (car (slime-region-for-defun-at-point)))
(n 0))
(save-excursion
;; We use this and no repeated `beginning-of-defun's to get
;; reader conditionals right.
(goto-char (point-min))
(while (progn (slime-forward-sexp)
(< (point) original-pos))
(cl-incf n)))
n))
;;; This is similiar to `slime-enclosing-form-paths' in the
;;; `slime-parse' contrib except that this does not do any duck-tape
;;; parsing, and gets reader conditionals right.
(defun slime-current-form-path ()
"Returns the path from the beginning of the current toplevel
form to the atom at point, or nil if we're in front of a tlf."
(interactive)
(let ((source-path nil))
(save-excursion
;; Moving forward to get reader conditionals right.
(cl-loop for inner-pos = (point)
for outer-pos = (cl-nth-value 1 (slime-current-parser-state))
while outer-pos do
(goto-char outer-pos)
(unless (eq (char-before) ?#) ; when at #(...) continue.
(forward-char)
(let ((n 0))
(while (progn (slime-forward-sexp)
(< (point) inner-pos))
(cl-incf n))
(push n source-path)
(goto-char outer-pos)))))
source-path))
(provide 'slime-parse)

BIN
elpa/slime-20180413.1720/contrib/slime-parse.elc Normal file
View File

Binary file not shown.

18
elpa/slime-20180413.1720/contrib/slime-presentation-streams.el Normal file
View File

@@ -0,0 +1,18 @@
(eval-and-compile
(require 'slime))
(define-slime-contrib slime-presentation-streams
"Streams that allow attaching object identities to portions of
output."
(:authors "Alan Ruttenberg <alanr-l@mumble.net>"
"Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de>"
"Helmut Eller <heller@common-lisp.net>")
(:license "GPL")
(:on-load
(add-hook 'slime-connected-hook 'slime-presentation-streams-on-connected))
(:swank-dependencies swank-presentation-streams))
(defun slime-presentation-streams-on-connected ()
(slime-eval `(swank:init-presentation-streams)))
(provide 'slime-presentation-streams)

BIN
elpa/slime-20180413.1720/contrib/slime-presentation-streams.elc Normal file
View File

Binary file not shown.

872
elpa/slime-20180413.1720/contrib/slime-presentations.el Normal file
View File

@@ -0,0 +1,872 @@
(require 'slime)
(require 'bridge)
(require 'cl-lib)
(eval-when-compile
(require 'cl))
(define-slime-contrib slime-presentations
"Imitate LispM presentations."
(:authors "Alan Ruttenberg <alanr-l@mumble.net>"
"Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de>")
(:license "GPL")
(:slime-dependencies slime-repl)
(:swank-dependencies swank-presentations)
(:on-load
(add-hook 'slime-repl-mode-hook
(lambda ()
;; Respect the syntax text properties of presentation.
(set (make-local-variable 'parse-sexp-lookup-properties) t)
(add-hook 'after-change-functions
'slime-after-change-function 'append t)))
(add-hook 'slime-event-hooks 'slime-dispatch-presentation-event)
(setq slime-write-string-function 'slime-presentation-write)
(add-hook 'slime-connected-hook 'slime-presentations-on-connected)
(add-hook 'slime-repl-return-hooks 'slime-presentation-on-return-pressed)
(add-hook 'slime-repl-current-input-hooks 'slime-presentation-current-input)
(add-hook 'slime-open-stream-hooks 'slime-presentation-on-stream-open)
(add-hook 'slime-repl-clear-buffer-hook 'slime-clear-presentations)
(add-hook 'slime-edit-definition-hooks 'slime-edit-presentation)
(setq sldb-insert-frame-variable-value-function
'slime-presentation-sldb-insert-frame-variable-value)
(slime-presentation-init-keymaps)
(slime-presentation-add-easy-menu)))
;; To get presentations in the inspector as well, add this to your
;; init file.
;;
;; (eval-after-load 'slime-presentations
;; '(setq slime-inspector-insert-ispec-function
;; 'slime-presentation-inspector-insert-ispec))
;;
(defface slime-repl-output-mouseover-face
'((t (:box (:line-width 1 :color "black" :style released-button)
:inherit slime-repl-inputed-output-face)))
"Face for Lisp output in the SLIME REPL, when the mouse hovers over it"
:group 'slime-repl)
(defface slime-repl-inputed-output-face
'((((class color) (background light)) (:foreground "Red"))
(((class color) (background dark)) (:foreground "Red"))
(t (:slant italic)))
"Face for the result of an evaluation in the SLIME REPL."
:group 'slime-repl)
;; FIXME: This conditional is not right - just used because the code
;; here does not work in XEmacs.
(when (boundp 'text-property-default-nonsticky)
(pushnew '(slime-repl-presentation . t) text-property-default-nonsticky
:test 'equal)
(pushnew '(slime-repl-result-face . t) text-property-default-nonsticky
:test 'equal))
(make-variable-buffer-local
(defvar slime-presentation-start-to-point (make-hash-table)))
(defun slime-mark-presentation-start (id &optional target)
"Mark the beginning of a presentation with the given ID.
TARGET can be nil (regular process output) or :repl-result."
(setf (gethash id slime-presentation-start-to-point)
;; We use markers because text can also be inserted before this presentation.
;; (Output arrives while we are writing presentations within REPL results.)
(copy-marker (slime-output-target-marker target) nil)))
(defun slime-mark-presentation-start-handler (process string)
(if (and string (string-match "<\\([-0-9]+\\)" string))
(let* ((match (substring string (match-beginning 1) (match-end 1)))
(id (car (read-from-string match))))
(slime-mark-presentation-start id))))
(defun slime-mark-presentation-end (id &optional target)
"Mark the end of a presentation with the given ID.
TARGET can be nil (regular process output) or :repl-result."
(let ((start (gethash id slime-presentation-start-to-point)))
(remhash id slime-presentation-start-to-point)
(when start
(let* ((marker (slime-output-target-marker target))
(buffer (and marker (marker-buffer marker))))
(with-current-buffer buffer
(let ((end (marker-position marker)))
(slime-add-presentation-properties start end
id nil)))))))
(defun slime-mark-presentation-end-handler (process string)
(if (and string (string-match ">\\([-0-9]+\\)" string))
(let* ((match (substring string (match-beginning 1) (match-end 1)))
(id (car (read-from-string match))))
(slime-mark-presentation-end id))))
(cl-defstruct slime-presentation text id)
(defvar slime-presentation-syntax-table
(let ((table (copy-syntax-table lisp-mode-syntax-table)))
;; We give < and > parenthesis syntax, so that #< ... > is treated
;; as a balanced expression. This allows to use C-M-k, C-M-SPC,
;; etc. to deal with a whole presentation. (For Lisp mode, this
;; is not desirable, since we do not wish to get a mismatched
;; paren highlighted everytime we type < or >.)
(modify-syntax-entry ?< "(>" table)
(modify-syntax-entry ?> ")<" table)
table)
"Syntax table for presentations.")
(defun slime-add-presentation-properties (start end id result-p)
"Make the text between START and END a presentation with ID.
RESULT-P decides whether a face for a return value or output text is used."
(let* ((text (buffer-substring-no-properties start end))
(presentation (make-slime-presentation :text text :id id)))
(let ((inhibit-modification-hooks t))
(add-text-properties start end
`(modification-hooks (slime-after-change-function)
insert-in-front-hooks (slime-after-change-function)
insert-behind-hooks (slime-after-change-function)
syntax-table ,slime-presentation-syntax-table
rear-nonsticky t))
;; Use the presentation as the key of a text property
(case (- end start)
(0)
(1
(add-text-properties start end
`(slime-repl-presentation ,presentation
,presentation :start-and-end)))
(t
(add-text-properties start (1+ start)
`(slime-repl-presentation ,presentation
,presentation :start))
(when (> (- end start) 2)
(add-text-properties (1+ start) (1- end)
`(,presentation :interior)))
(add-text-properties (1- end) end
`(slime-repl-presentation ,presentation
,presentation :end))))
;; Also put an overlay for the face and the mouse-face. This enables
;; highlighting of nested presentations. However, overlays get lost
;; when we copy a presentation; their removal is also not undoable.
;; In these cases the mouse-face text properties need to take over ---
;; but they do not give nested highlighting.
(slime-ensure-presentation-overlay start end presentation))))
(defvar slime-presentation-map (make-sparse-keymap))
(defun slime-ensure-presentation-overlay (start end presentation)
(unless (cl-find presentation (overlays-at start)
:key (lambda (overlay)
(overlay-get overlay 'slime-repl-presentation)))
(let ((overlay (make-overlay start end (current-buffer) t nil)))
(overlay-put overlay 'slime-repl-presentation presentation)
(overlay-put overlay 'mouse-face 'slime-repl-output-mouseover-face)
(overlay-put overlay 'help-echo
(if (eq major-mode 'slime-repl-mode)
"mouse-2: copy to input; mouse-3: menu"
"mouse-2: inspect; mouse-3: menu"))
(overlay-put overlay 'face 'slime-repl-inputed-output-face)
(overlay-put overlay 'keymap slime-presentation-map))))
(defun slime-remove-presentation-properties (from to presentation)
(let ((inhibit-read-only t))
(remove-text-properties from to
`(,presentation t syntax-table t rear-nonsticky t))
(when (eq (get-text-property from 'slime-repl-presentation) presentation)
(remove-text-properties from (1+ from) `(slime-repl-presentation t)))
(when (eq (get-text-property (1- to) 'slime-repl-presentation) presentation)
(remove-text-properties (1- to) to `(slime-repl-presentation t)))
(dolist (overlay (overlays-at from))
(when (eq (overlay-get overlay 'slime-repl-presentation) presentation)
(delete-overlay overlay)))))
(defun slime-insert-presentation (string output-id &optional rectangle)
"Insert STRING in current buffer and mark it as a presentation
corresponding to OUTPUT-ID. If RECTANGLE is true, indent multi-line
strings to line up below the current point."
(cl-labels ((insert-it ()
(if rectangle
(slime-insert-indented string)
(insert string))))
(let ((start (point)))
(insert-it)
(slime-add-presentation-properties start (point) output-id t))))
(defun slime-presentation-whole-p (presentation start end &optional object)
(let ((object (or object (current-buffer))))
(string= (etypecase object
(buffer (with-current-buffer object
(buffer-substring-no-properties start end)))
(string (substring-no-properties object start end)))
(slime-presentation-text presentation))))
(defun slime-presentations-around-point (point &optional object)
(let ((object (or object (current-buffer))))
(loop for (key value . rest) on (text-properties-at point object) by 'cddr
when (slime-presentation-p key)
collect key)))
(defun slime-presentation-start-p (tag)
(memq tag '(:start :start-and-end)))
(defun slime-presentation-stop-p (tag)
(memq tag '(:end :start-and-end)))
(cl-defun slime-presentation-start (point presentation
&optional (object (current-buffer)))
"Find start of `presentation' at `point' in `object'.
Return buffer index and whether a start-tag was found."
(let* ((this-presentation (get-text-property point presentation object)))
(while (not (slime-presentation-start-p this-presentation))
(let ((change-point (previous-single-property-change
point presentation object (point-min))))
(unless change-point
(return-from slime-presentation-start
(values (etypecase object
(buffer (with-current-buffer object 1))
(string 0))
nil)))
(setq this-presentation (get-text-property change-point
presentation object))
(unless this-presentation
(return-from slime-presentation-start
(values point nil)))
(setq point change-point)))
(values point t)))
(cl-defun slime-presentation-end (point presentation
&optional (object (current-buffer)))
"Find end of presentation at `point' in `object'. Return buffer
index (after last character of the presentation) and whether an
end-tag was found."
(let* ((this-presentation (get-text-property point presentation object)))
(while (not (slime-presentation-stop-p this-presentation))
(let ((change-point (next-single-property-change
point presentation object)))
(unless change-point
(return-from slime-presentation-end
(values (etypecase object
(buffer (with-current-buffer object (point-max)))
(string (length object)))
nil)))
(setq point change-point)
(setq this-presentation (get-text-property point
presentation object))))
(if this-presentation
(let ((after-end (next-single-property-change point
presentation object)))
(if (not after-end)
(values (etypecase object
(buffer (with-current-buffer object (point-max)))
(string (length object)))
t)
(values after-end t)))
(values point nil))))
(cl-defun slime-presentation-bounds (point presentation
&optional (object (current-buffer)))
"Return start index and end index of `presentation' around `point'
in `object', and whether the presentation is complete."
(multiple-value-bind (start good-start)
(slime-presentation-start point presentation object)
(multiple-value-bind (end good-end)
(slime-presentation-end point presentation object)
(values start end
(and good-start good-end
(slime-presentation-whole-p presentation
start end object))))))
(defun slime-presentation-around-point (point &optional object)
"Return presentation, start index, end index, and whether the
presentation is complete."
(let ((object (or object (current-buffer)))
(innermost-presentation nil)
(innermost-start 0)
(innermost-end most-positive-fixnum))
(dolist (presentation (slime-presentations-around-point point object))
(multiple-value-bind (start end whole-p)
(slime-presentation-bounds point presentation object)
(when whole-p
(when (< (- end start) (- innermost-end innermost-start))
(setq innermost-start start
innermost-end end
innermost-presentation presentation)))))
(values innermost-presentation
innermost-start innermost-end)))
(defun slime-presentation-around-or-before-point (point &optional object)
(let ((object (or object (current-buffer))))
(multiple-value-bind (presentation start end whole-p)
(slime-presentation-around-point point object)
(if (or presentation (= point (point-min)))
(values presentation start end whole-p)
(slime-presentation-around-point (1- point) object)))))
(defun slime-presentation-around-or-before-point-or-error (point)
(multiple-value-bind (presentation start end whole-p)
(slime-presentation-around-or-before-point point)
(unless presentation
(error "No presentation at point"))
(values presentation start end whole-p)))
(cl-defun slime-for-each-presentation-in-region (from to function
&optional (object (current-buffer)))
"Call `function' with arguments `presentation', `start', `end',
`whole-p' for every presentation in the region `from'--`to' in the
string or buffer `object'."
(cl-labels ((handle-presentation (presentation point)
(multiple-value-bind (start end whole-p)
(slime-presentation-bounds point presentation object)
(funcall function presentation start end whole-p))))
;; Handle presentations active at `from'.
(dolist (presentation (slime-presentations-around-point from object))
(handle-presentation presentation from))
;; Use the `slime-repl-presentation' property to search for new presentations.
(let ((point from))
(while (< point to)
(setq point (next-single-property-change point 'slime-repl-presentation
object to))
(let* ((presentation (get-text-property point 'slime-repl-presentation object))
(status (get-text-property point presentation object)))
(when (slime-presentation-start-p status)
(handle-presentation presentation point)))))))
;; XEmacs compatibility hack, from message by Stephen J. Turnbull on
;; xemacs-beta@xemacs.org of 18 Mar 2002
(unless (boundp 'undo-in-progress)
(defvar undo-in-progress nil
"Placeholder defvar for XEmacs compatibility from SLIME.")
(defadvice undo-more (around slime activate)
(let ((undo-in-progress t)) ad-do-it)))
(defun slime-after-change-function (start end &rest ignore)
"Check all presentations within and adjacent to the change.
When a presentation has been altered, change it to plain text."
(let ((inhibit-modification-hooks t))
(let ((real-start (max 1 (1- start)))
(real-end (min (1+ (buffer-size)) (1+ end)))
(any-change nil))
;; positions around the change
(slime-for-each-presentation-in-region
real-start real-end
(lambda (presentation from to whole-p)
(cond
(whole-p
(slime-ensure-presentation-overlay from to presentation))
((not undo-in-progress)
(slime-remove-presentation-properties from to
presentation)
(setq any-change t)))))
(when any-change
(undo-boundary)))))
(defun slime-presentation-around-click (event)
"Return the presentation around the position of the mouse-click EVENT.
If there is no presentation, signal an error.
Also return the start position, end position, and buffer of the presentation."
(when (and (featurep 'xemacs) (not (button-press-event-p event)))
(error "Command must be bound to a button-press-event"))
(let ((point (if (featurep 'xemacs) (event-point event) (posn-point (event-end event))))
(window (if (featurep 'xemacs) (event-window event) (caadr event))))
(with-current-buffer (window-buffer window)
(multiple-value-bind (presentation start end)
(slime-presentation-around-point point)
(unless presentation
(error "No presentation at click"))
(values presentation start end (current-buffer))))))
(defun slime-check-presentation (from to buffer presentation)
(unless (slime-eval `(cl:nth-value 1 (swank:lookup-presented-object
',(slime-presentation-id presentation))))
(with-current-buffer buffer
(slime-remove-presentation-properties from to presentation))))
(defun slime-copy-or-inspect-presentation-at-mouse (event)
(interactive "e") ; no "@" -- we don't want to select the clicked-at window
(multiple-value-bind (presentation start end buffer)
(slime-presentation-around-click event)
(slime-check-presentation start end buffer presentation)
(if (with-current-buffer buffer
(eq major-mode 'slime-repl-mode))
(slime-copy-presentation-at-mouse-to-repl event)
(slime-inspect-presentation-at-mouse event))))
(defun slime-inspect-presentation (presentation start end buffer)
(let ((reset-p
(with-current-buffer buffer
(not (eq major-mode 'slime-inspector-mode)))))
(slime-eval-async `(swank:inspect-presentation ',(slime-presentation-id presentation) ,reset-p)
'slime-open-inspector)))
(defun slime-inspect-presentation-at-mouse (event)
(interactive "e")
(multiple-value-bind (presentation start end buffer)
(slime-presentation-around-click event)
(slime-inspect-presentation presentation start end buffer)))
(defun slime-inspect-presentation-at-point (point)
(interactive "d")
(multiple-value-bind (presentation start end)
(slime-presentation-around-or-before-point-or-error point)
(slime-inspect-presentation presentation start end (current-buffer))))
(defun slime-M-.-presentation (presentation start end buffer &optional where)
(let* ((id (slime-presentation-id presentation))
(presentation-string (format "Presentation %s" id))
(location (slime-eval `(swank:find-definition-for-thing
(swank:lookup-presented-object
',(slime-presentation-id presentation))))))
(unless (eq (car location) :error)
(slime-edit-definition-cont
(and location (list (make-slime-xref :dspec `(,presentation-string)
:location location)))
presentation-string
where))))
(defun slime-M-.-presentation-at-mouse (event)
(interactive "e")
(multiple-value-bind (presentation start end buffer)
(slime-presentation-around-click event)
(slime-M-.-presentation presentation start end buffer)))
(defun slime-M-.-presentation-at-point (point)
(interactive "d")
(multiple-value-bind (presentation start end)
(slime-presentation-around-or-before-point-or-error point)
(slime-M-.-presentation presentation start end (current-buffer))))
(defun slime-edit-presentation (name &optional where)
(if (or current-prefix-arg (not (equal (slime-symbol-at-point) name)))
nil ; NAME came from user explicitly, so decline.
(multiple-value-bind (presentation start end whole-p)
(slime-presentation-around-or-before-point (point))
(when presentation
(slime-M-.-presentation presentation start end (current-buffer) where)))))
(defun slime-copy-presentation-to-repl (presentation start end buffer)
(let ((text (with-current-buffer buffer
;; we use the buffer-substring rather than the
;; presentation text to capture any overlays
(buffer-substring start end)))
(id (slime-presentation-id presentation)))
(unless (integerp id)
(setq id (slime-eval `(swank:lookup-and-save-presented-object-or-lose ',id))))
(unless (eql major-mode 'slime-repl-mode)
(slime-switch-to-output-buffer))
(cl-flet ((do-insertion ()
(unless (looking-back "\\s-" (- (point) 1))
(insert " "))
(slime-insert-presentation text id)
(unless (or (eolp) (looking-at "\\s-"))
(insert " "))))
(if (>= (point) slime-repl-prompt-start-mark)
(do-insertion)
(save-excursion
(goto-char (point-max))
(do-insertion))))))
(defun slime-copy-presentation-at-mouse-to-repl (event)
(interactive "e")
(multiple-value-bind (presentation start end buffer)
(slime-presentation-around-click event)
(slime-copy-presentation-to-repl presentation start end buffer)))
(defun slime-copy-presentation-at-point-to-repl (point)
(interactive "d")
(multiple-value-bind (presentation start end)
(slime-presentation-around-or-before-point-or-error point)
(slime-copy-presentation-to-repl presentation start end (current-buffer))))
(defun slime-copy-presentation-at-mouse-to-point (event)
(interactive "e")
(multiple-value-bind (presentation start end buffer)
(slime-presentation-around-click event)
(let ((presentation-text
(with-current-buffer buffer
(buffer-substring start end))))
(when (not (string-match "\\s-"
(buffer-substring (1- (point)) (point))))
(insert " "))
(insert presentation-text)
(slime-after-change-function (point) (point))
(when (and (not (eolp)) (not (looking-at "\\s-")))
(insert " ")))))
(defun slime-copy-presentation-to-kill-ring (presentation start end buffer)
(let ((presentation-text
(with-current-buffer buffer
(buffer-substring start end))))
(kill-new presentation-text)
(message "Saved presentation \"%s\" to kill ring" presentation-text)))
(defun slime-copy-presentation-at-mouse-to-kill-ring (event)
(interactive "e")
(multiple-value-bind (presentation start end buffer)
(slime-presentation-around-click event)
(slime-copy-presentation-to-kill-ring presentation start end buffer)))
(defun slime-copy-presentation-at-point-to-kill-ring (point)
(interactive "d")
(multiple-value-bind (presentation start end)
(slime-presentation-around-or-before-point-or-error point)
(slime-copy-presentation-to-kill-ring presentation start end (current-buffer))))
(defun slime-describe-presentation (presentation)
(slime-eval-describe
`(swank::describe-to-string
(swank:lookup-presented-object ',(slime-presentation-id presentation)))))
(defun slime-describe-presentation-at-mouse (event)
(interactive "@e")
(multiple-value-bind (presentation) (slime-presentation-around-click event)
(slime-describe-presentation presentation)))
(defun slime-describe-presentation-at-point (point)
(interactive "d")
(multiple-value-bind (presentation)
(slime-presentation-around-or-before-point-or-error point)
(slime-describe-presentation presentation)))
(defun slime-pretty-print-presentation (presentation)
(slime-eval-describe
`(swank::swank-pprint
(cl:list
(swank:lookup-presented-object ',(slime-presentation-id presentation))))))
(defun slime-pretty-print-presentation-at-mouse (event)
(interactive "@e")
(multiple-value-bind (presentation) (slime-presentation-around-click event)
(slime-pretty-print-presentation presentation)))
(defun slime-pretty-print-presentation-at-point (point)
(interactive "d")
(multiple-value-bind (presentation)
(slime-presentation-around-or-before-point-or-error point)
(slime-pretty-print-presentation presentation)))
(defun slime-mark-presentation (point)
(interactive "d")
(multiple-value-bind (presentation start end)
(slime-presentation-around-or-before-point-or-error point)
(goto-char start)
(push-mark end nil t)))
(defun slime-previous-presentation (&optional arg)
"Move point to the beginning of the first presentation before point.
With ARG, do this that many times.
A negative argument means move forward instead."
(interactive "p")
(unless arg (setq arg 1))
(slime-next-presentation (- arg)))
(defun slime-next-presentation (&optional arg)
"Move point to the beginning of the next presentation after point.
With ARG, do this that many times.
A negative argument means move backward instead."
(interactive "p")
(unless arg (setq arg 1))
(cond
((plusp arg)
(dotimes (i arg)
;; First skip outside the current surrounding presentation (if any)
(multiple-value-bind (presentation start end)
(slime-presentation-around-point (point))
(when presentation
(goto-char end)))
(let ((p (next-single-property-change (point) 'slime-repl-presentation)))
(unless p
(error "No next presentation"))
(multiple-value-bind (presentation start end)
(slime-presentation-around-or-before-point-or-error p)
(goto-char start)))))
((minusp arg)
(dotimes (i (- arg))
;; First skip outside the current surrounding presentation (if any)
(multiple-value-bind (presentation start end)
(slime-presentation-around-point (point))
(when presentation
(goto-char start)))
(let ((p (previous-single-property-change (point) 'slime-repl-presentation)))
(unless p
(error "No previous presentation"))
(multiple-value-bind (presentation start end)
(slime-presentation-around-or-before-point-or-error p)
(goto-char start)))))))
(define-key slime-presentation-map [mouse-2] 'slime-copy-or-inspect-presentation-at-mouse)
(define-key slime-presentation-map [mouse-3] 'slime-presentation-menu)
(when (featurep 'xemacs)
(define-key slime-presentation-map [button2] 'slime-copy-or-inspect-presentation-at-mouse)
(define-key slime-presentation-map [button3] 'slime-presentation-menu))
;; protocol for handling up a menu.
;; 1. Send lisp message asking for menu choices for this object.
;; Get back list of strings.
;; 2. Let used choose
;; 3. Call back to execute menu choice, passing nth and string of choice
(defun slime-menu-choices-for-presentation (presentation buffer from to choice-to-lambda)
"Return a menu for `presentation' at `from'--`to' in `buffer', suitable for `x-popup-menu'."
(let* ((what (slime-presentation-id presentation))
(choices (with-current-buffer buffer
(slime-eval
`(swank::menu-choices-for-presentation-id ',what)))))
(cl-labels ((savel (f) ;; IMPORTANT - xemacs can't handle lambdas in x-popup-menu. So give them a name
(let ((sym (cl-gensym)))
(setf (gethash sym choice-to-lambda) f)
sym)))
(etypecase choices
(list
`(,(format "Presentation %s" (truncate-string-to-width
(slime-presentation-text presentation)
30 nil nil t))
(""
("Find Definition" . ,(savel 'slime-M-.-presentation-at-mouse))
("Inspect" . ,(savel 'slime-inspect-presentation-at-mouse))
("Describe" . ,(savel 'slime-describe-presentation-at-mouse))
("Pretty-print" . ,(savel 'slime-pretty-print-presentation-at-mouse))
("Copy to REPL" . ,(savel 'slime-copy-presentation-at-mouse-to-repl))
("Copy to kill ring" . ,(savel 'slime-copy-presentation-at-mouse-to-kill-ring))
,@(unless buffer-read-only
`(("Copy to point" . ,(savel 'slime-copy-presentation-at-mouse-to-point))))
,@(let ((nchoice 0))
(mapcar
(lambda (choice)
(incf nchoice)
(cons choice
(savel `(lambda ()
(interactive)
(slime-eval
'(swank::execute-menu-choice-for-presentation-id
',what ,nchoice ,(nth (1- nchoice) choices)))))))
choices)))))
(symbol ; not-present
(with-current-buffer buffer
(slime-remove-presentation-properties from to presentation))
(sit-for 0) ; allow redisplay
`("Object no longer recorded"
("sorry" . ,(if (featurep 'xemacs) nil '(nil)))))))))
(defun slime-presentation-menu (event)
(interactive "e")
(let* ((point (if (featurep 'xemacs) (event-point event)
(posn-point (event-end event))))
(window (if (featurep 'xemacs) (event-window event) (caadr event)))
(buffer (window-buffer window))
(choice-to-lambda (make-hash-table)))
(multiple-value-bind (presentation from to)
(with-current-buffer buffer
(slime-presentation-around-point point))
(unless presentation
(error "No presentation at event position"))
(let ((menu (slime-menu-choices-for-presentation
presentation buffer from to choice-to-lambda)))
(let ((choice (x-popup-menu event menu)))
(when choice
(call-interactively (gethash choice choice-to-lambda))))))))
(defun slime-presentation-expression (presentation)
"Return a string that contains a CL s-expression accessing
the presented object."
(let ((id (slime-presentation-id presentation)))
(etypecase id
(number
;; Make sure it works even if *read-base* is not 10.
(format "(swank:lookup-presented-object-or-lose %d.)" id))
(list
;; for frame variables and inspector parts
(format "(swank:lookup-presented-object-or-lose '%s)" id)))))
(defun slime-buffer-substring-with-reified-output (start end)
(let ((str-props (buffer-substring start end))
(str-no-props (buffer-substring-no-properties start end)))
(slime-reify-old-output str-props str-no-props)))
(defun slime-reify-old-output (str-props str-no-props)
(let ((pos (slime-property-position 'slime-repl-presentation str-props)))
(if (null pos)
str-no-props
(multiple-value-bind (presentation start-pos end-pos whole-p)
(slime-presentation-around-point pos str-props)
(if (not presentation)
str-no-props
(concat (substring str-no-props 0 pos)
;; Eval in the reader so that we play nice with quote.
;; -luke (19/May/2005)
"#." (slime-presentation-expression presentation)
(slime-reify-old-output (substring str-props end-pos)
(substring str-no-props end-pos))))))))
(defun slime-repl-grab-old-output (replace)
"Resend the old REPL output at point.
If replace it non-nil the current input is replaced with the old
output; otherwise the new input is appended."
(multiple-value-bind (presentation beg end)
(slime-presentation-around-or-before-point (point))
(slime-check-presentation beg end (current-buffer) presentation)
(let ((old-output (buffer-substring beg end))) ;;keep properties
;; Append the old input or replace the current input
(cond (replace (goto-char slime-repl-input-start-mark))
(t (goto-char (point-max))
(unless (eq (char-before) ?\ )
(insert " "))))
(delete-region (point) (point-max))
(let ((inhibit-read-only t))
(insert old-output)))))
;;; Presentation-related key bindings, non-context menu
(defvar slime-presentation-command-map nil
"Keymap for presentation-related commands. Bound to a prefix key.")
(defvar slime-presentation-bindings
'((?i slime-inspect-presentation-at-point)
(?d slime-describe-presentation-at-point)
(?w slime-copy-presentation-at-point-to-kill-ring)
(?r slime-copy-presentation-at-point-to-repl)
(?p slime-previous-presentation)
(?n slime-next-presentation)
(?\ slime-mark-presentation)))
(defun slime-presentation-init-keymaps ()
(slime-init-keymap 'slime-presentation-command-map nil t
slime-presentation-bindings)
(define-key slime-presentation-command-map "\M-o" 'slime-clear-presentations)
;; C-c C-v is the prefix for the presentation-command map.
(define-key slime-prefix-map "\C-v" slime-presentation-command-map))
(defun slime-presentation-around-or-before-point-p ()
(multiple-value-bind (presentation beg end)
(slime-presentation-around-or-before-point (point))
presentation))
(defvar slime-presentation-easy-menu
(let ((P '(slime-presentation-around-or-before-point-p)))
`("Presentations"
[ "Find Definition" slime-M-.-presentation-at-point ,P ]
[ "Inspect" slime-inspect-presentation-at-point ,P ]
[ "Describe" slime-describe-presentation-at-point ,P ]
[ "Pretty-print" slime-pretty-print-presentation-at-point ,P ]
[ "Copy to REPL" slime-copy-presentation-at-point-to-repl ,P ]
[ "Copy to kill ring" slime-copy-presentation-at-point-to-kill-ring ,P ]
[ "Mark" slime-mark-presentation ,P ]
"--"
[ "Previous presentation" slime-previous-presentation ]
[ "Next presentation" slime-next-presentation ]
"--"
[ "Clear all presentations" slime-clear-presentations ])))
(defun slime-presentation-add-easy-menu ()
(easy-menu-define menubar-slime-presentation slime-mode-map "Presentations" slime-presentation-easy-menu)
(easy-menu-define menubar-slime-presentation slime-repl-mode-map "Presentations" slime-presentation-easy-menu)
(easy-menu-define menubar-slime-presentation sldb-mode-map "Presentations" slime-presentation-easy-menu)
(easy-menu-define menubar-slime-presentation slime-inspector-mode-map "Presentations" slime-presentation-easy-menu)
(easy-menu-add slime-presentation-easy-menu 'slime-mode-map)
(easy-menu-add slime-presentation-easy-menu 'slime-repl-mode-map)
(easy-menu-add slime-presentation-easy-menu 'sldb-mode-map)
(easy-menu-add slime-presentation-easy-menu 'slime-inspector-mode-map))
;;; hook functions (hard to isolate stuff)
(defun slime-dispatch-presentation-event (event)
(slime-dcase event
((:presentation-start id &optional target)
(slime-mark-presentation-start id target)
t)
((:presentation-end id &optional target)
(slime-mark-presentation-end id target)
t)
(t nil)))
(defun slime-presentation-write-result (string)
(with-current-buffer (slime-output-buffer)
(let ((marker (slime-output-target-marker :repl-result))
(saved-point (point-marker)))
(goto-char marker)
(slime-propertize-region `(face slime-repl-result-face
rear-nonsticky (face))
(insert string))
;; Move the input-start marker after the REPL result.
(set-marker marker (point))
(set-marker slime-output-end (point))
;; Restore point before insertion but only it if was farther
;; than `marker'. Omitting this breaks REPL test
;; `repl-type-ahead'.
(when (> saved-point (point))
(goto-char saved-point)))
(slime-repl-show-maximum-output)))
(defun slime-presentation-write (string &optional target)
(case target
((nil) ; Regular process output
(slime-repl-emit string))
(:repl-result
(slime-presentation-write-result string))
(t (slime-emit-to-target string target))))
(defun slime-presentation-current-input (&optional until-point-p)
"Return the current input as string.
The input is the region from after the last prompt to the end of
buffer. Presentations of old results are expanded into code."
(slime-buffer-substring-with-reified-output slime-repl-input-start-mark
(if until-point-p
(point)
(point-max))))
(defun slime-presentation-on-return-pressed (end-of-input)
(when (and (car (slime-presentation-around-or-before-point (point)))
(< (point) slime-repl-input-start-mark))
(slime-repl-grab-old-output end-of-input)
(slime-repl-recenter-if-needed)
t))
(defun slime-presentation-bridge-insert (process output)
(slime-output-filter process (or output "")))
(defun slime-presentation-on-stream-open (stream)
(install-bridge)
(setq bridge-insert-function #'slime-presentation-bridge-insert)
(setq bridge-destination-insert nil)
(setq bridge-source-insert nil)
(setq bridge-handlers
(list* '("<" . slime-mark-presentation-start-handler)
'(">" . slime-mark-presentation-end-handler)
bridge-handlers)))
(defun slime-clear-presentations ()
"Forget all objects associated to SLIME presentations.
This allows the garbage collector to remove these objects
even on Common Lisp implementations without weak hash tables."
(interactive)
(slime-eval-async `(swank:clear-repl-results))
(unless (eql major-mode 'slime-repl-mode)
(slime-switch-to-output-buffer))
(slime-for-each-presentation-in-region 1 (1+ (buffer-size))
(lambda (presentation from to whole-p)
(slime-remove-presentation-properties from to
presentation))))
(defun slime-presentation-inspector-insert-ispec (ispec)
(if (stringp ispec)
(insert ispec)
(slime-dcase ispec
((:value string id)
(slime-propertize-region
(list 'slime-part-number id
'mouse-face 'highlight
'face 'slime-inspector-value-face)
(slime-insert-presentation string `(:inspected-part ,id) t)))
((:label string)
(insert (slime-inspector-fontify label string)))
((:action string id)
(slime-insert-propertized (list 'slime-action-number id
'mouse-face 'highlight
'face 'slime-inspector-action-face)
string)))))
(defun slime-presentation-sldb-insert-frame-variable-value (value frame index)
(slime-insert-presentation
(sldb-in-face local-value value)
`(:frame-var ,slime-current-thread ,(car frame) ,index) t))
(defun slime-presentations-on-connected ()
(slime-eval-async `(swank:init-presentations)))
(provide 'slime-presentations)

BIN
elpa/slime-20180413.1720/contrib/slime-presentations.elc Normal file
View File

Binary file not shown.

51
elpa/slime-20180413.1720/contrib/slime-quicklisp.el Normal file
View File

@@ -0,0 +1,51 @@
(require 'slime)
(require 'cl-lib)
;;; bits of the following taken from slime-asdf.el
(define-slime-contrib slime-quicklisp
"Quicklisp support."
(:authors "Matthew Kennedy <burnsidemk@gmail.com>")
(:license "GPL")
(:slime-dependencies slime-repl)
(:swank-dependencies swank-quicklisp))
;;; Utilities
(defgroup slime-quicklisp nil
"Quicklisp support for Slime."
:prefix "slime-quicklisp-"
:group 'slime)
(defvar slime-quicklisp-system-history nil
"History list for Quicklisp system names.")
(defun slime-read-quicklisp-system-name (&optional prompt default-value)
"Read a Quick system name from the minibuffer, prompting with PROMPT."
(let* ((completion-ignore-case nil)
(prompt (or prompt "Quicklisp system"))
(quicklisp-system-names (slime-eval `(swank:list-quicklisp-systems)))
(prompt (concat prompt (if default-value
(format " (default `%s'): " default-value)
": "))))
(completing-read prompt (slime-bogus-completion-alist quicklisp-system-names)
nil nil nil
'slime-quicklisp-system-history default-value)))
(defun slime-quicklisp-quickload (system)
"Load a Quicklisp system."
(slime-save-some-lisp-buffers)
(slime-display-output-buffer)
(slime-repl-shortcut-eval-async `(ql:quickload ,system)))
;;; REPL shortcuts
(defslime-repl-shortcut slime-repl-quicklisp-quickload ("quicklisp-quickload" "ql")
(:handler (lambda ()
(interactive)
(slime-quicklisp-quickload (slime-read-quicklisp-system-name))))
(:one-liner "Load a system known to Quicklisp."))
(provide 'slime-quicklisp)

BIN
elpa/slime-20180413.1720/contrib/slime-quicklisp.elc Normal file
View File

Binary file not shown.

156
elpa/slime-20180413.1720/contrib/slime-references.el Normal file
View File

@@ -0,0 +1,156 @@
(require 'slime)
(require 'advice)
(require 'slime-compiler-notes-tree) ; FIXME: actually only uses the tree bits, so that should be a library.
(define-slime-contrib slime-references
"Clickable references to documentation (SBCL only)."
(:authors "Christophe Rhodes <csr21@cantab.net>"
"Luke Gorrie <luke@bluetail.com>"
"Tobias C. Rittweiler <tcr@freebits.de>")
(:license "GPL")
(:on-load
(ad-enable-advice 'slime-note.message 'after 'slime-note.message+references)
(ad-activate 'slime-note.message)
(setq slime-tree-printer 'slime-tree-print-with-references)
(add-hook 'sldb-extras-hooks 'sldb-maybe-insert-references))
(:on-unload
(ad-disable-advice 'slime-note.message 'after 'slime-note.message+references)
(ad-deactivate 'slime-note.message)
(setq slime-tree-printer 'slime-tree-default-printer)
(remove-hook 'sldb-extras-hooks 'sldb-maybe-insert-references)))
(defcustom slime-sbcl-manual-root "http://www.sbcl.org/manual/"
"*The base URL of the SBCL manual, for documentation lookup."
:type '(choice (string :tag "HTML Documentation")
(const :tag "Info Documentation" :info))
:group 'slime-mode)
(defface sldb-reference-face
(list (list t '(:underline t)))
"Face for references."
:group 'slime-debugger)
;;;;; SBCL-style references
(defvar slime-references-local-keymap
(let ((map (make-sparse-keymap "local keymap for slime references")))
(define-key map [mouse-2] 'slime-lookup-reference-at-mouse)
(define-key map [return] 'slime-lookup-reference-at-point)
map))
(defun slime-reference-properties (reference)
"Return the properties for a reference.
Only add clickability to properties we actually know how to lookup."
(cl-destructuring-bind (where type what) reference
(if (or (and (eq where :sbcl) (eq type :node))
(and (eq where :ansi-cl)
(memq type '(:function :special-operator :macro
:type :system-class
:section :glossary :issue))))
`(slime-reference ,reference
font-lock-face sldb-reference-face
follow-link t
mouse-face highlight
help-echo "mouse-2: visit documentation."
keymap ,slime-references-local-keymap))))
(defun slime-insert-reference (reference)
"Insert documentation reference from a condition.
See SWANK-BACKEND:CONDITION-REFERENCES for the datatype."
(cl-destructuring-bind (where type what) reference
(insert "\n" (slime-format-reference-source where) ", ")
(slime-insert-propertized (slime-reference-properties reference)
(slime-format-reference-node what))
(insert (format " [%s]" type))))
(defun slime-insert-references (references)
(when references
(insert "\nSee also:")
(slime-with-rigid-indentation 2
(mapc #'slime-insert-reference references))))
(defun slime-format-reference-source (where)
(cl-case where
(:amop "The Art of the Metaobject Protocol")
(:ansi-cl "Common Lisp Hyperspec")
(:sbcl "SBCL Manual")
(t (format "%S" where))))
(defun slime-format-reference-node (what)
(if (listp what)
(mapconcat #'prin1-to-string what ".")
what))
(defun slime-lookup-reference-at-point ()
"Browse the documentation reference at point."
(interactive)
(let ((refs (get-text-property (point) 'slime-reference)))
(if (null refs)
(error "No references at point")
(cl-destructuring-bind (where type what) refs
(cl-case where
(:ansi-cl
(cl-case type
(:section
(browse-url (funcall common-lisp-hyperspec-section-fun what)))
(:glossary
(browse-url (funcall common-lisp-hyperspec-glossary-function what)))
(:issue
(browse-url (common-lisp-issuex what)))
(:special-operator
(browse-url (common-lisp-special-operator (downcase name))))
(t
(hyperspec-lookup what))))
(t
(case slime-sbcl-manual-root
(:info
(info (format "(sbcl)%s" what)))
(t
(browse-url
(format "%s#%s" slime-sbcl-manual-root
(subst-char-in-string ?\ ?\- what)))))))))))
(defun slime-lookup-reference-at-mouse (event)
"Invoke the action pointed at by the mouse."
(interactive "e")
(cl-destructuring-bind (mouse-1 (w pos . _) . _) event
(save-excursion
(goto-char pos)
(slime-lookup-reference-at-point))))
;;;;; Hook into *SLIME COMPILATION*
(defun slime-note.references (note)
(plist-get note :references))
;;; FIXME: `compilation-mode' will swallow the `mouse-face'
;;; etc. properties.
(defadvice slime-note.message (after slime-note.message+references)
(setq ad-return-value
(concat ad-return-value
(with-temp-buffer
(slime-insert-references
(slime-note.references (ad-get-arg 0)))
(buffer-string)))))
;;;;; Hook into slime-compiler-notes-tree
(defun slime-tree-print-with-references (tree)
;; for SBCL-style references
(slime-tree-default-printer tree)
(let ((note (plist-get (slime-tree.plist tree) 'note)))
(when note
(let ((references (slime-note.references note)))
(when references
(terpri (current-buffer))
(slime-insert-references references))))))
;;;;; Hook into SLDB
(defun sldb-maybe-insert-references (extra)
(slime-dcase extra
((:references references) (slime-insert-references references) t)
(t nil)))
(provide 'slime-references)

BIN
elpa/slime-20180413.1720/contrib/slime-references.elc Normal file
View File

Binary file not shown.

1786
elpa/slime-20180413.1720/contrib/slime-repl.el Normal file
View File

File diff suppressed because it is too large Load Diff

BIN
elpa/slime-20180413.1720/contrib/slime-repl.elc Normal file
View File

Binary file not shown.

34
elpa/slime-20180413.1720/contrib/slime-sbcl-exts.el Normal file
View File

@@ -0,0 +1,34 @@
(require 'slime)
(require 'cl-lib)
(define-slime-contrib slime-sbcl-exts
"Misc extensions for SBCL"
(:authors "Tobias C. Rittweiler <tcr@freebits.de>")
(:license "GPL")
(:slime-dependencies slime-references)
(:swank-dependencies swank-sbcl-exts))
(defun slime-sbcl-bug-at-point ()
(save-excursion
(save-match-data
(unless (looking-at "#[0-9]\\{6\\}")
(search-backward-regexp "#\\<" (line-beginning-position) t))
(when (looking-at "#[0-9]\\{6\\}")
(buffer-substring-no-properties (match-beginning 0) (match-end 0))))))
(defun slime-read-sbcl-bug (prompt &optional query)
"Either read a sbcl bug or choose the one at point.
The user is prompted if a prefix argument is in effect, if there is no
symbol at point, or if QUERY is non-nil."
(let ((bug (slime-sbcl-bug-at-point)))
(cond ((or current-prefix-arg query (not bug))
(slime-read-from-minibuffer prompt bug))
(t bug))))
(defun slime-visit-sbcl-bug (bug)
"Visit the Launchpad site that describes `bug' (#nnnnnn)."
(interactive (list (slime-read-sbcl-bug "Bug number (#nnnnnn): ")))
(browse-url (format "http://bugs.launchpad.net/sbcl/+bug/%s"
(substring bug 1))))
(provide 'slime-sbcl-exts)

BIN
elpa/slime-20180413.1720/contrib/slime-sbcl-exts.elc Normal file
View File

Binary file not shown.

40
elpa/slime-20180413.1720/contrib/slime-scheme.el Normal file
View File

@@ -0,0 +1,40 @@
;;; slime-scheme.el --- Support Scheme programs running under Common Lisp
;;
;; Authors: Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de>
;;
;; License: GNU GPL (same license as Emacs)
;;
;;; Installation:
;;
;; Add this to your .emacs:
;;
;; (add-to-list 'load-path "<directory-of-this-file>")
;; (add-hook 'slime-load-hook (lambda () (require 'slime-scheme)))
;;
(eval-and-compile
(require 'slime))
(defun slime-scheme-mode-hook ()
(slime-mode 1))
(defun slime-scheme-indentation-update (symbol indent packages)
;; Does the symbol have an indentation value that we set?
(when (equal (get symbol 'scheme-indent-function)
(get symbol 'slime-scheme-indent))
(put symbol 'slime-scheme-indent indent)
(put symbol 'scheme-indent-function indent)))
;;; Initialization
(defun slime-scheme-init ()
(add-hook 'scheme-mode-hook 'slime-scheme-mode-hook)
(add-hook 'slime-indentation-update-hooks 'slime-scheme-indentation-update)
(add-to-list 'slime-lisp-modes 'scheme-mode))
(defun slime-scheme-unload ()
(remove-hook 'scheme-mode-hook 'slime-scheme-mode-hook)
(remove-hook 'slime-indentation-update-hooks 'slime-scheme-indentation-update)
(setq slime-lisp-modes (remove 'scheme-mode slime-lisp-modes)))
(provide 'slime-scheme)

BIN
elpa/slime-20180413.1720/contrib/slime-scheme.elc Normal file
View File

Binary file not shown.

48
elpa/slime-20180413.1720/contrib/slime-scratch.el Normal file
View File

@@ -0,0 +1,48 @@
;;; slime-scratch.el
(require 'slime)
(require 'cl-lib)
(define-slime-contrib slime-scratch
"Imitate Emacs' *scratch* buffer"
(:authors "Helmut Eller <heller@common-lisp.net>")
(:license "GPL")
(:on-load
(def-slime-selector-method ?s "*slime-scratch* buffer."
(slime-scratch-buffer))))
;;; Code
(defvar slime-scratch-mode-map
(let ((map (make-sparse-keymap)))
(set-keymap-parent map lisp-mode-map)
map))
(defun slime-scratch ()
(interactive)
(slime-switch-to-scratch-buffer))
(defun slime-switch-to-scratch-buffer ()
(set-buffer (slime-scratch-buffer))
(unless (eq (current-buffer) (window-buffer))
(pop-to-buffer (current-buffer) t)))
(defvar slime-scratch-file nil)
(defun slime-scratch-buffer ()
"Return the scratch buffer, create it if necessary."
(or (get-buffer (slime-buffer-name :scratch))
(with-current-buffer (if slime-scratch-file
(find-file slime-scratch-file)
(get-buffer-create (slime-buffer-name :scratch)))
(rename-buffer (slime-buffer-name :scratch))
(lisp-mode)
(use-local-map slime-scratch-mode-map)
(slime-mode t)
(current-buffer))))
(slime-define-keys slime-scratch-mode-map
("\C-j" 'slime-eval-print-last-expression))
(provide 'slime-scratch)

BIN
elpa/slime-20180413.1720/contrib/slime-scratch.elc Normal file
View File

Binary file not shown.

34
elpa/slime-20180413.1720/contrib/slime-snapshot.el Normal file
View File

@@ -0,0 +1,34 @@
(eval-and-compile
(require 'slime))
(define-slime-contrib slime-snapshot
"Save&restore memory images without disconnecting"
(:authors "Helmut Eller <heller@common-lisp.net>")
(:license "GPL v3")
(:swank-dependencies swank-snapshot))
(defun slime-snapshot (filename &optional background)
"Save a memory image to the file FILENAME."
(interactive (list (read-file-name "Image file: ")
current-prefix-arg))
(let ((file (expand-file-name filename)))
(when (and (file-exists-p file)
(not (yes-or-no-p (format "File exists %s. Overwrite it? "
filename))))
(signal 'quit nil))
(slime-eval-with-transcript
`(,(if background
'swank-snapshot:background-save-snapshot
'swank-snapshot:save-snapshot)
,file))))
(defun slime-restore (filename)
"Restore a memory image stored in file FILENAME."
(interactive (list (read-file-name "Image file: ")))
;; bypass event dispatcher because we don't expect a reply. FIXME.
(slime-net-send `(:emacs-rex (swank-snapshot:restore-snapshot
,(expand-file-name filename))
nil t nil)
(slime-connection)))
(provide 'slime-snapshot)

BIN
elpa/slime-20180413.1720/contrib/slime-snapshot.elc Normal file
View File

Binary file not shown.

224
elpa/slime-20180413.1720/contrib/slime-sprof.el Normal file
View File

@@ -0,0 +1,224 @@
(require 'slime)
(require 'cl-lib)
(eval-when-compile (require 'cl)) ; lexical-let*
(define-slime-contrib slime-sprof
"Integration with SBCL's sb-sprof."
(:authors "Juho Snellman"
"Stas Boukarev")
(:license "MIT")
(:swank-dependencies swank-sprof)
(:on-load
(let ((C '(and (slime-connected-p)
(equal (slime-lisp-implementation-type) "SBCL"))))
(setf (cdr (last (assoc "Profiling" slime-easy-menu)))
`("--"
[ "Start sb-sprof" slime-sprof-start ,C ]
[ "Stop sb-sprof" slime-sprof-stop ,C ]
[ "Report sb-sprof" slime-sprof-report ,C ])))))
(defvar slime-sprof-exclude-swank nil
"*Display swank functions in the report.")
(define-derived-mode slime-sprof-browser-mode fundamental-mode
"slprof"
"Mode for browsing profiler data\
\\<slime-sprof-browser-mode-map>\
\\{slime-sprof-browser-mode-map}"
:syntax-table lisp-mode-syntax-table
(setq buffer-read-only t))
(set-keymap-parent slime-sprof-browser-mode-map slime-parent-map)
(slime-define-keys slime-sprof-browser-mode-map
("h" 'describe-mode)
("d" 'slime-sprof-browser-disassemble-function)
("g" 'slime-sprof-browser-go-to)
("v" 'slime-sprof-browser-view-source)
("s" 'slime-sprof-toggle-swank-exclusion)
((kbd "RET") 'slime-sprof-browser-toggle))
;; Start / stop profiling
(cl-defun slime-sprof-start (&optional (mode :cpu))
(interactive)
(slime-eval `(swank:swank-sprof-start :mode ,mode)))
(defun slime-sprof-start-alloc ()
(interactive)
(slime-sprof-start :alloc))
(defun slime-sprof-start-time ()
(interactive)
(slime-sprof-start :time))
(defun slime-sprof-stop ()
(interactive)
(slime-eval `(swank:swank-sprof-stop)))
;; Reporting
(defun slime-sprof-format (graph)
(with-current-buffer (slime-buffer-name :sprof)
(let ((inhibit-read-only t))
(erase-buffer)
(insert (format "%4s %-54s %6s %6s %6s\n"
"Rank"
"Name"
"Self%"
"Cumul%"
"Total%"))
(dolist (data graph)
(slime-sprof-browser-insert-line data 54))))
(forward-line 2))
(cl-defun slime-sprof-update (&optional (exclude-swank slime-sprof-exclude-swank))
(slime-eval-async `(swank:swank-sprof-get-call-graph
:exclude-swank ,exclude-swank)
'slime-sprof-format))
(defalias 'slime-sprof-browser 'slime-sprof-report)
(defun slime-sprof-report ()
(interactive)
(slime-with-popup-buffer ((slime-buffer-name :sprof)
:connection t
:select t
:mode 'slime-sprof-browser-mode)
(slime-sprof-update)))
(defun slime-sprof-toggle-swank-exclusion ()
(interactive)
(setq slime-sprof-exclude-swank
(not slime-sprof-exclude-swank))
(slime-sprof-update))
(defun slime-sprof-browser-insert-line (data name-length)
(cl-destructuring-bind (index name self cumul total)
data
(if index
(insert (format "%-4d " index))
(insert " "))
(slime-insert-propertized
(slime-sprof-browser-name-properties)
(format (format "%%-%ds " name-length)
(slime-sprof-abbreviate-name name name-length)))
(insert (format "%6.2f " self))
(when cumul
(insert (format "%6.2f " cumul))
(when total
(insert (format "%6.2f" total))))
(when index
(slime-sprof-browser-add-line-text-properties
`(profile-index ,index expanded nil)))
(insert "\n")))
(defun slime-sprof-abbreviate-name (name max-length)
(cl-subseq name 0 (min (length name) max-length)))
;; Expanding / collapsing
(defun slime-sprof-browser-toggle ()
(interactive)
(let ((index (get-text-property (point) 'profile-index)))
(when index
(save-excursion
(if (slime-sprof-browser-line-expanded-p)
(slime-sprof-browser-collapse)
(slime-sprof-browser-expand))))))
(defun slime-sprof-browser-collapse ()
(let ((inhibit-read-only t))
(slime-sprof-browser-add-line-text-properties '(expanded nil))
(forward-line)
(cl-loop until (or (eobp)
(get-text-property (point) 'profile-index))
do
(delete-region (point-at-bol) (point-at-eol))
(unless (eobp)
(delete-char 1)))))
(defun slime-sprof-browser-expand ()
(lexical-let* ((buffer (current-buffer))
(point (point))
(index (get-text-property point 'profile-index)))
(slime-eval-async `(swank:swank-sprof-expand-node ,index)
(lambda (data)
(with-current-buffer buffer
(save-excursion
(destructuring-bind (&key callers calls)
data
(slime-sprof-browser-add-expansion callers
"Callers"
0)
(slime-sprof-browser-add-expansion calls
"Calls"
0))))))))
(defun slime-sprof-browser-add-expansion (data type nesting)
(when data
(let ((inhibit-read-only t))
(slime-sprof-browser-add-line-text-properties '(expanded t))
(end-of-line)
(insert (format "\n %s" type))
(dolist (node data)
(cl-destructuring-bind (index name cumul) node
(insert (format (format "\n%%%ds" (+ 7 (* 2 nesting))) ""))
(slime-insert-propertized
(slime-sprof-browser-name-properties)
(let ((len (- 59 (* 2 nesting))))
(format (format "%%-%ds " len)
(slime-sprof-abbreviate-name name len))))
(slime-sprof-browser-add-line-text-properties
`(profile-sub-index ,index))
(insert (format "%6.2f" cumul)))))))
(defun slime-sprof-browser-line-expanded-p ()
(get-text-property (point) 'expanded))
(defun slime-sprof-browser-add-line-text-properties (properties)
(add-text-properties (point-at-bol)
(point-at-eol)
properties))
(defun slime-sprof-browser-name-properties ()
'(face sldb-restart-number-face))
;; "Go to function"
(defun slime-sprof-browser-go-to ()
(interactive)
(let ((sub-index (get-text-property (point) 'profile-sub-index)))
(when sub-index
(let ((pos (text-property-any
(point-min) (point-max) 'profile-index sub-index)))
(when pos (goto-char pos))))))
;; Disassembly
(defun slime-sprof-browser-disassemble-function ()
(interactive)
(let ((index (or (get-text-property (point) 'profile-index)
(get-text-property (point) 'profile-sub-index))))
(when index
(slime-eval-describe `(swank:swank-sprof-disassemble
,index)))))
;; View source
(defun slime-sprof-browser-view-source ()
(interactive)
(let ((index (or (get-text-property (point) 'profile-index)
(get-text-property (point) 'profile-sub-index))))
(when index
(slime-eval-async
`(swank:swank-sprof-source-location ,index)
(lambda (source-location)
(slime-dcase source-location
((:error message)
(message "%s" message)
(ding))
(t
(slime-show-source-location source-location))))))))
(provide 'slime-sprof)

BIN
elpa/slime-20180413.1720/contrib/slime-sprof.elc Normal file
View File

Binary file not shown.

837
elpa/slime-20180413.1720/contrib/slime-trace-dialog.el Normal file
View File

@@ -0,0 +1,837 @@
;;; -*- coding: utf-8; lexical-binding: t -*-
;;;
;;; slime-trace-dialog.el -- a navigable dialog of inspectable trace entries
;;;
;;; TODO: implement better wrap interface for sbcl method, labels and such
;;; TODO: backtrace printing is very slow
;;;
(require 'slime)
(require 'slime-parse)
(require 'slime-repl)
(require 'cl-lib)
(define-slime-contrib slime-trace-dialog
"Provide an interfactive trace dialog buffer for managing and
inspecting details of traced functions. Invoke this dialog with C-c T."
(:authors "João Távora <joaotavora@gmail.com>")
(:license "GPL")
(:swank-dependencies swank-trace-dialog)
(:on-load (add-hook 'slime-mode-hook 'slime-trace-dialog-enable)
(add-hook 'slime-repl-mode-hook 'slime-trace-dialog-enable))
(:on-unload (remove-hook 'slime-mode-hook 'slime-trace-dialog-enable)
(remove-hook 'slime-repl-mode-hook 'slime-trace-dialog-enable)))
;;;; Variables
;;;
(defvar slime-trace-dialog-flash t
"Non-nil means flash the updated region of the SLIME Trace Dialog. ")
(defvar slime-trace-dialog--specs-overlay nil)
(defvar slime-trace-dialog--progress-overlay nil)
(defvar slime-trace-dialog--tree-overlay nil)
(defvar slime-trace-dialog--collapse-chars (cons "-" "+"))
;;;; Local trace entry model
(defvar slime-trace-dialog--traces nil)
(cl-defstruct (slime-trace-dialog--trace
(:constructor slime-trace-dialog--make-trace))
id
parent
spec
args
retlist
depth
beg
end
collapse-button-marker
summary-beg
children-end
collapsed-p)
(defun slime-trace-dialog--find-trace (id)
(gethash id slime-trace-dialog--traces))
;;;; Modes and mode maps
;;;
(defvar slime-trace-dialog-mode-map
(let ((map (make-sparse-keymap))
(remaps '((slime-inspector-operate-on-point . nil)
(slime-inspector-operate-on-click . nil)
(slime-inspector-reinspect
. slime-trace-dialog-fetch-status)
(slime-inspector-next-inspectable-object
. slime-trace-dialog-next-button)
(slime-inspector-previous-inspectable-object
. slime-trace-dialog-prev-button))))
(set-keymap-parent map slime-inspector-mode-map)
(cl-loop for (old . new) in remaps
do (substitute-key-definition old new map))
(set-keymap-parent map slime-parent-map)
(define-key map (kbd "G") 'slime-trace-dialog-fetch-traces)
(define-key map (kbd "C-k") 'slime-trace-dialog-clear-fetched-traces)
(define-key map (kbd "g") 'slime-trace-dialog-fetch-status)
(define-key map (kbd "M-RET") 'slime-trace-dialog-copy-down-to-repl)
(define-key map (kbd "q") 'quit-window)
map))
(define-derived-mode slime-trace-dialog-mode fundamental-mode
"SLIME Trace Dialog" "Mode for controlling SLIME's Trace Dialog"
(set-syntax-table lisp-mode-syntax-table)
(read-only-mode 1)
(add-to-list (make-local-variable 'slime-trace-dialog-after-toggle-hook)
'slime-trace-dialog-fetch-status))
(define-derived-mode slime-trace-dialog--detail-mode slime-inspector-mode
"SLIME Trace Detail"
"Mode for viewing a particular trace from SLIME's Trace Dialog")
(setq slime-trace-dialog--detail-mode-map
(let ((map (make-sparse-keymap))
(remaps '((slime-inspector-next-inspectable-object
. slime-trace-dialog-next-button)
(slime-inspector-previous-inspectable-object
. slime-trace-dialog-prev-button))))
(set-keymap-parent map slime-trace-dialog-mode-map)
(cl-loop for (old . new) in remaps
do (substitute-key-definition old new map))
map))
(defvar slime-trace-dialog-minor-mode-map
(let ((map (make-sparse-keymap)))
(define-key map (kbd "C-c T") 'slime-trace-dialog)
(define-key map (kbd "C-c M-t") 'slime-trace-dialog-toggle-trace)
map))
(define-minor-mode slime-trace-dialog-minor-mode
"Add keybindings for accessing SLIME's Trace Dialog.")
(defun slime-trace-dialog-enable ()
(slime-trace-dialog-minor-mode 1))
(easy-menu-define slime-trace-dialog--menubar (list slime-trace-dialog-minor-mode-map
slime-trace-dialog-mode-map)
"A menu for accessing some features of SLIME's Trace Dialog"
(let* ((in-dialog '(eq major-mode 'slime-trace-dialog-mode))
(dialog-live `(and ,in-dialog
(memq slime-buffer-connection slime-net-processes)))
(connected '(slime-connected-p)))
`("Trace"
["Toggle trace" slime-trace-dialog-toggle-trace ,connected]
["Trace complex spec" slime-trace-dialog-toggle-complex-trace ,connected]
["Open Trace dialog" slime-trace-dialog (and ,connected (not ,in-dialog))]
"--"
[ "Refresh traces and progress" slime-trace-dialog-fetch-status ,dialog-live]
[ "Fetch next batch" slime-trace-dialog-fetch-traces ,dialog-live]
[ "Clear all fetched traces" slime-trace-dialog-clear-fetched-traces ,dialog-live]
[ "Toggle details" slime-trace-dialog-hide-details-mode ,in-dialog]
[ "Toggle autofollow" slime-trace-dialog-autofollow-mode ,in-dialog])))
(define-minor-mode slime-trace-dialog-hide-details-mode
"Hide details in `slime-trace-dialog-mode'"
nil " Brief"
:group 'slime-trace-dialog
(unless (derived-mode-p 'slime-trace-dialog-mode)
(error "Not a SLIME Trace Dialog buffer"))
(slime-trace-dialog--set-hide-details-mode))
(define-minor-mode slime-trace-dialog-autofollow-mode
"Automatically open buffers with trace details from `slime-trace-dialog-mode'"
nil " Autofollow"
:group 'slime-trace-dialog
(unless (derived-mode-p 'slime-trace-dialog-mode)
(error "Not a SLIME Trace Dialog buffer")))
;;;; Helper functions
;;;
(defun slime-trace-dialog--call-refreshing (buffer
overlay
dont-erase
recover-point-p
fn)
(with-current-buffer buffer
(let ((inhibit-point-motion-hooks t)
(inhibit-read-only t)
(saved (point)))
(save-restriction
(when overlay
(narrow-to-region (overlay-start overlay)
(overlay-end overlay)))
(unwind-protect
(if dont-erase
(goto-char (point-max))
(delete-region (point-min) (point-max)))
(funcall fn)
(when recover-point-p
(goto-char saved)))
(when slime-trace-dialog-flash
(slime-flash-region (point-min) (point-max)))))
buffer))
(cl-defmacro slime-trace-dialog--refresh ((&key
overlay
dont-erase
recover-point-p
buffer)
&rest body)
(declare (indent 1)
(debug (sexp &rest form)))
`(slime-trace-dialog--call-refreshing ,(or buffer
`(current-buffer))
,overlay
,dont-erase
,recover-point-p
#'(lambda () ,@body)))
(defmacro slime-trace-dialog--insert-and-overlay (string overlay)
`(save-restriction
(let ((inhibit-read-only t))
(narrow-to-region (point) (point))
(insert ,string "\n")
(set (make-local-variable ',overlay)
(let ((overlay (make-overlay (point-min)
(point-max)
(current-buffer)
nil
t)))
(move-overlay overlay (overlay-start overlay)
(1- (overlay-end overlay)))
;; (overlay-put overlay 'face '(:background "darkslategrey"))
overlay)))))
(defun slime-trace-dialog--buffer-name ()
(format "*traces for %s*"
(slime-connection-name slime-default-connection)))
(defun slime-trace-dialog--live-dialog (&optional buffer-or-name)
(let ((buffer-or-name (or buffer-or-name
(slime-trace-dialog--buffer-name))))
(and (buffer-live-p (get-buffer buffer-or-name))
(with-current-buffer buffer-or-name
(memq slime-buffer-connection slime-net-processes))
buffer-or-name)))
(defun slime-trace-dialog--ensure-buffer ()
(let ((name (slime-trace-dialog--buffer-name)))
(or (slime-trace-dialog--live-dialog name)
(with-current-buffer (get-buffer-create name)
(let ((inhibit-read-only t))
(erase-buffer))
(slime-trace-dialog-mode)
(save-excursion
(buffer-disable-undo)
(slime-trace-dialog--insert-and-overlay
"[waiting for the traced specs to be available]"
slime-trace-dialog--specs-overlay)
(slime-trace-dialog--insert-and-overlay
"[waiting for some info on trace download progress ]"
slime-trace-dialog--progress-overlay)
(slime-trace-dialog--insert-and-overlay
"[waiting for the actual traces to be available]"
slime-trace-dialog--tree-overlay)
(current-buffer))
(setq slime-buffer-connection slime-default-connection)
(current-buffer)))))
(defun slime-trace-dialog--make-autofollow-fn (id)
(let ((requested nil))
#'(lambda (_before after)
(let ((inhibit-point-motion-hooks t)
(id-after (get-text-property after 'slime-trace-dialog--id)))
(when (and (= after (point))
slime-trace-dialog-autofollow-mode
id-after
(= id-after id)
(not requested))
(setq requested t)
(slime-eval-async `(swank-trace-dialog:report-trace-detail
,id-after)
#'(lambda (detail)
(setq requested nil)
(when detail
(let ((inhibit-point-motion-hooks t))
(slime-trace-dialog--open-detail detail
'no-pop))))))))))
(defun slime-trace-dialog--set-collapsed (collapsed-p trace button)
(save-excursion
(setf (slime-trace-dialog--trace-collapsed-p trace) collapsed-p)
(slime-trace-dialog--go-replace-char-at
button
(if collapsed-p
(cdr slime-trace-dialog--collapse-chars)
(car slime-trace-dialog--collapse-chars)))
(slime-trace-dialog--hide-unhide
(slime-trace-dialog--trace-summary-beg trace)
(slime-trace-dialog--trace-end trace)
(if collapsed-p 1 -1))
(slime-trace-dialog--hide-unhide
(slime-trace-dialog--trace-end trace)
(slime-trace-dialog--trace-children-end trace)
(if collapsed-p 1 -1))))
(defun slime-trace-dialog--hide-unhide (start-pos end-pos delta)
(cl-loop with inhibit-read-only = t
for pos = start-pos then next
for next = (next-single-property-change
pos
'slime-trace-dialog--hidden-level
nil
end-pos)
for hidden-level = (+ (or (get-text-property
pos
'slime-trace-dialog--hidden-level)
0)
delta)
do (add-text-properties pos next
(list 'slime-trace-dialog--hidden-level
hidden-level
'invisible
(cl-plusp hidden-level)))
while (< next end-pos)))
(defun slime-trace-dialog--set-hide-details-mode ()
(cl-loop for trace being the hash-values of slime-trace-dialog--traces
do (slime-trace-dialog--hide-unhide
(slime-trace-dialog--trace-summary-beg trace)
(slime-trace-dialog--trace-end trace)
(if slime-trace-dialog-hide-details-mode 1 -1))))
(defun slime-trace-dialog--format-part (part-id part-text trace-id type)
(slime-trace-dialog--button
(format "%s" part-text)
#'(lambda (_button)
(slime-eval-async
`(swank-trace-dialog:inspect-trace-part ,trace-id ,part-id ,type)
#'slime-open-inspector))
'mouse-face 'highlight
'slime-trace-dialog--part-id part-id
'slime-trace-dialog--type type
'face 'slime-inspector-value-face))
(defun slime-trace-dialog--format-trace-entry (id external)
(slime-trace-dialog--button
(format "%s" external)
#'(lambda (_button)
(slime-eval-async
`(swank::inspect-object (swank-trace-dialog::find-trace ,id))
#'slime-open-inspector))
'face 'slime-inspector-value-face))
(defun slime-trace-dialog--format (fmt-string &rest args)
(let* ((string (apply #'format fmt-string args))
(indent (make-string (max 2
(- 50 (length string))) ? )))
(format "%s%s" string indent)))
(defun slime-trace-dialog--button (title lambda &rest props)
(let ((string (format "%s" title)))
(apply #'make-text-button string nil
'action #'(lambda (button)
(funcall lambda button))
'mouse-face 'highlight
'face 'slime-inspector-action-face
props)
string))
(defun slime-trace-dialog--call-maintaining-properties (pos fn)
(save-excursion
(goto-char pos)
(let* ((saved-props (text-properties-at pos))
(saved-point (point))
(inhibit-read-only t)
(inhibit-point-motion-hooks t))
(funcall fn)
(add-text-properties saved-point (point) saved-props)
(if (markerp pos) (set-marker pos saved-point)))))
(cl-defmacro slime-trace-dialog--maintaining-properties (pos
&body body)
(declare (indent 1))
`(slime-trace-dialog--call-maintaining-properties ,pos #'(lambda () ,@body)))
(defun slime-trace-dialog--go-replace-char-at (pos char)
(slime-trace-dialog--maintaining-properties pos
(delete-char 1)
(insert char)))
;;;; Handlers for the *trace-dialog* and *trace-detail* buffers
;;;
(defun slime-trace-dialog--open-specs (traced-specs)
(cl-labels ((make-report-spec-fn
(&optional form)
#'(lambda (_button)
(slime-eval-async
`(cl:progn
,form
(swank-trace-dialog:report-specs))
#'(lambda (results)
(slime-trace-dialog--open-specs results))))))
(slime-trace-dialog--refresh
(:overlay slime-trace-dialog--specs-overlay
:recover-point-p t)
(insert
(slime-trace-dialog--format "Traced specs (%s)" (length traced-specs))
(slime-trace-dialog--button "[refresh]"
(make-report-spec-fn))
"\n" (make-string 50 ? )
(slime-trace-dialog--button
"[untrace all]"
(make-report-spec-fn `(swank-trace-dialog:dialog-untrace-all)))
"\n\n")
(cl-loop for spec in traced-specs
do (insert
" "
(slime-trace-dialog--button
"[untrace]"
(make-report-spec-fn
`(swank-trace-dialog:dialog-untrace ',spec)))
(format " %s" spec)
"\n")))))
(defvar slime-trace-dialog--fetch-key nil)
(defvar slime-trace-dialog--stop-fetching nil)
(defun slime-trace-dialog--update-progress (total &optional show-stop-p remaining-p)
;; `remaining-p' indicates `total' is the number of remaining traces.
(slime-trace-dialog--refresh
(:overlay slime-trace-dialog--progress-overlay
:recover-point-p t)
(let* ((done (hash-table-count slime-trace-dialog--traces))
(total (if remaining-p (+ done total) total)))
(insert
(slime-trace-dialog--format "Trace collection status (%d/%s)"
done
(or total "0"))
(slime-trace-dialog--button "[refresh]"
#'(lambda (_button)
(slime-trace-dialog-fetch-progress))))
(when (and total (cl-plusp (- total done)))
(insert "\n" (make-string 50 ? )
(slime-trace-dialog--button
"[fetch next batch]"
#'(lambda (_button)
(slime-trace-dialog-fetch-traces nil)))
"\n" (make-string 50 ? )
(slime-trace-dialog--button
"[fetch all]"
#'(lambda (_button)
(slime-trace-dialog-fetch-traces t)))))
(when total
(insert "\n" (make-string 50 ? )
(slime-trace-dialog--button
"[clear]"
#'(lambda (_button)
(slime-trace-dialog-clear-fetched-traces)))))
(when show-stop-p
(insert "\n" (make-string 50 ? )
(slime-trace-dialog--button
"[stop]"
#'(lambda (_button)
(setq slime-trace-dialog--stop-fetching t)))))
(insert "\n\n"))))
(defun slime-trace-dialog--open-detail (trace-tuple &optional no-pop)
(slime-with-popup-buffer ("*trace-detail*" :select (not no-pop)
:mode 'slime-trace-dialog--detail-mode)
(cl-destructuring-bind (id _parent-id _spec args retlist backtrace external)
trace-tuple
(let ((headline (slime-trace-dialog--format-trace-entry id external)))
(setq headline (format "%s\n%s\n"
headline
(make-string (length headline) ?-)))
(insert headline))
(cl-loop for (type objects label)
in `((:arg ,args "Called with args:")
(:retval ,retlist "Returned values:"))
do (insert (format "\n%s\n" label))
(insert (cl-loop for object in objects
for i from 0
concat (format " %s: %s\n" i
(slime-trace-dialog--format-part
(cl-first object)
(cl-second object)
id
type)))))
(when backtrace
(insert "\nBacktrace:\n"
(cl-loop for (i spec) in backtrace
concat (format " %s: %s\n" i spec)))))))
;;;; Rendering traces
;;;
(defun slime-trace-dialog--draw-tree-lines (start offset direction)
(save-excursion
(let ((inhibit-point-motion-hooks t))
(goto-char start)
(cl-loop with replace-set = (if (eq direction 'down)
'(? )
'(? ?`))
for line-beginning = (line-beginning-position
(if (eq direction 'down)
2 0))
for pos = (+ line-beginning offset)
while (and (< (point-min) line-beginning)
(< line-beginning (point-max))
(memq (char-after pos) replace-set))
do
(slime-trace-dialog--go-replace-char-at pos "|")
(goto-char pos)))))
(defun slime-trace-dialog--make-indent (depth suffix)
(concat (make-string (* 3 (max 0 (1- depth))) ? )
(if (cl-plusp depth) suffix)))
(defun slime-trace-dialog--make-collapse-button (trace)
(slime-trace-dialog--button (if (slime-trace-dialog--trace-collapsed-p trace)
(cdr slime-trace-dialog--collapse-chars)
(car slime-trace-dialog--collapse-chars))
#'(lambda (button)
(slime-trace-dialog--set-collapsed
(not (slime-trace-dialog--trace-collapsed-p
trace))
trace
button))))
(defun slime-trace-dialog--insert-trace (trace)
(let* ((id (slime-trace-dialog--trace-id trace))
(parent (slime-trace-dialog--trace-parent trace))
(has-children-p (slime-trace-dialog--trace-children-end trace))
(indent-spec (slime-trace-dialog--make-indent
(slime-trace-dialog--trace-depth trace)
"`--"))
(indent-summary (slime-trace-dialog--make-indent
(slime-trace-dialog--trace-depth trace)
" "))
(autofollow-fn (slime-trace-dialog--make-autofollow-fn id))
(id-string (slime-trace-dialog--button
(format "%4s" id)
#'(lambda (_button)
(slime-eval-async
`(swank-trace-dialog:report-trace-detail
,id)
#'slime-trace-dialog--open-detail))))
(spec (slime-trace-dialog--trace-spec trace))
(summary (cl-loop for (type objects marker) in
`((:arg ,(slime-trace-dialog--trace-args trace)
" > ")
(:retval ,(slime-trace-dialog--trace-retlist trace)
" < "))
concat (cl-loop for object in objects
concat " "
concat indent-summary
concat marker
concat (slime-trace-dialog--format-part
(cl-first object)
(cl-second object)
id
type)
concat "\n"))))
(puthash id trace slime-trace-dialog--traces)
;; insert and propertize the text
;;
(setf (slime-trace-dialog--trace-beg trace) (point-marker))
(insert id-string " ")
(insert indent-spec)
(if has-children-p
(insert (slime-trace-dialog--make-collapse-button trace))
(setf (slime-trace-dialog--trace-collapse-button-marker trace)
(point-marker))
(insert "-"))
(insert (format " %s\n" spec))
(setf (slime-trace-dialog--trace-summary-beg trace) (point-marker))
(insert summary)
(setf (slime-trace-dialog--trace-end trace) (point-marker))
(set-marker-insertion-type (slime-trace-dialog--trace-beg trace) t)
(add-text-properties (slime-trace-dialog--trace-beg trace)
(slime-trace-dialog--trace-end trace)
(list 'slime-trace-dialog--id id
'point-entered autofollow-fn
'point-left autofollow-fn))
;; respect brief mode and collapsed state
;;
(cl-loop for condition in (list slime-trace-dialog-hide-details-mode
(slime-trace-dialog--trace-collapsed-p trace))
when condition
do (slime-trace-dialog--hide-unhide
(slime-trace-dialog--trace-summary-beg
trace)
(slime-trace-dialog--trace-end trace)
1))
(cl-loop for tr = trace then parent
for parent = (slime-trace-dialog--trace-parent tr)
while parent
when (slime-trace-dialog--trace-collapsed-p parent)
do (slime-trace-dialog--hide-unhide
(slime-trace-dialog--trace-beg trace)
(slime-trace-dialog--trace-end trace)
(+ 1
(or (get-text-property (slime-trace-dialog--trace-beg parent)
'slime-trace-dialog--hidden-level)
0)))
(cl-return))
;; maybe add the collapse-button to the parent in case it didn't
;; have one already
;;
(when (and parent
(slime-trace-dialog--trace-collapse-button-marker parent))
(slime-trace-dialog--maintaining-properties
(slime-trace-dialog--trace-collapse-button-marker parent)
(delete-char 1)
(insert (slime-trace-dialog--make-collapse-button parent))
(setf (slime-trace-dialog--trace-collapse-button-marker parent)
nil)))
;; draw the tree lines
;;
(when parent
(slime-trace-dialog--draw-tree-lines (slime-trace-dialog--trace-beg trace)
(+ 2 (length indent-spec))
'up))
(when has-children-p
(slime-trace-dialog--draw-tree-lines (slime-trace-dialog--trace-beg trace)
(+ 5 (length indent-spec))
'down))
;; set the "children-end" slot
;;
(unless (slime-trace-dialog--trace-children-end trace)
(cl-loop for parent = trace
then (slime-trace-dialog--trace-parent parent)
while parent
do
(setf (slime-trace-dialog--trace-children-end parent)
(slime-trace-dialog--trace-end trace))))))
(defun slime-trace-dialog--render-trace (trace)
;; Render the trace entry in the appropriate place.
;;
;; A trace becomes a few lines of slightly propertized text in the
;; buffer, inserted by `slime-trace-dialog--insert-trace', bound by
;; point markers that we use here.
;;
;; The new trace might be replacing an existing one, or otherwise
;; must be placed under its existing parent which might or might not
;; be the last entry inserted.
;;
(let ((existing (slime-trace-dialog--find-trace
(slime-trace-dialog--trace-id trace)))
(parent (slime-trace-dialog--trace-parent trace)))
(cond (existing
;; Other traces might already reference `existing' and with
;; need to maintain that eqness. Best way to do that is
;; destructively modify `existing' with the new retlist...
;;
(setf (slime-trace-dialog--trace-retlist existing)
(slime-trace-dialog--trace-retlist trace))
;; Now, before deleting and re-inserting `existing' at an
;; arbitrary point in the tree, note that it's
;; "children-end" marker is already non-nil, and informs us
;; about its parenthood status. We want to 1. leave it
;; alone if it's already a parent, or 2. set it to nil if
;; it's a leaf, thus forcing the needed update of the
;; parents' "children-end" marker.
;;
(when (= (slime-trace-dialog--trace-children-end existing)
(slime-trace-dialog--trace-end existing))
(setf (slime-trace-dialog--trace-children-end existing) nil))
(delete-region (slime-trace-dialog--trace-beg existing)
(slime-trace-dialog--trace-end existing))
(goto-char (slime-trace-dialog--trace-end existing))
;; Remember to set `trace' to be `existing'
;;
(setq trace existing))
(parent
(goto-char (1+ (slime-trace-dialog--trace-children-end parent))))
(;; top level trace
t
(goto-char (point-max))))
(goto-char (line-beginning-position))
(slime-trace-dialog--insert-trace trace)))
(defun slime-trace-dialog--update-tree (tuples)
(save-excursion
(slime-trace-dialog--refresh
(:overlay slime-trace-dialog--tree-overlay
:dont-erase t)
(cl-loop for tuple in tuples
for parent = (slime-trace-dialog--find-trace (cl-second tuple))
for trace = (slime-trace-dialog--make-trace
:id (cl-first tuple)
:parent parent
:spec (cl-third tuple)
:args (cl-fourth tuple)
:retlist (cl-fifth tuple)
:depth (if parent
(1+ (slime-trace-dialog--trace-depth
parent))
0))
do (slime-trace-dialog--render-trace trace)))))
(defun slime-trace-dialog--clear-local-tree ()
(set (make-local-variable 'slime-trace-dialog--fetch-key)
(cl-gensym "slime-trace-dialog-fetch-key-"))
(set (make-local-variable 'slime-trace-dialog--traces)
(make-hash-table))
(slime-trace-dialog--refresh
(:overlay slime-trace-dialog--tree-overlay))
(slime-trace-dialog--update-progress nil))
(defun slime-trace-dialog--on-new-results (results &optional recurse)
(cl-destructuring-bind (tuples remaining reply-key)
results
(cond ((and slime-trace-dialog--fetch-key
(string= (symbol-name slime-trace-dialog--fetch-key)
(symbol-name reply-key)))
(slime-trace-dialog--update-tree tuples)
(slime-trace-dialog--update-progress
remaining
(and recurse
(cl-plusp remaining))
t)
(when (and recurse
(not (prog1 slime-trace-dialog--stop-fetching
(setq slime-trace-dialog--stop-fetching nil)))
(cl-plusp remaining))
(slime-eval-async `(swank-trace-dialog:report-partial-tree
',reply-key)
#'(lambda (results) (slime-trace-dialog--on-new-results
results
recurse))))))))
;;;; Interactive functions
;;;
(defun slime-trace-dialog-fetch-specs ()
"Refresh just list of traced specs."
(interactive)
(slime-eval-async `(swank-trace-dialog:report-specs)
#'slime-trace-dialog--open-specs))
(defun slime-trace-dialog-fetch-progress ()
(interactive)
(slime-eval-async
'(swank-trace-dialog:report-total)
#'(lambda (total)
(slime-trace-dialog--update-progress
total))))
(defun slime-trace-dialog-fetch-status ()
"Refresh just the status part of the SLIME Trace Dialog"
(interactive)
(slime-trace-dialog-fetch-specs)
(slime-trace-dialog-fetch-progress))
(defun slime-trace-dialog-clear-fetched-traces (&optional interactive)
"Clear local and remote traces collected so far"
(interactive "p")
(when (or (not interactive)
(y-or-n-p "Clear all collected and fetched traces?"))
(slime-eval-async
'(swank-trace-dialog:clear-trace-tree)
#'(lambda (_ignored)
(slime-trace-dialog--clear-local-tree)))))
(defun slime-trace-dialog-fetch-traces (&optional recurse)
(interactive "P")
(setq slime-trace-dialog--stop-fetching nil)
(slime-eval-async `(swank-trace-dialog:report-partial-tree
',slime-trace-dialog--fetch-key)
#'(lambda (results) (slime-trace-dialog--on-new-results results
recurse))))
(defun slime-trace-dialog-next-button (&optional goback)
(interactive)
(let ((finder (if goback
#'previous-single-property-change
#'next-single-property-change)))
(cl-loop for pos = (funcall finder (point) 'action)
while pos
do (goto-char pos)
until (get-text-property pos 'action))))
(defun slime-trace-dialog-prev-button ()
(interactive)
(slime-trace-dialog-next-button 'goback))
(defvar slime-trace-dialog-after-toggle-hook nil
"Hooks run after toggling a dialog-trace")
(defun slime-trace-dialog-toggle-trace (&optional using-context-p)
"Toggle the dialog-trace of the spec at point.
When USING-CONTEXT-P, attempt to decipher lambdas. methods and
other complicated function specs."
(interactive "P")
;; Notice the use of "spec strings" here as opposed to the
;; proper cons specs we use on the swank side.
;;
;; Notice the conditional use of `slime-trace-query' found in
;; swank-fancy-trace.el
;;
(let* ((spec-string (if using-context-p
(slime-extract-context)
(slime-symbol-at-point)))
(spec-string (if (fboundp 'slime-trace-query)
(slime-trace-query spec-string)
spec-string)))
(message "%s" (slime-eval `(swank-trace-dialog:dialog-toggle-trace
(swank::from-string ,spec-string))))
(run-hooks 'slime-trace-dialog-after-toggle-hook)))
(defun slime-trace-dialog--update-existing-dialog ()
(let ((existing (slime-trace-dialog--live-dialog)))
(when existing
(with-current-buffer existing
(slime-trace-dialog-fetch-status)))))
(add-hook 'slime-trace-dialog-after-toggle-hook
'slime-trace-dialog--update-existing-dialog)
(defun slime-trace-dialog-toggle-complex-trace ()
"Toggle the dialog-trace of the complex spec at point.
See `slime-trace-dialog-toggle-trace'."
(interactive)
(slime-trace-dialog-toggle-trace t))
(defun slime-trace-dialog (&optional clear-and-fetch)
"Show trace dialog and refresh trace collection status.
With optional CLEAR-AND-FETCH prefix arg, clear the current tree
and fetch a first batch of traces."
(interactive "P")
(with-current-buffer
(pop-to-buffer (slime-trace-dialog--ensure-buffer))
(slime-trace-dialog-fetch-status)
(when (or clear-and-fetch
(null slime-trace-dialog--fetch-key))
(slime-trace-dialog--clear-local-tree))
(when clear-and-fetch
(slime-trace-dialog-fetch-traces nil))))
(defun slime-trace-dialog-copy-down-to-repl (id part-id type)
"Eval the Trace Dialog entry under point in the REPL (to set *)"
(interactive (cl-loop for prop in '(slime-trace-dialog--id
slime-trace-dialog--part-id
slime-trace-dialog--type)
collect (get-text-property (point) prop)))
(unless (and id part-id type) (error "No trace part at point %s" (point)))
(slime-repl-send-string
(format "%s" `(nth-value 0
(swank-trace-dialog::find-trace-part
,id ,part-id ,type))))
(slime-repl))
(provide 'slime-trace-dialog)

BIN
elpa/slime-20180413.1720/contrib/slime-trace-dialog.elc Normal file
View File

Binary file not shown.

107
elpa/slime-20180413.1720/contrib/slime-tramp.el Normal file
View File

@@ -0,0 +1,107 @@
(require 'slime)
(require 'tramp)
(eval-when-compile (require 'cl)) ; lexical-let
(define-slime-contrib slime-tramp
"Filename translations for tramp"
(:authors "Marco Baringer <mb@bese.it>")
(:license "GPL")
(:on-load
(setq slime-to-lisp-filename-function #'slime-tramp-to-lisp-filename)
(setq slime-from-lisp-filename-function #'slime-tramp-from-lisp-filename)))
(defcustom slime-filename-translations nil
"Assoc list of hostnames and filename translation functions.
Each element is of the form (HOSTNAME-REGEXP TO-LISP FROM-LISP).
HOSTNAME-REGEXP is a regexp which is applied to the connection's
slime-machine-instance. If HOSTNAME-REGEXP maches then the
corresponding TO-LISP and FROM-LISP functions will be used to
translate emacs filenames and lisp filenames.
TO-LISP will be passed the filename of an emacs buffer and must
return a string which the underlying lisp understandas as a
pathname. FROM-LISP will be passed a pathname as returned by the
underlying lisp and must return something that emacs will
understand as a filename (this string will be passed to
find-file).
This list will be traversed in order, so multiple matching
regexps are possible.
Example:
Assuming you run emacs locally and connect to slime running on
the machine 'soren' and you can connect with the username
'animaliter':
(push (list \"^soren$\"
(lambda (emacs-filename)
(subseq emacs-filename (length \"/ssh:animaliter@soren:\")))
(lambda (lisp-filename)
(concat \"/ssh:animaliter@soren:\" lisp-filename)))
slime-filename-translations)
See also `slime-create-filename-translator'."
:type '(repeat (list :tag "Host description"
(regexp :tag "Hostname regexp")
(function :tag "To lisp function")
(function :tag "From lisp function")))
:group 'slime-lisp)
(defun slime-find-filename-translators (hostname)
(cond ((cdr (cl-assoc-if (lambda (regexp) (string-match regexp hostname))
slime-filename-translations)))
(t (list #'identity #'identity))))
(defun slime-make-tramp-file-name (username remote-host lisp-filename)
"Old (with multi-hops) tramp compatability function"
(if (boundp 'tramp-multi-methods)
(tramp-make-tramp-file-name nil nil
username
remote-host
lisp-filename)
(tramp-make-tramp-file-name nil
username
remote-host
lisp-filename)))
(cl-defun slime-create-filename-translator (&key machine-instance
remote-host
username)
"Creates a three element list suitable for push'ing onto
slime-filename-translations which uses Tramp to load files on
hostname using username. MACHINE-INSTANCE is a required
parameter, REMOTE-HOST defaults to MACHINE-INSTANCE and USERNAME
defaults to (user-login-name).
MACHINE-INSTANCE is the value returned by slime-machine-instance,
which is just the value returned by cl:machine-instance on the
remote lisp. REMOTE-HOST is the fully qualified domain name (or
just the IP) of the remote machine. USERNAME is the username we
should login with.
The functions created here expect your tramp-default-method or
tramp-default-method-alist to be setup correctly."
(lexical-let ((remote-host (or remote-host machine-instance))
(username (or username (user-login-name))))
(list (concat "^" machine-instance "$")
(lambda (emacs-filename)
(tramp-file-name-localname
(tramp-dissect-file-name emacs-filename)))
`(lambda (lisp-filename)
(slime-make-tramp-file-name
,username
,remote-host
lisp-filename)))))
(defun slime-tramp-to-lisp-filename (filename)
(funcall (if (slime-connected-p)
(first (slime-find-filename-translators (slime-machine-instance)))
'identity)
(expand-file-name filename)))
(defun slime-tramp-from-lisp-filename (filename)
(funcall (second (slime-find-filename-translators (slime-machine-instance)))
filename))
(provide 'slime-tramp)

BIN
elpa/slime-20180413.1720/contrib/slime-tramp.elc Normal file
View File

Binary file not shown.

92
elpa/slime-20180413.1720/contrib/slime-typeout-frame.el Normal file
View File

@@ -0,0 +1,92 @@
(require 'slime)
(require 'slime-autodoc)
(require 'cl-lib)
(defvar slime-typeout-frame-unbind-stack ())
(define-slime-contrib slime-typeout-frame
"Display messages in a dedicated frame."
(:authors "Luke Gorrie <luke@synap.se>")
(:license "GPL")
(:on-load
(unless (slime-typeout-tty-only-p)
(add-hook 'slime-connected-hook 'slime-ensure-typeout-frame)
(add-hook 'slime-autodoc-mode-hook 'slime-typeout-wrap-autodoc)
(cl-loop for (var value) in
'((slime-message-function slime-typeout-message)
(slime-background-message-function slime-typeout-message))
do (slime-typeout-frame-init-var var value))))
(:on-unload
(remove-hook 'slime-connected-hook 'slime-ensure-typeout-frame)
(remove-hook 'slime-autodoc-mode-hook 'slime-typeout-wrap-autodoc)
(cl-loop for (var value) in slime-typeout-frame-unbind-stack
do (cond ((eq var 'slime-unbound) (makunbound var))
(t (set var value))))
(setq slime-typeout-frame-unbind-stack nil)))
(defun slime-typeout-frame-init-var (var value)
(push (list var (if (boundp var) (symbol-value var) 'slime-unbound))
slime-typeout-frame-unbind-stack)
(set var value))
(defun slime-typeout-tty-only-p ()
(cond ((featurep 'xemacs)
(null (remove 'tty (mapcar #'device-type (console-device-list)))))
(t (not (window-system)))))
;;;; Typeout frame
;; When a "typeout frame" exists it is used to display certain
;; messages instead of the echo area or pop-up windows.
(defvar slime-typeout-window nil
"The current typeout window.")
(defvar slime-typeout-frame-properties
'((height . 10) (minibuffer . nil))
"The typeout frame properties (passed to `make-frame').")
(defun slime-typeout-buffer ()
(with-current-buffer (get-buffer-create (slime-buffer-name :typeout))
(setq buffer-read-only t)
(current-buffer)))
(defun slime-typeout-active-p ()
(and slime-typeout-window
(window-live-p slime-typeout-window)))
(defun slime-typeout-message-aux (format-string &rest format-args)
(slime-ensure-typeout-frame)
(with-current-buffer (slime-typeout-buffer)
(let ((inhibit-read-only t)
(msg (apply #'format format-string format-args)))
(unless (string= msg "")
(erase-buffer)
(insert msg)))))
(defun slime-typeout-message (format-string &rest format-args)
(apply #'slime-typeout-message-aux format-string format-args))
(defun slime-make-typeout-frame ()
"Create a frame for displaying messages (e.g. arglists)."
(interactive)
(let ((frame (make-frame slime-typeout-frame-properties)))
(save-selected-window
(select-window (frame-selected-window frame))
(switch-to-buffer (slime-typeout-buffer))
(setq slime-typeout-window (selected-window)))))
(defun slime-ensure-typeout-frame ()
"Create the typeout frame unless it already exists."
(interactive)
(if (slime-typeout-active-p)
(save-selected-window
(select-window slime-typeout-window)
(switch-to-buffer (slime-typeout-buffer)))
(slime-make-typeout-frame)))
(defun slime-typeout-wrap-autodoc ()
(setq eldoc-message-function 'slime-typeout-message-aux))
(provide 'slime-typeout-frame)

BIN
elpa/slime-20180413.1720/contrib/slime-typeout-frame.elc Normal file
View File

Binary file not shown.

99
elpa/slime-20180413.1720/contrib/slime-xref-browser.el Normal file
View File

@@ -0,0 +1,99 @@
(eval-and-compile
(require 'slime))
(define-slime-contrib slime-xref-browser
"Xref browsing with tree-widget"
(:authors "Rui Patroc<6F>nio <rui.patrocinio@netvisao.pt>")
(:license "GPL"))
;;;; classes browser
(defun slime-expand-class-node (widget)
(or (widget-get widget :args)
(let ((name (widget-get widget :tag)))
(cl-loop for kid in (slime-eval `(swank:mop :subclasses ,name))
collect `(tree-widget :tag ,kid
:expander slime-expand-class-node
:has-children t)))))
(defun slime-browse-classes (name)
"Read the name of a class and show its subclasses."
(interactive (list (slime-read-symbol-name "Class Name: ")))
(slime-call-with-browser-setup
(slime-buffer-name :browser) (slime-current-package) "Class Browser"
(lambda ()
(widget-create 'tree-widget :tag name
:expander 'slime-expand-class-node
:has-echildren t))))
(defvar slime-browser-map nil
"Keymap for tree widget browsers")
(require 'tree-widget)
(unless slime-browser-map
(setq slime-browser-map (make-sparse-keymap))
(set-keymap-parent slime-browser-map widget-keymap)
(define-key slime-browser-map "q" 'bury-buffer))
(defun slime-call-with-browser-setup (buffer package title fn)
(switch-to-buffer buffer)
(kill-all-local-variables)
(setq slime-buffer-package package)
(let ((inhibit-read-only t)) (erase-buffer))
(widget-insert title "\n\n")
(save-excursion
(funcall fn))
(lisp-mode-variables t)
(slime-mode t)
(use-local-map slime-browser-map)
(widget-setup))
;;;; Xref browser
(defun slime-fetch-browsable-xrefs (type name)
"Return a list ((LABEL DSPEC)).
LABEL is just a string for display purposes.
DSPEC can be used to expand the node."
(let ((xrefs '()))
(cl-loop for (_file . specs) in (slime-eval `(swank:xref ,type ,name)) do
(cl-loop for (dspec . _location) in specs do
(let ((exp (ignore-errors (read (downcase dspec)))))
(cond ((and (consp exp) (eq 'flet (car exp)))
;; we can't expand FLET references so they're useless
)
((and (consp exp) (eq 'method (car exp)))
;; this isn't quite right, but good enough for now
(push (list dspec (string (cl-second exp))) xrefs))
(t
(push (list dspec dspec) xrefs))))))
xrefs))
(defun slime-expand-xrefs (widget)
(or (widget-get widget :args)
(let* ((type (widget-get widget :xref-type))
(dspec (widget-get widget :xref-dspec))
(xrefs (slime-fetch-browsable-xrefs type dspec)))
(cl-loop for (label dspec) in xrefs
collect `(tree-widget :tag ,label
:xref-type ,type
:xref-dspec ,dspec
:expander slime-expand-xrefs
:has-children t)))))
(defun slime-browse-xrefs (name type)
"Show the xref graph of a function in a tree widget."
(interactive
(list (slime-read-from-minibuffer "Name: "
(slime-symbol-at-point))
(read (completing-read "Type: " (slime-bogus-completion-alist
'(":callers" ":callees" ":calls"))
nil t ":"))))
(slime-call-with-browser-setup
(slime-buffer-name :xref) (slime-current-package) "Xref Browser"
(lambda ()
(widget-create 'tree-widget :tag name :xref-type type :xref-dspec name
:expander 'slime-expand-xrefs :has-echildren t))))
(provide 'slime-xref-browser)

BIN
elpa/slime-20180413.1720/contrib/slime-xref-browser.elc Normal file
View File

Binary file not shown.

1615
elpa/slime-20180413.1720/contrib/swank-arglists.lisp Normal file
View File

File diff suppressed because it is too large Load Diff

542
elpa/slime-20180413.1720/contrib/swank-asdf.lisp Normal file
View File

@@ -0,0 +1,542 @@
;;; swank-asdf.lisp -- ASDF support
;;
;; Authors: Daniel Barlow <dan@telent.net>
;; Marco Baringer <mb@bese.it>
;; Edi Weitz <edi@agharta.de>
;; Francois-Rene Rideau <tunes@google.com>
;; and others
;; License: Public Domain
;;
(in-package :swank)
(eval-when (:compile-toplevel :load-toplevel :execute)
;;; The best way to load ASDF is from an init file of an
;;; implementation. If ASDF is not loaded at the time swank-asdf is
;;; loaded, it will be tried first with (require "asdf"), if that
;;; doesn't help and *asdf-path* is set, it will be loaded from that
;;; file.
;;; To set *asdf-path* put the following into ~/.swank.lisp:
;;; (defparameter swank::*asdf-path* #p"/path/to/asdf/asdf.lisp")
(defvar *asdf-path* nil
"Path to asdf.lisp file, to be loaded in case (require \"asdf\") fails."))
(eval-when (:compile-toplevel :load-toplevel :execute)
(unless (member :asdf *features*)
(ignore-errors (funcall 'require "asdf"))))
(eval-when (:compile-toplevel :load-toplevel :execute)
(unless (member :asdf *features*)
(handler-bind ((warning #'muffle-warning))
(when *asdf-path*
(load *asdf-path* :if-does-not-exist nil)))))
;; If still not found, error out.
(eval-when (:compile-toplevel :load-toplevel :execute)
(unless (member :asdf *features*)
(error "Could not load ASDF.
Please update your implementation or
install a recent release of ASDF and in your ~~/.swank.lisp specify:
(defparameter swank::*asdf-path* #p\"/path/containing/asdf/asdf.lisp\")")))
;;; If ASDF is too old, punt.
;; As of January 2014, Quicklisp has been providing 2.26 for a year
;; (and previously had 2.014.6 for over a year), whereas
;; all SLIME-supported implementations provide ASDF3 (i.e. 2.27 or later)
;; except LispWorks (stuck with 2.019) and SCL (which hasn't been released
;; in years and doesn't provide ASDF at all, but is fully supported by ASDF).
;; If your implementation doesn't provide ASDF, or provides an old one,
;; install an upgrade yourself and configure *asdf-path*.
;; It's just not worth the hassle supporting something
;; that doesn't even have COERCE-PATHNAME.
;;
;; NB: this version check is duplicated in swank-loader.lisp so that we don't
;; try to load this contrib when ASDF is too old since that will abort the SLIME
;; connection.
#-asdf3
(eval-when (:compile-toplevel :load-toplevel :execute)
(unless (or #+asdf3 t #+asdf2
(asdf:version-satisfies (asdf:asdf-version) "2.14.6"))
(error "Your ASDF is too old. ~
The oldest version supported by swank-asdf is 2.014.6.")))
;;; Import functionality from ASDF that isn't available in all ASDF versions.
;;; Please do NOT depend on any of the below as reference:
;;; they are sometimes stripped down versions, for compatibility only.
;;; Indeed, they are supposed to work on *OLDER*, not *NEWER* versions of ASDF.
;;;
;;; The way I got these is usually by looking at the current definition,
;;; using git blame in one screen to locate which commit last modified it,
;;; and git log in another to determine which release that made it in.
;;; It is OK for some of the below definitions to be or become obsolete,
;;; as long as it will make do with versions older than the tagged version:
;;; if ASDF is more recent, its more recent version will win.
;;;
;;; If your software is hacking ASDF, use its internals.
;;; If you want ASDF utilities in user software, please use ASDF-UTILS.
(defun asdf-at-least (version)
(asdf:version-satisfies (asdf:asdf-version) version))
(defmacro asdefs (version &rest defs)
(flet ((defun* (version name aname rest)
`(progn
(defun ,name ,@rest)
(declaim (notinline ,name))
(when (asdf-at-least ,version)
(setf (fdefinition ',name) (fdefinition ',aname)))))
(defmethod* (version aname rest)
`(unless (asdf-at-least ,version)
(defmethod ,aname ,@rest)))
(defvar* (name aname rest)
`(progn
(define-symbol-macro ,name ,aname)
(defvar ,aname ,@rest))))
`(progn
,@(loop :for (def name . args) :in defs
:for aname = (intern (string name) :asdf)
:collect
(ecase def
((defun) (defun* version name aname args))
((defmethod) (defmethod* version aname args))
((defvar) (defvar* name aname args)))))))
(asdefs "2.15"
(defvar *wild* #-cormanlisp :wild #+cormanlisp "*")
(defun collect-asds-in-directory (directory collect)
(map () collect (directory-asd-files directory)))
(defun register-asd-directory (directory &key recurse exclude collect)
(if (not recurse)
(collect-asds-in-directory directory collect)
(collect-sub*directories-asd-files
directory :exclude exclude :collect collect))))
(asdefs "2.16"
(defun load-sysdef (name pathname)
(declare (ignore name))
(let ((package (asdf::make-temporary-package)))
(unwind-protect
(let ((*package* package)
(*default-pathname-defaults*
(asdf::pathname-directory-pathname
(translate-logical-pathname pathname))))
(asdf::asdf-message
"~&; Loading system definition from ~A into ~A~%" ;
pathname package)
(load pathname))
(delete-package package))))
(defun directory* (pathname-spec &rest keys &key &allow-other-keys)
(apply 'directory pathname-spec
(append keys
'#.(or #+allegro
'(:directories-are-files nil
:follow-symbolic-links nil)
#+clozure
'(:follow-links nil)
#+clisp
'(:circle t :if-does-not-exist :ignore)
#+(or cmu scl)
'(:follow-links nil :truenamep nil)
#+sbcl
(when (find-symbol "RESOLVE-SYMLINKS" '#:sb-impl)
'(:resolve-symlinks nil)))))))
(asdefs "2.17"
(defun collect-sub*directories-asd-files
(directory &key
(exclude asdf::*default-source-registry-exclusions*)
collect)
(asdf::collect-sub*directories
directory
(constantly t)
(lambda (x) (not (member (car (last (pathname-directory x)))
exclude :test #'equal)))
(lambda (dir) (collect-asds-in-directory dir collect))))
(defun system-source-directory (system-designator)
(asdf::pathname-directory-pathname
(asdf::system-source-file system-designator)))
(defun filter-logical-directory-results (directory entries merger)
(if (typep directory 'logical-pathname)
(loop for f in entries
when
(if (typep f 'logical-pathname)
f
(let ((u (ignore-errors (funcall merger f))))
(and u
(equal (ignore-errors (truename u))
(truename f))
u)))
collect it)
entries))
(defun directory-asd-files (directory)
(directory-files directory asdf::*wild-asd*)))
(asdefs "2.19"
(defun subdirectories (directory)
(let* ((directory (asdf::ensure-directory-pathname directory))
#-(or abcl cormanlisp xcl)
(wild (asdf::merge-pathnames*
#-(or abcl allegro cmu lispworks sbcl scl xcl)
asdf::*wild-directory*
#+(or abcl allegro cmu lispworks sbcl scl xcl) "*.*"
directory))
(dirs
#-(or abcl cormanlisp xcl)
(ignore-errors
(directory* wild . #.(or #+clozure '(:directories t :files nil)
#+mcl '(:directories t))))
#+(or abcl xcl) (system:list-directory directory)
#+cormanlisp (cl::directory-subdirs directory))
#+(or abcl allegro cmu lispworks sbcl scl xcl)
(dirs (loop for x in dirs
for d = #+(or abcl xcl) (extensions:probe-directory x)
#+allegro (excl:probe-directory x)
#+(or cmu sbcl scl) (asdf::directory-pathname-p x)
#+lispworks (lw:file-directory-p x)
when d collect #+(or abcl allegro xcl) d
#+(or cmu lispworks sbcl scl) x)))
(filter-logical-directory-results
directory dirs
(let ((prefix (or (normalize-pathname-directory-component
(pathname-directory directory))
;; because allegro 8.x returns NIL for #p"FOO:"
'(:absolute))))
(lambda (d)
(let ((dir (normalize-pathname-directory-component
(pathname-directory d))))
(and (consp dir) (consp (cdr dir))
(make-pathname
:defaults directory :name nil :type nil :version nil
:directory
(append prefix
(make-pathname-component-logical
(last dir))))))))))))
(asdefs "2.21"
(defun component-loaded-p (c)
(and (gethash 'load-op (asdf::component-operation-times
(asdf::find-component c nil))) t))
(defun normalize-pathname-directory-component (directory)
(cond
#-(or cmu sbcl scl)
((stringp directory) `(:absolute ,directory) directory)
((or (null directory)
(and (consp directory)
(member (first directory) '(:absolute :relative))))
directory)
(t
(error "Unrecognized pathname directory component ~S" directory))))
(defun make-pathname-component-logical (x)
(typecase x
((eql :unspecific) nil)
#+clisp (string (string-upcase x))
#+clisp (cons (mapcar 'make-pathname-component-logical x))
(t x)))
(defun make-pathname-logical (pathname host)
(make-pathname
:host host
:directory (make-pathname-component-logical (pathname-directory pathname))
:name (make-pathname-component-logical (pathname-name pathname))
:type (make-pathname-component-logical (pathname-type pathname))
:version (make-pathname-component-logical (pathname-version pathname)))))
(asdefs "2.22"
(defun directory-files (directory &optional (pattern asdf::*wild-file*))
(let ((dir (pathname directory)))
(when (typep dir 'logical-pathname)
(when (wild-pathname-p dir)
(error "Invalid wild pattern in logical directory ~S" directory))
(unless (member (pathname-directory pattern)
'(() (:relative)) :test 'equal)
(error "Invalid file pattern ~S for logical directory ~S"
pattern directory))
(setf pattern (make-pathname-logical pattern (pathname-host dir))))
(let ((entries (ignore-errors
(directory* (asdf::merge-pathnames* pattern dir)))))
(filter-logical-directory-results
directory entries
(lambda (f)
(make-pathname :defaults dir
:name (make-pathname-component-logical
(pathname-name f))
:type (make-pathname-component-logical
(pathname-type f))
:version (make-pathname-component-logical
(pathname-version f)))))))))
(asdefs "2.26.149"
(defmethod component-relative-pathname ((system asdf:system))
(asdf::coerce-pathname
(and (slot-boundp system 'asdf::relative-pathname)
(slot-value system 'asdf::relative-pathname))
:type :directory
:defaults (system-source-directory system)))
(defun load-asd (pathname &key name &allow-other-keys)
(asdf::load-sysdef (or name (string-downcase (pathname-name pathname)))
pathname)))
;;; Taken from ASDF 1.628
(defmacro while-collecting ((&rest collectors) &body body)
`(asdf::while-collecting ,collectors ,@body))
;;; Now for SLIME-specific stuff
(defun asdf-operation (operation)
(or (asdf::find-symbol* operation :asdf)
(error "Couldn't find ASDF operation ~S" operation)))
(defun map-system-components (fn system)
(map-component-subcomponents fn (asdf:find-system system)))
(defun map-component-subcomponents (fn component)
(when component
(funcall fn component)
(when (typep component 'asdf:module)
(dolist (c (asdf:module-components component))
(map-component-subcomponents fn c)))))
;;; Maintaining a pathname to component table
(defvar *pathname-component* (make-hash-table :test 'equal))
(defun clear-pathname-component-table ()
(clrhash *pathname-component*))
(defun register-system-pathnames (system)
(map-system-components 'register-component-pathname system))
(defun recompute-pathname-component-table ()
(clear-pathname-component-table)
(asdf::map-systems 'register-system-pathnames))
(defun pathname-component (x)
(gethash (pathname x) *pathname-component*))
(defmethod asdf:component-pathname :around ((component asdf:component))
(let ((p (call-next-method)))
(when (pathnamep p)
(setf (gethash p *pathname-component*) component))
p))
(defun register-component-pathname (component)
(asdf:component-pathname component))
(recompute-pathname-component-table)
;;; This is a crude hack, see ASDF's LP #481187.
(defslimefun who-depends-on (system)
(flet ((system-dependencies (op system)
(mapcar (lambda (dep)
(asdf::coerce-name (if (consp dep) (second dep) dep)))
(cdr (assoc op (asdf:component-depends-on op system))))))
(let ((system-name (asdf::coerce-name system))
(result))
(asdf::map-systems
(lambda (system)
(when (member system-name
(system-dependencies 'asdf:load-op system)
:test #'string=)
(push (asdf:component-name system) result))))
result)))
(defmethod xref-doit ((type (eql :depends-on)) thing)
(when (typep thing '(or string symbol))
(loop for dependency in (who-depends-on thing)
for asd-file = (asdf:system-definition-pathname dependency)
when asd-file
collect (list dependency
(swank/backend:make-location
`(:file ,(namestring asd-file))
`(:position 1)
`(:snippet ,(format nil "(defsystem :~A" dependency)
:align t))))))
(defslimefun operate-on-system-for-emacs (system-name operation &rest keywords)
"Compile and load SYSTEM using ASDF.
Record compiler notes signalled as `compiler-condition's."
(collect-notes
(lambda ()
(apply #'operate-on-system system-name operation keywords))))
(defun operate-on-system (system-name operation-name &rest keyword-args)
"Perform OPERATION-NAME on SYSTEM-NAME using ASDF.
The KEYWORD-ARGS are passed on to the operation.
Example:
\(operate-on-system \"cl-ppcre\" 'compile-op :force t)"
(handler-case
(with-compilation-hooks ()
(apply #'asdf:operate (asdf-operation operation-name)
system-name keyword-args)
t)
((or asdf:compile-error #+asdf3 asdf/lisp-build:compile-file-error)
() nil)))
(defun unique-string-list (&rest lists)
(sort (delete-duplicates (apply #'append lists) :test #'string=) #'string<))
(defslimefun list-all-systems-in-central-registry ()
"Returns a list of all systems in ASDF's central registry
AND in its source-registry. (legacy name)"
(unique-string-list
(mapcar
#'pathname-name
(while-collecting (c)
(loop for dir in asdf:*central-registry*
for defaults = (eval dir)
when defaults
do (collect-asds-in-directory defaults #'c))
(asdf:ensure-source-registry)
(if (or #+asdf3 t
#-asdf3 (asdf:version-satisfies (asdf:asdf-version) "2.15"))
(loop :for k :being :the :hash-keys :of asdf::*source-registry*
:do (c k))
#-asdf3
(dolist (entry (asdf::flatten-source-registry))
(destructuring-bind (directory &key recurse exclude) entry
(register-asd-directory
directory
:recurse recurse :exclude exclude :collect #'c))))))))
(defslimefun list-all-systems-known-to-asdf ()
"Returns a list of all systems ASDF knows already."
(while-collecting (c)
(asdf::map-systems (lambda (system) (c (asdf:component-name system))))))
(defslimefun list-asdf-systems ()
"Returns the systems in ASDF's central registry and those which ASDF
already knows."
(unique-string-list
(list-all-systems-known-to-asdf)
(list-all-systems-in-central-registry)))
(defun asdf-component-source-files (component)
(while-collecting (c)
(labels ((f (x)
(typecase x
(asdf:source-file (c (asdf:component-pathname x)))
(asdf:module (map () #'f (asdf:module-components x))))))
(f component))))
(defun make-operation (x)
#+#.(swank/backend:with-symbol 'make-operation 'asdf)
(asdf:make-operation x)
#-#.(swank/backend:with-symbol 'make-operation 'asdf)
(make-instance x))
(defun asdf-component-output-files (component)
(while-collecting (c)
(labels ((f (x)
(typecase x
(asdf:source-file
(map () #'c
(asdf:output-files (make-operation 'asdf:compile-op) x)))
(asdf:module (map () #'f (asdf:module-components x))))))
(f component))))
(defslimefun asdf-system-files (name)
(let* ((system (asdf:find-system name))
(files (mapcar #'namestring
(cons
(asdf:system-definition-pathname system)
(asdf-component-source-files system))))
(main-file (find name files
:test #'equalp :key #'pathname-name :start 1)))
(if main-file
(cons main-file (remove main-file files
:test #'equal :count 1))
files)))
(defslimefun asdf-system-loaded-p (name)
(component-loaded-p name))
(defslimefun asdf-system-directory (name)
(namestring (translate-logical-pathname (asdf:system-source-directory name))))
(defun pathname-system (pathname)
(let ((component (pathname-component pathname)))
(when component
(asdf:component-name (asdf:component-system component)))))
(defslimefun asdf-determine-system (file buffer-package-name)
(or
(and file
(pathname-system file))
(and file
(progn
;; If not found, let's rebuild the table first
(recompute-pathname-component-table)
(pathname-system file)))
;; If we couldn't find an already defined system,
;; try finding a system that's named like BUFFER-PACKAGE-NAME.
(loop with package = (guess-buffer-package buffer-package-name)
for name in (package-names package)
for system = (asdf:find-system (asdf::coerce-name name) nil)
when (and system
(or (not file)
(pathname-system file)))
return (asdf:component-name system))))
(defslimefun delete-system-fasls (name)
(let ((removed-count
(loop for file in (asdf-component-output-files
(asdf:find-system name))
when (probe-file file)
count it
and
do (delete-file file))))
(format nil "~d file~:p ~:*~[were~;was~:;were~] removed" removed-count)))
(defvar *recompile-system* nil)
(defmethod asdf:operation-done-p :around
((operation asdf:compile-op)
component)
(unless (eql *recompile-system*
(asdf:component-system component))
(call-next-method)))
(defslimefun reload-system (name)
(let ((*recompile-system* (asdf:find-system name)))
(operate-on-system-for-emacs name 'asdf:load-op)))
;; Doing list-all-systems-in-central-registry might be quite slow
;; since it accesses a file-system, so run it once at the background
;; to initialize caches.
(when (eql *communication-style* :spawn)
(spawn (lambda ()
(ignore-errors (list-all-systems-in-central-registry)))
:name "init-asdf-fs-caches"))
;;; Hook for compile-file-for-emacs
(defun try-compile-file-with-asdf (pathname load-p &rest options)
(declare (ignore options))
(let ((component (pathname-component pathname)))
(when component
;;(format t "~&Compiling ASDF component ~S~%" component)
(let ((op (make-operation 'asdf:compile-op)))
(with-compilation-hooks ()
(asdf:perform op component))
(when load-p
(asdf:perform (make-operation 'asdf:load-op) component))
(values t t nil (first (asdf:output-files op component)))))))
(defun try-compile-asd-file (pathname load-p &rest options)
(declare (ignore load-p options))
(when (equalp (pathname-type pathname) "asd")
(load-asd pathname)
(values t t nil pathname)))
(pushnew 'try-compile-asd-file *compile-file-for-emacs-hook*)
;;; (pushnew 'try-compile-file-with-asdf *compile-file-for-emacs-hook*)
(provide :swank-asdf)

298
elpa/slime-20180413.1720/contrib/swank-c-p-c.lisp Normal file
View File

@@ -0,0 +1,298 @@
;;; swank-c-p-c.lisp -- ILISP style Compound Prefix Completion
;;
;; Author: Luke Gorrie <luke@synap.se>
;; Edi Weitz <edi@agharta.de>
;; Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de>
;; Tobias C. Rittweiler <tcr@freebits.de>
;; and others
;;
;; License: Public Domain
;;
(in-package :swank)
(eval-when (:compile-toplevel :load-toplevel :execute)
(swank-require :swank-util))
(defslimefun completions (string default-package-name)
"Return a list of completions for a symbol designator STRING.
The result is the list (COMPLETION-SET COMPLETED-PREFIX), where
COMPLETION-SET is the list of all matching completions, and
COMPLETED-PREFIX is the best (partial) completion of the input
string.
Simple compound matching is supported on a per-hyphen basis:
(completions \"m-v-\" \"COMMON-LISP\")
==> ((\"multiple-value-bind\" \"multiple-value-call\"
\"multiple-value-list\" \"multiple-value-prog1\"
\"multiple-value-setq\" \"multiple-values-limit\")
\"multiple-value\")
\(For more advanced compound matching, see FUZZY-COMPLETIONS.)
If STRING is package qualified the result list will also be
qualified. If string is non-qualified the result strings are
also not qualified and are considered relative to
DEFAULT-PACKAGE-NAME.
The way symbols are matched depends on the symbol designator's
format. The cases are as follows:
FOO - Symbols with matching prefix and accessible in the buffer package.
PKG:FOO - Symbols with matching prefix and external in package PKG.
PKG::FOO - Symbols with matching prefix and accessible in package PKG.
"
(multiple-value-bind (name package-name package internal-p)
(parse-completion-arguments string default-package-name)
(let* ((symbol-set (symbol-completion-set
name package-name package internal-p
(make-compound-prefix-matcher #\-)))
(package-set (package-completion-set
name package-name package internal-p
(make-compound-prefix-matcher '(#\. #\-))))
(completion-set
(format-completion-set (nconc symbol-set package-set)
internal-p package-name)))
(when completion-set
(list completion-set (longest-compound-prefix completion-set))))))
;;;;; Find completion set
(defun symbol-completion-set (name package-name package internal-p matchp)
"Return the set of completion-candidates as strings."
(mapcar (completion-output-symbol-converter name)
(and package
(mapcar #'symbol-name
(find-matching-symbols name
package
(and (not internal-p)
package-name)
matchp)))))
(defun package-completion-set (name package-name package internal-p matchp)
(declare (ignore package internal-p))
(mapcar (completion-output-package-converter name)
(and (not package-name)
(find-matching-packages name matchp))))
(defun find-matching-symbols (string package external test)
"Return a list of symbols in PACKAGE matching STRING.
TEST is called with two strings. If EXTERNAL is true, only external
symbols are returned."
(let ((completions '())
(converter (completion-output-symbol-converter string)))
(flet ((symbol-matches-p (symbol)
(and (or (not external)
(symbol-external-p symbol package))
(funcall test string
(funcall converter (symbol-name symbol))))))
(do-symbols* (symbol package)
(when (symbol-matches-p symbol)
(push symbol completions))))
completions))
(defun find-matching-symbols-in-list (string list test)
"Return a list of symbols in LIST matching STRING.
TEST is called with two strings."
(let ((completions '())
(converter (completion-output-symbol-converter string)))
(flet ((symbol-matches-p (symbol)
(funcall test string
(funcall converter (symbol-name symbol)))))
(dolist (symbol list)
(when (symbol-matches-p symbol)
(push symbol completions))))
(remove-duplicates completions)))
(defun find-matching-packages (name matcher)
"Return a list of package names matching NAME with MATCHER.
MATCHER is a two-argument predicate."
(let ((converter (completion-output-package-converter name)))
(remove-if-not (lambda (x)
(funcall matcher name (funcall converter x)))
(mapcar (lambda (pkgname)
(concatenate 'string pkgname ":"))
(loop for package in (list-all-packages)
nconcing (package-names package))))))
;; PARSE-COMPLETION-ARGUMENTS return table:
;;
;; user behaviour | NAME | PACKAGE-NAME | PACKAGE
;; ----------------+--------+--------------+-----------------------------------
;; asdf [tab] | "asdf" | NIL | #<PACKAGE "DEFAULT-PACKAGE-NAME">
;; | | | or *BUFFER-PACKAGE*
;; asdf: [tab] | "" | "asdf" | #<PACKAGE "ASDF">
;; | | |
;; asdf:foo [tab] | "foo" | "asdf" | #<PACKAGE "ASDF">
;; | | |
;; as:fo [tab] | "fo" | "as" | NIL
;; | | |
;; : [tab] | "" | "" | #<PACKAGE "KEYWORD">
;; | | |
;; :foo [tab] | "foo" | "" | #<PACKAGE "KEYWORD">
;;
(defun parse-completion-arguments (string default-package-name)
"Parse STRING as a symbol designator.
Return these values:
SYMBOL-NAME
PACKAGE-NAME, or nil if the designator does not include an explicit package.
PACKAGE, generally the package to complete in. (However, if PACKAGE-NAME is
NIL, return the respective package of DEFAULT-PACKAGE-NAME instead;
if PACKAGE is non-NIL but a package cannot be found under that name,
return NIL.)
INTERNAL-P, if the symbol is qualified with `::'."
(multiple-value-bind (name package-name internal-p)
(tokenize-symbol string)
(flet ((default-package ()
(or (guess-package default-package-name) *buffer-package*)))
(let ((package (cond
((not package-name)
(default-package))
((equal package-name "")
(guess-package (symbol-name :keyword)))
((find-locally-nicknamed-package
package-name (default-package)))
(t
(guess-package package-name)))))
(values name package-name package internal-p)))))
(defun completion-output-case-converter (input &optional with-escaping-p)
"Return a function to convert strings for the completion output.
INPUT is used to guess the preferred case."
(ecase (readtable-case *readtable*)
(:upcase (cond ((or with-escaping-p
(and (plusp (length input))
(not (some #'lower-case-p input))))
#'identity)
(t #'string-downcase)))
(:invert (lambda (output)
(multiple-value-bind (lower upper) (determine-case output)
(cond ((and lower upper) output)
(lower (string-upcase output))
(upper (string-downcase output))
(t output)))))
(:downcase (cond ((or with-escaping-p
(and (zerop (length input))
(not (some #'upper-case-p input))))
#'identity)
(t #'string-upcase)))
(:preserve #'identity)))
(defun completion-output-package-converter (input)
"Return a function to convert strings for the completion output.
INPUT is used to guess the preferred case."
(completion-output-case-converter input))
(defun completion-output-symbol-converter (input)
"Return a function to convert strings for the completion output.
INPUT is used to guess the preferred case. Escape symbols when needed."
(let ((case-converter (completion-output-case-converter input))
(case-converter-with-escaping (completion-output-case-converter input t)))
(lambda (str)
(if (or (multiple-value-bind (lowercase uppercase)
(determine-case str)
;; In these readtable cases, symbols with letters from
;; the wrong case need escaping
(case (readtable-case *readtable*)
(:upcase lowercase)
(:downcase uppercase)
(t nil)))
(some (lambda (el)
(or (member el '(#\: #\Space #\Newline #\Tab))
(multiple-value-bind (macrofun nonterminating)
(get-macro-character el)
(and macrofun
(not nonterminating)))))
str))
(concatenate 'string "|" (funcall case-converter-with-escaping str) "|")
(funcall case-converter str)))))
(defun determine-case (string)
"Return two booleans LOWER and UPPER indicating whether STRING
contains lower or upper case characters."
(values (some #'lower-case-p string)
(some #'upper-case-p string)))
;;;;; Compound-prefix matching
(defun make-compound-prefix-matcher (delimiter &key (test #'char=))
"Returns a matching function that takes a `prefix' and a
`target' string and which returns T if `prefix' is a
compound-prefix of `target', and otherwise NIL.
Viewing each of `prefix' and `target' as a series of substrings
delimited by DELIMITER, if each substring of `prefix' is a prefix
of the corresponding substring in `target' then we call `prefix'
a compound-prefix of `target'.
DELIMITER may be a character, or a list of characters."
(let ((delimiters (etypecase delimiter
(character (list delimiter))
(cons (assert (every #'characterp delimiter))
delimiter))))
(lambda (prefix target)
(declare (type simple-string prefix target))
(loop with tpos = 0
for ch across prefix
always (and (< tpos (length target))
(let ((delimiter (car (member ch delimiters :test test))))
(if delimiter
(setf tpos (position delimiter target :start tpos))
(funcall test ch (aref target tpos)))))
do (incf tpos)))))
;;;;; Extending the input string by completion
(defun longest-compound-prefix (completions &optional (delimiter #\-))
"Return the longest compound _prefix_ for all COMPLETIONS."
(flet ((tokenizer (string) (tokenize-completion string delimiter)))
(untokenize-completion
(loop for token-list in (transpose-lists (mapcar #'tokenizer completions))
if (notevery #'string= token-list (rest token-list))
;; Note that we possibly collect the "" here as well, so that
;; UNTOKENIZE-COMPLETION will append a delimiter for us.
collect (longest-common-prefix token-list)
and do (loop-finish)
else collect (first token-list))
delimiter)))
(defun tokenize-completion (string delimiter)
"Return all substrings of STRING delimited by DELIMITER."
(loop with end
for start = 0 then (1+ end)
until (> start (length string))
do (setq end (or (position delimiter string :start start) (length string)))
collect (subseq string start end)))
(defun untokenize-completion (tokens &optional (delimiter #\-))
(format nil (format nil "~~{~~A~~^~a~~}" delimiter) tokens))
(defun transpose-lists (lists)
"Turn a list-of-lists on its side.
If the rows are of unequal length, truncate uniformly to the shortest.
For example:
\(transpose-lists '((ONE TWO THREE) (1 2)))
=> ((ONE 1) (TWO 2))"
(cond ((null lists) '())
((some #'null lists) '())
(t (cons (mapcar #'car lists)
(transpose-lists (mapcar #'cdr lists))))))
;;;; Completion for character names
(defslimefun completions-for-character (prefix)
(let* ((matcher (make-compound-prefix-matcher #\_ :test #'char-equal))
(completion-set (character-completion-set prefix matcher))
(completions (sort completion-set #'string<)))
(list completions (longest-compound-prefix completions #\_))))
(provide :swank-c-p-c)

71
elpa/slime-20180413.1720/contrib/swank-clipboard.lisp Normal file
View File

@@ -0,0 +1,71 @@
;;; swank-clipboard.lisp --- Object clipboard
;;
;; Written by Helmut Eller in 2008.
;; License: Public Domain
(defpackage :swank-clipboard
(:use :cl)
(:import-from :swank :defslimefun :with-buffer-syntax :dcase)
(:export :add :delete-entry :entries :entry-to-ref :ref))
(in-package :swank-clipboard)
(defstruct clipboard entries (counter 0))
(defvar *clipboard* (make-clipboard))
(defslimefun add (datum)
(let ((value (dcase datum
((:string string package)
(with-buffer-syntax (package)
(eval (read-from-string string))))
((:inspector part)
(swank:inspector-nth-part part))
((:sldb frame var)
(swank/backend:frame-var-value frame var)))))
(clipboard-add value)
(format nil "Added: ~a"
(entry-to-string (1- (length (clipboard-entries *clipboard*)))))))
(defslimefun entries ()
(loop for (ref . value) in (clipboard-entries *clipboard*)
collect `(,ref . ,(to-line value))))
(defslimefun delete-entry (entry)
(let ((msg (format nil "Deleted: ~a" (entry-to-string entry))))
(clipboard-delete-entry entry)
msg))
(defslimefun entry-to-ref (entry)
(destructuring-bind (ref . value) (clipboard-entry entry)
(list ref (to-line value 5))))
(defun clipboard-add (value)
(setf (clipboard-entries *clipboard*)
(append (clipboard-entries *clipboard*)
(list (cons (incf (clipboard-counter *clipboard*))
value)))))
(defun clipboard-ref (ref)
(let ((tail (member ref (clipboard-entries *clipboard*) :key #'car)))
(cond (tail (cdr (car tail)))
(t (error "Invalid clipboard ref: ~s" ref)))))
(defun clipboard-entry (entry)
(elt (clipboard-entries *clipboard*) entry))
(defun clipboard-delete-entry (index)
(let* ((list (clipboard-entries *clipboard*))
(tail (nthcdr index list)))
(setf (clipboard-entries *clipboard*)
(append (ldiff list tail) (cdr tail)))))
(defun entry-to-string (entry)
(destructuring-bind (ref . value) (clipboard-entry entry)
(format nil "#@~d(~a)" ref (to-line value))))
(defun to-line (object &optional (width 75))
(with-output-to-string (*standard-output*)
(write object :right-margin width :lines 1)))
(provide :swank-clipboard)

1006
elpa/slime-20180413.1720/contrib/swank-fancy-inspector.lisp Normal file
View File

File diff suppressed because it is too large Load Diff

706
elpa/slime-20180413.1720/contrib/swank-fuzzy.lisp Normal file
View File

@@ -0,0 +1,706 @@
;;; swank-fuzzy.lisp --- fuzzy symbol completion
;;
;; Authors: Brian Downing <bdowning@lavos.net>
;; Tobias C. Rittweiler <tcr@freebits.de>
;; and others
;;
;; License: Public Domain
;;
(in-package :swank)
(eval-when (:compile-toplevel :load-toplevel :execute)
(swank-require :swank-util)
(swank-require :swank-c-p-c))
(defvar *fuzzy-duplicate-symbol-filter* :nearest-package
"Specifies how fuzzy-matching handles \"duplicate\" symbols.
Possible values are :NEAREST-PACKAGE, :HOME-PACKAGE, :ALL, or a custom
function. See Fuzzy Completion in the manual for details.")
(export '*fuzzy-duplicate-symbol-filter*)
;;; For nomenclature of the fuzzy completion section, please read
;;; through the following docstring.
(defslimefun fuzzy-completions (string default-package-name
&key limit time-limit-in-msec)
"Returns a list of two values:
An (optionally limited to LIMIT best results) list of fuzzy
completions for a symbol designator STRING. The list will be
sorted by score, most likely match first.
A flag that indicates whether or not TIME-LIMIT-IN-MSEC has
been exhausted during computation. If that parameter's value is
NIL or 0, no time limit is assumed.
The main result is a list of completion objects, where a completion
object is:
(COMPLETED-STRING SCORE (&rest CHUNKS) CLASSIFICATION-STRING)
where a CHUNK is a description of a matched substring:
(OFFSET SUBSTRING)
and FLAGS is short string describing properties of the symbol (see
SYMBOL-CLASSIFICATION-STRING).
E.g., completing \"mvb\" in a package that uses COMMON-LISP would
return something like:
((\"multiple-value-bind\" 26.588236 ((0 \"m\") (9 \"v\") (15 \"b\"))
(:FBOUNDP :MACRO))
...)
If STRING is package qualified the result list will also be
qualified. If string is non-qualified the result strings are
also not qualified and are considered relative to
DEFAULT-PACKAGE-NAME.
Which symbols are candidates for matching depends on the symbol
designator's format. The cases are as follows:
FOO - Symbols accessible in the buffer package.
PKG:FOO - Symbols external in package PKG.
PKG::FOO - Symbols accessible in package PKG."
;; For Emacs we allow both NIL and 0 as value of TIME-LIMIT-IN-MSEC
;; to denote an infinite time limit. Internally, we only use NIL for
;; that purpose, to be able to distinguish between "no time limit
;; alltogether" and "current time limit already exhausted." So we've
;; got to canonicalize its value at first:
(let* ((no-time-limit-p (or (not time-limit-in-msec)
(zerop time-limit-in-msec)))
(time-limit (if no-time-limit-p nil time-limit-in-msec)))
(multiple-value-bind (completion-set interrupted-p)
(fuzzy-completion-set string default-package-name :limit limit
:time-limit-in-msec time-limit)
;; We may send this as elisp [] arrays to spare a coerce here,
;; but then the network serialization were slower by handling arrays.
;; Instead we limit the number of completions that is transferred
;; (the limit is set from Emacs.)
(list (coerce completion-set 'list) interrupted-p))))
;;; A Fuzzy Matching -- Not to be confused with a fuzzy completion
;;; object that will be sent back to Emacs, as described above.
(defstruct (fuzzy-matching (:conc-name fuzzy-matching.)
(:predicate fuzzy-matching-p)
(:constructor make-fuzzy-matching
(symbol package-name score package-chunks
symbol-chunks &key (symbol-p t))))
symbol ; The symbol that has been found to match.
symbol-p ; To deffirentiate between completeing
; package: and package:nil
package-name ; The name of the package where SYMBOL was found in.
; (This is not necessarily the same as the home-package
; of SYMBOL, because the SYMBOL can be internal to
; lots of packages; also think of package nicknames.)
score ; The higher the better SYMBOL is a match.
package-chunks ; Chunks pertaining to the package identifier of SYMBOL.
symbol-chunks) ; Chunks pertaining to SYMBOL's name.
(defun %fuzzy-extract-matching-info (fuzzy-matching user-input-string)
(multiple-value-bind (_ user-package-name __ input-internal-p)
(parse-completion-arguments user-input-string nil)
(declare (ignore _ __))
(with-struct (fuzzy-matching. score symbol package-name package-chunks
symbol-chunks symbol-p)
fuzzy-matching
(let (symbol-name real-package-name internal-p)
(cond (symbol-p ; symbol fuzzy matching?
(setf symbol-name (symbol-name symbol))
(setf internal-p input-internal-p)
(setf real-package-name (cond ((keywordp symbol) "")
((not user-package-name) nil)
(t package-name))))
(t ; package fuzzy matching?
(setf symbol-name "")
(setf real-package-name package-name)
;; If no explicit package name was given by the user
;; (e.g. input was "asdf"), we want to append only
;; one colon ":" to the package names.
(setf internal-p (if user-package-name input-internal-p nil))))
(values symbol-name
real-package-name
(if user-package-name internal-p nil)
(completion-output-symbol-converter user-input-string)
(completion-output-package-converter user-input-string))))))
(defun fuzzy-format-matching (fuzzy-matching user-input-string)
"Returns the completion (\"foo:bar\") that's represented by FUZZY-MATCHING."
(multiple-value-bind (symbol-name package-name internal-p
symbol-converter package-converter)
(%fuzzy-extract-matching-info fuzzy-matching user-input-string)
(setq symbol-name (and symbol-name
(funcall symbol-converter symbol-name)))
(setq package-name (and package-name
(funcall package-converter package-name)))
(let ((result (untokenize-symbol package-name internal-p symbol-name)))
;; We return the length of the possibly added prefix as second value.
(values result (search symbol-name result)))))
(defun fuzzy-convert-matching-for-emacs (fuzzy-matching user-input-string)
"Converts a result from the fuzzy completion core into something
that emacs is expecting. Converts symbols to strings, fixes case
issues, and adds information (as a string) describing if the symbol is
bound, fbound, a class, a macro, a generic-function, a
special-operator, or a package."
(with-struct (fuzzy-matching. symbol score package-chunks symbol-chunks
symbol-p)
fuzzy-matching
(multiple-value-bind (name added-length)
(fuzzy-format-matching fuzzy-matching user-input-string)
(list name
(format nil "~,2f" score)
(append package-chunks
(mapcar (lambda (chunk)
;; Fix up chunk positions to account for possible
;; added package identifier.
(let ((offset (first chunk))
(string (second chunk)))
(list (+ added-length offset) string)))
symbol-chunks))
(if symbol-p
(symbol-classification-string symbol)
"-------p")))))
(defun fuzzy-completion-set (string default-package-name
&key limit time-limit-in-msec)
"Returns two values: an array of completion objects, sorted by
their score, that is how well they are a match for STRING
according to the fuzzy completion algorithm. If LIMIT is set,
only the top LIMIT results will be returned. Additionally, a flag
is returned that indicates whether or not TIME-LIMIT-IN-MSEC was
exhausted."
(check-type limit (or null (integer 0 #.(1- most-positive-fixnum))))
(check-type time-limit-in-msec
(or null (integer 0 #.(1- most-positive-fixnum))))
(multiple-value-bind (matchings interrupted-p)
(fuzzy-generate-matchings string default-package-name time-limit-in-msec)
(when (and limit
(> limit 0)
(< limit (length matchings)))
(if (array-has-fill-pointer-p matchings)
(setf (fill-pointer matchings) limit)
(setf matchings (make-array limit :displaced-to matchings))))
(map-into matchings #'(lambda (m)
(fuzzy-convert-matching-for-emacs m string))
matchings)
(values matchings interrupted-p)))
(defun fuzzy-generate-matchings (string default-package-name
time-limit-in-msec)
"Does all the hard work for FUZZY-COMPLETION-SET. If
TIME-LIMIT-IN-MSEC is NIL, an infinite time limit is assumed."
(multiple-value-bind (parsed-symbol-name parsed-package-name
package internal-p)
(parse-completion-arguments string default-package-name)
(flet ((fix-up (matchings parent-package-matching)
;; The components of each matching in MATCHINGS have been computed
;; relatively to PARENT-PACKAGE-MATCHING. Make them absolute.
(let* ((p parent-package-matching)
(p.name (fuzzy-matching.package-name p))
(p.score (fuzzy-matching.score p))
(p.chunks (fuzzy-matching.package-chunks p)))
(map-into
matchings
(lambda (m)
(let ((m.score (fuzzy-matching.score m)))
(setf (fuzzy-matching.package-name m) p.name)
(setf (fuzzy-matching.package-chunks m) p.chunks)
(setf (fuzzy-matching.score m)
(if (equal parsed-symbol-name "")
;; Make package matchings be sorted before all
;; the relative symbol matchings while preserving
;; over all orderness.
(/ p.score 100)
(+ p.score m.score)))
m))
matchings)))
(find-symbols (designator package time-limit &optional filter)
(fuzzy-find-matching-symbols designator package
:time-limit-in-msec time-limit
:external-only (not internal-p)
:filter (or filter #'identity)))
(find-packages (designator time-limit)
(fuzzy-find-matching-packages designator
:time-limit-in-msec time-limit))
(maybe-find-local-package (name)
(or (find-locally-nicknamed-package name *buffer-package*)
(find-package name))))
(let ((time-limit time-limit-in-msec) (symbols) (packages) (results)
(dedup-table (make-hash-table :test #'equal)))
(cond ((not parsed-package-name) ; E.g. STRING = "asd"
;; We don't know if user is searching for a package or a symbol
;; within his current package. So we try to find either.
(setf (values packages time-limit)
(find-packages parsed-symbol-name time-limit))
(setf (values symbols time-limit)
(find-symbols parsed-symbol-name package time-limit)))
((string= parsed-package-name "") ; E.g. STRING = ":" or ":foo"
(setf (values symbols time-limit)
(find-symbols parsed-symbol-name package time-limit)))
(t ; E.g. STRING = "asd:" or "asd:foo"
;; Find fuzzy matchings of the denoted package identifier part.
;; After that, find matchings for the denoted symbol identifier
;; relative to all the packages found.
(multiple-value-bind (symbol-packages rest-time-limit)
(find-packages parsed-package-name time-limit-in-msec)
;; We want to traverse the found packages in the order of
;; their score, since those with higher score presumably
;; represent better choices. (This is important because some
;; packages may never be looked at if time limit exhausts
;; during traversal.)
(setf symbol-packages
(sort symbol-packages #'fuzzy-matching-greaterp))
(loop
for package-matching across symbol-packages
for package = (maybe-find-local-package
(fuzzy-matching.package-name
package-matching))
while (or (not time-limit) (> rest-time-limit 0)) do
(multiple-value-bind (matchings remaining-time)
;; The duplication filter removes all those symbols
;; which are present in more than one package
;; match. See *FUZZY-DUPLICATE-SYMBOL-FILTER*
(find-symbols parsed-symbol-name package rest-time-limit
(%make-duplicate-symbols-filter
package-matching symbol-packages dedup-table))
(setf matchings (fix-up matchings package-matching))
(setf symbols (concatenate 'vector symbols matchings))
(setf rest-time-limit remaining-time)
(let ((guessed-sort-duration
(%guess-sort-duration (length symbols))))
(when (and rest-time-limit
(<= rest-time-limit guessed-sort-duration))
(decf rest-time-limit guessed-sort-duration)
(loop-finish))))
finally
(setf time-limit rest-time-limit)
(when (equal parsed-symbol-name "") ; E.g. STRING = "asd:"
(setf packages symbol-packages))))))
;; Sort by score; thing with equal score, sort alphabetically.
;; (Especially useful when PARSED-SYMBOL-NAME is empty, and all
;; possible completions are to be returned.)
(setf results (concatenate 'vector symbols packages))
(setf results (sort results #'fuzzy-matching-greaterp))
(values results (and time-limit (<= time-limit 0)))))))
(defun %guess-sort-duration (length)
;; These numbers are pretty much arbitrary, except that they're
;; vaguely correct on my machine with SBCL. Yes, this is an ugly
;; kludge, but it's better than before (where this didn't exist at
;; all, which essentially meant, that this was taken to be 0.)
(if (zerop length)
0
(let ((comparasions (* 3.8 (* length (log length 2)))))
(* 1000 (* comparasions (expt 10 -7)))))) ; msecs
(defun %make-duplicate-symbols-filter (current-package-matching fuzzy-package-matchings dedup-table)
;; Returns a filter function based on *FUZZY-DUPLICATE-SYMBOL-FILTER*.
(case *fuzzy-duplicate-symbol-filter*
(:home-package
;; Return a filter function that takes a symbol, and which returns T
;; if and only if /no/ matching in FUZZY-PACKAGE-MATCHINGS represents
;; the home-package of the symbol passed.
(let ((packages (mapcar #'(lambda (m)
(find-package (fuzzy-matching.package-name m)))
(remove current-package-matching
(coerce fuzzy-package-matchings 'list)))))
#'(lambda (symbol)
(not (member (symbol-package symbol) packages)))))
(:nearest-package
;; Keep only the first occurence of the symbol.
#'(lambda (symbol)
(unless (gethash (symbol-name symbol) dedup-table)
(setf (gethash (symbol-name symbol) dedup-table) t))))
(:all
;; No filter
#'identity)
(t
(typecase *fuzzy-duplicate-symbol-filter*
(function
;; Custom filter
(funcall *fuzzy-duplicate-symbol-filter*
(fuzzy-matching.package-name current-package-matching)
(map 'list #'fuzzy-matching.package-name fuzzy-package-matchings)
dedup-table))
(t
;; Bad filter value
(warn "bad *FUZZY-DUPLICATE-SYMBOL-FILTER* value: ~s"
*fuzzy-duplicate-symbol-filter*)
#'identity)))))
(defun fuzzy-matching-greaterp (m1 m2)
"Returns T if fuzzy-matching M1 should be sorted before M2.
Basically just the scores of the two matchings are compared, and
the match with higher score wins. For the case that the score is
equal, the one which comes alphabetically first wins."
(declare (type fuzzy-matching m1 m2))
(let ((score1 (fuzzy-matching.score m1))
(score2 (fuzzy-matching.score m2)))
(cond ((> score1 score2) t)
((< score1 score2) nil) ; total order
(t
(let ((name1 (symbol-name (fuzzy-matching.symbol m1)))
(name2 (symbol-name (fuzzy-matching.symbol m2))))
(string< name1 name2))))))
(declaim (ftype (function () (integer 0)) get-real-time-msecs))
(defun get-real-time-in-msecs ()
(let ((units-per-msec (max 1 (floor internal-time-units-per-second 1000))))
(values (floor (get-internal-real-time) units-per-msec))))
(defun fuzzy-find-matching-symbols
(string package &key (filter #'identity) external-only time-limit-in-msec)
"Returns two values: a vector of fuzzy matchings for matching
symbols in PACKAGE, using the fuzzy completion algorithm, and the
remaining time limit.
Only those symbols are considered of which FILTER does return T.
If EXTERNAL-ONLY is true, only external symbols are considered. A
TIME-LIMIT-IN-MSEC of NIL is considered no limit; if it's zero or
negative, perform a NOP."
(let ((time-limit-p (and time-limit-in-msec t))
(time-limit (or time-limit-in-msec 0))
(rtime-at-start (get-real-time-in-msecs))
(package-name (package-name package))
(count 0))
(declare (type boolean time-limit-p))
(declare (type integer time-limit rtime-at-start))
(declare (type (integer 0 #.(1- most-positive-fixnum)) count))
(flet ((recompute-remaining-time (old-remaining-time)
(cond ((not time-limit-p)
;; propagate NIL back as infinite time limit
(values nil nil))
((> count 0) ; ease up on getting internal time like crazy
(setf count (mod (1+ count) 128))
(values nil old-remaining-time))
(t (let* ((elapsed-time (- (get-real-time-in-msecs)
rtime-at-start))
(remaining (- time-limit elapsed-time)))
(values (<= remaining 0) remaining)))))
(perform-fuzzy-match (string symbol-name)
(let* ((converter (completion-output-symbol-converter string))
(converted-symbol-name (funcall converter symbol-name)))
(compute-highest-scoring-completion string
converted-symbol-name))))
(let ((completions (make-array 256 :adjustable t :fill-pointer 0))
(rest-time-limit time-limit))
(do-symbols* (symbol package)
(multiple-value-bind (exhausted? remaining-time)
(recompute-remaining-time rest-time-limit)
(setf rest-time-limit remaining-time)
(cond (exhausted? (return))
((not (and (or (not external-only)
(symbol-external-p symbol package))
(funcall filter symbol))))
((string= "" string) ; "" matches always
(vector-push-extend
(make-fuzzy-matching symbol package-name
0.0 '() '())
completions))
(t
(multiple-value-bind (match-result score)
(perform-fuzzy-match string (symbol-name symbol))
(when match-result
(vector-push-extend
(make-fuzzy-matching symbol package-name score
'() match-result)
completions)))))))
(values completions rest-time-limit)))))
(defun fuzzy-find-matching-packages (name &key time-limit-in-msec)
"Returns a vector of fuzzy matchings for each package that is
similiar to NAME, and the remaining time limit.
Cf. FUZZY-FIND-MATCHING-SYMBOLS."
(let ((time-limit-p (and time-limit-in-msec t))
(time-limit (or time-limit-in-msec 0))
(rtime-at-start (get-real-time-in-msecs))
(converter (completion-output-package-converter name))
(completions (make-array 32 :adjustable t :fill-pointer 0)))
(declare (type boolean time-limit-p))
(declare (type integer time-limit rtime-at-start))
(declare (type function converter))
(flet ((match-package (names)
(loop with max-pkg-name = ""
with max-result = nil
with max-score = 0
for package-name in names
for converted-name = (funcall converter package-name)
do
(multiple-value-bind (result score)
(compute-highest-scoring-completion name
converted-name)
(when (and result (> score max-score))
(setf max-pkg-name package-name)
(setf max-result result)
(setf max-score score)))
finally
(when max-result
(vector-push-extend
(make-fuzzy-matching nil max-pkg-name
max-score max-result '()
:symbol-p nil)
completions)))))
(cond ((and time-limit-p (<= time-limit 0))
(values #() time-limit))
(t
(loop for (nick) in (package-local-nicknames *buffer-package*)
do
(match-package (list nick)))
(loop for package in (list-all-packages)
do
;; Find best-matching package-nickname:
(match-package (package-names package))
finally
(return
(values completions
(and time-limit-p
(let ((elapsed-time (- (get-real-time-in-msecs)
rtime-at-start)))
(- time-limit elapsed-time)))))))))))
(defslimefun fuzzy-completion-selected (original-string completion)
"This function is called by Slime when a fuzzy completion is
selected by the user. It is for future expansion to make
testing, say, a machine learning algorithm for completion scoring
easier.
ORIGINAL-STRING is the string the user completed from, and
COMPLETION is the completion object (see docstring for
SWANK:FUZZY-COMPLETIONS) corresponding to the completion that the
user selected."
(declare (ignore original-string completion))
nil)
;;;;; Fuzzy completion core
(defparameter *fuzzy-recursion-soft-limit* 30
"This is a soft limit for recursion in
RECURSIVELY-COMPUTE-MOST-COMPLETIONS. Without this limit,
completing a string such as \"ZZZZZZ\" with a symbol named
\"ZZZZZZZZZZZZZZZZZZZZZZZ\" will result in explosive recursion to
find all the ways it can match.
Most natural language searches and symbols do not have this
problem -- this is only here as a safeguard.")
(declaim (fixnum *fuzzy-recursion-soft-limit*))
(defvar *all-chunks* '())
(declaim (type list *all-chunks*))
(defun compute-highest-scoring-completion (short full)
"Finds the highest scoring way to complete the abbreviation
SHORT onto the string FULL, using CHAR= as a equality function for
letters. Returns two values: The first being the completion
chunks of the highest scorer, and the second being the score."
(let* ((scored-results
(mapcar #'(lambda (result)
(cons (score-completion result short full) result))
(compute-most-completions short full)))
(winner (first (sort scored-results #'> :key #'first))))
(values (rest winner) (first winner))))
(defun compute-most-completions (short full)
"Finds most possible ways to complete FULL with the letters in SHORT.
Calls RECURSIVELY-COMPUTE-MOST-COMPLETIONS recursively. Returns
a list of (&rest CHUNKS), where each CHUNKS is a description of
how a completion matches."
(let ((*all-chunks* nil))
(recursively-compute-most-completions short full 0 0 nil nil nil t)
*all-chunks*))
(defun recursively-compute-most-completions
(short full
short-index initial-full-index
chunks current-chunk current-chunk-pos
recurse-p)
"Recursively (if RECURSE-P is true) find /most/ possible ways
to fuzzily map the letters in SHORT onto FULL, using CHAR= to
determine if two letters match.
A chunk is a list of elements that have matched consecutively.
When consecutive matches stop, it is coerced into a string,
paired with the starting position of the chunk, and pushed onto
CHUNKS.
Whenever a letter matches, if RECURSE-P is true,
RECURSIVELY-COMPUTE-MOST-COMPLETIONS calls itself with a position
one index ahead, to find other possibly higher scoring
possibilities. If there are less than
*FUZZY-RECURSION-SOFT-LIMIT* results in *ALL-CHUNKS* currently,
this call will also recurse.
Once a word has been completely matched, the chunks are pushed
onto the special variable *ALL-CHUNKS* and the function returns."
(declare (optimize speed)
(type fixnum short-index initial-full-index)
(type list current-chunk)
(simple-string short full))
(flet ((short-cur ()
"Returns the next letter from the abbreviation, or NIL
if all have been used."
(if (= short-index (length short))
nil
(aref short short-index)))
(add-to-chunk (char pos)
"Adds the CHAR at POS in FULL to the current chunk,
marking the start position if it is empty."
(unless current-chunk
(setf current-chunk-pos pos))
(push char current-chunk))
(collect-chunk ()
"Collects the current chunk to CHUNKS and prepares for
a new chunk."
(when current-chunk
(let ((current-chunk-as-string
(nreverse
(make-array (length current-chunk)
:element-type 'character
:initial-contents current-chunk))))
(push (list current-chunk-pos current-chunk-as-string) chunks)
(setf current-chunk nil
current-chunk-pos nil)))))
;; If there's an outstanding chunk coming in collect it. Since
;; we're recursively called on skipping an input character, the
;; chunk can't possibly continue on.
(when current-chunk (collect-chunk))
(do ((pos initial-full-index (1+ pos)))
((= pos (length full)))
(let ((cur-char (aref full pos)))
(if (and (short-cur)
(char= cur-char (short-cur)))
(progn
(when recurse-p
;; Try other possibilities, limiting insanely deep
;; recursion somewhat.
(recursively-compute-most-completions
short full short-index (1+ pos)
chunks current-chunk current-chunk-pos
(not (> (length *all-chunks*)
*fuzzy-recursion-soft-limit*))))
(incf short-index)
(add-to-chunk cur-char pos))
(collect-chunk))))
(collect-chunk)
;; If we've exhausted the short characters we have a match.
(if (short-cur)
nil
(let ((rev-chunks (reverse chunks)))
(push rev-chunks *all-chunks*)
rev-chunks))))
;;;;; Fuzzy completion scoring
(defvar *fuzzy-completion-symbol-prefixes* "*+-%&?<"
"Letters that are likely to be at the beginning of a symbol.
Letters found after one of these prefixes will be scored as if
they were at the beginning of ths symbol.")
(defvar *fuzzy-completion-symbol-suffixes* "*+->"
"Letters that are likely to be at the end of a symbol.
Letters found before one of these suffixes will be scored as if
they were at the end of the symbol.")
(defvar *fuzzy-completion-word-separators* "-/."
"Letters that separate different words in symbols. Letters
after one of these symbols will be scores more highly than other
letters.")
(defun score-completion (completion short full)
"Scores the completion chunks COMPLETION as a completion from
the abbreviation SHORT to the full string FULL. COMPLETION is a
list like:
((0 \"mul\") (9 \"v\") (15 \"b\"))
Which, if SHORT were \"mulvb\" and full were \"multiple-value-bind\",
would indicate that it completed as such (completed letters
capitalized):
MULtiple-Value-Bind
Letters are given scores based on their position in the string.
Letters at the beginning of a string or after a prefix letter at
the beginning of a string are scored highest. Letters after a
word separator such as #\- are scored next highest. Letters at
the end of a string or before a suffix letter at the end of a
string are scored medium, and letters anywhere else are scored
low.
If a letter is directly after another matched letter, and its
intrinsic value in that position is less than a percentage of the
previous letter's value, it will use that percentage instead.
Finally, a small scaling factor is applied to favor shorter
matches, all other things being equal."
(labels ((at-beginning-p (pos)
(= pos 0))
(after-prefix-p (pos)
(and (= pos 1)
(find (aref full 0) *fuzzy-completion-symbol-prefixes*)))
(word-separator-p (pos)
(find (aref full pos) *fuzzy-completion-word-separators*))
(after-word-separator-p (pos)
(find (aref full (1- pos)) *fuzzy-completion-word-separators*))
(at-end-p (pos)
(= pos (1- (length full))))
(before-suffix-p (pos)
(and (= pos (- (length full) 2))
(find (aref full (1- (length full)))
*fuzzy-completion-symbol-suffixes*)))
(score-or-percentage-of-previous (base-score pos chunk-pos)
(if (zerop chunk-pos)
base-score
(max base-score
(+ (* (score-char (1- pos) (1- chunk-pos)) 0.85)
(expt 1.2 chunk-pos)))))
(score-char (pos chunk-pos)
(score-or-percentage-of-previous
(cond ((at-beginning-p pos) 10)
((after-prefix-p pos) 10)
((word-separator-p pos) 1)
((after-word-separator-p pos) 8)
((at-end-p pos) 6)
((before-suffix-p pos) 6)
(t 1))
pos chunk-pos))
(score-chunk (chunk)
(loop for chunk-pos below (length (second chunk))
for pos from (first chunk)
summing (score-char pos chunk-pos))))
(let* ((chunk-scores (mapcar #'score-chunk completion))
(length-score (/ 10.0 (1+ (- (length full) (length short))))))
(values
(+ (reduce #'+ chunk-scores) length-score)
(list (mapcar #'list chunk-scores completion) length-score)))))
(defun highlight-completion (completion full)
"Given a chunk definition COMPLETION and the string FULL,
HIGHLIGHT-COMPLETION will create a string that demonstrates where
the completion matched in the string. Matches will be
capitalized, while the rest of the string will be lower-case."
(let ((highlit (nstring-downcase (copy-seq full))))
(dolist (chunk completion)
(setf highlit (nstring-upcase highlit
:start (first chunk)
:end (+ (first chunk)
(length (second chunk))))))
highlit))
(defun format-fuzzy-completion-set (winners)
"Given a list of completion objects such as on returned by
FUZZY-COMPLETION-SET, format the list into user-readable output
for interactive debugging purpose."
(let ((max-len
(loop for winner in winners maximizing (length (first winner)))))
(loop for (sym score result) in winners do
(format t "~&~VA score ~8,2F ~A"
max-len (highlight-completion result sym) score result))))
(provide :swank-fuzzy)

995
elpa/slime-20180413.1720/contrib/swank-goo.goo Normal file
View File

@@ -0,0 +1,995 @@
;;;; swank-goo.goo --- Swank server for GOO
;;;
;;; Copyright (C) 2005 Helmut Eller
;;;
;;; This file is licensed under the terms of the GNU General Public
;;; License as distributed with Emacs (press C-h C-c to view it).
;;;; Installation
;;
;; 1. Add something like this to your .emacs:
;;
;; (setq slime-lisp-implementations
;; '((goo ("g2c") :init goo-slime-init)))
;;
;; (defun goo-slime-init (file _)
;; (format "%S\n%S\n"
;; `(set goo/system:*module-search-path*
;; (cat '(".../slime/contrib/")
;; goo/system:*module-search-path*))
;; `(swank-goo:start-swank ,file)))
;;
;; 2. Start everything with M-- M-x slime goo
;;
;;;; Code
(use goo)
(use goo/boot)
(use goo/x)
(use goo/io/port)
(use goo/io/write)
(use goo/eval)
(use goo/system)
(use goo/conditions)
(use goo/fun)
(use goo/loc)
(use goo/chr)
(use eval/module)
(use eval/ast)
(use eval/g2c)
;;;; server setup
(df create-server (port-number) (setup-server port-number announce-port))
(df start-swank (port-file)
(setup-server 0 (fun (s) (write-port-file (%local-port s) port-file))))
(df setup-server (port-number announce)
(let ((s (create-socket port-number)))
(fin (seq
(announce s)
(let ((c (accept s)))
;;(post "connection: %s" c)
(fin (serve-requests c)
(%close (@fd c)))))
(post "closing socket: %s" s)
(%close s))))
(df announce-port (socket)
(post "Listening on port: %d\n" (%local-port socket)))
(df write-port-file (port-number filename)
(with-port (file (open <file-out-port> filename))
(msg file "%d\n" port-number)))
(dc <slime-toplevel> (<restart>))
(dc <connection> (<any>))
(dp @socket (<connection> => <port>))
(dp @in (<connection> => <in-port>))
(dp @out (<connection> => <out-port>))
(dv emacs-connection|(t? <connection>) #f)
(df serve-requests (socket)
(dlet ((emacs-connection (new <connection>
@socket socket
@out (new <slime-out-port> @socket socket)
@in (new <slime-in-port> @socket socket))))
(dlet ((out (@out emacs-connection))
(in (@in emacs-connection)))
(while #t
(simple-restart
<slime-toplevel> "SLIME top-level"
(fun () (process-next-event socket)))))))
(d. <nil> (t= 'nil))
(d. t #t)
(d. cons pair)
(dv tag-counter|<int> 0)
(df process-next-event (port) (dispatch-event (decode-message port) port))
(df dispatch-event (event port)
;; (post "%=\n" event)
(match event
((:emacs-rex ,form ,package ,_thread-id ,id)
(eval-for-emacs form package port id))
((:read-string ,_)
(def tag (incf tag-counter))
(encode-message `(:read-string ,_ ,tag) port)
(rep loop ()
(match (decode-message port)
((:emacs-return-string ,_ ,rtag ,str)
(assert (= tag rtag) "Unexpected reply tag: %d" rtag)
str)
((,@evt)
(try-recover
(fun () (dispatch-event evt port))
(fun () (encode-message `(:read-aborted ,_ ,tag) port)))
(loop)))))
((:emacs-return-string ,_ ,rtag ,str)
(error "Unexpected event: %=" event))
((,@_) (encode-message event port))))
(dc <eval-context> (<any>))
(dp @module (<eval-context> => <module>))
(dp @id (<eval-context> => <int>))
(dp @port (<eval-context> => <port>))
(dp @prev (<eval-context> => (t? <eval-context>)))
;; should be ddv
(dv eval-context|(t? <eval-context>) #f)
(df buffer-module () (@module eval-context))
(df eval-for-emacs (form|<lst> package|(t+ <str> <nil>) port id|<int>)
(try-recover
(fun ()
(try <condition> debugger-hook
(dlet ((eval-context (new <eval-context>
@module (find-buffer-module package) @id id
@port port @prev eval-context)))
(def result (eval (frob-form-for-eval form) 'swank-goo))
(force-out out)
(dispatch-event `(:return (:ok ,result) ,id) port))))
(fun () (dispatch-event `(:return (:abort) ,id) port))))
(dm find-buffer-module (name|<str> => <module>)
(or (elt-or (all-modules) (as-sym name) #f)
(find-buffer-module 'nil)))
(dm find-buffer-module (name|<nil> => <module>) default-module)
(dv default-module|<module> (runtime-module 'goo/user))
(d. slimefuns (fab <tab> 100))
(ds defslimefun (,name ,args ,@body)
`(set (elt slimefuns ',name)
(df ,(cat-sym 'swank@ name) ,args ,@body)))
(df slimefun (name)
(or (elt-or slimefuns name #f)
(error "Undefined slimefun: %=" name)))
;; rewrite (swank:foo ...) to ((slimefun 'foo) ...)
(df frob-form-for-eval (form)
(match form
((,op ,@args)
(match (map as-sym (split (sym-name op) #\:))
((swank ,name)
`((slimefun ',name) ,@args))))))
;;;; debugger
(dc <sldb-context> (<any>))
(dp @level (<sldb-context> => <int>))
(dp @top-frame (<sldb-context> => <lst>))
(dp @restarts (<sldb-context> => <lst>))
(dp @condition (<sldb-context> => <condition>))
(dp @eval-context (<sldb-context> => (t? <eval-context>)))
(dv sldb-context|(t? <sldb-context>) #f)
(df debugger-hook (c|<condition> resume)
(let ((tf (find-top-frame 'debugger-hook 2))
(rs (compute-restarts c))
(l (if sldb-context (1+ (@level sldb-context)) 1)))
(cond ((> l 10) (emergency-abort c))
(#t
(dlet ((sldb-context (new <sldb-context>
@level l @top-frame tf
@restarts rs @condition c
@eval-context eval-context)))
(let ((bt (compute-backtrace tf 0 10)))
(force-out out)
(dispatch-event `(:debug 0 ,l
,@(debugger-info c rs bt eval-context))
(@port eval-context))
(sldb-loop l (@port eval-context))))))))
(df emergency-abort (c)
(post "Maximum debug level reached aborting...\n")
(post "%s\n" (describe-condition c))
(do-stack-frames (fun (f args) (msg out " %= %=\n" f args)))
(invoke-handler-interactively (find-restart <slime-toplevel>) in out))
(df sldb-loop (level port)
(fin (while #t
(dispatch-event `(:debug-activate 0 ,level) port)
(simple-restart
<restart> (msg-to-str "Return to SLDB level %s" level)
(fun () (process-next-event port))))
(dispatch-event `(:debug-return 0 ,level nil) port)))
(defslimefun backtrace (start|<int> end|(t+ <int> <nil>))
(backtrace-for-emacs
(compute-backtrace (@top-frame sldb-context)
start
(if (isa? end <int>) end #f))))
(defslimefun throw-to-toplevel ()
(invoke-handler-interactively (find-restart <slime-toplevel>) in out))
(defslimefun invoke-nth-restart-for-emacs (sldb-level|<int> n|<int>)
(when (= (@level sldb-context) sldb-level)
(invoke-handler-interactively (elt (@restarts sldb-context) n) in out)))
(defslimefun debugger-info-for-emacs (start end)
(debugger-info (@condition sldb-context)
(@restarts sldb-context)
(compute-backtrace (@top-frame sldb-context)
start
(if (isa? end <int>) end #f))))
(defslimefun frame-locals-and-catch-tags (frame-idx)
(def frame (nth-frame frame-idx))
(list
(map-keyed (fun (i name)
(lst ':name (sym-name name) ':id 0
':value (safe-write-to-string (frame-var-value frame i))))
(frame-var-names frame))
'()))
(defslimefun inspect-frame-var (frame-idx var-idx)
(reset-inspector)
(inspect-object (frame-var-value (nth-frame frame-idx) var-idx)))
(defslimefun inspect-current-condition ()
(reset-inspector)
(inspect-object (@condition sldb-context)))
(defslimefun frame-source-location (frame-idx)
(match (nth-frame frame-idx)
((,f ,@_)
(or (emacs-src-loc f)
`(:error ,(msg-to-str "No src-loc available for: %s" f))))))
(defslimefun eval-string-in-frame (string frame-idx)
(def frame (nth-frame frame-idx))
(let ((names (frame-var-names frame))
(values (frame-var-values frame)))
(write-to-string
(app (eval `(fun ,names ,(read-from-string string))
(module-name (buffer-module)))
values))))
(df debugger-info (condition restarts backtrace eval-context)
(lst `(,(try-or (fun () (describe-condition condition)) "<...>")
,(cat " [class: " (class-name-str condition) "]")
())
(restarts-for-emacs restarts)
(backtrace-for-emacs backtrace)
(pending-continuations eval-context)))
(df backtrace-for-emacs (backtrace)
(map (fun (f)
(match f
((,idx (,f ,@args))
(lst idx (cat (if (fun-name f)
(sym-name (fun-name f))
(safe-write-to-string f))
(safe-write-to-string args))))))
backtrace))
(df restarts-for-emacs (restarts)
(map (fun (x) `(,(sym-name (class-name (%handler-condition-type x)))
,(describe-restart x)))
restarts))
(df describe-restart (restart)
(describe-handler (%handler-info restart) (%handler-condition-type restart)))
(df compute-restarts (condition)
(packing (%do-handlers-of-type <restart> (fun (c) (pack c)))))
(df find-restart (type)
(esc ret
(%do-handlers-of-type type ret)
#f))
(df pending-continuations (context|(t? <eval-context>))
(if context
(pair (@id context) (pending-continuations (@prev context)))
'()))
(df find-top-frame (fname|<sym> offset|<int>)
(esc ret
(let ((top-seen? #f))
(do-stack-frames (fun (f args)
(cond (top-seen?
(cond ((== offset 0)
(ret (pair f args)))
(#t (decf offset))))
((== (fun-name f) fname)
(set top-seen? #t))))))))
(df compute-backtrace (top-frame start|<int> end)
(packing
(esc break
(do-user-frames (fun (idx f args)
(when (and end (<= end idx))
(break #f))
(when (<= start idx)
(pack (lst idx (pair f args)))))
top-frame))))
(df nth-frame (n|<int>)
(esc ret
(do-user-frames
(fun (idx f args)
(when (= idx n)
(ret (pair f args))))
(@top-frame sldb-context))))
(df frame-var-value (frame var-idx)
(match frame
((,f ,@args)
(def sig (fun-sig f))
(def arity (sig-arity sig))
(def nary? (sig-nary? sig))
(cond ((< var-idx arity) (elt args var-idx))
(nary? (sub* args arity))))))
(df frame-var-names (frame)
(match frame
((,f ,@_) (fun-info-names (fun-info f)))))
(df frame-var-values (frame)
(map (curry frame-var-value frame) (keys (frame-var-names frame))))
(df do-user-frames (f|<fun> top-frame)
(let ((idx -1)
(top-seen? #f))
(do-stack-frames
(fun (ffun args)
(cond (top-seen?
(incf idx)
(f idx ffun (rev args)))
((= (pair ffun args) top-frame)
(set top-seen? #t)))))))
;;;; Write some classes a little less verbose
;; (dm recurring-write (port|<out-port> x d|<int> recur|<fun>)
;; (msg port "#{%s &%s}" (class-name-str x)
;; (num-to-str-base (address-of x) 16)))
(dm recurring-write (port|<out-port> x|<module> d|<int> recur|<fun>)
(msg port "#{%s %s}" (class-name-str x) (module-name x)))
(dm recurring-write (port|<out-port> x|<module-binding> d|<int> recur|<fun>)
(msg port "#{%s %s}" (class-name-str x) (binding-name x)))
(dm recurring-write (port|<out-port> x|<tab> d|<int> recur|<fun>)
(msg port "#{%s %s}" (class-name-str x) (len x)))
(dm recurring-write (port|<out-port> x|<static-global-environment>
d|<int> recur|<fun>)
(msg port "#{%s}" (class-name-str x)))
(dm recurring-write (port|<out-port> x|<regular-application>
d|<int> recur|<fun>)
(msg port "#{%s}" (class-name-str x)))
(dm recurring-write (port|<out-port> x|<src-loc> d|<int> recur|<fun>)
(msg port "#{%s %s:%=}" (class-name-str x)
(src-loc-file x) (src-loc-line x)))
;;;; Inspector
(dc <inspector> (<any>))
(dp! @object (<inspector> => <any>))
(dp! @parts (<inspector> => <vec>) (new <vec>))
(dp! @stack (<inspector> => <lst>) '())
(dv inspector #f)
(defslimefun init-inspector (form|<str>)
(reset-inspector)
(inspect-object (str-eval form (buffer-module))))
(defslimefun quit-inspector () (reset-inspector) 'nil)
(defslimefun inspect-nth-part (n|<int>)
(inspect-object (elt (@parts inspector) n)))
(defslimefun inspector-pop ()
(cond ((<= 2 (len (@stack inspector)))
(popf (@stack inspector))
(inspect-object (popf (@stack inspector))))
(#t 'nil)))
(df reset-inspector () (set inspector (new <inspector>)))
(df inspect-object (o)
(set (@object inspector) o)
(set (@parts inspector) (new <vec>))
(pushf (@stack inspector) o)
(lst ':title (safe-write-to-string o) ; ':type (class-name-str o)
':content (inspector-content
`("class: " (:value ,(class-of o)) "\n"
,@(inspect o)))))
(df inspector-content (content)
(map (fun (part)
(case-by part isa?
((<str>) part)
((<lst>)
(match part
((:value ,o ,@str)
`(:value ,@(if (nul? str)
(lst (safe-write-to-string o))
str)
,(assign-index o)))))
(#t (error "Bad inspector content: %=" part))))
content))
(df assign-index (o)
(pushf (@parts inspector) o)
(1- (len (@parts inspector))))
(dg inspect (o))
;; a list of dangerous functions
(d. getter-blacklist (lst fun-code fun-env class-row))
(dm inspect (o)
(join (map (fun (p)
(let ((getter (prop-getter p)))
`(,(sym-name (fun-name getter)) ": "
,(cond ((mem? getter-blacklist getter) "<...>")
((not (prop-bound? o getter)) "<unbound>")
(#t (try-or (fun () `(:value ,(getter o)))
"<...>"))))))
(class-props (class-of o)))
'("\n")))
(dm inspect (o|<seq>)
(join (packing (do-keyed (fun (pos val)
(pack `(,(num-to-str pos) ": " (:value ,val))))
o))
'("\n")))
(dm inspect (o|<tab>)
(join (packing (do-keyed (fun (key val)
(pack `((:value ,key) "\t: " (:value ,val))))
o))
'("\n")))
;; inspecting the env of closures is broken
;; (dm inspect (o|<met>)
;; (cat (sup o)
;; '("\n")
;; (if (%fun-env? o)
;; (inspect (packing (for ((i (below (%fun-env-len o))))
;; (pack (%fun-env-elt o i)))))
;; '())))
;;
;; (df %fun-env? (f|<met> => <log>) #eb{ FUNENV($f) != $#f })
;; (df %fun-env-len (f|<met> => <int>) #ei{ ((ENV)FUNENV ($f))->size })
;; (df %fun-env-elt (f|<met> i|<int> => <any>) #eg{ FUNENVGET($f, @i) })
;;;; init
(defslimefun connection-info ()
`(:pid
,(process-id) :style nil
:lisp-implementation (:type "GOO" :name "goo"
:version ,(%lookup '*goo-version* 'eval/main))
:machine (:instance "" :type "" :version "")
:features ()
:package (:name "goo/user" :prompt "goo/user")))
(defslimefun quit-lisp () #ei{ exit (0),0 })
(defslimefun set-default-directory (dir|<str>) #ei{ chdir(@dir) } dir)
;;;; eval
(defslimefun ping () "PONG")
(defslimefun create-repl (_)
(let ((name (sym-name (module-name (buffer-module)))))
`(,name ,name)))
(defslimefun listener-eval (string)
(clear-input in)
`(:values ,(write-to-string (str-eval string (buffer-module)))))
(defslimefun interactive-eval (string)
(cat "=> " (write-to-string (str-eval string (buffer-module)))))
(df str-eval (s|<str> m|<module>)
(eval (read-from-string s) (module-name m)))
(df clear-input (in|<in-port>) (while (ready? in) (get in)))
(dc <break> (<restart>))
(defslimefun simple-break ()
(simple-restart
<break> "Continue from break"
(fun () (sig (new <simple-condition>
condition-message "Interrupt from Emacs"))))
'nil)
(defslimefun clear-repl-results () 'nil)
;;;; compile
(defslimefun compile-string-for-emacs (string buffer position directory)
(def start (current-time))
(def r (g2c-eval (read-from-string string)
(module-target-environment (buffer-module))))
(lst (write-to-string r)
(/ (as <flo> (- (current-time) start)) 1000000.0)))
(defslimefun compiler-notes-for-emacs () 'nil)
(defslimefun filename-to-modulename (filename|<str> => (t+ <str> <nil>))
(try-or (fun () (sym-name (filename-to-modulename filename))) 'nil))
(df filename-to-modulename (filename|<str> => <sym>)
(def paths (map pathname-to-components
(map simplify-filename
(pick file-exists? *module-search-path*))))
(def filename (pathname-to-components filename))
(def moddir (rep parent ((modpath filename))
(cond ((any? (curry = modpath) paths)
modpath)
(#t
(parent (components-parent-directory modpath))))))
(def modfile (components-to-pathname (sub* filename (len moddir))))
(as-sym (sub modfile 0 (- (len modfile) (len *goo-extension*)))))
;;;; Load
(defslimefun load-file (filename)
(let ((file (cond ((= (sub (rev filename) 0 4) "oog.") filename)
(#t (cat filename ".goo")))))
(safe-write-to-string (load-file file (filename-to-modulename file)))))
;;;; background activities
(defslimefun operator-arglist (op _)
(try-or (fun ()
(let ((value (str-eval op (buffer-module))))
(if (isa? value <fun>)
(write-to-string value)
'nil)))
'nil))
;;;; M-.
(defslimefun find-definitions-for-emacs (name|<str>)
(match (parse-symbol name)
((,sym ,modname)
(def env (module-target-environment (runtime-module modname)))
(def b (find-binding sym env))
(cond (b (find-binding-definitions b))
(#t 'nil)))))
(df parse-symbol (name|<str> => <lst>)
(if (mem? name #\:)
(match (split name #\:)
((,module ,name) (lst (as-sym name) (as-sym module))))
(lst (as-sym name) (module-name (buffer-module)))))
(df find-binding-definitions (b|<binding>)
(def value (case (binding-kind b)
(('runtime) (loc-val (binding-locative b)))
(('global) (let ((box (binding-global-box b)))
(and box (global-box-value box))))
(('macro) (binding-info b))
(#t (error "unknown binding kind %=" (binding-kind b)))))
(map (fun (o)
(def loc (emacs-src-loc o))
`(,(write-to-string (dspec o))
,(or loc `(:error "no src-loc available"))))
(defining-objects value)))
(dm defining-objects (o => <lst>) '())
(dm defining-objects (o|<fun> => <lst>) (lst o))
(dm defining-objects (o|<gen> => <lst>) (pair o (fun-mets o)))
(dm emacs-src-loc (o|<fun>)
(def loc (fun-src-loc o))
(and loc `(:location (:file ,(simplify-filename
(find-goo-file-in-path
(module-name-to-relpath (src-loc-file loc))
*module-search-path*)))
(:line ,(src-loc-line loc))
())))
(dm dspec (f|<fun>)
(cond ((fun-name f)
`(,(if (isa? f <gen>) 'dg 'dm) ,(fun-name f) ,@(dspec-arglist f)))
(#t f)))
(df dspec-arglist (f|<fun>)
(map2 (fun (name class)
(cond ((= class <any>) name)
((isa? class <class>)
`(,name ,(class-name class)))
(#t `(,name ,class))))
(fun-info-names (fun-info f))
(sig-specs (fun-sig f))))
(defslimefun buffer-first-change (filename) 'nil)
;;;; apropos
(defslimefun apropos-list-for-emacs
(pattern only-external? case-sensitive? package)
(def matches (fab <tab> 100))
(do-all-bindings
(fun (b)
(when (finds (binding-name-str b) pattern)
(set (elt matches
(cat-sym (binding-name b)
(module-name (binding-module b))))
b))))
(set matches (sort-by (packing-as <vec> (for ((b matches)) (pack b)))
(fun (x y)
(< (binding-name x)
(binding-name y)))))
(map (fun (b)
`(:designator
,(cat (sym-name (module-name (binding-module b))) ":"
(binding-name-str b)
"\tkind: " (sym-name (binding-kind b)))))
(as <lst> matches)))
(df do-all-bindings (f|<fun>)
(for ((module (%module-loader-modules (runtime-module-loader))))
(do f (environment-bindings (module-target-environment module)))))
(dm < (s1|<str> s2|<str> => <log>)
(let ((l1 (len s1)) (l2 (len s2)))
(rep loop ((i 0))
(cond ((= i l1) (~= l1 l2))
((= i l2) #f)
((< (elt s1 i) (elt s2 i)) #t)
((= (elt s1 i) (elt s2 i)) (loop (1+ i)))
(#t #f)))))
(df %binding-info (name|<sym> module|<sym>)
(binding-info
(find-binding
name (module-target-environment (runtime-module module)))))
;;;; completion
(defslimefun simple-completions (pattern|<str> package)
(def matches (lst))
(for ((b (environment-bindings (module-target-environment (buffer-module)))))
(when (prefix? (binding-name-str b) pattern)
(pushf matches b)))
(def strings (map binding-name-str matches))
`(,strings ,(cond ((nul? strings) pattern)
(#t (fold+ common-prefix strings)))))
(df common-prefix (s1|<seq> s2|<seq>)
(let ((limit (min (len s1) (len s2))))
(rep loop ((i 0))
(cond ((or (= i limit)
(~= (elt s1 i) (elt s2 i)))
(sub s1 0 i))
(#t (loop (1+ i)))))))
(defslimefun list-all-package-names (_|...)
(map sym-name (keys (all-modules))))
(df all-modules () (%module-loader-modules (runtime-module-loader)))
;;;; Macroexpand
(defslimefun swank-macroexpand-1 (str|<str>)
(write-to-string
(%ast-macro-expand (read-from-string str)
(module-target-environment (buffer-module))
#f)))
;;;; streams
(dc <slime-out-port> (<out-port>))
(dp @socket (<slime-out-port> => <port>))
(dp! @buf-len (<slime-out-port> => <int>) 0)
(dp @buf (<slime-out-port> => <vec>) (new <vec>))
(dp! @timestamp (<slime-out-port> => <int>) 0)
(dm recurring-write (port|<out-port> x|<slime-out-port> d|<int> recur|<fun>)
(msg port "#{%s buf-len: %s}" (class-name-str x) (@buf-len x)))
(dm put (p|<slime-out-port> c|<chr>)
(add! (@buf p) c)
(incf (@buf-len p))
(maybe-flush p (= c #\newline)))
(dm puts (p|<slime-out-port> s|<str>)
(add! (@buf p) s)
(incf (@buf-len p) (len s))
(maybe-flush p (mem? s #\newline)))
(df maybe-flush (p|<slime-out-port> newline?|<log>)
(and (or (> (@buf-len p) 4000) newline?)
(> (- (current-time) (@timestamp p)) 100000)
(force-out p)))
(dm force-out (p|<slime-out-port>)
(unless (zero? (@buf-len p))
(dispatch-event `(:write-string ,(%buf-to-str (@buf p))) (@socket p))
(set (@buf-len p) 0)
(zap! (@buf p)))
(set (@timestamp p) (current-time)))
(df %buf-to-str (buf|<vec>)
(packing-as <str>
(for ((i buf))
(cond ((isa? i <str>) (for ((c i)) (pack c)))
(#t (pack i))))))
(dc <slime-in-port> (<in-port>))
(dp @socket (<slime-in-port> => <port>))
(dp! @idx (<slime-in-port> => <int>) 0)
(dp! @buf (<slime-in-port> => <str>) "")
(df receive-input (p|<slime-in-port>)
(dispatch-event `(:read-string ,0) (@socket p)))
(dm get (p|<slime-in-port> => <chr>)
(cond ((< (@idx p) (len (@buf p)))
(def c (elt (@buf p) (@idx p)))
(incf (@idx p))
c)
(#t
(def input (receive-input p))
(cond ((zero? (len input)) (eof-object))
(#t (set (@buf p) input)
(set (@idx p) 0)
(get p))))))
(dm ready? (p|<slime-in-port> => <log>) (< (@idx p) (len (@buf p))))
(dm peek (p|<slime-in-port> => <chr>)
(let ((c (get p)))
(unless (eof-object? c)
(decf (@idx p)))
c))
;;;; Message encoding
(df decode-message (port|<in-port>)
(read-from-string (get-block port (read-message-length port))))
(df read-message-length (port)
(or (str-to-num (cat "#x" (get-block port 6)))
(error "can't parse message length")))
(df encode-message (message port)
(let ((string (dlet ((*max-print-length* 1000000)
(*max-print-depth* 1000000))
(write-to-string message))))
(puts port (encode-message-length (len string)))
(puts port string)
(force-out port)))
(df encode-message-length (n)
(loc ((hex (byte)
(if (< byte #x10)
(cat "0" (num-to-str-base byte 16))
(num-to-str-base byte 16)))
(byte (i) (hex (& (>> n (* i 8)) 255))))
(cat (byte 2) (byte 1) (byte 0))))
;;;; semi general utilities
;; Return the name of O's class as string.
(df class-name-str (o => <str>) (sym-name (class-name (class-of o))))
(df binding-name-str (b|<binding> => <str>) (sym-name (binding-name b)))
(df as-sym (str|<str>) (as <sym> str))
;; Replace '//' in the middle of a filename with with a '/'
(df simplify-filename (str|<str> => <str>)
(match (pathname-to-components str)
((,hd ,@tl)
(components-to-pathname (cons hd (del-vals tl 'root))))))
;; Execute BODY and only if BODY exits abnormally execute RECOVER.
(df try-recover (body recover)
(let ((ok #f))
(fin (let ((val (body)))
(set ok #t)
val)
(unless ok
(recover)))))
;; like CL's IGNORE-ERRORS but return VALUE in case of an error.
(df try-or (body|<fun> value)
(esc ret
(try <error> (fun (condition resume) (ret value))
(body))))
(df simple-restart (type msg body)
(esc restart
(try ((type type) (description msg))
(fun (c r) (restart #f))
(body))))
(df safe-write-to-string (o)
(esc ret
(try <error> (fun (c r)
(ret (cat "#<error during write " (class-name-str o) ">")))
(write-to-string o))))
;; Read a string of length COUNT.
(df get-block (port|<in-port> count|<int> => <str>)
(packing-as <str>
(for ((i (below count)))
(let ((c (get port)))
(cond ((eof-object? c)
(error "Premature EOF (read %d of %d)" i count))
(#t (pack c)))))))
;;;; import some internal bindings
(df %lookup (name|<sym> module|<sym>)
(loc-val
(binding-locative
(find-binding
name (module-target-environment (runtime-module module))))))
(d. %handler-info (%lookup 'handler-info 'goo/conditions))
(d. %handler-condition-type (%lookup 'handler-condition-type 'goo/conditions))
(d. %do-handlers-of-type (%lookup 'do-handlers-of-type 'goo/conditions))
(d. %module-loader-modules (%lookup 'module-loader-modules 'eval/module))
(d. %ast-macro-expand (%lookup 'ast-macro-expand 'eval/ast))
;;;; low level socket stuff
;;; this shouldn't be here
#{
#include <sys/types.h>
#include <sys/socket.h>
#include <netinet/in.h>
#include <errno.h>
#include <string.h>
#include <stdlib.h>
#include <sys/time.h>
/* convert a goo number to a C long */
static long g2i (P o) { return untag (o); }
static int
set_reuse_address (int socket, int value) {
return setsockopt (socket, SOL_SOCKET, SO_REUSEADDR, &value, sizeof value);
}
static int
bind_socket (int socket, int port) {
struct sockaddr_in addr;
addr.sin_family = AF_INET;
addr.sin_port = htons (port);
addr.sin_addr.s_addr = htonl (INADDR_ANY);
return bind (socket, (struct sockaddr *)&addr, sizeof addr);
}
static int
local_port (int socket) {
struct sockaddr_in addr;
socklen_t len = sizeof addr;
int code = getsockname (socket, (struct sockaddr *)&addr, &len);
return (code == -1) ? -1 : ntohs (addr.sin_port);
}
static int
c_accept (int socket) {
struct sockaddr_in addr;
socklen_t len = sizeof addr;
return accept (socket, (struct sockaddr *)&addr, &len);
}
static P tup3 (P e0, P e1, P e2) {
P tup = YPPtfab ((P)3, YPfalse);
YPtelt_setter (e0, tup, (P)0);
YPtelt_setter (e1, tup, (P)1);
YPtelt_setter (e2, tup, (P)2);
return tup;
}
static P
current_time (void) {
struct timeval timeval;
int code = gettimeofday (&timeval, NULL);
if (code == 0) {
return tup3 (YPib ((P)(timeval.tv_sec >> 24)),
YPib ((P)(timeval.tv_sec & 0xffffff)),
YPib ((P)(timeval.tv_usec)));
} else return YPib ((P)errno);
}
}
;; Return the current time in microsecs
(df current-time (=> <int>)
(def t #eg{ current_time () })
(cond ((isa? t <int>) (error "%s" (strerror t)))
(#t (+ (* (+ (<< (1st t) 24)
(2nd t))
1000000)
(3rd t)))))
(dm strerror (e|<int> => <str>) #es{ strerror (g2i ($e)) })
(dm strerror (e|(t= #f) => <str>) #es{ strerror (errno) })
(df checkr (value|<int>)
(cond ((~== value -1) value)
(#t (error "%s" (strerror #f)))))
(df create-socket (port|<int> => <int>)
(let ((socket (checkr #ei{ socket (PF_INET, SOCK_STREAM, 0) })))
(checkr #ei{ set_reuse_address (g2i ($socket), 1) })
(checkr #ei{ bind_socket (g2i ($socket), g2i ($port)) })
(checkr #ei{ listen (g2i ($socket), 1)})
socket))
(df %local-port (fd|<int>) (checkr #ei{ local_port (g2i ($fd)) }))
(df %close (fd|<int>) (checkr #ei{ close (g2i ($fd)) }))
(dc <fd-io-port> (<in-port> <out-port>))
(dp @fd (<fd-io-port> => <int>))
(dp @in (<fd-io-port> => <file-in-port>))
(dp @out (<fd-io-port> => <file-out-port>))
(dm recurring-write (port|<out-port> x|<fd-io-port> d|<int> recur|<fun>)
(msg port "#{%s fd: %s}" (class-name-str x) (@fd x)))
(dm get (port|<fd-io-port> => <chr>) (get (@in port)))
(dm puts (port|<fd-io-port> s|<str>) (puts (@out port) s))
(dm force-out (port|<fd-io-port>) (force-out (@out port)))
(dm fdopen (fd|<int> type|(t= <fd-io-port>) => <fd-io-port>)
(new <fd-io-port> @fd fd
@in (new <file-in-port> port-handle (%fdopen fd "r"))
@out (new <file-out-port> port-handle (%fdopen fd "w"))))
(df %fdopen (fd|<int> mode|<str> => <loc>)
(def addr #ei{ fdopen (g2i ($fd), @mode) })
(when (zero? addr)
(error "fdopen failed: %s" (strerror #f)))
(%lb (%iu addr)))
(df accept (socket|<int> => <fd-io-port>)
(fdopen (checkr #ei{ c_accept (g2i ($socket)) }) <fd-io-port>))
(export
start-swank
create-server)
;;; swank-goo.goo ends here

18
elpa/slime-20180413.1720/contrib/swank-hyperdoc.lisp Normal file
View File

@@ -0,0 +1,18 @@
(in-package :swank)
(defslimefun hyperdoc (string)
(let ((hyperdoc-package (find-package :hyperdoc)))
(when hyperdoc-package
(multiple-value-bind (symbol foundp symbol-name package)
(parse-symbol string *buffer-package*)
(declare (ignore symbol))
(when foundp
(funcall (find-symbol (string :lookup) hyperdoc-package)
(package-name (if (member package (cons *buffer-package*
(package-use-list
*buffer-package*)))
*buffer-package*
package))
symbol-name))))))
(provide :swank-hyperdoc)

86
elpa/slime-20180413.1720/contrib/swank-ikarus.ss Normal file
View File

@@ -0,0 +1,86 @@
;; swank-larceny.scm --- Swank server for Ikarus
;;
;; License: Public Domain
;; Author: Helmut Eller
;;
;; In a shell execute:
;; ikarus swank-ikarus.ss
;; and then `M-x slime-connect' in Emacs.
;;
(library (swank os)
(export getpid make-server-socket accept local-port close-socket)
(import (rnrs)
(only (ikarus foreign) make-c-callout dlsym dlopen
pointer-set-c-long! pointer-ref-c-unsigned-short
malloc free pointer-size)
(rename (only (ikarus ipc) tcp-server-socket accept-connection
close-tcp-server-socket)
(tcp-server-socket make-server-socket)
(close-tcp-server-socket close-socket))
(only (ikarus)
struct-type-descriptor
struct-type-field-names
struct-field-accessor)
)
(define libc (dlopen))
(define (cfun name return-type arg-types)
((make-c-callout return-type arg-types) (dlsym libc name)))
(define getpid (cfun "getpid" 'signed-int '()))
(define (accept socket codec)
(let-values (((in out) (accept-connection socket)))
(values (transcoded-port in (make-transcoder codec))
(transcoded-port out (make-transcoder codec)))))
(define (socket-fd socket)
(let ((rtd (struct-type-descriptor socket)))
(do ((i 0 (+ i 1))
(names (struct-type-field-names rtd) (cdr names)))
((eq? (car names) 'fd) ((struct-field-accessor rtd i) socket)))))
(define sockaddr_in/size 16)
(define sockaddr_in/sin_family 0)
(define sockaddr_in/sin_port 2)
(define sockaddr_in/sin_addr 4)
(define (local-port socket)
(let* ((fd (socket-fd socket))
(addr (malloc sockaddr_in/size))
(size (malloc (pointer-size))))
(pointer-set-c-long! size 0 sockaddr_in/size)
(let ((code (getsockname fd addr size))
(port (ntohs (pointer-ref-c-unsigned-short
addr sockaddr_in/sin_port))))
(free addr)
(free size)
(cond ((= code -1) (error "getsockname failed"))
(#t port)))))
(define getsockname
(cfun "getsockname" 'signed-int '(signed-int pointer pointer)))
(define ntohs (cfun "ntohs" 'unsigned-short '(unsigned-short)))
)
(library (swank sys)
(export implementation-name eval-in-interaction-environment)
(import (rnrs)
(rnrs eval)
(only (ikarus) interaction-environment))
(define (implementation-name) "ikarus")
(define (eval-in-interaction-environment form)
(eval form (interaction-environment)))
)
(import (only (ikarus) load))
(load "swank-r6rs.scm")
(import (swank))
(start-server #f)

140
elpa/slime-20180413.1720/contrib/swank-indentation.lisp Normal file
View File

@@ -0,0 +1,140 @@
(in-package :swank)
(defvar *application-hints-tables* '()
"A list of hash tables mapping symbols to indentation hints (lists
of symbols and numbers as per cl-indent.el). Applications can add hash
tables to the list to change the auto indentation slime sends to
emacs.")
(defun has-application-indentation-hint-p (symbol)
(let ((default (load-time-value (gensym))))
(dolist (table *application-hints-tables*)
(let ((indentation (gethash symbol table default)))
(unless (eq default indentation)
(return-from has-application-indentation-hint-p
(values indentation t))))))
(values nil nil))
(defun application-indentation-hint (symbol)
(let ((indentation (has-application-indentation-hint-p symbol)))
(labels ((walk (indentation-spec)
(etypecase indentation-spec
(null nil)
(number indentation-spec)
(symbol (string-downcase indentation-spec))
(cons (cons (walk (car indentation-spec))
(walk (cdr indentation-spec)))))))
(walk indentation))))
;;; override swank version of this function
(defun symbol-indentation (symbol)
"Return a form describing the indentation of SYMBOL.
The form is to be used as the `common-lisp-indent-function' property
in Emacs."
(cond
((has-application-indentation-hint-p symbol)
(application-indentation-hint symbol))
((and (macro-function symbol)
(not (known-to-emacs-p symbol)))
(let ((arglist (arglist symbol)))
(etypecase arglist
((member :not-available)
nil)
(list
(macro-indentation arglist)))))
(t nil)))
;;; More complex version.
(defun macro-indentation (arglist)
(labels ((frob (list &optional base)
(if (every (lambda (x)
(member x '(nil "&rest") :test #'equal))
list)
;; If there was nothing interesting, don't return anything.
nil
;; Otherwise substitute leading NIL's with 4 or 1.
(let ((ok t))
(substitute-if (if base
4
1)
(lambda (x)
(if (and ok (not x))
t
(setf ok nil)))
list))))
(walk (list level &optional firstp)
(when (consp list)
(let ((head (car list)))
(if (consp head)
(let ((indent (frob (walk head (+ level 1) t))))
(cons (list* "&whole" (if (zerop level)
4
1)
indent) (walk (cdr list) level)))
(case head
;; &BODY is &BODY, this is clear.
(&body
'("&body"))
;; &KEY is tricksy. If it's at the base level, we want
;; to indent them normally:
;;
;; (foo bar quux
;; :quux t
;; :zot nil)
;;
;; If it's at a destructuring level, we want indent of 1:
;;
;; (with-foo (var arg
;; :foo t
;; :quux nil)
;; ...)
(&key
(if (zerop level)
'("&rest" nil)
'("&rest" 1)))
;; &REST is tricksy. If it's at the front of
;; destructuring, we want to indent by 1, otherwise
;; normally:
;;
;; (foo (bar quux
;; zot)
;; ...)
;;
;; but
;;
;; (foo bar quux
;; zot)
(&rest
(if (and (plusp level) firstp)
'("&rest" 1)
'("&rest" nil)))
;; &WHOLE and &ENVIRONMENT are skipped as if they weren't there
;; at all.
((&whole &environment)
(walk (cddr list) level firstp))
;; &OPTIONAL is indented normally -- and the &OPTIONAL marker
;; itself is not counted.
(&optional
(walk (cdr list) level))
;; Indent normally, walk the tail -- but
;; unknown lambda-list keywords terminate the walk.
(otherwise
(unless (member head lambda-list-keywords)
(cons nil (walk (cdr list) level))))))))))
(frob (walk arglist 0 t) t)))
#+nil
(progn
(assert (equal '(4 4 ("&whole" 4 "&rest" 1) "&body")
(macro-indentation '(bar quux (&rest slots) &body body))))
(assert (equal nil
(macro-indentation '(a b c &rest more))))
(assert (equal '(4 4 4 "&body")
(macro-indentation '(a b c &body more))))
(assert (equal '(("&whole" 4 1 1 "&rest" 1) "&body")
(macro-indentation '((name zot &key foo bar) &body body))))
(assert (equal nil
(macro-indentation '(x y &key z)))))
(provide :swank-indentation)

998
elpa/slime-20180413.1720/contrib/swank-jolt.k Normal file
View File

@@ -0,0 +1,998 @@
;;; swank-jolt.k --- Swank server for Jolt -*- goo -*-
;;
;; Copyright (C) 2008 Helmut Eller
;;
;; This file is licensed under the terms of the GNU General Public
;; License as distributed with Emacs (press C-h C-c for details).
;;; Commentary:
;;
;; Jolt/Coke is a Lisp-like language wich operates at the semantic level of
;; C, i.e. most objects are machine words and memory pointers. The
;; standard boot files define an interface to Id Smalltalk. So we can
;; also pretend to do OOP, but we must be careful to pass properly
;; tagged pointers to Smalltalk.
;;
;; This file only implements a minimum of SLIME's functionality. We
;; install a handler with atexit(3) to invoke the debugger. This way
;; we can stop Jolt from terminating the process on every error.
;; Unfortunately, the backtrace doesn't contain much information and
;; we also have no error message (other than the exit code). Jolt
;; usually prints some message to stdout before calling exit, so you
;; have to look in the *inferior-lisp* buffer for hints. We do
;; nothing (yet) to recover from SIGSEGV.
;;; Installation
;;
;; 1. Download and build cola. See <http://piumarta.com/software/cola/>.
;; I used the svn version:
;; svn co http://piumarta.com/svn2/idst/trunk idst
;; 2. Add something like this to your .emacs:
;;
;; (add-to-list 'slime-lisp-implementations
;; '(jolt (".../idst/function/jolt-burg/main"
;; "boot.k" ".../swank-jolt.k" "-") ; note the "-"
;; :init jolt-slime-init
;; :init-function slime-redirect-inferior-output)
;; (defun jolt-slime-init (file _) (format "%S\n" `(start-swank ,file)))
;; (defun jolt () (interactive) (slime 'jolt))
;;
;; 3. Use `M-x jolt' to start it.
;;
;;; Code
;; In this file I use 2-3 letters for often used names, like DF or
;; VEC, even if those names are abbreviations. I think that after a
;; little getting used to, this style is just as readable as the more
;; traditional DEFUN and VECTOR. Shorter names make it easier to
;; write terse code, in particular 1-line definitions.
;; `df' is like `defun' in a traditional lisp
(syntax df
(lambda (form compiler)
(printf "df %s ...\n" [[[form second] asString] _stringValue])
`(define ,[form second] (lambda ,@[form copyFrom: '2]))))
;; (! args ...) is the same as [args ...] but easier to edit.
(syntax !
(lambda (form compiler)
(cond ((== [form size] '3)
(if [[form third] isSymbol]
`(send ',[form third] ,[form second])
[compiler errorSyntax: [form third]]))
((and [[form size] > '3]
(== [[form size] \\ '2] '0))
(let ((args [OrderedCollection new])
(keys [OrderedCollection new])
(i '2) (len [form size]))
(while (< i len)
(let ((key [form at: i]))
(if (or [key isKeyword]
(and (== i '2) [key isSymbol])) ; for [X + Y]
[keys addLast: [key asString]]
[compiler errorSyntax: key]))
[args addLast: [form at: [i + '1]]]
(set i [i + '2]))
`(send ',[[keys concatenated] asSymbol] ,[form second] ,@args)))
(1 [compiler errorArgumentCount: form]))))
(define Integer (import "Integer"))
(define Symbol (import "Symbol")) ;; aka. _selector
(define StaticBlockClosure (import "StaticBlockClosure"))
(define BlockClosure (import "BlockClosure"))
(define SequenceableCollection (import "SequenceableCollection"))
(define _vtable (import "_vtable"))
(define ByteArray (import "ByteArray"))
(define CodeGenerator (import "CodeGenerator"))
(define TheGlobalEnvironment (import "TheGlobalEnvironment"))
(df error (msg) (! Object error: msg))
(df print-to-string (obj)
(let ((len '200)
(stream (! WriteStream on: (! String new: len))))
(! stream print: obj)
(! stream contents)))
(df assertion-failed (exp)
(error (! '"Assertion failed: " , (print-to-string exp))))
(syntax assert
(lambda (form)
`(if (not ,(! form second))
(assertion-failed ',(! form second)))))
(df isa? (obj type) (! obj isKindOf: type))
(df equal (o1 o2) (! o1 = o2))
(define nil 0)
(define false 0)
(define true (! Object notNil))
(df bool? (obj) (or (== obj false) (== obj true)))
(df int? (obj) (isa? obj Integer))
;; In this file the convention X>Y is used for operations that convert
;; X-to-Y. And _ means "machine word". So _>int is the operator that
;; converts a machine word to an Integer.
(df _>int (word) (! Integer value_: word))
(df int>_ (i) (! i _integerValue))
;; Fixnum operators. Manual tagging/untagging would probably be more
;; efficent than invoking methods.
(df fix? (obj) (& obj 1))
(df _>fix (n) (! SmallInteger value_: n))
(df fix>_ (i) (! i _integerValue))
(df fx+ (fx1 fx2) (! fx1 + fx2))
(df fx* (fx1 fx2) (! fx1 * fx2))
(df fx1+ (fx) (! fx + '1))
(df fx1- (fx) (! fx - '1))
(df str? (obj) (isa? obj String))
(df >str (o) (! o asString))
(df str>_ (s) (! s _stringValue))
(df _>str (s) (! String value_: s))
(df sym? (obj) (isa? obj Symbol))
(df seq? (obj) (isa? obj SequenceableCollection))
(df array? (obj) (isa? obj Array))
(df len (obj) (! obj size))
(df len_ (obj) (! (! obj size) _integerValue))
(df ref (obj idx) (! obj at: idx))
(df set-ref (obj idx elt) (! obj at: idx put: elt))
(df first (obj) (! obj first))
(df second (obj) (! obj second))
(df puts (string stream) (! stream nextPutAll: string))
(define _GC_base (dlsym "GC_base"))
;; Is ADDR a pointer to a heap allocated object? The Boehm GC nows
;; such things. This is useful for debugging, because we can quite
;; safely (i.e. without provoking SIGSEGV) access such addresses.
(df valid-pointer? (addr)
(let ((ptr (& addr (~ 1))))
(and (_GC_base ptr)
(_GC_base (long@ ptr -1)))))
;; Print OBJ as a Lisp printer would do.
(df prin1 (obj stream)
(cond ((fix? obj) (! stream print: obj))
((== obj nil) (puts '"nil" stream))
((== obj false) (puts '"#f" stream))
((== obj true) (puts '"#t" stream))
((not (valid-pointer? obj))
(begin (puts '"#<w " stream)
(prin1 (_>int obj) stream)
(puts '">" stream)))
((int? obj) (! stream print: obj))
((sym? obj) (puts (>str obj) stream))
((isa? obj StaticBlockClosure)
(begin (puts '"#<fun /" stream)
(! stream print: (! obj arity))
(puts '"#>" stream)))
((and (str? obj) (len obj))
(! obj printEscapedOn: stream delimited: (ref '"\"" '0)))
((and (array? obj) (len obj))
(begin (puts '"(" stream)
(let ((max (- (len_ obj) 1)))
(for (i 0 1 max)
(prin1 (ref obj (_>fix i)) stream)
(if (!= i max)
(puts '" " stream))))
(puts '")" stream)))
((and (isa? obj OrderedCollection) (len obj))
(begin (puts '"#[" stream)
(let ((max (- (len_ obj) 1)))
(for (i 0 1 max)
(prin1 (ref obj (_>fix i)) stream)
(if (!= i max)
(puts '" " stream))))
(puts '"]" stream)))
(true
(begin (puts '"#<" stream)
(puts (! obj debugName) stream)
(puts '">" stream))))
obj)
(df print (obj)
(prin1 obj StdOut)
(puts '"\n" StdOut))
(df prin1-to-string (obj)
(let ((len '100)
(stream (! WriteStream on: (! String new: len))))
(prin1 obj stream)
(! stream contents)))
;;(df %vable-tally (_vtable) (long@ _vtable))
(df cr () (printf "\n"))
(df print-object-selectors (obj)
(let ((vtable (! obj _vtable))
(tally (long@ vtable 0))
(bindings (long@ vtable 1)))
(for (i 1 1 tally)
(print (long@ (long@ bindings i)))
(cr))))
(df print-object-slots (obj)
(let ((size (! obj _sizeof))
(end (+ obj size)))
(while (< obj end)
(print (long@ obj))
(cr)
(incr obj 4))))
(df intern (string) (! Symbol intern: string))
;; Jolt doesn't seem to have an equivalent for gensym, but it's damn
;; hard to write macros without it. So here we adopt the conventions
;; that symbols which look like ".[0-9]+" are reserved for gensym and
;; shouldn't be used for "user visible variables".
(define gensym-counter 0)
(df gensym ()
(set gensym-counter (+ gensym-counter 1))
(intern (! '"." , (>str (_>fix gensym-counter)))))
;; Surprisingly, SequenceableCollection doesn't have a indexOf method.
;; So we even need to implement such mundane things.
(df index-of (seq elt)
(let ((max (len seq))
(i '0))
(while (! i < max)
(if (equal (ref seq i) elt)
(return i)
(set i (! i + '1))))
nil))
(df find-dot (array) (index-of array '.))
;; What followes is the implementation of the pattern matching macro MIF.
;; The syntax is (mif (PATTERN EXP) THEN ELSE).
;; The THEN-branch is executed if PATTERN matches the value produced by EXP.
;; ELSE gets only executed if the match failes.
;; A pattern can be
;; 1) a symbol, which matches all values, but also binds the variable to the
;; value
;; 2) (quote LITERAL), matches if the value is `equal' to LITERAL.
;; 3) (PS ...) matches sequences, if the elements match PS.
;; 4) (P1 ... Pn . Ptail) matches if P1 ... Pn match the respective elements
;; at indices 1..n and if Ptail matches the rest
;; of the sequence
;; Examples:
;; (mif (x 10) x 'else) => 10
;; (mif ('a 'a) 'then 'else) => then
;; (mif ('a 'b) 'then 'else) => else
;; (mif ((a b) '(1 2)) b 'else) => 2
;; (mif ((a . b) '(1 2)) b 'else) => '(2)
;; (mif ((. x) '(1 2)) x 'else) => '(1 2)
(define mif% 0) ;; defer
(df mif%array (compiler pattern i value then fail)
;;(print `(mif%array ,pattern ,i ,value))
(cond ((== i (len_ pattern)) then)
((== (ref pattern (_>fix i)) '.)
(begin
(if (!= (- (len_ pattern) 2) i)
(begin
(print pattern)
(! compiler error: (! '"dot in strange position: "
, (>str (_>fix i))))))
(mif% compiler
(ref pattern (_>fix (+ i 1)))
`(! ,value copyFrom: ',(_>fix i))
then fail)))
(true
(mif% compiler
(ref pattern (_>fix i))
`(ref ,value ',(_>fix i))
(mif%array compiler pattern (+ i 1) value then fail)
fail))))
(df mif% (compiler pattern value then fail)
;;(print `(mif% ,pattern ,value ,then))
(cond ((== pattern '_) then)
((== pattern '.) (! compiler errorSyntax: pattern))
((sym? pattern)
`(let ((,pattern ,value)) ,then))
((seq? pattern)
(cond ((== (len_ pattern) 0)
`(if (== (len_ ,value) 0) ,then (goto ,fail)))
((== (first pattern) 'quote)
(begin
(if (not (== (len_ pattern) 2))
(! compiler errorSyntax: pattern))
`(if (equal ,value ,pattern) ,then (goto ,fail))))
(true
(let ((tmp (gensym)) (tmp2 (gensym))
(pos (find-dot pattern)))
`(let ((,tmp2 ,value)
(,tmp ,tmp2))
(if (and (seq? ,tmp)
,(if (find-dot pattern)
`(>= (len ,tmp)
',(_>fix (- (len_ pattern) 2)))
`(== (len ,tmp) ',(len pattern))))
,(mif%array compiler pattern 0 tmp then fail)
(goto ,fail)))))))
(true (! compiler errorSyntax: pattern))))
(syntax mif
(lambda (node compiler)
;;(print `(mif ,node))
(if (not (or (== (len_ node) 4)
(== (len_ node) 3)))
(! compiler errorArgumentCount: node))
(if (not (and (array? (ref node '1))
(== (len_ (ref node '1)) 2)))
(! compiler errorSyntax: (ref node '1)))
(let ((pattern (first (ref node '1)))
(value (second (ref node '1)))
(then (ref node '2))
(else (if (== (len_ node) 4)
(ref node '3)
`(error "mif failed")))
(destination (gensym))
(fail (! compiler newLabel))
(success (! compiler newLabel)))
`(let ((,destination 0))
,(mif% compiler pattern value
`(begin (set ,destination ,then)
(goto ,success))
fail)
(label ,fail)
(set ,destination ,else)
(label ,success)
,destination))))
;; (define *catch-stack* nil)
;;
(df bar (o) (mif ('a o) 'yes 'no))
(assert (== (bar 'a) 'yes))
(assert (== (bar 'b) 'no))
(df foo (o) (mif (('a) o) 'yes 'no))
(assert (== (foo '(a)) 'yes))
(assert (== (foo '(b)) 'no))
(df baz (o) (mif (('a 'b) o) 'yes 'no))
(assert (== (baz '(a b)) 'yes))
(assert (== (baz '(a c)) 'no))
(assert (== (baz '(b c)) 'no))
(assert (== (baz 'a) 'no))
(df mifvar (o) (mif (y o) y 'no))
(assert (== (mifvar 'foo) 'foo))
(df mifvec (o) (mif ((y) o) y 'no))
(assert (== (mifvec '(a)) 'a))
(assert (== (mifvec 'x) 'no))
(df mifvec2 (o) (mif (('a y) o) y 'no))
(assert (== (mifvec2 '(a b)) 'b))
(assert (== (mifvec2 '(b c)) 'no))
(assert (== (mif ((x) '(a)) x 'no) 'a))
(assert (== (mif ((x . y) '(a b)) x 'no) 'a))
(assert (== (mif ((x y . z) '(a b)) y 'no) 'b))
(assert (equal (mif ((x . y) '(a b)) y 'no) '(b)))
(assert (equal (mif ((. x) '(a b)) x 'no) '(a b)))
(assert (equal (mif (((. x)) '((a b))) x 'no) '(a b)))
(assert (equal (mif (((. x) . y) '((a b) c)) y 'no) '(c)))
(assert (== (mif (() '()) 'yes 'no) 'yes))
(assert (== (mif (() '(a)) 'yes 'no) 'no))
;; Now that we have a somewhat convenient pattern matcher we can write
;; a more convenient macro defining macro:
(syntax defmacro
(lambda (node compiler)
(mif (('defmacro name (. args) . body) node)
(begin
(printf "defmacro %s ...\n" (str>_ (>str name)))
`(syntax ,name
(lambda (node compiler)
(mif ((',name ,@args) node)
(begin ,@body)
(! compiler errorSyntax: node)))))
(! compiler errorSyntax: node))))
;; and an even more convenient pattern matcher:
(defmacro mcase (value . clauses)
(let ((tmp (gensym)))
`(let ((,tmp ,value))
,(mif (() clauses)
`(begin (print ,tmp)
(error "mcase failed"))
(mif (((pattern . body) . more) clauses)
`(mif (,pattern ,tmp)
(begin ,@(mif (() body) '(0) body))
(mcase ,tmp ,@more))
(! compiler errorSyntax: clauses))))))
;; and some traditional macros
(defmacro when (test . body) `(if ,test (begin ,@body)))
(defmacro unless (test . body) `(if ,test 0 (begin ,@body)))
(defmacro or (. args) ; the built in OR returns 1 on success.
(mcase args
(() 0)
((e) e)
((e1 . more)
(let ((tmp (gensym)))
`(let ((,tmp ,e1))
(if ,tmp ,tmp (or ,@more)))))))
(defmacro dotimes_ ((var n) . body)
(let ((tmp (gensym)))
`(let ((,tmp ,n)
(,var 0))
(while (< ,var ,tmp)
,@body
(set ,var (+ ,var 1))))))
(defmacro dotimes ((var n) . body)
(let ((tmp (gensym)))
`(let ((,tmp ,n)
(,var '0))
(while (< ,var ,tmp)
,@body
(set ,var (fx1+ ,var))))))
;; DOVEC is like the traditional DOLIST but works on "vectors"
;; i.e. sequences which can be indexed efficently.
(defmacro dovec ((var seq) . body)
(let ((i (gensym))
(max (gensym))
(tmp (gensym)))
`(let ((,i 0)
(,tmp ,seq)
(,max (len_ ,tmp)))
(while (< ,i ,max)
(let ((,var (! ,tmp at: (_>fix ,i))))
,@body
(set ,i (+ ,i 1)))))))
;; "Packing" is what Lispers usually call "collecting".
;; The Lisp idiom (let ((result '())) .. (push x result) .. (nreverse result))
;; translates to (packing (result) .. (pack x result))
(defmacro packing ((var) . body)
`(let ((,var (! OrderedCollection new)))
,@body
(! ,var asArray)))
(df pack (elt packer) (! packer addLast: elt))
(assert (equal (packing (p) (dotimes_ (i 2) (pack (_>fix i) p)))
'(0 1)))
(assert (equal (packing (p) (dovec (e '(2 3)) (pack e p)))
'(2 3)))
(assert (equal (packing (p)
(let ((a '(2 3)))
(dotimes (i (len a))
(pack (ref a i) p))))
'(2 3)))
;; MAPCAR (more or less)
(df map (fun col)
(packing (r)
(dovec (e col)
(pack (fun e) r))))
;; VEC allocates and initializes a new array.
;; The macro translates (vec x y z) to `(,x ,y ,z).
(defmacro vec (. args)
`(quasiquote
(,@(map (lambda (arg) `(,'unquote ,arg))
args))))
(assert (equal (vec '0 '1) '(0 1)))
(assert (equal (vec) '()))
(assert (== (len (vec 0 1 2 3 4)) '5))
;; Concatenate.
(defmacro cat (. args) `(! (vec '"" ,@args) concatenated))
(assert (equal (cat '"a" '"b" '"c") '"abc"))
;; Take a vector of bytes and copy the bytes to a continuous
;; block of memory
(df assemble_ (col) (! (! ByteArray withAll: col) _bytes))
;; Jolt doesn't seem to have catch/throw or something equivalent.
;; Here I use a pair of assembly routines as substitue.
;; (catch% FUN) calls FUN with the current stack pointer.
;; (throw% VALUE K) unwinds the stack to K and then returns VALUE.
;; catch% is a bit like call/cc.
;;
;; [Would setjmp/longjmp work from Jolt? or does setjmp require
;; C-compiler magic?]
;; [I figure Smalltalk has a way to do non-local-exits but, I don't know
;; how to use that in Jolt.]
;;
(define catch%
(assemble_
'(0x55 ; push %ebp
0x89 0xe5 ; mov %esp,%ebp
0x54 ; push %esp
0x8b 0x45 0x08 ; mov 0x8(%ebp),%eax
0xff 0xd0 ; call *%eax
0xc9 ; leave
0xc3 ; ret
)))
(define throw%
(assemble_
`(,@'()
0x8b 0x44 0x24 0x04 ; mov 0x4(%esp),%eax
0x8b 0x6c 0x24 0x08 ; mov 0x8(%esp),%ebp
0xc9 ; leave
0xc3 ; ret
)))
(df bar (i k)
(if (== i 0)
(throw% 100 k)
(begin
(printf "bar %d\n" i)
(bar (- i 1) k))))
(df foo (k)
(printf "foo.1\n")
(printf "foo.2 %d\n" (bar 10 k)))
;; Our way to produce closures: we compile a new little function which
;; hardcodes the addresses of the code resp. the data-vector. The
;; nice thing is that such closures can be used called C function
;; pointers. It's probably slow to invoke the compiler for such
;; things, so use with care.
(df make-closure (addr state)
(int>_
(! `(lambda (a b c d)
(,(_>int addr) ,(_>int state) a b c d))
eval)))
;; Return a closure which calls FUN with ARGS and the arguments
;; that the closure was called with.
;; Example: ((curry printf "%d\n") 10)
(defmacro curry (fun . args)
`(make-closure
(lambda (state a b c d)
((ref state '0)
,@(packing (sv)
(dotimes (i (len args))
(pack `(ref state ',(fx1+ i)) sv)))
a b c d))
(vec ,fun ,@args)))
(df parse-closure-arglist (vars)
(let ((pos (or (index-of vars '|)
(return nil)))
(cvars (! vars copyFrom: '0 to: (fx1- pos)))
(lvars (! vars copyFrom: (fx1+ pos))))
(vec cvars lvars)))
;; Create a closure, to-be-closed-over variables must enumerated
;; explicitly.
;; Example: ((let ((x 1)) (closure (x | y) (+ x y))) 3) => 4.
;; The variables before the "|" are captured by the closure.
(defmacro closure ((. vars) . body)
(mif ((cvars lvars) (parse-closure-arglist vars))
`(curry (lambda (,@cvars ,@lvars) ,@body)
,@cvars)
(! compiler errorSyntax: vars)))
;; The analog for Smalltalkish "blocks".
(defmacro block ((. vars) . body)
(mif ((cvars lvars) (parse-closure-arglist vars))
`(! StaticBlockClosure
function_: (curry (lambda (,@cvars _closure _self ,@lvars) ,@body)
,@cvars)
arity_: ,(len lvars))
(! compiler errorSyntax: vars)))
(define %mkstemp (dlsym "mkstemp"))
(df make-temp-file ()
(let ((name (! '"/tmp/jolt-tmp.XXXXXX" copy))
(fd (%mkstemp (! name _stringValue))))
(if (== fd -1)
(error "mkstemp failed"))
`(,fd ,name)))
(define %unlink (dlsym "unlink"))
(df unlink (filename) (%unlink (! filename _stringValue)))
(define write (dlsym "write"))
(df write-bytes (addr count fd)
(let ((written (write fd addr count)))
(if (!= written count)
(begin
(printf "write failed %p %d %d => %d" addr count fd written)
(error '"write failed")))))
(define system (dlsym "system"))
(define main (dlsym "main"))
;; Starting at address ADDR, disassemble COUNT bytes.
;; This is implemented by writing the memory region to a file
;; and call ndisasm on it.
(df disas (addr count)
(let ((fd+name (make-temp-file)))
(write-bytes addr count (first fd+name))
(let ((cmd (str>_ (cat '"ndisasm -u -o "
(>str (_>fix addr))
'" " (second fd+name)))))
(printf "Running: %s\n" cmd)
(system cmd))
(unlink (second fd+name))))
(df rep ()
(let ((result (! (! CokeScanner read: StdIn) eval)))
(puts '"=> " StdOut)
(print result)
(puts '"\n" StdOut)))
;; Perhaps we could use setcontext/getcontext to return from signal
;; handlers (or not).
(define +ucontext-size+ 350)
(define _getcontext (dlsym "getcontext"))
(define _setcontext (dlsym "setcontext"))
(df getcontext ()
(let ((context (malloc 350)))
(_getcontext context)
context))
(define on_exit (dlsym "on_exit")) ; "atexit" doesn't work. why?
(define *top-level-restart* 0)
(define *top-level-context* 0)
(define *debugger-hook* 0)
;; Jolt's error handling strategy is charmingly simple: call exit.
;; We invoke the SLIME debugger from an exit handler.
;; (The handler is registered with atexit, that's a libc function.)
(df exit-handler (reason arg)
(printf "exit-handler 0x%x\n" reason)
;;(backtrace)
(on_exit exit-handler nil)
(when *debugger-hook*
(*debugger-hook* `(exit ,reason)))
(cond (*top-level-context*
(_setcontext *top-level-context*))
(*top-level-restart*
(throw% reason *top-level-restart*))))
(df repl ()
(set *top-level-context* (getcontext))
(while (not (! (! StdIn readStream) atEnd))
(printf "top-level\n")
(catch%
(lambda (k)
(set *top-level-restart* k)
(printf "repl\n")
(while 1
(rep)))))
(printf "EOF\n"))
;; (repl)
;;; Socket code. (How boring. Duh, should have used netcat instead.)
(define strerror (dlsym "strerror"))
(df check-os-code (value)
(if (== value -1)
(error (_>str (strerror (fix>_ (! OS errno)))))
value))
;; For now just hard-code constants which usually reside in header
;; files (just like a Forth guy would do).
(define PF_INET 2)
(define SOCK_STREAM 1)
(define SOL_SOCKET 1)
(define SO_REUSEADDR 2)
(define socket (dlsym "socket"))
(define setsockopt (dlsym "setsockopt"))
(df set-reuse-address (sock value)
(let ((word-size 4)
(val (! Object _balloc: (_>fix word-size))))
(set-int@ val value)
(check-os-code
(setsockopt sock SOL_SOCKET SO_REUSEADDR val word-size))))
(define sockaddr_in/size 16)
(define sockaddr_in/sin_family 0)
(define sockaddr_in/sin_port 2)
(define sockaddr_in/sin_addr 4)
(define INADDR_ANY 0)
(define AF_INET 2)
(define htons (dlsym "htons"))
(define bind (dlsym "bind"))
(df bind-socket (sock port)
(let ((addr (! OS _balloc: (_>fix sockaddr_in/size))))
(set-short@ (+ addr sockaddr_in/sin_family) AF_INET)
(set-short@ (+ addr sockaddr_in/sin_port) (htons port))
(set-int@ (+ addr sockaddr_in/sin_addr) INADDR_ANY)
(check-os-code
(bind sock addr sockaddr_in/size))))
(define listen (dlsym "listen"))
(df create-socket (port)
(let ((sock (check-os-code (socket PF_INET SOCK_STREAM 0))))
(set-reuse-address sock 1)
(bind-socket sock port)
(check-os-code (listen sock 1))
sock))
(define accept% (dlsym "accept"))
(df accept (sock)
(let ((addr (! OS _balloc: (_>fix sockaddr_in/size)))
(len (! OS _balloc: 4)))
(set-int@ len sockaddr_in/size)
(check-os-code (accept% sock addr len))))
(define getsockname (dlsym "getsockname"))
(define ntohs (dlsym "ntohs"))
(df local-port (sock)
(let ((addr (! OS _balloc: (_>fix sockaddr_in/size)))
(len (! OS _balloc: 4)))
(set-int@ len sockaddr_in/size)
(check-os-code
(getsockname sock addr len))
(ntohs (short@ (+ addr sockaddr_in/sin_port)))))
(define close (dlsym "close"))
(define _read (dlsym "read"))
;; Now, after 2/3 of the file we can begin with the actual Swank
;; server.
(df read-string (fd count)
(let ((buffer (! String new: count))
(buffer_ (str>_ buffer))
(count_ (int>_ count))
(start 0))
(while (> (- count_ start) 0)
(let ((rcount (check-os-code (_read fd
(+ buffer_ start)
(- count_ start)))))
(set start (+ start rcount))))
buffer))
;; Read and parse a message from the wire.
(df read-packet (fd)
(let ((header (read-string fd '6))
(length (! Integer fromString: header base: '16))
(payload (read-string fd length)))
(! CokeScanner read: payload)))
;; Print a messag to the wire.
(df send-to-emacs (event fd)
(let ((stream (! WriteStream on: (! String new: '100))))
(! stream position: '6)
(prin1 event stream)
(let ((len (! stream position)))
(! stream position: '0)
(! (fx+ len '-6) printOn: stream base: '16 width: '6)
(write-bytes (str>_ (! stream collection)) (int>_ len) fd))))
(df add-quotes (form)
(mcase form
((fun . args)
`(,fun ,@(packing (s)
(dovec (e args)
(pack `(quote ,e) s)))))))
(define sldb 0) ;defer
(df eval-for-emacs (form id fd abort)
(let ((old-hook *debugger-hook*))
(mcase (catch%
(closure (form fd | k)
(set *debugger-hook* (curry sldb fd k))
`(ok ,(int>_ (! (add-quotes form) eval)))))
(('ok value)
(set *debugger-hook* old-hook)
(send-to-emacs `(:return (:ok ,value) ,id) fd)
'ok)
(arg
(set *debugger-hook* old-hook)
(send-to-emacs `(:return (:abort) ,id) fd)
(throw% arg abort)))))
(df process-events (fd)
(on_exit exit-handler nil)
(let ((done nil))
(while (not done)
(mcase (read-packet fd)
((':emacs-rex form package thread id)
(mcase (catch% (closure (form id fd | abort)
(eval-for-emacs form id fd abort)))
('ok)
;;('abort nil)
('top-level)
(other
;;(return other) ; compiler breaks with return
(set done 1))))))))
(df next-frame (fp)
(let ((next (get-caller-fp fp)))
(if (and (!= next fp)
(<= next %top-level-fp))
next
nil)))
(df nth-frame (n top)
(let ((fp top)
(i 0))
(while fp
(if (== i n) (return fp))
(set fp (next-frame fp))
(set i (+ i 1)))
nil))
(define Dl_info/size 16)
(define Dl_info/dli_fname 0)
(define Dl_info/dli_sname 8)
(df get-dl-sym-name (addr)
(let ((info (! OS _balloc: (_>fix Dl_info/size))))
(when (== (dladdr addr info) 0)
(return nil))
(let ((sname (long@ (+ info Dl_info/dli_sname)) )
(fname (long@ (+ info Dl_info/dli_fname))))
(cond ((and sname fname)
(cat (_>str sname) '" in " (_>str fname)))
(sname (_>str fname))
(fname (cat '"<??> " (_>str fname)))
(true nil)))))
;;(get-dl-sym-name printf)
(df guess-function-name (ip)
(let ((fname (get-function-name ip)))
(if fname
(_>str fname)
(get-dl-sym-name ip))))
(df backtrace>el (top_ from_ to_)
(let ((fp (nth-frame from_ top_))
(i from_))
(packing (bt)
(while (and fp (< i to_))
(let ((ip (get-frame-ip fp)))
(pack (vec (_>int i)
(cat (or (guess-function-name ip) '"(no-name)")
'" " ;;(>str (_>int ip))
))
bt))
(set i (+ i 1))
(set fp (next-frame fp))))))
(df debugger-info (fp msg)
(vec `(,(prin1-to-string msg) " [type ...]" ())
'(("quit" "Return to top level"))
(backtrace>el fp 0 20)
'()))
(define *top-frame* 0)
(define *sldb-quit* 0)
(df debugger-loop (fd args abort)
(let ((fp (get-current-fp)))
(set *top-frame* fp)
(send-to-emacs `(:debug 0 1 ,@(debugger-info fp args)) fd)
(while 1
(mcase (read-packet fd)
((':emacs-rex form package thread id)
(mcase (catch% (closure (form id fd | k)
(set *sldb-quit* k)
(eval-for-emacs form id fd k)
'ok))
('ok nil)
(other
(send-to-emacs `(:return (:abort) ,id) fd)
(throw% other abort))))))))
(df sldb (fd abort args)
(let ((old-top-frame *top-frame*)
(old-sldb-quit *sldb-quit*))
(mcase (catch% (curry debugger-loop fd args))
(value
(set *top-frame* old-top-frame)
(set *sldb-quit* old-sldb-quit)
(send-to-emacs `(:debug-return 0 1 nil) fd)
(throw% value abort)))))
(df swank:backtrace (start end)
(backtrace>el *top-frame* (int>_ start) (int>_ end)))
(df sldb-quit ()
(assert *sldb-quit*)
(throw% 'top-level *sldb-quit*))
(df swank:invoke-nth-restart-for-emacs (...) (sldb-quit))
(df swank:throw-to-toplevel (...) (sldb-quit))
(df setup-server (port announce)
(let ((sock (create-socket port)))
(announce sock)
(let ((client (accept sock)))
(process-events client)
(close client))
(printf "Closing socket: %d %d\n" sock (local-port sock))
(close sock)))
(df announce-port (sock)
(printf "Listening on port: %d\n" (local-port sock)))
(df create-server (port) (setup-server port announce-port))
(df write-port-file (filename sock)
(let ((f (! File create: filename)))
(! f write: (print-to-string (_>int (local-port sock))))
(! f close)))
(df start-swank (port-file)
(setup-server 0 (curry write-port-file (_>str port-file))))
(define getpid (dlsym "getpid"))
(df swank:connection-info ()
`(,@'()
:pid ,(_>int (getpid))
:style nil
:lisp-implementation (,@'()
:type "Coke"
:name "jolt"
:version ,(! CodeGenerator versionString))
:machine (:instance "" :type ,(! OS architecture) :version "")
:features ()
:package (:name "jolt" :prompt "jolt")))
(df swank:listener-eval (string)
(let ((result (! (! CokeScanner read: string) eval)))
`(:values ,(prin1-to-string (if (or (fix? result)
(and (valid-pointer? result)
(int? result)))
(int>_ result)
result))
,(prin1-to-string result))))
(df swank:interactive-eval (string)
(let ((result (! (! CokeScanner read: string) eval)))
(cat '"=> " (prin1-to-string (if (or (fix? result)
(and (valid-pointer? result)
(int? result)))
(int>_ result)
result))
'", " (prin1-to-string result))))
(df swank:operator-arglist () nil)
(df swank:buffer-first-change () nil)
(df swank:create-repl (_) '("jolt" "jolt"))
(df min (x y) (if (<= x y) x y))
(df common-prefix2 (e1 e2)
(let ((i '0)
(max (min (len e1) (len e2))))
(while (and (< i max)
(== (ref e1 i) (ref e2 i)))
(set i (fx1+ i)))
(! e1 copyFrom: '0 to: (fx1- i))))
(df common-prefix (seq)
(mcase seq
(() nil)
(_
(let ((prefix (ref seq '0)))
(dovec (e seq)
(set prefix (common-prefix2 prefix e)))
prefix))))
(df swank:simple-completions (prefix _package)
(let ((matches (packing (s)
(dovec (e (! TheGlobalEnvironment keys))
(let ((name (>str e)))
(when (! name beginsWith: prefix)
(pack name s)))))))
(vec matches (or (common-prefix matches) prefix))))
;; swank-jolt.k ends here

2504
elpa/slime-20180413.1720/contrib/swank-kawa.scm Normal file
View File

File diff suppressed because it is too large Load Diff

176
elpa/slime-20180413.1720/contrib/swank-larceny.scm Normal file
View File

@@ -0,0 +1,176 @@
;; swank-larceny.scm --- Swank server for Larceny
;;
;; License: Public Domain
;; Author: Helmut Eller
;;
;; In a shell execute:
;; larceny -r6rs -program swank-larceny.scm
;; and then `M-x slime-connect' in Emacs.
(library (swank os)
(export getpid make-server-socket accept local-port close-socket)
(import (rnrs)
(primitives foreign-procedure
ffi/handle->address
ffi/string->asciiz
sizeof:pointer
sizeof:int
%set-pointer
%get-int))
(define getpid (foreign-procedure "getpid" '() 'int))
(define fork (foreign-procedure "fork" '() 'int))
(define close (foreign-procedure "close" '(int) 'int))
(define dup2 (foreign-procedure "dup2" '(int int) 'int))
(define bytevector-content-offset$ sizeof:pointer)
(define execvp% (foreign-procedure "execvp" '(string boxed) 'int))
(define (execvp file . args)
(let* ((nargs (length args))
(argv (make-bytevector (* (+ nargs 1)
sizeof:pointer))))
(do ((offset 0 (+ offset sizeof:pointer))
(as args (cdr as)))
((null? as))
(%set-pointer argv
offset
(+ (ffi/handle->address (ffi/string->asciiz (car as)))
bytevector-content-offset$)))
(%set-pointer argv (* nargs sizeof:pointer) 0)
(execvp% file argv)))
(define pipe% (foreign-procedure "pipe" '(boxed) 'int))
(define (pipe)
(let ((array (make-bytevector (* sizeof:int 2))))
(let ((r (pipe% array)))
(values r (%get-int array 0) (%get-int array sizeof:int)))))
(define (fork/exec file . args)
(let ((pid (fork)))
(cond ((= pid 0)
(apply execvp file args))
(#t pid))))
(define (start-process file . args)
(let-values (((r1 down-out down-in) (pipe))
((r2 up-out up-in) (pipe))
((r3 err-out err-in) (pipe)))
(assert (= 0 r1))
(assert (= 0 r2))
(assert (= 0 r3))
(let ((pid (fork)))
(case pid
((-1)
(error "Failed to fork a subprocess."))
((0)
(close up-out)
(close err-out)
(close down-in)
(dup2 down-out 0)
(dup2 up-in 1)
(dup2 err-in 2)
(apply execvp file args)
(exit 1))
(else
(close down-out)
(close up-in)
(close err-in)
(list pid
(make-fd-io-stream up-out down-in)
(make-fd-io-stream err-out err-out)))))))
(define (make-fd-io-stream in out)
(let ((write (lambda (bv start count) (fd-write out bv start count)))
(read (lambda (bv start count) (fd-read in bv start count)))
(closeit (lambda () (close in) (close out))))
(make-custom-binary-input/output-port
"fd-stream" read write #f #f closeit)))
(define write% (foreign-procedure "write" '(int ulong int) 'int))
(define (fd-write fd bytevector start count)
(write% fd
(+ (ffi/handle->address bytevector)
bytevector-content-offset$
start)
count))
(define read% (foreign-procedure "read" '(int ulong int) 'int))
(define (fd-read fd bytevector start count)
;;(printf "fd-read: ~a ~s ~a ~a\n" fd bytevector start count)
(read% fd
(+ (ffi/handle->address bytevector)
bytevector-content-offset$
start)
count))
(define (make-server-socket port)
(let* ((args `("/bin/bash" "bash"
"-c"
,(string-append
"netcat -s 127.0.0.1 -q 0 -l -v "
(if port
(string-append "-p " (number->string port))
""))))
(nc (apply start-process args))
(err (transcoded-port (list-ref nc 2)
(make-transcoder (latin-1-codec))))
(line (get-line err))
(pos (last-index-of line '#\])))
(cond (pos
(let* ((tail (substring line (+ pos 1) (string-length line)))
(port (get-datum (open-string-input-port tail))))
(list (car nc) (cadr nc) err port)))
(#t (error "netcat failed: " line)))))
(define (accept socket codec)
(let* ((line (get-line (caddr socket)))
(pos (last-index-of line #\])))
(cond (pos
(close-port (caddr socket))
(let ((stream (cadr socket)))
(let ((io (transcoded-port stream (make-transcoder codec))))
(values io io))))
(else (error "accept failed: " line)))))
(define (local-port socket)
(list-ref socket 3))
(define (last-index-of str chr)
(let loop ((i (string-length str)))
(cond ((<= i 0) #f)
(#t (let ((i (- i 1)))
(cond ((char=? (string-ref str i) chr)
i)
(#t
(loop i))))))))
(define (close-socket socket)
;;(close-port (cadr socket))
#f
)
)
(library (swank sys)
(export implementation-name eval-in-interaction-environment)
(import (rnrs)
(primitives system-features
aeryn-evaluator))
(define (implementation-name) "larceny")
;; see $LARCENY/r6rsmode.sch:
;; Larceny's ERR5RS and R6RS modes.
;; Code names:
;; Aeryn ERR5RS
;; D'Argo R6RS-compatible
;; Spanky R6RS-conforming (not yet implemented)
(define (eval-in-interaction-environment form)
(aeryn-evaluator form))
)
(import (rnrs) (rnrs eval) (larceny load))
(load "swank-r6rs.scm")
(eval '(start-server #f) (environment '(swank)))

91
elpa/slime-20180413.1720/contrib/swank-listener-hooks.lisp Normal file
View File

@@ -0,0 +1,91 @@
;;; swank-listener-hooks.lisp --- listener with special hooks
;;
;; Author: Alan Ruttenberg <alanr-l@mumble.net>
;; Provides *slime-repl-eval-hooks* special variable which
;; can be used for easy interception of SLIME REPL form evaluation
;; for purposes such as integration with application event loop.
(in-package :swank)
(eval-when (:compile-toplevel :load-toplevel :execute)
(swank-require :swank-repl))
(defvar *slime-repl-advance-history* nil
"In the dynamic scope of a single form typed at the repl, is set to nil to
prevent the repl from advancing the history - * ** *** etc.")
(defvar *slime-repl-suppress-output* nil
"In the dynamic scope of a single form typed at the repl, is set to nil to
prevent the repl from printing the result of the evalation.")
(defvar *slime-repl-eval-hook-pass* (gensym "PASS")
"Token to indicate that a repl hook declines to evaluate the form")
(defvar *slime-repl-eval-hooks* nil
"A list of functions. When the repl is about to eval a form, first try running each of
these hooks. The first hook which returns a value which is not *slime-repl-eval-hook-pass*
is considered a replacement for calling eval. If there are no hooks, or all
pass, then eval is used.")
(export '*slime-repl-eval-hooks*)
(defslimefun repl-eval-hook-pass ()
"call when repl hook declines to evaluate the form"
(throw *slime-repl-eval-hook-pass* *slime-repl-eval-hook-pass*))
(defslimefun repl-suppress-output ()
"In the dynamic scope of a single form typed at the repl, call to
prevent the repl from printing the result of the evalation."
(setq *slime-repl-suppress-output* t))
(defslimefun repl-suppress-advance-history ()
"In the dynamic scope of a single form typed at the repl, call to
prevent the repl from advancing the history - * ** *** etc."
(setq *slime-repl-advance-history* nil))
(defun %eval-region (string)
(with-input-from-string (stream string)
(let (- values)
(loop
(let ((form (read stream nil stream)))
(when (eq form stream)
(fresh-line)
(finish-output)
(return (values values -)))
(setq - form)
(if *slime-repl-eval-hooks*
(setq values (run-repl-eval-hooks form))
(setq values (multiple-value-list (eval form))))
(finish-output))))))
(defun run-repl-eval-hooks (form)
(loop for hook in *slime-repl-eval-hooks*
for res = (catch *slime-repl-eval-hook-pass*
(multiple-value-list (funcall hook form)))
until (not (eq res *slime-repl-eval-hook-pass*))
finally (return
(if (eq res *slime-repl-eval-hook-pass*)
(multiple-value-list (eval form))
res))))
(defun %listener-eval (string)
(clear-user-input)
(with-buffer-syntax ()
(swank-repl::track-package
(lambda ()
(let ((*slime-repl-suppress-output* :unset)
(*slime-repl-advance-history* :unset))
(multiple-value-bind (values last-form) (%eval-region string)
(unless (or (and (eq values nil) (eq last-form nil))
(eq *slime-repl-advance-history* nil))
(setq *** ** ** * * (car values)
/// // // / / values))
(setq +++ ++ ++ + + last-form)
(unless (eq *slime-repl-suppress-output* t)
(funcall swank-repl::*send-repl-results-function* values)))))))
nil)
(setq swank-repl::*listener-eval-function* '%listener-eval)
(provide :swank-listener-hooks)

227
elpa/slime-20180413.1720/contrib/swank-macrostep.lisp Normal file
View File

@@ -0,0 +1,227 @@
;;; swank-macrostep.lisp -- fancy macro-expansion via macrostep.el
;;
;; Authors: Luis Oliveira <luismbo@gmail.com>
;; Jon Oddie <j.j.oddie@gmail.com>
;;
;; License: Public Domain
(defpackage swank-macrostep
(:use cl swank)
(:import-from swank
#:*macroexpand-printer-bindings*
#:with-buffer-syntax
#:with-bindings
#:to-string
#:macroexpand-all
#:compiler-macroexpand-1
#:defslimefun
#:collect-macro-forms)
(:export #:macrostep-expand-1
#:macro-form-p))
(in-package #:swank-macrostep)
(defslimefun macrostep-expand-1 (string compiler-macros? context)
(with-buffer-syntax ()
(let ((form (read-from-string string)))
(multiple-value-bind (expansion error-message)
(expand-form-once form compiler-macros? context)
(if error-message
`(:error ,error-message)
(multiple-value-bind (macros compiler-macros)
(collect-macro-forms-in-context expansion context)
(let* ((all-macros (append macros compiler-macros))
(pretty-expansion (pprint-to-string expansion))
(positions (collect-form-positions expansion
pretty-expansion
all-macros))
(subform-info
(loop
for form in all-macros
for (start end) in positions
when (and start end)
collect (let ((op-name (to-string (first form)))
(op-type
(if (member form macros)
:macro
:compiler-macro)))
(list op-name
op-type
start)))))
`(:ok ,pretty-expansion ,subform-info))))))))
(defun expand-form-once (form compiler-macros? context)
(multiple-value-bind (expansion expanded?)
(macroexpand-1-in-context form context)
(if expanded?
(values expansion nil)
(if (not compiler-macros?)
(values nil "Not a macro form")
(multiple-value-bind (expansion expanded?)
(compiler-macroexpand-1 form)
(if expanded?
(values expansion nil)
(values nil "Not a macro or compiler-macro form")))))))
(defslimefun macro-form-p (string compiler-macros? context)
(with-buffer-syntax ()
(let ((form
(handler-case
(read-from-string string)
(error (condition)
(unless (debug-on-swank-error)
(return-from macro-form-p
`(:error ,(format nil "Read error: ~A" condition))))))))
`(:ok ,(macro-form-type form compiler-macros? context)))))
(defun macro-form-type (form compiler-macros? context)
(cond
((or (not (consp form))
(not (symbolp (car form))))
nil)
((multiple-value-bind (expansion expanded?)
(macroexpand-1-in-context form context)
(declare (ignore expansion))
expanded?)
:macro)
((and compiler-macros?
(multiple-value-bind (expansion expanded?)
(compiler-macroexpand-1 form)
(declare (ignore expansion))
expanded?))
:compiler-macro)
(t
nil)))
;;;; Hacks to support macro-expansion within local context
(defparameter *macrostep-tag* (gensym))
(defparameter *macrostep-placeholder* '*macrostep-placeholder*)
(define-condition expansion-in-context-failed (simple-error)
())
(defmacro throw-expansion (form &environment env)
(throw *macrostep-tag* (macroexpand-1 form env)))
(defmacro throw-collected-macro-forms (form &environment env)
(throw *macrostep-tag* (collect-macro-forms form env)))
(defun macroexpand-1-in-context (form context)
(handler-case
(macroexpand-and-catch
`(throw-expansion ,form) context)
(error ()
(macroexpand-1 form))))
(defun collect-macro-forms-in-context (form context)
(handler-case
(macroexpand-and-catch
`(throw-collected-macro-forms ,form) context)
(error ()
(collect-macro-forms form))))
(defun macroexpand-and-catch (form context)
(catch *macrostep-tag*
(macroexpand-all (enclose-form-in-context form context))
(error 'expansion-in-context-failed)))
(defun enclose-form-in-context (form context)
(with-buffer-syntax ()
(destructuring-bind (prefix suffix) context
(let* ((placeholder-form
(read-from-string
(concatenate
'string
prefix (prin1-to-string *macrostep-placeholder*) suffix)))
(substituted-form (subst form *macrostep-placeholder*
placeholder-form)))
(if (not (equal placeholder-form substituted-form))
substituted-form
(error 'expansion-in-context-failed))))))
;;;; Tracking Pretty Printer
(defun marker-char-p (char)
(<= #xe000 (char-code char) #xe8ff))
(defun make-marker-char (id)
;; using the private-use characters U+E000..U+F8FF as markers, so
;; that's our upper limit for how many we can use.
(assert (<= 0 id #x8ff))
(code-char (+ #xe000 id)))
(defun marker-char-id (char)
(assert (marker-char-p char))
(- (char-code char) #xe000))
(defparameter +whitespace+ (mapcar #'code-char '(9 13 10 32)))
(defun whitespacep (char)
(member char +whitespace+))
(defun pprint-to-string (object &optional pprint-dispatch)
(let ((*print-pprint-dispatch* (or pprint-dispatch *print-pprint-dispatch*)))
(with-bindings *macroexpand-printer-bindings*
(to-string object))))
#-clisp
(defun collect-form-positions (expansion printed-expansion forms)
(loop for (start end)
in (collect-marker-positions
(pprint-to-string expansion (make-tracking-pprint-dispatch forms))
(length forms))
collect (when (and start end)
(list (find-non-whitespace-position printed-expansion start)
(find-non-whitespace-position printed-expansion end)))))
;; The pprint-dispatch table constructed by
;; MAKE-TRACKING-PPRINT-DISPATCH causes an infinite loop and stack
;; overflow under CLISP version 2.49. Make the COLLECT-FORM-POSITIONS
;; entry point a no-op in thi case, so that basic macro-expansion will
;; still work (without detection of inner macro forms)
#+clisp
(defun collect-form-positions (expansion printed-expansion forms)
nil)
(defun make-tracking-pprint-dispatch (forms)
(let ((original-table *print-pprint-dispatch*)
(table (copy-pprint-dispatch)))
(flet ((maybe-write-marker (position stream)
(when position
(write-char (make-marker-char position) stream))))
(set-pprint-dispatch 'cons
(lambda (stream cons)
(let ((pos (position cons forms)))
(maybe-write-marker pos stream)
;; delegate printing to the original table.
(funcall (pprint-dispatch cons original-table)
stream
cons)
(maybe-write-marker pos stream)))
most-positive-fixnum
table))
table))
(defun collect-marker-positions (string position-count)
(let ((positions (make-array position-count :initial-element nil)))
(loop with p = 0
for char across string
unless (whitespacep char)
do (if (marker-char-p char)
(push p (aref positions (marker-char-id char)))
(incf p)))
(map 'list #'reverse positions)))
(defun find-non-whitespace-position (string position)
(loop with non-whitespace-position = -1
for i from 0 and char across string
unless (whitespacep char)
do (incf non-whitespace-position)
until (eql non-whitespace-position position)
finally (return i)))
(provide :swank-macrostep)

25
elpa/slime-20180413.1720/contrib/swank-media.lisp Normal file
View File

@@ -0,0 +1,25 @@
;;; swank-media.lisp --- insert other media (images)
;;
;; Authors: Christophe Rhodes <csr21@cantab.net>
;;
;; Licence: GPLv2 or later
;;
(in-package :swank)
;; this file is empty of functionality. The slime-media contrib
;; allows swank to return messages other than :write-string as repl
;; results; this is used in the R implementation of swank to display R
;; objects with graphical representations (such as trellis objects) as
;; image presentations in the swank repl. In R, this is done by
;; having a hook function for the preparation of the repl results, in
;; addition to the already-existing hook for sending the repl results
;; (*send-repl-results-function*, used by swank-presentations.lisp).
;; The swank-media.R contrib implementation defines a generic function
;; for use as this hook, along with methods for commonly-encountered
;; graphical R objects. (This strategy is harder in CL, where methods
;; can only be defined if their specializers already exist; in R's S3
;; object system, methods are ordinary functions with a special naming
;; convention)
(provide :swank-media)

870
elpa/slime-20180413.1720/contrib/swank-mit-scheme.scm Normal file
View File

@@ -0,0 +1,870 @@
;;; swank-mit-scheme.scm --- SLIME server for MIT Scheme
;;
;; Copyright (C) 2008 Helmut Eller
;;
;; This file is licensed under the terms of the GNU General Public
;; License as distributed with Emacs (press C-h C-c for details).
;;;; Installation:
#|
1. You need MIT Scheme 9.2
2. The Emacs side needs some fiddling. I have the following in
my .emacs:
(setq slime-lisp-implementations
'((mit-scheme ("mit-scheme") :init mit-scheme-init)))
(defun mit-scheme-init (file encoding)
(format "%S\n\n"
`(begin
(load-option 'format)
(load-option 'sos)
(eval
'(create-package-from-description
(make-package-description '(swank) (list (list))
(vector) (vector) (vector) false))
(->environment '(package)))
(load ,(expand-file-name
".../contrib/swank-mit-scheme.scm" ; <-- insert your path
slime-path)
(->environment '(swank)))
(eval '(start-swank ,file) (->environment '(swank))))))
(defun mit-scheme ()
(interactive)
(slime 'mit-scheme))
(defun find-mit-scheme-package ()
(save-excursion
(let ((case-fold-search t))
(and (re-search-backward "^[;]+ package: \\((.+)\\).*$" nil t)
(match-string-no-properties 1)))))
(setq slime-find-buffer-package-function 'find-mit-scheme-package)
(add-hook 'scheme-mode-hook (lambda () (slime-mode 1)))
The `mit-scheme-init' function first loads the SOS and FORMAT
libraries, then creates a package "(swank)", and loads this file
into that package. Finally it starts the server.
`find-mit-scheme-package' tries to figure out which package the
buffer belongs to, assuming that ";;; package: (FOO)" appears
somewhere in the file. Luckily, this assumption is true for many of
MIT Scheme's own files. Alternatively, you could add Emacs style
-*- slime-buffer-package: "(FOO)" -*- file variables.
4. Start everything with `M-x mit-scheme'.
|#
;;; package: (swank)
(if (< (car (get-subsystem-version "Release"))
'9)
(error "This file requires MIT Scheme Release 9"))
(define (swank port)
(accept-connections (or port 4005) #f))
;; ### hardcoded port number for now. netcat-openbsd doesn't print
;; the listener port anymore.
(define (start-swank port-file)
(accept-connections 4055 port-file)
)
;;;; Networking
(define (accept-connections port port-file)
(let ((sock (open-tcp-server-socket port (host-address-loopback))))
(format #t "Listening on port: ~s~%" port)
(if port-file (write-port-file port port-file))
(dynamic-wind
(lambda () #f)
(lambda () (serve (tcp-server-connection-accept sock #t #f)))
(lambda () (close-tcp-server-socket sock)))))
(define (write-port-file portnumber filename)
(call-with-output-file filename (lambda (p) (write portnumber p))))
(define *top-level-restart* #f)
(define (serve socket)
(with-simple-restart
'disconnect "Close connection."
(lambda ()
(with-keyboard-interrupt-handler
(lambda () (main-loop socket))))))
(define (disconnect)
(format #t "Disconnecting ...~%")
(invoke-restart (find-restart 'disconnect)))
(define (main-loop socket)
(do () (#f)
(with-simple-restart
'abort "Return to SLIME top-level."
(lambda ()
(fluid-let ((*top-level-restart* (find-restart 'abort)))
(dispatch (read-packet socket) socket 0))))))
(define (with-keyboard-interrupt-handler fun)
(define (set-^G-handler exp)
(eval `(vector-set! keyboard-interrupt-vector (char->ascii #\G) ,exp)
(->environment '(runtime interrupt-handler))))
(dynamic-wind
(lambda () #f)
(lambda ()
(set-^G-handler
`(lambda (char) (with-simple-restart
'continue "Continue from interrupt."
(lambda () (error "Keyboard Interrupt.")))))
(fun))
(lambda ()
(set-^G-handler '^G-interrupt-handler))))
;;;; Reading/Writing of SLIME packets
(define (read-packet in)
"Read an S-expression from STREAM using the SLIME protocol."
(let* ((len (read-length in))
(buffer (make-string len)))
(fill-buffer! in buffer)
(read-from-string buffer)))
(define (write-packet message out)
(let* ((string (write-to-string message)))
(log-event "WRITE: [~a]~s~%" (string-length string) string)
(write-length (string-length string) out)
(write-string string out)
(flush-output out)))
(define (fill-buffer! in buffer)
(read-string! buffer in))
(define (read-length in)
(if (eof-object? (peek-char in)) (disconnect))
(do ((len 6 (1- len))
(sum 0 (+ (* sum 16) (char->hex-digit (read-char in)))))
((zero? len) sum)))
(define (ldb size position integer)
"LoaD a Byte of SIZE bits at bit position POSITION from INTEGER."
(fix:and (fix:lsh integer (- position))
(1- (fix:lsh 1 size))))
(define (write-length len out)
(do ((pos 20 (- pos 4)))
((< pos 0))
(write-hex-digit (ldb 4 pos len) out)))
(define (write-hex-digit n out)
(write-char (hex-digit->char n) out))
(define (hex-digit->char n)
(digit->char n 16))
(define (char->hex-digit c)
(char->digit c 16))
;;;; Event dispatching
(define (dispatch request socket level)
(log-event "READ: ~s~%" request)
(case (car request)
((:emacs-rex) (apply emacs-rex socket level (cdr request)))))
(define (swank-package)
(or (name->package '(swank))
(name->package '(user))))
(define *buffer-package* #f)
(define (find-buffer-package name)
(if (elisp-false? name)
#f
(let ((v (ignore-errors
(lambda () (name->package (read-from-string name))))))
(and (package? v) v))))
(define swank-env (->environment (swank-package)))
(define (user-env buffer-package)
(cond ((string? buffer-package)
(let ((p (find-buffer-package buffer-package)))
(if (not p) (error "Invalid package name: " buffer-package))
(package/environment p)))
(else (nearest-repl/environment))))
;; quote keywords
(define (hack-quotes list)
(map (lambda (x)
(cond ((symbol? x) `(quote ,x))
(#t x)))
list))
(define (emacs-rex socket level sexp package thread id)
(let ((ok? #f) (result #f) (condition #f))
(dynamic-wind
(lambda () #f)
(lambda ()
(bind-condition-handler
(list condition-type:serious-condition)
(lambda (c) (set! condition c) (invoke-sldb socket (1+ level) c))
(lambda ()
(fluid-let ((*buffer-package* package))
(set! result
(eval (cons* (car sexp) socket (hack-quotes (cdr sexp)))
swank-env))
(set! ok? #t)))))
(lambda ()
(write-packet `(:return
,(if ok? `(:ok ,result)
`(:abort
,(if condition
(format #f "~a"
(condition/type condition))
"<unknown reason>")))
,id)
socket)))))
(define (swank:connection-info _)
(let ((p (environment->package (user-env #f))))
`(:pid ,(unix/current-pid)
:package (:name ,(write-to-string (package/name p))
:prompt ,(write-to-string (package/name p)))
:lisp-implementation
(:type "MIT Scheme" :version ,(get-subsystem-version-string "release"))
:encoding (:coding-systems ("iso-8859-1"))
)))
(define (swank:quit-lisp _)
(%exit))
;;;; Evaluation
(define (swank-repl:listener-eval socket string)
;;(call-with-values (lambda () (eval-region string socket))
;; (lambda values `(:values . ,(map write-to-string values))))
`(:values ,(write-to-string (eval-region string socket))))
(define (eval-region string socket)
(let ((sexp (read-from-string string)))
(if (eof-object? exp)
(values)
(with-output-to-repl socket
(lambda () (eval sexp (user-env *buffer-package*)))))))
(define (with-output-to-repl socket fun)
(let ((p (make-port repl-port-type socket)))
(dynamic-wind
(lambda () #f)
(lambda () (with-output-to-port p fun))
(lambda () (flush-output p)))))
(define (swank:interactive-eval socket string)
;;(call-with-values (lambda () (eval-region string)) format-for-echo-area)
(format-values (eval-region string socket))
)
(define (format-values . values)
(if (null? values)
"; No value"
(with-string-output-port
(lambda (out)
(write-string "=> " out)
(do ((vs values (cdr vs))) ((null? vs))
(write (car vs) out)
(if (not (null? (cdr vs)))
(write-string ", " out)))))))
(define (swank:pprint-eval _ string)
(pprint-to-string (eval (read-from-string string)
(user-env *buffer-package*))))
(define (swank:interactive-eval-region socket string)
(format-values (eval-region string socket)))
(define (swank:set-package _ package)
(set-repl/environment! (nearest-repl)
(->environment (read-from-string package)))
(let* ((p (environment->package (user-env #f)))
(n (write-to-string (package/name p))))
(list n n)))
(define (repl-write-substring port string start end)
(cond ((< start end)
(write-packet `(:write-string ,(substring string start end))
(port/state port))))
(- end start))
(define (repl-write-char port char)
(write-packet `(:write-string ,(string char))
(port/state port)))
(define repl-port-type
(make-port-type `((write-substring ,repl-write-substring)
(write-char ,repl-write-char)) #f))
(define (swank-repl:create-repl socket . _)
(let* ((env (user-env #f))
(name (format #f "~a" (package/name (environment->package env)))))
(list name name)))
;;;; Compilation
(define (swank:compile-string-for-emacs _ string . x)
(apply
(lambda (errors seconds)
`(:compilation-result ,errors t ,seconds nil nil))
(call-compiler
(lambda ()
(let* ((sexps (snarf-string string))
(env (user-env *buffer-package*))
(scode (syntax `(begin ,@sexps) env))
(compiled-expression (compile-scode scode #t)))
(scode-eval compiled-expression env))))))
(define (snarf-string string)
(with-input-from-string string
(lambda ()
(let loop ()
(let ((e (read)))
(if (eof-object? e) '() (cons e (loop))))))))
(define (call-compiler fun)
(let ((time #f))
(with-timings fun
(lambda (run-time gc-time real-time)
(set! time real-time)))
(list 'nil (internal-time/ticks->seconds time))))
(define (swank:compiler-notes-for-emacs _) nil)
(define (swank:compile-file-for-emacs socket file load?)
(apply
(lambda (errors seconds)
(list ':compilation-result errors 't seconds load?
(->namestring (pathname-name file))))
(call-compiler
(lambda () (with-output-to-repl socket (lambda () (compile-file file)))))))
(define (swank:load-file socket file)
(with-output-to-repl socket
(lambda ()
(pprint-to-string
(load file (user-env *buffer-package*))))))
(define (swank:disassemble-form _ string)
(let ((sexp (let ((sexp (read-from-string string)))
(cond ((and (pair? sexp) (eq? (car sexp) 'quote))
(cadr sexp))
(#t sexp)))))
(with-output-to-string
(lambda ()
(compiler:disassemble
(eval sexp (user-env *buffer-package*)))))))
(define (swank:disassemble-symbol _ string)
(with-output-to-string
(lambda ()
(compiler:disassemble
(eval (read-from-string string)
(user-env *buffer-package*))))))
;;;; Macroexpansion
(define (swank:swank-macroexpand-all _ string)
(with-output-to-string
(lambda ()
(pp (syntax (read-from-string string)
(user-env *buffer-package*))))))
(define swank:swank-macroexpand-1 swank:swank-macroexpand-all)
(define swank:swank-macroexpand swank:swank-macroexpand-all)
;;; Arglist
(define (swank:operator-arglist socket name pack)
(let ((v (ignore-errors
(lambda ()
(string-trim-right
(with-output-to-string
(lambda ()
(carefully-pa
(eval (read-from-string name) (user-env pack))))))))))
(if (condition? v) 'nil v)))
(define (carefully-pa o)
(cond ((arity-dispatched-procedure? o)
;; MIT Scheme crashes for (pa /)
(display "arity-dispatched-procedure"))
((procedure? o) (pa o))
(else (error "Not a procedure"))))
;;; Some unimplemented stuff.
(define (swank:buffer-first-change . _) nil)
(define (swank:filename-to-modulename . _) nil)
(define (swank:swank-require . _) nil)
;; M-. is beyond my capabilities.
(define (swank:find-definitions-for-emacs . _) nil)
;;; Debugger
(define-structure (sldb-state (conc-name sldb-state.)) condition restarts)
(define *sldb-state* #f)
(define (invoke-sldb socket level condition)
(fluid-let ((*sldb-state* (make-sldb-state condition (bound-restarts))))
(dynamic-wind
(lambda () #f)
(lambda ()
(write-packet `(:debug 0 ,level ,@(sldb-info *sldb-state* 0 20))
socket)
(sldb-loop level socket))
(lambda ()
(write-packet `(:debug-return 0 ,level nil) socket)))))
(define (sldb-loop level socket)
(write-packet `(:debug-activate 0 ,level) socket)
(with-simple-restart
'abort (format #f "Return to SLDB level ~a." level)
(lambda () (dispatch (read-packet socket) socket level)))
(sldb-loop level socket))
(define (sldb-info state start end)
(let ((c (sldb-state.condition state))
(rs (sldb-state.restarts state)))
(list (list (condition/report-string c)
(format #f " [~a]" (%condition-type/name (condition/type c)))
nil)
(sldb-restarts rs)
(sldb-backtrace c start end)
;;'((0 "dummy frame"))
'())))
(define %condition-type/name
(eval '%condition-type/name (->environment '(runtime error-handler))))
(define (sldb-restarts restarts)
(map (lambda (r)
(list (symbol->string (restart/name r))
(with-string-output-port
(lambda (p) (write-restart-report r p)))))
restarts))
(define (swank:throw-to-toplevel . _)
(invoke-restart *top-level-restart*))
(define (swank:sldb-abort . _)
(abort (sldb-state.restarts *sldb-state*)))
(define (swank:sldb-continue . _)
(continue (sldb-state.restarts *sldb-state*)))
(define (swank:invoke-nth-restart-for-emacs _ _sldb-level n)
(invoke-restart (list-ref (sldb-state.restarts *sldb-state*) n)))
(define (swank:debugger-info-for-emacs _ from to)
(sldb-info *sldb-state* from to))
(define (swank:backtrace _ from to)
(sldb-backtrace (sldb-state.condition *sldb-state*) from to))
(define (sldb-backtrace condition from to)
(sldb-backtrace-aux (condition/continuation condition) from to))
(define (sldb-backtrace-aux k from to)
(let ((l (map frame>string (substream (continuation>frames k) from to))))
(let loop ((i from) (l l))
(if (null? l)
'()
(cons (list i (car l)) (loop (1+ i) (cdr l)))))))
;; Stack parser fails for this:
;; (map (lambda (x) x) "/tmp/x.x")
(define (continuation>frames k)
(let loop ((frame (continuation->stack-frame k)))
(cond ((not frame) (stream))
(else
(let ((next (ignore-errors
(lambda () (stack-frame/next-subproblem frame)))))
(cons-stream frame
(if (condition? next)
(stream next)
(loop next))))))))
(define (frame>string frame)
(if (condition? frame)
(format #f "Bogus frame: ~a ~a" frame
(condition/report-string frame))
(with-string-output-port (lambda (p) (print-frame frame p)))))
(define (print-frame frame port)
(define (invalid-subexpression? subexpression)
(or (debugging-info/undefined-expression? subexpression)
(debugging-info/unknown-expression? subexpression)))
(define (invalid-expression? expression)
(or (debugging-info/undefined-expression? expression)
(debugging-info/compiled-code? expression)))
(with-values (lambda () (stack-frame/debugging-info frame))
(lambda (expression environment subexpression)
(cond ((debugging-info/compiled-code? expression)
(write-string ";unknown compiled code" port))
((not (debugging-info/undefined-expression? expression))
(fluid-let ((*unparse-primitives-by-name?* #t))
(write
(unsyntax (if (invalid-subexpression? subexpression)
expression
subexpression))
port)))
((debugging-info/noise? expression)
(write-string ";" port)
(write-string ((debugging-info/noise expression) #f)
port))
(else
(write-string ";undefined expression" port))))))
(define (substream s from to)
(let loop ((i 0) (l '()) (s s))
(cond ((or (= i to) (stream-null? s)) (reverse l))
((< i from) (loop (1+ i) l (stream-cdr s)))
(else (loop (1+ i) (cons (stream-car s) l) (stream-cdr s))))))
(define (swank:frame-locals-and-catch-tags _ frame)
(list (map frame-var>elisp (frame-vars (sldb-get-frame frame)))
'()))
(define (frame-vars frame)
(with-values (lambda () (stack-frame/debugging-info frame))
(lambda (expression environment subexpression)
(cond ((environment? environment)
(environment>frame-vars environment))
(else '())))))
(define (environment>frame-vars environment)
(let loop ((e environment))
(cond ((environment->package e) '())
(else (append (environment-bindings e)
(if (environment-has-parent? e)
(loop (environment-parent e))
'()))))))
(define (frame-var>elisp b)
(list ':name (write-to-string (car b))
':value (cond ((null? (cdr b)) "{unavailable}")
(else (>line (cadr b))))
':id 0))
(define (sldb-get-frame index)
(stream-ref (continuation>frames
(condition/continuation
(sldb-state.condition *sldb-state*)))
index))
(define (frame-var-value frame var)
(let ((binding (list-ref (frame-vars frame) var)))
(cond ((cdr binding) (cadr binding))
(else unspecific))))
(define (swank:inspect-frame-var _ frame var)
(reset-inspector)
(inspect-object (frame-var-value (sldb-get-frame frame) var)))
;;;; Completion
(define (swank:simple-completions _ string package)
(let ((strings (all-completions string (user-env package) string-prefix?)))
(list (sort strings string<?)
(longest-common-prefix strings))))
(define (all-completions pattern env match?)
(let ((ss (map %symbol->string (environment-names env))))
(keep-matching-items ss (lambda (s) (match? pattern s)))))
;; symbol->string is too slow
(define %symbol->string symbol-name)
(define (environment-names env)
(append (environment-bound-names env)
(if (environment-has-parent? env)
(environment-names (environment-parent env))
'())))
(define (longest-common-prefix strings)
(define (common-prefix s1 s2)
(substring s1 0 (string-match-forward s1 s2)))
(reduce common-prefix "" strings))
;;;; Apropos
(define (swank:apropos-list-for-emacs _ name #!optional
external-only case-sensitive package)
(let* ((pkg (and (string? package)
(find-package (read-from-string package))))
(parent (and (not (default-object? external-only))
(elisp-false? external-only)))
(ss (append-map (lambda (p)
(map (lambda (s) (cons p s))
(apropos-list name p (and pkg parent))))
(if pkg (list pkg) (all-packages))))
(ss (sublist ss 0 (min (length ss) 200))))
(map (lambda (e)
(let ((p (car e)) (s (cdr e)))
(list ':designator (format #f "~a ~a" s (package/name p))
':variable (>line
(ignore-errors
(lambda () (package-lookup p s)))))))
ss)))
(define (swank:list-all-package-names . _)
(map (lambda (p) (write-to-string (package/name p)))
(all-packages)))
(define (all-packages)
(define (package-and-children package)
(append (list package)
(append-map package-and-children (package/children package))))
(package-and-children system-global-package))
;;;; Inspector
(define-structure (inspector-state (conc-name istate.))
object parts next previous content)
(define istate #f)
(define (reset-inspector)
(set! istate #f))
(define (swank:init-inspector _ string)
(reset-inspector)
(inspect-object (eval (read-from-string string)
(user-env *buffer-package*))))
(define (inspect-object o)
(let ((previous istate)
(content (inspect o))
(parts (make-eqv-hash-table)))
(set! istate (make-inspector-state o parts #f previous content))
(if previous (set-istate.next! previous istate))
(istate>elisp istate)))
(define (istate>elisp istate)
(list ':title (>line (istate.object istate))
':id (assign-index (istate.object istate) (istate.parts istate))
':content (prepare-range (istate.parts istate)
(istate.content istate)
0 500)))
(define (assign-index o parts)
(let ((i (hash-table/count parts)))
(hash-table/put! parts i o)
i))
(define (prepare-range parts content from to)
(let* ((cs (substream content from to))
(ps (prepare-parts cs parts)))
(list ps
(if (< (length cs) (- to from))
(+ from (length cs))
(+ to 1000))
from to)))
(define (prepare-parts ps parts)
(define (line label value)
`(,(format #f "~a: " label)
(:value ,(>line value) ,(assign-index value parts))
"\n"))
(append-map (lambda (p)
(cond ((string? p) (list p))
((symbol? p) (list (symbol->string p)))
(#t
(case (car p)
((line) (apply line (cdr p)))
(else (error "Invalid part:" p))))))
ps))
(define (swank:inspect-nth-part _ index)
(inspect-object (hash-table/get (istate.parts istate) index 'no-such-part)))
(define (swank:quit-inspector _)
(reset-inspector))
(define (swank:inspector-pop _)
(cond ((istate.previous istate)
(set! istate (istate.previous istate))
(istate>elisp istate))
(else 'nil)))
(define (swank:inspector-next _)
(cond ((istate.next istate)
(set! istate (istate.next istate))
(istate>elisp istate))
(else 'nil)))
(define (swank:inspector-range _ from to)
(prepare-range (istate.parts istate)
(istate.content istate)
from to))
(define-syntax stream*
(syntax-rules ()
((stream* tail) tail)
((stream* e1 e2 ...) (cons-stream e1 (stream* e2 ...)))))
(define (iline label value) `(line ,label ,value))
(define-generic inspect (o))
(define-method inspect ((o <object>))
(cond ((environment? o) (inspect-environment o))
((vector? o) (inspect-vector o))
((procedure? o) (inspect-procedure o))
((compiled-code-block? o) (inspect-code-block o))
;;((system-pair? o) (inspect-system-pair o))
((probably-scode? o) (inspect-scode o))
(else (inspect-fallback o))))
(define (inspect-fallback o)
(let* ((class (object-class o))
(slots (class-slots class)))
(stream*
(iline "Class" class)
(let loop ((slots slots))
(cond ((null? slots) (stream))
(else
(let ((n (slot-name (car slots))))
(stream* (iline n (slot-value o n))
(loop (cdr slots))))))))))
(define-method inspect ((o <pair>))
(if (or (pair? (cdr o)) (null? (cdr o)))
(inspect-list o)
(inspect-cons o)))
(define (inspect-cons o)
(stream (iline "car" (car o))
(iline "cdr" (cdr o))))
(define (inspect-list o)
(let loop ((i 0) (o o))
(cond ((null? o) (stream))
((or (pair? (cdr o)) (null? (cdr o)))
(stream* (iline i (car o))
(loop (1+ i) (cdr o))))
(else
(stream (iline i (car o))
(iline "tail" (cdr o)))))))
(define (inspect-environment o)
(stream*
(iline "(package)" (environment->package o))
(let loop ((bs (environment-bindings o)))
(cond ((null? bs)
(if (environment-has-parent? o)
(stream (iline "(<parent>)" (environment-parent o)))
(stream)))
(else
(let* ((b (car bs)) (s (car b)))
(cond ((null? (cdr b))
(stream* s " {" (environment-reference-type o s) "}\n"
(loop (cdr bs))))
(else
(stream* (iline s (cadr b))
(loop (cdr bs)))))))))))
(define (inspect-vector o)
(let ((len (vector-length o)))
(let loop ((i 0))
(cond ((= i len) (stream))
(else (stream* (iline i (vector-ref o i))
(loop (1+ i))))))))
(define (inspect-procedure o)
(cond ((primitive-procedure? o)
(stream (iline "name" (primitive-procedure-name o))
(iline "arity" (primitive-procedure-arity o))
(iline "doc" (primitive-procedure-documentation o))))
((compound-procedure? o)
(stream (iline "arity" (procedure-arity o))
(iline "lambda" (procedure-lambda o))
(iline "env" (ignore-errors
(lambda () (procedure-environment o))))))
(else
(stream
(iline "block" (compiled-entry/block o))
(with-output-to-string (lambda () (compiler:disassemble o)))))))
(define (inspect-code-block o)
(stream-append
(let loop ((i (compiled-code-block/constants-start o)))
(cond ((>= i (compiled-code-block/constants-end o)) (stream))
(else
(stream*
(iline i (system-vector-ref o i))
(loop (+ i compiled-code-block/bytes-per-object))))))
(stream (iline "debuginfo" (compiled-code-block/debugging-info o))
(iline "env" (compiled-code-block/environment o))
(with-output-to-string (lambda () (compiler:disassemble o))))))
(define (inspect-scode o)
(stream (pprint-to-string o)))
(define (probably-scode? o)
(define tests (list access? assignment? combination? comment?
conditional? definition? delay? disjunction? lambda?
quotation? sequence? the-environment? variable?))
(let loop ((tests tests))
(cond ((null? tests) #f)
(((car tests) o))
(else (loop (cdr tests))))))
(define (inspect-system-pair o)
(stream (iline "car" (system-pair-car o))
(iline "cdr" (system-pair-cdr o))))
;;;; Auxilary functions
(define nil '())
(define t 't)
(define (elisp-false? o) (member o '(nil ())))
(define (elisp-true? o) (not (elisp-false? o)))
(define (>line o)
(let ((r (write-to-string o 100)))
(cond ((not (car r)) (cdr r))
(else (string-append (cdr r) " ..")))))
;; Must compile >line otherwise we can't write unassigend-reference-traps.
(set! >line (compile-procedure >line))
(define (read-from-string s) (with-input-from-string s read))
(define (pprint-to-string o)
(with-string-output-port
(lambda (p)
(fluid-let ((*unparser-list-breadth-limit* 10)
(*unparser-list-depth-limit* 4)
(*unparser-string-length-limit* 100))
(pp o p)))))
;(define (1+ n) (+ n 1))
(define (1- n) (- n 1))
(define (package-lookup package name)
(let ((p (if (package? package) package (find-package package))))
(environment-lookup (package/environment p) name)))
(define log-port (current-output-port))
(define (log-event fstring . args)
;;(apply format log-port fstring args)
#f
)
;;; swank-mit-scheme.scm ends here

348
elpa/slime-20180413.1720/contrib/swank-mlworks.sml Normal file
View File

@@ -0,0 +1,348 @@
(* swank-mlworks.sml -- SWANK server for MLWorks
*
* This code has been placed in the Public Domain.
*)
(* This is an experiment to see how the interfaces/modules would look
* in a language with a supposedly "good" module system.
*
* MLWorks is probably the only SML implementation that tries to
* support "interactive programming". Since MLWorks wasn't maintained
* the last 15 or so years, big chunks of the SML Basis Library are
* missing or not the way as required by the standard. That makes it
* rather hard to do anything; it also shows that MLWorks hasn't been
* "used in anger" for a long time.
*)
structure Swank = struct
structure Util = struct
fun utf8ToString (v:Word8Vector.vector) : string = Byte.bytesToString v
fun stringToUtf8 s = Byte.stringToBytes s
end
structure Map = struct
datatype ('a, 'b) map = Alist of {list: ('a * 'b) list ref,
eq: ('a * 'a) -> bool}
fun stringMap () =
Alist {list = ref [],
eq = (fn (x:string,y:string) => x = y)}
fun lookup (Alist {list, eq}, key) =
let fun search [] = NONE
| search ((key', value) :: xs) =
if eq (key', key) then SOME value
else search xs
in search (!list)
end
fun put (Alist {list, eq}, key, value) =
let val l = (key, value) :: (!list)
in list := l
end
end
structure CharBuffer = struct
local
structure C = CharArray
datatype buffer = B of {array : C.array ref,
index: int ref}
in
fun new hint = B {array = ref (C.array (hint, #"\000")),
index = ref 0}
fun append (buffer as B {array, index}, char) =
let val a = !array
val i = !index
val len = C.length a
in if i < len then
(C.update (a, i, char);
index := i + 1;
())
else let val aa = C.array (2 * len, #"\000")
fun copy (src, dst) =
let val len = C.length src
fun loop i =
if i = len then ()
else (C.update (dst, i, C.sub (src, i));
loop (i + 1))
in loop 0 end
in copy (a, aa);
C.update (aa, i, char);
array := aa;
index := i + 1;
()
end
end
fun toString (B {array, index}) =
let val a = !array
val i = !index
in CharVector.tabulate (i, fn i => C.sub (a, i)) end
end
end
structure Sexp = struct
structure Type = struct
datatype sexp = Int of int
| Str of string
| Lst of sexp list
| Sym of string
| QSym of string * string
| T
| Nil
| Quote
end
open Type
exception ReadError
fun fromUtf8 v =
let val len = Word8Vector.length v
val index = ref 0
fun getc () =
case getc' () of
SOME c => c
| NONE => raise ReadError
and getc' () =
let val i = !index
in if i = len then NONE
else (index := i + 1;
SOME (Byte.byteToChar (Word8Vector.sub (v, i))))
end
and ungetc () = index := !index - 1
and sexp () : sexp =
case getc () of
#"\"" => string (CharBuffer.new 100)
| #"(" => lst ()
| #"'" => Lst [Quote, sexp ()]
| _ => (ungetc(); token ())
and string buf : sexp =
case getc () of
#"\"" => Str (CharBuffer.toString buf)
| #"\\" => (CharBuffer.append (buf, getc ()); string buf)
| c => (CharBuffer.append (buf, c); string buf)
and lst () =
let val x = sexp ()
in case getc () of
#")" => Lst [x]
| #" " => let val Lst y = lst () in Lst (x :: y) end
| _ => raise ReadError
end
and token () =
let val tok = token' (CharBuffer.new 50)
val c0 = String.sub (tok, 0)
in if Char.isDigit c0 then (case Int.fromString tok of
SOME i => Int i
| NONE => raise ReadError)
else
Sym (tok)
end
and token' buf : string =
case getc' () of
NONE => CharBuffer.toString buf
| SOME #"\\" => (CharBuffer.append (buf, getc ());
token' buf)
| SOME #" " => (ungetc (); CharBuffer.toString buf)
| SOME #")" => (ungetc (); CharBuffer.toString buf)
| SOME c => (CharBuffer.append (buf, c); token' buf)
in
sexp ()
end
fun toString sexp =
case sexp of
(Str s) => "\"" ^ String.toCString s ^ "\""
| (Lst []) => "nil"
| (Lst xs) => "(" ^ String.concatWith " " (map toString xs) ^ ")"
| Sym (name) => name
| QSym (pkg, name) => pkg ^ ":" ^ name
| Quote => "quote"
| T => "t"
| Nil => "nil"
| Int i => Int.toString i
fun toUtf8 sexp = Util.stringToUtf8 (toString sexp)
end
structure Net = struct
local
structure S = Socket
structure I = INetSock
structure W = Word8Vector
fun createSocket (port) =
let val sock : S.passive I.stream_sock = I.TCP.socket ()
val SOME localhost = NetHostDB.fromString "127.0.0.1"
in
S.Ctl.setREUSEADDR (sock, true);
S.bind (sock, I.toAddr (localhost, port));
S.listen (sock, 2);
sock
end
fun addrToString sockAddr =
let val (ip, port) = I.fromAddr sockAddr
in NetHostDB.toString ip ^ ":" ^ Int.toString port
end
exception ShortRead of W.vector
exception InvalidHexString of string
in
fun acceptConnection port =
let val sock = createSocket port
val addr = S.Ctl.getSockName sock
val _ = print ("Listening on: " ^ addrToString addr ^ "\n")
val (peer, addr) = S.accept sock
in
S.close sock;
print ("Connection from: " ^ addrToString addr ^ "\n");
peer
end
fun receivePacket socket =
let val v = S.recvVec (socket, 6)
val _ = if W.length v = 6 then ()
else raise ShortRead v
val s = Util.utf8ToString v
val _ = print ("s = " ^ s ^ "\n")
val len =
case StringCvt.scanString (Int.scan StringCvt.HEX) s of
SOME len => len
| NONE => raise InvalidHexString s
val _ = print ("len = " ^ Int.toString len ^ "\n")
val payload = S.recvVec (socket, len)
val plen = W.length payload
val _ = print ("plen = " ^ Int.toString plen ^ "\n")
val _ = if plen = len then ()
else raise ShortRead payload
in
payload
end
fun nibbleToHex i:string = Int.fmt StringCvt.HEX i
fun loadNibble i pos =
Word32.toInt (Word32.andb (Word32.>> (Word32.fromInt i,
Word.fromInt (pos * 4)),
0wxf))
fun hexDigit i pos = nibbleToHex (loadNibble i pos)
fun lenToHex i =
concat [hexDigit i 5,
hexDigit i 4,
hexDigit i 3,
hexDigit i 2,
hexDigit i 1,
hexDigit i 0]
fun sendPacket (payload:W.vector, socket) =
let val len = W.length payload
val header = Util.stringToUtf8 (lenToHex len)
val packet = W.concat [header, payload]
in print ("len = " ^ Int.toString len ^ "\n"
^ "header = " ^ lenToHex len ^ "\n"
^ "paylad = " ^ Util.utf8ToString payload ^ "\n");
S.sendVec (socket, {buf = packet, i = 0, sz = NONE})
end
end
end
structure Rpc = struct
open Sexp.Type
val funTable : (string, sexp list -> sexp) Map.map
= Map.stringMap ()
fun define name f = Map.put (funTable, name, f)
exception UnknownFunction of string
fun call (name, args) =
(print ("call: " ^ name ^ "\n");
case Map.lookup (funTable, name) of
SOME f => f args
| NONE => raise UnknownFunction name)
local fun getpid () =
Word32.toInt (Posix.Process.pidToWord (Posix.ProcEnv.getpid ()))
in
fun connectionInfo [] =
Lst [Sym ":pid", Int (getpid ()),
Sym ":lisp-implementation", Lst [Sym ":type", Str "MLWorks",
Sym ":name", Str "mlworks",
Sym ":version", Str "2.x"],
Sym ":machine", Lst [Sym ":instance", Str "",
Sym ":type", Str "",
Sym ":version", Str ""],
Sym ":features", Nil,
Sym ":package", Lst [Sym ":name", Str "root",
Sym ":prompt", Str "-"]]
end
fun nyi _ = Nil
local structure D = Shell.Dynamic
in
fun interactiveEval [Str string] =
let val x = D.eval string
in Str (concat [D.printValue x, " : ", D.printType (D.getType x)])
end
end
val _ =
(define "swank:connection-info" connectionInfo;
define "swank:swank-require" nyi;
define "swank:interactive-eval" interactiveEval;
())
end
structure EventLoop = struct
open Sexp.Type
fun execute (sexp, pkg) =
(print ("sexp = " ^ (Sexp.toString sexp) ^ "\n");
case sexp of
Lst (Sym name :: args) => Rpc.call (name, args))
fun emacsRex (sexp, pkg, id as Int _, sock) =
let val result = (Lst [Sym (":ok"), execute (sexp, pkg)]
handle exn => (Lst [Sym ":abort",
Str (exnName exn ^ ": "
^ exnMessage exn)]))
val reply = Lst [Sym ":return", result, id]
in Net.sendPacket (Sexp.toUtf8 reply, sock)
end
fun dispatch (Lst ((Sym key) :: args), sock) =
case key of
":emacs-rex" => let val [sexp, pkg, _, id] = args
in emacsRex (sexp, pkg, id, sock)
end
fun processRequests socket:unit =
let val sexp = Sexp.fromUtf8 (Net.receivePacket socket)
in print ("request: "
^ Util.utf8ToString (Sexp.toUtf8 sexp)
^ "\n");
dispatch (sexp, socket);
processRequests socket
end
end
(* val _ = EventLoop.processRequests (Net.acceptConnection 4005) *)
val _ = ()
end
(* (Swank.EventLoop.processRequests (Swank.Net.acceptConnection 4005)) *)

Some files were not shown because too many files have changed in this diff Show More