From heller at common-lisp.net Fri Nov 2 08:14:16 2012 From: heller at common-lisp.net (CVS User heller) Date: Fri, 02 Nov 2012 01:14:16 -0700 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory tiger.common-lisp.net:/tmp/cvs-serv22007 Modified Files: ChangeLog slime.el Log Message: * slime.el ([test] find-definition): Test defstruct and defvar. ([test] find-definition.3): New. --- /project/slime/cvsroot/slime/ChangeLog 2012/10/30 18:38:33 1.2359 +++ /project/slime/cvsroot/slime/ChangeLog 2012/11/02 08:14:16 1.2360 @@ -1,3 +1,8 @@ +2012-11-02 Helmut Eller + + * slime.el ([test] find-definition): Test defstruct and defvar. + ([test] find-definition.3): New. + 2012-10-30 Helmut Eller * swank-cmucl.lisp (dd-location): Use info db as fallback. --- /project/slime/cvsroot/slime/slime.el 2012/10/27 17:53:39 1.1418 +++ /project/slime/cvsroot/slime/slime.el 2012/11/02 08:14:16 1.1419 @@ -7878,7 +7878,10 @@ "Find the definition of a function or macro in swank.lisp." '(("start-server" "SWANK" "(defun start-server ") ("swank::start-server" "CL-USER" "(defun start-server ") - ("swank:start-server" "CL-USER" "(defun start-server ")) + ("swank:start-server" "CL-USER" "(defun start-server ") + ("swank::connection" "CL-USER" "(defstruct (connection") + ("swank::*emacs-connection*" "CL-USER" "(defvar \\*emacs-connection\\*") + ) (switch-to-buffer "*scratch*") ; not buffer of definition (slime-check-top-level) (let ((orig-buffer (current-buffer)) @@ -7928,6 +7931,35 @@ (slime-check "Definition now at point." (looking-at snippet))) ))) +(def-slime-test (find-definition.3) + (name source regexp) + "Extra tests for defstruct." + '(("swank::foo-struct" + "(progn + (defun foo-fun ()) + (defstruct foo-struct (:constructor nil) (:predicate nil)) +)" + "(defstruct foo-struct")) + (switch-to-buffer "*scratch*") + (with-temp-buffer + (insert source) + (let ((slime-buffer-package "SWANK")) + (slime-eval + `(swank:compile-string-for-emacs + ,source + ,(buffer-name) + '((:position 0) (:line 1 1)) + ,nil + ,nil))) + (let ((temp-buffer (current-buffer))) + (with-current-buffer "*scratch*" + (slime-edit-definition name) + (slime-check ("Definition of %S is in buffer `%s'." + name temp-buffer) + (eq (current-buffer) temp-buffer)) + (slime-check "Definition now at point." (looking-at regexp))) + ))) + (def-slime-test complete-symbol (prefix expected-completions) "Find the completions of a symbol-name prefix." From heller at common-lisp.net Fri Nov 2 08:14:28 2012 From: heller at common-lisp.net (CVS User heller) Date: Fri, 02 Nov 2012 01:14:28 -0700 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory tiger.common-lisp.net:/tmp/cvs-serv22109 Modified Files: ChangeLog swank-allegro.lisp Log Message: * swank-allegro.lisp (frame-source-location, ldb-code-to-src-loc): Use function-source-location for some cases that used to cause errors. (frame-package): New. (format-sldb-condition, call-with-syntax-hooks): Deleted. Did just the same as the default implementation. --- /project/slime/cvsroot/slime/ChangeLog 2012/11/02 08:14:16 1.2360 +++ /project/slime/cvsroot/slime/ChangeLog 2012/11/02 08:14:28 1.2361 @@ -1,5 +1,14 @@ 2012-11-02 Helmut Eller + * swank-allegro.lisp (frame-source-location, ldb-code-to-src-loc): + Use function-source-location for some cases that used to cause + errors. + (frame-package): New. + (format-sldb-condition, call-with-syntax-hooks): Deleted. Did just + the same as the default implementation. + +2012-11-02 Helmut Eller + * slime.el ([test] find-definition): Test defstruct and defvar. ([test] find-definition.3): New. --- /project/slime/cvsroot/slime/swank-allegro.lisp 2012/08/04 23:48:19 1.154 +++ /project/slime/cvsroot/slime/swank-allegro.lisp 2012/11/02 08:14:28 1.155 @@ -85,12 +85,6 @@ (excl:find-external-format (car e) :try-variant t))))) -(defimplementation format-sldb-condition (c) - (princ-to-string c)) - -(defimplementation call-with-syntax-hooks (fn) - (funcall fn)) - ;;;; Unix signals (defimplementation getpid () @@ -214,11 +208,11 @@ (let* ((frame (nth-frame index))) (multiple-value-bind (x fun xx xxx pc) (debugger::dyn-fd-analyze frame) (declare (ignore x xx xxx)) - (cond (pc - #+(version>= 8 2) - (pc-source-location fun pc) - #-(version>= 8 2) - (function-source-location fun)) + (cond ((and pc + #+(version>= 8 2) + (pc-source-location fun pc) + #-(version>= 8 2) + (function-source-location fun))) (t ; frames for unbound functions etc end up here (cadr (car (fspec-definition-locations (car (debugger:frame-expression frame)))))))))) @@ -232,7 +226,7 @@ (let* ((debug-info (excl::function-source-debug-info fun))) (cond ((not debug-info) (function-source-location fun)) - (t + (t (let* ((code-loc (find-if (lambda (c) (<= (- pc (sys::natural-width)) (excl::ldb-code-pc c) @@ -248,25 +242,27 @@ (let* ((start (excl::ldb-code-start-char code)) (func (excl::ldb-code-func code)) (src-file (excl:source-file func))) - (cond (start + (cond (start (buffer-or-file-location src-file start)) - (t + (func (let* ((debug-info (excl::function-source-debug-info func)) (whole (aref debug-info 0)) (paths (source-paths-of (excl::ldb-code-source whole) (excl::ldb-code-source code))) - (path (longest-common-prefix paths)) + (path (if paths (longest-common-prefix paths) '())) (start (excl::ldb-code-start-char whole))) - (buffer-or-file - src-file - (lambda (file) - (make-location `(:file ,file) + (buffer-or-file + src-file + (lambda (file) + (make-location `(:file ,file) `(:source-path (0 . ,path) ,start))) (lambda (buffer bstart) (make-location `(:buffer ,buffer) `(:source-path (0 . ,path) - ,(+ bstart start)))))))))) - + ,(+ bstart start))))))) + (t + nil)))) + (defun longest-common-prefix (sequences) (assert sequences) (flet ((common-prefix (s1 s2) @@ -296,6 +292,12 @@ `(let* ,vars ,form) (debugger:environment-of-frame frame))))) +(defimplementation frame-package (frame-number) + (let* ((frame (nth-frame frame-number)) + (exp (debugger:frame-expression frame))) + (typecase exp + ((cons symbol) (symbol-package (car exp)))))) + (defimplementation return-from-frame (frame-number form) (let ((frame (nth-frame frame-number))) (multiple-value-call #'debugger:frame-return From heller at common-lisp.net Fri Nov 2 08:14:42 2012 From: heller at common-lisp.net (CVS User heller) Date: Fri, 02 Nov 2012 01:14:42 -0700 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory tiger.common-lisp.net:/tmp/cvs-serv22190 Modified Files: ChangeLog swank.lisp Log Message: * swank.lisp (condition-message): New. Binds *print-cirlce. (safe-condition-message): Move binding of printer vars to condition-message. (*sldb-condition-printer*): Set it to #'condition-message. --- /project/slime/cvsroot/slime/ChangeLog 2012/11/02 08:14:28 1.2361 +++ /project/slime/cvsroot/slime/ChangeLog 2012/11/02 08:14:42 1.2362 @@ -1,5 +1,12 @@ 2012-11-02 Helmut Eller + * swank.lisp (condition-message): New. Binds *print-cirlce. + (safe-condition-message): Move binding of printer vars to + condition-message. + (*sldb-condition-printer*): Set it to #'condition-message. + +2012-11-02 Helmut Eller + * swank-allegro.lisp (frame-source-location, ldb-code-to-src-loc): Use function-source-location for some cases that used to cause errors. --- /project/slime/cvsroot/slime/swank.lisp 2012/10/27 17:53:39 1.794 +++ /project/slime/cvsroot/slime/swank.lisp 2012/11/02 08:14:42 1.795 @@ -2158,24 +2158,28 @@ (send-to-emacs `(:debug-condition ,(current-thread-id) ,(princ-to-string real-condition))))) -(defvar *sldb-condition-printer* #'format-sldb-condition +(defun condition-message (condition) + (let ((*print-pretty* t) + (*print-right-margin* 65) + (*print-circle* t)) + (format-sldb-condition condition))) + +(defvar *sldb-condition-printer* #'condition-message "Function called to print a condition to an SLDB buffer.") (defun safe-condition-message (condition) "Safely print condition to a string, handling any errors during printing." - (let ((*print-pretty* t) (*print-right-margin* 65) - (*print-length* 1000) (*print-level* 200)) - (truncate-string - (handler-case - (funcall *sldb-condition-printer* condition) - (error (cond) - ;; Beware of recursive errors in printing, so only use the condition - ;; if it is printable itself: - (format nil "Unable to display error condition~@[: ~A~]" - (ignore-errors (princ-to-string cond))))) - (ash 1 16) - "..."))) + (truncate-string + (handler-case + (funcall *sldb-condition-printer* condition) + (error (cond) + ;; Beware of recursive errors in printing, so only use the condition + ;; if it is printable itself: + (format nil "Unable to display error condition~@[: ~A~]" + (ignore-errors (princ-to-string cond))))) + (ash 1 16) + "...")) (defun debugger-condition-for-emacs () (list (safe-condition-message *swank-debugger-condition*) From heller at common-lisp.net Fri Nov 2 08:35:12 2012 From: heller at common-lisp.net (CVS User heller) Date: Fri, 02 Nov 2012 01:35:12 -0700 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory tiger.common-lisp.net:/tmp/cvs-serv31399 Modified Files: ChangeLog slime.el Log Message: * slime.el (find-definition.3): Fix syntax. --- /project/slime/cvsroot/slime/ChangeLog 2012/11/02 08:14:42 1.2362 +++ /project/slime/cvsroot/slime/ChangeLog 2012/11/02 08:35:12 1.2363 @@ -1,5 +1,9 @@ 2012-11-02 Helmut Eller + * slime.el (find-definition.3): Fix syntax. + +2012-11-02 Helmut Eller + * swank.lisp (condition-message): New. Binds *print-cirlce. (safe-condition-message): Move binding of printer vars to condition-message. --- /project/slime/cvsroot/slime/slime.el 2012/11/02 08:14:16 1.1419 +++ /project/slime/cvsroot/slime/slime.el 2012/11/02 08:35:12 1.1420 @@ -7934,12 +7934,12 @@ (def-slime-test (find-definition.3) (name source regexp) "Extra tests for defstruct." - '(("swank::foo-struct" + '(("swank::foo-struct" "(progn (defun foo-fun ()) - (defstruct foo-struct (:constructor nil) (:predicate nil)) + (defstruct (foo-struct (:constructor nil) (:predicate nil))) )" - "(defstruct foo-struct")) + "(defstruct (foo-struct")) (switch-to-buffer "*scratch*") (with-temp-buffer (insert source) From heller at common-lisp.net Thu Nov 8 12:34:06 2012 From: heller at common-lisp.net (CVS User heller) Date: Thu, 08 Nov 2012 04:34:06 -0800 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory tiger.common-lisp.net:/tmp/cvs-serv18347 Modified Files: ChangeLog slime.el Log Message: * slime.el (slime-timer-call): Use debug marker in condition-case. --- /project/slime/cvsroot/slime/ChangeLog 2012/11/02 08:35:12 1.2363 +++ /project/slime/cvsroot/slime/ChangeLog 2012/11/08 12:34:06 1.2364 @@ -1,3 +1,8 @@ +2012-11-08 Helmut Eller + + * slime.el (slime-timer-call): Use debug marker in + condition-case. + 2012-11-02 Helmut Eller * slime.el (find-definition.3): Fix syntax. --- /project/slime/cvsroot/slime/slime.el 2012/11/02 08:35:12 1.1420 +++ /project/slime/cvsroot/slime/slime.el 2012/11/08 12:34:06 1.1421 @@ -1414,7 +1414,7 @@ #'slime-timer-call #'slime-attempt-connection process (and retries (1- retries)) (1+ attempt)))))))) - + (defun slime-timer-call (fun &rest args) "Call function FUN with ARGS, reporting all errors. @@ -1422,7 +1422,8 @@ `timer-event-handler') ignores errors." (condition-case data (apply fun args) - (error (debug nil (list "Error in timer" fun args data))))) + ((debug error) + (debug nil (list "Error in timer" fun args data))))) (defun slime-cancel-connect-retry-timer () (when slime-connect-retry-timer From jgarcia at common-lisp.net Fri Nov 9 21:28:40 2012 From: jgarcia at common-lisp.net (CVS User jgarcia) Date: Fri, 09 Nov 2012 13:28:40 -0800 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory tiger.common-lisp.net:/tmp/cvs-serv31787 Modified Files: swank-ecl.lisp Log Message: call-with-compilation-hooks in swank-ecl.lisp called the same function twice. --- /project/slime/cvsroot/slime/swank-ecl.lisp 2012/08/04 23:48:19 1.77 +++ /project/slime/cvsroot/slime/swank-ecl.lisp 2012/11/09 21:28:40 1.78 @@ -252,7 +252,7 @@ (make-error-location "No location found.")))) (defimplementation call-with-compilation-hooks (function) - #-ecl-bytecmp + #+ecl-bytecmp (funcall function) #-ecl-bytecmp (handler-bind ((c:compiler-message #'handle-compiler-message)) From heller at common-lisp.net Sun Nov 11 09:30:53 2012 From: heller at common-lisp.net (CVS User heller) Date: Sun, 11 Nov 2012 01:30:53 -0800 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory tiger.common-lisp.net:/tmp/cvs-serv3184 Modified Files: ChangeLog swank-allegro.lisp Log Message: * swank-allegro.lisp (ldb-code-to-src-loc): Scan backward to the first code point with a non-nil start-char. (frame-package): Also match for ((:internal foo ...)). --- /project/slime/cvsroot/slime/ChangeLog 2012/11/08 12:34:06 1.2364 +++ /project/slime/cvsroot/slime/ChangeLog 2012/11/11 09:30:53 1.2365 @@ -1,3 +1,9 @@ +2012-11-11 Helmut Eller + + * swank-allegro.lisp (ldb-code-to-src-loc): Scan backward to the + first code point with a non-nil start-char. + (frame-package): Also match for ((:internal foo ...)). + 2012-11-08 Helmut Eller * slime.el (slime-timer-call): Use debug marker in --- /project/slime/cvsroot/slime/swank-allegro.lisp 2012/11/02 08:14:28 1.155 +++ /project/slime/cvsroot/slime/swank-allegro.lisp 2012/11/11 09:30:53 1.156 @@ -239,8 +239,13 @@ #+(version>= 8 2) (defun ldb-code-to-src-loc (code) - (let* ((start (excl::ldb-code-start-char code)) - (func (excl::ldb-code-func code)) + (declare (optimize debug)) + (let* ((func (excl::ldb-code-func code)) + (debug-info (excl::function-source-debug-info func)) + (start (loop for i downfrom (excl::ldb-code-index code) + for bpt = (aref debug-info i) + for start = (excl::ldb-code-start-char bpt) + when start return start)) (src-file (excl:source-file func))) (cond (start (buffer-or-file-location src-file start)) @@ -250,7 +255,7 @@ (paths (source-paths-of (excl::ldb-code-source whole) (excl::ldb-code-source code))) (path (if paths (longest-common-prefix paths) '())) - (start (excl::ldb-code-start-char whole))) + (start 0)) (buffer-or-file src-file (lambda (file) @@ -296,7 +301,9 @@ (let* ((frame (nth-frame frame-number)) (exp (debugger:frame-expression frame))) (typecase exp - ((cons symbol) (symbol-package (car exp)))))) + ((cons symbol) (symbol-package (car exp))) + ((cons (cons (eql :internal) (cons symbol))) + (symbol-package (cadar exp)))))) (defimplementation return-from-frame (frame-number form) (let ((frame (nth-frame frame-number))) From heller at common-lisp.net Sun Nov 11 09:31:07 2012 From: heller at common-lisp.net (CVS User heller) Date: Sun, 11 Nov 2012 01:31:07 -0800 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory tiger.common-lisp.net:/tmp/cvs-serv3284 Modified Files: ChangeLog slime.el Log Message: * slime.el ([test] find-definition.3): Mark as expected to fail. ([test] arglist): Adjust regexp so that CCL passes. (slime-execute-tests): Insert summary table at the the end. (slime-check): Don't change counters here, as that would count multiple times per test. Instead to the counting in slime-execute-tests. --- /project/slime/cvsroot/slime/ChangeLog 2012/11/11 09:30:53 1.2365 +++ /project/slime/cvsroot/slime/ChangeLog 2012/11/11 09:31:07 1.2366 @@ -1,5 +1,14 @@ 2012-11-11 Helmut Eller + * slime.el ([test] find-definition.3): Mark as expected to fail. + ([test] arglist): Adjust regexp so that CCL passes. + (slime-execute-tests): Insert summary table at the the end. + (slime-check): Don't change counters here, as that would count + multiple times per test. Instead to the counting in + slime-execute-tests. + +2012-11-11 Helmut Eller + * swank-allegro.lisp (ldb-code-to-src-loc): Scan backward to the first code point with a non-nil start-char. (frame-package): Also match for ((:internal foo ...)). --- /project/slime/cvsroot/slime/slime.el 2012/11/08 12:34:06 1.1421 +++ /project/slime/cvsroot/slime/slime.el 2012/11/11 09:31:07 1.1422 @@ -7383,6 +7383,7 @@ ;; dynamically bound during a single test (defvar slime-current-test) (defvar slime-unexpected-failures) +(defvar slime-unexpected-passes) ;;;;; Execution engine @@ -7403,8 +7404,9 @@ (goto-char (point-min)) (hide-body) ;; Expose failed tests - (dolist (o (overlays-in (point-min) (point-max))) - (when (overlay-get o 'slime-failed-test) + (dolist (o (reverse (overlays-in (point-min) (point-max)))) + (when (or (overlay-get o 'slime-failed-test) + (overlay-get o 'slime-summary)) (goto-char (overlay-start o)) (show-subtree))))) @@ -7412,7 +7414,7 @@ "Ask for the name of a test and then execute the test." (interactive (list (slime-read-test-name))) (let ((test (find name slime-tests :key #'slime-test.name))) - (assert test) + (assert test () "No test named: %S" name) (let ((slime-tests (list test))) (slime-run-tests)))) @@ -7451,6 +7453,7 @@ (slime-skipped-tests 0) (slime-unexpected-failures 0) (slime-expected-failures 0) + (slime-unexpected-passes 0) (slime-lisp-under-test (slime-lisp-implementation-name))) (dolist (slime-current-test slime-tests) (with-struct (slime-test. name (function fname) inputs style) @@ -7467,31 +7470,54 @@ (debug-on-quit t)) (catch 'skip (apply function input))) - (condition-case err + (condition-case err + (progn (apply function input) + (cond ((slime-test-should-fail-p) + (incf slime-unexpected-passes) + (slime-print-check-xpass (format "%s" name))) + (t))) (error (cond ((slime-test-should-fail-p) (incf slime-expected-failures) - (slime-test-failure "ERROR (expected)" - (format "%S" err))) + (slime-print-check-xerror err)) (t (incf slime-unexpected-failures) (slime-print-check-error err)))))))))) - (let ((summary - (concat (if (and (zerop slime-expected-failures) - (zerop slime-unexpected-failures)) - (format "All %d tests completed successfully." - slime-total-tests) - (format "Failed on %d (%d expected) of %d tests." - (+ slime-expected-failures - slime-unexpected-failures) - slime-expected-failures - slime-total-tests)) - (if (zerop slime-skipped-tests) - "" - (format " Skipped %d tests." slime-skipped-tests))))) + (let* ((tab + `(("tests " ,slime-total-tests) + ("expected passes " ,(- slime-total-tests + slime-unexpected-failures + slime-unexpected-passes + slime-skipped-tests)) + ("expected failures " ,slime-expected-failures) + ("unexpected failures " ,slime-unexpected-failures) + ("unexpected successes" ,slime-unexpected-passes) + ("tests skipped " ,slime-skipped-tests))) + (stats + (loop for (fstring arg) in tab + concat (format (concat "# of " fstring " : %d\n") arg))) + (summary + (cond ((and (zerop slime-expected-failures) + (zerop slime-unexpected-failures)) + (format "All %d tests completed successfully." + slime-total-tests)) + (t + (format + "Failed on %d (%d expected, %d skipped) of %d tests." + (+ slime-expected-failures + slime-unexpected-failures) + slime-expected-failures + slime-skipped-tests + slime-total-tests))))) (save-excursion (with-current-buffer slime-test-buffer-name + (goto-char (point-max)) + (insert "* Summary\n") + (let ((start (point))) + (insert stats) + (let ((overlay (make-overlay start (point)))) + (overlay-put overlay 'slime-summary t))) (goto-char (point-min)) (insert summary "\n\n"))) (message "%s" summary) @@ -7620,31 +7646,43 @@ "Check a condition (assertion.) TEST-NAME can be a symbol, a string, or a (FORMAT-STRING . ARGS) list. BODY returns true if the check succeeds." - (let ((check-name (gensym "check-name-"))) - `(let ((,check-name ,(typecase test-name - (symbol (symbol-name test-name)) - (string test-name) - (cons `(format , at test-name))))) - (if (progn , at body) - (slime-print-check-ok ,check-name) - (cond ((slime-test-should-fail-p) - (incf slime-expected-failures) - (slime-test-failure "FAIL (expected)" ,check-name)) - (t - (incf slime-unexpected-failures) - (slime-print-check-failed ,check-name))) - (when slime-test-debug-on-error - (debug (format "Check failed: %S" ,check-name))))))) + `(let ((ok (progn , at body)) + (check-name ,(typecase test-name + (symbol (symbol-name test-name)) + (string test-name) + (cons `(format , at test-name))))) + (cond ((and ok (not (slime-test-should-fail-p))) + (slime-print-check-ok check-name)) + ((and ok (slime-test-should-fail-p)) + (slime-print-check-xpass check-name)) + ((and (not ok) (not (slime-test-should-fail-p))) + (slime-print-check-failed check-name)) + ((and (not ok) (slime-test-should-fail-p)) + (slime-print-check-xfailed check-name)) + (t (assert nil))) + (when (and (not ok) slime-test-debug-on-error) + (debug (format "Check failed: %S" check-name))) + (when (not ok) + (error "Check failed: %S" check-name)))) (defun slime-print-check-ok (test-name) (slime-test-message (concat "OK: " test-name))) +(defun slime-print-check-xpass (test-name) + (slime-test-message (concat "XPASS: " test-name))) + (defun slime-print-check-failed (test-name) (slime-test-failure "FAILED" test-name)) +(defun slime-print-check-xfailed (test-name) + (slime-test-failure "XFAILED" test-name)) + (defun slime-print-check-error (reason) (slime-test-failure "ERROR" (format "%S" reason))) +(defun slime-print-check-xerror (reason) + (slime-test-failure "XERROR" (format "%S" reason))) + (put 'slime-check 'lisp-indent-function 1) @@ -7932,7 +7970,9 @@ (slime-check "Definition now at point." (looking-at snippet))) ))) -(def-slime-test (find-definition.3) +(def-slime-test (find-definition.3 + (:fails-for "abcl" "allegro" "clisp" "lispworks" "sbcl" + "ecl")) (name source regexp) "Extra tests for defstruct." '(("swank::foo-struct" @@ -7996,7 +8036,7 @@ string buffer position filename policy)") ("swank::connection.socket-io" "(swank::connection.socket-io \ -\\(struct\\(ure\\)?\\|object\\|instance\\|x\\))") +\\(struct\\(ure\\)?\\|object\\|instance\\|x\\|connection\\))") ("cl:lisp-implementation-type" "(cl:lisp-implementation-type)") ("cl:class-name" "(cl:class-name \\(class\\|object\\|instance\\|structure\\))")) From sboukarev at common-lisp.net Sun Nov 11 20:00:33 2012 From: sboukarev at common-lisp.net (CVS User sboukarev) Date: Sun, 11 Nov 2012 12:00:33 -0800 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory tiger.common-lisp.net:/tmp/cvs-serv25620 Modified Files: ChangeLog swank.lisp Log Message: * swank.lisp (interrupt-worker-thread): Solve *send-counter* binding problem. find-worker-thread: Merge with `thread-for-evaluation'. --- /project/slime/cvsroot/slime/ChangeLog 2012/11/11 09:31:07 1.2366 +++ /project/slime/cvsroot/slime/ChangeLog 2012/11/11 20:00:33 1.2367 @@ -1,3 +1,9 @@ +2012-11-11 Stas Boukarev + + * swank.lisp (interrupt-worker-thread): Solve *send-counter* + binding problem. + find-worker-thread: Merge with `thread-for-evaluation'. + 2012-11-11 Helmut Eller * slime.el ([test] find-definition.3): Mark as expected to fail. --- /project/slime/cvsroot/slime/swank.lisp 2012/11/02 08:14:42 1.795 +++ /project/slime/cvsroot/slime/swank.lisp 2012/11/11 20:00:33 1.796 @@ -997,23 +997,25 @@ (sleep *auto-flush-interval*))) ;; FIXME: drop dependency on find-repl-thread -;; FIXME: and don't add and any more -(defun find-worker-thread (connection id) +(defun thread-for-evaluation (connection id &key find-existing) + "Find or create a thread to evaluate the next request." (etypecase id ((member t) (etypecase connection - (multithreaded-connection (or (car (mconn.active-threads connection)) - (find-repl-thread connection))) + (multithreaded-connection + (if find-existing + (or (car (mconn.active-threads connection)) + (find-repl-thread connection)) + (spawn-worker-thread connection))) (singlethreaded-connection (current-thread)))) - ((member :repl-thread) + ((member :repl-thread) (find-repl-thread connection)) (fixnum (find-thread id)))) -;; FIXME: the else branch does look like it was written by someone who -;; doesn't know what he is doeing. (defun interrupt-worker-thread (connection id) - (let ((thread (find-worker-thread connection id))) + (let ((thread (thread-for-evaluation connection id + :find-existing t))) (log-event "interrupt-worker-thread: ~a ~a~%" id thread) (if thread (etypecase connection @@ -1024,22 +1026,10 @@ (invoke-or-queue-interrupt #'simple-break)))) (singlethreaded-connection (simple-break))) - (let ((*send-counter* 0)) ;; shouldn't be necessary, but it is - (send-to-emacs (list :debug-condition (current-thread-id) - (format nil "Thread with id ~a not found" - id))))))) - -(defun thread-for-evaluation (connection id) - "Find or create a thread to evaluate the next request." - (etypecase id - ((member t) - (etypecase connection - (multithreaded-connection (spawn-worker-thread connection)) - (singlethreaded-connection (current-thread)))) - ((member :repl-thread) - (find-repl-thread connection)) - (fixnum - (find-thread id)))) + (encode-message (list :debug-condition (current-thread-id) + (format nil "Thread with id ~a not found" + id)) + (current-socket-io))))) (defun spawn-worker-thread (connection) (spawn (lambda () From sboukarev at common-lisp.net Mon Nov 12 17:27:37 2012 From: sboukarev at common-lisp.net (CVS User sboukarev) Date: Mon, 12 Nov 2012 09:27:37 -0800 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory tiger.common-lisp.net:/tmp/cvs-serv10798 Modified Files: ChangeLog swank.lisp Log Message: * swank.lisp (with-panic-handler): Abort the condition after closing the connection, otherwise it ends up in the slime debugger causing nested errors. --- /project/slime/cvsroot/slime/ChangeLog 2012/11/11 20:00:33 1.2367 +++ /project/slime/cvsroot/slime/ChangeLog 2012/11/12 17:27:36 1.2368 @@ -1,3 +1,9 @@ +2012-11-12 Stas Boukarev + + * swank.lisp (with-panic-handler): Abort the condition after + closing the connection, otherwise it ends up in the slime debugger + causing nested errors. + 2012-11-11 Stas Boukarev * swank.lisp (interrupt-worker-thread): Solve *send-counter* --- /project/slime/cvsroot/slime/swank.lisp 2012/11/11 20:00:33 1.796 +++ /project/slime/cvsroot/slime/swank.lisp 2012/11/12 17:27:36 1.797 @@ -317,11 +317,12 @@ (defmacro with-panic-handler ((connection) &body body) "Close the connection on unhandled `serious-condition's." (let ((conn (gensym))) - `(let ((,conn ,connection)) - (handler-bind ((serious-condition - (lambda (condition) - (close-connection ,conn condition (safe-backtrace))))) - . ,body)))) + `(let ((,conn ,connection)) + (handler-bind ((serious-condition + (lambda (condition) + (close-connection ,conn condition (safe-backtrace)) + (abort condition)))) + . ,body)))) (add-hook *new-connection-hook* 'notify-backend-of-connection) (defun notify-backend-of-connection (connection) From sboukarev at common-lisp.net Tue Nov 13 15:44:40 2012 From: sboukarev at common-lisp.net (CVS User sboukarev) Date: Tue, 13 Nov 2012 07:44:40 -0800 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory tiger.common-lisp.net:/tmp/cvs-serv25282 Modified Files: ChangeLog swank.lisp Log Message: * swank-asdf.lisp: Better ASDF support. * swank.lisp (*compile-file-for-emacs-hook*): A hook for compile-file-for-emacs, so that ASDF can hook its compilation functions. --- /project/slime/cvsroot/slime/ChangeLog 2012/11/12 17:27:36 1.2368 +++ /project/slime/cvsroot/slime/ChangeLog 2012/11/13 15:44:39 1.2369 @@ -1,3 +1,9 @@ +2012-11-13 Francois-Rene Rideau + + * swank.lisp (*compile-file-for-emacs-hook*): A hook for + compile-file-for-emacs, so that ASDF can hook its compilation + functions. + 2012-11-12 Stas Boukarev * swank.lisp (with-panic-handler): Abort the condition after --- /project/slime/cvsroot/slime/swank.lisp 2012/11/12 17:27:36 1.797 +++ /project/slime/cvsroot/slime/swank.lisp 2012/11/13 15:44:40 1.798 @@ -2425,24 +2425,36 @@ :loadp (if loadp t) :faslfile faslfile)))))) -(defslimefun compile-file-for-emacs (filename load-p &rest options &key policy - &allow-other-keys) +(defun compile-file-with-compile-file (pathname load-p &rest options + &key policy + &allow-other-keys) + (multiple-value-bind (output-pathname warnings? failure?) + (swank-compile-file pathname + (fasl-pathname pathname options) + nil + (or (guess-external-format pathname) + :default) + :policy policy) + (declare (ignore warnings?)) + (values t (not failure?) load-p output-pathname))) + +(defvar *compile-file-for-emacs-hook* '(compile-file-with-compile-file)) + +(defslimefun compile-file-for-emacs (filename load-p &rest options) "Compile FILENAME and, when LOAD-P, load the result. Record compiler notes signalled as `compiler-condition's." (with-buffer-syntax () (collect-notes (lambda () (let ((pathname (filename-to-pathname filename)) - (*compile-print* nil) (*compile-verbose* t)) - (multiple-value-bind (output-pathname warnings? failure?) - (swank-compile-file pathname - (fasl-pathname pathname options) - nil - (or (guess-external-format pathname) - :default) - :policy policy) - (declare (ignore warnings?)) - (values (not failure?) load-p output-pathname))))))) + (*compile-print* nil) + (*compile-verbose* t)) + (loop for hook in *compile-file-for-emacs-hook* + do + (multiple-value-bind (tried success load? output-pathname) + (apply hook pathname load-p options) + (when tried + (return (values success load? output-pathname)))))))))) (defvar *fasl-pathname-function* nil "In non-nil, use this function to compute the name for fasl-files.") From sboukarev at common-lisp.net Tue Nov 13 15:44:40 2012 From: sboukarev at common-lisp.net (CVS User sboukarev) Date: Tue, 13 Nov 2012 07:44:40 -0800 Subject: [slime-cvs] CVS slime/contrib Message-ID: Update of /project/slime/cvsroot/slime/contrib In directory tiger.common-lisp.net:/tmp/cvs-serv25282/contrib Modified Files: ChangeLog swank-asdf.lisp Log Message: * swank-asdf.lisp: Better ASDF support. * swank.lisp (*compile-file-for-emacs-hook*): A hook for compile-file-for-emacs, so that ASDF can hook its compilation functions. --- /project/slime/cvsroot/slime/contrib/ChangeLog 2012/10/19 05:18:05 1.552 +++ /project/slime/cvsroot/slime/contrib/ChangeLog 2012/11/13 15:44:40 1.553 @@ -1,3 +1,7 @@ +2012-11-13 Francois-Rene Rideau + + * swank-asdf.lisp: Better ASDF support. + 2012-10-19 Stas Boukarev * slime-fuzzy.el (slime-fuzzy-choices-buffer): Don't move position --- /project/slime/cvsroot/slime/contrib/swank-asdf.lisp 2011/10/05 11:22:21 1.32 +++ /project/slime/cvsroot/slime/contrib/swank-asdf.lisp 2012/11/13 15:44:40 1.33 @@ -1,40 +1,369 @@ -;;; swank-asdf.el -- ASDF support +;;; swank-asdf.lisp -- ASDF support ;; -;; Authors: Daniel Barlow +;; Authors: Daniel Barlow ;; Marco Baringer ;; Edi Weitz -;; and others +;; Francois-Rene Rideau +;; and others ;; License: Public Domain ;; (in-package :swank) -#-asdf (eval-when (:compile-toplevel :load-toplevel :execute) - (require :asdf)) + (defvar *asdf-directory* + (merge-pathnames #p"cl/asdf/" (user-homedir-pathname)) + "Directory in which your favorite and/or latest version + of the ASDF source code is located")) + +;;; Doing our best to load ASDF +;; First, try loading asdf from your implementation +(eval-when (:compile-toplevel :load-toplevel :execute) + (unless (member :asdf *features*) + (ignore-errors (require "asdf")))) + +;; If not found, load asdf from wherever the user specified it +(eval-when (:compile-toplevel :load-toplevel :execute) + (unless (member :asdf *features*) + (handler-bind ((warning #'muffle-warning)) + (ignore-errors (load (make-pathname :name "asdf" :type "lisp" + :defaults *asdf-directory*)))))) +;; If still not found, error out. +(eval-when (:compile-toplevel :load-toplevel :execute) + (unless (member :asdf *features*) + (error "Could not load ASDF. +Please install ASDF2 and in your ~~/.swank.lisp specify: + (defparameter swank::*asdf-directory* #p\"/path/containing/asdf/\")"))) + +;;; If ASDF is found, try to upgrade it to the latest installed version. +;; (eval-when (:compile-toplevel :load-toplevel :execute) +;; (handler-bind ((warning #'muffle-warning)) +;; (pushnew *asdf-directory* asdf:*central-registry*) +;; (asdf:oos 'asdf:load-op :asdf))) + +;;; If ASDF is too old, punt. +(eval-when (:compile-toplevel :load-toplevel :execute) + (unless (or #+asdf2 (asdf:version-satisfies (asdf:asdf-version) "2.000")) + (error "Your ASDF version is too old. +Please upgrade to ASDF2 and in your ~~/.swank.lisp specify: + (defparameter swank::*asdf-directory* #p\"/path/containing/asdf/\")"))) + +;;; Import functionality from ASDF that isn't available in all ASDF versions. +;;; Please do NOT depend on any of the below as reference: +;;; they are sometimes stripped down versions, for compatibility only. +;;; +;;; The way I got these is usually by looking at the current definition, +;;; using git blame in one screen to locate which commit last modified it, +;;; and git log in another to determine which release that made it in. +;;; It is OK for some of the below definitions to be or become obsolete, +;;; as long as it will make do with versions older than the tagged version: +;;; if ASDF is more recent, its more recent version will win. +;;; +;;; If your software is hacking ASDF, use its internals. +;;; If you want ASDF utilities in user software, please use ASDF-UTILS. + +(defun asdf-at-least (version) + (or #+asdf2 (asdf:version-satisfies + (asdf:asdf-version) version))) + +(defmacro asdefs (version &rest defs) + (flet ((defun* (version name aname rest) + `(progn + (defun ,name , at rest) + (declaim (notinline ,name)) + (when (asdf-at-least ,version) + (setf (fdefinition ',name) (fdefinition ',aname))))) + (defvar* (name aname rest) + `(progn + (define-symbol-macro ,name ,aname) + (defvar ,aname , at rest)))) + `(progn + ,@(loop :for (def name . args) :in defs + :for aname = (intern (string name) :asdf) + :collect + (ecase def + ((defun) (defun* version name aname args)) + ((defvar) (defvar* name aname args))))))) + +(asdefs "2.015" + (defvar *wild* #-cormanlisp :wild #+cormanlisp "*")) + +(asdefs "2.010" + (defun collect-sub*directories (directory collectp recursep collector) + (when (funcall collectp directory) + (funcall collector directory)) + (dolist (subdir (subdirectories directory)) + (when (funcall recursep subdir) + (collect-sub*directories subdir collectp recursep collector))))) + +(asdefs "2.011" + (defun find-symbol* (s p) + (find-symbol (string s) p))) + +(asdefs "2.012" + (defvar *wild-file* + (make-pathname :name *wild* :type *wild* + :version (or #-(or abcl xcl) *wild*) :directory nil)) + (defvar *wild-directory* + (make-pathname :directory `(:relative ,*wild*) + :name nil :type nil :version nil))) + +(asdefs "2.014" + (defun ensure-directory-pathname (pathspec) + (cond + ((stringp pathspec) + (ensure-directory-pathname (pathname pathspec))) + ((not (pathnamep pathspec)) + (error "Invalid pathname designator ~S" pathspec)) + ((wild-pathname-p pathspec) + (error "Can't reliably convert wild pathname ~S" pathspec)) + ((asdf::directory-pathname-p pathspec) + pathspec) + (t + (make-pathname :directory (append (or (pathname-directory pathspec) + (list :relative)) + (list (file-namestring pathspec))) + :name nil :type nil :version nil + :defaults pathspec))))) + +(asdefs "2.015" + (defun collect-asds-in-directory (directory collect) + (map () collect (directory-asd-files directory))) + + (defun register-asd-directory (directory &key recurse exclude collect) + (if (not recurse) + (collect-asds-in-directory directory collect) + (collect-sub*directories-asd-files + directory :exclude exclude :collect collect)))) + +(asdefs "2.016" + (defun load-sysdef (name pathname) + (declare (ignore name)) + (let ((package (asdf::make-temporary-package))) + (unwind-protect + (let ((*package* package) + (*default-pathname-defaults* + (asdf::pathname-directory-pathname + (translate-logical-pathname pathname)))) + (asdf::asdf-message + "~&; Loading system definition from ~A into ~A~%" + pathname package) + (load pathname)) + (delete-package package)))) + + (defun directory* (pathname-spec &rest keys &key &allow-other-keys) + (apply 'directory pathname-spec + (append keys + '#.(or #+allegro + '(:directories-are-files nil + :follow-symbolic-links nil) + #+clozure + '(:follow-links nil) + #+clisp + '(:circle t :if-does-not-exist :ignore) + #+(or cmu scl) + '(:follow-links nil :truenamep nil) + #+sbcl + (when (find-symbol "RESOLVE-SYMLINKS" '#:sb-impl) + '(:resolve-symlinks nil))))))) +(asdefs "2.017" + (defun collect-sub*directories-asd-files + (directory &key + (exclude asdf::*default-source-registry-exclusions*) + collect) + (collect-sub*directories + directory + (constantly t) + (lambda (x) (not (member (car (last (pathname-directory x))) + exclude :test #'equal))) + (lambda (dir) (collect-asds-in-directory dir collect)))) + + (defun system-source-directory (system-designator) + (pathname-directory-pathname (asdf::system-source-file system-designator))) + + (defun filter-logical-directory-results (directory entries merger) + (if (typep directory 'logical-pathname) + (loop for f in entries + when + (if (typep f 'logical-pathname) + f + (let ((u (ignore-errors (funcall merger f)))) + (and u + (equal (ignore-errors (truename u)) + (truename f)) + u))) + collect it) + entries)) + + (defun directory-asd-files (directory) + (directory-files directory asdf::*wild-asd*))) + +(asdefs "2.019" + (defun subdirectories (directory) + (let* ((directory (ensure-directory-pathname directory)) + #-(or abcl cormanlisp genera xcl) + (wild (asdf::merge-pathnames* + #-(or abcl allegro cmu lispworks sbcl scl xcl) + *wild-directory* + #+(or abcl allegro cmu lispworks sbcl scl xcl) "*.*" + directory)) + (dirs + #-(or abcl cormanlisp genera xcl) + (ignore-errors + (directory* wild . #.(or #+clozure '(:directories t :files nil) + #+mcl '(:directories t)))) + #+(or abcl xcl) (system:list-directory directory) + #+cormanlisp (cl::directory-subdirs directory) + #+genera (fs:directory-list directory)) + #+(or abcl allegro cmu genera lispworks sbcl scl xcl) + (dirs (loop for x in dirs + for d = #+(or abcl xcl) (extensions:probe-directory x) + #+allegro (excl:probe-directory x) + #+(or cmu sbcl scl) (asdf::directory-pathname-p x) + #+genera (getf (cdr x) :directory) + #+lispworks (lw:file-directory-p x) + when d collect #+(or abcl allegro xcl) d + #+genera (ensure-directory-pathname (first x)) + #+(or cmu lispworks sbcl scl) x))) + (filter-logical-directory-results + directory dirs + (let ((prefix (or (normalize-pathname-directory-component + (pathname-directory directory)) + ;; because allegro returns NIL for #p"FOO:" + '(:absolute)))) + (lambda (d) + (let ((dir (normalize-pathname-directory-component + (pathname-directory d)))) + (and (consp dir) (consp (cdr dir)) + (make-pathname + :defaults directory :name nil :type nil :version nil + :directory + (append prefix + (make-pathname-component-logical + (last dir)))))))))))) + +(asdefs "2.21" + (defun normalize-pathname-directory-component (directory) + (cond + #-(or cmu sbcl scl) + ((stringp directory) `(:absolute ,directory) directory) + #+gcl + ((and (consp directory) (stringp (first directory))) + `(:absolute , at directory)) + ((or (null directory) + (and (consp directory) + (member (first directory) '(:absolute :relative)))) + directory) + (t + (error "Unrecognized pathname directory component ~S" directory)))) + + (defun make-pathname-component-logical (x) + (typecase x + ((eql :unspecific) nil) + #+clisp (string (string-upcase x)) + #+clisp (cons (mapcar 'make-pathname-component-logical x)) + (t x))) + + (defun make-pathname-logical (pathname host) + (make-pathname + :host host + :directory (make-pathname-component-logical (pathname-directory pathname)) + :name (make-pathname-component-logical (pathname-name pathname)) + :type (make-pathname-component-logical (pathname-type pathname)) + :version (make-pathname-component-logical (pathname-version pathname))))) + +(asdefs "2.022" + (defun directory-files (directory &optional (pattern *wild-file*)) + (let ((dir (pathname directory))) + (when (typep dir 'logical-pathname) + (when (wild-pathname-p dir) + (error "Invalid wild pattern in logical directory ~S" directory)) + (unless (member (pathname-directory pattern) + '(() (:relative)) :test 'equal) + (error "Invalid file pattern ~S for logical directory ~S" + pattern directory)) + (setf pattern (make-pathname-logical pattern (pathname-host dir)))) + (let ((entries (ignore-errors + (directory* (asdf::merge-pathnames* pattern dir))))) + (filter-logical-directory-results + directory entries + (lambda (f) + (make-pathname :defaults dir + :name (make-pathname-component-logical + (pathname-name f)) + :type (make-pathname-component-logical + (pathname-type f)) + :version (make-pathname-component-logical + (pathname-version f))))))))) + +;;; Taken from ASDF 1.628 +(defmacro while-collecting ((&rest collectors) &body body) + (let ((vars (mapcar (lambda (x) (gensym (symbol-name x))) collectors)) + (initial-values (mapcar (constantly nil) collectors))) + `(let ,(mapcar #'list vars initial-values) + (flet ,(mapcar (lambda (c v) `(,c (x) (push x ,v) (values))) + collectors vars) + , at body + (values ,@(mapcar (lambda (v) `(reverse ,v)) vars)))))) + + +;;; Now for SLIME-specific stuff (defun find-operation (operation) - (or (find-symbol (symbol-name operation) :asdf) + (or (find-symbol* operation :asdf) (error "Couldn't find ASDF operation ~S" operation))) -(defun map-defined-systems (fn) - (loop for (nil . system) being the hash-values in asdf::*defined-systems* - do (funcall fn system))) +(defun map-system-components (fn system) + (map-component-subcomponents fn (asdf:find-system system))) + +(defun map-component-subcomponents (fn component) + (when component + (funcall fn component) + (when (typep component 'asdf:module) + (dolist (c (asdf:module-components component)) + (map-component-subcomponents fn c))))) + +;;; Maintaining a pathname to component table + +(defvar *pathname-component* (make-hash-table :test 'equal)) + +(defun clear-pathname-component-table () + (clrhash *pathname-component*)) -;;; This is probably a crude hack, see ASDF's LP #481187. +(defun register-system-pathnames (system) + (map-system-components 'register-component-pathname system)) + +(defun recompute-pathname-component-table () + (clear-pathname-component-table) + (asdf::map-systems 'register-system-pathnames)) + +(defun pathname-component (x) + (gethash (pathname x) *pathname-component*)) + +(defmethod asdf:component-pathname :around ((component asdf:component)) + (let ((p (call-next-method))) + (setf (gethash p *pathname-component*) component) + p)) + +(defun register-component-pathname (component) + (asdf:component-pathname component)) + +(recompute-pathname-component-table) + +;;; This is a crude hack, see ASDF's LP #481187. (defslimefun who-depends-on (system) (flet ((system-dependencies (op system) - (mapcar #'(lambda (dep) - (asdf::coerce-name (if (consp dep) (second dep) dep))) + (mapcar (lambda (dep) + (asdf::coerce-name (if (consp dep) (second dep) dep))) (cdr (assoc op (asdf:component-depends-on op system)))))) (let ((system-name (asdf::coerce-name system)) (result)) - (map-defined-systems - #'(lambda (system) - (when (member system-name - (system-dependencies 'asdf:load-op system) - :test #'string=) - (push (asdf:component-name system) result)))) + (asdf::map-systems + (lambda (system) + (when (member system-name + (system-dependencies 'asdf:load-op system) + :test #'string=) + (push (asdf:component-name system) result)))) result))) (defmethod xref-doit ((type (eql :depends-on)) thing) @@ -49,7 +378,6 @@ `(:snippet ,(format nil "(defsystem :~A" dependency) :align t)))))) - (defslimefun operate-on-system-for-emacs (system-name operation &rest keywords) "Compile and load SYSTEM using ASDF. Record compiler notes signalled as `compiler-condition's." @@ -69,65 +397,68 @@ t) [226 lines skipped] From sboukarev at common-lisp.net Thu Nov 22 12:41:26 2012 From: sboukarev at common-lisp.net (CVS User sboukarev) Date: Thu, 22 Nov 2012 04:41:26 -0800 Subject: [slime-cvs] CVS slime/contrib Message-ID: Update of /project/slime/cvsroot/slime/contrib In directory tiger.common-lisp.net:/tmp/cvs-serv4778/contrib Modified Files: ChangeLog slime-package-fu.el Log Message: * contrib/slime-package-fu.el (slime-determine-symbol-style): Fix the default case when no :export symbols are present. Because of (every anything nil) => T. --- /project/slime/cvsroot/slime/contrib/ChangeLog 2012/11/13 15:44:40 1.553 +++ /project/slime/cvsroot/slime/contrib/ChangeLog 2012/11/22 12:41:26 1.554 @@ -1,3 +1,9 @@ +2012-11-22 Stas Boukarev + + * slime-package-fu.el (slime-determine-symbol-style): Fix the + default case when no :export symbols are present. + Because of (every anything nil) => T. + 2012-11-13 Francois-Rene Rideau * swank-asdf.lisp: Better ASDF support. --- /project/slime/cvsroot/slime/contrib/slime-package-fu.el 2012/03/06 01:47:49 1.16 +++ /project/slime/cvsroot/slime/contrib/slime-package-fu.el 2012/11/22 12:41:26 1.17 @@ -18,7 +18,8 @@ (defvar slime-package-file-candidates (mapcar #'file-name-nondirectory - '("package.lisp" "packages.lisp" "pkgdcl.lisp" "defpackage.lisp"))) + '("package.lisp" "packages.lisp" "pkgdcl.lisp" + "defpackage.lisp"))) (defvar slime-export-symbol-representation-function #'(lambda (n) (format "#:%s" n))) @@ -35,7 +36,8 @@ "^(\\(cl:\\|common-lisp:\\)?defpackage\\>[ \t']*") (defun slime-find-package-definition-rpc (package) - (slime-eval `(swank:find-definition-for-thing (swank::guess-package ,package)))) + (slime-eval `(swank:find-definition-for-thing + (swank::guess-package ,package)))) (defun slime-find-package-definition-regexp (package) (save-excursion @@ -73,14 +75,16 @@ (file-name-as-directory "..")))) (try (dirname) (dolist (package-file-name slime-package-file-candidates) - (let ((f (slime-to-lisp-filename (concat dirname package-file-name)))) + (let ((f (slime-to-lisp-filename + (concat dirname package-file-name)))) (when (file-readable-p f) (return f)))))) (when buffer-file-name (let ((buffer-cwd (file-name-directory buffer-file-name))) (or (try buffer-cwd) (try (file-name-subdirectory buffer-cwd)) - (try (file-name-subdirectory (file-name-subdirectory buffer-cwd)))))))) + (try (file-name-subdirectory + (file-name-subdirectory buffer-cwd)))))))) (defun slime-goto-package-source-definition (package) "Tries to find the DEFPACKAGE form of `package'. If found, @@ -91,7 +95,8 @@ t))) (or (try (slime-find-package-definition-rpc package)) (try (slime-find-package-definition-regexp package)) - (try (when-let (package-file (slime-find-possible-package-file (buffer-file-name))) + (try (when-let (package-file (slime-find-possible-package-file + (buffer-file-name))) (with-current-buffer (find-file-noselect package-file t) (slime-find-package-definition-regexp package)))) (error "Couldn't find source definition of package: %s" package)))) @@ -217,7 +222,9 @@ (slime-beginning-of-list) (slime-forward-sexp) (let ((symbols (slime-export-symbols))) - (cond ((every (lambda (x) + (cond ((null symbols) + slime-export-symbol-representation-function) + ((every (lambda (x) (string-match "^:" x)) symbols) (lambda (n) (format ":%s" n))) @@ -264,13 +271,17 @@ (unless symbol (error "No symbol at point.")) (cond (current-prefix-arg (if (plusp (slime-frob-defpackage-form package :unexport symbol)) - (message "Symbol `%s' no longer exported form `%s'" symbol package) - (message "Symbol `%s' is not exported from `%s'" symbol package)) + (message "Symbol `%s' no longer exported form `%s'" + symbol package) + (message "Symbol `%s' is not exported from `%s'" + symbol package)) (slime-unexport-symbol symbol package)) (t (if (plusp (slime-frob-defpackage-form package :export symbol)) - (message "Symbol `%s' now exported from `%s'" symbol package) - (message "Symbol `%s' already exported from `%s'" symbol package)) + (message "Symbol `%s' now exported from `%s'" + symbol package) + (message "Symbol `%s' already exported from `%s'" + symbol package)) (slime-export-symbol symbol package))))) (defun slime-export-class (name) From sboukarev at common-lisp.net Fri Nov 23 11:28:27 2012 From: sboukarev at common-lisp.net (CVS User sboukarev) Date: Fri, 23 Nov 2012 03:28:27 -0800 Subject: [slime-cvs] CVS slime/contrib Message-ID: Update of /project/slime/cvsroot/slime/contrib In directory tiger.common-lisp.net:/tmp/cvs-serv12856 Modified Files: ChangeLog slime-repl.el swank-repl.lisp Log Message: * slime-repl.el (slime-repl-print-right-margin-follows-window): New variable, defaults to NIL. (slime-repl-eval-string): Respect the above variable. * swank-repl.lisp (listener-eval): New keyword parameter, window-width, if supplied binds *print-right-margin* to its value. Based on a patch by Marco Baringer. --- /project/slime/cvsroot/slime/contrib/ChangeLog 2012/11/22 12:41:26 1.554 +++ /project/slime/cvsroot/slime/contrib/ChangeLog 2012/11/23 11:28:27 1.555 @@ -1,3 +1,13 @@ +2012-11-23 Stas Boukarev + + * slime-repl.el (slime-repl-print-right-margin-follows-window): + New variable, defaults to NIL. + (slime-repl-eval-string): Respect the above variable. + * swank-repl.lisp (listener-eval): New keyword parameter, + window-width, if supplied binds *print-right-margin* to its + value. + Based on a patch by Marco Baringer. + 2012-11-22 Stas Boukarev * slime-package-fu.el (slime-determine-symbol-style): Fix the --- /project/slime/cvsroot/slime/contrib/slime-repl.el 2011/12/23 20:03:15 1.63 +++ /project/slime/cvsroot/slime/contrib/slime-repl.el 2012/11/23 11:28:27 1.64 @@ -52,6 +52,12 @@ :type '(boolean) :group 'slime-repl) +(defcustom slime-repl-print-right-margin-follows-window nil + "When T we bind CL:*PRINT-RIGHT-MARGIN* to the width of the +current repl's (as per slime-output-buffer) window." + :type '(boolean) + :group 'slime-repl) + (defface slime-repl-prompt-face (if (slime-face-inheritance-possible-p) '((t (:inherit font-lock-keyword-face))) @@ -524,7 +530,13 @@ (defun slime-repl-eval-string (string) (slime-rex () - ((list 'swank:listener-eval string) (slime-lisp-package)) + ((if slime-repl-print-right-margin-follows-window + `(swank:listener-eval ,string + :window-width + ,(with-current-buffer (slime-output-buffer) + (window-width))) + `(swank:listener-eval ,string)) + (slime-lisp-package)) ((:ok result) (slime-repl-insert-result result)) ((:abort condition) @@ -550,7 +562,8 @@ (slime-save-marker slime-output-start (slime-save-marker slime-output-end (goto-char slime-output-end) - (insert-before-markers (format "; Evaluation aborted on %s.\n" condition)) + (insert-before-markers (format "; Evaluation aborted on %s.\n" + condition)) (slime-repl-insert-prompt)))) (slime-repl-show-maximum-output))) @@ -574,7 +587,8 @@ '(face slime-repl-prompt-face read-only t intangible t slime-repl-prompt t ;; emacs stuff - rear-nonsticky (slime-repl-prompt read-only face intangible) + rear-nonsticky (slime-repl-prompt read-only face + intangible) ;; xemacs stuff start-open t end-open t) (insert-before-markers prompt)) @@ -1511,7 +1525,8 @@ name)) (qualified-symbol-name (slime-qualify-cl-symbol-name symbol)) (symbol-name (slime-cl-symbol-name qualified-symbol-name)) - (symbol-package (slime-cl-symbol-package qualified-symbol-name)) + (symbol-package (slime-cl-symbol-package + qualified-symbol-name)) (call (if (equalp (slime-lisp-package) symbol-package) symbol-name qualified-symbol-name))) @@ -1585,7 +1600,8 @@ (interactive) (let* ((package (slime-current-package)) (exists-p (or (null package) - (slime-eval `(cl:packagep (swank::guess-package ,package))))) + (slime-eval `(cl:packagep + (swank::guess-package ,package))))) (directory default-directory)) (when (and package exists-p) (slime-repl-set-package package)) @@ -1717,12 +1733,14 @@ (defun slime-repl-add-hooks () (add-hook 'slime-event-hooks 'slime-repl-event-hook-function) (add-hook 'slime-connected-hook 'slime-repl-connected-hook-function) - (add-hook 'slime-cycle-connections-hook 'slime-change-repl-to-default-connection)) + (add-hook 'slime-cycle-connections-hook + 'slime-change-repl-to-default-connection)) (defun slime-repl-remove-hooks () (remove-hook 'slime-event-hooks 'slime-repl-event-hook-function) (remove-hook 'slime-connected-hook 'slime-repl-connected-hook-function) - (remove-hook 'slime-cycle-connections-hook 'slime-change-repl-to-default-connection)) + (remove-hook 'slime-cycle-connections-hook + 'slime-change-repl-to-default-connection)) (let ((byte-compile-warnings '())) (mapc #'byte-compile @@ -1989,7 +2007,8 @@ (slime-wait-condition "Debugger visible" (lambda () (and (slime-sldb-level= 1) - (get-buffer-window (sldb-get-default-buffer)))) + (get-buffer-window + (sldb-get-default-buffer)))) 5) (with-current-buffer (sldb-get-default-buffer) (sldb-continue)) --- /project/slime/cvsroot/slime/contrib/swank-repl.lisp 2012/03/06 20:55:13 1.5 +++ /project/slime/cvsroot/slime/contrib/swank-repl.lisp 2012/11/23 11:28:27 1.6 @@ -156,8 +156,11 @@ (defvar *listener-eval-function* 'repl-eval) -(defslimefun listener-eval (string) - (funcall *listener-eval-function* string)) +(defslimefun listener-eval (string &key (window-width nil window-width-p)) + (if window-width-p + (let ((*print-right-margin* window-width)) + (funcall *listener-eval-function* string)) + (funcall *listener-eval-function* string))) (defvar *send-repl-results-function* 'send-repl-results-to-emacs) From sboukarev at common-lisp.net Fri Nov 23 11:37:53 2012 From: sboukarev at common-lisp.net (CVS User sboukarev) Date: Fri, 23 Nov 2012 03:37:53 -0800 Subject: [slime-cvs] CVS slime/contrib Message-ID: Update of /project/slime/cvsroot/slime/contrib In directory tiger.common-lisp.net:/tmp/cvs-serv17918 Modified Files: ChangeLog slime-repl.el Log Message: Rename slime-repl-print-right-margin-follows-window to slime-repl-auto-right-margin. --- /project/slime/cvsroot/slime/contrib/ChangeLog 2012/11/23 11:28:27 1.555 +++ /project/slime/cvsroot/slime/contrib/ChangeLog 2012/11/23 11:37:53 1.556 @@ -1,6 +1,6 @@ 2012-11-23 Stas Boukarev - * slime-repl.el (slime-repl-print-right-margin-follows-window): + * slime-repl.el (slime-repl-auto-right-margin): New variable, defaults to NIL. (slime-repl-eval-string): Respect the above variable. * swank-repl.lisp (listener-eval): New keyword parameter, --- /project/slime/cvsroot/slime/contrib/slime-repl.el 2012/11/23 11:28:27 1.64 +++ /project/slime/cvsroot/slime/contrib/slime-repl.el 2012/11/23 11:37:53 1.65 @@ -52,7 +52,7 @@ :type '(boolean) :group 'slime-repl) -(defcustom slime-repl-print-right-margin-follows-window nil +(defcustom slime-repl-auto-right-margin nil "When T we bind CL:*PRINT-RIGHT-MARGIN* to the width of the current repl's (as per slime-output-buffer) window." :type '(boolean) @@ -530,7 +530,7 @@ (defun slime-repl-eval-string (string) (slime-rex () - ((if slime-repl-print-right-margin-follows-window + ((if slime-repl-auto-right-margin `(swank:listener-eval ,string :window-width ,(with-current-buffer (slime-output-buffer) From sboukarev at common-lisp.net Fri Nov 23 15:32:13 2012 From: sboukarev at common-lisp.net (CVS User sboukarev) Date: Fri, 23 Nov 2012 07:32:13 -0800 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory tiger.common-lisp.net:/tmp/cvs-serv7885 Modified Files: ChangeLog slime.el Log Message: * slime.el (slime-edit-definition): Don't ask the user for a name to search if it's missing before running slime-edit-definition-hooks, the hooks might search for name in a different manner (for example, presentations). --- /project/slime/cvsroot/slime/ChangeLog 2012/11/13 15:44:39 1.2369 +++ /project/slime/cvsroot/slime/ChangeLog 2012/11/23 15:32:12 1.2370 @@ -1,3 +1,8 @@ +2012-11-23 Stas Boukarev + + * slime.el (slime-edit-definition): Don't ask the user for a name + to search if it's missing before running slime-edit-definition-hooks + 2012-11-13 Francois-Rene Rideau * swank.lisp (*compile-file-for-emacs-hook*): A hook for --- /project/slime/cvsroot/slime/slime.el 2012/11/11 09:31:07 1.1422 +++ /project/slime/cvsroot/slime/slime.el 2012/11/23 15:32:13 1.1423 @@ -3909,15 +3909,27 @@ ;;; `slime-edit-definition'. (defvar slime-edit-definition-hooks) -(defun slime-edit-definition (name &optional where) +(defun slime-edit-definition (&optional name where) "Lookup the definition of the name at point. If there's no name at point, or a prefix argument is given, then the function name is prompted." - (interactive (list (slime-read-symbol-name "Edit Definition of: "))) - (or (run-hook-with-args-until-success 'slime-edit-definition-hooks - name where) - (slime-edit-definition-cont (slime-find-definitions name) - name where))) + (interactive) + (let ((name (cond ((not (called-interactively-p)) + name) + (current-prefix-arg + (slime-read-symbol-name "Edit Definition of: ")) + (t + (slime-symbol-at-point))))) + ;; The hooks might search for a name in a different manner, so don't + ;; ask the user if it's missing before the hooks are run + (or (run-hook-with-args-until-success 'slime-edit-definition-hooks + name where) + (let ((name (or name + (if (called-interactively-p) + (slime-read-symbol-name "Edit Definition of: ") + name)))) + (slime-edit-definition-cont (slime-find-definitions name) + name where))))) (defun slime-edit-definition-cont (xrefs name where) (destructuring-bind (1loc file-alist) (slime-analyze-xrefs xrefs) From sboukarev at common-lisp.net Fri Nov 23 17:51:16 2012 From: sboukarev at common-lisp.net (CVS User sboukarev) Date: Fri, 23 Nov 2012 09:51:16 -0800 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory tiger.common-lisp.net:/tmp/cvs-serv19642 Modified Files: ChangeLog slime.el Log Message: * slime.el (slime-edit-definition): Don't ask the user for a name to search if it's missing before running slime-edit-definition-hooks (slime-open-inspector): pop-to-buffer before inserting anything, otherwise the point is not moved into the desired position. --- /project/slime/cvsroot/slime/ChangeLog 2012/11/23 15:32:12 1.2370 +++ /project/slime/cvsroot/slime/ChangeLog 2012/11/23 17:51:15 1.2371 @@ -2,6 +2,8 @@ * slime.el (slime-edit-definition): Don't ask the user for a name to search if it's missing before running slime-edit-definition-hooks + (slime-open-inspector): pop-to-buffer before inserting anything, + otherwise the point is not moved into the desired position. 2012-11-13 Francois-Rene Rideau --- /project/slime/cvsroot/slime/slime.el 2012/11/23 15:32:13 1.1423 +++ /project/slime/cvsroot/slime/slime.el 2012/11/23 17:51:16 1.1424 @@ -6553,26 +6553,26 @@ (setq slime-buffer-connection (slime-current-connection)) (let ((inhibit-read-only t)) (erase-buffer) + (pop-to-buffer (current-buffer)) (destructuring-bind (&key id title content) inspected-parts - (macrolet ((fontify (face string) - `(slime-inspector-fontify ,face ,string))) + (macrolet ((fontify (face string) + `(slime-inspector-fontify ,face ,string))) (slime-propertize-region - (list 'slime-part-number id + (list 'slime-part-number id 'mouse-face 'highlight 'face 'slime-inspector-value-face) - (insert title)) + (insert title)) (while (eq (char-before) ?\n) (backward-delete-char 1)) (insert "\n" (fontify label "--------------------") "\n") (save-excursion - (slime-inspector-insert-content content)) - (pop-to-buffer (current-buffer)) + (slime-inspector-insert-content content)) (when point (check-type point cons) (ignore-errors - (goto-char (point-min)) - (forward-line (1- (car point))) - (move-to-column (cdr point))))))))) + (goto-char (point-min)) + (forward-line (1- (car point))) + (move-to-column (cdr point))))))))) (defvar slime-inspector-limit 500) From sboukarev at common-lisp.net Wed Nov 28 20:52:29 2012 From: sboukarev at common-lisp.net (CVS User sboukarev) Date: Wed, 28 Nov 2012 12:52:29 -0800 Subject: [slime-cvs] CVS slime/contrib Message-ID: Update of /project/slime/cvsroot/slime/contrib In directory tiger.common-lisp.net:/tmp/cvs-serv27311 Modified Files: ChangeLog swank-asdf.lisp Log Message: * swank-asdf.lisp (asdf-system-directory): Return a namestring, not a namestring. --- /project/slime/cvsroot/slime/contrib/ChangeLog 2012/11/23 11:37:53 1.556 +++ /project/slime/cvsroot/slime/contrib/ChangeLog 2012/11/28 20:52:29 1.557 @@ -1,3 +1,8 @@ +2012-11-28 Stas Boukarev + + * swank-asdf.lisp (asdf-system-directory): Return a namestring, + not a namestring. + 2012-11-23 Stas Boukarev * slime-repl.el (slime-repl-auto-right-margin): --- /project/slime/cvsroot/slime/contrib/swank-asdf.lisp 2012/11/13 15:44:40 1.33 +++ /project/slime/cvsroot/slime/contrib/swank-asdf.lisp 2012/11/28 20:52:29 1.34 @@ -472,7 +472,7 @@ t)) (defslimefun asdf-system-directory (name) - (asdf:system-source-directory name)) + (namestring (asdf:system-source-directory name))) (defun pathname-system (pathname) (let ((component (pathname-component pathname))) From sboukarev at common-lisp.net Wed Nov 28 20:53:22 2012 From: sboukarev at common-lisp.net (CVS User sboukarev) Date: Wed, 28 Nov 2012 12:53:22 -0800 Subject: [slime-cvs] CVS slime/contrib Message-ID: Update of /project/slime/cvsroot/slime/contrib In directory tiger.common-lisp.net:/tmp/cvs-serv27460 Modified Files: ChangeLog Log Message: Fix a typo. --- /project/slime/cvsroot/slime/contrib/ChangeLog 2012/11/28 20:52:29 1.557 +++ /project/slime/cvsroot/slime/contrib/ChangeLog 2012/11/28 20:53:22 1.558 @@ -1,7 +1,7 @@ 2012-11-28 Stas Boukarev * swank-asdf.lisp (asdf-system-directory): Return a namestring, - not a namestring. + not a pathname. 2012-11-23 Stas Boukarev