sbcl stuff
This commit is contained in:
Ian Keane
parent
1d1dbc34df
commit
5d91dbb667
335 changed files with 119806 additions and 1 deletions
|
|
@ -0,0 +1,199 @@
|
|||
(require 'slime-autodoc)
|
||||
(require 'slime-tests)
|
||||
(require 'cl-lib)
|
||||
|
||||
(defun slime-autodoc-to-string ()
|
||||
"Retrieve and return autodoc for form at point."
|
||||
(let ((autodoc (car (slime-eval
|
||||
`(swank:autodoc
|
||||
',(slime-autodoc--parse-context)
|
||||
:print-right-margin
|
||||
,(window-width (minibuffer-window)))))))
|
||||
(if (eq autodoc :not-available)
|
||||
:not-available
|
||||
(slime-autodoc--canonicalize-whitespace autodoc))))
|
||||
|
||||
(defun slime-check-autodoc-at-point (arglist)
|
||||
(slime-test-expect (format "Autodoc in `%s' (at %d) is as expected"
|
||||
(buffer-string) (point))
|
||||
arglist
|
||||
(slime-autodoc-to-string)))
|
||||
|
||||
(defmacro define-autodoc-tests (&rest specs)
|
||||
`(progn
|
||||
,@(cl-loop
|
||||
for (buffer-sexpr wished-arglist . options)
|
||||
in specs
|
||||
for fails-for = (plist-get options :fails-for)
|
||||
for skip-trailing-test-p = (plist-get options :skip-trailing-test-p)
|
||||
for i from 1
|
||||
when (featurep 'ert)
|
||||
collect `(define-slime-ert-test ,(intern (format "autodoc-tests-%d" i))
|
||||
()
|
||||
,(format "Check autodoc works ok for %s" buffer-sexpr)
|
||||
,@(if fails-for
|
||||
`(:expected-result
|
||||
'(satisfies
|
||||
(lambda (result)
|
||||
(ert-test-result-type-p
|
||||
result
|
||||
(if (member (slime-lisp-implementation-name)
|
||||
',fails-for)
|
||||
:failed
|
||||
:passed))))))
|
||||
(slime-sync-to-top-level 0.3)
|
||||
(slime-check-top-level)
|
||||
(with-temp-buffer
|
||||
(setq slime-buffer-package "COMMON-LISP-USER")
|
||||
(lisp-mode)
|
||||
(insert ,buffer-sexpr)
|
||||
(search-backward "*HERE*")
|
||||
(delete-region (match-beginning 0) (match-end 0))
|
||||
(should (equal ,wished-arglist
|
||||
(slime-autodoc-to-string)))
|
||||
(unless ,skip-trailing-test-p
|
||||
(insert ")") (backward-char)
|
||||
(should (equal ,wished-arglist
|
||||
(slime-autodoc-to-string)))))
|
||||
(slime-sync-to-top-level 0.3)))))
|
||||
|
||||
(define-autodoc-tests
|
||||
;; Test basics
|
||||
("(swank::emacs-connected*HERE*" "(emacs-connected)")
|
||||
("(swank::emacs-connected *HERE*" "(emacs-connected)")
|
||||
("(swank::create-socket*HERE*"
|
||||
"(create-socket host port &key backlog)")
|
||||
("(swank::create-socket *HERE*"
|
||||
"(create-socket ===> host <=== port &key backlog)")
|
||||
("(swank::create-socket foo *HERE*"
|
||||
"(create-socket host ===> port <=== &key backlog)")
|
||||
|
||||
;; Test that autodoc differentiates between exported and
|
||||
;; unexported symbols.
|
||||
("(swank:create-socket*HERE*" :not-available)
|
||||
|
||||
;; Test if cursor is on non-existing required parameter
|
||||
("(swank::create-socket foo bar *HERE*"
|
||||
"(create-socket host port &key backlog)")
|
||||
|
||||
;; Test cursor in front of opening parenthesis
|
||||
("(swank::with-struct *HERE*(foo. x y) *struct* body1)"
|
||||
"(with-struct (conc-name &rest names) obj &body body)"
|
||||
:skip-trailing-test-p t)
|
||||
|
||||
;; Test variable content display
|
||||
("(progn swank::default-server-port*HERE*"
|
||||
"DEFAULT-SERVER-PORT => 4005")
|
||||
|
||||
;; Test that "variable content display" is not triggered for
|
||||
;; trivial constants.
|
||||
("(swank::create-socket t*HERE*"
|
||||
"(create-socket ===> host <=== port &key backlog)")
|
||||
("(swank::create-socket :foo*HERE*"
|
||||
"(create-socket ===> host <=== port &key backlog)")
|
||||
|
||||
;; Test with syntactic sugar
|
||||
("#'(lambda () (swank::create-socket*HERE*"
|
||||
"(create-socket host port &key backlog)")
|
||||
("`(lambda () ,(swank::create-socket*HERE*"
|
||||
"(create-socket host port &key backlog)")
|
||||
("(remove-if #'(lambda () (swank::create-socket*HERE*"
|
||||
"(create-socket host port &key backlog)")
|
||||
("`(remove-if #'(lambda () ,@(swank::create-socket*HERE*"
|
||||
"(create-socket host port &key backlog)")
|
||||
|
||||
;; Test &optional
|
||||
("(swank::symbol-status foo *HERE*"
|
||||
"(symbol-status symbol &optional\
|
||||
===> (package (symbol-package symbol)) <===)" :fails-for ("allegro" "ccl"))
|
||||
|
||||
;; Test context-sensitive autodoc (DEFMETHOD)
|
||||
("(defmethod swank::arglist-dispatch (*HERE*"
|
||||
"(defmethod arglist-dispatch\
|
||||
(===> operator <=== arguments) &body body)")
|
||||
("(defmethod swank::arglist-dispatch :before (*HERE*"
|
||||
"(defmethod arglist-dispatch :before\
|
||||
(===> operator <=== arguments) &body body)")
|
||||
|
||||
;; Test context-sensitive autodoc (APPLY)
|
||||
("(apply 'swank::eval-for-emacs*HERE*"
|
||||
"(apply 'eval-for-emacs &optional form buffer-package id &rest args)")
|
||||
("(apply #'swank::eval-for-emacs*HERE*"
|
||||
"(apply #'eval-for-emacs &optional form buffer-package id &rest args)" :fails-for ("ccl"))
|
||||
("(apply 'swank::eval-for-emacs foo *HERE*"
|
||||
"(apply 'eval-for-emacs &optional form\
|
||||
===> buffer-package <=== id &rest args)")
|
||||
("(apply #'swank::eval-for-emacs foo *HERE*"
|
||||
"(apply #'eval-for-emacs &optional form\
|
||||
===> buffer-package <=== id &rest args)" :fails-for ("ccl"))
|
||||
|
||||
;; Test context-sensitive autodoc (ERROR, CERROR)
|
||||
("(error 'simple-condition*HERE*"
|
||||
"(error 'simple-condition &rest arguments\
|
||||
&key format-arguments format-control)" :fails-for ("ccl"))
|
||||
("(cerror \"Foo\" 'simple-condition*HERE*"
|
||||
"(cerror \"Foo\" 'simple-condition\
|
||||
&rest arguments &key format-arguments format-control)"
|
||||
:fails-for ("allegro" "ccl"))
|
||||
|
||||
;; Test &KEY and nested arglists
|
||||
("(swank::with-retry-restart (:msg *HERE*"
|
||||
"(with-retry-restart (&key ===> (msg \"Retry.\") <===) &body body)"
|
||||
:fails-for ("allegro" "ccl"))
|
||||
("(swank::with-retry-restart (:msg *HERE*(foo"
|
||||
"(with-retry-restart (&key ===> (msg \"Retry.\") <===) &body body)"
|
||||
:skip-trailing-test-p t
|
||||
:fails-for ("allegro" "ccl"))
|
||||
("(swank::start-server \"/tmp/foo\" :dont-close *HERE*"
|
||||
"(start-server port-file &key (style swank:*communication-style*)\
|
||||
===> (dont-close swank:*dont-close*) <===)"
|
||||
:fails-for ("allegro" "ccl"))
|
||||
|
||||
;; Test declarations and type specifiers
|
||||
("(declare (string *HERE*"
|
||||
"(declare (string &rest ===> variables <===))"
|
||||
:fails-for ("allegro") :fails-for ("ccl"))
|
||||
("(declare ((string *HERE*"
|
||||
"(declare ((string &optional ===> size <===) &rest variables))")
|
||||
("(declare (type (string *HERE*"
|
||||
"(declare (type (string &optional ===> size <===) &rest variables))")
|
||||
|
||||
;; Test local functions
|
||||
("(flet ((foo (x y) (+ x y))) (foo *HERE*" "(foo ===> x <=== y)")
|
||||
("(macrolet ((foo (x y) `(+ ,x ,y))) (foo *HERE*" "(foo ===> x <=== y)")
|
||||
("(labels ((foo (x y) (+ x y))) (foo *HERE*" "(foo ===> x <=== y)")
|
||||
("(labels ((foo (x y) (+ x y))
|
||||
(bar (y) (foo *HERE*"
|
||||
"(foo ===> x <=== y)" :fails-for ("cmucl" "sbcl" "allegro" "ccl")))
|
||||
|
||||
(def-slime-test autodoc-space
|
||||
(input-keys expected-message)
|
||||
"Emulate the inserting something followed by the space key
|
||||
event and verify that the right thing appears in the echo
|
||||
area (after a short delay)."
|
||||
'(("( s w a n k : : o p e r a t o r - a r g l i s t SPC"
|
||||
"(operator-arglist name package)"))
|
||||
(when noninteractive
|
||||
(slime-skip-test "Can't use unread-command-events in batch mode"))
|
||||
(let* ((keys (eval `(kbd ,input-keys)))
|
||||
(tag (cons nil nil))
|
||||
(timerfun (lambda (tag) (throw tag nil)))
|
||||
(timer (run-with-timer 0.1 nil timerfun tag)))
|
||||
(with-temp-buffer
|
||||
(lisp-mode)
|
||||
(unwind-protect
|
||||
(catch tag
|
||||
(message nil)
|
||||
(select-window (display-buffer (current-buffer) t))
|
||||
(setq unread-command-events (listify-key-sequence keys))
|
||||
(accept-process-output)
|
||||
(recursive-edit))
|
||||
(setq unread-command-events nil)
|
||||
(cancel-timer timer))
|
||||
(slime-test-expect "Message after SPC"
|
||||
expected-message (current-message))
|
||||
(accept-process-output nil (* eldoc-idle-delay 2))
|
||||
(slime-test-expect "Message after edloc delay"
|
||||
expected-message (current-message)))))
|
||||
|
||||
(provide 'slime-autodoc-tests)
|
||||
|
|
@ -0,0 +1,140 @@
|
|||
(require 'slime-c-p-c)
|
||||
(require 'slime-tests)
|
||||
|
||||
(def-slime-test completions
|
||||
(prefix expected-completions)
|
||||
"Find the completions of a symbol-name prefix."
|
||||
'(("cl:compile" (("cl:compile" "cl:compile-file" "cl:compile-file-pathname"
|
||||
"cl:compiled-function" "cl:compiled-function-p"
|
||||
"cl:compiler-macro" "cl:compiler-macro-function")
|
||||
"cl:compile"))
|
||||
("cl:foobar" nil)
|
||||
("swank::compile-file" (("swank::compile-file"
|
||||
"swank::compile-file-for-emacs"
|
||||
"swank::compile-file-if-needed"
|
||||
"swank::compile-file-output"
|
||||
"swank::compile-file-pathname")
|
||||
"swank::compile-file"))
|
||||
("cl:m-v-l" (("cl:multiple-value-list" "cl:multiple-values-limit") "cl:multiple-value"))
|
||||
("common-lisp" (("common-lisp-user:" "common-lisp:") "common-lisp")))
|
||||
(let ((completions (slime-completions prefix)))
|
||||
(slime-test-expect "Completion set" expected-completions completions)))
|
||||
|
||||
(def-slime-test complete-symbol*
|
||||
(buffer-sexp wished-completion &optional chosen-completion fancy unambiguous)
|
||||
"Ensure that completions are correctly inserted."
|
||||
'(("cl:and" "cl:and")
|
||||
("(cl:and" "(cl:and")
|
||||
("(cl:and)" "(cl:and)")
|
||||
("(cl:and)" "(cl:and)" nil nil t)
|
||||
;; Fancy completion of a form that accepts arguments should
|
||||
;; insert a space after the completed form.
|
||||
("(cl:and)" "(cl:and )" nil t)
|
||||
;; ...but only for symbols in the funcall position.
|
||||
("cl:and" "cl:and" nil t)
|
||||
;; Fancy completion of a form without arguments should insert a
|
||||
;; closing paren.
|
||||
("(cl:get-internal-run-time" "(cl:get-internal-run-time)" nil t)
|
||||
;; ...but only for symbols in the funcall position.
|
||||
("cl:get-internal-run-time" "cl:get-internal-run-time" nil t)
|
||||
("cl:m-v-b" "cl:multiple-value-bind")
|
||||
("cl:m-v-l" "cl:multiple-value-list" "cl:multiple-value-list")
|
||||
;; Fancy completion is only done for unique completions. This is
|
||||
;; not a hard requirement, and might change in the future. This
|
||||
;; test is included merely to document the current behavior.
|
||||
("(cl:m-v-l)" "(cl:multiple-value-list)" "cl:multiple-value-list" t)
|
||||
("cl:mult" "cl:multiple-value-call" "cl:multiple-value-call")
|
||||
("cl:multiple-value" "cl:multiple-value-setq" "cl:multiple-value-setq")
|
||||
("cl:compile" "cl:compile" "cl:compile")
|
||||
("cl:compile" "cl:compile-file" "cl:compile-file")
|
||||
("cl:f-o" "cl:force-output" "cl:force-output")
|
||||
;; When `slime-c-p-c-unambiguous-prefix-p' is non nil,
|
||||
;; `slime-complete-symbol*' will move point back to the
|
||||
;; unambiguous portion of the prefix; however, the final result
|
||||
;; after choosing a completion candidate should be the same.
|
||||
("cl:f-o" "cl:force-output" "cl:force-output" nil t)
|
||||
("(cl:f-o)" "(cl:force-output)" "cl:force-output" nil t)
|
||||
;; Character completions
|
||||
("#\\N" "#\\Newline")
|
||||
("#\\R" "#\\Return" "#\\Return")
|
||||
("#\\R" "#\\Rubout" "#\\Rubout" nil t)
|
||||
;; Keyword completions
|
||||
("(cl:find 'x '() :)" "(cl:find 'x '() :START)" ":START")
|
||||
("(cl:find 'x '() :S)" "(cl:find 'x '() :START)")
|
||||
("(cl:find 'x '() :s)" "(cl:find 'x '() :start)")
|
||||
("(cl:find 'x '() :s)" "(cl:find 'x '() :start)" nil t)
|
||||
("(cl:find 'x '() :t)" "(cl:find 'x '() :test)" ":test")
|
||||
("(cl:find 'x '() :t)" "(cl:find 'x '() :test-not)" ":test-not" nil t))
|
||||
(slime-check-top-level)
|
||||
(save-window-excursion
|
||||
(with-temp-buffer
|
||||
(lisp-mode)
|
||||
(setq slime-buffer-package "SWANK")
|
||||
(insert buffer-sexp)
|
||||
(when (eq (char-before) ?\))
|
||||
(backward-char))
|
||||
(let ((slime-c-p-c-unambiguous-prefix-p unambiguous)
|
||||
(slime-complete-symbol*-fancy fancy))
|
||||
(if (not fancy)
|
||||
(slime-complete-symbol*)
|
||||
;; `slime-complete-symbol*-fancy-bit' may call
|
||||
;; `execute-kbd-macro', which ultimately operates on the
|
||||
;; buffer associated with the selected window, not
|
||||
;; necessarily the current buffer. Call `pop-to-buffer' to
|
||||
;; ensure that the current buffer is in the selected window
|
||||
;; before calling `slime-complete-symbol*'. Fancy completion
|
||||
;; might also kick off a `slime-eval-async' in
|
||||
;; `slime-echo-arglist', so ensure the output is consumed
|
||||
;; with `slime-sync-to-top-level' before continuing.
|
||||
(pop-to-buffer (current-buffer))
|
||||
(slime-complete-symbol*)
|
||||
(slime-sync-to-top-level 1)))
|
||||
(when chosen-completion
|
||||
(with-selected-window slime-completions-window
|
||||
(goto-char (point-min))
|
||||
(search-forward chosen-completion)
|
||||
(choose-completion)))
|
||||
(slime-check-completed-form buffer-sexp wished-completion))))
|
||||
|
||||
(def-slime-test complete-form
|
||||
(buffer-sexpr wished-completion &optional skip-trailing-test-p)
|
||||
""
|
||||
'(("(defmethod arglist-dispatch *HERE*"
|
||||
"(defmethod arglist-dispatch (operator arguments) body...)")
|
||||
("(with-struct *HERE*"
|
||||
"(with-struct (conc-name names...) obj body...)")
|
||||
("(with-struct *HERE*"
|
||||
"(with-struct (conc-name names...) obj body...)")
|
||||
("(with-struct (*HERE*"
|
||||
"(with-struct (conc-name names...)" t)
|
||||
("(with-struct (foo. bar baz *HERE*"
|
||||
"(with-struct (foo. bar baz names...)" t))
|
||||
(slime-check-top-level)
|
||||
(with-temp-buffer
|
||||
(lisp-mode)
|
||||
(setq slime-buffer-package "SWANK")
|
||||
(insert buffer-sexpr)
|
||||
(search-backward "*HERE*")
|
||||
(delete-region (match-beginning 0) (match-end 0))
|
||||
(slime-complete-form)
|
||||
(slime-check-completed-form buffer-sexpr wished-completion)
|
||||
|
||||
;; Now the same but with trailing `)' for paredit users...
|
||||
(unless skip-trailing-test-p
|
||||
(erase-buffer)
|
||||
(insert buffer-sexpr)
|
||||
(search-backward "*HERE*")
|
||||
(delete-region (match-beginning 0) (match-end 0))
|
||||
(insert ")") (backward-char)
|
||||
(slime-complete-form)
|
||||
(slime-check-completed-form (concat buffer-sexpr ")") wished-completion))
|
||||
))
|
||||
|
||||
(defun slime-check-completed-form (buffer-sexpr wished-completion)
|
||||
(slime-test-expect (format "Completed form for `%s' is as expected"
|
||||
buffer-sexpr)
|
||||
wished-completion
|
||||
(buffer-string)
|
||||
'equal))
|
||||
|
||||
(provide 'slime-c-p-c-tests)
|
||||
File diff suppressed because it is too large
Load diff
|
|
@ -0,0 +1,46 @@
|
|||
(require 'slime-enclosing-context)
|
||||
(require 'slime-tests)
|
||||
(require 'cl-lib)
|
||||
|
||||
(def-slime-test enclosing-context.1
|
||||
(buffer-sexpr wished-bound-names wished-bound-functions)
|
||||
"Check that finding local definitions work."
|
||||
'(("(flet ((,nil ()))
|
||||
(let ((bar 13)
|
||||
(,foo 42))
|
||||
*HERE*))"
|
||||
;; We used to return ,foo here, but we do not anymore. We
|
||||
;; still return ,nil for the `slime-enclosing-bound-functions',
|
||||
;; though. The first one is used for local M-., whereas the
|
||||
;; latter is used for local autodoc. It does not seem too
|
||||
;; important for local M-. to work on such names. \(The reason
|
||||
;; that it does not work anymore, is that
|
||||
;; `slime-symbol-at-point' now does TRT and does not return a
|
||||
;; leading comma anymore.\)
|
||||
("bar" nil nil)
|
||||
((",nil" "()")))
|
||||
("(flet ((foo ()))
|
||||
(quux)
|
||||
(bar *HERE*))"
|
||||
("foo")
|
||||
(("foo" "()"))))
|
||||
(slime-check-top-level)
|
||||
(with-temp-buffer
|
||||
(let ((tmpbuf (current-buffer)))
|
||||
(lisp-mode)
|
||||
(insert buffer-sexpr)
|
||||
(search-backward "*HERE*")
|
||||
(cl-multiple-value-bind (bound-names points)
|
||||
(slime-enclosing-bound-names)
|
||||
(slime-check "Check enclosing bound names"
|
||||
(cl-loop for name in wished-bound-names
|
||||
always (member name bound-names))))
|
||||
(cl-multiple-value-bind (fn-names fn-arglists points)
|
||||
(slime-enclosing-bound-functions)
|
||||
(slime-check "Check enclosing bound functions"
|
||||
(cl-loop for (name arglist) in wished-bound-functions
|
||||
always (and (member name fn-names)
|
||||
(member arglist fn-arglists)))))
|
||||
)))
|
||||
|
||||
(provide 'slime-enclosing-context-tests)
|
||||
|
|
@ -0,0 +1,120 @@
|
|||
(require 'slime-fontifying-fu)
|
||||
(require 'slime-tests)
|
||||
|
||||
(def-slime-test font-lock-magic (buffer-content)
|
||||
"Some testing for the font-lock-magic. *YES* should be
|
||||
highlighted as a suppressed form, *NO* should not."
|
||||
|
||||
'(("(defun *NO* (x y) (+ x y))")
|
||||
("(defun *NO*")
|
||||
("*NO*) #-(and) (*YES*) (*NO* *NO*")
|
||||
("\(
|
||||
\(defun *NO*")
|
||||
("\)
|
||||
\(defun *NO*
|
||||
\(
|
||||
\)")
|
||||
("#+#.foo
|
||||
\(defun *NO* (x y) (+ x y))")
|
||||
("#+#.foo
|
||||
\(defun *NO* (x ")
|
||||
("#+(
|
||||
\(defun *NO* (x ")
|
||||
("#+(test)
|
||||
\(defun *NO* (x ")
|
||||
|
||||
("(eval-when (...)
|
||||
\(defun *NO* (x ")
|
||||
|
||||
("(eval-when (...)
|
||||
#+(and)
|
||||
\(defun *NO* (x ")
|
||||
|
||||
("#-(and) (defun *YES* (x y) (+ x y))")
|
||||
("
|
||||
#-(and) (defun *YES* (x y) (+ x y))
|
||||
#+(and) (defun *NO* (x y) (+ x y))")
|
||||
|
||||
("#+(and) (defun *NO* (x y) #-(and) (+ *YES* y))")
|
||||
("#| #+(or) |# *NO*")
|
||||
("#| #+(or) x |# *NO*")
|
||||
("*NO* \"#| *NO* #+(or) x |# *NO*\" *NO*")
|
||||
("#+#.foo (defun foo (bar))
|
||||
#-(and) *YES* *NO* bar
|
||||
")
|
||||
("#+(foo) (defun foo (bar))
|
||||
#-(and) *YES* *NO* bar")
|
||||
("#| #+(or) |# *NO* foo
|
||||
#-(and) *YES* *NO*")
|
||||
("#- (and)
|
||||
\(*YES*)
|
||||
\(*NO*)
|
||||
#-(and)
|
||||
\(*YES*)
|
||||
\(*NO*)")
|
||||
("#+nil (foo)
|
||||
|
||||
#-(and)
|
||||
#+nil (
|
||||
asdf *YES* a
|
||||
fsdfad)
|
||||
|
||||
\( asdf *YES*
|
||||
|
||||
)
|
||||
\(*NO*)
|
||||
|
||||
")
|
||||
("*NO*
|
||||
|
||||
#-(and) \(progn
|
||||
#-(and)
|
||||
(defun *YES* ...)
|
||||
|
||||
#+(and)
|
||||
(defun *YES* ...)
|
||||
|
||||
(defun *YES* ...)
|
||||
|
||||
*YES*
|
||||
|
||||
*YES*
|
||||
|
||||
*YES*
|
||||
|
||||
*YES*
|
||||
\)
|
||||
|
||||
*NO*")
|
||||
("#-(not) *YES* *NO*
|
||||
|
||||
*NO*
|
||||
|
||||
#+(not) *NO* *NO*
|
||||
|
||||
*NO*
|
||||
|
||||
#+(not a b c) *NO* *NO*
|
||||
|
||||
*NO*"))
|
||||
(slime-check-top-level)
|
||||
(with-temp-buffer
|
||||
(insert buffer-content)
|
||||
(slime-initialize-lisp-buffer-for-test-suite
|
||||
:autodoc t :font-lock-magic t)
|
||||
;; Can't use `font-lock-fontify-buffer' because for the case when
|
||||
;; `jit-lock-mode' is enabled. Jit-lock-mode fontifies only on
|
||||
;; actual display.
|
||||
(font-lock-default-fontify-buffer)
|
||||
(when (search-backward "*NO*" nil t)
|
||||
(slime-test-expect "Not suppressed by reader conditional?"
|
||||
'slime-reader-conditional-face
|
||||
(get-text-property (point) 'face)
|
||||
#'(lambda (x y) (not (eq x y)))))
|
||||
(goto-char (point-max))
|
||||
(when (search-backward "*YES*" nil t)
|
||||
(slime-test-expect "Suppressed by reader conditional?"
|
||||
'slime-reader-conditional-face
|
||||
(get-text-property (point) 'face)))))
|
||||
|
||||
(provide 'slime-fontifying-fu-tests)
|
||||
|
|
@ -0,0 +1,81 @@
|
|||
(require 'slime-indentation)
|
||||
(require 'slime-tests)
|
||||
|
||||
(define-common-lisp-style "common-lisp-indent-test"
|
||||
;; Used to specify a few complex indentation specs for testing.
|
||||
(:inherit "basic")
|
||||
(:indentation
|
||||
(complex-indent.1 ((&whole 4 (&whole 1 1 1 1 (&whole 1 1) &rest 1)
|
||||
&body) &body))
|
||||
(complex-indent.2 (4 (&whole 4 &rest 1) &body))
|
||||
(complex-indent.3 (4 &body))))
|
||||
|
||||
(defun slime-indentation-mess-up-indentation ()
|
||||
(while (not (eobp))
|
||||
(forward-line 1)
|
||||
(unless (looking-at "^$")
|
||||
(cl-case (random 2)
|
||||
(0
|
||||
;; Delete all leading whitespace -- except for
|
||||
;; comment lines.
|
||||
(while (and (looking-at " ") (not (looking-at " ;")))
|
||||
(delete-char 1)))
|
||||
(1
|
||||
;; Insert whitespace random.
|
||||
(let ((n (1+ (random 24))))
|
||||
(while (> n 0) (cl-decf n) (insert " ")))))))
|
||||
(buffer-string))
|
||||
|
||||
(eval-and-compile
|
||||
(defun slime-indentation-test-form (test-name bindings expected)
|
||||
`(define-slime-ert-test ,test-name ()
|
||||
,(format "An indentation test named `%s'" test-name)
|
||||
(with-temp-buffer
|
||||
(lisp-mode)
|
||||
(setq indent-tabs-mode nil)
|
||||
(common-lisp-set-style "common-lisp-indent-test")
|
||||
(let ,(cons `(expected ,expected) bindings)
|
||||
(insert expected)
|
||||
(goto-char (point-min))
|
||||
(let ((mess (slime-indentation-mess-up-indentation)))
|
||||
(when (string= mess expected)
|
||||
(ert-fail "Could not mess up indentation?"))
|
||||
(indent-region (point-min) (point-max))
|
||||
(delete-trailing-whitespace)
|
||||
(should (equal expected (buffer-string))))))))
|
||||
|
||||
(defun slime-indentation-test-forms-for-file (file)
|
||||
(with-current-buffer
|
||||
(find-file-noselect (concat slime-path
|
||||
"/contrib/test/slime-cl-indent-test.txt"))
|
||||
(goto-char (point-min))
|
||||
(cl-loop
|
||||
while (re-search-forward ";;; Test:[\t\n\s]*\\(.*\\)[\t\n\s]" nil t)
|
||||
for test-name = (intern (match-string-no-properties 1))
|
||||
for bindings =
|
||||
(save-restriction
|
||||
(narrow-to-region (point)
|
||||
(progn (forward-comment
|
||||
(point-max))
|
||||
(point)))
|
||||
(save-excursion
|
||||
(goto-char (point-min))
|
||||
(cl-loop while
|
||||
(re-search-forward
|
||||
"\\([^\s]*\\)[\t\n\s]*:[\t\n\s]*\\(.*\\)[\t\n\s]" nil t)
|
||||
collect (list
|
||||
(intern (match-string-no-properties 1))
|
||||
(car
|
||||
(read-from-string (match-string-no-properties 2)))))))
|
||||
for expected = (buffer-substring-no-properties (point)
|
||||
(scan-sexps (point)
|
||||
1))
|
||||
collect (slime-indentation-test-form test-name bindings expected)))))
|
||||
|
||||
(defmacro slime-indentation-define-tests ()
|
||||
`(progn
|
||||
,@(slime-indentation-test-forms-for-file "slime-cl-indent-test.txt")))
|
||||
|
||||
(slime-indentation-define-tests)
|
||||
|
||||
(provide 'slime-indentation-tests)
|
||||
|
|
@ -0,0 +1,287 @@
|
|||
;; Tests for slime-macrostep. The following are expected failures:
|
||||
|
||||
;; - Under CLISP, highlighting of macro sub-forms fails because our
|
||||
;; pretty-printer dispatch table hacking causes infinite recursion:
|
||||
;; see comment in swank-macrostep.lisp
|
||||
|
||||
;; - COLLECT-MACRO-FORMS does not catch compiler macros under CLISP
|
||||
;; and ABCL
|
||||
|
||||
;; - Under CCL and ECL, compiler macro calls returned by
|
||||
;; COLLECT-MACRO-FORMS are not EQ to the original form, and so are
|
||||
;; not detected by the tracking pretty-printer mechanism. This
|
||||
;; could be fixed by adding :TEST #'EQUAL to the POSITION call
|
||||
;; within MAKE-TRACKING-PPRINT-DISPATCH, at the cost of introducing
|
||||
;; false positives.
|
||||
|
||||
;; ECL has two other issues:
|
||||
|
||||
;; - it currently lacks a working SLIME defimplementation for
|
||||
;; MACROEXPAND-ALL (Github issue #157), without which none of the
|
||||
;; expand-in-context stuff works.
|
||||
|
||||
;; - the environments consed up by its WALKER:MACROEXPAND-ALL
|
||||
;; function are slightly broken, and do not work when passed to
|
||||
;; MACROEXPAND-1 unless fixed up via
|
||||
|
||||
;; (subst 'si::macro 'walker::macro env)
|
||||
|
||||
(require 'slime-macrostep)
|
||||
(require 'slime-tests)
|
||||
(require 'cl-lib)
|
||||
|
||||
(defun slime-macrostep-eval-definitions (definitions)
|
||||
(slime-check-top-level)
|
||||
(slime-compile-string definitions 0)
|
||||
(slime-sync-to-top-level 5))
|
||||
|
||||
(defmacro slime-macrostep-with-text (buffer-text &rest body)
|
||||
(declare (indent 1))
|
||||
`(with-temp-buffer
|
||||
(lisp-mode)
|
||||
(save-excursion
|
||||
(insert ,buffer-text))
|
||||
,@body))
|
||||
|
||||
(defun slime-macrostep-search (form)
|
||||
"Search forward for FORM, leaving point at its first character."
|
||||
(let ((case-fold-search t)
|
||||
(search-spaces-regexp "\\s-+"))
|
||||
(re-search-forward (regexp-quote form)))
|
||||
(goto-char (match-beginning 0)))
|
||||
|
||||
|
||||
|
||||
(def-slime-test (slime-macrostep-expand-defmacro)
|
||||
(definition buffer-text original expansion)
|
||||
"Test that simple macrostep expansion works."
|
||||
'(("(defmacro macrostep-dummy-macro (&rest args)
|
||||
`(expansion of ,@args))"
|
||||
|
||||
"(progn
|
||||
(first body form)
|
||||
(second body form)
|
||||
(macrostep-dummy-macro (first (argument)) second (third argument))
|
||||
(remaining body forms))"
|
||||
|
||||
"(macrostep-dummy-macro (first (argument)) second (third argument))"
|
||||
|
||||
"(expansion of (first (argument)) second (third argument))"))
|
||||
(slime-macrostep-eval-definitions definition)
|
||||
(slime-macrostep-with-text buffer-text
|
||||
(slime-macrostep-search original)
|
||||
(macrostep-expand)
|
||||
(slime-test-expect "Macroexpansion is correct"
|
||||
expansion
|
||||
(downcase (slime-sexp-at-point))
|
||||
#'slime-test-macroexpansion=)))
|
||||
|
||||
(def-slime-test (slime-macrostep-fontify-macros
|
||||
(:fails-for "clisp" "ECL"))
|
||||
(definition buffer-text original subform)
|
||||
"Test that macro forms in expansions are font-locked"
|
||||
'(("(defmacro macrostep-dummy-1 (&rest args)
|
||||
`(expansion including (macrostep-dummy-2 ,@args)))
|
||||
(defmacro macrostep-dummy-2 (&rest args)
|
||||
`(final expansion of ,@args))"
|
||||
|
||||
"(progn
|
||||
(first body form)
|
||||
(second body form)
|
||||
(macrostep-dummy-1 (first (argument)) second (third argument))
|
||||
(remaining body forms))"
|
||||
|
||||
"(macrostep-dummy-1 (first (argument)) second (third argument))"
|
||||
|
||||
"(macrostep-dummy-2 (first (argument)) second (third argument))"))
|
||||
(slime-macrostep-eval-definitions definition)
|
||||
(slime-macrostep-with-text buffer-text
|
||||
(slime-macrostep-search original)
|
||||
(macrostep-expand)
|
||||
(slime-macrostep-search subform)
|
||||
(forward-char) ; move over open paren
|
||||
(slime-check "Head of macro form in expansion is fontified correctly"
|
||||
(eq (get-char-property (point) 'font-lock-face)
|
||||
'macrostep-macro-face))))
|
||||
|
||||
(def-slime-test (slime-macrostep-fontify-compiler-macros
|
||||
(:fails-for "armedbear" "clisp" "ccl" "ECL"))
|
||||
(definition buffer-text original subform)
|
||||
"Test that compiler-macro forms in expansions are font-locked"
|
||||
'(("(defmacro macrostep-dummy-3 (&rest args)
|
||||
`(expansion including (macrostep-dummy-4 ,@args)))
|
||||
(defun macrostep-dummy-4 (&rest args)
|
||||
args)
|
||||
(define-compiler-macro macrostep-dummy-4 (&rest args)
|
||||
`(compile-time expansion of ,@args))"
|
||||
|
||||
"(progn
|
||||
(first body form)
|
||||
(second body form)
|
||||
(macrostep-dummy-3 first second third)
|
||||
(remaining body forms))"
|
||||
|
||||
"(macrostep-dummy-3 first second third)"
|
||||
|
||||
"(macrostep-dummy-4 first second third)"))
|
||||
(slime-macrostep-eval-definitions definition)
|
||||
(slime-macrostep-with-text buffer-text
|
||||
(slime-macrostep-search original)
|
||||
(let ((macrostep-expand-compiler-macros t))
|
||||
(macrostep-expand))
|
||||
(slime-macrostep-search subform)
|
||||
(forward-char) ; move over open paren
|
||||
(slime-check "Head of compiler-macro in expansion is fontified correctly"
|
||||
(eq (get-char-property (point) 'font-lock-face)
|
||||
'macrostep-compiler-macro-face))))
|
||||
|
||||
(def-slime-test (slime-macrostep-expand-macrolet
|
||||
(:fails-for "ECL"))
|
||||
(definitions buffer-text expansions)
|
||||
"Test that calls to macrolet-defined macros are expanded."
|
||||
'((nil
|
||||
"(macrolet
|
||||
((test (&rest args) `(expansion of ,@args)))
|
||||
(first body form)
|
||||
(second body form)
|
||||
(test (strawberry pie) and (apple pie))
|
||||
(final body form))"
|
||||
(("(test (strawberry pie) and (apple pie))"
|
||||
"(EXPANSION OF (STRAWBERRY PIE) AND (APPLE PIE))")))
|
||||
|
||||
;; From swank.lisp:
|
||||
(nil
|
||||
"(macrolet ((define-xref-action (xref-type handler)
|
||||
`(defmethod xref-doit ((type (eql ,xref-type)) thing)
|
||||
(declare (ignorable type))
|
||||
(funcall ,handler thing))))
|
||||
(define-xref-action :calls #'who-calls)
|
||||
(define-xref-action :calls-who #'calls-who)
|
||||
(define-xref-action :references #'who-references)
|
||||
(define-xref-action :binds #'who-binds)
|
||||
(define-xref-action :macroexpands #'who-macroexpands)
|
||||
(define-xref-action :specializes #'who-specializes)
|
||||
(define-xref-action :callers #'list-callers)
|
||||
(define-xref-action :callees #'list-callees))"
|
||||
(("(define-xref-action :calls #'who-calls)"
|
||||
"(DEFMETHOD XREF-DOIT ((TYPE (EQL :CALLS)) THING)
|
||||
(DECLARE (IGNORABLE TYPE))
|
||||
(FUNCALL #'WHO-CALLS THING))")
|
||||
("(define-xref-action :macroexpands #'who-macroexpands)"
|
||||
"(DEFMETHOD XREF-DOIT ((TYPE (EQL :MACROEXPANDS)) THING)
|
||||
(DECLARE (IGNORABLE TYPE))
|
||||
(FUNCALL #'WHO-MACROEXPANDS THING))")
|
||||
("(define-xref-action :callees #'list-callees)"
|
||||
"(DEFMETHOD XREF-DOIT ((TYPE (EQL :CALLEES)) THING)
|
||||
(DECLARE (IGNORABLE TYPE))
|
||||
(FUNCALL #'LIST-CALLEES THING))")))
|
||||
|
||||
;; Test expansion of shadowed definitions
|
||||
(nil
|
||||
"(macrolet
|
||||
((test-macro (&rest forms) (cons 'outer-definition forms)))
|
||||
(test-macro first (call))
|
||||
(macrolet
|
||||
((test-macro (&rest forms) (cons 'inner-definition forms)))
|
||||
(test-macro (second (call)))))"
|
||||
(("(test-macro first (call))"
|
||||
"(OUTER-DEFINITION FIRST (CALL))")
|
||||
("(test-macro (second (call)))"
|
||||
"(INNER-DEFINITION (SECOND (CALL)))")))
|
||||
|
||||
;; Expansion of macro-defined local macros
|
||||
("(defmacro with-local-dummy-macro (&rest body)
|
||||
`(macrolet ((dummy (&rest args) `(expansion (of) ,@args)))
|
||||
,@body))"
|
||||
"(with-local-dummy-macro
|
||||
(dummy form (one))
|
||||
(dummy (form two)))"
|
||||
(("(dummy form (one))"
|
||||
"(EXPANSION (OF) FORM (ONE))")
|
||||
("(dummy (form two))"
|
||||
"(EXPANSION (OF) (FORM TWO))"))))
|
||||
|
||||
(when definitions
|
||||
(slime-macrostep-eval-definitions definitions))
|
||||
(slime-macrostep-with-text buffer-text
|
||||
;; slime-test-macroexpansion= does not expect tab characters,
|
||||
;; so make sure that Emacs does not insert them
|
||||
(let ((indent-tabs-mode nil))
|
||||
(cl-loop
|
||||
for (original expansion) in expansions
|
||||
do
|
||||
(goto-char (point-min))
|
||||
(slime-macrostep-search original)
|
||||
(macrostep-expand)
|
||||
(slime-test-expect "Macroexpansion is correct"
|
||||
expansion
|
||||
(slime-sexp-at-point)
|
||||
#'slime-test-macroexpansion=)))))
|
||||
|
||||
(def-slime-test (slime-macrostep-fontify-local-macros
|
||||
(:fails-for "clisp" "ECL"))
|
||||
()
|
||||
"Test that locally-bound macros are highlighted in expansions."
|
||||
'(())
|
||||
(slime-macrostep-with-text
|
||||
"(macrolet ((frob (&rest args)
|
||||
(if (zerop (length args))
|
||||
nil
|
||||
`(cons ,(car args) (frob ,@(cdr args))))))
|
||||
(frob 1 2 3 4 5))"
|
||||
(let ((expansions
|
||||
'(("(frob 1 2 3 4 5)"
|
||||
"(CONS 1 (FROB 2 3 4 5))"
|
||||
"(FROB 2 3 4 5)")
|
||||
("(FROB 2 3 4 5)"
|
||||
"(CONS 2 (FROB 3 4 5))"
|
||||
"(FROB 3 4 5)")
|
||||
("(FROB 3 4 5)"
|
||||
"(CONS 3 (FROB 4 5))"
|
||||
"(FROB 4 5)")
|
||||
("(FROB 4 5)"
|
||||
"(CONS 4 (FROB 5))"
|
||||
"(FROB 5)")
|
||||
("(FROB 5)"
|
||||
"(CONS 5 (FROB))"
|
||||
"(FROB)")
|
||||
;; ("(FROB)"
|
||||
;; "NIL"
|
||||
;; nil)
|
||||
)))
|
||||
(cl-loop for (original expansion subform) in expansions
|
||||
do
|
||||
(goto-char (point-min))
|
||||
(slime-macrostep-search original)
|
||||
(macrostep-expand)
|
||||
(slime-test-expect "Macroexpansion is correct"
|
||||
expansion
|
||||
(slime-sexp-at-point)
|
||||
#'slime-test-macroexpansion=)
|
||||
(when subform
|
||||
(slime-macrostep-search subform)
|
||||
(forward-char)
|
||||
(slime-check "Head of macro form in expansion is fontified correctly"
|
||||
(eq (get-char-property (point) 'font-lock-face)
|
||||
'macrostep-macro-face)))))))
|
||||
|
||||
(def-slime-test (slime-macrostep-handle-unreadable-objects)
|
||||
(definitions buffer-text subform expansion)
|
||||
"Check that macroexpansion succeeds in a context containing unreadable objects."
|
||||
'(("(defmacro macrostep-dummy-5 (&rest args)
|
||||
`(expansion of ,@args))"
|
||||
"(progn
|
||||
#<unreadable object>
|
||||
(macrostep-dummy-5 quux frob))"
|
||||
"(macrostep-dummy-5 quux frob)"
|
||||
"(EXPANSION OF QUUX FROB)"))
|
||||
(slime-macrostep-eval-definitions definitions)
|
||||
(slime-macrostep-with-text buffer-text
|
||||
(slime-macrostep-search subform)
|
||||
(macrostep-expand)
|
||||
(slime-test-expect "Macroexpansion is correct"
|
||||
expansion
|
||||
(slime-sexp-at-point)
|
||||
#'slime-test-macroexpansion=)))
|
||||
|
||||
(provide 'slime-macrostep-tests)
|
||||
|
|
@ -0,0 +1,43 @@
|
|||
(require 'slime-mdot-fu)
|
||||
(require 'slime-tests)
|
||||
|
||||
(def-slime-test find-local-definitions.1
|
||||
(buffer-sexpr definition target-regexp)
|
||||
"Check that finding local definitions work."
|
||||
'(((defun foo (x)
|
||||
(let ((y (+ x 1)))
|
||||
(- x y *HERE*)))
|
||||
y
|
||||
"(y (+ x 1))")
|
||||
|
||||
((defun bar (x)
|
||||
(flet ((foo (z) (+ x z)))
|
||||
(* x (foo *HERE*))))
|
||||
foo
|
||||
"(foo (z) (+ x z))")
|
||||
|
||||
((defun quux (x)
|
||||
(flet ((foo (z) (+ x z)))
|
||||
(let ((foo (- 1 x)))
|
||||
(+ x foo *HERE*))))
|
||||
foo
|
||||
"(foo (- 1 x)")
|
||||
|
||||
((defun zurp (x)
|
||||
(macrolet ((frob (x y) `(quux ,x ,y)))
|
||||
(frob x *HERE*)))
|
||||
frob
|
||||
"(frob (x y)"))
|
||||
(slime-check-top-level)
|
||||
(with-temp-buffer
|
||||
(let ((tmpbuf (current-buffer)))
|
||||
(insert (prin1-to-string buffer-sexpr))
|
||||
(search-backward "*HERE*")
|
||||
(slime-edit-local-definition (prin1-to-string definition))
|
||||
(slime-sync)
|
||||
(slime-check "Check that we didnt leave the temp buffer."
|
||||
(eq (current-buffer) tmpbuf))
|
||||
(slime-check "Check that we are at the local definition."
|
||||
(looking-at (regexp-quote target-regexp))))))
|
||||
|
||||
(provide 'slime-mdot-fu-tests)
|
||||
|
|
@ -0,0 +1,63 @@
|
|||
(require 'slime-parse)
|
||||
(require 'slime-tests)
|
||||
|
||||
(defun slime-check-buffer-form (result-form)
|
||||
(slime-test-expect
|
||||
(format "Buffer form correct in `%s' (at %d)" (buffer-string) (point))
|
||||
result-form
|
||||
(slime-parse-form-upto-point 10)))
|
||||
|
||||
(def-slime-test form-up-to-point.1
|
||||
(buffer-sexpr result-form &optional skip-trailing-test-p)
|
||||
""
|
||||
`(("(char= #\\(*HERE*"
|
||||
("char=" "#\\(" ,slime-cursor-marker))
|
||||
("(char= #\\( *HERE*"
|
||||
("char=" "#\\(" "" ,slime-cursor-marker))
|
||||
("(char= #\\) *HERE*"
|
||||
("char=" "#\\)" "" ,slime-cursor-marker))
|
||||
("(char= #\\*HERE*"
|
||||
("char=" "#\\" ,slime-cursor-marker) t)
|
||||
("(defun*HERE*"
|
||||
("defun" ,slime-cursor-marker))
|
||||
("(defun foo*HERE*"
|
||||
("defun" "foo" ,slime-cursor-marker))
|
||||
("(defun foo (x y)*HERE*"
|
||||
("defun" "foo"
|
||||
("x" "y") ,slime-cursor-marker))
|
||||
("(defun foo (x y*HERE*"
|
||||
("defun" "foo"
|
||||
("x" "y" ,slime-cursor-marker)))
|
||||
("(apply 'foo*HERE*"
|
||||
("apply" "'foo" ,slime-cursor-marker))
|
||||
("(apply #'foo*HERE*"
|
||||
("apply" "#'foo" ,slime-cursor-marker))
|
||||
("(declare ((vector bit *HERE*"
|
||||
("declare" (("vector" "bit" "" ,slime-cursor-marker))))
|
||||
("(with-open-file (*HERE*"
|
||||
("with-open-file" ("" ,slime-cursor-marker)))
|
||||
("(((*HERE*"
|
||||
((("" ,slime-cursor-marker))))
|
||||
("(defun #| foo #| *HERE*"
|
||||
("defun" "" ,slime-cursor-marker))
|
||||
("(defun #-(and) (bar) f*HERE*"
|
||||
("defun" "f" ,slime-cursor-marker))
|
||||
("(remove-if #'(lambda (x)*HERE*"
|
||||
("remove-if" ("lambda" ("x") ,slime-cursor-marker)))
|
||||
("`(remove-if ,(lambda (x)*HERE*"
|
||||
("remove-if" ("lambda" ("x") ,slime-cursor-marker)))
|
||||
("`(remove-if ,@(lambda (x)*HERE*"
|
||||
("remove-if" ("lambda" ("x") ,slime-cursor-marker))))
|
||||
(slime-check-top-level)
|
||||
(with-temp-buffer
|
||||
(lisp-mode)
|
||||
(insert buffer-sexpr)
|
||||
(search-backward "*HERE*")
|
||||
(delete-region (match-beginning 0) (match-end 0))
|
||||
(slime-check-buffer-form result-form)
|
||||
(unless skip-trailing-test-p
|
||||
(insert ")") (backward-char)
|
||||
(slime-check-buffer-form result-form))
|
||||
))
|
||||
|
||||
(provide 'slime-parse-tests)
|
||||
|
|
@ -0,0 +1,61 @@
|
|||
(require 'slime-presentations)
|
||||
(require 'slime-tests)
|
||||
(require 'slime-repl-tests "test/slime-repl-tests")
|
||||
|
||||
(define-slime-ert-test pick-up-presentation-at-point ()
|
||||
"Ensure presentations are found consistently."
|
||||
(cl-labels ((assert-it (point &optional negate)
|
||||
(let ((result
|
||||
(cl-first
|
||||
(slime-presentation-around-or-before-point point))))
|
||||
(unless (if negate (not result) result)
|
||||
(ert-fail
|
||||
(format "Failed to pick up presentation at point %s"
|
||||
point))))))
|
||||
(with-temp-buffer
|
||||
(slime-insert-presentation "1234567890" `(:inspected-part 42))
|
||||
(insert " ")
|
||||
(assert-it 1)
|
||||
(assert-it 2)
|
||||
(assert-it 3)
|
||||
(assert-it 4)
|
||||
(assert-it 5)
|
||||
(assert-it 10)
|
||||
(assert-it 11)
|
||||
(assert-it 12 t))))
|
||||
|
||||
(def-slime-test (pretty-presentation-results (:fails-for "allegro"))
|
||||
(input result-contents)
|
||||
"Test some more simple situations dealing with print-width and stuff.
|
||||
|
||||
Very much like `repl-test-2', but should be more stable when
|
||||
presentations are enabled, except in allegro."
|
||||
'(("\
|
||||
(with-standard-io-syntax
|
||||
(write (make-list 15 :initial-element '(1 . 2)) :pretty t :right-margin 75)
|
||||
0)"
|
||||
"\
|
||||
SWANK> \
|
||||
(with-standard-io-syntax
|
||||
(write (make-list 15 :initial-element '(1 . 2)) :pretty t :right-margin 75)
|
||||
0)
|
||||
{((1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2)
|
||||
(1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2))
|
||||
}0
|
||||
SWANK> *[]")
|
||||
;; Two times to test the effect of FRESH-LINE.
|
||||
("\
|
||||
(with-standard-io-syntax
|
||||
(write (make-list 15 :initial-element '(1 . 2)) :pretty t :right-margin 75)
|
||||
0)"
|
||||
"SWANK> \
|
||||
(with-standard-io-syntax
|
||||
(write (make-list 15 :initial-element '(1 . 2)) :pretty t :right-margin 75)
|
||||
0)
|
||||
{((1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2)
|
||||
(1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2))
|
||||
}0
|
||||
SWANK> *[]"))
|
||||
(slime-test-repl-test input result-contents))
|
||||
|
||||
(provide 'slime-presentations-tests)
|
||||
|
|
@ -0,0 +1,343 @@
|
|||
(require 'slime-repl)
|
||||
(require 'slime-tests)
|
||||
(require 'cl-lib)
|
||||
|
||||
(defmacro slime-repl-test-markers (expected-string-spec &rest marker-specs)
|
||||
"For (MARKER SIG FORM) in MARKER-SPECS, produce suitable `should' assertions.
|
||||
The assertions compare values in symbols `expected-MARKER' and
|
||||
`observed-MARKER'. The former is obtained by searching EXPECTED-STRING-SPEC
|
||||
for the string sig SIG, the latter by evaling FORM in the test buffer."
|
||||
(declare (indent 1))
|
||||
(cl-loop
|
||||
for (marker signature observer-form) in marker-specs
|
||||
for expected-sym = (make-symbol (format "expected-%s" marker))
|
||||
for observed-sym = (make-symbol (format "observed-%s" marker))
|
||||
|
||||
collect `(,expected-sym
|
||||
(progn (goto-char (point-min))
|
||||
(when (search-forward ,signature nil t)
|
||||
(replace-match "")
|
||||
(point-marker))))
|
||||
into expected-bindings
|
||||
collect `(,observed-sym ,observer-form)
|
||||
into observed-bindings
|
||||
collect `(when (and ,observed-sym (not ,expected-sym))
|
||||
(ert-fail
|
||||
(format "Didn't expect to observe %s, but did and its %s"
|
||||
',marker ,observed-sym)))
|
||||
into assertions
|
||||
collect `(when (and (not ,observed-sym) ,expected-sym)
|
||||
(ert-fail
|
||||
(format "Expected %s to be %s, bit didn't observe anything"
|
||||
',marker ,expected-sym)))
|
||||
into assertions
|
||||
collect `(when (and ,observed-sym ,expected-sym)
|
||||
(should (= ,observed-sym ,expected-sym)))
|
||||
into assertions
|
||||
finally
|
||||
(return
|
||||
`(progn
|
||||
(let (,@observed-bindings
|
||||
(observed-string (buffer-substring-no-properties (point-min)
|
||||
(point-max))))
|
||||
(with-current-buffer (get-buffer-create "*slime-repl test buffer*")
|
||||
(erase-buffer)
|
||||
(insert ,expected-string-spec)
|
||||
(let (,@expected-bindings)
|
||||
(should
|
||||
(equal observed-string (buffer-string)))
|
||||
,@assertions)))))))
|
||||
|
||||
(defun slime-check-buffer-contents (_msg expected-string-spec)
|
||||
(slime-repl-test-markers expected-string-spec
|
||||
(point "*" (point))
|
||||
(output-start "{" (next-single-property-change
|
||||
(point-min) 'slime-repl-output))
|
||||
(output-end "}" (previous-single-property-change
|
||||
(point-max) 'slime-repl-output))
|
||||
(input-start "[" slime-repl-input-start-mark)
|
||||
(point-max "]" (point-max))
|
||||
(next-input-start "^" nil)))
|
||||
|
||||
(def-slime-test package-updating
|
||||
(package-name nicknames)
|
||||
"Test if slime-lisp-package is updated."
|
||||
'(("COMMON-LISP" ("CL"))
|
||||
("KEYWORD" ("" "KEYWORD" "||"))
|
||||
("COMMON-LISP-USER" ("CL-USER")))
|
||||
(with-current-buffer (slime-output-buffer)
|
||||
(let ((p (slime-eval
|
||||
`(swank-repl:listener-eval
|
||||
,(format
|
||||
"(cl:setq cl:*print-case* :upcase)
|
||||
(cl:setq cl:*package* (cl:find-package %S))
|
||||
(cl:package-name cl:*package*)" package-name))
|
||||
(slime-lisp-package))))
|
||||
(slime-check ("slime-lisp-package is %S." package-name)
|
||||
(equal (slime-lisp-package) package-name))
|
||||
(slime-check ("slime-lisp-package-prompt-string is in %S." nicknames)
|
||||
(member (slime-lisp-package-prompt-string) nicknames)))))
|
||||
|
||||
(defmacro with-canonicalized-slime-repl-buffer (&rest body)
|
||||
"Evaluate BODY within a fresh REPL buffer. The REPL prompt is
|
||||
canonicalized to \"SWANK\"---we do actually switch to that
|
||||
package, though."
|
||||
(declare (debug (&rest form)) (indent 0))
|
||||
`(let ((%old-prompt% (slime-lisp-package-prompt-string)))
|
||||
(unwind-protect
|
||||
(progn (with-current-buffer (slime-output-buffer)
|
||||
(setf (slime-lisp-package-prompt-string) "SWANK"))
|
||||
(kill-buffer (slime-output-buffer))
|
||||
(with-current-buffer (slime-output-buffer)
|
||||
,@body))
|
||||
(setf (slime-lisp-package-prompt-string) %old-prompt%))))
|
||||
|
||||
(def-slime-test repl-test
|
||||
(input result-contents)
|
||||
"Test simple commands in the minibuffer."
|
||||
'(("(+ 1 2)" "SWANK> (+ 1 2)
|
||||
3
|
||||
SWANK> *[]")
|
||||
("(princ 10)" "SWANK> (princ 10)
|
||||
{10
|
||||
}10
|
||||
SWANK> *[]")
|
||||
("(princ 10)(princ 20)" "SWANK> (princ 10)(princ 20)
|
||||
{1020
|
||||
}20
|
||||
SWANK> *[]")
|
||||
("(dotimes (i 10 77) (princ i) (terpri))"
|
||||
"SWANK> (dotimes (i 10 77) (princ i) (terpri))
|
||||
{0
|
||||
1
|
||||
2
|
||||
3
|
||||
4
|
||||
5
|
||||
6
|
||||
7
|
||||
8
|
||||
9
|
||||
}77
|
||||
SWANK> *[]")
|
||||
("(abort)" "SWANK> (abort)
|
||||
; Evaluation aborted on NIL.
|
||||
SWANK> *[]")
|
||||
("(progn (princ 10) (force-output) (abort))"
|
||||
"SWANK> (progn (princ 10) (force-output) (abort))
|
||||
{10}; Evaluation aborted on NIL.
|
||||
SWANK> *[]")
|
||||
("(progn (princ 10) (abort))"
|
||||
;; output can be flushed after aborting
|
||||
"SWANK> (progn (princ 10) (abort))
|
||||
{10}; Evaluation aborted on NIL.
|
||||
SWANK> *[]")
|
||||
("(if (fresh-line) 1 0)"
|
||||
"SWANK> (if (fresh-line) 1 0)
|
||||
{
|
||||
}1
|
||||
SWANK> *[]")
|
||||
("(values 1 2 3)" "SWANK> (values 1 2 3)
|
||||
1
|
||||
2
|
||||
3
|
||||
SWANK> *[]"))
|
||||
(with-canonicalized-slime-repl-buffer
|
||||
(insert input)
|
||||
(slime-check-buffer-contents "Buffer contains input"
|
||||
(concat "SWANK> [" input "*]"))
|
||||
(call-interactively 'slime-repl-return)
|
||||
(slime-sync-to-top-level 5)
|
||||
(slime-check-buffer-contents "Buffer contains result" result-contents)))
|
||||
|
||||
(def-slime-test repl-test-2
|
||||
(input result-contents)
|
||||
"Test some more simple situations dealing with print-width and stuff"
|
||||
'(("(with-standard-io-syntax
|
||||
(write (make-list 15 :initial-element '(1 . 2)) :pretty t) 0)"
|
||||
"SWANK> (with-standard-io-syntax
|
||||
(write (make-list 15 :initial-element '(1 . 2)) :pretty t) 0)
|
||||
{((1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2)
|
||||
(1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2))
|
||||
}0
|
||||
SWANK> *[]")
|
||||
;; Two times to test the effect of FRESH-LINE.
|
||||
("(with-standard-io-syntax
|
||||
(write (make-list 15 :initial-element '(1 . 2)) :pretty t) 0)"
|
||||
"SWANK> (with-standard-io-syntax
|
||||
(write (make-list 15 :initial-element '(1 . 2)) :pretty t) 0)
|
||||
{((1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2)
|
||||
(1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2))
|
||||
}0
|
||||
SWANK> *[]"))
|
||||
(slime-skip-test "Repl test is unstable without the slime-presentations contrib.")
|
||||
(slime-test-repl-test input result-contents))
|
||||
|
||||
(def-slime-test repl-return
|
||||
(before after result-contents)
|
||||
"Test if slime-repl-return sends the correct protion to Lisp even
|
||||
if point is not at the end of the line."
|
||||
'(("(+ 1 2)" "" "SWANK> (+ 1 2)
|
||||
3
|
||||
SWANK> ")
|
||||
("(+ 1 " "2)" "SWANK> (+ 1 2)
|
||||
3
|
||||
SWANK> ")
|
||||
|
||||
("(+ 1\n" "2)" "SWANK> (+ 1
|
||||
2)
|
||||
3
|
||||
SWANK> "))
|
||||
(with-canonicalized-slime-repl-buffer
|
||||
(insert before)
|
||||
(save-excursion (insert after))
|
||||
(slime-test-expect "Buffer contains input"
|
||||
(concat "SWANK> " before after)
|
||||
(buffer-string))
|
||||
(call-interactively 'slime-repl-return)
|
||||
(slime-sync-to-top-level 5)
|
||||
(slime-test-expect "Buffer contains result"
|
||||
result-contents (buffer-string))))
|
||||
|
||||
(def-slime-test repl-read
|
||||
(prompt input result-contents)
|
||||
"Test simple commands in the minibuffer."
|
||||
'(("(read-line)" "foo" "SWANK> (values (read-line))
|
||||
foo
|
||||
\"foo\"
|
||||
SWANK> ")
|
||||
("(read-char)" "1" "SWANK> (values (read-char))
|
||||
1
|
||||
#\\1
|
||||
SWANK> ")
|
||||
("(read)" "(+ 2 3
|
||||
4)" "SWANK> (values (read))
|
||||
\(+ 2 3
|
||||
4)
|
||||
\(+ 2 3 4)
|
||||
SWANK> "))
|
||||
(with-canonicalized-slime-repl-buffer
|
||||
(insert (format "(values %s)" prompt))
|
||||
(call-interactively 'slime-repl-return)
|
||||
(slime-wait-condition "reading" #'slime-reading-p 5)
|
||||
(insert input)
|
||||
(call-interactively 'slime-repl-return)
|
||||
(slime-sync-to-top-level 5)
|
||||
(slime-test-expect "Buffer contains result"
|
||||
result-contents (buffer-string))))
|
||||
|
||||
(def-slime-test repl-read-lines
|
||||
(command inputs final-contents)
|
||||
"Test reading multiple lines from the repl."
|
||||
'(("(list (read-line) (read-line) (read-line))"
|
||||
("a" "b" "c")
|
||||
"SWANK> (list (read-line) (read-line) (read-line))
|
||||
a
|
||||
b
|
||||
c
|
||||
\(\"a\" \"b\" \"c\")
|
||||
SWANK> "))
|
||||
(with-canonicalized-slime-repl-buffer
|
||||
(insert command)
|
||||
(call-interactively 'slime-repl-return)
|
||||
(dolist (input inputs)
|
||||
(slime-wait-condition "reading" #'slime-reading-p 5)
|
||||
(insert input)
|
||||
(call-interactively 'slime-repl-return))
|
||||
(slime-sync-to-top-level 5)
|
||||
(slime-test-expect "Buffer contains result"
|
||||
final-contents
|
||||
(buffer-string)
|
||||
#'equal)))
|
||||
|
||||
(def-slime-test repl-type-ahead
|
||||
(command input final-contents)
|
||||
"Ensure that user input is preserved correctly.
|
||||
In particular, input inserted while waiting for a result."
|
||||
'(("(sleep 0.1)" "foo*" "SWANK> (sleep 0.1)
|
||||
NIL
|
||||
SWANK> [foo*]")
|
||||
("(sleep 0.1)" "*foo" "SWANK> (sleep 0.1)
|
||||
NIL
|
||||
SWANK> [*foo]")
|
||||
("(progn (sleep 0.1) (abort))" "*foo" "SWANK> (progn (sleep 0.1) (abort))
|
||||
; Evaluation aborted on NIL.
|
||||
SWANK> [*foo]"))
|
||||
(with-canonicalized-slime-repl-buffer
|
||||
(insert command)
|
||||
(call-interactively 'slime-repl-return)
|
||||
(save-excursion (insert (cl-delete ?* input)))
|
||||
(forward-char (cl-position ?* input))
|
||||
(slime-sync-to-top-level 5)
|
||||
(slime-check-buffer-contents "Buffer contains result" final-contents)))
|
||||
|
||||
|
||||
(def-slime-test interrupt-in-blocking-read
|
||||
()
|
||||
"Let's see what happens if we interrupt a blocking read operation."
|
||||
'(())
|
||||
(slime-skip-test "TODO: skip for now, but analyse this failure!")
|
||||
(slime-check-top-level)
|
||||
(with-canonicalized-slime-repl-buffer
|
||||
(insert "(read-char)")
|
||||
(call-interactively 'slime-repl-return)
|
||||
(slime-wait-condition "reading" #'slime-reading-p 5)
|
||||
(slime-interrupt)
|
||||
(slime-wait-condition "Debugger visible"
|
||||
(lambda ()
|
||||
(and (slime-sldb-level= 1)
|
||||
(get-buffer-window
|
||||
(sldb-get-default-buffer))))
|
||||
5)
|
||||
(with-current-buffer (sldb-get-default-buffer)
|
||||
(sldb-continue))
|
||||
(slime-wait-condition "reading" #'slime-reading-p 5)
|
||||
(with-current-buffer (slime-output-buffer)
|
||||
(insert "X")
|
||||
(call-interactively 'slime-repl-return)
|
||||
(slime-sync-to-top-level 5)
|
||||
(slime-test-expect "Buffer contains result"
|
||||
"SWANK> (read-char)
|
||||
X
|
||||
#\\X
|
||||
SWANK> " (buffer-string)))))
|
||||
|
||||
(def-slime-test move-around-and-be-nasty
|
||||
()
|
||||
"Test moving around in repl, and watching attempts to destroy prompt fail"
|
||||
'(())
|
||||
(slime-skip-test "TODO: Test causes instability for other tests.")
|
||||
(slime-check-top-level)
|
||||
(with-canonicalized-slime-repl-buffer
|
||||
(let ((start (point)))
|
||||
(insert "foo")
|
||||
(beginning-of-line)
|
||||
(should (equal (buffer-substring-no-properties
|
||||
(point-min)
|
||||
(point-max)) "SWANK> foo"))
|
||||
(should (equal (point) start))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(let ((inhibit-field-text-motion t))
|
||||
(goto-char (line-beginning-position)))
|
||||
(should-error (delete-char 1)))
|
||||
(goto-char (line-end-position))))))
|
||||
|
||||
(def-slime-test mixed-output-and-results
|
||||
(prompt eval-input result-contents)
|
||||
"Test that output goes to the correct places."
|
||||
'(("(princ 123)" (cl:loop repeat 2 do (cl:princ 456)) "SWANK> (princ 123)
|
||||
123
|
||||
123
|
||||
456456
|
||||
SWANK> "))
|
||||
(with-canonicalized-slime-repl-buffer
|
||||
(insert prompt)
|
||||
(call-interactively 'slime-repl-return)
|
||||
(slime-sync-to-top-level 5)
|
||||
(slime-eval eval-input)
|
||||
(slime-sync-to-top-level 5)
|
||||
(slime-test-expect "Buffer contains result"
|
||||
result-contents (buffer-string))))
|
||||
|
||||
(provide 'slime-repl-tests)
|
||||
Loading…
Add table
Add a link
Reference in a new issue