[slime-cvs] CVS update: slime/swank-loader.lisp slime/ChangeLog slime/slime.el slime/swank-cmucl.lisp slime/swank-openmcl.lisp slime/swank-sbcl.lisp slime/swank.lisp
James Bielman
jbielman at common-lisp.net
Fri Oct 17 19:09:16 UTC 2003
Update of /project/slime/cvsroot/slime
In directory common-lisp.net:/tmp/cvs-serv11290
Modified Files:
ChangeLog slime.el swank-cmucl.lisp swank-openmcl.lisp
swank-sbcl.lisp swank.lisp
Added Files:
swank-loader.lisp
Log Message:
Many fixes for the OpenMCL port:
* swank.lisp (apropos-symbols): Change back to using the standard
2-argument APROPOS-LIST and check symbols explicitly when
EXTERNAL-ONLY is true.
Move loading of sys-dependent backend code into 'swank-loader'.
* swank-sbcl.lisp: Moved declarations of *PREVIOUS-COMPILER-CONDITION*
into 'swank.lisp' to kill warnings about undefined variables.
* swank-openmcl.lisp (handle-compiler-warning): Use source position
instead of function name for warning locations.
(swank-compile-string): Compile into a temporary file instead of
using COMPILE so finding warning positions works when using C-c C-c.
(compute-backtrace): Don't display frames without a function.
(apropos-list-for-emacs): Implement APROPOS.
(who-calls): Implement WHO-CALLS.
(completions): Implement COMPLETIONS.
Use NIL instead of zero so FRESH-LINE does the right thing.
* slime.el (slime-maybe-compile-swank): Removed function---compile
the backend using 'swank-loader.lisp' instead.
(slime-backend): Changed default backend to 'slime-loader'.
(slime-lisp-binary-extension): Deleted as this is no longer needed.
* swank-loader.lisp: New file.
Date: Fri Oct 17 15:09:15 2003
Author: jbielman
Index: slime/ChangeLog
diff -u slime/ChangeLog:1.36 slime/ChangeLog:1.37
--- slime/ChangeLog:1.36 Fri Oct 17 13:42:52 2003
+++ slime/ChangeLog Fri Oct 17 15:09:14 2003
@@ -1,3 +1,30 @@
+2003-10-17 James Bielman <jamesjb at jamesjb.com>
+
+ * swank.lisp (apropos-symbols): Change back to using the standard
+ 2-argument APROPOS-LIST and check symbols explicitly when
+ EXTERNAL-ONLY is true.
+ Move loading of sys-dependent backend code into 'swank-loader'.
+
+ * swank-sbcl.lisp: Moved declarations of *PREVIOUS-COMPILER-CONDITION*
+ into 'swank.lisp' to kill warnings about undefined variables.
+
+ * swank-openmcl.lisp (handle-compiler-warning): Use source position
+ instead of function name for warning locations.
+ (swank-compile-string): Compile into a temporary file instead of
+ using COMPILE so finding warning positions works when using C-c C-c.
+ (compute-backtrace): Don't display frames without a function.
+ (apropos-list-for-emacs): Implement APROPOS.
+ (who-calls): Implement WHO-CALLS.
+ (completions): Implement COMPLETIONS.
+ Use NIL instead of zero so FRESH-LINE does the right thing.
+
+ * slime.el (slime-maybe-compile-swank): Removed function---compile
+ the backend using 'swank-loader.lisp' instead.
+ (slime-backend): Changed default backend to 'slime-loader'.
+ (slime-lisp-binary-extension): Deleted as this is no longer needed.
+
+ * swank-loader.lisp: New file.
+
2003-10-17 Luke Gorrie <luke at bluetail.com>
* slime.el (slime-net-connect): Check that
Index: slime/slime.el
diff -u slime/slime.el:1.38 slime/slime.el:1.39
--- slime/slime.el:1.38 Fri Oct 17 13:42:38 2003
+++ slime/slime.el Fri Oct 17 15:09:14 2003
@@ -76,10 +76,7 @@
"Number of times to try connecting to the Swank server before aborting.
Nil means never give up.")
-(defvar slime-lisp-binary-extension ".x86f"
- "Filename extension for Lisp object files.")
-
-(defvar slime-backend "swank"
+(defvar slime-backend "swank-loader"
"The name of the Lisp file implementing the Swank server.")
(make-variable-buffer-local
@@ -506,28 +503,11 @@
(defun slime-start-swank-server ()
"Start a Swank server on the inferior lisp."
- (slime-maybe-compile-swank)
(comint-proc-query (inferior-lisp-proc)
(format "(load %S)\n"
(concat slime-path slime-backend)))
(comint-proc-query (inferior-lisp-proc)
(format "(swank:start-server %S)\n" slime-swank-port)))
-
-(defun slime-maybe-compile-swank ()
- (let ((source (concat slime-path slime-backend ".lisp"))
- (binary (concat slime-path slime-backend slime-lisp-binary-extension)))
- (flet ((compile-swank () (comint-proc-query
- (inferior-lisp-proc)
- (format "(compile-file %S)\n" source))))
- (when (or (and (not (file-exists-p binary))
- (or slime-dont-prompt
- (y-or-n-p "\
-The CMUCL support library (Swank) is not compiled. Compile now? ")))
- (and (file-newer-than-file-p source binary)
- (or slime-dont-prompt
- (y-or-n-p "\
-Your Swank binary is older than the source. Recompile now? "))))
- (compile-swank)))))
(defun slime-fetch-features-list ()
"Fetch and remember the *FEATURES* of the inferior lisp."
Index: slime/swank-cmucl.lisp
diff -u slime/swank-cmucl.lisp:1.6 slime/swank-cmucl.lisp:1.7
--- slime/swank-cmucl.lisp:1.6 Thu Oct 16 17:03:37 2003
+++ slime/swank-cmucl.lisp Fri Oct 17 15:09:14 2003
@@ -130,12 +130,6 @@
;;;; Compilation Commands
-(defvar *previous-compiler-condition* nil
- "Used to detect duplicates.")
-
-(defvar *previous-context* nil
- "Used for compiler warnings without context.")
-
(defvar *buffername*)
(defvar *buffer-offset*)
Index: slime/swank-openmcl.lisp
diff -u slime/swank-openmcl.lisp:1.7 slime/swank-openmcl.lisp:1.8
--- slime/swank-openmcl.lisp:1.7 Thu Oct 16 17:03:37 2003
+++ slime/swank-openmcl.lisp Fri Oct 17 15:09:14 2003
@@ -13,7 +13,7 @@
;;; The LLGPL is also available online at
;;; http://opensource.franz.com/preamble.html
;;;
-;;; $Id: swank-openmcl.lisp,v 1.7 2003/10/16 21:03:37 lgorrie Exp $
+;;; $Id: swank-openmcl.lisp,v 1.8 2003/10/17 19:09:14 jbielman Exp $
;;;
;;;
@@ -21,6 +21,11 @@
;;; tested only with OpenMCL version 0.14-030901 on Darwin --- I would
;;; be interested in hearing the results with other versions.
;;;
+;;; Additionally, reporting the positions of warnings accurately requires
+;;; a small patch to the OpenMCL file compiler, which may be found at:
+;;;
+;;; http://www.jamesjb.com/slime/openmcl-warning-position.diff
+;;;
;;; Things that work:
;;;
;;; * Evaluation of forms with C-M-x.
@@ -30,18 +35,18 @@
;;; * Macroexpanding with C-c RET.
;;; * Disassembling the symbol at point with C-c M-d.
;;; * Describing symbol at point with C-c C-d.
+;;; * Compiler warnings are trapped and sent to Emacs using the buffer
+;;; position of the offending top level form.
+;;; * Symbol completion and apropos.
;;;
;;; Things that sort of work:
;;;
-;;; * Compiler warnings are trapped and sent to Emacs. The elisp code
-;;; attempts to place the warnings on the correct defun by doing
-;;; regular expression searches. Does not work in all cases.
+;;; * WHO-CALLS is implemented but is only able to return the file a
+;;; caller is defined in---source location information is not available.
;;;
;;; Things that aren't done yet:
;;;
;;; * Cross-referencing.
-;;; * Symbol completion.
-;;; * Apropos.
;;; * Due to unimplementation functionality the test suite does not
;;; run correctly (it hangs upon entering the debugger).
;;;
@@ -62,8 +67,6 @@
"Create the TCP server and accept connections in a new thread."
(let ((server-socket (ccl:make-socket :connect :passive :local-port port
:reuse-address reuse-address)))
- (format *terminal-io* "~&;; Swank: Accepting connections on port ~D.~%"
- port)
(loop
(let ((socket (ccl:accept-connection server-socket :wait t)))
(ccl:process-run-function
@@ -104,7 +107,7 @@
(write-char char (slime-output-stream-buffer stream)))
(defmethod ccl:stream-line-column ((stream slime-output-stream))
- 0)
+ nil)
(defmethod ccl:stream-force-output ((stream slime-output-stream))
(send-to-emacs `(:read-output ,(get-output-stream-string
@@ -117,7 +120,6 @@
(defvar *swank-debugger-hook*)
(defvar *swank-debugger-stack-frame*)
-;;; XXX i hope this is correct for threads
(defmethod ccl::application-error :before (application condition error-pointer)
(declare (ignore application condition))
(setq *swank-debugger-stack-frame* error-pointer))
@@ -143,43 +145,53 @@
;;; Compilation
-(defun condition-function-name (condition)
- "Return the function name as a symbol from a compiler condition."
- (symbol-name (car (ccl::compiler-warning-function-name
- condition))))
+(defvar *buffer-offset*)
+
+(defun condition-source-position (condition)
+ "Return the position in the source file of a compiler condition."
+ (+ 1 *buffer-offset* (ccl::compiler-warning-stream-position condition)))
(defun handle-compiler-warning (condition)
"Construct a compiler note for Emacs from a compiler warning
condition."
- (describe (car (ccl::compiler-warning-function-name condition)))
(push (list :position nil
- :function-name (condition-function-name condition)
:source-path nil
:filename (ccl::compiler-warning-file-name condition)
:severity :warning
:message (format nil "~A" condition)
:context nil
- :buffername nil
- :buffer-offset 0)
- *compiler-notes*))
+ :buffername 'anything
+ :buffer-offset (condition-source-position condition))
+ *compiler-notes*)
+ (muffle-warning condition))
(defun call-trapping-compilation-notes (fn)
(handler-bind ((ccl::compiler-warning #'handle-compiler-warning))
(funcall fn)))
+(defun temp-file-name ()
+ (ccl:%get-cstring (#_tmpnam (ccl:%null-ptr))))
+
(defslimefun swank-compile-string (string buffer start)
- (declare (ignore buffer start))
- (call-with-compilation-hooks
- (lambda ()
- (let ((*package* *buffer-package*))
- (eval (from-string
- (format nil "(funcall (compile nil '(lambda () ~A)))"
- string)))))))
+ (declare (ignore buffer))
+ (let ((*buffer-offset* start)
+ (*package* *buffer-package*)
+ (filename (temp-file-name)))
+ (call-with-compilation-hooks
+ (lambda ()
+ (unwind-protect
+ (progn
+ (with-open-file (s filename :direction :output :if-exists :error)
+ (write-string string s))
+ (let ((binary-filename (compile-file filename :load t)))
+ (delete-file binary-filename)))
+ (delete-file filename))))))
(defslimefun swank-compile-file (filename load)
- (call-with-compilation-hooks
- (lambda ()
- (compile-file filename :load load))))
+ (let ((*buffer-offset* 0))
+ (call-with-compilation-hooks
+ (lambda ()
+ (compile-file filename :load load)))))
;;; Debugging
@@ -243,27 +255,25 @@
(defun compute-backtrace (start end &key (start-frame (ccl::%get-frame-ptr)))
(let ((tcr (ccl::%current-tcr))
(result)
+ (frame-number 0)
(total 0))
(do* ((p start-frame (ccl::parent-frame p tcr))
- (frame-number 0 (1+ frame-number))
(q (ccl::last-frame-ptr tcr)))
((or (null p) (eq p q) (ccl::%stack< q p tcr))
(values))
(declare (fixnum frame-number))
(progn
(multiple-value-bind (lfun pc) (ccl::cfp-lfun p)
- (incf total)
- (if (and (>= frame-number start) (< frame-number end))
- (push (list frame-number
- (format nil "~D: (~A~A)"
+ (declare (ignore pc))
+ (when lfun
+ (incf total)
+ (if (and (>= frame-number start) (< frame-number end))
+ (push (list frame-number
+ (format nil "~D: (~A)"
frame-number
- (if lfun
- (ccl::%lfun-name-string lfun)
- "#<Unknown Frame>")
- (if lfun
- (frame-parameters p tcr lfun pc)
- "")))
- result)))))
+ (ccl::%lfun-name-string lfun)))
+ result))
+ (incf frame-number)))))
(values (nreverse result) total)))
(defslimefun backtrace-for-emacs (start end)
@@ -300,12 +310,91 @@
(defslimefun describe-class (symbol-name)
(print-description-to-string (find-class (from-string symbol-name) nil)))
-(defslimefun-unimplemented apropos-list-for-emacs (name &optional
- external-only
- package))
+(defun briefly-describe-symbol-for-emacs (symbol)
+ "Return a plist describing SYMBOL.
+Return NIL if the symbol is unbound."
+ (let ((result '()))
+ (labels ((first-line (string)
+ (let ((pos (position #\newline string)))
+ (if (null pos) string (subseq string 0 pos))))
+ (doc (kind &optional (sym symbol))
+ (let ((string (documentation sym kind)))
+ (if string
+ (first-line string)
+ :not-documented)))
+ (maybe-push (property value)
+ (when value
+ (setf result (list* property value result)))))
+ (maybe-push
+ :variable (when (boundp symbol)
+ (doc 'variable)))
+ (maybe-push
+ :function (if (fboundp symbol)
+ (doc 'function)))
+ (maybe-push
+ :setf (let ((setf-function-name (ccl::setf-function-spec-name
+ `(setf ,symbol))))
+ (when (fboundp setf-function-name)
+ (doc 'function setf-function-name))))
+;; (maybe-push
+;; :type (if (ext:info type kind symbol)
+;; (doc 'type)))
+ (maybe-push
+ :class (if (find-class symbol nil)
+ (doc 'class)))
+ (if result
+ (list* :designator (to-string symbol) result)))))
+
+(defslimefun apropos-list-for-emacs (name &optional external-only package)
+ "Make an apropos search for Emacs.
+The result is a list of property lists."
+ (mapcan (listify #'briefly-describe-symbol-for-emacs)
+ (sort (apropos-symbols name external-only package)
+ #'present-symbol-before-p)))
+
+(defun listify (f)
+ "Return a function like F, but which returns any non-null value
+wrapped in a list."
+ (lambda (x)
+ (let ((y (funcall f x)))
+ (and y (list y)))))
+
+(defun present-symbol-before-p (a b)
+ "Return true if A belongs before B in a printed summary of symbols.
+Sorted alphabetically by package name and then symbol name, except
+that symbols accessible in the current package go first."
+ (flet ((accessible (s)
+ (find-symbol (symbol-name s) *buffer-package*)))
+ (let ((pa (symbol-package a))
+ (pb (symbol-package b)))
+ (cond ((or (eq pa pb)
+ (and (accessible a) (accessible b)))
+ (string< (symbol-name a) (symbol-name b)))
+ ((accessible a) t)
+ ((accessible b) nil)
+ (t
+ (string< (package-name pa) (package-name pb)))))))
;;; Tracing and Disassembly
+(defslimefun who-calls (symbol-name)
+ (let ((callers (ccl::callers symbol-name))
+ (result (make-hash-table :test 'equalp))
+ (list nil))
+ (dolist (caller callers)
+ (let ((source-info (ccl::%source-files caller)))
+ (when (atom source-info)
+ (let ((filename (namestring (truename source-info)))
+ ;; This is clearly not the real source path but it will
+ ;; get us into the file at least...
+ (source-path '(0)))
+ (push (list (string caller) source-path)
+ (gethash filename result))))))
+ (maphash #'(lambda (k v)
+ (push (cons k (list v)) list))
+ result)
+ list))
+
(defslimefun-unimplemented who-references (symbol-name package-name))
(defslimefun-unimplemented who-binds (symbol-name package-name))
(defslimefun-unimplemented who-sets (symbol-name package-name))
@@ -316,7 +405,54 @@
;;; Completion
-(defslimefun-unimplemented completions (string default-package-name))
+(defslimefun completions (string default-package-name)
+ "Return a list of completions for a symbol designator STRING.
+
+The result is a list of strings. If STRING is package qualified the
+result list will also be qualified. If string is non-qualified the
+result strings are also not qualified and are considered relative to
+DEFAULT-PACKAGE-NAME. All symbols accessible in the package are
+considered."
+ (flet ((parse-designator (string)
+ (values (let ((pos (position #\: string :from-end t)))
+ (if pos (subseq string (1+ pos)) string))
+ (let ((pos (position #\: string)))
+ (if pos (subseq string 0 pos) nil))
+ (search "::" string))))
+ (multiple-value-bind (name package-name internal)
+ (parse-designator string)
+ (let ((completions nil)
+ (package (find-package
+ (string-upcase (cond ((equal package-name "") "KEYWORD")
+ (package-name)
+ (default-package-name))))))
+ (when package
+ (do-symbols (symbol package)
+ (when (and (string-prefix-p name (symbol-name symbol))
+ (or internal
+ (not package-name)
+ (symbol-external-p symbol)))
+ (push symbol completions))))
+ (let ((*print-case* (if (find-if #'upper-case-p string)
+ :upcase :downcase))
+ (*package* package))
+ (mapcar (lambda (s)
+ (cond (internal (format nil "~A::~A" package-name s))
+ (package-name (format nil "~A:~A" package-name s))
+ (t (format nil "~A" s))))
+ completions))))))
+
+(defun symbol-external-p (s)
+ (multiple-value-bind (_ status)
+ (find-symbol (symbol-name s) (symbol-package s))
+ (declare (ignore _))
+ (eq status :external)))
+
+(defun string-prefix-p (s1 s2)
+ "Return true iff the string S1 is a prefix of S2. \(This includes
+the case where S1 is equal to S2.)"
+ (and (<= (length s1) (length s2))
+ (string-equal s1 s2 :end2 (length s1))))
;;; Macroexpansion
Index: slime/swank-sbcl.lisp
diff -u slime/swank-sbcl.lisp:1.6 slime/swank-sbcl.lisp:1.7
--- slime/swank-sbcl.lisp:1.6 Thu Oct 16 21:38:41 2003
+++ slime/swank-sbcl.lisp Fri Oct 17 15:09:14 2003
@@ -230,9 +230,6 @@
(defvar *buffername*)
(defvar *buffer-offset*)
-(defvar *previous-compiler-condition* nil
- "Used to detect duplicates.")
-
(defun handle-notification-condition (condition)
"Handle a condition caused by a compiler warning.
This traps all compiler conditions at a lower-level than using
Index: slime/swank.lisp
diff -u slime/swank.lisp:1.35 slime/swank.lisp:1.36
--- slime/swank.lisp:1.35 Thu Oct 16 22:08:50 2003
+++ slime/swank.lisp Fri Oct 17 15:09:14 2003
@@ -13,14 +13,6 @@
(:nicknames "SWANK-IMPL")
(:export #:start-server)))
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (defparameter swank::*sysdep-pathname*
- (merge-pathnames (or #+cmu "swank-cmucl"
- #+(and sbcl sb-thread) "swank-sbcl"
- #+openmcl "swank-openmcl")
- (or *compile-file-pathname* *load-pathname*
- *default-pathname-defaults*))))
-
(in-package :swank)
(defvar *swank-io-package*
@@ -179,6 +171,12 @@
;;;; Compilation Commands.
+(defvar *previous-compiler-condition* nil
+ "Used to detect duplicates.")
+
+(defvar *previous-context* nil
+ "Used for compiler warnings without context.")
+
(defvar *compiler-notes* '()
"List of compiler notes for the last compilation unit.")
@@ -236,10 +234,14 @@
(defslimefun list-all-package-names ()
(mapcar #'package-name (list-all-packages)))
+
(defun apropos-symbols (string &optional external-only package)
- "Return the symbols matching an apropos search."
- ;; CMUCL used ext:map-apropos here, not sure why
- (remove-if #'keywordp (apropos-list string package external-only)))
+ (remove-if (lambda (sym)
+ (or (keywordp sym)
+ (and external-only
+ (not (equal (symbol-package sym) *buffer-package*))
+ (not (symbol-external-p sym)))))
+ (apropos-list string package)))
(defun print-output-to-string (fn)
(with-output-to-string (*standard-output*)
@@ -271,12 +273,6 @@
(defslimefun disassemble-symbol (symbol-name)
(print-output-to-string (lambda () (disassemble (from-string symbol-name)))))
-
-
-;;;; now pull the per-backend stuff in
-(eval-when (:compile-toplevel) (compile-file swank::*sysdep-pathname*))
-(eval-when (:load-toplevel :execute) (load swank::*sysdep-pathname*))
-
;;; Local Variables:
;;; eval: (font-lock-add-keywords 'lisp-mode '(("(\\(defslimefun\\)\\s +\\(\\(\\w\\|\\s_\\)+\\)" (1 font-lock-keyword-face) (2 font-lock-function-name-face))))
More information about the slime-cvs
mailing list