[slime-cvs] CVS update: slime/swank.lisp slime/swank-cmucl.lisp slime/swank-openmcl.lisp slime/swank-sbcl.lisp
Helmut Eller
heller at common-lisp.net
Fri Oct 17 21:18:04 UTC 2003
Update of /project/slime/cvsroot/slime
In directory common-lisp.net:/tmp/cvs-serv15851
Modified Files:
swank.lisp swank-cmucl.lisp swank-openmcl.lisp swank-sbcl.lisp
Log Message:
Move more stuff to swank.lisp.
Date: Fri Oct 17 17:18:04 2003
Author: heller
Index: slime/swank.lisp
diff -u slime/swank.lisp:1.37 slime/swank.lisp:1.38
--- slime/swank.lisp:1.37 Fri Oct 17 15:49:05 2003
+++ slime/swank.lisp Fri Oct 17 17:18:04 2003
@@ -33,7 +33,6 @@
(defun start-server (&optional (port server-port))
"Start the Slime backend on TCP port `port'."
(create-swank-server port :reuse-address t)
- #+xref (setf c:*record-xref-info* t)
(when *swank-debug-p*
(format *debug-io* "~&;; Swank ready.~%")))
@@ -92,7 +91,7 @@
(defun prin1-to-string-for-emacs (object)
(with-standard-io-syntax
(let ((*print-case* :downcase)
- (*print-readably* nil)
+ (*print-readably* t)
(*print-pretty* nil)
(*package* *swank-io-package*))
(prin1-to-string object))))
@@ -137,6 +136,14 @@
(error "Backend function ~A not implemented." ',fun))
(export ',fun :swank)))
+(defvar *swank-debugger-condition*)
+(defvar *swank-debugger-hook*)
+
+(defun swank-debugger-hook (condition hook)
+ (let ((*swank-debugger-condition* condition)
+ (*swank-debugger-hook* hook))
+ (sldb-loop)))
+
(defslimefun eval-string (string buffer-package)
(let ((*debugger-hook* #'swank-debugger-hook))
(let (ok result)
@@ -153,8 +160,24 @@
(force-output)
(format nil "~{~S~^, ~}" values)))
-;;; this was unimplemented in -openmcl, anyone know why?
-;;; ditto interactive-eval-region
+(defslimefun interactive-eval-region (string)
+ (let ((*package* *buffer-package*))
+ (with-input-from-string (stream string)
+ (loop for form = (read stream nil stream)
+ until (eq form stream)
+ for result = (multiple-value-list (eval form))
+ do (force-output)
+ finally (return (format nil "~{~S~^, ~}" result))))))
+
+(defslimefun re-evaluate-defvar (form)
+ (let ((*package* *buffer-package*))
+ (let ((form (read-from-string form)))
+ (destructuring-bind (dv name &optional value doc) form
+ (declare (ignore value doc))
+ (assert (eq dv 'defvar))
+ (makunbound name)
+ (prin1-to-string (eval form))))))
+
(defslimefun pprint-eval (string)
(let ((*package* *buffer-package*))
(let ((value (eval (read-from-string string))))
@@ -226,8 +249,8 @@
(defun call-with-compilation-hooks (fn)
(multiple-value-bind (result usecs)
(with-trapping-compilation-notes ()
- (clear-compiler-notes)
- (measure-time-interval fn))
+ (clear-compiler-notes)
+ (measure-time-interval fn))
(list (to-string result)
(format nil "~,2F" (/ usecs 1000000.0)))))
@@ -273,6 +296,96 @@
(defslimefun disassemble-symbol (symbol-name)
(print-output-to-string (lambda () (disassemble (from-string symbol-name)))))
+
+;;; Completion
+
+(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))))
+
+;;; Apropos
+
+(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)))))))
+
+;;;
+
+(defslimefun untrace-all ()
+ (untrace))
+
+(defslimefun load-file (filename)
+ (load filename))
;;; Local Variables:
;;; eval: (font-lock-add-keywords 'lisp-mode '(("(\\(defslimefun\\)\\s +\\(\\(\\w\\|\\s_\\)+\\)" (1 font-lock-keyword-face) (2 font-lock-function-name-face))))
Index: slime/swank-cmucl.lisp
diff -u slime/swank-cmucl.lisp:1.7 slime/swank-cmucl.lisp:1.8
--- slime/swank-cmucl.lisp:1.7 Fri Oct 17 15:09:14 2003
+++ slime/swank-cmucl.lisp Fri Oct 17 17:18:04 2003
@@ -14,6 +14,7 @@
(fcntl fd unix:F-SETFL (logior flags unix:O_NONBLOCK)))))
(set-fd-non-blocking (sys:fd-stream-fd sys:*stdin*))
+(setf c:*record-xref-info* t)
;;; TCP Server.
@@ -93,33 +94,7 @@
(condition (c)
(throw 'serve-request-catcher c))))
-;;; Asynchronous eval
-
-(defvar *swank-debugger-condition*)
-(defvar *swank-debugger-hook*)
-
-(defun swank-debugger-hook (condition hook)
- (let ((*swank-debugger-condition* condition)
- (*swank-debugger-hook* hook))
- (sldb-loop)))
-
-(defslimefun interactive-eval-region (string)
- (let ((*package* *buffer-package*))
- (with-input-from-string (stream string)
- (loop for form = (read stream nil stream)
- until (eq form stream)
- for result = (multiple-value-list (eval form))
- do (force-output)
- finally (return (format nil "~{~S~^, ~}" result))))))
-
-(defslimefun re-evaluate-defvar (form)
- (let ((*package* *buffer-package*))
- (let ((form (read-from-string form)))
- (destructuring-bind (dv name &optional value doc) form
- (declare (ignore value doc))
- (assert (eq dv 'defvar))
- (makunbound name)
- (prin1-to-string (eval form))))))
+;;;
(defslimefun set-default-directory (directory)
(setf (ext:default-directory) (namestring directory))
@@ -433,56 +408,6 @@
(defslimefun list-callees (symbol-name)
(stringify-function-name-list (function-callees (from-string symbol-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))))
-
;;;; Definitions
(defvar *debug-definition-finding* nil
@@ -601,38 +526,6 @@
(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)))))))
-
-
-
(defslimefun describe-setf-function (symbol-name)
(print-description-to-string
(or (ext:info setf inverse (from-string symbol-name))
@@ -666,24 +559,12 @@
(debug::trace-1 fname (debug::make-trace-info))
(format nil "~S is now traced." fname)))))
-(defslimefun untrace-all ()
- (untrace))
-
-(defslimefun load-file (filename)
- (load filename))
-
;;; Debugging
(defvar *sldb-level* 0)
(defvar *sldb-stack-top*)
(defvar *sldb-restarts*)
-
-(defslimefun ping (level)
- (cond ((= level *sldb-level*)
- *sldb-level*)
- (t
- (throw-to-toplevel))))
(defslimefun getpid ()
(unix:unix-getpid))
Index: slime/swank-openmcl.lisp
diff -u slime/swank-openmcl.lisp:1.8 slime/swank-openmcl.lisp:1.9
--- slime/swank-openmcl.lisp:1.8 Fri Oct 17 15:09:14 2003
+++ slime/swank-openmcl.lisp Fri Oct 17 17:18:04 2003
@@ -13,7 +13,7 @@
;;; The LLGPL is also available online at
;;; http://opensource.franz.com/preamble.html
;;;
-;;; $Id: swank-openmcl.lisp,v 1.8 2003/10/17 19:09:14 jbielman Exp $
+;;; $Id: swank-openmcl.lisp,v 1.9 2003/10/17 21:18:04 heller Exp $
;;;
;;;
@@ -116,22 +116,12 @@
;;; Evaluation
-(defvar *swank-debugger-condition*)
-(defvar *swank-debugger-hook*)
(defvar *swank-debugger-stack-frame*)
(defmethod ccl::application-error :before (application condition error-pointer)
(declare (ignore application condition))
(setq *swank-debugger-stack-frame* error-pointer))
-(defun swank-debugger-hook (condition hook)
- (let ((*swank-debugger-condition* condition)
- (*swank-debugger-hook* hook))
- (sldb-loop)))
-
-(defslimefun-unimplemented interactive-eval-region (string))
-(defslimefun-unimplemented re-evaluate-defvar (form))
-
(defslimefun arglist-string (fname)
(let ((*print-case* :downcase))
(multiple-value-bind (function condition)
@@ -199,12 +189,6 @@
(defvar *sldb-stack-top*)
(defvar *sldb-restarts*)
-(defslimefun ping (level)
- (cond ((= level *sldb-level*)
- *sldb-level*)
- (t
- (throw-to-toplevel))))
-
(defslimefun getpid ()
(ccl::getpid))
@@ -345,36 +329,6 @@
(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)
@@ -402,57 +356,6 @@
(defslimefun-unimplemented find-fdefinition (symbol-name package-name))
(defslimefun-unimplemented function-source-location-for-emacs (fname))
-
-;;; Completion
-
-(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.8 slime/swank-sbcl.lisp:1.9
--- slime/swank-sbcl.lisp:1.8 Fri Oct 17 15:45:59 2003
+++ slime/swank-sbcl.lisp Fri Oct 17 17:18:04 2003
@@ -177,36 +177,7 @@
;;; Utilities
-(defvar *swank-debugger-condition*)
(defvar *swank-debugger-stack-frame*)
-(defvar *swank-debugger-hook*)
-
-(defun swank-debugger-hook (condition hook)
- (let ((*swank-debugger-condition* condition)
- (*swank-debugger-hook* hook))
- (sldb-loop)))
-
-;;; this looks portable, but why no openmcl support?
-(defslimefun interactive-eval-region (string)
- (let ((*package* *buffer-package*))
- (with-input-from-string (stream string)
- (loop for form = (read stream nil stream)
- until (eq form stream)
- for result = (multiple-value-list (eval form))
- do (force-output)
- finally (return (format nil "~{~S~^, ~}" result))))))
-
-(defslimefun re-evaluate-defvar (form)
- (let ((*package* *buffer-package*))
- (let ((form (read-from-string form)))
- (destructuring-bind (dv name &optional value doc) form
- (declare (ignore value doc))
- (assert (eq dv 'defvar) (form)
- "Can't parse ~S as a ~S form" form 'defvar)
- (makunbound name)
- (prin1-to-string (eval form))))))
-
-
;;; adapted from cmucl
(defslimefun set-default-directory (directory)
@@ -338,56 +309,6 @@
(and (every #'< path1 path2)
(< (length path1) (length path2))))
-(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))))
-
-
-
;;;; Definitions
(defvar *debug-definition-finding* nil
@@ -475,38 +396,6 @@
(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)))))))
-
-
(defslimefun describe-setf-function (symbol-name)
(print-description-to-string `(setf ,(from-string symbol-name))))
@@ -536,26 +425,12 @@
(sb-debug::trace-1 fname (sb-debug::make-trace-info))
(format nil "~S is now traced." fname)))))
-(defslimefun untrace-all ()
- (untrace))
-
-
-
-(defslimefun load-file (filename)
- (load filename))
-
;;; Debugging
(defvar *sldb-level* 0)
(defvar *sldb-stack-top*)
(defvar *sldb-restarts*)
-
-(defslimefun ping (level)
- (cond ((= level *sldb-level*)
- *sldb-level*)
- (t
- (throw-to-toplevel))))
(defslimefun getpid ()
(sb-unix:unix-getpid))
More information about the slime-cvs
mailing list