[slime-cvs] CVS update: slime/swank-cmucl.lisp slime/swank-openmcl.lisp slime/swank-sbcl.lisp slime/swank.lisp
Dan Barlow
dbarlow at common-lisp.net
Wed Oct 15 22:48:31 UTC 2003
Update of /project/slime/cvsroot/slime
In directory common-lisp.net:/tmp/cvs-serv18257
Modified Files:
swank-cmucl.lisp swank-openmcl.lisp swank-sbcl.lisp swank.lisp
Log Message:
Third portablizing iteration: more refactoring common bits
pprint-eval set-package *compiler-notes* clear-compiler-notes
*notes-database* clear-note-database features canonicalize-filename
compiler-notes-for-file compiler-notes-for-emacs measure-time-interval
call-with-compilation-hooks
list-all-package-names apropos-symbols print-output-to-string
print-description-to-string describe-symbol describe-function
apply-macro-expander swank-macroexpand-1 swank-macroexpand
disassemble-symbol
Date: Wed Oct 15 18:48:31 2003
Author: dbarlow
Index: slime/swank-cmucl.lisp
diff -u slime/swank-cmucl.lisp:1.2 slime/swank-cmucl.lisp:1.3
--- slime/swank-cmucl.lisp:1.2 Wed Oct 15 18:02:49 2003
+++ slime/swank-cmucl.lisp Wed Oct 15 18:48:30 2003
@@ -110,17 +110,6 @@
do (force-output)
finally (return (format nil "~{~S~^, ~}" result))))))
-(defslimefun pprint-eval (string)
- (let ((*package* *buffer-package*))
- (let ((value (eval (read-from-string string))))
- (let ((*print-pretty* t)
- (*print-circle* t)
- (*print-level* nil)
- (*print-length* nil)
- (ext:*gc-verbose* nil))
- (with-output-to-string (stream)
- (pprint value stream))))))
-
(defslimefun re-evaluate-defvar (form)
(let ((*package* *buffer-package*))
(let ((form (read-from-string form)))
@@ -130,10 +119,6 @@
(makunbound name)
(prin1-to-string (eval form))))))
-(defslimefun set-package (package)
- (setq *package* (guess-package-from-string package))
- (package-name *package*))
-
(defslimefun set-default-directory (directory)
(setf (ext:default-directory) (namestring directory))
;; Setting *default-pathname-defaults* to an absolute directory
@@ -143,8 +128,7 @@
;;;; Compilation Commands
-(defvar *compiler-notes* '()
- "List of compiler notes for the last compilation unit.")
+
(defvar *previous-compiler-condition* nil
"Used to detect duplicates.")
@@ -152,22 +136,6 @@
(defvar *previous-context* nil
"Used for compiler warnings without context.")
-(defvar *notes-database* (make-hash-table :test #'equal)
- "Database of recorded compiler notes/warnings/erros (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, and :NOTE.
- MESSAGE is a string describing the note.
- CONTEXT is a string giving further details of where the error occured.")
-
-(defun clear-compiler-notes ()
- (setf *compiler-notes* '())
- (setf *previous-compiler-condition* nil)
- (setf *previous-context* nil))
-
-(defun clear-note-database (filename)
- (remhash (canonicalize-filename filename) *notes-database*))
-
(defvar *buffername*)
(defvar *buffer-offset*)
@@ -243,46 +211,12 @@
(reverse
(c::compiler-error-context-original-source-path context)))))
-(defslimefun features ()
- (mapcar #'symbol-name *features*))
-
-(defun canonicalize-filename (filename)
- (namestring (unix:unix-resolve-links 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*))
-
-(defun measure-time-intervall (fn)
- "Call FN and return the first return value and the elapsed time.
-The time is measured in microseconds."
- (multiple-value-bind (ok start-secs start-usecs) (unix:unix-gettimeofday)
- (assert ok)
- (let ((value (funcall fn)))
- (multiple-value-bind (ok end-secs end-usecs) (unix:unix-gettimeofday)
- (assert ok)
- (values value (+ (* (- end-secs start-secs) 1000000)
- (- end-usecs start-usecs)))))))
-
(defmacro with-trapping-compilation-notes (() &body body)
`(handler-bind ((c::compiler-error #'handle-notification-condition)
(c::style-warning #'handle-notification-condition)
(c::warning #'handle-notification-condition))
, at body))
-(defun call-with-compilation-hooks (fn)
- (multiple-value-bind (result usecs)
- (with-trapping-compilation-notes ()
- (clear-compiler-notes)
- (measure-time-intervall fn))
- (list (to-string result)
- (format nil "~,2F" (/ usecs 1000000.0)))))
-
(defslimefun swank-compile-file (filename load)
(call-with-compilation-hooks
(lambda ()
@@ -555,14 +489,6 @@
(and (<= (length s1) (length s2))
(string-equal s1 s2 :end2 (length s1))))
-(defslimefun list-all-package-names ()
- (let ((list '()))
- (maphash (lambda (name package)
- (declare (ignore package))
- (pushnew name list))
- lisp::*package-names*)
- list))
-
;;;; Definitions
(defvar *debug-definition-finding* nil
@@ -693,15 +619,6 @@
(let ((y (funcall f x)))
(and y (list y)))))
-(defun apropos-symbols (string &optional external-only package)
- "Return the symbols matching an apropos search."
- (let ((symbols '()))
- (ext:map-apropos (lambda (sym)
- (unless (keywordp sym)
- (push sym symbols)))
- string package external-only)
- symbols))
-
(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
@@ -718,45 +635,22 @@
(t
(string< (package-name pa) (package-name pb)))))))
-(defun print-output-to-string (fn)
- (with-output-to-string (*standard-output*)
- (funcall fn)))
-
-(defun print-desciption-to-string (object)
- (print-output-to-string (lambda () (describe object))))
-(defslimefun describe-symbol (symbol-name)
- (print-desciption-to-string (from-string symbol-name)))
-
-(defslimefun describe-function (symbol-name)
- (print-desciption-to-string (symbol-function (from-string symbol-name))))
(defslimefun describe-setf-function (symbol-name)
- (print-desciption-to-string
+ (print-description-to-string
(or (ext:info setf inverse (from-string symbol-name))
(ext:info setf expander (from-string symbol-name)))))
(defslimefun describe-type (symbol-name)
- (print-desciption-to-string
+ (print-description-to-string
(kernel:values-specifier-type (from-string symbol-name))))
(defslimefun describe-class (symbol-name)
- (print-desciption-to-string (find-class (from-string symbol-name) nil)))
+ (print-description-to-string (find-class (from-string symbol-name) nil)))
;;; Macroexpansion
-(defun apply-macro-expander (expander string)
- (let ((*print-pretty* t)
- (*print-length* 20)
- (*print-level* 20))
- (to-string (funcall expander (from-string string)))))
-
-(defslimefun swank-macroexpand-1 (string)
- (apply-macro-expander #'macroexpand-1 string))
-
-(defslimefun swank-macroexpand (string)
- (apply-macro-expander #'macroexpand string))
-
(defslimefun swank-macroexpand-all (string)
(apply-macro-expander #'walker:macroexpand-all string))
@@ -779,9 +673,6 @@
(defslimefun untrace-all ()
(untrace))
-(defslimefun disassemble-symbol (symbol-name)
- (print-output-to-string (lambda () (disassemble (from-string symbol-name)))))
-
(defslimefun load-file (filename)
(load filename))
Index: slime/swank-openmcl.lisp
diff -u slime/swank-openmcl.lisp:1.3 slime/swank-openmcl.lisp:1.4
--- slime/swank-openmcl.lisp:1.3 Wed Oct 15 18:02:49 2003
+++ slime/swank-openmcl.lisp Wed Oct 15 18:48:30 2003
@@ -13,7 +13,7 @@
;;; The LLGPL is also available online at
;;; http://opensource.franz.com/preamble.html
;;;
-;;; $Id: swank-openmcl.lisp,v 1.3 2003/10/15 22:02:49 dbarlow Exp $
+;;; $Id: swank-openmcl.lisp,v 1.4 2003/10/15 22:48:30 dbarlow Exp $
;;;
;;;
@@ -128,7 +128,6 @@
(sldb-loop)))
(defslimefun-unimplemented interactive-eval-region (string))
-(defslimefun-unimplemented pprint-eval (string))
(defslimefun-unimplemented re-evaluate-defvar (form))
(defslimefun arglist-string (fname)
@@ -144,11 +143,6 @@
;;; Compilation
-(defvar *compiler-notes* '())
-
-(defun clear-compiler-notes ()
- (setf *compiler-notes* '()))
-
(defun condition-function-name (condition)
"Return the function name as a symbol from a compiler condition."
(symbol-name (car (ccl::compiler-warning-function-name
@@ -169,35 +163,10 @@
:buffer-offset 0)
*compiler-notes*))
-(defun unix-gettimeofday ()
- (ccl::rlet ((tv :timeval))
- (#_gettimeofday tv (ccl::%null-ptr))
- (values (ccl::pref tv :timeval.tv_sec)
- (ccl::pref tv :timeval.tv_usec))))
-
-(defun measure-time-interval (fn)
- "Call FN and return the first return value aand the elapsed time.
-The time is measured in microseconds."
- (multiple-value-bind (start-secs start-usecs)
- (unix-gettimeofday)
- (let ((value (funcall fn)))
- (multiple-value-bind (end-secs end-usecs)
- (unix-gettimeofday)
- (values value (+ (* (- end-secs start-secs) 1000000)
- (- end-usecs start-usecs)))))))
-
(defmacro with-trapping-compilation-notes (() &body body)
`(handler-bind ((ccl::compiler-warning #'handle-compiler-warning))
, at body))
-(defun call-with-compilation-hooks (fn)
- (multiple-value-bind (result usecs)
- (with-trapping-compilation-notes ()
- (clear-compiler-notes)
- (measure-time-interval fn))
- (list (to-string result)
- (format nil "~,2F" (/ usecs 1000000.0)))))
-
(defslimefun swank-compile-string (string buffer start)
(declare (ignore buffer start))
(call-with-compilation-hooks
@@ -212,8 +181,6 @@
(lambda ()
(compile-file filename :load load))))
-(defslimefun compiler-notes-for-emacs ()
- (reverse *compiler-notes*))
(defslimefun-unimplemented compiler-notes-for-file (filename))
@@ -330,20 +297,6 @@
;;; Utilities
-(defun print-output-to-string (fn)
- (with-output-to-string (*standard-output*)
- (let ((*debug-io* *standard-output*))
- (funcall fn))))
-
-(defun print-description-to-string (object)
- (print-output-to-string (lambda () (describe object))))
-
-(defslimefun describe-symbol (symbol-name)
- (print-description-to-string (from-string symbol-name)))
-
-(defslimefun describe-function (symbol-name)
- (print-description-to-string (from-string symbol-name)))
-
(defslimefun-unimplemented describe-setf-function (symbol-name))
(defslimefun-unimplemented describe-type (symbol-name))
@@ -359,14 +312,6 @@
;;; Tracing and Disassembly
-(defslimefun disassemble-symbol (symbol-name)
- (print-output-to-string
- (lambda () (disassemble (from-string symbol-name)))))
-
-;;; Cross-referencing
-
-;; I think some of these will never work in OpenMCL...
-(defslimefun-unimplemented who-calls (symbol-name package-name))
(defslimefun-unimplemented who-references (symbol-name package-name))
(defslimefun-unimplemented who-binds (symbol-name package-name))
(defslimefun-unimplemented who-sets (symbol-name package-name))
@@ -378,19 +323,7 @@
;;; Completion
(defslimefun-unimplemented completions (string default-package-name))
-(defslimefun-unimplemented list-all-package-names ())
;;; Macroexpansion
-(defun apply-macro-expander (expander string)
- (let ((*print-pretty* t)
- (*print-length* 20)
- (*print-level* 20))
- (to-string (funcall expander (from-string string)))))
-
-(defslimefun swank-macroexpand-1 (string)
- (apply-macro-expander #'macroexpand-1 string))
-
-(defslimefun swank-macroexpand (string)
- (apply-macro-expander #'macroexpand string))
(defslimefun-unimplemented swank-macroexpand-all (string))
Index: slime/swank-sbcl.lisp
diff -u slime/swank-sbcl.lisp:1.3 slime/swank-sbcl.lisp:1.4
--- slime/swank-sbcl.lisp:1.3 Wed Oct 15 18:02:49 2003
+++ slime/swank-sbcl.lisp Wed Oct 15 18:48:30 2003
@@ -132,14 +132,15 @@
;;; Utilities
(defvar *swank-debugger-condition*)
-(defvar *swank-debugger-hook*)
(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)
@@ -149,16 +150,6 @@
do (force-output)
finally (return (format nil "~{~S~^, ~}" result))))))
-(defslimefun pprint-eval (string)
- (let ((*package* *buffer-package*))
- (let ((value (eval (read-from-string string))))
- (let ((*print-pretty* t)
- (*print-circle* t)
- (*print-level* nil)
- (*print-length* nil))
- (with-output-to-string (stream)
- (pprint value stream))))))
-
(defslimefun re-evaluate-defvar (form)
(let ((*package* *buffer-package*))
(let ((form (read-from-string form)))
@@ -169,9 +160,7 @@
(makunbound name)
(prin1-to-string (eval form))))))
-(defslimefun set-package (package)
- (setq *package* (guess-package-from-string package))
- (package-name *package*))
+
;;; adapted from cmucl
(defslimefun set-default-directory (directory)
@@ -190,24 +179,6 @@
(princ-to-string arglist)
"(-- <Unknown-Function>)")))))
-;;;; Compilation Commands.
-
-(defvar *compiler-notes* '()
- "List of compiler notes for the last compilation unit.")
-
-(defun clear-compiler-notes () (setf *compiler-notes* '()))
-
-(defvar *notes-database* (make-hash-table :test #'equal)
- "Database of recorded compiler notes/warnings/erros (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, 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*))
-
(defvar *buffername*)
(defvar *buffer-offset*)
@@ -272,44 +243,12 @@
(reverse
(sb-c::compiler-error-context-original-source-path context)))))
-(defslimefun features ()
- (mapcar #'symbol-name *features*))
-
-(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*))
-
-(defun measure-time-interval (fn)
- "Call FN and return the first return value and the elapsed time.
-The time is measured in microseconds."
- (let ((before (get-internal-real-time)))
- (values
- (funcall fn)
- (* (- (get-internal-real-time) before)
- (/ 1000000 internal-time-units-per-second)))))
-
(defmacro with-trapping-compilation-notes (() &body body)
`(handler-bind ((sb-c:compiler-error #'handle-notification-condition)
(style-warning #'handle-notification-condition)
(warning #'handle-notification-condition))
, at body))
-(defun call-with-compilation-hooks (fn)
- (multiple-value-bind (result usecs)
- (with-trapping-compilation-notes ()
- (clear-compiler-notes)
- (measure-time-interval fn))
- (list (to-string result)
- (format nil "~,2F" (/ usecs 1000000.0)))))
-
(defslimefun swank-compile-file (filename load)
(call-with-compilation-hooks
(lambda ()
@@ -320,7 +259,6 @@
(ret (compile-file filename)))
(if load (load ret) ret)))))
-
(defslimefun swank-compile-string (string buffer start)
(call-with-compilation-hooks
(lambda ()
@@ -403,8 +341,7 @@
(and (<= (length s1) (length s2))
(string-equal s1 s2 :end2 (length s1))))
-(defslimefun list-all-package-names ()
- (mapcar #'package-name (list-all-packages)))
+
;;;; Definitions
@@ -508,11 +445,6 @@
(let ((y (funcall f x)))
(and y (list y)))))
-(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)))
-
(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
@@ -529,46 +461,18 @@
(t
(string< (package-name pa) (package-name pb)))))))
-(defun print-output-to-string (fn)
- (with-output-to-string (*standard-output*)
- (funcall fn)))
-
-(defun print-desciption-to-string (object)
- (print-output-to-string (lambda () (describe object))))
-
-(defslimefun describe-symbol (symbol-name)
- (print-desciption-to-string (from-string symbol-name)))
-
-(defslimefun describe-function (symbol-name)
- (print-desciption-to-string (symbol-function (from-string symbol-name))))
(defslimefun describe-setf-function (symbol-name)
- (print-desciption-to-string `(setf ,(from-string symbol-name))))
+ (print-description-to-string `(setf ,(from-string symbol-name))))
(defslimefun describe-type (symbol-name)
- (print-desciption-to-string
+ (print-description-to-string
(sb-kernel:values-specifier-type (from-string symbol-name))))
(defslimefun describe-class (symbol-name)
- (print-desciption-to-string (find-class (from-string symbol-name) nil)))
-
-;;; Macroexpansion
-
-(defun apply-macro-expander (expander string)
- (let ((*print-pretty* t)
- (*print-length* 20)
- (*print-level* 20))
- (to-string (funcall expander (from-string string)))))
+ (print-description-to-string (find-class (from-string symbol-name) nil)))
-(defslimefun swank-macroexpand-1 (string)
- (apply-macro-expander #'macroexpand-1 string))
-
-(defslimefun swank-macroexpand (string)
- (apply-macro-expander #'macroexpand string))
-
-#+nil
-(defslimefun swank-macroexpand-all (string)
- (apply-macro-expander #'sb-walker:macroexpand-all string))
+;;; macroexpansion
(defslimefun-unimplemented swank-macroexpand-all (string))
@@ -590,8 +494,7 @@
(defslimefun untrace-all ()
(untrace))
-(defslimefun disassemble-symbol (symbol-name)
- (print-output-to-string (lambda () (disassemble (from-string symbol-name)))))
+
(defslimefun load-file (filename)
(load filename))
Index: slime/swank.lisp
diff -u slime/swank.lisp:1.28 slime/swank.lisp:1.29
--- slime/swank.lisp:1.28 Wed Oct 15 18:02:49 2003
+++ slime/swank.lisp Wed Oct 15 18:48:30 2003
@@ -161,9 +161,115 @@
(force-output)
(format nil "~{~S~^, ~}" values)))
+;;; this was unimplemented in -openmcl, anyone know why?
+;;; ditto interactive-eval-region
+(defslimefun pprint-eval (string)
+ (let ((*package* *buffer-package*))
+ (let ((value (eval (read-from-string string))))
+ (let ((*print-pretty* t)
+ (*print-circle* t)
+ (*print-level* nil)
+ #+cmu (ext:*gc-verbose* nil)
+ (*print-length* nil))
+ (with-output-to-string (stream)
+ (pprint value stream))))))
+(defslimefun set-package (package)
+ (setq *package* (guess-package-from-string package))
+ (package-name *package*))
+;;;; Compilation Commands.
+
+(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/erros (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, 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*))
+
+(defslimefun features ()
+ (mapcar #'symbol-name *features*))
+
+(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*))
+
+(defun measure-time-interval (fn)
+ "Call FN and return the first return value and the elapsed time.
+The time is measured in microseconds."
+ (let ((before (get-internal-real-time)))
+ (values
+ (funcall fn)
+ (* (- (get-internal-real-time) before)
+ (/ 1000000 internal-time-units-per-second)))))
+
+(defun call-with-compilation-hooks (fn)
+ (multiple-value-bind (result usecs)
+ (with-trapping-compilation-notes ()
+ (clear-compiler-notes)
+ (measure-time-interval fn))
+ (list (to-string result)
+ (format nil "~,2F" (/ usecs 1000000.0)))))
+
+(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)))
+
+
+(defun print-output-to-string (fn)
+ (with-output-to-string (*standard-output*)
+ (let ((*debug-io* *standard-output*))
+ (funcall fn))))
+
+(defun print-description-to-string (object)
+ (print-output-to-string (lambda () (describe object))))
+
+(defslimefun describe-symbol (symbol-name)
+ (print-description-to-string (from-string symbol-name)))
+
+(defslimefun describe-function (symbol-name)
+ (print-description-to-string (symbol-function (from-string symbol-name))))
+
+;;; Macroexpansion
+
+(defun apply-macro-expander (expander string)
+ (let ((*print-pretty* t)
+ (*print-length* 20)
+ (*print-level* 20))
+ (to-string (funcall expander (from-string string)))))
+
+(defslimefun swank-macroexpand-1 (string)
+ (apply-macro-expander #'macroexpand-1 string))
+
+(defslimefun swank-macroexpand (string)
+ (apply-macro-expander #'macroexpand string))
+
+(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*))
More information about the slime-cvs
mailing list