[slime-cvs] CVS update: slime/swank-backend.lisp slime/swank.lisp slime/swank-sbcl.lisp slime/swank-loader.lisp slime/swank-cmucl.lisp
Luke Gorrie
lgorrie at common-lisp.net
Sun Nov 23 05:00:14 UTC 2003
Update of /project/slime/cvsroot/slime
In directory common-lisp.net:/tmp/cvs-serv10850
Modified Files:
swank.lisp swank-sbcl.lisp swank-loader.lisp swank-cmucl.lisp
Added Files:
swank-backend.lisp
Log Message:
* swank-sbcl.lisp (describe-symbol-for-emacs): Don't ask for
(documentation SYM 'class), CLHS says there isn't any 'class
documentation (and SBCL warns).
* swank.lisp, swank-cmucl.lisp, swank-sbcl.lisp: Refactored
interface through swank-backend.lisp for: swank-compile-file,
swank-compile-string, describe-symbol-for-emacs (apropos),
macroexpand-all, arglist-string.
* swank-backend.lisp: New file defining the interface between
swank.lisp and the swank-*.lisp implementation files.
Date: Sun Nov 23 00:00:13 2003
Author: lgorrie
Index: slime/swank.lisp
diff -u slime/swank.lisp:1.60 slime/swank.lisp:1.61
--- slime/swank.lisp:1.60 Sat Nov 22 00:36:59 2003
+++ slime/swank.lisp Sun Nov 23 00:00:13 2003
@@ -1,4 +1,4 @@
-;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;; -*- Mode: lisp; outline-regexp: ";;;;*"; indent-tabs-mode: nil -*-
;;;
;;; swank.lisp --- the portable bits
;;;
@@ -7,14 +7,17 @@
;;; This code has been placed in the Public Domain. All warranties are
;;; disclaimed.
+#+nil
(defpackage :swank
(:use :common-lisp)
- (:nicknames "SWANK-IMPL")
(:export #:start-server #:create-swank-server
#:*sldb-pprint-frames*))
(in-package :swank)
+;; Directly exported backend functions.
+(export '(arglist-string))
+
(defvar *swank-io-package*
(let ((package (make-package "SWANK-IO-PACKAGE")))
(import '(nil t quote) package)
@@ -294,30 +297,11 @@
;;;; 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.")
(defun clear-compiler-notes ()
- (setf *compiler-notes* '())
- (setf *previous-compiler-condition* nil)
- (setf *previous-context* nil))
-
-(defvar *notes-database* (make-hash-table :test #'equal)
- "Database of recorded compiler notes/warnings/errors (keyed by filename).
-Each value is a list of (LOCATION SEVERITY MESSAGE CONTEXT) lists.
- LOCATION is a position in the source code (integer or source path).
- SEVERITY is one of :ERROR, :WARNING, :STYLE-WARNING and :NOTE.
- MESSAGE is a string describing the note.
- CONTEXT is a string giving further details of where the error occured.")
-
-(defun clear-note-database (filename)
- (remhash (canonicalize-filename filename) *notes-database*))
+ (setf *compiler-notes* '()))
(defslimefun features ()
(mapcar #'symbol-name *features*))
@@ -325,11 +309,6 @@
(defun canonicalize-filename (filename)
(namestring (truename filename)))
-(defslimefun compiler-notes-for-file (filename)
- "Return the compiler notes recorded for FILENAME.
-\(See *NOTES-DATABASE* for a description of the return type.)"
- (gethash (canonicalize-filename filename) *notes-database*))
-
(defslimefun compiler-notes-for-emacs ()
"Return the list of compiler notes for the last compilation unit."
(reverse *compiler-notes*))
@@ -343,14 +322,33 @@
(* (- (get-internal-real-time) before)
(/ 1000000 internal-time-units-per-second)))))
-(defmacro with-trapping-compilation-notes (() &body body)
- `(call-trapping-compilation-notes (lambda () , at body)))
+(defun record-note-for-condition (condition)
+ "Record a note for a compiler-condition."
+ (push (make-compiler-note condition) *compiler-notes*))
+
+(defun make-compiler-note (condition)
+ "Make a compiler note data structure from a compiler-condition."
+ (declare (type compiler-condition condition))
+ (list :message (message condition)
+ :severity (severity condition)
+ :location (location condition)))
-(defun call-with-compilation-hooks (fn)
+(defslimefun swank-compile-file (filename load-p)
+ (clear-compiler-notes)
(multiple-value-bind (result usecs)
- (with-trapping-compilation-notes ()
- (clear-compiler-notes)
- (measure-time-interval fn))
+ (handler-bind ((compiler-condition #'record-note-for-condition))
+ (measure-time-interval (lambda ()
+ (compile-file-for-emacs filename load-p))))
+ (list (to-string result)
+ (format nil "~,2F" (/ usecs 1000000.0)))))
+
+(defslimefun swank-compile-string (string buffer start)
+ (clear-compiler-notes)
+ (multiple-value-bind (result usecs)
+ (handler-bind ((compiler-condition #'record-note-for-condition))
+ (measure-time-interval
+ (lambda ()
+ (compile-string-for-emacs string :buffer buffer :position start))))
(list (to-string result)
(format nil "~,2F" (/ usecs 1000000.0)))))
@@ -408,6 +406,9 @@
(defslimefun disassemble-symbol (symbol-name)
(print-output-to-string (lambda () (disassemble (from-string symbol-name)))))
+(defslimefun swank-macroexpand-all (string)
+ (apply-macro-expander #'macroexpand-all string))
+
;;; Completion
(defun case-convert (string)
@@ -512,6 +513,23 @@
(mapcan (listify #'briefly-describe-symbol-for-emacs)
(sort (apropos-symbols name external-only package)
#'present-symbol-before-p)))
+
+(defun briefly-describe-symbol-for-emacs (symbol)
+ "Return a property list describing SYMBOL.
+Like `describe-symbol-for-emacs' but with at most one line per item."
+ (flet ((first-line (string)
+ (let ((pos (position #\newline string)))
+ (if (null pos) string (subseq string 0 pos)))))
+ (list* :designator (to-string symbol)
+ (map-if #'stringp #'first-line (describe-symbol-for-emacs symbol)))))
+
+(defun map-if (test fn &rest lists)
+ "Like (mapcar FN . LISTS) but only call FN on objects satisfying TEST.
+Example:
+\(map-if #'oddp #'- '(1 2 3 4 5)) => (-1 2 -3 4 -5)"
+ (apply #'mapcar
+ (lambda (x) (if (funcall test x) (funcall fn x) x))
+ lists))
(defun listify (f)
"Return a function like F, but which returns any non-null value
Index: slime/swank-sbcl.lisp
diff -u slime/swank-sbcl.lisp:1.23 slime/swank-sbcl.lisp:1.24
--- slime/swank-sbcl.lisp:1.23 Sun Nov 16 13:08:43 2003
+++ slime/swank-sbcl.lisp Sun Nov 23 00:00:13 2003
@@ -196,6 +196,9 @@
(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
@@ -205,34 +208,36 @@
(let ((context (sb-c::find-error-context nil)))
(when (and context (not (eq condition *previous-compiler-condition*)))
(setq *previous-compiler-condition* condition)
- (let* ((file-name (sb-c::compiler-error-context-file-name context))
- (file-pos (sb-c::compiler-error-context-file-position context))
- (file (if (typep file-name 'pathname)
- (namestring file-name)
- file-name))
- (note
- (list
- :severity (etypecase condition
- (sb-c:compiler-error :error)
- (sb-ext:compiler-note :note)
- (style-warning :style-warning)
- (warning :warning))
- :message (brief-compiler-message-for-emacs condition context)
- :location
- (list
- :sbcl
- :buffername (if (boundp '*buffername*) *buffername*)
- :buffer-offset (if (boundp '*buffer-offset*) *buffer-offset*)
- :position file-pos
- :filename (etypecase file
- (symbol file)
- ((or string pathname)
- (namestring (truename file))))
- :source-path (current-compiler-error-source-path context)))))
- #+nil
- (let ((*print-length* nil))
- (format *terminal-io* "handle-notification-condition ~A ~%" note))
- (push note *compiler-notes*)))))
+ (signal-compiler-condition condition context))))
+
+(defun signal-compiler-condition (condition context)
+ (signal (make-condition
+ 'compiler-condition
+ :original-condition condition
+ :severity (etypecase condition
+ (sb-c:compiler-error :error)
+ (sb-ext:compiler-note :note)
+ (style-warning :style-warning)
+ (warning :warning))
+ :message (brief-compiler-message-for-emacs condition context)
+ :location (compiler-note-location context))))
+
+(defun compiler-note-location (context)
+ "Determine from CONTEXT the current compiler source location."
+ (let* ((file-name (sb-c::compiler-error-context-file-name context))
+ (file-pos (sb-c::compiler-error-context-file-position context))
+ (file (if (typep file-name 'pathname)
+ (namestring file-name)
+ file-name)))
+ (list :sbcl
+ :buffername (if (boundp '*buffername*) *buffername*)
+ :buffer-offset (if (boundp '*buffer-offset*) *buffer-offset*)
+ :position file-pos
+ :filename (etypecase file
+ (symbol file)
+ ((or string pathname)
+ (namestring (truename file))))
+ :source-path (current-compiler-error-source-path context))))
(defun brief-compiler-message-for-emacs (condition error-context)
"Briefly describe a compiler error for Emacs.
@@ -257,40 +262,36 @@
(reverse
(sb-c::compiler-error-context-original-source-path context)))))
-(defun call-trapping-compilation-notes (fn)
- (handler-bind ((sb-c:compiler-error #'handle-notification-condition)
- (sb-ext:compiler-note #'handle-notification-condition)
- (style-warning #'handle-notification-condition)
- (warning #'handle-notification-condition))
- (funcall fn)))
-
-(defslimefun swank-compile-file (filename load)
- (call-with-compilation-hooks
- (lambda ()
- (clear-note-database filename)
- #+xref (clear-xref-info filename)
- (let* ((*buffername* nil)
- (*buffer-offset* nil)
- (ret (compile-file filename)))
- (if load (load ret) ret)))))
-
-(defslimefun swank-compile-string (string buffer start)
- (call-with-compilation-hooks
- (lambda ()
- (let ((*package* *buffer-package*))
- (prog1
- (eval (from-string
- (format nil "(funcall (compile nil '(lambda () ~A)))"
- string)))
- (loop for n in *compiler-notes*
- for loc = (getf n :location)
- for (_ . l) = loc
- for sp = (getf l :source-path)
- ;; account for the added lambda, replace leading
- ;; position with 0
- do (setf (getf l :source-path) (cons 0 (cddr sp))
- (getf l :buffername) buffer
- (getf l :buffer-offset) start)))))))
+(defmacro with-compilation-hooks (() &body body)
+ `(handler-bind ((sb-c:compiler-error #'handle-notification-condition)
+ (sb-ext:compiler-note #'handle-notification-condition)
+ (style-warning #'handle-notification-condition)
+ (warning #'handle-notification-condition))
+ , at body))
+
+(defmethod compile-file-for-emacs (filename load-p)
+ (with-compilation-hooks ()
+ (let* ((*buffername* nil)
+ (*buffer-offset* nil)
+ (ret (compile-file filename)))
+ (if load-p (load ret) ret))))
+
+(defmethod compile-string-for-emacs (string &key buffer position)
+ (with-compilation-hooks ()
+ (let ((*package* *buffer-package*))
+ (prog1
+ (eval (from-string
+ (format nil "(funcall (compile nil '(lambda () ~A)))"
+ string)))
+ (loop for n in *compiler-notes*
+ for loc = (getf n :location)
+ for (_ . l) = loc
+ for sp = (getf l :source-path)
+ ;; account for the added lambda, replace leading
+ ;; position with 0
+ do (setf (getf l :source-path) (cons 0 (cddr sp))
+ (getf l :buffername) buffer
+ (getf l :buffer-offset) position))))))
;;;; xref stuff doesn't exist for sbcl yet
@@ -352,23 +353,13 @@
(finder fname)
(handler-case (finder fname)
(error (e) (list :error (format nil "Error: ~A" e))))))))
-;; (function-source-location-for-emacs "read-next-form")
-(defun briefly-describe-symbol-for-emacs (symbol)
+
+(defmethod 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)
- (let ((string
- ;; sbcl 0.8.4.early signals unbound slot on
- ;; (documentation 'function 'type)
- ;; (fixed for 0.8.5)
- (ignore-errors (documentation symbol kind))))
- (if string
- (first-line string)
- :not-documented)))
+ (labels ((doc (kind)
+ (or (documentation symbol kind) :not-documented))
(maybe-push (property value)
(when value
(setf result (list* property value result)))))
@@ -388,11 +379,7 @@
(maybe-push
:type (if (sb-int:info :type :kind symbol)
(doc 'type)))
- (maybe-push
- :class (if (find-class symbol nil)
- (doc 'class)))
- (if result
- (list* :designator (to-string symbol) result)))))
+ result)))
(defslimefun describe-setf-function (symbol-name)
(print-description-to-string `(setf ,(from-string symbol-name))))
@@ -406,12 +393,9 @@
;;; macroexpansion
-(defun sbcl-macroexpand-all (form)
+(defmethod macroexpand-all (form)
(let ((sb-walker:*walk-form-expand-macros-p* t))
(sb-walker:walk-form form)))
-
-(defslimefun swank-macroexpand-all (string)
- (apply-macro-expander #'sbcl-macroexpand-all string))
;;;
Index: slime/swank-loader.lisp
diff -u slime/swank-loader.lisp:1.4 slime/swank-loader.lisp:1.5
--- slime/swank-loader.lisp:1.4 Wed Nov 19 07:12:09 2003
+++ slime/swank-loader.lisp Sun Nov 23 00:00:13 2003
@@ -7,7 +7,7 @@
;;; This code has been placed in the Public Domain. All warranties
;;; are disclaimed.
;;;
-;;; $Id: swank-loader.lisp,v 1.4 2003/11/19 12:12:09 heller Exp $
+;;; $Id: swank-loader.lisp,v 1.5 2003/11/23 05:00:13 lgorrie Exp $
;;;
(defpackage :swank-loader
@@ -65,7 +65,9 @@
(cond ((probe-file filename) filename)
(t nil))))
-(compile-files-if-needed-serially (cons *swank-pathname* *sysdep-pathnames*))
+(compile-files-if-needed-serially
+ (list* (make-swank-pathname "swank-backend") *swank-pathname*
+ *sysdep-pathnames*))
(when (user-init-file)
(load (user-init-file)))
Index: slime/swank-cmucl.lisp
diff -u slime/swank-cmucl.lisp:1.23 slime/swank-cmucl.lisp:1.24
--- slime/swank-cmucl.lisp:1.23 Wed Nov 19 07:37:37 2003
+++ slime/swank-cmucl.lisp Sun Nov 23 00:00:13 2003
@@ -1,4 +1,4 @@
-;;; -*- indent-tabs-mode: nil -*-
+;;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;+" -*-
(declaim (optimize debug))
@@ -175,7 +175,18 @@
(start-offset :initarg :start-offset)
(string :initarg :string)))
-(defun handle-compiler-condition (condition)
+(defvar *previous-compiler-condition* nil
+ "Used to detect duplicates.")
+
+(defvar *previous-context* nil
+ "Previous compiler error context.")
+
+(defvar *compiler-notes* '()
+ "List of compiler notes for the last compilation unit.")
+
+;;;;; Trapping notes
+
+(defun handle-notification-condition (condition)
"Handle a condition caused by a compiler warning.
This traps all compiler conditions at a lower-level than using
C:*COMPILER-NOTIFICATION-FUNCTION*. The advantage is that we get to
@@ -185,24 +196,48 @@
(let ((context (or (c::find-error-context nil) *previous-context*)))
(setq *previous-compiler-condition* condition)
(setq *previous-context* context)
- (let ((note (make-compiler-note condition context)))
- (push note *compiler-notes*)))))
+ (signal-compiler-condition condition context))))
+
+(defun signal-compiler-condition (condition context)
+ (signal (make-condition
+ 'compiler-condition
+ :original-condition condition
+ :severity (severity-for-emacs condition)
+ :message (brief-compiler-message-for-emacs condition context)
+ :location (compiler-note-location context))))
+
+(defun compiler-note-location (context)
+ (cond (context
+ (let ((cx context))
+ (resolve-location
+ *swank-source-info*
+ (c::compiler-error-context-file-name cx)
+ (c::compiler-error-context-file-position cx)
+ (reverse (c::compiler-error-context-original-source-path cx))
+ (c::compiler-error-context-original-source cx))))
+ (t
+ (resolve-location *swank-source-info* nil nil nil nil))))
+
+(defun severity-for-emacs (condition)
+ "Return the severity of CONDITION."
+ (etypecase condition
+ (c::compiler-error :error)
+ (c::style-warning :note)
+ (c::warning :warning)))
+
+(defun brief-compiler-message-for-emacs (condition error-context)
+ "Briefly describe a compiler error for Emacs.
+When Emacs presents the message it already has the source popped up
+and the source form highlighted. This makes much of the information in
+the error-context redundant."
+ (declare (type (or c::compiler-error-context null) error-context))
+ (let ((enclosing (and error-context
+ (c::compiler-error-context-enclosing-source
+ error-context))))
+ (if enclosing
+ (format nil "--> ~{~<~%--> ~1:;~A~> ~}~%~A" enclosing condition)
+ (format nil "~A" condition))))
-(defun make-compiler-note (condition context)
- (list :message (brief-compiler-message-for-emacs condition context)
- :severity (severity-for-emacs condition)
- :location
- (cond (context
- (let ((cx context))
- (resolve-location
- *swank-source-info*
- (c::compiler-error-context-file-name cx)
- (c::compiler-error-context-file-position cx)
- (reverse (c::compiler-error-context-original-source-path cx))
- (c::compiler-error-context-original-source cx))))
- (t
- (resolve-location *swank-source-info* nil nil nil nil)))))
-
(defgeneric resolve-location (source-info
file-name file-position
source-path source))
@@ -226,65 +261,35 @@
(source (eql nil)))
'(:null))
-(defun severity-for-emacs (condition)
- (etypecase condition
- (c::compiler-error :error)
- (c::style-warning :note)
- (c::warning :warning)))
-
-(defun brief-compiler-message-for-emacs (condition error-context)
- "Briefly describe a compiler error for Emacs.
-When Emacs presents the message it already has the source popped up
-and the source form highlighted. This makes much of the information in
-the error-context redundant."
- (declare (type (or c::compiler-error-context null) error-context))
- (let ((enclosing (and error-context
- (c::compiler-error-context-enclosing-source
- error-context))))
- (if enclosing
- (format nil "--> ~{~<~%--> ~1:;~A~> ~}~%~A" enclosing condition)
- (format nil "~A" condition))))
-
-(defun current-compiler-error-source-path (context)
- "Return the source-path for the current compiler error.
-Returns NIL if this cannot be determined by examining internal
-compiler state."
- (cond ((c::node-p context)
- (reverse
- (c::source-path-original-source (c::node-source-path context))))
- ((c::compiler-error-context-p context)
- (reverse
- (c::compiler-error-context-original-source-path context)))))
-
-(defun call-trapping-compilation-notes (fn)
- (handler-bind ((c::compiler-error #'handle-compiler-condition)
- (c::style-warning #'handle-compiler-condition)
- (c::warning #'handle-compiler-condition))
- (funcall fn)))
-
-(defslimefun swank-compile-file (filename load)
- (call-with-compilation-hooks
- (lambda ()
- (clear-note-database filename)
- (clear-xref-info filename)
- (let ((*swank-source-info* (make-instance 'file-source-info
- :filename filename)))
- (compile-file filename :load load)))))
-
-(defslimefun swank-compile-string (string buffer start)
- (call-with-compilation-hooks
- (lambda ()
- (let ((*package* *buffer-package*)
- (*swank-source-info* (make-instance 'buffer-source-info
- :buffer buffer
- :start-offset start
- :string string)))
- (with-input-from-string (stream string)
- (ext:compile-from-stream
- stream
- :source-info `(:emacs-buffer ,buffer
- :emacs-buffer-offset ,start
- :emacs-buffer-string ,string)))))))
+;;(defun call-trapping-compilation-notes (fn)
+(defmacro with-compilation-hooks (() &body body)
+ `(let ((*previous-compiler-condition* nil)
+ (*previous-context* nil))
+ (handler-bind ((c::compiler-error #'handle-notification-condition)
+ (c::style-warning #'handle-notification-condition)
+ (c::warning #'handle-notification-condition))
+ , at body)))
+
+(defmethod compile-file-for-emacs (filename load-p)
+ (clear-xref-info filename)
+ (with-compilation-hooks ()
+ (let ((*swank-source-info* (make-instance 'file-source-info
+ :filename filename)))
+ (compile-file filename :load load-p))))
+
+(defmethod compile-string-for-emacs (string &key buffer position)
+ (with-compilation-hooks ()
+ (let ((*package* *buffer-package*)
+ (*swank-source-info* (make-instance 'buffer-source-info
+ :buffer buffer
+ :start-offset position
+ :string string)))
+ (with-input-from-string (stream string)
+ (ext:compile-from-stream
+ stream
+ :source-info `(:emacs-buffer ,buffer
+ :emacs-buffer-offset ,position
+ :emacs-buffer-string ,string))))))
(defun clear-xref-info (namestring)
"Clear XREF notes pertaining to FILENAME.
@@ -316,7 +321,7 @@
(defun unix-truename (pathname)
(ext:unix-namestring (truename pathname)))
-(defslimefun arglist-string (fname)
+(defmethod arglist-string (fname)
"Return a string describing the argument list for FNAME.
The result has the format \"(...)\"."
(declare (type string fname))
@@ -328,11 +333,8 @@
(if (not (or (fboundp function)
(functionp function)))
"(-- <Unknown-Function>)"
- (let* ((fun (etypecase function
- (symbol (or (macro-function function)
- (symbol-function function)))
- ;;(function function)
- ))
+ (let* ((fun (or (macro-function function)
+ (symbol-function function)))
(df (di::function-debug-function fun))
(arglist (kernel:%function-arglist fun)))
(cond ((eval:interpreted-function-p fun)
@@ -573,21 +575,13 @@
;;;
-(defun briefly-describe-symbol-for-emacs (symbol)
- "Return a plist describing SYMBOL.
-Return NIL if the symbol is unbound."
+(defmethod describe-symbol-for-emacs (symbol)
(let ((result '()))
- (labels ((first-line (string)
- (let ((pos (position #\newline string)))
- (if (null pos) string (subseq string 0 pos))))
- (doc (kind)
- (let ((string (documentation symbol kind)))
- (if string
- (first-line string)
- :not-documented)))
- (maybe-push (property value)
- (when value
- (setf result (list* property value result)))))
+ (flet ((doc (kind)
+ (or (documentation symbol kind) :not-documented))
+ (maybe-push (property value)
+ (when value
+ (setf result (list* property value result)))))
(maybe-push
:variable (multiple-value-bind (kind recorded-p)
(ext:info variable kind symbol)
@@ -619,8 +613,7 @@
(maybe-push
:alien-enum (if (ext:info alien-type enum symbol)
(doc nil)))
- (if result
- (list* :designator (to-string symbol) result)))))
+ result)))
(defslimefun describe-setf-function (symbol-name)
(print-description-to-string
@@ -661,8 +654,8 @@
;;; Macroexpansion
-(defslimefun swank-macroexpand-all (string)
- (apply-macro-expander #'walker:macroexpand-all string))
+(defmethod macroexpand-all (form)
+ (walker:macroexpand-all form))
;;;
More information about the slime-cvs
mailing list