From heller at common-lisp.net Thu Jun 4 08:50:25 2009 From: heller at common-lisp.net (CVS User heller) Date: Thu, 04 Jun 2009 04:50:25 -0400 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory cl-net:/tmp/cvs-serv11310 Modified Files: ChangeLog swank-openmcl.lisp Log Message: * swank-openmcl.lisp (*known-processes*, mailbox): Use a weak hashtable to plug the memory leak. --- /project/slime/cvsroot/slime/ChangeLog 2009/05/28 19:01:09 1.1776 +++ /project/slime/cvsroot/slime/ChangeLog 2009/06/04 08:50:24 1.1777 @@ -45,6 +45,11 @@ Patch by Madhu. +2009-05-24 Helmut Eller + + * swank-openmcl.lisp (*known-processes*, mailbox): Use a weak + hashtable to plug the memory leak. + 2009-05-23 Helmut Eller * swank-openmcl.lisp (break-in-sldb): Honor *break-on-signals*. --- /project/slime/cvsroot/slime/swank-openmcl.lisp 2009/05/23 16:48:16 1.172 +++ /project/slime/cvsroot/slime/swank-openmcl.lisp 2009/06/04 08:50:24 1.173 @@ -517,6 +517,13 @@ (ccl::apply-in-frame p lfun (ccl::frame-supplied-args p lfun pc nil context)))) +(defimplementation disassemble-frame (the-frame-number) + (with-frame (p context lfun pc) the-frame-number + (declare (ignore p context pc)) + (disassemble lfun))) + +;; BREAK + (ccl::advise ccl::cbreak-loop (if *break-in-sldb* (apply #'break-in-sldb ccl::arglist) @@ -537,10 +544,6 @@ :format-arguments (list msg))) (t condition))) -(defimplementation disassemble-frame (the-frame-number) - (with-frame (p context lfun pc) the-frame-number - (declare (ignore p context pc)) - (disassemble lfun))) ;; CCL commit r11373 | gz | 2008-11-16 16:35:28 +0100 (Sun, 16 Nov 2008) ;; contains some interesting details: @@ -812,9 +815,9 @@ ;;; Multiprocessing -(defvar *known-processes* '() ; FIXME: leakage. -luke - "Alist (ID . PROCESS MAILBOX) list of processes that we have handed -out IDs for.") +(defvar *known-processes* + (make-hash-table :size 20 :weak :key :test #'eq) + "A map from threads to mailboxes.") (defvar *known-processes-lock* (ccl:make-lock "*known-processes-lock*")) @@ -875,17 +878,8 @@ (defun mailbox (thread) (ccl:with-lock-grabbed (*known-processes-lock*) - (let ((probe (rassoc thread *known-processes* :key #'car))) - (cond (probe (second (cdr probe))) - (t (let ((mailbox (make-mailbox))) - (setq *known-processes* - (acons (ccl::process-serial-number thread) - (list thread mailbox) - (remove-if - (lambda (entry) - (ccl::process-exhausted-p (cadr entry))) - *known-processes*))) - mailbox)))))) + (or (gethash thread *known-processes*) + (setf (gethash thread *known-processes*) (make-mailbox))))) (defimplementation send (thread message) (assert message) From heller at common-lisp.net Thu Jun 4 08:50:30 2009 From: heller at common-lisp.net (CVS User heller) Date: Thu, 04 Jun 2009 04:50:30 -0400 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory cl-net:/tmp/cvs-serv11345 Modified Files: HACKING Log Message: Mention docstrings. --- /project/slime/cvsroot/slime/HACKING 2008/03/24 00:20:12 1.9 +++ /project/slime/cvsroot/slime/HACKING 2009/06/04 08:50:30 1.10 @@ -141,7 +141,17 @@ For Emacs Lisp, we try to follow the _Tips and Conventions_ in Appendix D of the GNU Emacs Lisp Reference Manual (see Info file -`elisp', node `Tips'). +`elisp', node `Tips'). + +We use Emacs conventions for docstrings: the first line should be a +complete sentence to make the output of `apropos' look good. We also +use imperative verbs. + +The biggest problem with SLIME's code base is feature creep. Keep in +mind that the Right Thing isn't always the Smart Thing. If you can't +find an elegant solution to a problem then you're probably solving the +wrong problem. It's often a good idea to simplify the problem and to +ignore rarely needed cases. Remember that to rewrite a program better is the sincerest form of code appreciation. When you can see a way to rewrite a part of SLIME From heller at common-lisp.net Thu Jun 4 08:50:38 2009 From: heller at common-lisp.net (CVS User heller) Date: Thu, 04 Jun 2009 04:50:38 -0400 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory cl-net:/tmp/cvs-serv11376 Modified Files: ChangeLog Log Message: *** empty log message *** --- /project/slime/cvsroot/slime/ChangeLog 2009/06/04 08:50:24 1.1777 +++ /project/slime/cvsroot/slime/ChangeLog 2009/06/04 08:50:37 1.1778 @@ -1,3 +1,8 @@ +2009-06-04 Helmut Eller + + * swank-openmcl.lisp (*known-processes*, mailbox): Use a weak + hashtable to plug the memory leak. + 2009-05-28 Tobias C. Rittweiler * slime.el (def-slime-test): Forgot to remove debugging code. @@ -45,11 +50,6 @@ Patch by Madhu. -2009-05-24 Helmut Eller - - * swank-openmcl.lisp (*known-processes*, mailbox): Use a weak - hashtable to plug the memory leak. - 2009-05-23 Helmut Eller * swank-openmcl.lisp (break-in-sldb): Honor *break-on-signals*. From heller at common-lisp.net Thu Jun 4 09:08:08 2009 From: heller at common-lisp.net (CVS User heller) Date: Thu, 04 Jun 2009 05:08:08 -0400 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory cl-net:/tmp/cvs-serv15573 Modified Files: ChangeLog slime.el Log Message: * slime.el (slime-dispatch-event [:emcas-rex]): Don't clutter the main code-path with confusing error handling. --- /project/slime/cvsroot/slime/ChangeLog 2009/06/04 08:50:37 1.1778 +++ /project/slime/cvsroot/slime/ChangeLog 2009/06/04 09:08:06 1.1779 @@ -1,5 +1,10 @@ 2009-06-04 Helmut Eller + * slime.el (slime-dispatch-event [:emcas-rex]): Don't clutter + the main code-path with confusing error handling. + +2009-06-04 Helmut Eller + * swank-openmcl.lisp (*known-processes*, mailbox): Use a weak hashtable to plug the memory leak. --- /project/slime/cvsroot/slime/slime.el 2009/05/28 19:01:09 1.1183 +++ /project/slime/cvsroot/slime/slime.el 2009/06/04 09:08:06 1.1184 @@ -2375,18 +2375,10 @@ ((:emacs-rex form package thread continuation) (when (and (slime-use-sigint-for-interrupt) (slime-busy-p)) (slime-display-oneliner "; pipelined request... %S" form)) - (let ((id (incf (slime-continuation-counter))) - (send-ok nil)) + (let ((id (incf (slime-continuation-counter)))) + (slime-send `(:emacs-rex ,form ,package ,thread ,id)) (push (cons id continuation) (slime-rex-continuations)) - (unwind-protect - (progn - (slime-send `(:emacs-rex ,form ,package ,thread ,id)) - (setq send-ok t)) - (unless send-ok - (setf (slime-rex-continuations) - (cdr (slime-rex-continuations))) - (funcall continuation '(:abort))) - (slime-recompute-modelines t)))) + (slime-recompute-modelines t))) ((:return value id) (let ((rec (assq id (slime-rex-continuations)))) (cond (rec (setf (slime-rex-continuations) From heller at common-lisp.net Fri Jun 5 19:49:02 2009 From: heller at common-lisp.net (CVS User heller) Date: Fri, 05 Jun 2009 15:49:02 -0400 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory cl-net:/tmp/cvs-serv25094 Modified Files: ChangeLog swank-openmcl.lisp Log Message: Don't clutter compiler messages with source positions. Especially stuff like "In an anonymous lambda form inside an anonymous lambda form inside an anonymous lambda form inside FOO: Undeclared free variable X" is not helpful. * swank-openmcl.lisp (compiler-warning-short-message): New GF. (handle-compiler-warning): Use it. --- /project/slime/cvsroot/slime/ChangeLog 2009/06/04 09:08:06 1.1779 +++ /project/slime/cvsroot/slime/ChangeLog 2009/06/05 19:49:01 1.1780 @@ -1,3 +1,13 @@ +2009-06-05 Helmut Eller + + Don't clutter compiler messages with source positions. Especially + stuff like "In an anonymous lambda form inside an anonymous lambda + form inside an anonymous lambda form inside FOO: Undeclared free + variable X" is not helpful. + + * swank-openmcl.lisp (compiler-warning-short-message): New GF. + (handle-compiler-warning): Use it. + 2009-06-04 Helmut Eller * slime.el (slime-dispatch-event [:emcas-rex]): Don't clutter --- /project/slime/cvsroot/slime/swank-openmcl.lisp 2009/06/04 08:50:24 1.173 +++ /project/slime/cvsroot/slime/swank-openmcl.lisp 2009/06/05 19:49:02 1.174 @@ -229,6 +229,7 @@ 'compiler-condition :original-condition condition :message (format nil "~A" condition) + :short-message (compiler-warning-short-message condition) :severity (compiler-warning-severity condition) :location (source-note-to-source-location (ccl::compiler-warning-source-note condition) @@ -238,6 +239,24 @@ (defmethod compiler-warning-severity ((c ccl::compiler-warning)) :warning) (defmethod compiler-warning-severity ((c ccl::style-warning)) :style-warning) +(defgeneric compiler-warning-short-message (condition)) + +;; Pretty much the same as ccl::report-compiler-warning but +;; without the source position and function name stuff. +(defmethod compiler-warning-short-message ((c ccl::compiler-warning)) + (with-accessors ((type ccl::compiler-warning-warning-type) + (args ccl::compiler-warning-args) + (nrefs ccl::compiler-warning-nrefs)) c + (with-output-to-string (stream) + (let ((format-string (cdr (assoc type ccl::*compiler-warning-formats*)))) + (typecase format-string + (string (apply #'format stream format-string + (ccl::adjust-compiler-warning-args type args))) + (null (format stream "~A: ~S" type args)) + (t (funcall format-string c stream))) + (when (and nrefs (/= nrefs 1)) + (format stream " (~D references)" nrefs)))))) + (defimplementation call-with-compilation-hooks (function) (handler-bind ((ccl::compiler-warning 'handle-compiler-warning)) (funcall function))) @@ -519,7 +538,7 @@ (defimplementation disassemble-frame (the-frame-number) (with-frame (p context lfun pc) the-frame-number - (declare (ignore p context pc)) + (format t "LFUN: ~a~%PC: ~a FP: #x~x CONTEXT: ~a~%" flun pc p context) (disassemble lfun))) ;; BREAK From heller at common-lisp.net Fri Jun 5 19:58:54 2009 From: heller at common-lisp.net (CVS User heller) Date: Fri, 05 Jun 2009 15:58:54 -0400 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory cl-net:/tmp/cvs-serv27345 Modified Files: ChangeLog swank-openmcl.lisp Log Message: * swank-openmcl.lisp (disassemble-frame): Print current PC. --- /project/slime/cvsroot/slime/ChangeLog 2009/06/05 19:49:01 1.1780 +++ /project/slime/cvsroot/slime/ChangeLog 2009/06/05 19:58:53 1.1781 @@ -8,6 +8,8 @@ * swank-openmcl.lisp (compiler-warning-short-message): New GF. (handle-compiler-warning): Use it. + (disassemble-frame): Print current PC. + 2009-06-04 Helmut Eller * slime.el (slime-dispatch-event [:emcas-rex]): Don't clutter --- /project/slime/cvsroot/slime/swank-openmcl.lisp 2009/06/05 19:49:02 1.174 +++ /project/slime/cvsroot/slime/swank-openmcl.lisp 2009/06/05 19:58:54 1.175 @@ -538,7 +538,7 @@ (defimplementation disassemble-frame (the-frame-number) (with-frame (p context lfun pc) the-frame-number - (format t "LFUN: ~a~%PC: ~a FP: #x~x CONTEXT: ~a~%" flun pc p context) + (format t "LFUN: ~a~%PC: ~a FP: #x~x CONTEXT: ~a~%" lfun pc p context) (disassemble lfun))) ;; BREAK From trittweiler at common-lisp.net Thu Jun 11 08:07:18 2009 From: trittweiler at common-lisp.net (CVS User trittweiler) Date: Thu, 11 Jun 2009 04:07:18 -0400 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory cl-net:/tmp/cvs-serv11907 Modified Files: slime.el ChangeLog Log Message: * slime.el ([test] font-lock-magic): Moved to fontifying-fu contrib. --- /project/slime/cvsroot/slime/slime.el 2009/06/04 09:08:06 1.1184 +++ /project/slime/cvsroot/slime/slime.el 2009/06/11 08:07:17 1.1185 @@ -7449,91 +7449,6 @@ (slime-autodoc-mode -1)))) (setq lisp-mode-hook hook)))) -(def-slime-test font-lock-magic (buffer-content) - "Some testing for the font-lock-magic. *YES* should be - highlighted as a suppressed form, *NO* should not." - - '(("(defun *NO* (x y) (+ x y))") - ("(defun *NO*") - ("*NO*) #-(and) (*YES*) (*NO* *NO*") - ("\( -\(defun *NO*") - ("\) -\(defun *NO* - \( -\)") - ("#+#.foo -\(defun *NO* (x y) (+ x y))") - ("#+#.foo -\(defun *NO* (x ") - ("#+( -\(defun *NO* (x ") - ("#+(test) -\(defun *NO* (x ") - - ("(eval-when (...) -\(defun *NO* (x ") - - ("(eval-when (...) -#+(and) -\(defun *NO* (x ") - - ("#-(and) (defun *YES* (x y) (+ x y))") - (" -#-(and) (defun *YES* (x y) (+ x y)) -#+(and) (defun *NO* (x y) (+ x y))") - - ("#+(and) (defun *NO* (x y) #-(and) (+ *YES* y))") - ("#| #+(or) |# *NO*") - ("#| #+(or) x |# *NO*") - ("*NO* \"#| *NO* #+(or) x |# *NO*\" *NO*") - ("#+#.foo (defun foo (bar)) -#-(and) *YES* *NO* bar -") - ("#+(foo) (defun foo (bar)) -#-(and) *YES* *NO* bar") - ("#| #+(or) |# *NO* foo -#-(and) *YES* *NO*") - ("#- (and) -\(*YES*) -\(*NO*) -#-(and) -\(*YES*) -\(*NO*)") - ("#+nil (foo) - -#-(and) -#+nil ( - asdf *YES* a - fsdfad) - -\( asdf *YES* - - ) -\(*NO*) - -") - ) - (slime-check-top-level) - (with-temp-buffer - (insert buffer-content) - (slime-initialize-lisp-buffer-for-test-suite - :autodoc t :font-lock-magic t) - ;; Can't use `font-lock-fontify-buffer' because for the case when - ;; `jit-lock-mode' is enabled. Jit-lock-mode fontifies only on - ;; actual display. - (font-lock-default-fontify-buffer) - (when (search-backward "*NO*" nil t) - (slime-test-expect "Not suppressed by reader conditional?" - 'slime-reader-conditional-face - (get-text-property (point) 'face) - #'(lambda (x y) (not (eq x y))))) - (goto-char (point-max)) - (when (search-backward "*YES*" nil t) - (slime-test-expect "Suppressed by reader conditional?" - 'slime-reader-conditional-face - (get-text-property (point) 'face))))) - (def-slime-test narrowing () "Check that narrowing is properly sustained." '() --- /project/slime/cvsroot/slime/ChangeLog 2009/06/05 19:58:53 1.1781 +++ /project/slime/cvsroot/slime/ChangeLog 2009/06/11 08:07:17 1.1782 @@ -1,3 +1,7 @@ +2009-06-1 Tobias C. Rittweiler + + * slime.el ([test] font-lock-magic): Moved to fontifying-fu contrib. + 2009-06-05 Helmut Eller Don't clutter compiler messages with source positions. Especially @@ -12,7 +16,7 @@ 2009-06-04 Helmut Eller - * slime.el (slime-dispatch-event [:emcas-rex]): Don't clutter + * slime.el (slime-dispatch-event [:emacs-rex]): Don't clutter the main code-path with confusing error handling. 2009-06-04 Helmut Eller @@ -49,7 +53,7 @@ (slime-skipped-tests): New var. (slime-execute-tests): Adapted accordingly. ([test] disconnect): Renamed to `disconnect-and-reconnect' - ([test] disconnect-one-conneciton): New. + ([test] disconnect-one-connection): New. Adapted from patch by Stas Boukarev. From trittweiler at common-lisp.net Thu Jun 11 08:14:58 2009 From: trittweiler at common-lisp.net (CVS User trittweiler) Date: Thu, 11 Jun 2009 04:14:58 -0400 Subject: [slime-cvs] CVS slime/contrib Message-ID: Update of /project/slime/cvsroot/slime/contrib In directory cl-net:/tmp/cvs-serv12669/contrib Modified Files: slime-fontifying-fu.el ChangeLog Log Message: * slime-fontifying-fu.el (slime-compute-region-for-font-lock): Fix for `#+foo (... #+bar (... |) ...)'. ([test] font-lock-magic): Moved here. --- /project/slime/cvsroot/slime/contrib/slime-fontifying-fu.el 2009/05/20 19:29:16 1.8 +++ /project/slime/cvsroot/slime/contrib/slime-fontifying-fu.el 2009/06/11 08:14:58 1.9 @@ -6,7 +6,7 @@ ;; -;;; Fontify WITH-FOO and DO-FOO like standard macros. +;;; Fontify WITH-FOO, DO-FOO, and DEFINE-FOO like standard macros. ;;; Fontify CHECK-FOO like CHECK-TYPE. (defvar slime-additional-font-lock-keywords '(("(\\(\\(\\s_\\|\\w\\)*:\\(define-\\|do-\\|with-\\)\\(\\s_\\|\\w\\)*\\)" 1 font-lock-keyword-face) @@ -77,7 +77,10 @@ (slime-search-suppressed-forms-internal limit)) (slime-unknown-feature-expression ; e.g. #+(foo) (slime-search-suppressed-forms-internal limit)) - (error + (error + ;; If this reports `(cl-assertion-failed (<= (point) limit))', + ;; the actual culprit is `slime-extend-region-for-font-lock' + ;; which did not extend the region enough in this case. (slime-bug (concat "Caught error during fontification while searching for forms\n" "that are suppressed by reader-conditionals. The error was: %S.") @@ -161,6 +164,7 @@ (or (slime-search-directly-preceding-reader-conditional) pt))) (goto-char end) + (inline (slime-beginning-of-tlf)) ; `#+foo (progn ..#+bar (.. _END_ ..)..)' (when (search-backward-regexp slime-reader-conditionals-regexp beg t) ;; Nested reader conditionals, yuck! (while (when-let (pt (slime-search-directly-preceding-reader-conditional)) @@ -202,6 +206,114 @@ ;;; extend-region hook. ) + +(def-slime-test font-lock-magic (buffer-content) + "Some testing for the font-lock-magic. *YES* should be + highlighted as a suppressed form, *NO* should not." + + '(("(defun *NO* (x y) (+ x y))") + ("(defun *NO*") + ("*NO*) #-(and) (*YES*) (*NO* *NO*") + ("\( +\(defun *NO*") + ("\) +\(defun *NO* + \( +\)") + ("#+#.foo +\(defun *NO* (x y) (+ x y))") + ("#+#.foo +\(defun *NO* (x ") + ("#+( +\(defun *NO* (x ") + ("#+(test) +\(defun *NO* (x ") + + ("(eval-when (...) +\(defun *NO* (x ") + + ("(eval-when (...) +#+(and) +\(defun *NO* (x ") + + ("#-(and) (defun *YES* (x y) (+ x y))") + (" +#-(and) (defun *YES* (x y) (+ x y)) +#+(and) (defun *NO* (x y) (+ x y))") + + ("#+(and) (defun *NO* (x y) #-(and) (+ *YES* y))") + ("#| #+(or) |# *NO*") + ("#| #+(or) x |# *NO*") + ("*NO* \"#| *NO* #+(or) x |# *NO*\" *NO*") + ("#+#.foo (defun foo (bar)) +#-(and) *YES* *NO* bar +") + ("#+(foo) (defun foo (bar)) +#-(and) *YES* *NO* bar") + ("#| #+(or) |# *NO* foo +#-(and) *YES* *NO*") + ("#- (and) +\(*YES*) +\(*NO*) +#-(and) +\(*YES*) +\(*NO*)") + ("#+nil (foo) + +#-(and) +#+nil ( + asdf *YES* a + fsdfad) + +\( asdf *YES* + + ) +\(*NO*) + +") + ("*NO* + +#-(and) \(progn + #-(and) + (defun *YES* ...) + + #+(and) + (defun *YES* ...) + + (defun *YES* ...) + + *YES* + + *YES* + + *YES* + + *YES* +\) + +*NO*")) + (slime-check-top-level) + (with-temp-buffer + (insert buffer-content) + (slime-initialize-lisp-buffer-for-test-suite + :autodoc t :font-lock-magic t) + ;; Can't use `font-lock-fontify-buffer' because for the case when + ;; `jit-lock-mode' is enabled. Jit-lock-mode fontifies only on + ;; actual display. + (font-lock-default-fontify-buffer) + (when (search-backward "*NO*" nil t) + (slime-test-expect "Not suppressed by reader conditional?" + 'slime-reader-conditional-face + (get-text-property (point) 'face) + #'(lambda (x y) (not (eq x y))))) + (goto-char (point-max)) + (when (search-backward "*YES*" nil t) + (slime-test-expect "Suppressed by reader conditional?" + 'slime-reader-conditional-face + (get-text-property (point) 'face))))) + + + (provide 'slime-fontifying-fu) (let ((byte-compile-warnings '())) @@ -211,3 +323,4 @@ slime-search-directly-preceding-reader-conditional slime-search-suppressed-forms slime-beginning-of-tlf))) + --- /project/slime/cvsroot/slime/contrib/ChangeLog 2009/05/28 15:40:10 1.215 +++ /project/slime/cvsroot/slime/contrib/ChangeLog 2009/06/11 08:14:58 1.216 @@ -1,5 +1,11 @@ 2009-05-28 Tobias C. Rittweiler + * slime-fontifying-fu.el (slime-compute-region-for-font-lock): Fix + for `#+foo (... #+bar (... |) ...)'. + ([test] font-lock-magic): Moved here. + +2009-05-28 Tobias C. Rittweiler + * slime-repl.el (slime-repl-disconnect): Disconnect current connection. (slime-repl-disconnect-all): New; disconnect all connections. From trittweiler at common-lisp.net Thu Jun 11 12:30:07 2009 From: trittweiler at common-lisp.net (CVS User trittweiler) Date: Thu, 11 Jun 2009 08:30:07 -0400 Subject: [slime-cvs] CVS slime/contrib Message-ID: Update of /project/slime/cvsroot/slime/contrib In directory cl-net:/tmp/cvs-serv19923 Modified Files: slime-fontifying-fu.el Log Message: really fix --- /project/slime/cvsroot/slime/contrib/slime-fontifying-fu.el 2009/06/11 08:14:58 1.9 +++ /project/slime/cvsroot/slime/contrib/slime-fontifying-fu.el 2009/06/11 12:30:07 1.10 @@ -165,12 +165,18 @@ pt))) (goto-char end) (inline (slime-beginning-of-tlf)) ; `#+foo (progn ..#+bar (.. _END_ ..)..)' - (when (search-backward-regexp slime-reader-conditionals-regexp beg t) - ;; Nested reader conditionals, yuck! - (while (when-let (pt (slime-search-directly-preceding-reader-conditional)) - (goto-char pt))) - (ignore-errors (slime-forward-reader-conditional)) - (setq end (max end (point)))) + (let ((found? (search-backward-regexp slime-reader-conditionals-regexp beg t))) + (unless found? + ;; the toplevel form isn't suppressed as a whole, so try and + ;; see at the tentative end position. + (goto-char end) + (setq found? (search-backward-regexp slime-reader-conditionals-regexp beg t))) + (when found? + ;; Nested reader conditionals, yuck! + (while (when-let (pt (slime-search-directly-preceding-reader-conditional)) + (goto-char pt))) + (ignore-errors (slime-forward-reader-conditional)) + (setq end (max end (point))))) (values (or (/= beg orig-beg) (/= end orig-end)) beg end))) From gcarncross at common-lisp.net Fri Jun 12 12:12:38 2009 From: gcarncross at common-lisp.net (CVS User gcarncross) Date: Fri, 12 Jun 2009 08:12:38 -0400 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory cl-net:/tmp/cvs-serv6332 Modified Files: swank-ecl.lisp Log Message: Support new environment changes in recent ECL/CVS patch largely from ECL maintainer. --- /project/slime/cvsroot/slime/swank-ecl.lisp 2009/01/30 06:07:31 1.39 +++ /project/slime/cvsroot/slime/swank-ecl.lisp 2009/06/12 12:12:37 1.40 @@ -10,6 +10,8 @@ (in-package :swank-backend) +(declaim (optimize (debug 3))) + (defvar *tmp*) (eval-when (:compile-toplevel :load-toplevel :execute) @@ -283,19 +285,25 @@ (declare (ignore position)) (if file (is-swank-source-p file))))) +(defmacro find-ihs-top (x) + (if (< ext:+ecl-version-number+ 90601) + `(si::ihs-top ,x) + '(si::ihs-top))) + (defimplementation call-with-debugging-environment (debugger-loop-fn) (declare (type function debugger-loop-fn)) (let* ((*tpl-commands* si::tpl-commands) - (*ihs-top* (ihs-top 'call-with-debugging-environment)) + (*ihs-top* (find-ihs-top 'call-with-debugging-environment)) (*ihs-current* *ihs-top*) (*frs-base* (or (sch-frs-base *frs-top* *ihs-base*) (1+ (frs-top)))) (*frs-top* (frs-top)) (*read-suppress* nil) (*tpl-level* (1+ *tpl-level*)) - (*backtrace* (loop for ihs from *ihs-base* below *ihs-top* + (*backtrace* (loop for ihs from 0 below *ihs-top* collect (list (si::ihs-fun ihs) (si::ihs-env ihs) nil)))) + (declare (special *ihs-current*)) (loop for f from *frs-base* until *frs-top* do (let ((i (- (si::frs-ihs f) *ihs-base* 1))) (when (plusp i) @@ -312,7 +320,7 @@ (defimplementation call-with-debugger-hook (hook fun) (let ((*debugger-hook* hook) - (*ihs-base*(si::ihs-top 'call-with-debugger-hook))) + (*ihs-base* (find-ihs-top 'call-with-debugger-hook))) (funcall fun))) (defimplementation compute-backtrace (start end) @@ -346,10 +354,13 @@ (let ((functions '()) (blocks '()) (variables '())) - (dolist (record (second frame)) + #.(if (< ext:+ecl-version-number+ 90601) + '(setf frame (second frame)) + '(setf frame (si::decode-ihs-env (second frame)))) + (dolist (record frame) (let* ((record0 (car record)) (record1 (cdr record))) - (cond ((symbolp record0) + (cond ((or (symbolp record0) (stringp record0)) (setq variables (acons record0 record1 variables))) ((not (si::fixnump record0)) (push record1 functions)) @@ -453,7 +464,9 @@ `(:position ,pos) `(:snippet ,(with-open-file (s file) - (skip-toplevel-forms pos s) + (if (< ext:+ecl-version-number+ 90601) + (skip-toplevel-forms pos s) + (file-position s pos)) (skip-comments-and-whitespace s) (read-snippet s)))))))) `(:error (format nil "Source definition of ~S not found" obj)))) From gcarncross at common-lisp.net Fri Jun 12 12:13:36 2009 From: gcarncross at common-lisp.net (CVS User gcarncross) Date: Fri, 12 Jun 2009 08:13:36 -0400 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory cl-net:/tmp/cvs-serv6939 Modified Files: ChangeLog Log Message: *** empty log message *** --- /project/slime/cvsroot/slime/ChangeLog 2009/06/11 08:07:17 1.1782 +++ /project/slime/cvsroot/slime/ChangeLog 2009/06/12 12:13:36 1.1783 @@ -1,3 +1,8 @@ +2009-06-12 Geo Carncross + + * swank-ecl.lisp: Support new environment changes in recent ECL/CVS + patch largely from ECL maintainer. + 2009-06-1 Tobias C. Rittweiler * slime.el ([test] font-lock-magic): Moved to fontifying-fu contrib. From trittweiler at common-lisp.net Sun Jun 14 16:47:34 2009 From: trittweiler at common-lisp.net (CVS User trittweiler) Date: Sun, 14 Jun 2009 12:47:34 -0400 Subject: [slime-cvs] CVS slime/contrib Message-ID: Update of /project/slime/cvsroot/slime/contrib In directory cl-net:/tmp/cvs-serv13791/contrib Modified Files: slime-fontifying-fu.el ChangeLog Log Message: * slime-fontifying-fu.el (slime-search-suppressed-form): Retry the search differently; handlers are not active anymore inside a handler in `condition-case'. --- /project/slime/cvsroot/slime/contrib/slime-fontifying-fu.el 2009/06/11 12:30:07 1.10 +++ /project/slime/cvsroot/slime/contrib/slime-fontifying-fu.el 2009/06/14 16:47:34 1.11 @@ -64,27 +64,31 @@ "Find reader conditionalized forms where the test is false." (when (and slime-highlight-suppressed-forms (slime-connected-p)) - (condition-case condition - (slime-search-suppressed-forms-internal limit) - (end-of-file ; e.g. #+( - nil) - ;; We found a reader conditional we couldn't process for some - ;; reason; however, there may still be other reader conditionals - ;; before `limit'. - (invalid-read-syntax ; e.g. #+#.foo - (slime-search-suppressed-forms-internal limit)) - (scan-error ; e.g. #| #+(or) #| - (slime-search-suppressed-forms-internal limit)) - (slime-unknown-feature-expression ; e.g. #+(foo) - (slime-search-suppressed-forms-internal limit)) - (error - ;; If this reports `(cl-assertion-failed (<= (point) limit))', - ;; the actual culprit is `slime-extend-region-for-font-lock' - ;; which did not extend the region enough in this case. - (slime-bug - (concat "Caught error during fontification while searching for forms\n" - "that are suppressed by reader-conditionals. The error was: %S.") - condition))))) + (let ((result 'retry)) + (while (eq result 'retry) + (condition-case condition + (setq result (slime-search-suppressed-forms-internal limit)) + (end-of-file ; e.g. #+( + (setq result nil)) + ;; We found a reader conditional we couldn't process for + ;; some reason; however, there may still be other reader + ;; conditionals before `limit'. + (invalid-read-syntax ; e.g. #+#.foo + (setq result 'retry)) + (scan-error ; e.g. #| #+(or) #| + (setq result 'retry)) + (slime-unknown-feature-expression ; e.g. #+(foo) + (setq result 'retry)) + (error + (setq result nil) + ;; If this reports `(cl-assertion-failed (<= (point) limit))', + ;; the actual culprit is `slime-extend-region-for-font-lock' + ;; which did not extend the region enough in this case. + (slime-bug + (concat "Caught error during fontification while searching for forms\n" + "that are suppressed by reader-conditionals. The error was: %S.") + condition)))) + result))) (defun slime-search-directly-preceding-reader-conditional () --- /project/slime/cvsroot/slime/contrib/ChangeLog 2009/06/11 08:14:58 1.216 +++ /project/slime/cvsroot/slime/contrib/ChangeLog 2009/06/14 16:47:34 1.217 @@ -1,4 +1,10 @@ -2009-05-28 Tobias C. Rittweiler +2009-06-14 Tobias C. Rittweiler + + * slime-fontifying-fu.el (slime-search-suppressed-form): Retry the + search differently; handlers are not active anymore inside a + handler in `condition-case'. + +2009-06-12 Tobias C. Rittweiler * slime-fontifying-fu.el (slime-compute-region-for-font-lock): Fix for `#+foo (... #+bar (... |) ...)'. From heller at common-lisp.net Sun Jun 14 17:07:03 2009 From: heller at common-lisp.net (CVS User heller) Date: Sun, 14 Jun 2009 13:07:03 -0400 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory cl-net:/tmp/cvs-serv17820 Modified Files: ChangeLog swank-sbcl.lisp Log Message: Some workarounds for SBCL on Windows. * swank-sbcl.lisp (input-available-p): New function. (wait-for-input): Use it. ([win32] handle-listen, has-buffered-input-p): New. (temp-file-name, tempnam): Plain tmpnam(3) is next to useless on Windows use tempnam(3) instead. --- /project/slime/cvsroot/slime/ChangeLog 2009/06/12 12:13:36 1.1783 +++ /project/slime/cvsroot/slime/ChangeLog 2009/06/14 17:07:03 1.1784 @@ -1,3 +1,13 @@ +2009-06-14 Helmut Eller + + Some workarounds for SBCL on Windows. + + * swank-sbcl.lisp (input-available-p): New function. + (wait-for-input): Use it. + ([win32] handle-listen, has-buffered-input-p): New. + (temp-file-name, tempnam): Plain tmpnam(3) is next to useless on + Windows use tempnam(3) instead. + 2009-06-12 Geo Carncross * swank-ecl.lisp: Support new environment changes in recent ECL/CVS --- /project/slime/cvsroot/slime/swank-sbcl.lisp 2009/05/09 19:26:00 1.241 +++ /project/slime/cvsroot/slime/swank-sbcl.lisp 2009/06/14 17:07:03 1.242 @@ -163,35 +163,84 @@ (setq *wait-for-input-called* t)) (let ((*wait-for-input-called* nil)) (loop - (let ((ready (remove-if (lambda (s) - (let ((c (read-char-no-hang s nil :eof))) - (case c - ((nil) t) - ((:eof) nil) - (t - (unread-char c s) - nil)))) - streams))) + (let ((ready (remove-if-not #'input-ready-p streams))) (when ready (return ready))) (when timeout (return nil)) (when (check-slime-interrupts) (return :interrupt)) - (when *wait-for-input-called* (return :interrupt)) - (let* ((f (constantly t)) - (handlers (loop for s in streams - do (assert (open-stream-p s)) - collect (add-one-shot-handler s f)))) - (unwind-protect - (sb-sys:serve-event 0.2) - (mapc #'sb-sys:remove-fd-handler handlers)))))) - -(defun add-one-shot-handler (stream function) - (let (handler) - (setq handler - (sb-sys:add-fd-handler (sb-sys:fd-stream-fd stream) :input - (lambda (fd) - (declare (ignore fd)) - (sb-sys:remove-fd-handler handler) - (funcall function stream)))))) + (when *wait-for-input-called* (return :interrupt)) + (sleep 0.2)))) + +#-win32 +(defun input-ready-p (stream) + (let ((c (read-char-no-hang stream nil :eof))) + (etypecase c + (character (unread-char c stream) t) + (null nil) + ((member :eof) t)))) + +#+win32 +(progn + (defun input-ready-p (stream) + (or (has-buffered-input-p stream) + (handle-listen (sockint::fd->handle + (sb-impl::fd-stream-fd stream))))) + + (defun has-buffered-input-p (stream) + (let ((ibuf (sb-impl::fd-stream-ibuf stream))) + (/= (sb-impl::buffer-head ibuf) + (sb-impl::buffer-tail ibuf)))) + + (sb-alien:define-alien-routine ("WSACreateEvent" wsa-create-event) + sb-win32:handle) + + (sb-alien:define-alien-routine ("WSACloseEvent" wsa-close-event) + sb-alien:int + (event sb-win32:handle)) + + (defconstant +fd-read+ #.(ash 1 0)) + (defconstant +fd-close+ #.(ash 1 5)) + + (sb-alien:define-alien-routine ("WSAEventSelect" wsa-event-select) + sb-alien:int + (fd sb-alien:int) + (handle sb-win32:handle) + (mask sb-alien:long)) + + (sb-alien:load-shared-object "kernel32.dll") + (sb-alien:define-alien-routine ("WaitForSingleObjectEx" + wait-for-single-object-ex) + sb-alien:int + (event sb-win32:handle) + (milliseconds sb-alien:long) + (alertable sb-alien:int)) + + ;; see SB-WIN32:HANDLE-LISTEN + (defun handle-listen (handle) + (sb-alien:with-alien ((avail sb-win32:dword) + (buf (array char #.sb-win32::input-record-size))) + (unless (zerop (sb-win32:peek-named-pipe handle nil 0 nil + (sb-alien:alien-sap + (sb-alien:addr avail)) + nil)) + (return-from handle-listen (plusp avail))) + + (unless (zerop (sb-win32:peek-console-input handle + (sb-alien:alien-sap buf) + sb-win32::input-record-size + (sb-alien:alien-sap + (sb-alien:addr avail)))) + (return-from handle-listen (plusp avail)))) + + (let ((event (wsa-create-event))) + (wsa-event-select handle event (logior +fd-read+ +fd-close+)) + (let ((val (wait-for-single-object-ex event 0 0))) + (wsa-close-event event) + (unless (= val -1) + (return-from handle-listen (zerop val))))) + + nil) + + ) (defvar *external-format-to-coding-system* '((:iso-8859-1 @@ -527,12 +576,14 @@ ;;; (compile nil `(lambda () ,(read-from-string string))) ;;; did not provide. -(sb-alien:define-alien-routine "tmpnam" sb-alien:c-string - (dest (* sb-alien:c-string))) +(sb-alien:define-alien-routine (#-win32 "tempnam" #+win32 "_tempnam" tempnam) + sb-alien:c-string + (dir sb-alien:c-string) + (prefix sb-alien:c-string)) (defun temp-file-name () "Return a temporary file name to compile strings into." - (concatenate 'string (tmpnam nil) ".lisp")) + (tempnam nil nil)) (defun get-compiler-policy (default-policy) (declare (ignorable default-policy)) From heller at common-lisp.net Mon Jun 15 18:17:32 2009 From: heller at common-lisp.net (CVS User heller) Date: Mon, 15 Jun 2009 14:17:32 -0400 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory cl-net:/tmp/cvs-serv7432 Modified Files: ChangeLog swank-openmcl.lisp Log Message: * swank-openmcl.lisp (emacs-inspect [t]): Honor the type returned by inspector::line-n. (emacs-inspect [compiled-lexical-closure]): Deleted. Let CCL's inpector handle this case. Which does it better and it's less work for us. --- /project/slime/cvsroot/slime/ChangeLog 2009/06/14 17:07:03 1.1784 +++ /project/slime/cvsroot/slime/ChangeLog 2009/06/15 18:17:32 1.1785 @@ -1,3 +1,11 @@ +2009-06-15 Helmut Eller + + * swank-openmcl.lisp (emacs-inspect [t]): Honor the type returned + by inspector::line-n. + (emacs-inspect [compiled-lexical-closure]): Deleted. Let CCL's + inpector handle this case. Which does it better and it's less work + for us. + 2009-06-14 Helmut Eller Some workarounds for SBCL on Windows. --- /project/slime/cvsroot/slime/swank-openmcl.lisp 2009/06/05 19:58:54 1.175 +++ /project/slime/cvsroot/slime/swank-openmcl.lisp 2009/06/15 18:17:32 1.176 @@ -761,19 +761,25 @@ (string (gethash typecode *value2tag*)) (string (nth typecode '(tag-fixnum tag-list tag-misc tag-imm)))))) +(defun comment-type-p (type) + (or (eq type :comment) + (and (consp type) (eq (car type) :comment)))) + (defmethod emacs-inspect ((o t)) - (let* ((i (inspector::make-inspector o)) - (count (inspector::compute-line-count i)) - (lines - (loop - for l below count - for (value label) = (multiple-value-list - (inspector::line-n i l)) - collect (format nil "~(~a~)" (or label l)) - collect " = " - collect `(:value ,value) - collect '(:newline)))) - lines)) + (let* ((inspector::*inspector-disassembly* t) + (i (inspector::make-inspector o)) + (count (inspector::compute-line-count i))) + (loop for l from 0 below count append + (multiple-value-bind (value label type) (inspector::line-n i l) + (etypecase type + ((member nil :normal) + `(,(or label "") (:value ,value) (:newline))) + ((member :colon) + (label-value-line label value)) + ((member :static) + (list (princ-to-string label) " " `(:value ,value) '(:newline))) + ((satisfies comment-type-p) + (list (princ-to-string label) '(:newline)))))))) (defmethod emacs-inspect :around ((o t)) (if (or (uvector-inspector-p o) @@ -796,41 +802,8 @@ (defmethod emacs-inspect ((uv uvector-inspector)) (with-slots (object) uv - (loop for index below (ccl::uvsize object) - collect (format nil "~D: " index) - collect `(:value ,(ccl::uvref object index)) - collect `(:newline)))) - -(defun closure-closed-over-values (closure) - (let ((howmany (nth-value 8 (ccl::function-args (ccl::closure-function closure))))) - (loop for n below howmany - collect - (let* ((value (ccl::nth-immediate closure (+ 1 (- howmany n)))) - (map (car (ccl::function-symbol-map (ccl::closure-function closure)))) - (label (or (and map (svref map n)) n)) - (cellp (ccl::closed-over-value-p value))) - (list label (if cellp (ccl::closed-over-value value) value)))))) - -(defmethod emacs-inspect ((c ccl::compiled-lexical-closure)) - (list* - (format nil "A closure: ~a~%" c) - `(,@(if (arglist c) - (list "Its argument list is: " - (funcall (intern "INSPECTOR-PRINC" 'swank) (arglist c))) - ;; FIXME inspector-princ should load earlier - (list "A function of no arguments")) - (:newline) - ,@(when (documentation c t) - `("Documentation:" (:newline) ,(documentation c t) (:newline))) - ,(format nil "Closed over ~a values" (length (closure-closed-over-values c))) - (:newline) - ,@(loop for (name value) in (closure-closed-over-values c) - for count from 1 - append - (label-value-line* ((format nil "~2,' d) ~a" count (string name)) value)))))) - - - + (loop for i below (ccl::uvsize object) append + (label-value-line (princ-to-string i) (ccl::uvref object i))))) ;;; Multiprocessing From heller at common-lisp.net Mon Jun 15 18:17:49 2009 From: heller at common-lisp.net (CVS User heller) Date: Mon, 15 Jun 2009 14:17:49 -0400 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory cl-net:/tmp/cvs-serv7471 Modified Files: ChangeLog swank-openmcl.lisp Log Message: * swank-openmcl.lisp: Explicitly require CCL version 1.3. --- /project/slime/cvsroot/slime/ChangeLog 2009/06/15 18:17:32 1.1785 +++ /project/slime/cvsroot/slime/ChangeLog 2009/06/15 18:17:47 1.1786 @@ -1,5 +1,9 @@ 2009-06-15 Helmut Eller + * swank-openmcl.lisp: Explicitly require CCL version 1.3. + +2009-06-15 Helmut Eller + * swank-openmcl.lisp (emacs-inspect [t]): Honor the type returned by inspector::line-n. (emacs-inspect [compiled-lexical-closure]): Deleted. Let CCL's --- /project/slime/cvsroot/slime/swank-openmcl.lisp 2009/06/15 18:17:32 1.176 +++ /project/slime/cvsroot/slime/swank-openmcl.lisp 2009/06/15 18:17:48 1.177 @@ -52,6 +52,11 @@ (in-package :swank-backend) +(eval-when (:compile-toplevel :execute :load-toplevel) + (assert (and (= ccl::*openmcl-major-version* 1) + (>= ccl::*openmcl-minor-version* 3)) + () "This file needs CCL version 1.3 or newer")) + (import-from :ccl *gray-stream-symbols* :swank-backend) (eval-when (:compile-toplevel :load-toplevel :execute) From trittweiler at common-lisp.net Tue Jun 16 06:36:41 2009 From: trittweiler at common-lisp.net (CVS User trittweiler) Date: Tue, 16 Jun 2009 02:36:41 -0400 Subject: [slime-cvs] CVS slime/contrib Message-ID: Update of /project/slime/cvsroot/slime/contrib In directory cl-net:/tmp/cvs-serv25404 Modified Files: slime-fontifying-fu.el ChangeLog Log Message: * slime-fontifying-fu.el (slime-search-suppressed-form): Additional exit constraint for the loop; make sure we'r still in the limit. (slime-compute-region-for-font-lock): Simplify. --- /project/slime/cvsroot/slime/contrib/slime-fontifying-fu.el 2009/06/14 16:47:34 1.11 +++ /project/slime/cvsroot/slime/contrib/slime-fontifying-fu.el 2009/06/16 06:36:40 1.12 @@ -45,7 +45,8 @@ (and (eq char ?-) val)) (progn (forward-sexp) (backward-sexp) - (slime-forward-sexp) + ;; Try to suppress as far as possible. + (ignore-errors (slime-forward-sexp)) ;; There was an `ignore-errors' form around all this ;; because the following assertion was triggered ;; regularly (resulting in the "non-deterministic" @@ -65,7 +66,7 @@ (when (and slime-highlight-suppressed-forms (slime-connected-p)) (let ((result 'retry)) - (while (eq result 'retry) + (while (and (eq result 'retry) (<= (point) limit)) (condition-case condition (setq result (slime-search-suppressed-forms-internal limit)) (end-of-file ; e.g. #+( @@ -75,7 +76,7 @@ ;; conditionals before `limit'. (invalid-read-syntax ; e.g. #+#.foo (setq result 'retry)) - (scan-error ; e.g. #| #+(or) #| + (scan-error ; e.g. #+nil (foo ... (setq result 'retry)) (slime-unknown-feature-expression ; e.g. #+(foo) (setq result 'retry)) @@ -168,20 +169,14 @@ (or (slime-search-directly-preceding-reader-conditional) pt))) (goto-char end) - (inline (slime-beginning-of-tlf)) ; `#+foo (progn ..#+bar (.. _END_ ..)..)' - (let ((found? (search-backward-regexp slime-reader-conditionals-regexp beg t))) - (unless found? - ;; the toplevel form isn't suppressed as a whole, so try and - ;; see at the tentative end position. - (goto-char end) - (setq found? (search-backward-regexp slime-reader-conditionals-regexp beg t))) - (when found? - ;; Nested reader conditionals, yuck! - (while (when-let (pt (slime-search-directly-preceding-reader-conditional)) - (goto-char pt))) - (ignore-errors (slime-forward-reader-conditional)) - (setq end (max end (point))))) + (while (search-backward-regexp slime-reader-conditionals-regexp beg t) + (setq end (max end (save-excursion + (ignore-errors (slime-forward-reader-conditional)) + (point))))) (values (or (/= beg orig-beg) (/= end orig-end)) beg end))) + + + (defun slime-activate-font-lock-magic () --- /project/slime/cvsroot/slime/contrib/ChangeLog 2009/06/14 16:47:34 1.217 +++ /project/slime/cvsroot/slime/contrib/ChangeLog 2009/06/16 06:36:40 1.218 @@ -1,3 +1,10 @@ +2009-06-16 Tobias C. Rittweiler + + * slime-fontifying-fu.el (slime-search-suppressed-form): + Additional exit constraint for the loop; make sure we'r still in + the limit. + (slime-compute-region-for-font-lock): Simplify. + 2009-06-14 Tobias C. Rittweiler * slime-fontifying-fu.el (slime-search-suppressed-form): Retry the From heller at common-lisp.net Sat Jun 20 10:02:34 2009 From: heller at common-lisp.net (CVS User heller) Date: Sat, 20 Jun 2009 06:02:34 -0400 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory cl-net:/tmp/cvs-serv5519 Modified Files: ChangeLog swank-openmcl.lisp Log Message: * swank-openmcl.lisp (emacs-connected): Deleted. Setting ccl::*interactive-abort-process* doesn't seem right. --- /project/slime/cvsroot/slime/ChangeLog 2009/06/15 18:17:47 1.1786 +++ /project/slime/cvsroot/slime/ChangeLog 2009/06/20 10:02:34 1.1787 @@ -1,3 +1,8 @@ +2009-06-20 Helmut Eller + + * swank-openmcl.lisp (emacs-connected): Deleted. Setting + ccl::*interactive-abort-process* doesn't seem right. + 2009-06-15 Helmut Eller * swank-openmcl.lisp: Explicitly require CCL version 1.3. --- /project/slime/cvsroot/slime/swank-openmcl.lisp 2009/06/15 18:17:48 1.177 +++ /project/slime/cvsroot/slime/swank-openmcl.lisp 2009/06/20 10:02:34 1.178 @@ -192,9 +192,6 @@ (car (rassoc-if (lambda (x) (member coding-system x :test #'equal)) *external-format-to-coding-system*))) -(defimplementation emacs-connected () - (setq ccl::*interactive-abort-process* ccl::*current-process*)) - ;;; Unix signals (defimplementation call-without-interrupts (fn) @@ -413,7 +410,9 @@ (defimplementation install-debugger-globally (function) (setq *debugger-hook* function) - (setq *break-in-sldb* t)) + (setq *break-in-sldb* t) + ;;(setq ccl::*interactive-abort-process* ccl::*current-process*) + ) (defun backtrace-context () nil) @@ -623,7 +622,7 @@ (or (ccl:find-source-note-at-pc function pc) (ccl:function-source-note function)) (lambda () - (format nil "No source note at PC: ~A:#x~x" function pc)))) + (format nil "No source note at PC: ~a[~d]" function pc)))) (defun source-note-to-source-location (note if-nil-thunk) (labels ((filename-to-buffer (filename) From heller at common-lisp.net Sat Jun 20 10:02:46 2009 From: heller at common-lisp.net (CVS User heller) Date: Sat, 20 Jun 2009 06:02:46 -0400 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory cl-net:/tmp/cvs-serv5663 Modified Files: ChangeLog slime.el Log Message: * slime.el (slime-check-fancy-symbol-name): Don't update the loop index inside the loop body. --- /project/slime/cvsroot/slime/ChangeLog 2009/06/20 10:02:34 1.1787 +++ /project/slime/cvsroot/slime/ChangeLog 2009/06/20 10:02:46 1.1788 @@ -1,5 +1,10 @@ 2009-06-20 Helmut Eller + * slime.el (slime-check-fancy-symbol-name): Don't update the loop + index inside the loop body. + +2009-06-20 Helmut Eller + * swank-openmcl.lisp (emacs-connected): Deleted. Setting ccl::*interactive-abort-process* doesn't seem right. --- /project/slime/cvsroot/slime/slime.el 2009/06/11 08:07:17 1.1185 +++ /project/slime/cvsroot/slime/slime.el 2009/06/20 10:02:46 1.1186 @@ -7330,10 +7330,9 @@ (defun slime-check-fancy-symbol-name (buffer-offset symbol-name) ;; We test that `slime-symbol-at-point' works at every ;; character of the symbol name. - (dotimes (pt (length symbol-name)) - (setq pt (+ buffer-offset pt)) - (goto-char pt) - (slime-test-expect (format "Check `%s' (at %d)..." (buffer-string) pt) + (dotimes (i (length symbol-name)) + (goto-char (+ buffer-offset i)) + (slime-test-expect (format "Check `%s' (at %d)..." (buffer-string) (point)) symbol-name (slime-symbol-at-point) #'equal))) From heller at common-lisp.net Sun Jun 21 07:22:56 2009 From: heller at common-lisp.net (CVS User heller) Date: Sun, 21 Jun 2009 03:22:56 -0400 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory cl-net:/tmp/cvs-serv843 Modified Files: ChangeLog slime.el swank-abcl.lisp swank-allegro.lisp swank-backend.lisp swank-clisp.lisp swank-cmucl.lisp swank-corman.lisp swank-ecl.lisp swank-lispworks.lisp swank-openmcl.lisp swank-sbcl.lisp swank-scl.lisp swank.lisp Log Message: * swank-backend.lisp (frame-source-location): Renamed from frame-source-location-for-emacs. Update callers accordingly. --- /project/slime/cvsroot/slime/ChangeLog 2009/06/20 10:02:46 1.1788 +++ /project/slime/cvsroot/slime/ChangeLog 2009/06/21 07:22:56 1.1789 @@ -1,3 +1,8 @@ +2009-06-21 Helmut Eller + + * swank-backend.lisp (frame-source-location): Renamed from + frame-source-location-for-emacs. + 2009-06-20 Helmut Eller * slime.el (slime-check-fancy-symbol-name): Don't update the loop --- /project/slime/cvsroot/slime/slime.el 2009/06/20 10:02:46 1.1186 +++ /project/slime/cvsroot/slime/slime.el 2009/06/21 07:22:56 1.1187 @@ -5772,7 +5772,7 @@ (defun sldb-show-frame-source (frame-number) (slime-eval-async - `(swank:frame-source-location-for-emacs ,frame-number) + `(swank:frame-source-location ,frame-number) (lambda (source-location) (destructure-case source-location ((:error message) @@ -6074,7 +6074,7 @@ (defun sldb-recompile-frame-source (&optional raw-prefix-arg) (interactive "P") (slime-eval-async - `(swank:frame-source-location-for-emacs ,(sldb-frame-number-at-point)) + `(swank:frame-source-location ,(sldb-frame-number-at-point)) (lexical-let ((policy (slime-compute-policy raw-prefix-arg))) (lambda (source-location) (destructure-case source-location --- /project/slime/cvsroot/slime/swank-abcl.lisp 2009/04/30 12:50:25 1.64 +++ /project/slime/cvsroot/slime/swank-abcl.lisp 2009/06/21 07:22:56 1.65 @@ -284,7 +284,7 @@ (defimplementation disassemble-frame (index) (disassemble (debugger:frame-function (nth-frame index)))) -(defimplementation frame-source-location-for-emacs (index) +(defimplementation frame-source-location (index) (list :error (format nil "Cannot find source for frame: ~A" (nth-frame index)))) --- /project/slime/cvsroot/slime/swank-allegro.lisp 2009/05/15 18:47:38 1.127 +++ /project/slime/cvsroot/slime/swank-allegro.lisp 2009/06/21 07:22:56 1.128 @@ -187,7 +187,7 @@ (defimplementation disassemble-frame (index) (disassemble (debugger:frame-function (nth-frame index)))) -(defimplementation frame-source-location-for-emacs (index) +(defimplementation frame-source-location (index) (let* ((frame (nth-frame index)) (expr (debugger:frame-expression frame)) (fspec (first expr))) --- /project/slime/cvsroot/slime/swank-backend.lisp 2009/04/29 22:20:25 1.175 +++ /project/slime/cvsroot/slime/swank-backend.lisp 2009/06/21 07:22:56 1.176 @@ -681,7 +681,7 @@ (declare (ignore frame)) nil) -(definterface frame-source-location-for-emacs (frame-number) +(definterface frame-source-location (frame-number) "Return the source location for the frame associated to FRAME-NUMBER.") (definterface frame-catch-tags (frame-number) --- /project/slime/cvsroot/slime/swank-clisp.lisp 2009/01/30 09:58:48 1.89 +++ /project/slime/cvsroot/slime/swank-clisp.lisp 2009/06/21 07:22:56 1.90 @@ -521,7 +521,7 @@ (defimplementation restart-frame (index) (sys::redo-eval-frame (nth-frame index))) -(defimplementation frame-source-location-for-emacs (index) +(defimplementation frame-source-location (index) `(:error ,(format nil "frame-source-location not implemented. (frame: ~A)" (nth-frame index)))) --- /project/slime/cvsroot/slime/swank-cmucl.lisp 2009/02/14 12:33:28 1.211 +++ /project/slime/cvsroot/slime/swank-cmucl.lisp 2009/06/21 07:22:56 1.212 @@ -1535,7 +1535,7 @@ (error (e) (ignore-errors (princ e stream)))))) -(defimplementation frame-source-location-for-emacs (index) +(defimplementation frame-source-location (index) (code-location-source-location (di:frame-code-location (nth-frame index)))) (defimplementation eval-in-frame (form index) --- /project/slime/cvsroot/slime/swank-corman.lisp 2009/01/10 12:25:16 1.23 +++ /project/slime/cvsroot/slime/swank-corman.lisp 2009/06/21 07:22:56 1.24 @@ -208,7 +208,7 @@ (when vars (second (elt vars var))))) -(defimplementation frame-source-location-for-emacs (frame-number) +(defimplementation frame-source-location (frame-number) (fspec-location (frame-function (elt *frame-trace* frame-number)))) (defun break (&optional (format-control "Break") &rest format-arguments) --- /project/slime/cvsroot/slime/swank-ecl.lisp 2009/06/12 12:12:37 1.40 +++ /project/slime/cvsroot/slime/swank-ecl.lisp 2009/06/21 07:22:56 1.41 @@ -373,7 +373,7 @@ (defimplementation print-frame (frame stream) (format stream "~A" (first frame))) -(defimplementation frame-source-location-for-emacs (frame-number) +(defimplementation frame-source-location (frame-number) (nth-value 1 (frame-function (elt *backtrace* frame-number)))) (defimplementation frame-catch-tags (frame-number) --- /project/slime/cvsroot/slime/swank-lispworks.lisp 2009/01/15 17:07:21 1.129 +++ /project/slime/cvsroot/slime/swank-lispworks.lisp 2009/06/21 07:22:56 1.130 @@ -383,7 +383,7 @@ (declare (ignore _n _s _l)) value))) -(defimplementation frame-source-location-for-emacs (frame) +(defimplementation frame-source-location (frame) (let ((frame (nth-frame frame)) (callee (if (plusp frame) (nth-frame (1- frame))))) (if (dbg::call-frame-p frame) --- /project/slime/cvsroot/slime/swank-openmcl.lisp 2009/06/20 10:02:34 1.178 +++ /project/slime/cvsroot/slime/swank-openmcl.lisp 2009/06/21 07:22:56 1.179 @@ -515,7 +515,7 @@ (push (list name value) result))))) (reverse result)))) -(defimplementation frame-source-location-for-emacs (index) +(defimplementation frame-source-location (index) (with-frame (p context lfun pc) index (declare (ignore p context)) (if pc --- /project/slime/cvsroot/slime/swank-sbcl.lisp 2009/06/14 17:07:03 1.242 +++ /project/slime/cvsroot/slime/swank-sbcl.lisp 2009/06/21 07:22:56 1.243 @@ -1118,7 +1118,7 @@ (handler-case (code-location-source-location code-location) (error (c) (list :error (format nil "~A" c)))))) -(defimplementation frame-source-location-for-emacs (index) +(defimplementation frame-source-location (index) (safe-source-location-for-emacs (sb-di:frame-code-location (nth-frame index)))) --- /project/slime/cvsroot/slime/swank-scl.lisp 2009/01/10 12:25:16 1.32 +++ /project/slime/cvsroot/slime/swank-scl.lisp 2009/06/21 07:22:56 1.33 @@ -1367,7 +1367,7 @@ (error (e) (ignore-errors (princ e stream)))))) -(defimplementation frame-source-location-for-emacs (index) +(defimplementation frame-source-location (index) (code-location-source-location (di:frame-code-location (nth-frame index)))) (defimplementation eval-in-frame (form index) --- /project/slime/cvsroot/slime/swank.lisp 2009/05/28 15:42:47 1.648 +++ /project/slime/cvsroot/slime/swank.lisp 2009/06/21 07:22:56 1.649 @@ -48,7 +48,7 @@ #:*inspector-verbose* ;; These are re-exported directly from the backend: #:buffer-first-change - #:frame-source-location-for-emacs + #:frame-source-location #:restart-frame #:sldb-step #:sldb-break From heller at common-lisp.net Sun Jun 21 12:18:11 2009 From: heller at common-lisp.net (CVS User heller) Date: Sun, 21 Jun 2009 08:18:11 -0400 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory cl-net:/tmp/cvs-serv15605 Modified Files: ChangeLog slime.el Log Message: Don't try so hard to get symbol-at-point right. The old implementation was complicated and didn't even pass it's own test suite. The new version is less ambitious but simpler. * slime.el (slime-symbol-at-point, slime-beginning-of-symbol) (slime-end-of-symbol): Simplify. (slime-exit-vertical-bars, slime-symbol-constituent-at): Deleted. ([test] symbol-at-point.1 .. symbol-at-point.14): Renamed form fancy-symbol-names and split up into smaller peices. (slime-test-symbols): New. (slime-check-symbol-at-point): Renamed from slime-check-fancy-symbol-name. --- /project/slime/cvsroot/slime/ChangeLog 2009/06/21 07:22:56 1.1789 +++ /project/slime/cvsroot/slime/ChangeLog 2009/06/21 12:18:10 1.1790 @@ -1,5 +1,20 @@ 2009-06-21 Helmut Eller + Don't try so hard to get symbol-at-point right. + The old implementation was complicated and didn't even pass it's + own test suite. The new version is less ambitious but simpler. + + * slime.el (slime-symbol-at-point, slime-beginning-of-symbol) + (slime-end-of-symbol): Simplify. + (slime-exit-vertical-bars, slime-symbol-constituent-at): Deleted. + ([test] symbol-at-point.1 .. symbol-at-point.14): Renamed form + fancy-symbol-names and split up into smaller peices. + (slime-test-symbols): New. + (slime-check-symbol-at-point): Renamed from + slime-check-fancy-symbol-name. + +2009-06-21 Helmut Eller + * swank-backend.lisp (frame-source-location): Renamed from frame-source-location-for-emacs. --- /project/slime/cvsroot/slime/slime.el 2009/06/21 07:22:56 1.1187 +++ /project/slime/cvsroot/slime/slime.el 2009/06/21 12:18:10 1.1188 @@ -7327,110 +7327,97 @@ (defun slime-sldb-level= (level) (equal level (sldb-level))) -(defun slime-check-fancy-symbol-name (buffer-offset symbol-name) +(defvar slime-test-symbols + '(("foobar") ("foo at bar") ("@foobar") ("foobar@") ("\\@foobar") + ("|asdf||foo||bar|") + ("\\#") + ("\\(setf\\ car\\)"))) + +(defun slime-check-symbol-at-point (prefix symbol suffix) ;; We test that `slime-symbol-at-point' works at every ;; character of the symbol name. - (dotimes (i (length symbol-name)) - (goto-char (+ buffer-offset i)) - (slime-test-expect (format "Check `%s' (at %d)..." (buffer-string) (point)) - symbol-name - (slime-symbol-at-point) - #'equal))) - -(def-slime-test fancy-symbol-names (symbol-name) - "Check that we can cope with idiosyncratic symbol names." - '(("foobar") ("foo at bar") ("@foobar") ("foobar@") ("\\@foobar") - ("|asdf,@@@(foo[adsf])asdf!!!|::|fo||bar|asdf") - ("|asdf||foo||bar|") - ("\\|foo|bar|@asdf:foo|\\||") - ("\\\\\\\\foo|barfo\\\\|asdf") - ("\\#") ("|#<|Foo at Bar|>|") ("|#|")) - (slime-check-top-level) (with-temp-buffer (lisp-mode) - (slime-test-message "*** fancy symbol-name at BOB and EOB:") - (insert symbol-name) - (slime-check-fancy-symbol-name (point-min) symbol-name) - (erase-buffer) - - (slime-test-message "*** fancy symbol-name _not_ at BOB/EOB:") - (insert "(foo ") (insert symbol-name) (insert " bar)") - (slime-check-fancy-symbol-name (+ (point-min) 5) symbol-name) - (erase-buffer) - - (unless (eq (aref symbol-name 0) ?\@) ; Skip on `@foobar' - (slime-test-message "*** fancy symbol-name with leading ,:") - (insert ",") (insert symbol-name) - (slime-check-fancy-symbol-name (+ (point-min) 1) symbol-name) - (erase-buffer)) - - (slime-test-message "*** fancy symbol-name with leading ,@:") - (insert ",@") (insert symbol-name) - (slime-check-fancy-symbol-name (+ (point-min) 2) symbol-name) - (erase-buffer) - - (slime-test-message "*** fancy symbol-name with leading `:") - (insert "`") (insert symbol-name) - (slime-check-fancy-symbol-name (+ (point-min) 1) symbol-name) - (erase-buffer) - - (slime-test-message "*** fancy symbol-name wrapped in ():") - (insert "(") (insert symbol-name) (insert ")") - (slime-check-fancy-symbol-name (+ (point-min) 1) symbol-name) - (erase-buffer) - - (slime-test-message "*** fancy symbol-name wrapped in #<>:") - (insert "#<") (insert symbol-name) (insert " {DEADBEEF}>") - (slime-check-fancy-symbol-name (+ (point-min) 2) symbol-name) - (erase-buffer) - - (slime-test-message "*** fancy symbol-name wrapped in #<>:") - (insert "#<") (insert symbol-name) (insert " {DEADBEEF}>") - (slime-check-fancy-symbol-name (+ (point-min) 2) symbol-name) - (erase-buffer) - - (slime-test-message "*** fancy symbol-name wrapped in #| ... |#:") - (insert "#|\n") (insert symbol-name) (insert "\n|#") - (slime-check-fancy-symbol-name (+ (point-min) 4) symbol-name) - (erase-buffer) - - (slime-test-message "*** fancy symbol-name after #| )))(( |# (1):") - (let ((pre-content "#| )))(( #|\n")) - (insert pre-content) - (insert symbol-name) - (slime-check-fancy-symbol-name (+ (point-min) (length pre-content)) - symbol-name) - (erase-buffer)) + (insert prefix) + (let ((start (point))) + (insert symbol suffix) + (dotimes (i (length symbol)) + (goto-char (+ start i)) + (slime-test-expect (format "Check `%s' (at %d)..." + (buffer-string) (point)) + symbol + (slime-symbol-at-point) + #'equal))))) - (slime-test-message "*** fancy symbol-name after #| )))(( |# (2):") - (let ((pre-content "#| )))(( #|")) ; no newline - (insert pre-content) - (insert symbol-name) - (slime-check-fancy-symbol-name (+ (point-min) (length pre-content)) - symbol-name) - (erase-buffer)) - - (slime-test-message "*** fancy symbol-name wrapped in \"...\":") - (insert "\"\n") (insert symbol-name) (insert "\n\"") - (slime-check-fancy-symbol-name (+ (point-min) 3) symbol-name) - (erase-buffer) - - (slime-test-message "*** fancy symbol-name after \" )))(( \" (1):") - (let ((pre-content "\" )))(( \"\n")) - (insert pre-content) - (insert symbol-name) - (slime-check-fancy-symbol-name (+ (point-min) (length pre-content)) - symbol-name) - (erase-buffer)) +(def-slime-test symbol-at-point.1 (sym) + "Check that we can cope with idiosyncratic symbol names." + slime-test-symbols + (slime-check-symbol-at-point "" sym "")) - (slime-test-message "*** fancy symbol-name after \" )))(( \" (2):") - (let ((pre-content "\" )))(( \"")) ; no newline - (insert pre-content) - (insert symbol-name) - (slime-check-fancy-symbol-name (+ (point-min) (length pre-content)) - symbol-name) - (erase-buffer)) - )) +(def-slime-test symbol-at-point.2 (sym) + "fancy symbol-name _not_ at BOB/EOB" + slime-test-symbols + (slime-check-symbol-at-point "(foo " sym " bar)")) + +(def-slime-test symbol-at-point.3 (sym) + "fancy symbol-name with leading ," + (remove-if (lambda (s) (eq (aref (car s) 0) ?@)) slime-test-symbols) + (slime-check-symbol-at-point "," sym "")) + +(def-slime-test symbol-at-point.4 (sym) + "fancy symbol-name with leading ,@" + slime-test-symbols + (slime-check-symbol-at-point ",@" sym "")) + +(def-slime-test symbol-at-point.5 (sym) + "fancy symbol-name with leading `" + slime-test-symbols + (slime-check-symbol-at-point "`" sym "")) + +(def-slime-test symbol-at-point.6 (sym) + "fancy symbol-name wrapped in ()" + slime-test-symbols + (slime-check-symbol-at-point "(" sym ")")) + +(def-slime-test symbol-at-point.7 (sym) + "fancy symbol-name wrapped in #< {DEADBEEF}>" + slime-test-symbols + (slime-check-symbol-at-point "#<" sym " {DEADBEEF}>")) + +;;(def-slime-test symbol-at-point.8 (sym) +;; "fancy symbol-name wrapped in #<>" +;; slime-test-symbols +;; (slime-check-symbol-at-point "#<" sym ">")) + +(def-slime-test symbol-at-point.9 (sym) + "fancy symbol-name wrapped in #| ... |#" + slime-test-symbols + (slime-check-symbol-at-point "#|\n" sym "\n|#")) + +(def-slime-test symbol-at-point.10 (sym) + "fancy symbol-name after #| )))(( |# (1)" + slime-test-symbols + (slime-check-symbol-at-point "#| )))(( #|\n" sym "")) + +(def-slime-test symbol-at-point.11 (sym) + "fancy symbol-name after #| )))(( |# (2)" + slime-test-symbols + (slime-check-symbol-at-point "#| )))(( #|" sym "")) + +(def-slime-test symbol-at-point.12 (sym) + "fancy symbol-name wrapped in \"...\"" + slime-test-symbols + (slime-check-symbol-at-point "\"\n" sym "\"\n")) + +(def-slime-test symbol-at-point.13 (sym) + "fancy symbol-name wrapped in \" )))(( \" (1)" + slime-test-symbols + (slime-check-symbol-at-point "\" )))(( \"\n" sym "")) + +(def-slime-test symbol-at-point.14 (sym) + "fancy symbol-name wrapped in \" )))(( \" (1)" + slime-test-symbols + (slime-check-symbol-at-point "\" )))(( \"" sym "")) (defun* slime-initialize-lisp-buffer-for-test-suite (&key (font-lock-magic t) (autodoc t)) @@ -8309,57 +8296,17 @@ (beginning-of-defun) (list (point) end))))) -(defun slime-exit-vertical-bars () - "Move out from within vertical bars (|foo|) to the leading bar." - (let* ((parser-state (slime-current-parser-state)) - (in-string-p (nth 3 parser-state)) - (string-start (nth 8 parser-state))) - (when (and in-string-p - (eq (char-after string-start) ?\|)) - (goto-char string-start)))) - -(defun slime-symbol-constituent-at (pos) - "Is the character at position POS a valid symbol constituent?" - ;; We assume we're not within vertical bars, otherwise boringly - ;; everything would be a constituent. - (when-let (char (char-after pos)) ; nil when at eob. - (let* ((char-before (or (char-before pos) ?\a)) ; nil when at bob. - (syntax (char-syntax char)) - (syntax-before (char-syntax char-before))) - (if (and (eq char-before ?\#) (eq char ?\<)) ; #< ? - nil - (or - (memq syntax '(?\w ?\_ ?\\)) ; usual suspects? - (eq char ?\|) ; |foo|::|bar|? - (eq syntax-before ?\\) ; escaped? - (and (eq char ?\@) ; ,@@foobar or foo at bar? - (not (eq char-before ?\,)))))))) - -;;; `slime-beginning-of-symbol', and `slime-end-of-symbol' are written -;;; to get a lot of funky CL-style symbol names right (see -;;; `fancy-symbol-names' test.) To get them right, we have to use -;;; `forward-sexp' as that one does properly heed escaping etc. -;;; (defun slime-beginning-of-symbol () "Move to the beginning of the CL-style symbol at point." - (slime-exit-vertical-bars) - (let ((original-point (point))) - (while (slime-symbol-constituent-at (1- (point))) - (forward-sexp -1)) - (when (/= (point) original-point) - ;; Move past initial , and ,@: - (while (not (slime-symbol-constituent-at (point))) - (forward-char 1))))) + (while (re-search-backward "\\(\\sw\\|\\s_\\|\\s\\.\\|\\s\\\\|[#@|]\\)\\=" + nil t)) + (re-search-forward "\\=#[<|]" nil t) + (when (and (looking-at "@") (eq (char-before) ?\,)) + (forward-char))) (defun slime-end-of-symbol () "Move to the end of the CL-style symbol at point." - ;; We call this for two purposes: (a) to move out from vertical - ;; bars, and (b) to get to a safe position (e.g. in "\|foo:|bar|" if - ;; point is at the first vertical bar, `forward-sexp' would not see - ;; the escape.) - (slime-beginning-of-symbol) - (while (slime-symbol-constituent-at (point)) - (forward-sexp 1))) + (re-search-forward "\\=\\(\\sw\\|\\s_\\|\\s\\.\\|[#@|]\\)*")) (put 'slime-symbol 'end-op 'slime-end-of-symbol) (put 'slime-symbol 'beginning-op 'slime-beginning-of-symbol) @@ -8374,25 +8321,11 @@ (defun slime-symbol-at-point () "Return the name of the symbol at point, otherwise nil." - (save-restriction - ;;;; Don't be tricked into grabbing the REPL prompt. - ;;(when (and (eq major-mode 'slime-repl-mode) - ;; (>= (point) slime-repl-input-start-mark)) - ;; (narrow-to-region slime-repl-input-start-mark (point-max))) - (save-excursion - (let ((string (or (thing-at-point 'slime-symbol) - ;; Sometimes we can be too good, e.g. in "|# - ;; (defun foo () (getf" the above would return - ;; nil because the vertical bar is not - ;; terminated. The user probably wants "getf" - ;; nontheless. - (thing-at-point 'symbol)))) - (and string - ;; (thing-at-point 'symbol) returns "" instead of nil - ;; when called from an empty (or narrowed-to-empty) - ;; buffer. - (not (equal string "")) - (substring-no-properties string)))))) + ;; (thing-at-point 'symbol) returns "" in empty buffers + (let ((string (thing-at-point 'slime-symbol))) + (and string + (not (equal string "")) + (substring-no-properties string)))) (defun slime-sexp-at-point () "Return the sexp at point as a string, otherwise nil." From heller at common-lisp.net Sun Jun 21 12:18:25 2009 From: heller at common-lisp.net (CVS User heller) Date: Sun, 21 Jun 2009 08:18:25 -0400 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory cl-net:/tmp/cvs-serv15642 Modified Files: ChangeLog slime.el Log Message: * slime.el (slime-initialize-lisp-buffer-for-test-suite): Moved to contrib/slime-fontifying-fu.el --- /project/slime/cvsroot/slime/ChangeLog 2009/06/21 12:18:10 1.1790 +++ /project/slime/cvsroot/slime/ChangeLog 2009/06/21 12:18:25 1.1791 @@ -1,5 +1,9 @@ 2009-06-21 Helmut Eller + * slime.el (slime-initialize-lisp-buffer-for-test-suite): Moved to + contrib/slime-fontifying-fu.el + +2009-06-21 Helmut Eller Don't try so hard to get symbol-at-point right. The old implementation was complicated and didn't even pass it's own test suite. The new version is less ambitious but simpler. --- /project/slime/cvsroot/slime/slime.el 2009/06/21 12:18:10 1.1188 +++ /project/slime/cvsroot/slime/slime.el 2009/06/21 12:18:25 1.1189 @@ -7419,22 +7419,6 @@ slime-test-symbols (slime-check-symbol-at-point "\" )))(( \"" sym "")) -(defun* slime-initialize-lisp-buffer-for-test-suite - (&key (font-lock-magic t) (autodoc t)) - (let ((hook lisp-mode-hook)) - (unwind-protect - (progn - (set (make-local-variable 'slime-highlight-suppressed-forms) - font-lock-magic) - (setq lisp-mode-hook nil) - (lisp-mode) - (slime-mode 1) - (when (boundp 'slime-autodoc-mode) - (if autodoc - (slime-autodoc-mode 1) - (slime-autodoc-mode -1)))) - (setq lisp-mode-hook hook)))) - (def-slime-test narrowing () "Check that narrowing is properly sustained." '() From heller at common-lisp.net Sun Jun 21 12:18:25 2009 From: heller at common-lisp.net (CVS User heller) Date: Sun, 21 Jun 2009 08:18:25 -0400 Subject: [slime-cvs] CVS slime/contrib Message-ID: Update of /project/slime/cvsroot/slime/contrib In directory cl-net:/tmp/cvs-serv15642/contrib Modified Files: slime-fontifying-fu.el Log Message: * slime.el (slime-initialize-lisp-buffer-for-test-suite): Moved to contrib/slime-fontifying-fu.el --- /project/slime/cvsroot/slime/contrib/slime-fontifying-fu.el 2009/06/16 06:36:40 1.12 +++ /project/slime/cvsroot/slime/contrib/slime-fontifying-fu.el 2009/06/21 12:18:25 1.13 @@ -317,7 +317,21 @@ 'slime-reader-conditional-face (get-text-property (point) 'face))))) - +(defun* slime-initialize-lisp-buffer-for-test-suite + (&key (font-lock-magic t) (autodoc t)) + (let ((hook lisp-mode-hook)) + (unwind-protect + (progn + (set (make-local-variable 'slime-highlight-suppressed-forms) + font-lock-magic) + (setq lisp-mode-hook nil) + (lisp-mode) + (slime-mode 1) + (when (boundp 'slime-autodoc-mode) + (if autodoc + (slime-autodoc-mode 1) + (slime-autodoc-mode -1)))) + (setq lisp-mode-hook hook)))) (provide 'slime-fontifying-fu) @@ -328,4 +342,3 @@ slime-search-directly-preceding-reader-conditional slime-search-suppressed-forms slime-beginning-of-tlf))) - From heller at common-lisp.net Tue Jun 23 18:11:14 2009 From: heller at common-lisp.net (CVS User heller) Date: Tue, 23 Jun 2009 14:11:14 -0400 Subject: [slime-cvs] CVS slime/contrib Message-ID: Update of /project/slime/cvsroot/slime/contrib In directory cl-net:/tmp/cvs-serv12558 Modified Files: ChangeLog Added Files: swank-ikarus.ss swank-larceny.scm swank-r6rs.scm Log Message: * swank-ikarus.ss, swank-larceny.scm, swank-r6rs.scm: New files. --- /project/slime/cvsroot/slime/contrib/ChangeLog 2009/06/16 06:36:40 1.218 +++ /project/slime/cvsroot/slime/contrib/ChangeLog 2009/06/23 18:11:13 1.219 @@ -1,3 +1,7 @@ +2009-06-23 Helmut Eller + + * swank-ikarus.ss, swank-larceny.scm, swank-r6rs.scm: New files. + 2009-06-16 Tobias C. Rittweiler * slime-fontifying-fu.el (slime-search-suppressed-form): --- /project/slime/cvsroot/slime/contrib/swank-ikarus.ss 2009/06/23 18:11:14 NONE +++ /project/slime/cvsroot/slime/contrib/swank-ikarus.ss 2009/06/23 18:11:14 1.1 ;; swank-larceny.scm --- Swank server for Ikarus ;; ;; License: Public Domain ;; Author: Helmut Eller ;; ;; In a shell execute: ;; ikarus swank-ikarus.ss ;; and then `M-x slime-connect' in Emacs. ;; (library (swank os) (export getpid make-server-socket accept local-port close-socket) (import (rnrs) (only (ikarus foreign) make-c-callout dlsym dlopen pointer-set-c-long! pointer-ref-c-unsigned-short malloc free pointer-size) (rename (only (ikarus ipc) tcp-server-socket accept-connection close-tcp-server-socket) (tcp-server-socket make-server-socket) (close-tcp-server-socket close-socket)) (only (ikarus) struct-type-descriptor struct-type-field-names struct-field-accessor) ) (define libc (dlopen)) (define (cfun name return-type arg-types) ((make-c-callout return-type arg-types) (dlsym libc name))) (define getpid (cfun "getpid" 'signed-int '())) (define (accept socket codec) (let-values (((in out) (accept-connection socket))) (values (transcoded-port in (make-transcoder codec)) (transcoded-port out (make-transcoder codec))))) (define (socket-fd socket) (let ((rtd (struct-type-descriptor socket))) (do ((i 0 (+ i 1)) (names (struct-type-field-names rtd) (cdr names))) ((eq? (car names) 'fd) ((struct-field-accessor rtd i) socket))))) (define sockaddr_in/size 16) (define sockaddr_in/sin_family 0) (define sockaddr_in/sin_port 2) (define sockaddr_in/sin_addr 4) (define (local-port socket) (let* ((fd (socket-fd socket)) (addr (malloc sockaddr_in/size)) (size (malloc (pointer-size)))) (pointer-set-c-long! size 0 sockaddr_in/size) (let ((code (getsockname fd addr size)) (port (ntohs (pointer-ref-c-unsigned-short addr sockaddr_in/sin_port)))) (free addr) (free size) (cond ((= code -1) (error "getsockname failed")) (#t port))))) (define getsockname (cfun "getsockname" 'signed-int '(signed-int pointer pointer))) (define ntohs (cfun "ntohs" 'unsigned-short '(unsigned-short))) ) (library (swank sys) (export implementation-name eval-in-interaction-environment) (import (rnrs) (rnrs eval) (only (ikarus) interaction-environment)) (define (implementation-name) "ikarus") (define (eval-in-interaction-environment form) (eval form (interaction-environment))) ) (import (only (ikarus) load)) (load "swank-r6rs.scm") (import (swank)) (start-server #f) --- /project/slime/cvsroot/slime/contrib/swank-larceny.scm 2009/06/23 18:11:14 NONE +++ /project/slime/cvsroot/slime/contrib/swank-larceny.scm 2009/06/23 18:11:14 1.1 ;; swank-larceny.scm --- Swank server for Larceny ;; ;; License: Public Domain ;; Author: Helmut Eller ;; ;; In a shell execute: ;; larceny -r6rs -program swank-larceny.scm ;; and then `M-x slime-connect' in Emacs. (library (swank os) (export getpid make-server-socket accept local-port close-socket) (import (rnrs) (primitives foreign-procedure ffi/handle->address ffi/string->asciiz sizeof:pointer sizeof:int %set-pointer %get-int)) (define getpid (foreign-procedure "getpid" '() 'int)) (define fork (foreign-procedure "fork" '() 'int)) (define close (foreign-procedure "close" '(int) 'int)) (define dup2 (foreign-procedure "dup2" '(int int) 'int)) (define bytevector-content-offset$ sizeof:pointer) (define execvp% (foreign-procedure "execvp" '(string boxed) 'int)) (define (execvp file . args) (let* ((nargs (length args)) (argv (make-bytevector (* (+ nargs 1) sizeof:pointer)))) (do ((offset 0 (+ offset sizeof:pointer)) (as args (cdr as))) ((null? as)) (%set-pointer argv offset (+ (ffi/handle->address (ffi/string->asciiz (car as))) bytevector-content-offset$))) (%set-pointer argv (* nargs sizeof:pointer) 0) (execvp% file argv))) (define pipe% (foreign-procedure "pipe" '(boxed) 'int)) (define (pipe) (let ((array (make-bytevector (* sizeof:int 2)))) (let ((r (pipe% array))) (values r (%get-int array 0) (%get-int array sizeof:int))))) (define (fork/exec file . args) (let ((pid (fork))) (cond ((= pid 0) (apply execvp file args)) (#t pid)))) (define (start-process file . args) (let-values (((r1 down-out down-in) (pipe)) ((r2 up-out up-in) (pipe)) ((r3 err-out err-in) (pipe))) (assert (= 0 r1)) (assert (= 0 r2)) (assert (= 0 r3)) (let ((pid (fork))) (case pid ((-1) (error "Failed to fork a subprocess.")) ((0) (close up-out) (close err-out) (close down-in) (dup2 down-out 0) (dup2 up-in 1) (dup2 err-in 2) (apply execvp file args) (exit 1)) (else (close down-out) (close up-in) (close err-in) (list pid (make-fd-io-stream up-out down-in) (make-fd-io-stream err-out err-out))))))) (define (make-fd-io-stream in out) (let ((write (lambda (bv start count) (fd-write out bv start count))) (read (lambda (bv start count) (fd-read in bv start count))) (closeit (lambda () (close in) (close out)))) (make-custom-binary-input/output-port "fd-stream" read write #f #f closeit))) (define write% (foreign-procedure "write" '(int ulong int) 'int)) (define (fd-write fd bytevector start count) (write% fd (+ (ffi/handle->address bytevector) bytevector-content-offset$ start) count)) (define read% (foreign-procedure "read" '(int ulong int) 'int)) (define (fd-read fd bytevector start count) ;;(printf "fd-read: ~a ~s ~a ~a\n" fd bytevector start count) (read% fd (+ (ffi/handle->address bytevector) bytevector-content-offset$ start) count)) (define (make-server-socket port) (let* ((args `("/bin/bash" "bash" "-c" ,(string-append "netcat -s 127.0.0.1 -q 0 -l -v " (if port (string-append "-p " (number->string port)) "")))) (nc (apply start-process args)) (err (transcoded-port (list-ref nc 2) (make-transcoder (latin-1-codec)))) (line (get-line err)) (pos (last-index-of line '#\]))) (cond (pos (let* ((tail (substring line (+ pos 1) (string-length line))) (port (get-datum (open-string-input-port tail)))) (list (car nc) (cadr nc) err port))) (#t (error "netcat failed: " line))))) (define (accept socket codec) (let* ((line (get-line (caddr socket))) (pos (last-index-of line #\]))) (cond (pos (close-port (caddr socket)) (let ((stream (cadr socket))) (let ((io (transcoded-port stream (make-transcoder codec)))) (values io io)))) (else (error "accept failed: " line))))) (define (local-port socket) (list-ref socket 3)) (define (last-index-of str chr) (let loop ((i (string-length str))) (cond ((<= i 0) #f) (#t (let ((i (- i 1))) (cond ((char=? (string-ref str i) chr) i) (#t (loop i)))))))) (define (close-socket socket) ;;(close-port (cadr socket)) #f ) ) (library (swank sys) (export implementation-name eval-in-interaction-environment) (import (rnrs) (primitives system-features aeryn-evaluator)) (define (implementation-name) "larceny") ;; see $LARCENY/r6rsmode.sch: ;; Larceny's ERR5RS and R6RS modes. ;; Code names: ;; Aeryn ERR5RS ;; D'Argo R6RS-compatible ;; Spanky R6RS-conforming (not yet implemented) (define (eval-in-interaction-environment form) (aeryn-evaluator form)) ) (import (rnrs) (rnrs eval) (larceny load)) (load "swank-r6rs.scm") (eval '(start-server #f) (environment '(swank))) --- /project/slime/cvsroot/slime/contrib/swank-r6rs.scm 2009/06/23 18:11:14 NONE +++ /project/slime/cvsroot/slime/contrib/swank-r6rs.scm 2009/06/23 18:11:14 1.1 ;; swank-r6rs.sls --- Shareable code between swank-ikarus and swank-larceny ;; ;; Licence: public domain ;; Author: Helmut Eller ;; ;; This is a Swank server barely capable enough to process simple eval ;; requests from Emacs before dying. No fancy features like ;; backtraces, module redefintion, M-. etc. are implemented. Don't ;; even think about pc-to-source mapping. ;; ;; Despite standard modules, this file uses (swank os) and (swank sys) ;; which define implementation dependend functionality. There are ;; multiple modules in this files, which is probably not standardized. ;; ;; Naive FORMAT implementation which supports: ~a ~s ~d ~x ~c (library (swank format) (export format printf fprintf) (import (rnrs)) (define (format f . args) (call-with-string-output-port (lambda (port) (apply fprintf port f args)))) (define (printf f . args) (let ((port (current-output-port))) (apply fprintf port f args) (flush-output-port port))) (define (fprintf port f . args) (let ((len (string-length f))) (let loop ((i 0) (args args)) (cond ((= i len) (assert (null? args))) ((and (char=? (string-ref f i) #\~) (< (+ i 1) len)) (dispatch-format (string-ref f (+ i 1)) port (car args)) (loop (+ i 2) (cdr args))) (else (put-char port (string-ref f i)) (loop (+ i 1) args)))))) (define (dispatch-format char port arg) (let ((probe (assoc char format-dispatch-table))) (cond (probe ((cdr probe) arg port)) (else (error "invalid format char: " char))))) (define format-dispatch-table `((#\a . ,display) (#\s . ,write) (#\d . ,(lambda (arg port) (put-string port (number->string arg 10)))) (#\x . ,(lambda (arg port) (put-string port (number->string arg 16)))) (#\c . ,(lambda (arg port) (put-char port arg)))))) ;; CL-style restarts to let us continue after errors. (library (swank restarts) (export with-simple-restart compute-restarts invoke-restart restart-name write-restart-report) (import (rnrs)) (define *restarts* '()) (define-record-type restart (fields name reporter continuation)) (define (with-simple-restart name reporter thunk) (call/cc (lambda (k) (let ((old-restarts *restarts*) (restart (make-restart name (coerce-to-reporter reporter) k))) (dynamic-wind (lambda () (set! *restarts* (cons restart old-restarts))) thunk (lambda () (set! *restarts* old-restarts))))))) (define (compute-restarts) *restarts*) (define (invoke-restart restart . args) (apply (restart-continuation restart) args)) (define (write-restart-report restart port) ((restart-reporter restart) port)) (define (coerce-to-reporter obj) (cond ((string? obj) (lambda (port) (put-string port obj))) (#t (assert (procedure? obj)) obj))) ) ;; This module encodes & decodes messages from the wire and queues them. (library (swank event-queue) (export make-event-queue wait-for-event enqueue-event read-event write-event) (import (rnrs) (rnrs mutable-pairs) (swank format)) (define-record-type event-queue (fields (mutable q) wait-fun) (protocol (lambda (init) (lambda (wait-fun) (init '() wait-fun))))) (define (wait-for-event q pattern) (or (poll q pattern) (begin ((event-queue-wait-fun q) q) (wait-for-event q pattern)))) (define (poll q pattern) (let loop ((lag #f) (l (event-queue-q q))) (cond ((null? l) #f) ((event-match? (car l) pattern) (cond (lag (set-cdr! lag (cdr l)) (car l)) (else (event-queue-q-set! q (cdr l)) (car l)))) (else (loop l (cdr l)))))) (define (event-match? event pattern) (cond ((or (number? pattern) (member pattern '(t nil))) (equal? event pattern)) ((symbol? pattern) #t) ((pair? pattern) [288 lines skipped] From nsiivola at common-lisp.net Wed Jun 24 15:33:20 2009 From: nsiivola at common-lisp.net (CVS User nsiivola) Date: Wed, 24 Jun 2009 11:33:20 -0400 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory cl-net:/tmp/cvs-serv2994 Modified Files: ChangeLog slime.el swank.lisp Log Message: Add :WAIT keyword argument to support blocking in SWANK:INSPECT-IN-EMACS. --- /project/slime/cvsroot/slime/ChangeLog 2009/06/21 12:18:25 1.1791 +++ /project/slime/cvsroot/slime/ChangeLog 2009/06/24 15:33:19 1.1792 @@ -1,3 +1,16 @@ +2009-06-24 Nikodemus Siivola + + Add :WAIT keyword argument to support blocking in + SWANK:INSPECT-IN-EMACS. + + * swank.lisp (inspect-in-emacs): added keyword argument :wait. + + * slime.el (slime-dispatch-event): if swank requests response to + :inspect, add a hook to the inspector to signal swank once done. + (slime-open-inspector): add optional hook argument to be added as + local kill-buffer-hook. + + 2009-06-21 Helmut Eller * slime.el (slime-initialize-lisp-buffer-for-test-suite): Moved to --- /project/slime/cvsroot/slime/slime.el 2009/06/21 12:18:25 1.1189 +++ /project/slime/cvsroot/slime/slime.el 2009/06/24 15:33:20 1.1190 @@ -2424,8 +2424,13 @@ (slime-send `(:emacs-return ,thread ,tag ,value))) ((:ed what) (slime-ed what)) - ((:inspect what) - (slime-open-inspector what)) + ((:inspect what wait-thread wait-tag) + (let ((hook (when (and wait-thread wait-tag) + (lexical-let ((thread wait-thread) + (tag wait-tag)) + (lambda () + (slime-send `(:emacs-return ,thread ,tag nil))))))) + (slime-open-inspector what nil hook))) ((:background-message message) (slime-background-message "%s" message)) ((:debug-condition thread message) @@ -6313,10 +6318,13 @@ (defvar slime-inspector-insert-ispec-function 'slime-inspector-insert-ispec) -(defun slime-open-inspector (inspected-parts &optional point) +(defun slime-open-inspector (inspected-parts &optional point hook) "Display INSPECTED-PARTS in a new inspector window. -Optionally set point to POINT." +Optionally set point to POINT. If HOOK is provided, it is added to local +KILL-BUFFER hooks for the inspector buffer." (with-current-buffer (slime-inspector-buffer) + (when hook + (add-hook 'kill-buffer-hook hook t t)) (setq slime-buffer-connection (slime-current-connection)) (let ((inhibit-read-only t)) (erase-buffer) --- /project/slime/cvsroot/slime/swank.lisp 2009/06/21 07:22:56 1.649 +++ /project/slime/cvsroot/slime/swank.lisp 2009/06/24 15:33:20 1.650 @@ -2384,13 +2384,20 @@ (send-oob-to-emacs `(:ed ,target)))) (t nil))))) -(defslimefun inspect-in-emacs (what) - "Inspect WHAT in Emacs." +(defslimefun inspect-in-emacs (what &key wait) + "Inspect WHAT in Emacs. If WAIT is true (default NIL) blocks until the +inspector has been closed in Emacs." (flet ((send-it () - (with-buffer-syntax () - (reset-inspector) - (send-oob-to-emacs `(:inspect ,(inspect-object what)))))) - (cond + (let ((tag (when wait (make-tag))) + (thread (when wait (current-thread-id)))) + (with-buffer-syntax () + (reset-inspector) + (send-oob-to-emacs `(:inspect ,(inspect-object what) + ,thread + ,tag))) + (when wait + (wait-for-event `(:emacs-return ,tag result)))))) + (cond (*emacs-connection* (send-it)) ((default-connection) From gcarncross at common-lisp.net Thu Jun 25 04:04:45 2009 From: gcarncross at common-lisp.net (CVS User gcarncross) Date: Thu, 25 Jun 2009 00:04:45 -0400 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory cl-net:/tmp/cvs-serv13329 Modified Files: swank-ecl.lisp Log Message: Profiling support by Marko Koci?? --- /project/slime/cvsroot/slime/swank-ecl.lisp 2009/06/21 07:22:56 1.41 +++ /project/slime/cvsroot/slime/swank-ecl.lisp 2009/06/25 04:04:45 1.42 @@ -471,6 +471,31 @@ (read-snippet s)))))))) `(:error (format nil "Source definition of ~S not found" obj)))) +;;;; Profiling + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require 'profile)) + +(defimplementation profile (fname) + (when fname (eval `(profile:profile ,fname)))) + +(defimplementation unprofile (fname) + (when fname (eval `(profile:unprofile ,fname)))) + +(defimplementation unprofile-all () + (profile:unprofile-all) + "All functions unprofiled.") + +(defimplementation profile-report () + (profile:report)) + +(defimplementation profile-reset () + (profile:reset) + "Reset profiling counters.") + +(defimplementation profiled-functions () + (profile:profile)) + ;;;; Threads #+threads From gcarncross at common-lisp.net Thu Jun 25 04:06:17 2009 From: gcarncross at common-lisp.net (CVS User gcarncross) Date: Thu, 25 Jun 2009 00:06:17 -0400 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory cl-net:/tmp/cvs-serv15835 Modified Files: ChangeLog Log Message: Profiling support by Marko Koci?? --- /project/slime/cvsroot/slime/ChangeLog 2009/06/24 15:33:19 1.1792 +++ /project/slime/cvsroot/slime/ChangeLog 2009/06/25 04:06:15 1.1793 @@ -1,3 +1,7 @@ +2009-06-25 Geo Carncross + + * swank-ecl.lisp: Profiling support by Marko Koci?? + 2009-06-24 Nikodemus Siivola Add :WAIT keyword argument to support blocking in @@ -518,7 +522,7 @@ * swank-sbcl.lisp (swank-compile-file): Return T for the FAILURE-P return value in case of a FATAL-COMPILER-ERROR. - Reported by Philipp M. Sch?fer + Reported by Philipp M. Sch??fer 2009-04-03 Tobias C. Rittweiler @@ -1439,7 +1443,7 @@ * slime.el (slime-compute-modeline-connection-state): Fix computation of debugged requests. -2008-11-30 G?bor Melis +2008-11-30 G??bor Melis * slime.el (slime-compute-modeline-connection-state): Print the number of debugged requests if non-zero. @@ -1476,7 +1480,7 @@ (slime-restart-or-init-modeline-update-timer): Inrease the timer interval to 0.5 seconds. -2008-11-22 G?bor Melis +2008-11-22 G??bor Melis Reincarnate "eval..." (almost) @@ -1526,7 +1530,7 @@ 2008-10-31 Helmut Eller * slime.el (slime-repl-history-pattern): Simplify as suggested by - Knut Olav B?hmer and Michael Weber. + Knut Olav B??hmer and Michael Weber. 2008-10-31 Helmut Eller @@ -1764,7 +1768,7 @@ * slime.el (slime-cycle-connections): Do not make the new connection buffer-local if we're currently in a REPL buffer. -2008-09-24 Knut Olav B?hmer +2008-09-24 Knut Olav B??hmer * slime.el (slime-cycle-connections): New command. @@ -3160,7 +3164,7 @@ * slime.el (slime-list-threads, slime-thread-insert): Adapted to new return value of LIST-THREADS. -2008-07-04 G?bor Melis +2008-07-04 G??bor Melis * swank.lisp (call-with-redirected-io): Rebind only standard streams if *GLOBALLY-REDIRECT-IO*. Fixes lost output after @@ -3859,7 +3863,7 @@ Typical use is something like: (defun cmucl () (interactive) (slime 'cmucl)) -2008-01-22 Lu?s Oliveira +2008-01-22 Lu??s Oliveira * swank-source-path-parser.lisp (make-source-recording-readtable): don't suppress the #. reader macro. @@ -3937,7 +3941,7 @@ physical namestring, Emacs won't like a pathname or a logical namestring. -2008-01-02 Lu?s Oliveira +2008-01-02 Lu??s Oliveira Use sane default values for slime-repl-set-package. @@ -3983,7 +3987,7 @@ * slime.el (slime-insert-xref-location): New function. Tries to either insert the file name a function is defined in, or inserts information about the buffer a function was interactively - `C-c C-c'd from. Idea from Knut Olav B?hmer. + `C-c C-c'd from. Idea from Knut Olav B??hmer. (slime-insert-xrefs): Use it. 2007-12-14 Geo Carncross @@ -4521,7 +4525,7 @@ 2007-08-31 Andreas Fuchs * slime.el (slime-reindent-defun): Fixed when used in lisp file - buffers. (Similiar patch also provided by G?bor Melis; problem + buffers. (Similiar patch also provided by G??bor Melis; problem also reported by Jeff Cunningham.) 2007-08-31 Jon Allen Boone @@ -5167,7 +5171,7 @@ 2007-06-27 Tobias C. Rittweiler - Fixing `C-c M-q' at the REPL. Thanks to Andr? Thieme for pointing + Fixing `C-c M-q' at the REPL. Thanks to Andr?? Thieme for pointing out that it has been broken since several months. * slime.el (slime-reindent-defun): Use functions @@ -5333,7 +5337,7 @@ * swank.lisp (fuzzy-find-matching-symbols): Modified to take package nicknames into account. Previously, fuzzy completing on nicknames did (except for some incidental cases) not work. Thanks - to Lu?s Oliveira and Attila Lendvai for pointing that out. + to Lu??s Oliveira and Attila Lendvai for pointing that out. 2007-05-11 Tobias C. Rittweiler @@ -5606,7 +5610,7 @@ combined with their classification flags as determined by CLASSIFY-SYMBOL. -2007-04-08 Lu?s Oliveira +2007-04-08 Lu??s Oliveira * swank-backend.lisp (compute-sane-restarts): New interface. * swank-clisp.lisp: Fix tabs and trailing whitespace. @@ -6534,7 +6538,7 @@ (slime-repl-clear-buffer): Added optional prefix argument specifying how many lines to leave. -2006-12-06 Johan Bockg?rd +2006-12-06 Johan Bockg??rd * swank.lisp (fuzzy-completion-set): Don't mix for clauses and body clauses in loop. @@ -6882,7 +6886,7 @@ * swank-allegro.lisp (initialize-multiprocessing): Update for new api. -2006-10-20 Levente M?sz?ros +2006-10-20 Levente M??sz??ros Added "in-place" fuzzy completion GUI. See slime-fuzzy-completions-map and @@ -7417,7 +7421,7 @@ * swank.asd: Set *source-directory* to the asdf component dir. -2006-07-01 Lu?s Oliveira +2006-07-01 Lu??s Oliveira * swank-sbcl.lisp (locate-compiler-note): Change first branch to handle the changes introduced by the previous patch to @@ -7428,7 +7432,7 @@ * swank-sbcl.lisp (find-definitions): Remove backward compatibility code. -2006-06-26 Lu?s Oliveira +2006-06-26 Lu??s Oliveira * swank-sbcl.lisp (tmpnam, temp-file-name): New functions. (swank-compile-string): Create temporary file with the string and @@ -7929,7 +7933,7 @@ * slime.el (slime-autodoc): Use it here to make use of the whole width of the echo area for arglist display. -2006-03-16 G?bor Melis +2006-03-16 G??bor Melis * swank-allegro.lisp (inspect-for-emacs): Fix typo. @@ -8162,7 +8166,7 @@ * swank-backend.lisp: Add slot-value-using-class and slot-boundp-using-class to the swank-mop package. -2006-01-26 Lu?s Oliveira +2006-01-26 Lu??s Oliveira * slime.el (slime-enclosing-operator-names): detect make-instance forms and collect the class-name argument if it exists and is a @@ -8174,7 +8178,7 @@ (class-initargs-and-iniforms): New function. (format-initargs-and-initforms-for-echo-area): New function. -2006-01-20 M?sz?ros Levente +2006-01-20 M??sz??ros Levente * swank-sbcl.lisp (restart-frame): Provide an implementation even if it doesn't quite do what it's supposed to do. @@ -8454,7 +8458,7 @@ * slime.el (slime-repl-history-size, slime-repl-history-file): Use defcustom to declare the variables. -2005-10-23 G?bor Melis +2005-10-23 G??bor Melis * swank-backend.lisp (install-debugger-globally): new interface function @@ -9447,12 +9451,12 @@ (slime-repl-compile-and-load): Use save-some-lisp-buffers. (slime-oos): Use save-some-lisp-buffers. -2005-07-01 G?bor Melis +2005-07-01 G??bor Melis * swank-sbcl.lisp (threaded stuff): make SBCL 0.9.2.9+ work while retaining support for 0.9.2 -2005-06-28 G?bor Melis +2005-06-28 G??bor Melis * swank-sbcl.lisp (threaded stuff): horrible hack to make threaded SBCL 0.9.2 work. (also, Happy Birthday Christophe!) @@ -9929,7 +9933,7 @@ (slime-with-output-end-mark, slime-repl-return) (slime-repl-send-input, slime-display-output-buffer): Use it (slime-lisp-implementation-version, slime-machine-instance): New - connection variables. Suggested by Eduardo Mu?oz. + connection variables. Suggested by Eduardo Mu??oz. (slime-set-connection-info): Initialize them. * swank.lisp (connection-info): Include version and hostname in @@ -10611,7 +10615,7 @@ * swank-sbcl.lisp (profile-package): Add implementation for SBCL. -2005-01-10 Eduardo Mu?oz +2005-01-10 Eduardo Mu??oz * swank.lisp (inspect-for-emacs-list): LispWorks has a low args limit for apply: use reduce instead of apply. @@ -11351,7 +11355,7 @@ * slime.el (define-slime-dialect): New macro to make starting Lisps with different command line options easier. -2004-09-27 Rui Patroc?nio +2004-09-27 Rui Patroc??nio * swank.lisp (mop, mop-helper): Support functions for the class browser. @@ -11498,7 +11502,7 @@ * swank-sbcl.lisp, swank-cmucl.lisp (inspect-for-emacs): Insert function object's documentation when it's available. -2004-09-15 Eduardo Mu?oz +2004-09-15 Eduardo Mu??oz * .cvsignore: Added *.elc @@ -12356,7 +12360,7 @@ * hyperspec.el (common-lisp-hyperspec-format): This command now works at the end of the buffer, fixed `char-after' usage as - suggested by Johan Bockg?rd. + suggested by Johan Bockg??rd. 2004-06-28 Christophe Rhodes @@ -12792,11 +12796,11 @@ whitespace. * (slime-init-output-buffer): Initialize the package stack. - Reported by Rui Patroc?nio. + Reported by Rui Patroc??nio. * (slime-completions): Make it consistent with slime-simple-completions. The second argument was never supplied. - Reported by Rui Patroc?nio. + Reported by Rui Patroc??nio. 2004-06-09 Eric Blood @@ -13694,7 +13698,7 @@ `slime-mode'. This seems to give priority of keymap to the inspector, so that it can override SPC. -2004-03-26 Bj?rn Nordb? +2004-03-26 Bj??rn Nordb?? * swank.lisp (print-arglist): Updated to handle arglists with string elements, causing arglists for macros to display properly @@ -13718,7 +13722,7 @@ Wrap byte-compilation in `save-window-excursion' to avoid showing an unwanted warnings buffer (in XEmacs). -2004-03-25 Bj?rn Nordb? +2004-03-25 Bj??rn Nordb?? * swank-lispworks.lisp: (create-socket, set-sigint-handler) (who-references, who-binds, who-sets): Add backward compatibility @@ -13748,7 +13752,7 @@ (break): Be friendly to case-inverting readtables. * swank-lispworks.lisp (emacs-connected): Add default method to - environment-display-notifier. Reported by Bj?rn Nordb?. + environment-display-notifier. Reported by Bj??rn Nordb??. (set-default-directory, who-specializes): Implemented for Lispworks. (gfp): New function. @@ -14031,7 +14035,7 @@ 2004-03-09 Helmut Eller * swank-cmucl.lisp (read-into-simple-string): Use the correct fix. - Reported by H?kon Alstadheim. + Reported by H??kon Alstadheim. 2004-03-08 Helmut Eller @@ -15665,7 +15669,7 @@ 2003-12-11 Helmut Eller * slime.el (slime-repl-previous-prompt, slime-repl-next-prompt): - New commands. Suggested by H?kon Alstadheim. + New commands. Suggested by H??kon Alstadheim. (slime-repl-beginning-of-defun, slime-repl-end-of-defun): New commands. Suggested by Andreas Fuchs. (slime-repl-insert-prompt): Mark the prompt with a From heller at common-lisp.net Sat Jun 27 15:10:29 2009 From: heller at common-lisp.net (CVS User heller) Date: Sat, 27 Jun 2009 11:10:29 -0400 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory cl-net:/tmp/cvs-serv15686 Modified Files: ChangeLog slime.el Log Message: * slime.el (slime-beginning-of-symbol): Skip over #., #-, and #+. ([test] symbol-at-point.15 .. 17): Test it. --- /project/slime/cvsroot/slime/ChangeLog 2009/06/25 04:06:15 1.1793 +++ /project/slime/cvsroot/slime/ChangeLog 2009/06/27 15:10:29 1.1794 @@ -2,6 +2,11 @@ * swank-ecl.lisp: Profiling support by Marko Koci?? +2009-06-27 Helmut Eller + + * slime.el (slime-beginning-of-symbol): Skip over #., #-, and #+. + ([test] symbol-at-point.15 .. 17): Test it. + 2009-06-24 Nikodemus Siivola Add :WAIT keyword argument to support blocking in --- /project/slime/cvsroot/slime/slime.el 2009/06/24 15:33:20 1.1190 +++ /project/slime/cvsroot/slime/slime.el 2009/06/27 15:10:29 1.1191 @@ -7427,6 +7427,21 @@ slime-test-symbols (slime-check-symbol-at-point "\" )))(( \"" sym "")) +(def-slime-test symbol-at-point.15 (sym) + "symbol-at-point after #." + slime-test-symbols + (slime-check-symbol-at-point "#." sym "")) + +(def-slime-test symbol-at-point.16 (sym) + "symbol-at-point after #+" + slime-test-symbols + (slime-check-symbol-at-point "#+" sym "")) + +(def-slime-test symbol-at-point.17 (sym) + "symbol-at-point after #-" + slime-test-symbols + (slime-check-symbol-at-point "#-" sym "")) + (def-slime-test narrowing () "Check that narrowing is properly sustained." '() @@ -8292,7 +8307,7 @@ "Move to the beginning of the CL-style symbol at point." (while (re-search-backward "\\(\\sw\\|\\s_\\|\\s\\.\\|\\s\\\\|[#@|]\\)\\=" nil t)) - (re-search-forward "\\=#[<|]" nil t) + (re-search-forward "\\=#[-+.<|]" nil t) (when (and (looking-at "@") (eq (char-before) ?\,)) (forward-char))) From sboukarev at common-lisp.net Sun Jun 28 08:27:03 2009 From: sboukarev at common-lisp.net (CVS User sboukarev) Date: Sun, 28 Jun 2009 04:27:03 -0400 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory cl-net:/tmp/cvs-serv11866 Modified Files: ChangeLog swank-openmcl.lisp Log Message: (compiler-warning-short-message): In new versions of CCL `compiler-warning-nrefs' slot of the `compiler-warning' class is now a list, not an integer. --- /project/slime/cvsroot/slime/ChangeLog 2009/06/27 15:10:29 1.1794 +++ /project/slime/cvsroot/slime/ChangeLog 2009/06/28 08:27:03 1.1795 @@ -1,3 +1,9 @@ +2009-06-28 Stas Boukarev + + * swank-openmcl.lisp (compiler-warning-short-message): In new + versions of CCL `compiler-warning-nrefs' slot + of the `compiler-warning' class is now a list, not an integer. + 2009-06-25 Geo Carncross * swank-ecl.lisp: Profiling support by Marko Koci?? --- /project/slime/cvsroot/slime/swank-openmcl.lisp 2009/06/21 07:22:56 1.179 +++ /project/slime/cvsroot/slime/swank-openmcl.lisp 2009/06/28 08:27:03 1.180 @@ -256,8 +256,10 @@ (ccl::adjust-compiler-warning-args type args))) (null (format stream "~A: ~S" type args)) (t (funcall format-string c stream))) - (when (and nrefs (/= nrefs 1)) - (format stream " (~D references)" nrefs)))))) + (let ((nrefs (cond ((numberp nrefs) nrefs) + ((consp nrefs) (length nrefs))))) + (when (and nrefs (/= nrefs 1)) + (format stream " (~D references)" nrefs))))))) (defimplementation call-with-compilation-hooks (function) (handler-bind ((ccl::compiler-warning 'handle-compiler-warning)) From sboukarev at common-lisp.net Sun Jun 28 08:51:19 2009 From: sboukarev at common-lisp.net (CVS User sboukarev) Date: Sun, 28 Jun 2009 04:51:19 -0400 Subject: [slime-cvs] CVS slime/contrib Message-ID: Update of /project/slime/cvsroot/slime/contrib In directory cl-net:/tmp/cvs-serv17527 Modified Files: ChangeLog slime-fuzzy.el Log Message: (slime-fuzzy-complete-symbol): show message in the minibuffer after showing completion list, because completion itself can take place in the minibuffer. (slime-fuzzy-choices-buffer): if completion was started in the minibuffer, don't switch to minibuffer in the other window, but select minibuffer window instead. --- /project/slime/cvsroot/slime/contrib/ChangeLog 2009/06/23 18:11:13 1.219 +++ /project/slime/cvsroot/slime/contrib/ChangeLog 2009/06/28 08:51:18 1.220 @@ -1,3 +1,12 @@ +2009-06-28 Stas Boukarev + + * slime-fuzzy.el (slime-fuzzy-complete-symbol): show message in the + minibuffer after showing completion list, because completion + itself can take place in the minibuffer. + (slime-fuzzy-choices-buffer): if completion was started in the minibuffer, + don't switch to minibuffer in the other window, but select minibuffer window + instead. + 2009-06-23 Helmut Eller * swank-ikarus.ss, swank-larceny.scm, swank-r6rs.scm: New files. --- /project/slime/cvsroot/slime/contrib/slime-fuzzy.el 2009/01/08 10:33:12 1.9 +++ /project/slime/cvsroot/slime/contrib/slime-fuzzy.el 2009/06/28 08:51:18 1.10 @@ -281,8 +281,8 @@ (slime-fuzzy-done)) ;; Incomplete (t - (slime-minibuffer-respecting-message "Complete but not unique") - (slime-fuzzy-choices-buffer completion-set interrupted-p beg end))))))) + (slime-fuzzy-choices-buffer completion-set interrupted-p beg end) + (slime-minibuffer-respecting-message "Complete but not unique"))))))) (defun slime-get-fuzzy-buffer () @@ -369,7 +369,9 @@ (setq buffer-quit-function 'slime-fuzzy-abort)) ; M-Esc Esc (when slime-fuzzy-completion-in-place ;; switch back to the original buffer - (switch-to-buffer-other-window slime-fuzzy-target-buffer)))) + (if (minibufferp slime-fuzzy-target-buffer) + (select-window (minibuffer-window)) + (switch-to-buffer-other-window slime-fuzzy-target-buffer))))) (defun slime-fuzzy-fill-completions-buffer (completions interrupted-p) "Erases and fills the completion buffer with the given completions." From heller at common-lisp.net Sun Jun 28 19:14:44 2009 From: heller at common-lisp.net (CVS User heller) Date: Sun, 28 Jun 2009 15:14:44 -0400 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory cl-net:/tmp/cvs-serv5187 Modified Files: ChangeLog swank-sbcl.lisp Log Message: * swank-sbcl.lisp (add-fd-handler): Avoid recursive invocation of the handler, e.g. when read-sequence blocks. --- /project/slime/cvsroot/slime/ChangeLog 2009/06/28 08:27:03 1.1795 +++ /project/slime/cvsroot/slime/ChangeLog 2009/06/28 19:14:43 1.1796 @@ -1,3 +1,8 @@ +2009-06-28 Helmut Eller + + * swank-sbcl.lisp (add-fd-handler): Avoid recursive invocation + of the handler, e.g. when read-sequence blocks. + 2009-06-28 Stas Boukarev * swank-openmcl.lisp (compiler-warning-short-message): In new @@ -19,12 +24,11 @@ SWANK:INSPECT-IN-EMACS. * swank.lisp (inspect-in-emacs): added keyword argument :wait. - + * slime.el (slime-dispatch-event): if swank requests response to :inspect, add a hook to the inspector to signal swank once done. (slime-open-inspector): add optional hook argument to be added as local kill-buffer-hook. - 2009-06-21 Helmut Eller @@ -32,6 +36,7 @@ contrib/slime-fontifying-fu.el 2009-06-21 Helmut Eller + Don't try so hard to get symbol-at-point right. The old implementation was complicated and didn't even pass it's own test suite. The new version is less ambitious but simpler. --- /project/slime/cvsroot/slime/swank-sbcl.lisp 2009/06/21 07:22:56 1.243 +++ /project/slime/cvsroot/slime/swank-sbcl.lisp 2009/06/28 19:14:44 1.244 @@ -139,12 +139,18 @@ (sb-sys:invalidate-descriptor fd)) (close socket)) -(defimplementation add-fd-handler (socket fn) - (declare (type function fn)) - (let ((fd (socket-fd socket))) - (sb-sys:add-fd-handler fd :input (lambda (_) - _ - (funcall fn))))) +(defimplementation add-fd-handler (socket fun) + (let ((fd (socket-fd socket)) + (handler nil)) + (labels ((add () + (setq handler (sb-sys:add-fd-handler fd :input #'run))) + (run (fd) + (sb-sys:remove-fd-handler handler) ; prevent recursion + (unwind-protect + (funcall fun) + (when (sb-unix:unix-fstat fd) ; still open? + (add))))) + (add)))) (defimplementation remove-fd-handlers (socket) (sb-sys:invalidate-descriptor (socket-fd socket))) From heller at common-lisp.net Sun Jun 28 19:14:55 2009 From: heller at common-lisp.net (CVS User heller) Date: Sun, 28 Jun 2009 15:14:55 -0400 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory cl-net:/tmp/cvs-serv5234 Modified Files: ChangeLog slime.el Log Message: * slime.el (slime-compiler-macroexpand-inplace) (slime-compiler-macroexpand-1-inplace): New commands. (slime-macroexpansion-minor-mode-map): Bind them. Patch by Stelian Ionescu. --- /project/slime/cvsroot/slime/ChangeLog 2009/06/28 19:14:43 1.1796 +++ /project/slime/cvsroot/slime/ChangeLog 2009/06/28 19:14:54 1.1797 @@ -1,3 +1,9 @@ +2009-06-28 Stelian Ionescu + + * slime.el (slime-compiler-macroexpand-inplace) + (slime-compiler-macroexpand-1-inplace): New commands. + (slime-macroexpansion-minor-mode-map): Bind them. + 2009-06-28 Helmut Eller * swank-sbcl.lisp (add-fd-handler): Avoid recursive invocation --- /project/slime/cvsroot/slime/slime.el 2009/06/27 15:10:29 1.1191 +++ /project/slime/cvsroot/slime/slime.el 2009/06/28 19:14:54 1.1192 @@ -5032,6 +5032,8 @@ (define-key slime-macroexpansion-minor-mode-map mapping to)))) (remap 'slime-macroexpand-1 'slime-macroexpand-1-inplace) (remap 'slime-macroexpand-all 'slime-macroexpand-all-inplace) + (remap 'slime-compiler-macroexpand-1 'slime-compiler-macroexpand-1-inplace) + (remap 'slime-compiler-macroexpand 'slime-compiler-macroexpand-inplace) (remap 'advertised-undo 'slime-macroexpand-undo) (remap 'undo 'slime-macroexpand-undo)) @@ -5160,11 +5162,21 @@ (interactive) (slime-eval-macroexpand 'swank:swank-compiler-macroexpand)) +(defun slime-compiler-macroexpand-inplace () + "Display the compiler-macro expansion of sexp at point." + (interactive) + (slime-eval-macroexpand-inplace 'swank:swank-compiler-macroexpand)) + (defun slime-compiler-macroexpand-1 () "Display the compiler-macro expansion of sexp at point." (interactive) (slime-eval-macroexpand 'swank:swank-compiler-macroexpand-1)) +(defun slime-compiler-macroexpand-1-inplace () + "Display the compiler-macro expansion of sexp at point." + (interactive) + (slime-eval-macroexpand-inplace 'swank:swank-compiler-macroexpand-1)) + (defun slime-format-string-expand () "Format the format-string at point, and display its expansion." (interactive) From heller at common-lisp.net Sun Jun 28 19:15:08 2009 From: heller at common-lisp.net (CVS User heller) Date: Sun, 28 Jun 2009 15:15:08 -0400 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory cl-net:/tmp/cvs-serv5277 Modified Files: ChangeLog slime.el swank-backend.lisp swank-openmcl.lisp swank.lisp Log Message: Generalize list-threads for implementation-dependent attributes. * swank-backend.lisp (thread-attributes): New function. * swank-openmcl (thread-attributes): Implement it. * swank.lisp (list-threads): Return a table with the attribute names as the first row and the new attributes in the last columns. * slime.el (slime-update-threads-buffer): For now, ignore the extra attributes. --- /project/slime/cvsroot/slime/ChangeLog 2009/06/28 19:14:54 1.1797 +++ /project/slime/cvsroot/slime/ChangeLog 2009/06/28 19:15:07 1.1798 @@ -1,3 +1,14 @@ +2009-06-28 Terje Norderhaug + + Generalize list-threads for implementation-dependent attributes. + + * swank-backend.lisp (thread-attributes): New function. + * swank-openmcl (thread-attributes): Implement it. + * swank.lisp (list-threads): Return a table with the attribute + names as the first row and the new attributes in the last columns. + * slime.el (slime-update-threads-buffer): For now, ignore the + extra attributes. + 2009-06-28 Stelian Ionescu * slime.el (slime-compiler-macroexpand-inplace) --- /project/slime/cvsroot/slime/slime.el 2009/06/28 19:14:54 1.1192 +++ /project/slime/cvsroot/slime/slime.el 2009/06/28 19:15:08 1.1193 @@ -6122,7 +6122,7 @@ (defun slime-update-threads-buffer () (interactive) - (let ((threads (slime-eval '(swank:list-threads)))) + (let ((threads (cdr (slime-eval '(swank:list-threads))))) (with-current-buffer slime-threads-buffer-name (let ((inhibit-read-only t)) (erase-buffer) --- /project/slime/cvsroot/slime/swank-backend.lisp 2009/06/21 07:22:56 1.176 +++ /project/slime/cvsroot/slime/swank-backend.lisp 2009/06/28 19:15:08 1.177 @@ -1007,6 +1007,11 @@ (declare (ignore thread description)) "") +(definterface thread-attributes (thread) + "Return a plist of implementation-dependent attributes for THREAD" + (declare (ignore thread)) + '()) + (definterface make-lock (&key name) "Make a lock for thread synchronization. Only one thread may hold the lock (via CALL-WITH-LOCK-HELD) at a time --- /project/slime/cvsroot/slime/swank-openmcl.lisp 2009/06/28 08:27:03 1.180 +++ /project/slime/cvsroot/slime/swank-openmcl.lisp 2009/06/28 19:15:08 1.181 @@ -843,6 +843,9 @@ (defimplementation thread-status (thread) (format nil "~A" (ccl:process-whostate thread))) +(defimplementation thread-attributes (thread) + (list :priority (ccl::process-priority thread))) + (defimplementation make-lock (&key name) (ccl:make-lock name)) --- /project/slime/cvsroot/slime/swank.lisp 2009/06/24 15:33:20 1.650 +++ /project/slime/cvsroot/slime/swank.lisp 2009/06/28 19:15:08 1.651 @@ -3595,15 +3595,23 @@ a time.") (defslimefun list-threads () - "Return a list ((ID NAME STATUS DESCRIPTION) ...) of all threads." + "Return a list (LABELS (ID NAME STATUS DESCRIPTION ATTRS ...) ...). +LABELS is a list of attribute names and the remaining lists are the +corresponding attribute values per thread." (setq *thread-list* (all-threads)) - (loop for thread in *thread-list* - for name = (thread-name thread) - collect (list (thread-id thread) - (if (symbolp name) (symbol-name name) name) - (thread-status thread) - (thread-description thread) - ))) + (let* ((plist (thread-attributes (car *thread-list*))) + (labels (loop for (key) on plist by #'cddr + collect key))) + `((:id :name :status :description , at labels) + ,@(loop for thread in *thread-list* + for name = (thread-name thread) + for attributes = (thread-attributes thread) + collect (list* (thread-id thread) + (if (symbolp name) (symbol-name name) name) + (thread-status thread) + (thread-description thread) + (loop for label in labels + collect (getf attributes label))))))) (defslimefun quit-thread-browser () (setq *thread-list* nil)) From sboukarev at common-lisp.net Mon Jun 29 04:24:52 2009 From: sboukarev at common-lisp.net (CVS User sboukarev) Date: Mon, 29 Jun 2009 00:24:52 -0400 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory cl-net:/tmp/cvs-serv12750 Modified Files: ChangeLog swank.lisp Log Message: (open-streams): do not create unnecessary output stream when using dedicated output stream. Thanks to Terje Norderhaug. --- /project/slime/cvsroot/slime/ChangeLog 2009/06/28 19:15:07 1.1798 +++ /project/slime/cvsroot/slime/ChangeLog 2009/06/29 04:24:51 1.1799 @@ -1,3 +1,8 @@ +2009-06-29 Stas Boukarev + + * swank.lisp (open-streams): do not create unnecessary output stream + when using dedicated output stream. Thanks to Terje Norderhaug. + 2009-06-28 Terje Norderhaug Generalize list-threads for implementation-dependent attributes. --- /project/slime/cvsroot/slime/swank.lisp 2009/06/28 19:15:08 1.651 +++ /project/slime/cvsroot/slime/swank.lisp 2009/06/29 04:24:51 1.652 @@ -895,8 +895,7 @@ (defun open-streams (connection) "Return the 5 streams for IO redirection: DEDICATED-OUTPUT INPUT OUTPUT IO REPL-RESULTS" - (let* ((output-fn (make-output-function connection)) - (input-fn + (let* ((input-fn (lambda () (with-connection (connection) (with-simple-restart (abort-read @@ -905,9 +904,9 @@ (dedicated-output (if *use-dedicated-output-stream* (open-dedicated-output-stream (connection.socket-io connection)))) - (out (make-output-stream output-fn)) (in (make-input-stream input-fn)) - (out (or dedicated-output out)) + (out (or dedicated-output + (make-output-stream (make-output-function connection)))) (io (make-two-way-stream in out)) (repl-results (make-output-stream-for-target connection :repl-result))) From sboukarev at common-lisp.net Tue Jun 30 02:50:26 2009 From: sboukarev at common-lisp.net (CVS User sboukarev) Date: Mon, 29 Jun 2009 22:50:26 -0400 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory cl-net:/tmp/cvs-serv30932 Modified Files: ChangeLog swank-openmcl.lisp Log Message: * swank-openmcl.lisp (arglist): Return :not-available if the arglist cannot be obtained. Patch by Terje Norderhaug. --- /project/slime/cvsroot/slime/ChangeLog 2009/06/29 04:24:51 1.1799 +++ /project/slime/cvsroot/slime/ChangeLog 2009/06/30 02:50:25 1.1800 @@ -1,3 +1,8 @@ +2009-06-30 Stas Boukarev + + * swank-openmcl.lisp (arglist): Return :not-available if the arglist + cannot be obtained. Patch by Terje Norderhaug. + 2009-06-29 Stas Boukarev * swank.lisp (open-streams): do not create unnecessary output stream --- /project/slime/cvsroot/slime/swank-openmcl.lisp 2009/06/28 19:15:08 1.181 +++ /project/slime/cvsroot/slime/swank-openmcl.lisp 2009/06/30 02:50:25 1.182 @@ -206,7 +206,10 @@ ;;; Arglist (defimplementation arglist (fname) - (arglist% fname)) + (multiple-value-bind (arglist binding) (arglist% fname) + (if binding + arglist + :not-available))) (defmethod arglist% ((f symbol)) (ccl:arglist f))