[slime-cvs] CVS update: slime/slime.el

Helmut Eller heller at common-lisp.net
Sat Nov 8 00:32:50 UTC 2003


Update of /project/slime/cvsroot/slime
In directory common-lisp.net:/tmp/cvs-serv16253

Modified Files:
	slime.el 
Log Message:
(slime-face-attributes, slime-face-font-name): Copy the font too.

(slime-buffer-package): Try to find be the package name before
resorting to slime-buffer-package.  Return nil and not "CL-USER" if
the package cannot be determined.

(slime-goto-location): Insert notes with a source path but no
filename or buffername at point.  This can happen for warnings during
macro expansion. (The macro expander is a interpreted function and
does not have a filename or buffername.)

(slime-show-note): Display 2 double quotes "" in the for zero length
messages.  SERIES tends to signal warnings with zero length messages.

slime-complete-saved-window-configuration: Store the window config in
a buffer local variable.

(slime-print-apropos): Add support for alien types.

(slime-select-function): Bind pop-up-windows to nil. (Doesn't seem to
work, though.)

(slime-selector): Switch to the minibuffer for reading the event.

(slime-display-buffer-region): Enlarge the window if it is too small.

(slime-find-buffer-package): Initialize command hooks.

Date: Fri Nov  7 19:32:50 2003
Author: heller

Index: slime/slime.el
diff -u slime/slime.el:1.81 slime/slime.el:1.82
--- slime/slime.el:1.81	Thu Nov  6 04:15:36 2003
+++ slime/slime.el	Fri Nov  7 19:32:50 2003
@@ -173,12 +173,17 @@
   (cond ((featurep 'xemacs) (custom-face-bold face))
         (t (face-bold-p face))))
 
+(defun slime-face-font-name (face)
+  (cond ((featurep 'xemacs) (face-font-name face))
+        (t (face-font face))))
+
 (defun slime-face-attributes (face)
   (list :foreground (slime-color-name (face-foreground face))
         :background (slime-color-name (face-background face))
         :underline (face-underline-p face)
-        :bold (slime-face-bold-p face)))
-        
+        :bold (slime-face-bold-p face)
+        :font (slime-face-font-name face)))
+
 (defface slime-highlight-face
   `((t ,(slime-face-attributes 'highlight)))
   "Face for compiler notes while selected."
@@ -496,16 +501,22 @@
 
 (defun slime-buffer-package (&optional dont-cache)
   "Return the Common Lisp package associated with the current buffer.
-This is heuristically determined by a text search of the buffer.
-The result is cached and returned on subsequent calls unless
-DONT-CACHE is non-nil.
+This is heuristically determined by a text search of the buffer.  The
+result is stored in `slime-buffer-package' unless DONT-CACHE is
+non-nil.  If the current package cannot be determined fall back to
+slime-buffer-package (which may also be nil).
 
 The REPL buffer is a special case: it's package is `slime-lisp-package'."
   (or (and (eq major-mode 'slime-repl-mode) slime-lisp-package)
-      (and (not dont-cache) slime-buffer-package)
-      (and (setq slime-buffer-package (slime-find-buffer-package))
-           (progn (force-mode-line-update) slime-buffer-package))
-      "CL-USER"))
+      (let ((string (slime-find-buffer-package)))
+        (cond (string
+               (cond (dont-cache)
+                     ((equal string slime-buffer-package))
+                     (t 
+                      (setq slime-buffer-package string)
+                      (force-mode-line-update)))
+               string)
+              (t slime-buffer-package)))))
 
 (defun slime-find-buffer-package ()
   "Figure out which Lisp package the current buffer is associated with."
@@ -1362,6 +1373,7 @@
   (setq mode-name "REPL")
   (set (make-local-variable 'scroll-conservatively) 20)
   (set (make-local-variable 'scroll-margin) 0)
+  (slime-setup-command-hooks)
   (run-hooks 'slime-repl-mode-hook))
 
 (defun slime-repl-insert-prompt ()
@@ -1551,14 +1563,12 @@
   "Mode the read input from Emacs
 \\{slime-repl-read-mode-map}"
   nil
-  nil
+  "[read]"
   '(("\C-m" . slime-repl-return)
     ("\C-c\C-b" . slime-repl-read-break)
     ("\C-c\C-c" . slime-repl-read-break)
     ("\C-c\C-g" . slime-repl-read-break)))
 
-(add-to-list 'minor-mode-alist '(slime-repl-read-mode "[read]"))
-
 (defun slime-repl-read-string ()
   (slime-switch-to-output-buffer)
   (set-marker slime-repl-input-start-mark (point) (current-buffer))
@@ -1826,7 +1836,10 @@
 	   (re-search-forward (format "^(def\\w+\\s +%s\\s +"
 				      (plist-get note :function-name)))
 	   (beginning-of-line)))
-	((not (plist-get note :source-path))
+	((or (not (plist-get note :source-path))
+             (and (not (plist-get note :filename))
+                  (not (plist-get note :buffername))
+                  (plist-get note :source-path)))
 	 ;; no source-path available. hmm... move the the first sexp
 	 (cond ((plist-get note :buffername)
 		(goto-char (plist-get note :buffer-offset)))
@@ -1933,7 +1946,8 @@
 (defun slime-show-note (overlay)
   "Present the details of a compiler note to the user."
   (slime-temporarily-highlight-note overlay)
-  (slime-message "%s" (get-char-property (point) 'help-echo)))
+  (let ((message (get-char-property (point) 'help-echo)))
+    (slime-message "%s" (if (zerop (length message)) "\"\"" message))))
 
 (defun slime-temporarily-highlight-note (overlay)
   "Temporarily highlight a compiler note's overlay.
@@ -2007,8 +2021,7 @@
   (slime-eval-async 
    `(swank:arglist-string ,symbol-name)
    (slime-buffer-package)
-   (lexical-let ((show-fn show-fn)
-                 (symbol-name symbol-name))
+   (with-lexical-bindings (show-fn symbol-name)
      (lambda (arglist)
        (if show-fn
            (funcall show-fn arglist)
@@ -2103,24 +2116,51 @@
 
 ;;; Completion
 
+(defvar slime-completions-buffer-name "*Completions*")
+
 (defvar slime-complete-saved-window-configuration nil
-  "Window configuration before we show the *Completions* buffer.")
+  "Window configuration before we show the *Completions* buffer.\n\
+This is buffer local in the buffer where the complition is
+perfermed.")
 
 (defun slime-complete-maybe-save-window-configuration ()
-  "Save the current window configuration, if there is no completion in
-progress."
+  (make-local-variable 'slime-complete-saved-window-configuration)
   (unless slime-complete-saved-window-configuration
     (setq slime-complete-saved-window-configuration
           (current-window-configuration))))
 
+(defun slime-complete-delay-restoration ()
+  (add-hook (make-local-variable 'pre-command-hook)
+            'slime-complete-maybe-restore-window-confguration))
+
+(defun slime-complete-forget-window-configuration ()
+  (setq slime-complete-saved-window-configuration nil))
+
 (defun slime-complete-restore-window-configuration ()
-  "Delete the *Completions* buffer and restore the window config if
-available."
-  (when (get-buffer "*Completions*")
-    (kill-buffer "*Completions*"))
+  "Restore the window config if available."
+  (remove-hook (make-local-variable 'pre-command-hook)
+               'slime-complete-maybe-restore-window-confguration)
   (when slime-complete-saved-window-configuration
     (set-window-configuration slime-complete-saved-window-configuration)
-    (setq slime-complete-saved-window-configuration nil)))
+    (setq slime-complete-saved-window-configuration nil))
+  (when (get-buffer slime-completions-buffer-name)
+    (bury-buffer slime-completions-buffer-name)))
+
+(defun slime-complete-maybe-restore-window-confguration ()
+  "Restore the window configuration, if the following command
+terminates a current completion."
+  (remove-hook (make-local-variable 'pre-command-hook)
+               'slime-complete-maybe-restore-window-confguration)
+  (cond ((find last-command-char "()\"'`,# \r\n:")
+         (slime-complete-restore-window-configuration))
+        ((memq this-command '(self-insert-command
+                              slime-complete-symbol
+                              backward-delete-char-untabify
+                              backward-delete-char
+                              scroll-other-window))
+         (slime-complete-delay-restoration))
+        (t 
+         (slime-complete-forget-window-configuration))))
 
 (defun slime-complete-symbol ()
   "Complete the symbol at point.
@@ -2145,44 +2185,18 @@
           ((not (string= prefix completion))
            (delete-region beg end)
            (insert-and-inherit completion)
-           (if (null (cdr completions))
-               (slime-restore-window-configuration)
-               (slime-complete-delay-restoration)))
+           (cond ((null (cdr completions))
+                  (slime-complete-restore-window-configuration))
+                 (t (slime-complete-delay-restoration))))
           (t
            (message "Making completion list...")
-           (slime-complete-maybe-save-window-configuration)
            (let ((list (all-completions prefix completions-alist nil)))
+             (slime-complete-maybe-save-window-configuration)
              (slime-with-output-to-temp-buffer "*Completions*"
-	       (display-completion-list list))
+               (display-completion-list list))
              (slime-complete-delay-restoration))
            (message "Making completion list...done")))))
 
-(defun slime-complete-delay-restoration ()
-  "Install a pre-command-hook that will restore the window
-configuration if possible."
-  (add-hook (make-local-variable 'pre-command-hook)
-            'slime-complete-maybe-restore-window-confguration))
-
-(defun slime-complete-forget-window-configuration ()
-  (remove-hook 'pre-command-hook 
-               'slime-complete-maybe-restore-window-confguration)
-  (setq slime-complete-saved-window-configuration nil))
-
-(defun slime-complete-maybe-restore-window-confguration ()
-  "Restore the window configuration, if the following command
-terminates a current completion."
-  (cond ((find last-command-char "()\"'`,# \r\n:")
-         (slime-complete-restore-window-configuration)
-         (slime-complete-forget-window-configuration))
-        ((memq this-command '(self-insert-command
-                              slime-complete-symbol
-                              backward-delete-char-untabify
-                              backward-delete-char
-                              scroll-other-window))
-         ;; keep going
-         )
-        (t (slime-complete-forget-window-configuration))))
-
 (defun slime-completing-read-internal (string default-package flag)
   ;; We misuse the predicate argument to pass the default-package.
   ;; That's needed because slime-completing-read-internal is called in
@@ -2349,16 +2363,20 @@
 
 (defun slime-display-buffer-region (buffer start end &optional other-window)
   "Like `display-buffer', but only display the specified region."
-  (with-current-buffer buffer
-    (save-excursion
-      (save-restriction
-        (goto-char start)
-        (beginning-of-line)
-        (narrow-to-region (point) end)
-        (let ((window (display-buffer buffer other-window)))
-          (set-window-start window (point))
-          (shrink-window-if-larger-than-buffer window)
-          window)))))
+  (let ((window-min-height 1))
+    (with-current-buffer buffer
+      (save-excursion
+        (save-restriction
+          (goto-char start)
+          (beginning-of-line)
+          (narrow-to-region (point) end)
+          (let ((window (display-buffer buffer other-window)))
+            (set-window-start window (point))
+            (unless (or (one-window-p t)
+                        (/= (frame-width) (window-width)))
+              (set-window-text-height window (/ (1- (frame-height)) 2)))
+            (shrink-window-if-larger-than-buffer window)
+            window))))))
 
 (defun slime-show-evaluation-result (value)
   (slime-show-last-output)
@@ -2524,7 +2542,12 @@
 		 (:function "Function" swank:describe-function)
 		 (:setf "Setf" swank:describe-setf-function)
 		 (:type "Type" swank:describe-type)
-		 (:class "Class" swank:describe-class))
+		 (:class "Class" swank:describe-class)
+                 (:alien-type "Alien type" swank:describe-alien-type)
+                 (:alien-struct "Alien struct" swank:describe-alien-struct)
+                 (:alien-union "Alien type" swank:describe-alien-union)
+                 (:alien-enum "Alien enum" swank:describe-alien-enum)
+                 )
 	    do
 	    (let ((value (plist-get plist prop))
 		  (start (point)))
@@ -2728,19 +2751,19 @@
     (slime-save-window-configuration)))
 
 (defun slime-select-function (function-names package)
-  (cond ((null function-names)
-	 (message "No callers"))
-	(t
-	 (lexical-let ((function-names function-names)
-		       (package package))
-	   (slime-select function-names
-			 (lambda (index)
-			   (slime-eval-async
-			    `(swank:function-source-location-for-emacs 
-			      ,(nth index function-names))
-			    package
-			    #'slime-carefully-show-source-location))
-			 (lambda (index)))))))
+  (if (null function-names)
+      (message "No callers")
+    (with-lexical-bindings (function-names package)
+      (slime-select 
+       function-names
+       (lambda (index)
+         (slime-eval-async `(swank:function-source-location-for-emacs 
+                             ,(nth index function-names))
+                           package
+                           (lambda (loc)
+                             (let ((pop-up-windows nil))
+                               (slime-carefully-show-source-location loc)))))
+       (lambda (index))))))
 
 (defun slime-carefully-show-source-location (location)
   (condition-case e
@@ -3399,7 +3422,9 @@
   (interactive)
   (message "Select [%s]: " 
            (apply #'string (mapcar #'car slime-selector-methods)))
-  (let* ((ch (read-char))
+  (let* ((ch (save-window-excursion
+               (select-window (minibuffer-window))
+               (read-char)))
          (method (find ch slime-selector-methods :key #'car)))
     (cond ((null method)
            (message "No method for character: ?\\%c" ch)





More information about the slime-cvs mailing list