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