From sboukarev at common-lisp.net Tue May 1 10:07:34 2012 From: sboukarev at common-lisp.net (CVS User sboukarev) Date: Tue, 01 May 2012 03:07:34 -0700 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory tiger.common-lisp.net:/tmp/cvs-serv32030 Modified Files: ChangeLog slime.el Log Message: * slime.el (slime-xrefs-for-notes): Format location in a proper way. Reported by Max Mikhanosha. --- /project/slime/cvsroot/slime/ChangeLog 2012/04/27 14:57:58 1.2321 +++ /project/slime/cvsroot/slime/ChangeLog 2012/05/01 10:07:34 1.2322 @@ -1,3 +1,9 @@ +2012-05-01 Stas Boukarev + + * slime.el (slime-xrefs-for-notes): Format location in a proper + way. + Reported by Max Mikhanosha. + 2012-04-27 Nikodemus Siivola * swank-sbcl.lisp (lisp-source-location): How hard can it be to --- /project/slime/cvsroot/slime/slime.el 2012/04/23 16:32:52 1.1401 +++ /project/slime/cvsroot/slime/slime.el 2012/05/01 10:07:34 1.1402 @@ -2842,10 +2842,10 @@ (fn (cadr (assq :file (cdr location)))) (file (assoc fn xrefs)) (node - (cons (format "%s: %s" - (getf note :severity) - (slime-one-line-ify (getf note :message))) - location))) + (list (format "%s: %s" + (getf note :severity) + (slime-one-line-ify (getf note :message))) + location))) (when fn (if file (push node (cdr file)) From sboukarev at common-lisp.net Wed May 2 17:33:17 2012 From: sboukarev at common-lisp.net (CVS User sboukarev) Date: Wed, 02 May 2012 10:33:17 -0700 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory tiger.common-lisp.net:/tmp/cvs-serv1508 Modified Files: ChangeLog swank.lisp Log Message: * swank.lisp (*find-definitions-right-trim*) (*find-definitions-left-trim*): New variables. ",:." and "#:" default values. (find-definitions-for-emacs): Trim names with using the above variables when a symbol is not found. --- /project/slime/cvsroot/slime/ChangeLog 2012/05/01 10:07:34 1.2322 +++ /project/slime/cvsroot/slime/ChangeLog 2012/05/02 17:33:16 1.2323 @@ -1,3 +1,11 @@ +2012-05-02 Stas Boukarev + + * swank.lisp (*find-definitions-right-trim*) + (*find-definitions-left-trim*): New variables. ",:." and "#:" + default values. + (find-definitions-for-emacs): Trim names with using the above + variables when a symbol is not found. + 2012-05-01 Stas Boukarev * slime.el (slime-xrefs-for-notes): Format location in a proper --- /project/slime/cvsroot/slime/swank.lisp 2012/04/24 11:12:14 1.787 +++ /project/slime/cvsroot/slime/swank.lisp 2012/05/02 17:33:16 1.788 @@ -65,7 +65,9 @@ #:quit-lisp #:eval-for-emacs #:eval-in-emacs - #:y-or-n-p-in-emacs)) + #:y-or-n-p-in-emacs + #:*find-definitions-right-trim* + #:*find-definitions-left-trim*)) (in-package :swank) @@ -2918,12 +2920,29 @@ (inspector-nth-part part)) ((:sldb frame var) (frame-var-value frame var)))) - + +(defvar *find-definitions-right-trim* ",:.") +(defvar *find-definitions-left-trim* "#:") + +(defun find-definitions-find-symbol (name) + (flet ((do-find (name) + (multiple-value-bind (symbol found) + (parse-symbol name) + (when found + (return-from find-definitions-find-symbol + (values symbol found)))))) + (do-find name) + (do-find (string-right-trim *find-definitions-right-trim* name)) + (do-find (string-left-trim *find-definitions-left-trim* name)) + (do-find (string-left-trim *find-definitions-left-trim* + (string-right-trim + *find-definitions-right-trim* name))))) + (defslimefun find-definitions-for-emacs (name) "Return a list ((DSPEC LOCATION) ...) of definitions for NAME. DSPEC is a string and LOCATION a source location. NAME is a string." - (multiple-value-bind (symbol found) (with-buffer-syntax () - (parse-symbol name)) + (multiple-value-bind (symbol found) + (find-definitions-find-symbol name) (when found (mapcar #'xref>elisp (find-definitions symbol))))) From sboukarev at common-lisp.net Thu May 3 07:44:54 2012 From: sboukarev at common-lisp.net (CVS User sboukarev) Date: Thu, 03 May 2012 00:44:54 -0700 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory tiger.common-lisp.net:/tmp/cvs-serv9549 Modified Files: ChangeLog swank.lisp Log Message: * swank.lisp (find-definitions-find-symbol): Put back accidentally removed with-buffer-syntax. --- /project/slime/cvsroot/slime/ChangeLog 2012/05/02 17:33:16 1.2323 +++ /project/slime/cvsroot/slime/ChangeLog 2012/05/03 07:44:53 1.2324 @@ -1,3 +1,8 @@ +2012-05-03 Stas Boukarev + + * swank.lisp (find-definitions-find-symbol): Put back accidentally + removed with-buffer-syntax. + 2012-05-02 Stas Boukarev * swank.lisp (*find-definitions-right-trim*) --- /project/slime/cvsroot/slime/swank.lisp 2012/05/02 17:33:16 1.788 +++ /project/slime/cvsroot/slime/swank.lisp 2012/05/03 07:44:54 1.789 @@ -2927,7 +2927,8 @@ (defun find-definitions-find-symbol (name) (flet ((do-find (name) (multiple-value-bind (symbol found) - (parse-symbol name) + (with-buffer-syntax () + (parse-symbol name)) (when found (return-from find-definitions-find-symbol (values symbol found)))))) From sboukarev at common-lisp.net Thu May 3 14:12:23 2012 From: sboukarev at common-lisp.net (CVS User sboukarev) Date: Thu, 03 May 2012 07:12:23 -0700 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory tiger.common-lisp.net:/tmp/cvs-serv7687 Modified Files: ChangeLog swank-backend.lisp swank-sbcl.lisp Log Message: * swank-sbcl.lisp (definition-source-for-emacs): Prefer :file over :buffer, because the buffer can be killed in the mean time and the silly "No buffer named x.lisp" would be displayed. --- /project/slime/cvsroot/slime/ChangeLog 2012/05/03 07:44:53 1.2324 +++ /project/slime/cvsroot/slime/ChangeLog 2012/05/03 14:12:22 1.2325 @@ -1,5 +1,11 @@ 2012-05-03 Stas Boukarev + * swank-sbcl.lisp (definition-source-for-emacs): Prefer :file over + :buffer, because the buffer can be killed in the mean time and the + silly "No buffer named x.lisp" would be displayed. + +2012-05-03 Stas Boukarev + * swank.lisp (find-definitions-find-symbol): Put back accidentally removed with-buffer-syntax. --- /project/slime/cvsroot/slime/swank-backend.lisp 2012/04/07 10:23:38 1.217 +++ /project/slime/cvsroot/slime/swank-backend.lisp 2012/05/03 14:12:22 1.218 @@ -239,19 +239,21 @@ (defmacro with-struct ((conc-name &rest names) obj &body body) "Like with-slots but works only for structs." - (flet ((reader (slot) (intern (concatenate 'string - (symbol-name conc-name) - (symbol-name slot)) - (symbol-package conc-name)))) + (flet ((reader (slot) + ;; Use read-from-string instead of intern so that + ;; conc-name can be a string such as ext:struct- and not + ;; cause errors and not force interning ext::struct- + (read-from-string + (concatenate 'string (string conc-name) (string slot))))) (let ((tmp (gensym "OO-"))) - ` (let ((,tmp ,obj)) - (symbol-macrolet - ,(loop for name in names collect - (typecase name - (symbol `(,name (,(reader name) ,tmp))) - (cons `(,(first name) (,(reader (second name)) ,tmp))) - (t (error "Malformed syntax in WITH-STRUCT: ~A" name)))) - , at body))))) + ` (let ((,tmp ,obj)) + (symbol-macrolet + ,(loop for name in names collect + (typecase name + (symbol `(,name (,(reader name) ,tmp))) + (cons `(,(first name) (,(reader (second name)) ,tmp))) + (t (error "Malformed syntax in WITH-STRUCT: ~A" name)))) + , at body))))) (defmacro when-let ((var value) &body body) `(let ((,var ,value)) --- /project/slime/cvsroot/slime/swank-sbcl.lisp 2012/04/27 14:57:59 1.309 +++ /project/slime/cvsroot/slime/swank-sbcl.lisp 2012/05/03 14:12:23 1.310 @@ -789,49 +789,64 @@ (defun categorize-definition-source (definition-source) - (with-struct (sb-introspect::definition-source- - pathname form-path character-offset plist) - definition-source + (with-struct ("sb-introspect:definition-source-" + pathname form-path character-offset plist) + definition-source (cond ((getf plist :emacs-buffer) :buffer) - ((and pathname (or form-path character-offset)) :file) + ((and pathname (or form-path character-offset) + (probe-file pathname)) :file) (pathname :file-without-position) (t :invalid)))) +(defun definition-source-buffer-location (definition-source) + (with-struct ("sb-introspect:definition-source-" + form-path character-offset plist) + definition-source + (destructuring-bind (&key emacs-buffer emacs-position emacs-directory + emacs-string &allow-other-keys) + plist + (let ((*readtable* (guess-readtable-for-filename emacs-directory))) + (multiple-value-bind (start end) + (if form-path + (with-debootstrapping + (source-path-string-position form-path + emacs-string)) + (values character-offset + most-positive-fixnum)) + (make-location + `(:buffer ,emacs-buffer) + `(:offset ,emacs-position ,start) + `(:snippet + ,(subseq emacs-string + start + (min end (+ start *source-snippet-size*)))))))))) + +(defun definition-source-file-location (definition-source) + (with-struct ("sb-introspect:definition-source-" + pathname form-path character-offset plist + file-write-date) definition-source + (let* ((namestring (namestring (translate-logical-pathname pathname))) + (pos (if form-path + (source-file-position namestring file-write-date + form-path) + character-offset)) + (snippet (source-hint-snippet namestring file-write-date pos))) + (make-location `(:file ,namestring) + ;; /file positions/ in Common Lisp start from + ;; 0, buffer positions in Emacs start from 1. + `(:position ,(1+ pos)) + `(:snippet ,snippet))))) + (defun definition-source-for-emacs (definition-source type name) - (with-struct (sb-introspect::definition-source- - pathname form-path character-offset plist - file-write-date) - definition-source + (with-struct ("sb-introspect:definition-source-" + pathname form-path character-offset plist + file-write-date) + definition-source (ecase (categorize-definition-source definition-source) (:buffer - (destructuring-bind (&key emacs-buffer emacs-position emacs-directory - emacs-string &allow-other-keys) - plist - (let ((*readtable* (guess-readtable-for-filename emacs-directory))) - (multiple-value-bind (start end) - (if form-path - (with-debootstrapping - (source-path-string-position form-path emacs-string)) - (values character-offset most-positive-fixnum)) - (make-location - `(:buffer ,emacs-buffer) - `(:offset ,emacs-position ,start) - `(:snippet - ,(subseq emacs-string - start - (min end (+ start *source-snippet-size*))))))))) + (definition-source-buffer-location definition-source)) (:file - (let* ((namestring (namestring (translate-logical-pathname pathname))) - (pos (if form-path - (source-file-position namestring file-write-date - form-path) - character-offset)) - (snippet (source-hint-snippet namestring file-write-date pos))) - (make-location `(:file ,namestring) - ;; /file positions/ in Common Lisp start from - ;; 0, buffer positions in Emacs start from 1. - `(:position ,(1+ pos)) - `(:snippet ,snippet)))) + (definition-source-file-location definition-source)) (:file-without-position (make-location `(:file ,(namestring (translate-logical-pathname pathname))) @@ -840,9 +855,9 @@ `(:snippet ,(format nil "(defun ~a " (symbol-name name)))))) (:invalid - (error "DEFINITION-SOURCE of ~A ~A did not contain ~ + (error "DEFINITION-SOURCE of ~(~A~) ~A did not contain ~ meaningful information." - (string-downcase type) name))))) + type name))))) (defun source-file-position (filename write-date form-path) (let ((source (get-source-code filename write-date)) From sboukarev at common-lisp.net Thu May 3 14:28:17 2012 From: sboukarev at common-lisp.net (CVS User sboukarev) Date: Thu, 03 May 2012 07:28:17 -0700 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory tiger.common-lisp.net:/tmp/cvs-serv10875 Modified Files: ChangeLog swank-sbcl.lisp Log Message: * swank-sbcl.lisp (quit-lisp): Use sb-ext:exit when it's present. --- /project/slime/cvsroot/slime/ChangeLog 2012/05/03 14:12:22 1.2325 +++ /project/slime/cvsroot/slime/ChangeLog 2012/05/03 14:28:17 1.2326 @@ -3,6 +3,7 @@ * swank-sbcl.lisp (definition-source-for-emacs): Prefer :file over :buffer, because the buffer can be killed in the mean time and the silly "No buffer named x.lisp" would be displayed. + (quit-lisp): Use sb-ext:exit when it's present. 2012-05-03 Stas Boukarev --- /project/slime/cvsroot/slime/swank-sbcl.lisp 2012/05/03 14:12:23 1.310 +++ /project/slime/cvsroot/slime/swank-sbcl.lisp 2012/05/03 14:28:17 1.311 @@ -1671,10 +1671,14 @@ ) (defimplementation quit-lisp () - #+sb-thread - (dolist (thread (remove (current-thread) (all-threads))) - (ignore-errors (sb-thread:terminate-thread thread))) - (sb-ext:quit)) + #+#.(swank-backend:with-symbol 'exit 'sb-ext) + (sb-ext:exit) + #-#.(swank-backend:with-symbol 'exit 'sb-ext) + (progn + #+sb-thread + (dolist (thread (remove (current-thread) (all-threads))) + (ignore-errors (sb-thread:terminate-thread thread))) + (sb-ext:quit))) From sboukarev at common-lisp.net Thu May 3 15:49:17 2012 From: sboukarev at common-lisp.net (CVS User sboukarev) Date: Thu, 03 May 2012 08:49:17 -0700 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory tiger.common-lisp.net:/tmp/cvs-serv6427 Modified Files: ChangeLog slime.el swank-sbcl.lisp Log Message: * slime.el (slime-goto-source-location): Allow for :buffer-and-file locations, prefer buffer if the buffer exists. * swank-sbcl.lisp (definition-source-for-emacs): Send :buffer-and-file when both are available. (quit-lisp): Use sb-ext:exit when it's present. --- /project/slime/cvsroot/slime/ChangeLog 2012/05/03 14:28:17 1.2326 +++ /project/slime/cvsroot/slime/ChangeLog 2012/05/03 15:49:17 1.2327 @@ -1,8 +1,10 @@ 2012-05-03 Stas Boukarev - * swank-sbcl.lisp (definition-source-for-emacs): Prefer :file over - :buffer, because the buffer can be killed in the mean time and the - silly "No buffer named x.lisp" would be displayed. + * slime.el (slime-goto-source-location): Allow for + :buffer-and-file locations, prefer buffer if the buffer exists. + + * swank-sbcl.lisp (definition-source-for-emacs): Send + :buffer-and-file when both are available. (quit-lisp): Use sb-ext:exit when it's present. 2012-05-03 Stas Boukarev --- /project/slime/cvsroot/slime/slime.el 2012/05/01 10:07:34 1.1402 +++ /project/slime/cvsroot/slime/slime.el 2012/05/03 15:49:17 1.1403 @@ -3307,6 +3307,11 @@ ((:buffer buffer-name) (slime-check-location-buffer-name-sanity buffer-name) (set-buffer buffer-name)) + ((:buffer-and-file buffer filename) + (slime-goto-location-buffer + (if (get-buffer buffer) + (list :buffer buffer) + (list :file filename)))) ((:source-form string) (set-buffer (get-buffer-create (slime-buffer-name :source))) (erase-buffer) @@ -3430,6 +3435,7 @@ ::= (:file ) | (:buffer ) + | (:buffer-and-file ) | (:source-form ) | (:zip ) @@ -3440,18 +3446,38 @@ | (:source-path ) | (:method . )" (destructure-case location - ((:location buffer _position _hints) - (slime-goto-location-buffer buffer) - (let ((pos (slime-location-offset location))) - (cond ((and (<= (point-min) pos) (<= pos (point-max)))) - (widen-automatically (widen)) - (t (error "Location is outside accessible part of buffer"))) - (goto-char pos))) + ((:location buffer position hints) + (cond ((eql (car buffer) :buffer-and-file) + (slime-goto-source-location-buffer-and-file buffer position hints + noerror)) + (t + (slime-goto-location-buffer buffer) + (let ((pos (slime-location-offset location))) + (cond ((and (<= (point-min) pos) (<= pos (point-max)))) + (widen-automatically (widen)) + (t + (error "Location is outside accessible part of buffer"))) + (goto-char pos))))) ((:error message) (if noerror (slime-message "%s" message) (error "%s" message))))) +(defun slime-goto-source-location-buffer-and-file (buffer position hints + noerror) + (destructuring-bind (type buffer file) buffer + (slime-goto-source-location + (if (get-buffer buffer) + (list :location + (list :buffer buffer) + (getf position :buffer-position) + (getf hints :buffer-hints)) + (list :location + (list :file file) + (getf position :file-position) + (getf hints :file-hints))) + noerror))) + (defun slime-location-offset (location) "Return the position, as character number, of LOCATION." (save-restriction @@ -3964,6 +3990,7 @@ (if buffer (format "%S" buffer) ; "#" (format "%s (previously existing buffer)" bufname)))) + ((:buffer-and-file buffer filename) filename) ((:source-form _) "(S-Exp)") ((:zip _zip entry) entry))) (t --- /project/slime/cvsroot/slime/swank-sbcl.lisp 2012/05/03 14:28:17 1.311 +++ /project/slime/cvsroot/slime/swank-sbcl.lisp 2012/05/03 15:49:17 1.312 @@ -792,11 +792,13 @@ (with-struct ("sb-introspect:definition-source-" pathname form-path character-offset plist) definition-source - (cond ((getf plist :emacs-buffer) :buffer) - ((and pathname (or form-path character-offset) - (probe-file pathname)) :file) - (pathname :file-without-position) - (t :invalid)))) + (let ((file-p (and pathname (probe-file pathname) + (or form-path character-offset)))) + (cond ((and (getf plist :emacs-buffer) file-p) :buffer-and-file) + ((getf plist :emacs-buffer) :buffer) + (file-p :file) + (pathname :file-without-position) + (t :invalid))))) (defun definition-source-buffer-location (definition-source) (with-struct ("sb-introspect:definition-source-" @@ -837,12 +839,27 @@ `(:position ,(1+ pos)) `(:snippet ,snippet))))) +(defun definition-source-buffer-and-file-location (definition-source) + (let ((buffer (definition-source-buffer-location definition-source)) + (file (definition-source-file-location definition-source))) + (make-location (list :buffer-and-file + (cadr (location-buffer buffer)) + (cadr (location-buffer file))) + (list + :buffer-position (location-position buffer) + :file-position (location-position file)) + (list + :buffer-hints (location-hints buffer) + :file-hints (location-hints file))))) + (defun definition-source-for-emacs (definition-source type name) (with-struct ("sb-introspect:definition-source-" pathname form-path character-offset plist file-write-date) definition-source (ecase (categorize-definition-source definition-source) + (:buffer-and-file + (definition-source-buffer-and-file-location definition-source)) (:buffer (definition-source-buffer-location definition-source)) (:file From sboukarev at common-lisp.net Thu May 3 15:58:39 2012 From: sboukarev at common-lisp.net (CVS User sboukarev) Date: Thu, 03 May 2012 08:58:39 -0700 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory tiger.common-lisp.net:/tmp/cvs-serv7416 Modified Files: slime.el swank-sbcl.lisp Log Message: Simplify :buffer-and-file handling. --- /project/slime/cvsroot/slime/slime.el 2012/05/03 15:49:17 1.1403 +++ /project/slime/cvsroot/slime/slime.el 2012/05/03 15:58:39 1.1404 @@ -3446,18 +3446,14 @@ | (:source-path ) | (:method . )" (destructure-case location - ((:location buffer position hints) - (cond ((eql (car buffer) :buffer-and-file) - (slime-goto-source-location-buffer-and-file buffer position hints - noerror)) - (t - (slime-goto-location-buffer buffer) - (let ((pos (slime-location-offset location))) - (cond ((and (<= (point-min) pos) (<= pos (point-max)))) - (widen-automatically (widen)) - (t - (error "Location is outside accessible part of buffer"))) - (goto-char pos))))) + ((:location buffer _position _hints) + (slime-goto-location-buffer buffer) + (let ((pos (slime-location-offset location))) + (cond ((and (<= (point-min) pos) (<= pos (point-max)))) + (widen-automatically (widen)) + (t + (error "Location is outside accessible part of buffer"))) + (goto-char pos))) ((:error message) (if noerror (slime-message "%s" message) --- /project/slime/cvsroot/slime/swank-sbcl.lisp 2012/05/03 15:49:17 1.312 +++ /project/slime/cvsroot/slime/swank-sbcl.lisp 2012/05/03 15:58:39 1.313 @@ -845,36 +845,32 @@ (make-location (list :buffer-and-file (cadr (location-buffer buffer)) (cadr (location-buffer file))) - (list - :buffer-position (location-position buffer) - :file-position (location-position file)) - (list - :buffer-hints (location-hints buffer) - :file-hints (location-hints file))))) + (location-position buffer) + (location-hints buffer)))) (defun definition-source-for-emacs (definition-source type name) (with-struct ("sb-introspect:definition-source-" pathname form-path character-offset plist file-write-date) definition-source - (ecase (categorize-definition-source definition-source) - (:buffer-and-file - (definition-source-buffer-and-file-location definition-source)) - (:buffer - (definition-source-buffer-location definition-source)) - (:file - (definition-source-file-location definition-source)) - (:file-without-position - (make-location `(:file ,(namestring - (translate-logical-pathname pathname))) - '(:position 1) - (when (eql type :function) - `(:snippet ,(format nil "(defun ~a " - (symbol-name name)))))) - (:invalid - (error "DEFINITION-SOURCE of ~(~A~) ~A did not contain ~ + (:dbg (ecase (categorize-definition-source definition-source) + (:buffer-and-file + (definition-source-buffer-and-file-location definition-source)) + (:buffer + (definition-source-buffer-location definition-source)) + (:file + (definition-source-file-location definition-source)) + (:file-without-position + (make-location `(:file ,(namestring + (translate-logical-pathname pathname))) + '(:position 1) + (when (eql type :function) + `(:snippet ,(format nil "(defun ~a " + (symbol-name name)))))) + (:invalid + (error "DEFINITION-SOURCE of ~(~A~) ~A did not contain ~ meaningful information." - type name))))) + type name)))))) (defun source-file-position (filename write-date form-path) (let ((source (get-source-code filename write-date)) From sboukarev at common-lisp.net Thu May 3 15:59:06 2012 From: sboukarev at common-lisp.net (CVS User sboukarev) Date: Thu, 03 May 2012 08:59:06 -0700 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory tiger.common-lisp.net:/tmp/cvs-serv7501 Modified Files: swank-sbcl.lisp Log Message: Remove debugging code. --- /project/slime/cvsroot/slime/swank-sbcl.lisp 2012/05/03 15:58:39 1.313 +++ /project/slime/cvsroot/slime/swank-sbcl.lisp 2012/05/03 15:59:06 1.314 @@ -853,24 +853,24 @@ pathname form-path character-offset plist file-write-date) definition-source - (:dbg (ecase (categorize-definition-source definition-source) - (:buffer-and-file - (definition-source-buffer-and-file-location definition-source)) - (:buffer - (definition-source-buffer-location definition-source)) - (:file - (definition-source-file-location definition-source)) - (:file-without-position - (make-location `(:file ,(namestring - (translate-logical-pathname pathname))) - '(:position 1) - (when (eql type :function) - `(:snippet ,(format nil "(defun ~a " - (symbol-name name)))))) - (:invalid - (error "DEFINITION-SOURCE of ~(~A~) ~A did not contain ~ + (ecase (categorize-definition-source definition-source) + (:buffer-and-file + (definition-source-buffer-and-file-location definition-source)) + (:buffer + (definition-source-buffer-location definition-source)) + (:file + (definition-source-file-location definition-source)) + (:file-without-position + (make-location `(:file ,(namestring + (translate-logical-pathname pathname))) + '(:position 1) + (when (eql type :function) + `(:snippet ,(format nil "(defun ~a " + (symbol-name name)))))) + (:invalid + (error "DEFINITION-SOURCE of ~(~A~) ~A did not contain ~ meaningful information." - type name)))))) + type name))))) (defun source-file-position (filename write-date form-path) (let ((source (get-source-code filename write-date)) From nsiivola at common-lisp.net Fri May 4 11:16:40 2012 From: nsiivola at common-lisp.net (CVS User nsiivola) Date: Fri, 04 May 2012 04:16:40 -0700 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory tiger.common-lisp.net:/tmp/cvs-serv8180 Modified Files: ChangeLog swank-sbcl.lisp Log Message: sbcl: remove MERGE-TAIL-CALLS proclamation --- /project/slime/cvsroot/slime/ChangeLog 2012/05/03 15:49:17 1.2327 +++ /project/slime/cvsroot/slime/ChangeLog 2012/05/04 11:16:40 1.2328 @@ -1,3 +1,8 @@ +2012-05-04 Nikodemus Siivola + + * swank-sbcl.lisp: Remove the SB-C::MERGE-TAIL-CALLS proclamation. + It does nothing, and never did, actually. + 2012-05-03 Stas Boukarev * slime.el (slime-goto-source-location): Allow for --- /project/slime/cvsroot/slime/swank-sbcl.lisp 2012/05/03 15:59:06 1.314 +++ /project/slime/cvsroot/slime/swank-sbcl.lisp 2012/05/04 11:16:40 1.315 @@ -22,8 +22,7 @@ (declaim (optimize (debug 2) (sb-c::insert-step-conditions 0) - (sb-c::insert-debug-catch 0) - (sb-c::merge-tail-calls 2))) + (sb-c::insert-debug-catch 0))) ;;; backwards compability tests From sboukarev at common-lisp.net Fri May 4 14:34:30 2012 From: sboukarev at common-lisp.net (CVS User sboukarev) Date: Fri, 04 May 2012 07:34:30 -0700 Subject: [slime-cvs] CVS slime/contrib Message-ID: Update of /project/slime/cvsroot/slime/contrib In directory tiger.common-lisp.net:/tmp/cvs-serv8547 Modified Files: ChangeLog swank-fancy-inspector.lisp Log Message: * swank-fancy-inspector.lisp (emacs-inspect symbol): On SBCL, show information about type specifiers. --- /project/slime/cvsroot/slime/contrib/ChangeLog 2012/04/20 05:54:21 1.546 +++ /project/slime/cvsroot/slime/contrib/ChangeLog 2012/05/04 14:34:30 1.547 @@ -1,3 +1,8 @@ +2012-05-04 Stas Boukarev + + * swank-fancy-inspector.lisp (emacs-inspect symbol): On SBCL, + show information about type specifiers. + 2012-04-20 John Smith Prettier arglists. --- /project/slime/cvsroot/slime/contrib/swank-fancy-inspector.lisp 2012/04/06 18:08:30 1.33 +++ /project/slime/cvsroot/slime/contrib/swank-fancy-inspector.lisp 2012/05/04 14:34:30 1.34 @@ -11,14 +11,14 @@ (defmethod emacs-inspect ((symbol symbol)) (let ((package (symbol-package symbol))) - (multiple-value-bind (_symbol status) - (and package (find-symbol (string symbol) package)) + (multiple-value-bind (_symbol status) + (and package (find-symbol (string symbol) package)) (declare (ignore _symbol)) (append - (label-value-line "Its name is" (symbol-name symbol)) - ;; - ;; Value - (cond ((boundp symbol) + (label-value-line "Its name is" (symbol-name symbol)) + ;; + ;; Value + (cond ((boundp symbol) (append (label-value-line (if (constantp symbol) "It is a constant of value" @@ -29,42 +29,42 @@ `(" " (:action "[unbind]" ,(lambda () (makunbound symbol)))) '((:newline)))) - (t '("It is unbound." (:newline)))) - (docstring-ispec "Documentation" symbol 'variable) - (multiple-value-bind (expansion definedp) (macroexpand symbol) - (if definedp - (label-value-line "It is a symbol macro with expansion" - expansion))) - ;; - ;; Function - (if (fboundp symbol) - (append (if (macro-function symbol) - `("It a macro with macro-function: " - (:value ,(macro-function symbol))) - `("It is a function: " - (:value ,(symbol-function symbol)))) - `(" " (:action "[unbind]" - ,(lambda () (fmakunbound symbol)))) - `((:newline))) - `("It has no function value." (:newline))) - (docstring-ispec "Function documentation" symbol 'function) - (when (compiler-macro-function symbol) - (append + (t '("It is unbound." (:newline)))) + (docstring-ispec "Documentation" symbol 'variable) + (multiple-value-bind (expansion definedp) (macroexpand symbol) + (if definedp + (label-value-line "It is a symbol macro with expansion" + expansion))) + ;; + ;; Function + (if (fboundp symbol) + (append (if (macro-function symbol) + `("It a macro with macro-function: " + (:value ,(macro-function symbol))) + `("It is a function: " + (:value ,(symbol-function symbol)))) + `(" " (:action "[unbind]" + ,(lambda () (fmakunbound symbol)))) + `((:newline))) + `("It has no function value." (:newline))) + (docstring-ispec "Function documentation" symbol 'function) + (when (compiler-macro-function symbol) + (append (label-value-line "It also names the compiler macro" (compiler-macro-function symbol) :newline nil) `(" " (:action "[remove]" ,(lambda () - (setf (compiler-macro-function symbol) nil))) + (setf (compiler-macro-function symbol) nil))) (:newline)))) - (docstring-ispec "Compiler macro documentation" - symbol 'compiler-macro) - ;; - ;; Package + (docstring-ispec "Compiler macro documentation" + symbol 'compiler-macro) + ;; + ;; Package (if package - `("It is " ,(string-downcase (string status)) + `("It is " ,(string-downcase (string status)) " to the package: " (:value ,package ,(package-name package)) - ,@(if (eq :internal status) + ,@(if (eq :internal status) `(" " (:action "[export]" ,(lambda () (export symbol package))))) @@ -73,33 +73,67 @@ ,(lambda () (unintern symbol package))) (:newline)) '("It is a non-interned symbol." (:newline))) - ;; - ;; Plist - (label-value-line "Property list" (symbol-plist symbol)) - ;; - ;; Class - (if (find-class symbol nil) - `("It names the class " - (:value ,(find-class symbol) ,(string symbol)) + ;; + ;; Plist + (label-value-line "Property list" (symbol-plist symbol)) + ;; + ;; Class + (if (find-class symbol nil) + `("It names the class " + (:value ,(find-class symbol) ,(string symbol)) " " - (:action "[remove]" - ,(lambda () (setf (find-class symbol) nil))) - (:newline))) - ;; - ;; More package - (if (find-package symbol) - (label-value-line "It names the package" (find-package symbol))) - )))) + (:action "[remove]" + ,(lambda () (setf (find-class symbol) nil))) + (:newline))) + ;; + ;; More package + (if (find-package symbol) + (label-value-line "It names the package" (find-package symbol))) + (inspect-type-specifier symbol))))) + +#-sbcl +(defun inspect-type-specifier (symbol) + (declare (ignore symbol))) + +#+sbcl +(defun inspect-type-specifier (symbol) + (let* ((kind (sb-int:info :type :kind symbol)) + (fun (case kind + (:defined + (or (sb-int:info :type :expander symbol) t)) + (:primitive + (or (sb-int:info :type :translator symbol) t))))) + (when fun + (append + (list + (format nil "It names a ~@[primitive~* ~]type-specifier." + (eq kind :primitive)) + '(:newline)) + (docstring-ispec "Type-specifier documentation" symbol 'type) + (unless (eq t fun) + (append + `("Type-specifier lambda-list: " + ,(inspector-princ + (if (eq :primitive kind) + (arglist fun) + (sb-int:info :type :lambda-list symbol))) + (:newline)) + (multiple-value-bind (expansion ok) + (handler-case (sb-ext:typexpand-1 symbol) + (error () (values nil nil))) + (when ok + (list "Type-specifier expansion: " + (princ-to-string expansion)))))))))) (defun docstring-ispec (label object kind) "Return a inspector spec if OBJECT has a docstring of of kind KIND." (let ((docstring (documentation object kind))) (cond ((not docstring) nil) - ((< (+ (length label) (length docstring)) - 75) - (list label ": " docstring '(:newline))) - (t - (list label ":" '(:newline) " " docstring '(:newline)))))) + ((< (+ (length label) (length docstring)) + 75) + (list label ": " docstring '(:newline))) + (t + (list label ":" '(:newline) " " docstring '(:newline)))))) (unless (find-method #'emacs-inspect '() (list (find-class 'function)) nil) (defmethod emacs-inspect ((f function)) @@ -108,12 +142,12 @@ (defun inspect-function (f) (append (label-value-line "Name" (function-name f)) - `("Its argument list is: " + `("Its argument list is: " ,(inspector-princ (arglist f)) (:newline)) (docstring-ispec "Documentation" f t) (if (function-lambda-expression f) (label-value-line "Lambda Expression" - (function-lambda-expression f))))) + (function-lambda-expression f))))) (defun method-specializers-for-inspect (method) "Return a \"pretty\" list of the method's specializers. Normal @@ -133,9 +167,9 @@ the rest of the list is the method's specialiazers (as per method-specializers-for-inspect)." (append (list (swank-mop:generic-function-name - (swank-mop:method-generic-function method))) - (swank-mop:method-qualifiers method) - (method-specializers-for-inspect method))) + (swank-mop:method-generic-function method))) + (swank-mop:method-qualifiers method) + (method-specializers-for-inspect method))) (defmethod emacs-inspect ((object standard-object)) (let ((class (class-of object))) @@ -151,30 +185,31 @@ "Return true if SPECIALIZER1 is more specific than SPECIALIZER2." (let ((s1 specializer1) (s2 specializer2) ) (cond ((typep s1 'swank-mop:eql-specializer) - (not (typep s2 'swank-mop:eql-specializer))) - (t - (flet ((cpl (class) - (and (swank-mop:class-finalized-p class) - (swank-mop:class-precedence-list class)))) - (member s2 (cpl s1))))))) + (not (typep s2 'swank-mop:eql-specializer))) + (t + (flet ((cpl (class) + (and (swank-mop:class-finalized-p class) + (swank-mop:class-precedence-list class)))) + (member s2 (cpl s1))))))) (defun methods-by-applicability (gf) "Return methods ordered by most specific argument types. `method-specializer<' is used for sorting." - ;; FIXME: argument-precedence-order and qualifiers are ignored. + ;; FIXME: argument-precedence-order and qualifiers are ignored. (labels ((method< (meth1 meth2) (loop for s1 in (swank-mop:method-specializers meth1) for s2 in (swank-mop:method-specializers meth2) do (cond ((specializer< s2 s1) (return nil)) ((specializer< s1 s2) (return t)))))) - (stable-sort (copy-seq (swank-mop:generic-function-methods gf)) #'method<))) + (stable-sort (copy-seq (swank-mop:generic-function-methods gf)) + #'method<))) (defun abbrev-doc (doc &optional (maxlen 80)) "Return the first sentence of DOC, but not more than MAXLAN characters." (subseq doc 0 (min (1+ (or (position #\. doc) (1- maxlen))) - maxlen - (length doc)))) + maxlen + (length doc)))) (defstruct (inspector-checklist (:conc-name checklist.) (:constructor %make-checklist (buttons))) @@ -253,7 +288,8 @@ (effective-slots (ecase (ref grouping-kind) (:all sorted-slots) - (:inheritance (stable-sort-by-inheritance sorted-slots class sort-predicate))))) + (:inheritance (stable-sort-by-inheritance sorted-slots + class sort-predicate))))) `("--------------------" (:newline) " Group slots by inheritance " @@ -326,7 +362,8 @@ and collect (format nil "~A:" (class-name previous-home-class)) and collect '(:newline) and append (make-slot-listing checklist object class - (nreverse current-slots) direct-slots + (nreverse current-slots) + direct-slots longest-slot-name-length) and do (setf current-slots (list slot))) (and current-slots @@ -347,7 +384,8 @@ (loop for effective-slot :in effective-slots for direct-slot = (find (swank-mop:slot-definition-name effective-slot) - direct-slots :key #'swank-mop:slot-definition-name) + direct-slots + :key #'swank-mop:slot-definition-name) for slot-name = (inspector-princ (swank-mop:slot-definition-name effective-slot)) collect (make-checklist-button checklist) @@ -372,7 +410,8 @@ (let ((slot-name (swank-mop:slot-definition-name slot))) (loop for class in (reverse (swank-mop:class-precedence-list class)) thereis (and (member slot-name (swank-mop:class-direct-slots class) - :key #'swank-mop:slot-definition-name :test #'eq) + :key #'swank-mop:slot-definition-name + :test #'eq) class)))) (defun stable-sort-by-inheritance (slots class predicate) @@ -391,32 +430,32 @@ (eval (read-from-string value-string))))))) -(defmethod emacs-inspect ((gf standard-generic-function)) +(defmethod emacs-inspect ((gf standard-generic-function)) (flet ((lv (label value) (label-value-line label value))) - (append + (append (lv "Name" (swank-mop:generic-function-name gf)) (lv "Arguments" (swank-mop:generic-function-lambda-list gf)) (docstring-ispec "Documentation" gf t) (lv "Method class" (swank-mop:generic-function-method-class gf)) - (lv "Method combination" - (swank-mop:generic-function-method-combination gf)) + (lv "Method combination" + (swank-mop:generic-function-method-combination gf)) `("Methods: " (:newline)) (loop for method in (funcall *gf-method-getter* gf) append - `((:value ,method ,(inspector-princ - ;; drop the name of the GF - (cdr (method-for-inspect-value method)))) + `((:value ,method ,(inspector-princ + ;; drop the name of the GF + (cdr (method-for-inspect-value method)))) " " - (:action "[remove method]" + (:action "[remove method]" ,(let ((m method)) ; LOOP reassigns method - (lambda () + (lambda () (remove-method gf m)))) - (:newline))) + (:newline))) `((:newline)) (all-slots-for-inspector gf)))) (defmethod emacs-inspect ((method standard-method)) `(,@(if (swank-mop:method-generic-function method) - `("Method defined on the generic function " + `("Method defined on the generic function " (:value ,(swank-mop:method-generic-function method) ,(inspector-princ (swank-mop:generic-function-name @@ -427,7 +466,8 @@ "Lambda List: " (:value ,(swank-mop:method-lambda-list method)) (:newline) "Specializers: " (:value ,(swank-mop:method-specializers method) - ,(inspector-princ (method-specializers-for-inspect method))) + ,(inspector-princ + (method-specializers-for-inspect method))) (:newline) "Qualifiers: " (:value ,(swank-mop:method-qualifiers method)) (:newline) @@ -435,93 +475,115 @@ (:newline) ,@(all-slots-for-inspector method))) +(defun specializer-direct-methods (class) + (sort (copy-seq (swank-mop:specializer-direct-methods class)) + #'string< + :key + (lambda (x) + (symbol-name + (let ((name (swank-mop::generic-function-name + (swank-mop::method-generic-function x)))) + (if (symbolp name) + name + (second name))))))) + (defmethod emacs-inspect ((class standard-class)) - `("Name: " (:value ,(class-name class)) - (:newline) - "Super classes: " - ,@(common-seperated-spec (swank-mop:class-direct-superclasses class)) - (:newline) - "Direct Slots: " - ,@(common-seperated-spec - (swank-mop:class-direct-slots class) - (lambda (slot) - `(:value ,slot ,(inspector-princ (swank-mop:slot-definition-name slot))))) - (:newline) - "Effective Slots: " - ,@(if (swank-mop:class-finalized-p class) - (common-seperated-spec - (swank-mop:class-slots class) - (lambda (slot) - `(:value ,slot ,(inspector-princ - (swank-mop:slot-definition-name slot))))) - `("# " - (:action "[finalize]" - ,(lambda () (swank-mop:finalize-inheritance class))))) - (:newline) - ,@(let ((doc (documentation class t))) - (when doc - `("Documentation:" (:newline) ,(inspector-princ doc) (:newline)))) - "Sub classes: " - ,@(common-seperated-spec (swank-mop:class-direct-subclasses class) - (lambda (sub) - `(:value ,sub ,(inspector-princ (class-name sub))))) - (:newline) - "Precedence List: " - ,@(if (swank-mop:class-finalized-p class) - (common-seperated-spec (swank-mop:class-precedence-list class) - (lambda (class) - `(:value ,class ,(inspector-princ (class-name class))))) - '("#")) [574 lines skipped] From heller at common-lisp.net Sun May 6 08:39:12 2012 From: heller at common-lisp.net (CVS User heller) Date: Sun, 06 May 2012 01:39:12 -0700 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory tiger.common-lisp.net:/tmp/cvs-serv25290 Modified Files: ChangeLog slime.el Log Message: * slime.el (slime-pprint-eval-region): New command. No keybinding though. --- /project/slime/cvsroot/slime/ChangeLog 2012/05/04 11:16:40 1.2328 +++ /project/slime/cvsroot/slime/ChangeLog 2012/05/06 08:39:11 1.2329 @@ -1,3 +1,9 @@ +2012-05-06 Cyrus Harmon + Helmut Eller + + * slime.el (slime-pprint-eval-region): New command. No keybinding + though. + 2012-05-04 Nikodemus Siivola * swank-sbcl.lisp: Remove the SB-C::MERGE-TAIL-CALLS proclamation. --- /project/slime/cvsroot/slime/slime.el 2012/05/03 15:58:39 1.1404 +++ /project/slime/cvsroot/slime/slime.el 2012/05/06 08:39:11 1.1405 @@ -4297,6 +4297,13 @@ `(swank:interactive-eval-region ,(buffer-substring-no-properties start end)))) +(defun slime-pprint-eval-region (start end) + "Evaluate region; pprint the value in a buffer." + (interactive "r") + (slime-eval-describe + `(swank:pprint-eval + ,(buffer-substring-no-properties start end)))) + (defun slime-eval-buffer () "Evaluate the current buffer. The value is printed in the echo area." @@ -7149,6 +7156,7 @@ [ "Eval Last Expression" slime-eval-last-expression ,C ] [ "Eval And Pretty-Print" slime-pprint-eval-last-expression ,C ] [ "Eval Region" slime-eval-region ,C ] + [ "Eval Region And Pretty-Print" slime-pprint-eval-region ,C ] [ "Interactive Eval..." slime-interactive-eval ,C ] [ "Edit Lisp Value..." slime-edit-value ,C ] [ "Call Defun" slime-call-defun ,C ]) From heller at common-lisp.net Sun May 6 08:51:26 2012 From: heller at common-lisp.net (CVS User heller) Date: Sun, 06 May 2012 01:51:26 -0700 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory tiger.common-lisp.net:/tmp/cvs-serv30764 Modified Files: ChangeLog swank-rpc.lisp swank.lisp Log Message: * swank.lisp, swank-rpc.lisp: iso-8859-1 is not same as latin-1-unix. --- /project/slime/cvsroot/slime/ChangeLog 2012/05/06 08:39:11 1.2329 +++ /project/slime/cvsroot/slime/ChangeLog 2012/05/06 08:51:26 1.2330 @@ -1,3 +1,8 @@ +2012-05-06 Helmut Eller + + * swank.lisp, swank-rpc.lisp: iso-8859-1 is not same as + latin-1-unix. + 2012-05-06 Cyrus Harmon Helmut Eller --- /project/slime/cvsroot/slime/swank-rpc.lisp 2012/04/24 11:12:14 1.12 +++ /project/slime/cvsroot/slime/swank-rpc.lisp 2012/05/06 08:51:26 1.13 @@ -1,4 +1,4 @@ -;;; -*- indent-tabs-mode: nil; coding: iso-8859-1 -*- +;;; -*- indent-tabs-mode: nil; coding: latin-1-unix -*- ;;; ;;; swank-rpc.lisp -- Pass remote calls and responses between lisp systems. ;;; --- /project/slime/cvsroot/slime/swank.lisp 2012/05/03 07:44:54 1.789 +++ /project/slime/cvsroot/slime/swank.lisp 2012/05/06 08:51:26 1.790 @@ -1,10 +1,8 @@ -;;; -*- outline-regexp: ";;;;;*"; indent-tabs-mode: nil; coding: iso-8859-1 -*- +;;;; swank.lisp --- Server for SLIME commands. ;;; ;;; This code has been placed in the Public Domain. All warranties ;;; are disclaimed. ;;; -;;;; swank.lisp -;;; ;;; This file defines the "Swank" TCP server for Emacs to talk to. The ;;; code in this file is purely portable Common Lisp. We do require a ;;; smattering of non-portable functions in order to write the server, @@ -3688,4 +3686,10 @@ (defun init () (run-hook *after-init-hook*)) +;; Local Variables: +;; coding: latin-1-unix +;; indent-tabs-mode: nil +;; outline-regexp: ";;;;;*" +;; End: + ;;; swank.lisp ends here From heller at common-lisp.net Sun May 6 15:40:04 2012 From: heller at common-lisp.net (CVS User heller) Date: Sun, 06 May 2012 08:40:04 -0700 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory tiger.common-lisp.net:/tmp/cvs-serv24544 Modified Files: ChangeLog swank-backend.lisp Log Message: * swank-backend.lisp (with-struct): Undo damage. * swank-sbcl.lisp (with-definition-source): New macro. --- /project/slime/cvsroot/slime/ChangeLog 2012/05/06 08:51:26 1.2330 +++ /project/slime/cvsroot/slime/ChangeLog 2012/05/06 15:40:04 1.2331 @@ -1,5 +1,10 @@ 2012-05-06 Helmut Eller + * swank-backend.lisp (with-struct): Undo damage. + * swank-sbcl.lisp (with-definition-source): New macro. + +2012-05-06 Helmut Eller + * swank.lisp, swank-rpc.lisp: iso-8859-1 is not same as latin-1-unix. --- /project/slime/cvsroot/slime/swank-backend.lisp 2012/05/03 14:12:22 1.218 +++ /project/slime/cvsroot/slime/swank-backend.lisp 2012/05/06 15:40:04 1.219 @@ -1,4 +1,4 @@ -;;; -*- Mode: lisp; indent-tabs-mode: nil; outline-regexp: ";;;;;*" -*- +;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;;*" -*- ;;; ;;; slime-backend.lisp --- SLIME backend interface. ;;; @@ -239,12 +239,12 @@ (defmacro with-struct ((conc-name &rest names) obj &body body) "Like with-slots but works only for structs." + (check-type conc-name symbol) (flet ((reader (slot) - ;; Use read-from-string instead of intern so that - ;; conc-name can be a string such as ext:struct- and not - ;; cause errors and not force interning ext::struct- - (read-from-string - (concatenate 'string (string conc-name) (string slot))))) + (intern (concatenate 'string + (symbol-name conc-name) + (symbol-name slot)) + (symbol-package conc-name)))) (let ((tmp (gensym "OO-"))) ` (let ((,tmp ,obj)) (symbol-macrolet From heller at common-lisp.net Sun May 6 16:16:02 2012 From: heller at common-lisp.net (CVS User heller) Date: Sun, 06 May 2012 09:16:02 -0700 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory tiger.common-lisp.net:/tmp/cvs-serv4787 Modified Files: ChangeLog swank-allegro.lisp Log Message: * swank-allegro.lisp (string-to-utf8): Set the :null-terminate argument of excl:string-to-octets to nil. --- /project/slime/cvsroot/slime/ChangeLog 2012/05/06 15:40:04 1.2331 +++ /project/slime/cvsroot/slime/ChangeLog 2012/05/06 16:16:02 1.2332 @@ -1,5 +1,10 @@ 2012-05-06 Helmut Eller + * swank-allegro.lisp (string-to-utf8): Set the :null-terminate + argument of excl:string-to-octets to nil. + +2012-05-06 Helmut Eller + * swank-backend.lisp (with-struct): Undo damage. * swank-sbcl.lisp (with-definition-source): New macro. --- /project/slime/cvsroot/slime/swank-allegro.lisp 2012/04/07 10:23:38 1.152 +++ /project/slime/cvsroot/slime/swank-allegro.lisp 2012/05/06 16:16:02 1.153 @@ -35,7 +35,8 @@ t)) (defimplementation string-to-utf8 (s) - (excl:string-to-octets s :external-format utf8-ef)) + (excl:string-to-octets s :external-format utf8-ef + :null-terminate nil)) (defimplementation utf8-to-string (u) (excl:octets-to-string u :external-format utf8-ef)) From heller at common-lisp.net Sun May 6 16:16:13 2012 From: heller at common-lisp.net (CVS User heller) Date: Sun, 06 May 2012 09:16:13 -0700 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory tiger.common-lisp.net:/tmp/cvs-serv4882 Modified Files: ChangeLog swank-sbcl.lisp Log Message: * swank-sbcl.lisp (with-definition-source): Forgot to commit this one. --- /project/slime/cvsroot/slime/ChangeLog 2012/05/06 16:16:02 1.2332 +++ /project/slime/cvsroot/slime/ChangeLog 2012/05/06 16:16:13 1.2333 @@ -1,5 +1,8 @@ 2012-05-06 Helmut Eller + * swank-sbcl.lisp (with-definition-source): Forgot to commit this + one. + * swank-allegro.lisp (string-to-utf8): Set the :null-terminate argument of excl:string-to-octets to nil. --- /project/slime/cvsroot/slime/swank-sbcl.lisp 2012/05/04 11:16:40 1.315 +++ /project/slime/cvsroot/slime/swank-sbcl.lisp 2012/05/06 16:16:13 1.316 @@ -1,4 +1,4 @@ -;;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- +;;;;; -*- indent-tabs-mode: nil -*- ;;; ;;; swank-sbcl.lisp --- SLIME backend for SBCL. ;;; @@ -786,11 +786,28 @@ (general-type-of obj) (to-string obj)))))) +(defmacro with-definition-source ((&rest names) obj &body body) + "Like with-slots but works only for structs." + (flet ((reader (slot) + ;; Use read-from-string instead of intern so that + ;; conc-name can be a string such as ext:struct- and not + ;; cause errors and not force interning ext::struct- + (read-from-string + (concatenate 'string "sb-introspect:definition-source-" + (string slot))))) + (let ((tmp (gensym "OO-"))) + ` (let ((,tmp ,obj)) + (symbol-macrolet + ,(loop for name in names collect + (typecase name + (symbol `(,name (,(reader name) ,tmp))) + (cons `(,(first name) (,(reader (second name)) ,tmp))) + (t (error "Malformed syntax in WITH-STRUCT: ~A" name)))) + , at body))))) (defun categorize-definition-source (definition-source) - (with-struct ("sb-introspect:definition-source-" - pathname form-path character-offset plist) - definition-source + (with-definition-source (pathname form-path character-offset plist) + definition-source (let ((file-p (and pathname (probe-file pathname) (or form-path character-offset)))) (cond ((and (getf plist :emacs-buffer) file-p) :buffer-and-file) @@ -800,9 +817,7 @@ (t :invalid))))) (defun definition-source-buffer-location (definition-source) - (with-struct ("sb-introspect:definition-source-" - form-path character-offset plist) - definition-source + (with-definition-source (form-path character-offset plist) definition-source (destructuring-bind (&key emacs-buffer emacs-position emacs-directory emacs-string &allow-other-keys) plist @@ -823,9 +838,8 @@ (min end (+ start *source-snippet-size*)))))))))) (defun definition-source-file-location (definition-source) - (with-struct ("sb-introspect:definition-source-" - pathname form-path character-offset plist - file-write-date) definition-source + (with-definition-source (pathname form-path character-offset plist + file-write-date) definition-source (let* ((namestring (namestring (translate-logical-pathname pathname))) (pos (if form-path (source-file-position namestring file-write-date @@ -848,10 +862,9 @@ (location-hints buffer)))) (defun definition-source-for-emacs (definition-source type name) - (with-struct ("sb-introspect:definition-source-" - pathname form-path character-offset plist - file-write-date) - definition-source + (with-definition-source (pathname form-path character-offset plist + file-write-date) + definition-source (ecase (categorize-definition-source definition-source) (:buffer-and-file (definition-source-buffer-and-file-location definition-source)) @@ -1623,7 +1636,7 @@ #+sb-lutex (defun condition-timed-wait (waitqueue mutex timeout) (declare (ignore timeout)) - (sb-thread:condition-wait waitqueue mutex)) + (sb-thread:condition-wait waitqueue mutex )) (defimplementation receive-if (test &optional timeout) (let* ((mbox (mailbox (current-thread))) From heller at common-lisp.net Sun May 6 16:16:24 2012 From: heller at common-lisp.net (CVS User heller) Date: Sun, 06 May 2012 09:16:24 -0700 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory tiger.common-lisp.net:/tmp/cvs-serv4990 Modified Files: ChangeLog swank-sbcl.lisp Log Message: * swank-sbcl.lisp (condition-timed-wait): Use the :timeout argument of sb-thread:condition-wait if supported. --- /project/slime/cvsroot/slime/ChangeLog 2012/05/06 16:16:13 1.2333 +++ /project/slime/cvsroot/slime/ChangeLog 2012/05/06 16:16:24 1.2334 @@ -1,5 +1,10 @@ 2012-05-06 Helmut Eller + * swank-sbcl.lisp (condition-timed-wait): Use the :timeout + argument of sb-thread:condition-wait if supported. + +2012-05-06 Helmut Eller + * swank-sbcl.lisp (with-definition-source): Forgot to commit this one. --- /project/slime/cvsroot/slime/swank-sbcl.lisp 2012/05/06 16:16:13 1.316 +++ /project/slime/cvsroot/slime/swank-sbcl.lisp 2012/05/06 16:16:24 1.317 @@ -1623,21 +1623,26 @@ (setf (mailbox.queue mbox) (nconc (mailbox.queue mbox) (list message))) (sb-thread:condition-broadcast (mailbox.waitqueue mbox))))) - #-sb-lutex - (defun condition-timed-wait (waitqueue mutex timeout) - (handler-case - (let ((*break-on-signals* nil)) - (sb-sys:with-deadline (:seconds timeout :override t) - (sb-thread:condition-wait waitqueue mutex) t)) - (sb-ext:timeout () - nil))) - ;; FIXME: with-timeout doesn't work properly on Darwin - #+sb-lutex (defun condition-timed-wait (waitqueue mutex timeout) - (declare (ignore timeout)) - (sb-thread:condition-wait waitqueue mutex )) - + (macrolet ((foo () + (cond ((> (length (sb-introspect:function-arglist + #'sb-thread:condition-wait)) + 2) + '(sb-thread:condition-wait waitqueue mutex + :timeout timeout)) + ((member :sb-lutex *features*) ; Darwin + '(sb-thread:condition-wait waitqueue mutex)) + (t + '(handler-case + (let ((*break-on-signals* nil)) + (sb-sys:with-deadline (:seconds timeout + :override t) + (sb-thread:condition-wait waitqueue mutex) t)) + (sb-ext:timeout () + nil)))))) + (foo))) + (defimplementation receive-if (test &optional timeout) (let* ((mbox (mailbox (current-thread))) (mutex (mailbox.mutex mbox)) From heller at common-lisp.net Sun May 6 21:19:48 2012 From: heller at common-lisp.net (CVS User heller) Date: Sun, 06 May 2012 14:19:48 -0700 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory tiger.common-lisp.net:/tmp/cvs-serv19905 Modified Files: ChangeLog swank-sbcl.lisp Log Message: * swank-sbcl.lisp (condition-timed-wait): Undo previous change. The :timeout arg doesn't seem ready for production use. --- /project/slime/cvsroot/slime/ChangeLog 2012/05/06 16:16:24 1.2334 +++ /project/slime/cvsroot/slime/ChangeLog 2012/05/06 21:19:48 1.2335 @@ -1,8 +1,14 @@ 2012-05-06 Helmut Eller + * swank-sbcl.lisp (condition-timed-wait): Undo previous change. + The :timeout arg doesn't seem ready for production use. + +2012-05-06 Helmut Eller + * swank-sbcl.lisp (condition-timed-wait): Use the :timeout argument of sb-thread:condition-wait if supported. + 2012-05-06 Helmut Eller * swank-sbcl.lisp (with-definition-source): Forgot to commit this --- /project/slime/cvsroot/slime/swank-sbcl.lisp 2012/05/06 16:16:24 1.317 +++ /project/slime/cvsroot/slime/swank-sbcl.lisp 2012/05/06 21:19:48 1.318 @@ -1624,11 +1624,14 @@ (nconc (mailbox.queue mbox) (list message))) (sb-thread:condition-broadcast (mailbox.waitqueue mbox))))) + (defun condition-timed-wait (waitqueue mutex timeout) (macrolet ((foo () - (cond ((> (length (sb-introspect:function-arglist - #'sb-thread:condition-wait)) - 2) + (cond ((and (> (length (sb-introspect:function-lambda-list + #'sb-thread:condition-wait)) + 2) + nil ; FIXME: :timeout doesn't work. Why? + ) '(sb-thread:condition-wait waitqueue mutex :timeout timeout)) ((member :sb-lutex *features*) ; Darwin From heller at common-lisp.net Mon May 7 06:10:50 2012 From: heller at common-lisp.net (CVS User heller) Date: Sun, 06 May 2012 23:10:50 -0700 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory tiger.common-lisp.net:/tmp/cvs-serv22388 Modified Files: ChangeLog slime.el Log Message: Ignore linebreaks for the macroexpand test. SBCL should now also pass it. * slime.el (slime-test-macroexpansion=): New function. ([test] macroexpand): Use it. --- /project/slime/cvsroot/slime/ChangeLog 2012/05/06 21:19:48 1.2335 +++ /project/slime/cvsroot/slime/ChangeLog 2012/05/07 06:10:50 1.2336 @@ -1,3 +1,11 @@ +2012-05-07 Helmut Eller + + Ignore linebreaks for the macroexpand test. + SBCL should now also pass it. + + * slime.el (slime-test-macroexpansion=): New function. + ([test] macroexpand): Use it. + 2012-05-06 Helmut Eller * swank-sbcl.lisp (condition-timed-wait): Undo previous change. --- /project/slime/cvsroot/slime/slime.el 2012/05/06 08:39:11 1.1405 +++ /project/slime/cvsroot/slime/slime.el 2012/05/07 06:10:50 1.1406 @@ -8293,7 +8293,7 @@ (undo-boundary) (call-interactively name)) -(def-slime-test macroexpand +(def-slime-test macroexpand (macro-defs bufcontent expansion1 search-str expansion2) "foo" '((("(defmacro qwertz (&body body) `(list :qwertz ',body))" @@ -8306,34 +8306,42 @@ (setq slime-buffer-package ":swank") (with-temp-buffer (lisp-mode) - (dolist (def macro-defs) + (dolist (def macro-defs) (slime-compile-string def 0) (slime-sync-to-top-level 5)) (insert bufcontent) (goto-char (point-min)) (slime-execute-as-command 'slime-macroexpand-1) - (slime-wait-condition "Macroexpansion buffer visible" - (lambda () - (slime-buffer-visible-p + (slime-wait-condition "Macroexpansion buffer visible" + (lambda () + (slime-buffer-visible-p (slime-buffer-name :macroexpansion))) 5) (with-current-buffer (get-buffer (slime-buffer-name :macroexpansion)) (slime-test-expect "Initial macroexpansion is correct" - expansion1 - (downcase (buffer-string))) + expansion1 + (downcase (buffer-string)) + #'slime-test-macroexpansion=) (search-forward search-str) (backward-up-list) (slime-execute-as-command 'slime-macroexpand-1-inplace) (slime-sync-to-top-level 3) (slime-test-expect "In-place macroexpansion is correct" - expansion2 - (downcase (buffer-string))) + expansion2 + (downcase (buffer-string)) + #'slime-test-macroexpansion=) (slime-execute-as-command 'slime-macroexpand-undo) (slime-test-expect "Expansion after undo is correct" expansion1 - (downcase (buffer-string))))) + (downcase (buffer-string)) + #'slime-test-macroexpansion=))) (setq slime-buffer-package ":cl-user")) +(defun slime-test-macroexpansion= (string1 string2) + (let ((string1 (replace-regexp-in-string " *\n *" " " string1)) + (string2 (replace-regexp-in-string " *\n *" " " string2))) + (equal string1 string2))) + (def-slime-test indentation (buffer-content point-markers) "Check indentation update to work correctly." '((" From heller at common-lisp.net Fri May 11 06:52:06 2012 From: heller at common-lisp.net (CVS User heller) Date: Thu, 10 May 2012 23:52:06 -0700 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory tiger.common-lisp.net:/tmp/cvs-serv27405 Modified Files: ChangeLog swank-backend.lisp swank-sbcl.lisp Log Message: * swank-backend.lisp (call-with-io-timeout): Not used. Deleted. * swank-sbcl.lisp (call-with-io-timeout): Deleted. --- /project/slime/cvsroot/slime/ChangeLog 2012/05/07 06:10:50 1.2336 +++ /project/slime/cvsroot/slime/ChangeLog 2012/05/11 06:52:05 1.2337 @@ -1,3 +1,8 @@ +2012-05-11 Helmut Eller + + * swank-backend.lisp (call-with-io-timeout): Not used. Deleted. + * swank-sbcl.lisp (call-with-io-timeout): Deleted. + 2012-05-07 Helmut Eller Ignore linebreaks for the macroexpand test. --- /project/slime/cvsroot/slime/swank-backend.lisp 2012/05/06 15:40:04 1.219 +++ /project/slime/cvsroot/slime/swank-backend.lisp 2012/05/11 06:52:05 1.220 @@ -1425,12 +1425,6 @@ (type function function)) (funcall function)) -;; Same here: don't use this outside of swank-gray.lisp. -(definterface call-with-io-timeout (function &key seconds) - "Calls function with the specified IO timeout." - (declare (ignore seconds)) - (funcall function)) - ;;;; Weak datastructures --- /project/slime/cvsroot/slime/swank-sbcl.lisp 2012/05/06 21:19:48 1.318 +++ /project/slime/cvsroot/slime/swank-sbcl.lisp 2012/05/11 06:52:05 1.319 @@ -1838,13 +1838,6 @@ :dual-channel-p t :external-format external-format)) -(defimplementation call-with-io-timeout (function &key seconds) - (handler-case - (sb-sys:with-deadline (:seconds seconds) - (funcall function)) - (sb-sys:deadline-timeout () - nil))) - #-win32 (defimplementation background-save-image (filename &key restart-function completion-function) From heller at common-lisp.net Fri May 11 06:52:18 2012 From: heller at common-lisp.net (CVS User heller) Date: Thu, 10 May 2012 23:52:18 -0700 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory tiger.common-lisp.net:/tmp/cvs-serv27481 Modified Files: ChangeLog swank-sbcl.lisp Log Message: * swank-sbcl.lisp (stream-force-output): Don't use with-deadline. Grab the world-lock instead. (condition-timed-wait): Use the :timeout argument. --- /project/slime/cvsroot/slime/ChangeLog 2012/05/11 06:52:05 1.2337 +++ /project/slime/cvsroot/slime/ChangeLog 2012/05/11 06:52:18 1.2338 @@ -1,5 +1,11 @@ 2012-05-11 Helmut Eller + * swank-sbcl.lisp (stream-force-output): Don't use + with-deadline. Grab the world-lock instead. + (condition-timed-wait): Use the :timeout argument for real. + +2012-05-11 Helmut Eller + * swank-backend.lisp (call-with-io-timeout): Not used. Deleted. * swank-sbcl.lisp (call-with-io-timeout): Deleted. --- /project/slime/cvsroot/slime/swank-sbcl.lisp 2012/05/11 06:52:05 1.319 +++ /project/slime/cvsroot/slime/swank-sbcl.lisp 2012/05/11 06:52:18 1.320 @@ -1627,11 +1627,9 @@ (defun condition-timed-wait (waitqueue mutex timeout) (macrolet ((foo () - (cond ((and (> (length (sb-introspect:function-lambda-list - #'sb-thread:condition-wait)) - 2) - nil ; FIXME: :timeout doesn't work. Why? - ) + (cond ((> (length (sb-introspect:function-lambda-list + #'sb-thread:condition-wait)) + 2) '(sb-thread:condition-wait waitqueue mutex :timeout timeout)) ((member :sb-lutex *features*) ; Darwin @@ -1695,12 +1693,8 @@ (defclass slime-output-stream (fundamental-character-output-stream) ()) (defmethod stream-force-output :around ((stream slime-output-stream)) - (handler-case - (sb-sys:with-deadline (:seconds 0.1) - (call-next-method)) - (sb-sys:deadline-timeout () - nil))) - + (sb-thread:with-mutex (sb-c::**world-lock** :wait-p nil) + (call-next-method))) ) (defimplementation quit-lisp () From heller at common-lisp.net Fri May 11 18:08:45 2012 From: heller at common-lisp.net (CVS User heller) Date: Fri, 11 May 2012 11:08:45 -0700 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory tiger.common-lisp.net:/tmp/cvs-serv24832 Modified Files: ChangeLog slime.el swank-sbcl.lisp Log Message: * swank-sbcl.lisp (stream-force-output): Use with-world-lock i.e. with-recursive-lock instead of with-mutex. * slime.el (sbcl-world-lock): New test. --- /project/slime/cvsroot/slime/ChangeLog 2012/05/11 06:52:18 1.2338 +++ /project/slime/cvsroot/slime/ChangeLog 2012/05/11 18:08:44 1.2339 @@ -1,5 +1,11 @@ 2012-05-11 Helmut Eller + * swank-sbcl.lisp (stream-force-output): Use with-world-lock + i.e. with-recursive-lock instead of with-mutex. + * slime.el (sbcl-world-lock): New test. + +2012-05-11 Helmut Eller + * swank-sbcl.lisp (stream-force-output): Don't use with-deadline. Grab the world-lock instead. (condition-timed-wait): Use the :timeout argument for real. --- /project/slime/cvsroot/slime/slime.el 2012/05/07 06:10:50 1.1406 +++ /project/slime/cvsroot/slime/slime.el 2012/05/11 18:08:45 1.1407 @@ -8523,7 +8523,18 @@ (slime-check "Debugger closed" (slime-sldb-level= nil))) (slime-sync-to-top-level 8)) -;;; FIXME: reconnection is broken since the recent io-redirection changes. +(def-slime-test sbcl-world-lock + (n delay) + "Print something inside WITH-COMPILATION-UNIT. +In SBCL, WITH-COMPILATION-UNIT grabs the world lock and this tests that +we can grab it recursivly." + '((10 0.03)) + (slime-test-expect "no error" + t + (slime-eval `(cl:with-compilation-unit () + (swank:flow-control-test ,n ,delay) + t)))) + (def-slime-test (disconnect-one-connection (:style :spawn)) () "`slime-disconnect' should disconnect only the current connection" '(()) --- /project/slime/cvsroot/slime/swank-sbcl.lisp 2012/05/11 06:52:18 1.320 +++ /project/slime/cvsroot/slime/swank-sbcl.lisp 2012/05/11 18:08:45 1.321 @@ -1693,7 +1693,7 @@ (defclass slime-output-stream (fundamental-character-output-stream) ()) (defmethod stream-force-output :around ((stream slime-output-stream)) - (sb-thread:with-mutex (sb-c::**world-lock** :wait-p nil) + (sb-kernel:with-world-lock () (call-next-method))) ) From heller at common-lisp.net Sat May 12 06:34:47 2012 From: heller at common-lisp.net (CVS User heller) Date: Fri, 11 May 2012 23:34:47 -0700 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory tiger.common-lisp.net:/tmp/cvs-serv5147 Modified Files: ChangeLog swank-sbcl.lisp Log Message: * swank-sbcl.lisp (stream-force-output): Undo last few changes. --- /project/slime/cvsroot/slime/ChangeLog 2012/05/11 18:08:44 1.2339 +++ /project/slime/cvsroot/slime/ChangeLog 2012/05/12 06:34:47 1.2340 @@ -1,3 +1,7 @@ +2012-05-12 Helmut Eller + + * swank-sbcl.lisp (stream-force-output): Undo last few changes. + 2012-05-11 Helmut Eller * swank-sbcl.lisp (stream-force-output): Use with-world-lock --- /project/slime/cvsroot/slime/swank-sbcl.lisp 2012/05/11 18:08:45 1.321 +++ /project/slime/cvsroot/slime/swank-sbcl.lisp 2012/05/12 06:34:47 1.322 @@ -1627,12 +1627,7 @@ (defun condition-timed-wait (waitqueue mutex timeout) (macrolet ((foo () - (cond ((> (length (sb-introspect:function-lambda-list - #'sb-thread:condition-wait)) - 2) - '(sb-thread:condition-wait waitqueue mutex - :timeout timeout)) - ((member :sb-lutex *features*) ; Darwin + (cond ((member :sb-lutex *features*) ; Darwin '(sb-thread:condition-wait waitqueue mutex)) (t '(handler-case @@ -1693,8 +1688,11 @@ (defclass slime-output-stream (fundamental-character-output-stream) ()) (defmethod stream-force-output :around ((stream slime-output-stream)) - (sb-kernel:with-world-lock () - (call-next-method))) + (handler-case + (sb-sys:with-deadline (:seconds 0.1) + (call-next-method)) + (sb-sys:deadline-timeout () + nil))) ) (defimplementation quit-lisp () From heller at common-lisp.net Mon May 21 08:08:07 2012 From: heller at common-lisp.net (CVS User heller) Date: Mon, 21 May 2012 01:08:07 -0700 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory tiger.common-lisp.net:/tmp/cvs-serv3762 Modified Files: ChangeLog slime.el Log Message: Reduce dependecy on pre-defined faces. * slime.el (slime-apropos-symbol, slime-apropos-label): New faces. (slime-print-apropos): Use them. Reported by: Daimrod --- /project/slime/cvsroot/slime/ChangeLog 2012/05/12 06:34:47 1.2340 +++ /project/slime/cvsroot/slime/ChangeLog 2012/05/21 08:08:07 1.2341 @@ -1,3 +1,12 @@ +2012-05-21 Helmut Eller + + Reduce dependecy on pre-defined faces. + + * slime.el (slime-apropos-symbol, slime-apropos-label): New faces. + (slime-print-apropos): Use them. + + Reported by: Daimrod + 2012-05-12 Helmut Eller * swank-sbcl.lisp (stream-force-output): Undo last few changes. --- /project/slime/cvsroot/slime/slime.el 2012/05/11 18:08:45 1.1407 +++ /project/slime/cvsroot/slime/slime.el 2012/05/21 08:08:07 1.1408 @@ -4561,6 +4561,16 @@ (error "No symbol given")) (slime-eval-describe `(swank:describe-function ,symbol-name))) +(defface slime-apropos-symbol + '((t (:inherit bold))) + "Face for the symbol name in Apropos output." + :group 'slime) + +(defface slime-apropos-label + '((t (:inherit italic))) + "Face for label (`Function', `Variable' ...) in Apropos output." + :group 'slime) + (defun slime-apropos-summary (string case-sensitive-p package only-external-p) "Return a short description for the performed apropos search." (concat (if case-sensitive-p "Case-sensitive " "") @@ -4621,7 +4631,7 @@ (dolist (plist plists) (let ((designator (plist-get plist :designator))) (assert designator) - (slime-insert-propertized `(face ,apropos-symbol-face) designator)) + (slime-insert-propertized `(face slime-apropos-symbol) designator)) (terpri) (loop for (prop namespace) in '((:variable "Variable") @@ -4642,7 +4652,7 @@ (start (point))) (when value (princ " ") - (slime-insert-propertized `(face ,apropos-label-face) namespace) + (slime-insert-propertized `(face slime-apropos-label) namespace) (princ ": ") (princ (etypecase value (string value) From crhodes at common-lisp.net Wed May 23 20:55:43 2012 From: crhodes at common-lisp.net (CVS User crhodes) Date: Wed, 23 May 2012 13:55:43 -0700 Subject: [slime-cvs] CVS slime/contrib Message-ID: Update of /project/slime/cvsroot/slime/contrib In directory tiger.common-lisp.net:/tmp/cvs-serv29013/contrib Modified Files: ChangeLog swank-media.lisp Log Message: Add provide in swank-media. Noticed by Cyrus Harmon. --- /project/slime/cvsroot/slime/contrib/ChangeLog 2012/05/04 14:34:30 1.547 +++ /project/slime/cvsroot/slime/contrib/ChangeLog 2012/05/23 20:55:43 1.548 @@ -1,3 +1,7 @@ +2012-05-23 Christophe Rhodes + + * swank-media.lisp: add provide. + 2012-05-04 Stas Boukarev * swank-fancy-inspector.lisp (emacs-inspect symbol): On SBCL, --- /project/slime/cvsroot/slime/contrib/swank-media.lisp 2010/09/16 13:24:20 1.1 +++ /project/slime/cvsroot/slime/contrib/swank-media.lisp 2012/05/23 20:55:43 1.2 @@ -21,3 +21,5 @@ ;; can only be defined if their specializers already exist; in R's S3 ;; object system, methods are ordinary functions with a special naming ;; convention) + +(provide :swank-media) From sboukarev at common-lisp.net Fri May 25 01:25:06 2012 From: sboukarev at common-lisp.net (CVS User sboukarev) Date: Thu, 24 May 2012 18:25:06 -0700 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory tiger.common-lisp.net:/tmp/cvs-serv16116 Modified Files: ChangeLog slime.el Log Message: * slime.el (slime-oneliner): Use minibuffer width instead of the width of the current frame, minibuffer can be in a separate frame with a different width. Patch by Greg Pfeil (lp#1004252). --- /project/slime/cvsroot/slime/ChangeLog 2012/05/21 08:08:07 1.2341 +++ /project/slime/cvsroot/slime/ChangeLog 2012/05/25 01:25:05 1.2342 @@ -1,3 +1,10 @@ +2012-05-25 Stas Boukarev + + * slime.el (slime-oneliner): Use minibuffer width instead of the + width of the current frame, minibuffer can be in a separate frame + with a different width. + Patch by Greg Pfeil (lp#1004252). + 2012-05-21 Helmut Eller Reduce dependecy on pre-defined faces. --- /project/slime/cvsroot/slime/slime.el 2012/05/21 08:08:07 1.1408 +++ /project/slime/cvsroot/slime/slime.el 2012/05/25 01:25:06 1.1409 @@ -786,7 +786,7 @@ "Return STRING truncated to fit in a single echo-area line." (substring string 0 (min (length string) (or (position ?\n string) most-positive-fixnum) - (1- (frame-width))))) + (1- (window-width (minibuffer-window)))))) ;; Interface (defun slime-set-truncate-lines ()