Klimi's new dotfiles with stow.
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

1459 lines
55 KiB

4 years ago
  1. ;;; slime-tests.el --- Automated tests for slime.el
  2. ;;
  3. ;;;; License
  4. ;; Copyright (C) 2003 Eric Marsden, Luke Gorrie, Helmut Eller
  5. ;; Copyright (C) 2004,2005,2006 Luke Gorrie, Helmut Eller
  6. ;; Copyright (C) 2007,2008,2009 Helmut Eller, Tobias C. Rittweiler
  7. ;; Copyright (C) 2013
  8. ;;
  9. ;; For a detailed list of contributors, see the manual.
  10. ;;
  11. ;; This program is free software; you can redistribute it and/or
  12. ;; modify it under the terms of the GNU General Public License as
  13. ;; published by the Free Software Foundation; either version 2 of
  14. ;; the License, or (at your option) any later version.
  15. ;;
  16. ;; This program is distributed in the hope that it will be useful,
  17. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  19. ;; GNU General Public License for more details.
  20. ;;
  21. ;; You should have received a copy of the GNU General Public
  22. ;; License along with this program; if not, write to the Free
  23. ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
  24. ;; MA 02111-1307, USA.
  25. ;;;; Tests
  26. (require 'slime)
  27. (require 'ert nil t)
  28. (require 'ert "lib/ert" t) ;; look for bundled version for Emacs 23
  29. (require 'cl-lib)
  30. (require 'bytecomp) ; byte-compile-current-file
  31. (eval-when-compile
  32. (require 'cl)) ; lexical-let
  33. (defun slime-shuffle-list (list)
  34. (let* ((len (length list))
  35. (taken (make-vector len nil))
  36. (result (make-vector len nil)))
  37. (dolist (e list)
  38. (while (let ((i (random len)))
  39. (cond ((aref taken i))
  40. (t (aset taken i t)
  41. (aset result i e)
  42. nil)))))
  43. (append result '())))
  44. (defun slime-batch-test (&optional test-name randomize)
  45. "Run the test suite in batch-mode.
  46. Exits Emacs when finished. The exit code is the number of failed tests."
  47. (interactive)
  48. (let ((ert-debug-on-error nil)
  49. (timeout 30)
  50. (slime-background-message-function #'ignore))
  51. (slime)
  52. ;; Block until we are up and running.
  53. (lexical-let (timed-out)
  54. (run-with-timer timeout nil
  55. (lambda () (setq timed-out t)))
  56. (while (not (slime-connected-p))
  57. (sit-for 1)
  58. (when timed-out
  59. (when noninteractive
  60. (kill-emacs 252)))))
  61. (slime-sync-to-top-level 5)
  62. (let* ((selector (if randomize
  63. `(member ,@(slime-shuffle-list
  64. (ert-select-tests (or test-name t) t)))
  65. (or test-name t)))
  66. (ert-fun (if noninteractive
  67. 'ert-run-tests-batch
  68. 'ert)))
  69. (let ((stats (funcall ert-fun selector)))
  70. (if noninteractive
  71. (kill-emacs (ert-stats-completed-unexpected stats)))))))
  72. (defun slime-skip-test (message)
  73. ;; ERT for Emacs 23 and earlier doesn't have `ert-skip'
  74. (if (fboundp 'ert-skip)
  75. (ert-skip message)
  76. (message (concat "SKIPPING: " message))
  77. (ert-pass)))
  78. (defun slime-tests--undefine-all ()
  79. (dolist (test (ert-select-tests t t))
  80. (let* ((sym (ert-test-name test)))
  81. (cl-assert (eq (get sym 'ert--test) test))
  82. (cl-remprop sym 'ert--test))))
  83. (slime-tests--undefine-all)
  84. (eval-and-compile
  85. (defun slime-tests-auto-tags ()
  86. (append '(slime)
  87. (let ((file-name (or load-file-name
  88. byte-compile-current-file)))
  89. (if (and file-name
  90. (string-match "contrib/test/slime-\\(.*\\)\.elc?$"
  91. file-name))
  92. (list 'contrib (intern (match-string 1 file-name)))
  93. '(core)))))
  94. (defmacro define-slime-ert-test (name &rest args)
  95. "Like `ert-deftest', but set tags automatically.
  96. Also don't error if `ert.el' is missing."
  97. (if (not (featurep 'ert))
  98. (warn "No ert.el found: not defining test %s"
  99. name)
  100. (let* ((docstring (and (stringp (second args))
  101. (second args)))
  102. (args (if docstring
  103. (cddr args)
  104. (cdr args)))
  105. (tags (slime-tests-auto-tags)))
  106. `(ert-deftest ,name () ,(or docstring "No docstring for this test.")
  107. :tags ',tags
  108. ,@args))))
  109. (defun slime-test-ert-test-for (name input i doc body fails-for style fname)
  110. `(define-slime-ert-test
  111. ,(intern (format "%s-%d" name i)) ()
  112. ,(format "For input %s, %s" (truncate-string-to-width
  113. (format "%s" input)
  114. 15 nil nil 'ellipsis)
  115. (replace-regexp-in-string "^.??\\(\\w+\\)"
  116. (lambda (s) (downcase s))
  117. doc
  118. t))
  119. ,@(if fails-for
  120. `(:expected-result '(satisfies
  121. (lambda (result)
  122. (ert-test-result-type-p
  123. result
  124. (if (member
  125. (slime-lisp-implementation-name)
  126. ',fails-for)
  127. :failed
  128. :passed))))))
  129. ,@(when style
  130. `((let ((style (slime-communication-style)))
  131. (when (not (member style ',style))
  132. (slime-skip-test (format "test not applicable for style %s"
  133. style))))))
  134. (apply #',fname ',input))))
  135. (defmacro def-slime-test (name args doc inputs &rest body)
  136. "Define a test case.
  137. NAME ::= SYMBOL | (SYMBOL OPTION*) is a symbol naming the test.
  138. OPTION ::= (:fails-for IMPLEMENTATION*) | (:style COMMUNICATION-STYLE*)
  139. ARGS is a lambda-list.
  140. DOC is a docstring.
  141. INPUTS is a list of argument lists, each tested separately.
  142. BODY is the test case. The body can use `slime-check' to test
  143. conditions (assertions)."
  144. (declare (debug (&define name sexp sexp sexp &rest def-form)))
  145. (if (not (featurep 'ert))
  146. (warn "No ert.el found: not defining test %s"
  147. name)
  148. `(progn
  149. ,@(cl-destructuring-bind (name &rest options)
  150. (if (listp name) name (list name))
  151. (let ((fname (intern (format "slime-test-%s" name))))
  152. (cons `(defun ,fname ,args
  153. (slime-sync-to-top-level 0.3)
  154. ,@body
  155. (slime-sync-to-top-level 0.3))
  156. (cl-loop for input in (eval inputs)
  157. for i from 1
  158. with fails-for = (cdr (assoc :fails-for options))
  159. with style = (cdr (assoc :style options))
  160. collect (slime-test-ert-test-for name
  161. input
  162. i
  163. doc
  164. body
  165. fails-for
  166. style
  167. fname))))))))
  168. (put 'def-slime-test 'lisp-indent-function 4)
  169. (defmacro slime-check (check &rest body)
  170. (declare (indent defun))
  171. `(unless (progn ,@body)
  172. (ert-fail ,(cl-etypecase check
  173. (cons `(concat "Ooops, " ,(cons 'format check)))
  174. (string `(concat "Check failed: " ,check))
  175. (symbol `(concat "Check failed: " ,(symbol-name check)))))))
  176. ;;;;; Test case definitions
  177. (defun slime-check-top-level () ;(&optional _test-name)
  178. (accept-process-output nil 0.001)
  179. (slime-check "At the top level (no debugging or pending RPCs)"
  180. (slime-at-top-level-p)))
  181. (defun slime-at-top-level-p ()
  182. (and (not (sldb-get-default-buffer))
  183. (null (slime-rex-continuations))))
  184. (defun slime-wait-condition (name predicate timeout)
  185. (let ((end (time-add (current-time) (seconds-to-time timeout))))
  186. (while (not (funcall predicate))
  187. (let ((now (current-time)))
  188. (message "waiting for condition: %s [%s.%06d]" name
  189. (format-time-string "%H:%M:%S" now) (third now)))
  190. (cond ((time-less-p end (current-time))
  191. (error "Timeout waiting for condition: %S" name))
  192. (t
  193. ;; XXX if a process-filter enters a recursive-edit, we
  194. ;; hang forever
  195. (accept-process-output nil 0.1))))))
  196. (defun slime-sync-to-top-level (timeout)
  197. (slime-wait-condition "top-level" #'slime-at-top-level-p timeout))
  198. ;; XXX: unused function
  199. (defun slime-check-sldb-level (expected)
  200. (let ((sldb-level (let ((sldb (sldb-get-default-buffer)))
  201. (if sldb
  202. (with-current-buffer sldb
  203. sldb-level)))))
  204. (slime-check ("SLDB level (%S) is %S" expected sldb-level)
  205. (equal expected sldb-level))))
  206. (defun slime-test-expect (_name expected actual &optional test)
  207. (when (stringp expected) (setq expected (substring-no-properties expected)))
  208. (when (stringp actual) (setq actual (substring-no-properties actual)))
  209. (if test
  210. (should (funcall test expected actual))
  211. (should (equal expected actual))))
  212. (defun sldb-level ()
  213. (let ((sldb (sldb-get-default-buffer)))
  214. (if sldb
  215. (with-current-buffer sldb
  216. sldb-level))))
  217. (defun slime-sldb-level= (level)
  218. (equal level (sldb-level)))
  219. (eval-when-compile
  220. (defvar slime-test-symbols
  221. '(("foobar") ("foo@bar") ("@foobar") ("foobar@") ("\\@foobar")
  222. ("|asdf||foo||bar|")
  223. ("\\#<Foo@Bar>")
  224. ("\\(setf\\ car\\)"))))
  225. (defun slime-check-symbol-at-point (prefix symbol suffix)
  226. ;; We test that `slime-symbol-at-point' works at every
  227. ;; character of the symbol name.
  228. (with-temp-buffer
  229. (lisp-mode)
  230. (insert prefix)
  231. (let ((start (point)))
  232. (insert symbol suffix)
  233. (dotimes (i (length symbol))
  234. (goto-char (+ start i))
  235. (slime-test-expect (format "Check `%s' (at %d)..."
  236. (buffer-string) (point))
  237. symbol
  238. (slime-symbol-at-point)
  239. #'equal)))))
  240. (def-slime-test symbol-at-point.2 (sym)
  241. "fancy symbol-name _not_ at BOB/EOB"
  242. slime-test-symbols
  243. (slime-check-symbol-at-point "(foo " sym " bar)"))
  244. (def-slime-test symbol-at-point.3 (sym)
  245. "fancy symbol-name with leading ,"
  246. (remove-if (lambda (s) (eq (aref (car s) 0) ?@)) slime-test-symbols)
  247. (slime-check-symbol-at-point "," sym ""))
  248. (def-slime-test symbol-at-point.4 (sym)
  249. "fancy symbol-name with leading ,@"
  250. slime-test-symbols
  251. (slime-check-symbol-at-point ",@" sym ""))
  252. (def-slime-test symbol-at-point.5 (sym)
  253. "fancy symbol-name with leading `"
  254. slime-test-symbols
  255. (slime-check-symbol-at-point "`" sym ""))
  256. (def-slime-test symbol-at-point.6 (sym)
  257. "fancy symbol-name wrapped in ()"
  258. slime-test-symbols
  259. (slime-check-symbol-at-point "(" sym ")"))
  260. (def-slime-test symbol-at-point.7 (sym)
  261. "fancy symbol-name wrapped in #< {DEADBEEF}>"
  262. slime-test-symbols
  263. (slime-check-symbol-at-point "#<" sym " {DEADBEEF}>"))
  264. ;;(def-slime-test symbol-at-point.8 (sym)
  265. ;; "fancy symbol-name wrapped in #<>"
  266. ;; slime-test-symbols
  267. ;; (slime-check-symbol-at-point "#<" sym ">"))
  268. (def-slime-test symbol-at-point.9 (sym)
  269. "fancy symbol-name wrapped in #| ... |#"
  270. slime-test-symbols
  271. (slime-check-symbol-at-point "#|\n" sym "\n|#"))
  272. (def-slime-test symbol-at-point.10 (sym)
  273. "fancy symbol-name after #| )))(( |# (1)"
  274. slime-test-symbols
  275. (slime-check-symbol-at-point "#| )))(( #|\n" sym ""))
  276. (def-slime-test symbol-at-point.11 (sym)
  277. "fancy symbol-name after #| )))(( |# (2)"
  278. slime-test-symbols
  279. (slime-check-symbol-at-point "#| )))(( #|" sym ""))
  280. (def-slime-test symbol-at-point.12 (sym)
  281. "fancy symbol-name wrapped in \"...\""
  282. slime-test-symbols
  283. (slime-check-symbol-at-point "\"\n" sym "\"\n"))
  284. (def-slime-test symbol-at-point.13 (sym)
  285. "fancy symbol-name wrapped in \" )))(( \" (1)"
  286. slime-test-symbols
  287. (slime-check-symbol-at-point "\" )))(( \"\n" sym ""))
  288. (def-slime-test symbol-at-point.14 (sym)
  289. "fancy symbol-name wrapped in \" )))(( \" (1)"
  290. slime-test-symbols
  291. (slime-check-symbol-at-point "\" )))(( \"" sym ""))
  292. (def-slime-test symbol-at-point.15 (sym)
  293. "symbol-at-point after #."
  294. slime-test-symbols
  295. (slime-check-symbol-at-point "#." sym ""))
  296. (def-slime-test symbol-at-point.16 (sym)
  297. "symbol-at-point after #+"
  298. slime-test-symbols
  299. (slime-check-symbol-at-point "#+" sym ""))
  300. (def-slime-test sexp-at-point.1 (string)
  301. "symbol-at-point after #'"
  302. '(("foo")
  303. ("#:foo")
  304. ("#'foo")
  305. ("#'(lambda (x) x)")
  306. ("()"))
  307. (with-temp-buffer
  308. (lisp-mode)
  309. (insert string)
  310. (goto-char (point-min))
  311. (slime-test-expect (format "Check sexp `%s' (at %d)..."
  312. (buffer-string) (point))
  313. string
  314. (slime-sexp-at-point)
  315. #'equal)))
  316. (def-slime-test narrowing ()
  317. "Check that narrowing is properly sustained."
  318. '()
  319. (slime-check-top-level)
  320. (let ((random-buffer-name (symbol-name (cl-gensym)))
  321. (defun-pos) (tmpbuffer))
  322. (with-temp-buffer
  323. (dotimes (i 100) (insert (format ";;; %d. line\n" i)))
  324. (setq tmpbuffer (current-buffer))
  325. (setq defun-pos (point))
  326. (insert (concat "(defun __foo__ (x y)" "\n"
  327. " 'nothing)" "\n"))
  328. (dotimes (i 100) (insert (format ";;; %d. line\n" (+ 100 i))))
  329. (slime-check "Checking that newly created buffer is not narrowed."
  330. (not (slime-buffer-narrowed-p)))
  331. (goto-char defun-pos)
  332. (narrow-to-defun)
  333. (slime-check "Checking that narrowing succeeded."
  334. (slime-buffer-narrowed-p))
  335. (slime-with-popup-buffer (random-buffer-name)
  336. (slime-check ("Checking that we're in Slime's temp buffer `%s'"
  337. random-buffer-name)
  338. (equal (buffer-name (current-buffer)) random-buffer-name)))
  339. (with-current-buffer random-buffer-name
  340. ;; Notice that we cannot quit the buffer within the extent
  341. ;; of slime-with-output-to-temp-buffer.
  342. (quit-window t))
  343. (slime-check ("Checking that we've got back from `%s'"
  344. random-buffer-name)
  345. (and (eq (current-buffer) tmpbuffer)
  346. (= (point) defun-pos)))
  347. (slime-check "Checking that narrowing sustained \
  348. after quitting Slime's temp buffer."
  349. (slime-buffer-narrowed-p))
  350. (let ((slime-buffer-package "SWANK")
  351. (symbol '*buffer-package*))
  352. (slime-edit-definition (symbol-name symbol))
  353. (slime-check ("Checking that we've got M-. into swank.lisp. %S" symbol)
  354. (string= (file-name-nondirectory (buffer-file-name))
  355. "swank.lisp"))
  356. (slime-pop-find-definition-stack)
  357. (slime-check ("Checking that we've got back.")
  358. (and (eq (current-buffer) tmpbuffer)
  359. (= (point) defun-pos)))
  360. (slime-check "Checking that narrowing sustained after M-,"
  361. (slime-buffer-narrowed-p)))
  362. ))
  363. (slime-check-top-level))
  364. (defun slime-test--display-region-eval-arg (line window-height)
  365. (cl-etypecase line
  366. (number line)
  367. (cons (slime-dcase line
  368. ((+h line)
  369. (+ (slime-test--display-region-eval-arg line window-height)
  370. window-height))
  371. ((-h line)
  372. (- (slime-test--display-region-eval-arg line window-height)
  373. window-height))))))
  374. (defun slime-test--display-region-line-to-position (line window-height)
  375. (let ((line (slime-test--display-region-eval-arg line window-height)))
  376. (save-excursion
  377. (goto-char (point-min))
  378. (forward-line (1- line))
  379. (line-beginning-position))))
  380. (def-slime-test display-region
  381. (start end pos window-start expected-window-start expected-point)
  382. "Test `slime-display-region'."
  383. ;; numbers are actually lines numbers
  384. '(;; region visible, point in region
  385. (2 4 3 1 1 3)
  386. ;; region visible, point visible but ouside region
  387. (2 4 5 1 1 5)
  388. ;; end not visible, point at start
  389. (2 (+h 2) 2 1 2 2)
  390. ;; start not visible, point at start
  391. ((+h 2) (+h 500) (+h 2) 1 (+h 2) (+h 2))
  392. ;; start not visible, point after end
  393. ((+h 2) (+h 500) (+h 6) 1 (+h 2) (+h 6))
  394. ;; end - start should be visible, point after end
  395. ((+h 2) (+h 7) (+h 10) 1 (-h (+h 7)) (+h 6))
  396. ;; region is window-height + 1 and ends with newline
  397. ((+h -2) (+h (+h -3)) (+h -2) 1 (+h -3) (+h -2))
  398. (2 (+h 1) 3 1 1 3)
  399. (2 (+h 0) 3 1 1 3)
  400. (2 (+h -1) 3 1 1 3)
  401. ;; start and end are the beginning
  402. (1 1 1 1 1 1)
  403. ;;
  404. (1 (+h 1) (+h 22) (+h 20) 1 (+h 0))
  405. )
  406. (when noninteractive
  407. (slime-skip-test "Can't test slime-display-region in batch mode"))
  408. (with-temp-buffer
  409. (dotimes (i 1000)
  410. (insert (format "%09d\n" i)))
  411. (let* ((win (display-buffer (current-buffer) t))
  412. (wh (window-text-height win)))
  413. (cl-macrolet ((l2p (l)
  414. `(slime-test--display-region-line-to-position ,l wh)))
  415. (select-window win)
  416. (set-window-start win (l2p window-start))
  417. (redisplay)
  418. (goto-char (l2p pos))
  419. (cl-assert (= (l2p window-start) (window-start win)))
  420. (cl-assert (= (point) (l2p pos)))
  421. (slime--display-region (l2p start) (l2p end))
  422. (redisplay)
  423. (cl-assert (= (l2p expected-window-start) (window-start)))
  424. (cl-assert (= (l2p expected-point) (point)))
  425. ))))
  426. (def-slime-test find-definition
  427. (name buffer-package snippet)
  428. "Find the definition of a function or macro in swank.lisp."
  429. '(("start-server" "SWANK" "(defun start-server ")
  430. ("swank::start-server" "CL-USER" "(defun start-server ")
  431. ("swank:start-server" "CL-USER" "(defun start-server ")
  432. ("swank::connection" "CL-USER" "(defstruct (connection")
  433. ("swank::*emacs-connection*" "CL-USER" "(defvar \\*emacs-connection\\*")
  434. )
  435. (switch-to-buffer "*scratch*") ; not buffer of definition
  436. (slime-check-top-level)
  437. (let ((orig-buffer (current-buffer))
  438. (orig-pos (point))
  439. (enable-local-variables nil) ; don't get stuck on -*- eval: -*-
  440. (slime-buffer-package buffer-package))
  441. (slime-edit-definition name)
  442. ;; Postconditions
  443. (slime-check ("Definition of `%S' is in swank.lisp." name)
  444. (string= (file-name-nondirectory (buffer-file-name)) "swank.lisp"))
  445. (slime-check ("Looking at '%s'." snippet) (looking-at snippet))
  446. (slime-pop-find-definition-stack)
  447. (slime-check "Returning from definition restores original buffer/position."
  448. (and (eq orig-buffer (current-buffer))
  449. (= orig-pos (point)))))
  450. (slime-check-top-level))
  451. (def-slime-test (find-definition.2 (:fails-for "allegro" "lispworks"))
  452. (buffer-content buffer-package snippet)
  453. "Check that we're able to find definitions even when
  454. confronted with nasty #.-fu."
  455. '(("#.(prog1 nil (defvar *foobar* 42))
  456. (defun .foo. (x)
  457. (+ x #.*foobar*))
  458. #.(prog1 nil (makunbound '*foobar*))
  459. "
  460. "SWANK"
  461. "[ \t]*(defun .foo. "
  462. )
  463. ("#.(prog1 nil (defvar *foobar* 42))
  464. ;; some comment
  465. (defun .foo. (x)
  466. (+ x #.*foobar*))
  467. #.(prog1 nil (makunbound '*foobar*))
  468. "
  469. "SWANK"
  470. "[ \t]*(defun .foo. "
  471. )
  472. ("(in-package swank)
  473. (eval-when (:compile-toplevel) (defparameter *bar* 456))
  474. (eval-when (:load-toplevel :execute) (makunbound '*bar*))
  475. (defun bar () #.*bar*)
  476. (defun .foo. () 123)"
  477. "SWANK"
  478. "[ \t]*(defun .foo. () 123)"))
  479. (let ((slime-buffer-package buffer-package))
  480. (with-temp-buffer
  481. (insert buffer-content)
  482. (slime-check-top-level)
  483. (slime-eval
  484. `(swank:compile-string-for-emacs
  485. ,buffer-content
  486. ,(buffer-name)
  487. '((:position 0) (:line 1 1))
  488. ,nil
  489. ,nil))
  490. (let ((bufname (buffer-name)))
  491. (slime-edit-definition ".foo.")
  492. (slime-check ("Definition of `.foo.' is in buffer `%s'." bufname)
  493. (string= (buffer-name) bufname))
  494. (slime-check "Definition now at point." (looking-at snippet))))))
  495. (def-slime-test (find-definition.3
  496. (:fails-for "abcl" "allegro" "clisp" "lispworks" "sbcl"
  497. "ecl"))
  498. (name source regexp)
  499. "Extra tests for defstruct."
  500. '(("swank::foo-struct"
  501. "(progn
  502. (defun foo-fun ())
  503. (defstruct (foo-struct (:constructor nil) (:predicate nil)))
  504. )"
  505. "(defstruct (foo-struct"))
  506. (switch-to-buffer "*scratch*")
  507. (with-temp-buffer
  508. (insert source)
  509. (let ((slime-buffer-package "SWANK"))
  510. (slime-eval
  511. `(swank:compile-string-for-emacs
  512. ,source
  513. ,(buffer-name)
  514. '((:position 0) (:line 1 1))
  515. ,nil
  516. ,nil)))
  517. (let ((temp-buffer (current-buffer)))
  518. (with-current-buffer "*scratch*"
  519. (slime-edit-definition name)
  520. (slime-check ("Definition of %S is in buffer `%s'."
  521. name temp-buffer)
  522. (eq (current-buffer) temp-buffer))
  523. (slime-check "Definition now at point." (looking-at regexp)))
  524. )))
  525. (def-slime-test complete-symbol
  526. (prefix expected-completions)
  527. "Find the completions of a symbol-name prefix."
  528. '(("cl:compile" ("cl:compile" "cl:compile-file" "cl:compile-file-pathname"
  529. "cl:compiled-function" "cl:compiled-function-p"
  530. "cl:compiler-macro" "cl:compiler-macro-function"))
  531. ("cl:foobar" ())
  532. ("swank::compile-file" ("swank::compile-file"
  533. "swank::compile-file-for-emacs"
  534. "swank::compile-file-if-needed"
  535. "swank::compile-file-output"
  536. "swank::compile-file-pathname"))
  537. ("cl:m-v-l" ()))
  538. (let ((completions (slime-simple-completions prefix)))
  539. (slime-test-expect "Completion set" expected-completions completions)))
  540. (def-slime-test read-from-minibuffer
  541. (input-keys expected-result)
  542. "Test `slime-read-from-minibuffer' with INPUT-KEYS as events."
  543. '(("( r e v e TAB SPC ' ( 1 SPC 2 SPC 3 ) ) RET"
  544. "(reverse '(1 2 3))")
  545. ("( c l : c o n TAB s t a n t l TAB SPC 4 2 ) RET"
  546. "(cl:constantly 42)"))
  547. (when noninteractive
  548. (slime-skip-test "Can't use unread-command-events in batch mode"))
  549. (let ((keys (eval `(kbd ,input-keys)))) ; kbd is a macro in Emacs 23
  550. (setq unread-command-events (listify-key-sequence keys)))
  551. (let ((actual-result (slime-read-from-minibuffer "Test: ")))
  552. (accept-process-output) ; run idle timers
  553. (slime-test-expect "Completed string" expected-result actual-result)))
  554. (def-slime-test arglist
  555. ;; N.B. Allegro apparently doesn't return the default values of
  556. ;; optional parameters. Thus the regexp in the start-server
  557. ;; expected value. In a perfect world we'd find a way to smooth
  558. ;; over this difference between implementations--perhaps by
  559. ;; convincing Franz to provide a function that does what we want.
  560. (function-name expected-arglist)
  561. "Lookup the argument list for FUNCTION-NAME.
  562. Confirm that EXPECTED-ARGLIST is displayed."
  563. '(("swank::operator-arglist" "(swank::operator-arglist name package)")
  564. ("swank::compute-backtrace" "(swank::compute-backtrace start end)")
  565. ("swank::emacs-connected" "(swank::emacs-connected)")
  566. ("swank::compile-string-for-emacs"
  567. "(swank::compile-string-for-emacs \
  568. string buffer position filename policy)")
  569. ("swank::connection.socket-io"
  570. "(swank::connection.socket-io \
  571. \\(struct\\(ure\\)?\\|object\\|instance\\|x\\|connection\\))")
  572. ("cl:lisp-implementation-type" "(cl:lisp-implementation-type)")
  573. ("cl:class-name"
  574. "(cl:class-name \\(class\\|object\\|instance\\|structure\\))"))
  575. (let ((arglist (slime-eval `(swank:operator-arglist ,function-name
  576. "swank"))))
  577. (slime-test-expect "Argument list is as expected"
  578. expected-arglist (and arglist (downcase arglist))
  579. (lambda (pattern arglist)
  580. (and arglist (string-match pattern arglist))))))
  581. (defun slime-test--compile-defun (program subform)
  582. (slime-check-top-level)
  583. (with-temp-buffer
  584. (lisp-mode)
  585. (insert program)
  586. (let ((font-lock-verbose nil))
  587. (setq slime-buffer-package ":swank")
  588. (slime-compile-string (buffer-string) 1)
  589. (setq slime-buffer-package ":cl-user")
  590. (slime-sync-to-top-level 5)
  591. (goto-char (point-max))
  592. (slime-previous-note)
  593. (slime-check error-location-correct
  594. (equal (read (current-buffer)) subform))))
  595. (slime-check-top-level))
  596. (def-slime-test (compile-defun (:fails-for "allegro" "lispworks" "clisp"))
  597. (program subform)
  598. "Compile PROGRAM containing errors.
  599. Confirm that SUBFORM is correctly located."
  600. '(("(defun cl-user::foo () (cl-user::bar))" (cl-user::bar))
  601. ("(defun cl-user::foo ()
  602. #\\space
  603. ;;Sdf
  604. (cl-user::bar))"
  605. (cl-user::bar))
  606. ("(defun cl-user::foo ()
  607. #+(or)skipped
  608. #| #||#
  609. #||# |#
  610. (cl-user::bar))"
  611. (cl-user::bar))
  612. ("(defun cl-user::foo ()
  613. \"\\\" bla bla \\\"\"
  614. (cl-user::bar))"
  615. (cl-user::bar))
  616. ("(defun cl-user::foo ()
  617. #.*log-events*
  618. (cl-user::bar))"
  619. (cl-user::bar))
  620. ("#.'(defun x () (/ 1 0))
  621. (defun foo ()
  622. (cl-user::bar))
  623. "
  624. (cl-user::bar)))
  625. (slime-test--compile-defun program subform))
  626. ;; This test ideally would be collapsed into the previous
  627. ;; compile-defun test, but only 1 case fails for ccl--and that's here
  628. (def-slime-test (compile-defun-with-reader-conditionals
  629. (:fails-for "allegro" "lispworks" "clisp" "ccl"))
  630. (program subform)
  631. "Compile PROGRAM containing errors.
  632. Confirm that SUBFORM is correctly located."
  633. '(("(defun foo ()
  634. #+#.'(:and) (/ 1 0))"
  635. (/ 1 0)))
  636. (slime-test--compile-defun program subform))
  637. ;; SBCL used to pass this one but since they changed the
  638. ;; backquote/unquote reader it fails.
  639. (def-slime-test (compile-defun-with-backquote
  640. (:fails-for "allegro" "lispworks" "clisp" "sbcl"))
  641. (program subform)
  642. "Compile PROGRAM containing errors.
  643. Confirm that SUBFORM is correctly located."
  644. '(("(defun cl-user::foo ()
  645. (list `(1 ,(random 10) 2 ,@(make-list (random 10)) 3
  646. ,(cl-user::bar))))"
  647. (cl-user::bar)))
  648. (slime-test--compile-defun program subform))
  649. (def-slime-test (compile-file (:fails-for "allegro" "clisp"))
  650. (string)
  651. "Insert STRING in a file, and compile it."
  652. `((,(pp-to-string '(defun foo () nil))))
  653. (let ((filename "/tmp/slime-tmp-file.lisp"))
  654. (with-temp-file filename
  655. (insert string))
  656. (let ((cell (cons nil nil)))
  657. (slime-eval-async
  658. `(swank:compile-file-for-emacs ,filename nil)
  659. (slime-rcurry (lambda (result cell)
  660. (setcar cell t)
  661. (setcdr cell result))
  662. cell))
  663. (slime-wait-condition "Compilation finished" (lambda () (car cell))
  664. 0.5)
  665. (let ((result (cdr cell)))
  666. (slime-check "Compilation successfull"
  667. (eq (slime-compilation-result.successp result) t))))))
  668. (def-slime-test utf-8-source
  669. (input output)
  670. "Source code containing utf-8 should work"
  671. (list (let* ((bytes "\343\201\212\343\201\257\343\202\210\343\201\206")
  672. ;;(encode-coding-string (string #x304a #x306f #x3088 #x3046)
  673. ;; 'utf-8)
  674. (string (decode-coding-string bytes 'utf-8-unix)))
  675. (assert (equal bytes (encode-coding-string string 'utf-8-unix)))
  676. (list (concat "(defun cl-user::foo () \"" string "\")")
  677. string)))
  678. (slime-eval `(cl:eval (cl:read-from-string ,input)))
  679. (slime-test-expect "Eval result correct"
  680. output (slime-eval '(cl-user::foo)))
  681. (let ((cell (cons nil nil)))
  682. (let ((hook (slime-curry (lambda (cell &rest _) (setcar cell t)) cell)))
  683. (add-hook 'slime-compilation-finished-hook hook)
  684. (unwind-protect
  685. (progn
  686. (slime-compile-string input 0)
  687. (slime-wait-condition "Compilation finished"
  688. (lambda () (car cell))
  689. 0.5)
  690. (slime-test-expect "Compile-string result correct"
  691. output (slime-eval '(cl-user::foo))))
  692. (remove-hook 'slime-compilation-finished-hook hook))
  693. (let ((filename "/tmp/slime-tmp-file.lisp"))
  694. (setcar cell nil)
  695. (add-hook 'slime-compilation-finished-hook hook)
  696. (unwind-protect
  697. (with-temp-buffer
  698. (when (fboundp 'set-buffer-multibyte)
  699. (set-buffer-multibyte t))
  700. (setq buffer-file-coding-system 'utf-8-unix)
  701. (setq buffer-file-name filename)
  702. (insert ";; -*- coding: utf-8-unix -*- \n")
  703. (insert input)
  704. (let ((coding-system-for-write 'utf-8-unix))
  705. (write-region nil nil filename nil t))
  706. (let ((slime-load-failed-fasl 'always))
  707. (slime-compile-and-load-file)
  708. (slime-wait-condition "Compilation finished"
  709. (lambda () (car cell))
  710. 0.5))
  711. (slime-test-expect "Compile-file result correct"
  712. output (slime-eval '(cl-user::foo))))
  713. (remove-hook 'slime-compilation-finished-hook hook)
  714. (ignore-errors (delete-file filename)))))))
  715. (def-slime-test async-eval-debugging (depth)
  716. "Test recursive debugging of asynchronous evaluation requests."
  717. '((1) (2) (3))
  718. (lexical-let ((depth depth)
  719. (debug-hook-max-depth 0))
  720. (let ((debug-hook
  721. (lambda ()
  722. (with-current-buffer (sldb-get-default-buffer)
  723. (when (> sldb-level debug-hook-max-depth)
  724. (setq debug-hook-max-depth sldb-level)
  725. (if (= sldb-level depth)
  726. ;; We're at maximum recursion - time to unwind
  727. (sldb-quit)
  728. ;; Going down - enter another recursive debug
  729. ;; Recursively debug.
  730. (slime-eval-async '(error))))))))
  731. (let ((sldb-hook (cons debug-hook sldb-hook)))
  732. (slime-eval-async '(error))
  733. (slime-sync-to-top-level 5)
  734. (slime-check ("Maximum depth reached (%S) is %S."
  735. debug-hook-max-depth depth)
  736. (= debug-hook-max-depth depth))))))
  737. (def-slime-test unwind-to-previous-sldb-level (level2 level1)
  738. "Test recursive debugging and returning to lower SLDB levels."
  739. '((2 1) (4 2))
  740. (slime-check-top-level)
  741. (lexical-let ((level2 level2)
  742. (level1 level1)
  743. (state 'enter)
  744. (max-depth 0))
  745. (let ((debug-hook
  746. (lambda ()
  747. (with-current-buffer (sldb-get-default-buffer)
  748. (setq max-depth (max sldb-level max-depth))
  749. (ecase state
  750. (enter
  751. (cond ((= sldb-level level2)
  752. (setq state 'leave)
  753. (sldb-invoke-restart (sldb-first-abort-restart)))
  754. (t
  755. (slime-eval-async `(cl:aref cl:nil ,sldb-level)))))
  756. (leave
  757. (cond ((= sldb-level level1)
  758. (setq state 'ok)
  759. (sldb-quit))
  760. (t
  761. (sldb-invoke-restart (sldb-first-abort-restart))
  762. ))))))))
  763. (let ((sldb-hook (cons debug-hook sldb-hook)))
  764. (slime-eval-async `(cl:aref cl:nil 0))
  765. (slime-sync-to-top-level 15)
  766. (slime-check-top-level)
  767. (slime-check ("Maximum depth reached (%S) is %S." max-depth level2)
  768. (= max-depth level2))
  769. (slime-check ("Final state reached.")
  770. (eq state 'ok))))))
  771. (defun sldb-first-abort-restart ()
  772. (let ((case-fold-search t))
  773. (cl-position-if (lambda (x) (string-match "abort" (car x)))
  774. sldb-restarts)))
  775. (def-slime-test loop-interrupt-quit
  776. ()
  777. "Test interrupting a loop."
  778. '(())
  779. (slime-check-top-level)
  780. (slime-eval-async '(cl:loop) (lambda (_) ) "CL-USER")
  781. (accept-process-output nil 1)
  782. (slime-check "In eval state." (slime-busy-p))
  783. (slime-interrupt)
  784. (slime-wait-condition "First interrupt" (lambda () (slime-sldb-level= 1)) 5)
  785. (with-current-buffer (sldb-get-default-buffer)
  786. (sldb-quit))
  787. (slime-sync-to-top-level 5)
  788. (slime-check-top-level))
  789. (def-slime-test loop-interrupt-continue-interrupt-quit
  790. ()
  791. "Test interrupting a previously interrupted but continued loop."
  792. '(())
  793. (slime-check-top-level)
  794. (slime-eval-async '(cl:loop) (lambda (_) ) "CL-USER")
  795. (sleep-for 1)
  796. (slime-wait-condition "running" #'slime-busy-p 5)
  797. (slime-interrupt)
  798. (slime-wait-condition "First interrupt" (lambda () (slime-sldb-level= 1)) 5)
  799. (with-current-buffer (sldb-get-default-buffer)
  800. (sldb-continue))
  801. (slime-wait-condition "running" (lambda ()
  802. (and (slime-busy-p)
  803. (not (sldb-get-default-buffer)))) 5)
  804. (slime-interrupt)
  805. (slime-wait-condition "Second interrupt" (lambda () (slime-sldb-level= 1)) 5)
  806. (with-current-buffer (sldb-get-default-buffer)
  807. (sldb-quit))
  808. (slime-sync-to-top-level 5)
  809. (slime-check-top-level))
  810. (def-slime-test interactive-eval
  811. ()
  812. "Test interactive eval and continuing from the debugger."
  813. '(())
  814. (slime-check-top-level)
  815. (lexical-let ((done nil))
  816. (let ((sldb-hook (lambda () (sldb-continue) (setq done t))))
  817. (slime-interactive-eval
  818. "(progn\
  819. (cerror \"foo\" \"restart\")\
  820. (cerror \"bar\" \"restart\")\
  821. (+ 1 2))")
  822. (while (not done) (accept-process-output))
  823. (slime-sync-to-top-level 5)
  824. (slime-check-top-level)
  825. (unless noninteractive
  826. (let ((message (current-message)))
  827. (slime-check "Minibuffer contains: \"3\""
  828. (equal "=> 3 (2 bits, #x3, #o3, #b11)" message)))))))
  829. (def-slime-test report-condition-with-circular-list
  830. (format-control format-argument)
  831. "Test conditions involving circular lists."
  832. '(("~a" "(let ((x (cons nil nil))) (setf (cdr x) x))")
  833. ("~a" "(let ((x (cons nil nil))) (setf (car x) x))")
  834. ("~a" "(let ((x (cons (make-string 100000 :initial-element #\\X) nil)))\
  835. (setf (cdr x) x))"))
  836. (slime-check-top-level)
  837. (lexical-let ((done nil))
  838. (let ((sldb-hook (lambda () (sldb-continue) (setq done t))))
  839. (slime-interactive-eval
  840. (format "(with-standard-io-syntax (cerror \"foo\" \"%s\" %s) (+ 1 2))"
  841. format-control format-argument))
  842. (while (not done) (accept-process-output))
  843. (slime-sync-to-top-level 5)
  844. (slime-check-top-level)
  845. (unless noninteractive
  846. (let ((message (current-message)))
  847. (slime-check "Minibuffer contains: \"3\""
  848. (equal "=> 3 (2 bits, #x3, #o3, #b11)" message)))))))
  849. (def-slime-test interrupt-bubbling-idiot
  850. ()
  851. "Test interrupting a loop that sends a lot of output to Emacs."
  852. '(())
  853. (accept-process-output nil 1)
  854. (slime-check-top-level)
  855. (slime-eval-async '(cl:loop :for i :from 0 :do (cl:progn (cl:print i)
  856. (cl:finish-output)))
  857. (lambda (_) )
  858. "CL-USER")
  859. (sleep-for 1)
  860. (slime-interrupt)
  861. (slime-wait-condition "Debugger visible"
  862. (lambda ()
  863. (and (slime-sldb-level= 1)
  864. (get-buffer-window (sldb-get-default-buffer))))
  865. 30)
  866. (with-current-buffer (sldb-get-default-buffer)
  867. (sldb-quit))
  868. (slime-sync-to-top-level 5))
  869. (def-slime-test (interrupt-encode-message (:style :sigio))
  870. ()
  871. "Test interrupt processing during swank::encode-message"
  872. '(())
  873. (slime-eval-async '(cl:loop :for i :from 0
  874. :do (swank::background-message "foo ~d" i)))
  875. (sleep-for 1)
  876. (slime-eval-async '(cl:/ 1 0))
  877. (slime-wait-condition "Debugger visible"
  878. (lambda ()
  879. (and (slime-sldb-level= 1)
  880. (get-buffer-window (sldb-get-default-buffer))))
  881. 30)
  882. (with-current-buffer (sldb-get-default-buffer)
  883. (sldb-quit))
  884. (slime-sync-to-top-level 5))
  885. (def-slime-test inspector
  886. (exp)
  887. "Test basic inspector workingness."
  888. '(((let ((h (make-hash-table)))
  889. (loop for i below 10 do (setf (gethash i h) i))
  890. h))
  891. ((make-array 10))
  892. ((make-list 10))
  893. ('cons)
  894. (#'cons))
  895. (slime-inspect (prin1-to-string exp))
  896. (cl-assert (not (slime-inspector-visible-p)))
  897. (slime-wait-condition "Inspector visible" #'slime-inspector-visible-p 5)
  898. (with-current-buffer (window-buffer (selected-window))
  899. (slime-inspector-quit))
  900. (slime-wait-condition "Inspector closed"
  901. (lambda () (not (slime-inspector-visible-p)))
  902. 5)
  903. (slime-sync-to-top-level 1))
  904. (defun slime-buffer-visible-p (name)
  905. (let ((buffer (window-buffer (selected-window))))
  906. (string-match name (buffer-name buffer))))
  907. (defun slime-inspector-visible-p ()
  908. (slime-buffer-visible-p (slime-buffer-name :inspector)))
  909. (defun slime-execute-as-command (name)
  910. "Execute `name' as if it was done by the user through the
  911. Command Loop. Similiar to `call-interactively' but also pushes on
  912. the buffer's undo-list."
  913. (undo-boundary)
  914. (call-interactively name))
  915. (def-slime-test macroexpand
  916. (macro-defs bufcontent expansion1 search-str expansion2)
  917. "foo"
  918. '((("(defmacro qwertz (&body body) `(list :qwertz ',body))"
  919. "(defmacro yxcv (&body body) `(list :yxcv (qwertz ,@body)))")
  920. "(yxcv :A :B :C)"
  921. "(list :yxcv (qwertz :a :b :c))"
  922. "(qwertz"
  923. "(list :yxcv (list :qwertz '(:a :b :c)))"))
  924. (slime-check-top-level)
  925. (setq slime-buffer-package ":swank")
  926. (with-temp-buffer
  927. (lisp-mode)
  928. (dolist (def macro-defs)
  929. (slime-compile-string def 0)
  930. (slime-sync-to-top-level 5))
  931. (insert bufcontent)
  932. (goto-char (point-min))
  933. (slime-execute-as-command 'slime-macroexpand-1)
  934. (slime-wait-condition "Macroexpansion buffer visible"
  935. (lambda ()
  936. (slime-buffer-visible-p
  937. (slime-buffer-name :macroexpansion)))
  938. 5)
  939. (with-current-buffer (get-buffer (slime-buffer-name :macroexpansion))
  940. (slime-test-expect "Initial macroexpansion is correct"
  941. expansion1
  942. (downcase (buffer-string))
  943. #'slime-test-macroexpansion=)
  944. (search-forward search-str)
  945. (backward-up-list)
  946. (slime-execute-as-command 'slime-macroexpand-1-inplace)
  947. (slime-sync-to-top-level 3)
  948. (slime-test-expect "In-place macroexpansion is correct"
  949. expansion2
  950. (downcase (buffer-string))
  951. #'slime-test-macroexpansion=)
  952. (slime-execute-as-command 'slime-macroexpand-undo)
  953. (slime-test-expect "Expansion after undo is correct"
  954. expansion1
  955. (downcase (buffer-string))
  956. #'slime-test-macroexpansion=)))
  957. (setq slime-buffer-package ":cl-user"))
  958. (defun slime-test-macroexpansion= (string1 string2)
  959. (let ((string1 (replace-regexp-in-string " *\n *" " " string1))
  960. (string2 (replace-regexp-in-string " *\n *" " " string2)))
  961. (equal string1 string2)))
  962. (def-slime-test indentation (buffer-content point-markers)
  963. "Check indentation update to work correctly."
  964. '(("
  965. \(in-package :swank)
  966. \(defmacro with-lolipop (&body body)
  967. `(progn ,@body))
  968. \(defmacro lolipop (&body body)
  969. `(progn ,@body))
  970. \(with-lolipop
  971. 1
  972. 2
  973. 42)
  974. \(lolipop
  975. 1
  976. 2
  977. 23)
  978. "
  979. ("23" "42")))
  980. (with-temp-buffer
  981. (lisp-mode)
  982. (slime-lisp-mode-hook)
  983. (insert buffer-content)
  984. (slime-compile-region (point-min) (point-max))
  985. (slime-sync-to-top-level 3)
  986. (slime-update-indentation)
  987. (slime-sync-to-top-level 3)
  988. (dolist (marker point-markers)
  989. (search-backward marker)
  990. (beginning-of-defun)
  991. (indent-sexp))
  992. (slime-test-expect "Correct buffer content"
  993. buffer-content
  994. (substring-no-properties (buffer-string)))))
  995. (def-slime-test break
  996. (times exp)
  997. "Test whether BREAK invokes SLDB."
  998. (let ((exp1 '(break)))
  999. `((1 ,exp1) (2 ,exp1) (3 ,exp1)))
  1000. (accept-process-output nil 0.2)
  1001. (slime-check-top-level)
  1002. (slime-eval-async
  1003. `(cl:eval (cl:read-from-string
  1004. ,(prin1-to-string `(dotimes (i ,times)
  1005. (unless (= i 0)
  1006. (swank::sleep-for 1))
  1007. ,exp)))))
  1008. (dotimes (_i times)
  1009. (slime-wait-condition "Debugger visible"
  1010. (lambda ()
  1011. (and (slime-sldb-level= 1)
  1012. (get-buffer-window
  1013. (sldb-get-default-buffer))))
  1014. 3)
  1015. (with-current-buffer (sldb-get-default-buffer)
  1016. (sldb-continue))
  1017. (slime-wait-condition "sldb closed"
  1018. (lambda () (not (sldb-get-default-buffer)))
  1019. 0.5))
  1020. (slime-sync-to-top-level 1))
  1021. (def-slime-test (break2 (:fails-for "cmucl" "allegro"))
  1022. (times exp)
  1023. "Backends should arguably make sure that BREAK does not depend
  1024. on *DEBUGGER-HOOK*."
  1025. (let ((exp2
  1026. '(block outta
  1027. (let ((*debugger-hook* (lambda (c h) (return-from outta 42))))
  1028. (break)))))
  1029. `((1 ,exp2) (2 ,exp2) (3 ,exp2)))
  1030. (slime-test-break times exp))
  1031. (def-slime-test locally-bound-debugger-hook
  1032. ()
  1033. "Test that binding *DEBUGGER-HOOK* locally works properly."
  1034. '(())
  1035. (accept-process-output nil 1)
  1036. (slime-check-top-level)
  1037. (slime-compile-string
  1038. (prin1-to-string `(defun cl-user::quux ()
  1039. (block outta
  1040. (let ((*debugger-hook*
  1041. (lambda (c hook)
  1042. (declare (ignore c hook))
  1043. (return-from outta 42))))
  1044. (error "FOO")))))
  1045. 0)
  1046. (slime-sync-to-top-level 2)
  1047. (slime-eval-async '(cl-user::quux))
  1048. ;; FIXME: slime-wait-condition returns immediately if the test returns true
  1049. (slime-wait-condition "Checking that Debugger does not popup"
  1050. (lambda ()
  1051. (not (sldb-get-default-buffer)))
  1052. 3)
  1053. (slime-sync-to-top-level 5))
  1054. (def-slime-test end-of-file
  1055. (expr)
  1056. "Signalling END-OF-FILE should invoke the debugger."
  1057. '(((cl:error 'cl:end-of-file))
  1058. ((cl:read-from-string "")))
  1059. (let ((value (slime-eval
  1060. `(cl:let ((condition nil))
  1061. (cl:with-simple-restart
  1062. (cl:continue "continue")
  1063. (cl:let ((cl:*debugger-hook*
  1064. (cl:lambda (c h)
  1065. (cl:setq condition c)
  1066. (cl:continue))))
  1067. ,expr))
  1068. (cl:if (cl:typep condition 'cl:end-of-file) t)))))
  1069. (slime-test-expect "Debugger invoked" t value)))
  1070. (def-slime-test interrupt-at-toplevel
  1071. ()
  1072. "Let's see what happens if we send a user interrupt at toplevel."
  1073. '(())
  1074. (slime-check-top-level)
  1075. (unless (and (eq (slime-communication-style) :spawn)
  1076. (not (featurep 'slime-repl)))
  1077. (slime-interrupt)
  1078. (slime-wait-condition
  1079. "Debugger visible"
  1080. (lambda ()
  1081. (and (slime-sldb-level= 1)
  1082. (get-buffer-window (sldb-get-default-buffer))))
  1083. 5)
  1084. (with-current-buffer (sldb-get-default-buffer)
  1085. (sldb-quit))
  1086. (slime-sync-to-top-level 5)))
  1087. (def-slime-test interrupt-in-debugger (interrupts continues)
  1088. "Let's see what happens if we interrupt the debugger.
  1089. INTERRUPTS ... number of nested interrupts
  1090. CONTINUES ... how often the continue restart should be invoked"
  1091. '((1 0) (2 1) (4 2))
  1092. (slime-check "No debugger" (not (sldb-get-default-buffer)))
  1093. (when (and (eq (slime-communication-style) :spawn)
  1094. (not (featurep 'slime-repl)))
  1095. (slime-eval-async '(swank::without-slime-interrupts
  1096. (swank::receive)))
  1097. (sit-for 0.2))
  1098. (dotimes (i interrupts)
  1099. (slime-interrupt)
  1100. (let ((level (1+ i)))
  1101. (slime-wait-condition (format "Debug level %d reachend" level)
  1102. (lambda () (equal (sldb-level) level))
  1103. 2)))
  1104. (dotimes (i continues)
  1105. (with-current-buffer (sldb-get-default-buffer)
  1106. (sldb-continue))
  1107. (let ((level (- interrupts (1+ i))))
  1108. (slime-wait-condition (format "Return to debug level %d" level)
  1109. (lambda () (equal (sldb-level) level))
  1110. 2)))
  1111. (with-current-buffer (sldb-get-default-buffer)
  1112. (sldb-quit))
  1113. (slime-sync-to-top-level 1))
  1114. (def-slime-test flow-control
  1115. (n delay interrupts)
  1116. "Let Lisp produce output faster than Emacs can consume it."
  1117. `((400 0.03 3))
  1118. (when noninteractive
  1119. (slime-skip-test "test is currently unstable"))
  1120. (slime-check "No debugger" (not (sldb-get-default-buffer)))
  1121. (slime-eval-async `(swank:flow-control-test ,n ,delay))
  1122. (sleep-for 0.2)
  1123. (dotimes (_i interrupts)
  1124. (slime-interrupt)
  1125. (slime-wait-condition "In debugger" (lambda () (slime-sldb-level= 1)) 5)
  1126. (slime-check "In debugger" (slime-sldb-level= 1))
  1127. (with-current-buffer (sldb-get-default-buffer)
  1128. (sldb-continue))
  1129. (slime-wait-condition "No debugger" (lambda () (slime-sldb-level= nil)) 3)
  1130. (slime-check "Debugger closed" (slime-sldb-level= nil)))
  1131. (slime-sync-to-top-level 8))
  1132. (def-slime-test sbcl-world-lock
  1133. (n delay)
  1134. "Print something from *MACROEXPAND-HOOK*.
  1135. In SBCL, the compiler grabs a lock which can be problematic because
  1136. no method dispatch code can be generated for other threads.
  1137. This test will fail more likely before dispatch caches are warmed up."
  1138. '((10 0.03)
  1139. ;;((cl:+ swank::send-counter-limit 10) 0.03)
  1140. )
  1141. (slime-test-expect "no error"
  1142. 123
  1143. (slime-eval
  1144. `(cl:let ((cl:*macroexpand-hook*
  1145. (cl:lambda (fun form env)
  1146. (swank:flow-control-test ,n ,delay)
  1147. (cl:funcall fun form env))))
  1148. (cl:eval '(cl:macrolet ((foo () 123))
  1149. (foo)))))))
  1150. (def-slime-test (disconnect-one-connection (:style :spawn)) ()
  1151. "`slime-disconnect' should disconnect only the current connection"
  1152. '(())
  1153. (let ((connection-count (length slime-net-processes))
  1154. (old-connection slime-default-connection)
  1155. (slime-connected-hook nil))
  1156. (unwind-protect
  1157. (let ((slime-dispatching-connection
  1158. (slime-connect "localhost"
  1159. ;; Here we assume that the request will
  1160. ;; be evaluated in its own thread.
  1161. (slime-eval `(swank:create-server
  1162. :port 0 ; use random port
  1163. :style :spawn
  1164. :dont-close nil)))))
  1165. (slime-sync-to-top-level 3)
  1166. (slime-disconnect)
  1167. (slime-test-expect "Number of connections must remane the same"
  1168. connection-count
  1169. (length slime-net-processes)))
  1170. (slime-select-connection old-connection))))
  1171. (def-slime-test disconnect-and-reconnect
  1172. ()
  1173. "Close the connetion.
  1174. Confirm that the subprocess continues gracefully.
  1175. Reconnect afterwards."
  1176. '(())
  1177. (slime-check-top-level)
  1178. (let* ((c (slime-connection))
  1179. (p (slime-inferior-process c)))
  1180. (with-current-buffer (process-buffer p)
  1181. (erase-buffer))
  1182. (delete-process c)
  1183. (assert (equal (process-status c) 'closed) nil "Connection not closed")
  1184. (accept-process-output nil 0.1)
  1185. (assert (equal (process-status p) 'run) nil "Subprocess not running")
  1186. (with-current-buffer (process-buffer p)
  1187. (assert (< (buffer-size) 500) nil "Unusual output"))
  1188. (slime-inferior-connect p (slime-inferior-lisp-args p))
  1189. (lexical-let ((hook nil) (p p))
  1190. (setq hook (lambda ()
  1191. (slime-test-expect
  1192. "We are connected again" p (slime-inferior-process))
  1193. (remove-hook 'slime-connected-hook hook)))
  1194. (add-hook 'slime-connected-hook hook)
  1195. (slime-wait-condition "Lisp restarted"
  1196. (lambda ()
  1197. (not (member hook slime-connected-hook)))
  1198. 5))))
  1199. ;;;; SLIME-loading tests that launch separate Emacsen
  1200. ;;;;
  1201. (cl-defun slime-test-recipe-test-for (&key preflight
  1202. takeoff
  1203. landing)
  1204. (let ((success nil)
  1205. (test-file (make-temp-file "slime-recipe-" nil ".el"))
  1206. (test-forms
  1207. `((require 'cl)
  1208. (labels
  1209. ((die
  1210. (reason &optional more)
  1211. (princ reason)
  1212. (terpri)
  1213. (and more (pp more))
  1214. (kill-emacs 254)))
  1215. (condition-case err
  1216. (progn ,@preflight)
  1217. (error
  1218. (die "Unexpected error running preflight forms"
  1219. err)))
  1220. (add-hook
  1221. 'slime-connected-hook
  1222. #'(lambda ()
  1223. (condition-case err
  1224. (progn
  1225. ,@landing
  1226. (kill-emacs 0))
  1227. (error
  1228. (die "Unexpected error running landing forms"
  1229. err))))
  1230. t)
  1231. (condition-case err
  1232. (progn
  1233. ,@takeoff
  1234. ,(when (null landing) '(kill-emacs 0)))
  1235. (error
  1236. (die "Unexpected error running takeoff forms"
  1237. err)))
  1238. (with-timeout
  1239. (20
  1240. (die "Timeout waiting for recipe test to finish."
  1241. takeoff))
  1242. (while t (sit-for 1)))))))
  1243. (unwind-protect
  1244. (progn
  1245. (with-temp-buffer
  1246. (mapc #'insert (mapcar #'pp-to-string test-forms))
  1247. (write-file test-file))
  1248. (with-temp-buffer
  1249. (let ((retval
  1250. (call-process (concat invocation-directory invocation-name)
  1251. nil (list t nil) nil
  1252. "-Q" "--batch"
  1253. "-l" test-file)))
  1254. (unless (= 0 retval)
  1255. (ert-fail (buffer-substring
  1256. (+ (goto-char (point-min))
  1257. (skip-chars-forward " \t\n"))
  1258. (+ (goto-char (point-max))
  1259. (skip-chars-backward " \t\n")))))))
  1260. (setq success t))
  1261. (if success (delete-file test-file)
  1262. (message "Test failed: keeping %s for inspection" test-file)))))
  1263. (define-slime-ert-test readme-recipe ()
  1264. "Test the README.md's autoload recipe."
  1265. (slime-test-recipe-test-for
  1266. :preflight `((add-to-list 'load-path ,slime-path)
  1267. (require 'slime-autoloads)
  1268. (setq inferior-lisp-program ,inferior-lisp-program)
  1269. (setq slime-contribs '(slime-fancy)))
  1270. :takeoff `((call-interactively 'slime))
  1271. :landing `((unless (and (featurep 'slime-repl)
  1272. (find 'swank-repl slime-required-modules))
  1273. (die "slime-repl not loaded properly"))
  1274. (with-current-buffer (slime-repl-buffer)
  1275. (unless (and (string-match "^; +SLIME" (buffer-string))
  1276. (string-match "CL-USER> *$" (buffer-string)))
  1277. (die "REPL prompt not properly setup"
  1278. (buffer-substring-no-properties (point-min)
  1279. (point-max))))))))
  1280. (define-slime-ert-test traditional-recipe ()
  1281. "Test the README.md's traditional recipe."
  1282. (slime-test-recipe-test-for
  1283. :preflight `((add-to-list 'load-path ,slime-path)
  1284. (require 'slime)
  1285. (setq inferior-lisp-program ,inferior-lisp-program)
  1286. (slime-setup '(slime-fancy)))
  1287. :takeoff `((call-interactively 'slime))
  1288. :landing `((unless (and (featurep 'slime-repl)
  1289. (find 'swank-repl slime-required-modules))
  1290. (die "slime-repl not loaded properly"))
  1291. (with-current-buffer (slime-repl-buffer)
  1292. (unless (and (string-match "^; +SLIME" (buffer-string))
  1293. (string-match "CL-USER> *$" (buffer-string)))
  1294. (die "REPL prompt not properly setup"
  1295. (buffer-substring-no-properties (point-min)
  1296. (point-max))))))))
  1297. (define-slime-ert-test readme-recipe-autoload-on-lisp-visit ()
  1298. "Test more autoload bits in README.md's installation recipe."
  1299. (slime-test-recipe-test-for
  1300. :preflight `((add-to-list 'load-path ,slime-path)
  1301. (require 'slime-autoloads))
  1302. :takeoff `((if (featurep 'slime)
  1303. (die "Didn't expect SLIME to be loaded so early!"))
  1304. (find-file ,(make-temp-file "slime-lisp-source-file" nil
  1305. ".lisp"))
  1306. (unless (featurep 'slime)
  1307. (die "Expected SLIME to be fully loaded by now")))))
  1308. (defun slime-test-eval-now (string)
  1309. (second (slime-eval `(swank:eval-and-grab-output ,string))))
  1310. (def-slime-test (slime-recompile-all-xrefs (:fails-for "cmucl")) ()
  1311. "Test recompilation of all references within an xref buffer."
  1312. '(())
  1313. (let* ((cell (cons nil nil))
  1314. (hook (slime-curry (lambda (cell &rest _) (setcar cell t)) cell))
  1315. (filename (make-temp-file "slime-recompile-all-xrefs" nil ".lisp")))
  1316. (add-hook 'slime-compilation-finished-hook hook)
  1317. (unwind-protect
  1318. (with-temp-file filename
  1319. (set-visited-file-name filename)
  1320. (slime-test-eval-now "(defparameter swank::*.var.* nil)")
  1321. (insert "(in-package :swank)
  1322. (defun .fn1. ())
  1323. (defun .fn2. () (.fn1.) #.*.var.*)
  1324. (defun .fn3. () (.fn1.) #.*.var.*)")
  1325. (save-buffer)
  1326. (slime-compile-and-load-file)
  1327. (slime-wait-condition "Compilation finished"
  1328. (lambda () (car cell))
  1329. 0.5)
  1330. (slime-test-eval-now "(setq *.var.* t)")
  1331. (setcar cell nil)
  1332. (slime-xref :calls ".fn1."
  1333. (lambda (&rest args)
  1334. (apply #'slime-show-xrefs args)
  1335. (setcar cell t)))
  1336. (slime-wait-condition "Xrefs computed and displayed"
  1337. (lambda () (car cell))
  1338. 0.5)
  1339. (setcar cell nil)
  1340. (with-current-buffer slime-xref-last-buffer
  1341. (slime-recompile-all-xrefs)
  1342. (slime-wait-condition "Compilation finished"
  1343. (lambda () (car cell))
  1344. 0.5))
  1345. (should (cl-equalp (list (slime-test-eval-now "(.fn2.)")
  1346. (slime-test-eval-now "(.fn3.)"))
  1347. '("T" "T"))))
  1348. (remove-hook 'slime-compilation-finished-hook hook)
  1349. (when slime-xref-last-buffer
  1350. (kill-buffer slime-xref-last-buffer)))))
  1351. (provide 'slime-tests)