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