[slime-cvs] CVS update: slime/swank-corman.lisp slime/ChangeLog
Espen Wiborg
ewiborg at common-lisp.net
Tue Jun 7 10:08:06 UTC 2005
Update of /project/slime/cvsroot/slime
In directory common-lisp.net:/tmp/cvs-serv10937
Modified Files:
swank-corman.lisp ChangeLog
Log Message:
Convert to Unix line-endings.
(create-socket): Pass through the port argument unmodified,
gettting a random port if 0. Requires supporting change in
<ccl>/modules/sockets.lisp.
(inspect-for-emacs): defimplementation instead of defmethod.
Date: Tue Jun 7 12:08:05 2005
Author: ewiborg
Index: slime/swank-corman.lisp
diff -u slime/swank-corman.lisp:1.1 slime/swank-corman.lisp:1.2
--- slime/swank-corman.lisp:1.1 Tue May 31 20:36:52 2005
+++ slime/swank-corman.lisp Tue Jun 7 12:08:03 2005
@@ -1,477 +1,479 @@
-;;;
-;;; swank-corman.lisp --- Corman Lisp specific code for SLIME.
-;;;
-;;; Copyright (C) 2004, 2005 Espen Wiborg (espenhw at grumblesmurf.org)
-;;;
-;;; License
-;;; =======
-;;; This software is provided 'as-is', without any express or implied
-;;; warranty. In no event will the author be held liable for any damages
-;;; arising from the use of this software.
-;;;
-;;; Permission is granted to anyone to use this software for any purpose,
-;;; including commercial applications, and to alter it and redistribute
-;;; it freely, subject to the following restrictions:
-;;;
-;;; 1. The origin of this software must not be misrepresented; you must
-;;; not claim that you wrote the original software. If you use this
-;;; software in a product, an acknowledgment in the product documentation
-;;; would be appreciated but is not required.
-;;;
-;;; 2. Altered source versions must be plainly marked as such, and must
-;;; not be misrepresented as being the original software.
-;;;
-;;; 3. This notice may not be removed or altered from any source
-;;; distribution.
-;;;
-;;; Notes
-;;; =====
-;;; You will need CCL 2.51, and you will *definitely* need to patch
-;;; CCL with the patches at
-;;; http://www.grumblesmurf.org/lisp/corman-patches, otherwise SLIME
-;;; will blow up in your face. You should also follow the
-;;; instructions on http://www.grumblesmurf.org/lisp/corman-slime.
-;;;
-;;; The only communication style currently supported is NIL.
-;;;
-;;; Starting CCL inside emacs (with M-x slime) seems to work for me
-;;; with Corman Lisp 2.51, but I have seen random failures with 2.5
-;;; (sometimes it works, other times it hangs on start or hangs when
-;;; initializing WinSock) - starting CCL externally and using M-x
-;;; slime-connect always works fine.
-;;;
-;;; Sometimes CCL gets confused and starts giving you random memory access violation errors on startup; if this happens,
-;;;
-;;; What works
-;;; ==========
-;;; * Basic editing and evaluation
-;;; * Arglist display
-;;; * Compilation
-;;; * Loading files
-;;; * apropos/describe
-;;; * Debugger
-;;; * Inspector
-;;;
-;;; TODO
-;;; ====
-;;; * More debugger functionality (missing bits: restart-frame,
-;;; return-from-frame, disassemble-frame, activate-stepping,
-;;; toggle-trace)
-;;; * XREF
-;;; * Profiling
-;;; * More sophisticated communication styles than NIL
-;;;
-
-(in-package :swank-backend)
-
-;;; Pull in various needed bits
-(require :composite-streams)
-(require :sockets)
-(require :winbase)
-(require :lp)
-
-(use-package :gs)
-
-;; MOP stuff
-
-(defclass swank-mop:standard-slot-definition ()
- ()
- (:documentation "Dummy class created so that swank.lisp will compile and load."))
-
-(defun named-by-gensym-p (c)
- (null (symbol-package (class-name c))))
-
-(deftype swank-mop:eql-specializer ()
- '(satisfies named-by-gensym-p))
-
-(defun swank-mop:eql-specializer-object (specializer)
- (with-hash-table-iterator (next-entry cl::*clos-singleton-specializers*)
- (loop (multiple-value-bind (more key value)
- (next-entry)
- (unless more (return nil))
- (when (eq specializer value)
- (return key))))))
-
-(defun swank-mop:class-finalized-p (class)
- (declare (ignore class))
- t)
-
-(defun swank-mop:class-prototype (class)
- (make-instance class))
-
-(defun swank-mop:specializer-direct-methods (obj)
- (declare (ignore obj))
- nil)
-
-(defun swank-mop:generic-function-argument-precedence-order (gf)
- (generic-function-lambda-list gf))
-
-(defun swank-mop:generic-function-method-combination (gf)
- (declare (ignore gf))
- :standard)
-
-(defun swank-mop:generic-function-declarations (gf)
- (declare (ignore gf))
- nil)
-
-(defun swank-mop:slot-definition-documentation (slot)
- (declare (ignore slot))
- (getf slot :documentation nil))
-
-(defun swank-mop:slot-definition-type (slot)
- (declare (ignore slot))
- t)
-
-(import-swank-mop-symbols :cl '(;; classes
- :standard-slot-definition
- :eql-specializer
- :eql-specializer-object
- ;; standard class readers
- :class-default-initargs
- :class-direct-default-initargs
- :class-finalized-p
- :class-prototype
- :specializer-direct-methods
- ;; gf readers
- :generic-function-argument-precedence-order
- :generic-function-declarations
- :generic-function-method-combination
- ;; method readers
- ;; slot readers
- :slot-definition-documentation
- :slot-definition-type))
-
-;;;; swank implementations
-
-;;; Debugger
-
-(defvar *stack-trace* nil)
-(defvar *frame-trace* nil)
-
-(defstruct frame
- name function address debug-info variables)
-
-(defimplementation call-with-debugging-environment (fn)
- (let* ((real-stack-trace (cl::stack-trace))
- (*stack-trace* (cdr (member 'cl:invoke-debugger real-stack-trace
- :key #'car)))
- (*frame-trace*
- (let* ((db::*debug-level* 1)
- (db::*debug-frame-pointer* (db::stash-ebp
- (ct:create-foreign-ptr)))
- (db::*debug-max-level* (length real-stack-trace))
- (db::*debug-min-level* 1))
- (cdr (member #'cl:invoke-debugger
- (cons
- (make-frame :function nil)
- (loop for i from db::*debug-min-level*
- upto db::*debug-max-level*
- until (eq (db::get-frame-function i) cl::*top-level*)
- collect
- (make-frame :function (db::get-frame-function i)
- :address (db::get-frame-address i))))
- :key #'frame-function)))))
- (funcall fn)))
-
-(defimplementation compute-backtrace (start end)
- (subseq *stack-trace* start (min end (length *stack-trace*))))
-
-(defimplementation print-frame (frame stream)
- (format stream "~S" frame))
-
-(defun get-frame-debug-info (frame)
- (let ((info (frame-debug-info frame)))
- (if info
- info
- (setf (frame-debug-info frame)
- (db::prepare-frame-debug-info (frame-function frame)
- (frame-address frame))))))
-
-(defimplementation frame-locals (frame-number)
- (let* ((frame (elt *frame-trace* frame-number))
- (info (get-frame-debug-info frame)))
- (let ((var-list
- (loop for i from 4 below (length info) by 2
- collect `(list :name ',(svref info i) :id 0
- :value (db::debug-filter ,(svref info i))))))
- (let ((vars (eval-in-frame `(list , at var-list) frame-number)))
- (setf (frame-variables frame) vars)))))
-
-(defimplementation eval-in-frame (form frame-number)
- (let ((frame (elt *frame-trace* frame-number)))
- (let ((cl::*compiler-environment* (get-frame-debug-info frame)))
- (eval form))))
-
-(defimplementation frame-catch-tags (index)
- (declare (ignore index))
- nil)
-
-(defimplementation frame-var-value (frame-number var)
- (let ((vars (frame-variables (elt *frame-trace* frame-number))))
- (when vars
- (second (elt vars var)))))
-
-(defimplementation frame-source-location-for-emacs (frame-number)
- (fspec-location (frame-function (elt *frame-trace* frame-number))))
-
-;;; Socket communication
-
-(defimplementation create-socket (host port)
- (sockets:start-sockets)
- (sockets:make-server-socket :host host :port (if (zerop port) 4005 port)))
-
-(defimplementation local-port (socket)
- (sockets:socket-port socket))
-
-(defimplementation close-socket (socket)
- (close socket))
-
-(defimplementation accept-connection (socket
- &key (external-format :iso-latin-1-unix))
- (ecase external-format
- (:iso-latin-1-unix
- (sockets:make-socket-stream (sockets:accept-socket socket)))))
-
-;;; Misc
-
-(defimplementation preferred-communication-style ()
- nil)
-
-(defimplementation getpid ()
- ccl:*current-process-id*)
-
-(defimplementation lisp-implementation-type-name ()
- "cormanlisp")
-
-(defimplementation quit-lisp ()
- (sockets:stop-sockets)
- (win32:exitprocess 0))
-
-(defimplementation set-default-directory (directory)
- (setf (ccl:current-directory) directory)
- (directory-namestring (setf *default-pathname-defaults*
- (truename (merge-pathnames directory)))))
-
-(defimplementation default-directory ()
- (ccl:current-directory))
-
-(defimplementation macroexpand-all (form)
- (ccl:macroexpand-all form))
-
-;;; Documentation
-
-(defun fspec-location (fspec)
- (when (symbolp fspec)
- (setq fspec (symbol-function fspec)))
- (let ((file (ccl::function-source-file fspec)))
- (if file
- (handler-case
- (let ((truename (truename
- (merge-pathnames file
- ccl:*cormanlisp-directory*))))
- (make-location (list :file (namestring truename))
- (if (ccl::function-source-line fspec)
- (list :line (ccl::function-source-line fspec))
- (list :function-name (princ-to-string
- (function-name fspec))))))
- (error (c) (list :error (princ-to-string c))))
- (list :error (format nil "No source information available for ~S"
- fspec)))))
-
-(defimplementation find-definitions (name)
- (list (list name (fspec-location name))))
-
-(defimplementation arglist (name)
- (handler-case
- (cond ((and (symbolp name)
- (macro-function name))
- (ccl::macro-lambda-list (symbol-function name)))
- (t
- (when (symbolp name)
- (setq name (symbol-function name)))
- (if (eq (class-of name) cl::the-class-standard-gf)
- (generic-function-lambda-list name)
- (ccl:function-lambda-list name))))
- (error () :not-available)))
-
-(defimplementation function-name (fn)
- (handler-case (getf (cl::function-info-list fn) 'cl::function-name)
- (error () nil)))
-
-(defimplementation describe-symbol-for-emacs (symbol)
- (let ((result '()))
- (flet ((doc (kind &optional (sym symbol))
- (or (documentation sym kind) :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
- :class (if (find-class symbol nil)
- (doc 'class)))
- result)))
-
-(defimplementation describe-definition (symbol namespace)
- (ecase namespace
- (:variable
- (describe symbol))
- ((:function :generic-function)
- (describe (symbol-function symbol)))
- (:class
- (describe (find-class symbol)))))
-
-;;; Compiler
-
-(defvar *buffer-name* nil)
-(defvar *buffer-position*)
-(defvar *buffer-string*)
-(defvar *compile-filename* nil)
-
-;; FIXME
-(defimplementation call-with-compilation-hooks (FN)
- (handler-bind ((error (lambda (c)
- (signal (make-condition
- 'compiler-condition
- :original-condition c
- :severity :warning
- :message (format nil "~A" c)
- :location
- (cond (*buffer-name*
- (make-location
- (list :buffer *buffer-name*)
- (list :position *buffer-position*)))
- (*compile-filename*
- (make-location
- (list :file *compile-filename*)
- (list :position 1)))
- (t
- (list :error "No location"))))))))
- (funcall fn)))
-
-(defimplementation swank-compile-file (*compile-filename* load-p)
- (with-compilation-hooks ()
- (let ((*buffer-name* nil))
- (compile-file *compile-filename*)
- (when load-p
- (load (compile-file-pathname *compile-filename*))))))
-
-(defimplementation swank-compile-string (string &key buffer position directory)
- (declare (ignore directory))
- (with-compilation-hooks ()
- (let ((*buffer-name* buffer)
- (*buffer-position* position)
- (*buffer-string* string))
- (funcall (compile nil (read-from-string
- (format nil "(~S () ~A)" 'lambda string)))))))
-
-;;;; Inspecting
-
-(defclass corman-inspector (inspector)
- ())
-
-(defimplementation make-default-inspector ()
- (make-instance 'corman-inspector))
-
-(defun comma-separated (list &optional (callback (lambda (v)
- `(:value ,v))))
- (butlast (loop for e in list
- collect (funcall callback e)
- collect ", ")))
-
-(defmethod inspect-for-emacs ((class standard-class)
- (inspector corman-inspector))
- (declare (ignore inspector))
- (values "A class."
- `("Name: " (:value ,(class-name class))
- (:newline)
- "Super classes: "
- ,@(comma-separated (swank-mop:class-direct-superclasses class))
- (:newline)
- "Direct Slots: "
- ,@(comma-separated
- (swank-mop:class-direct-slots class)
- (lambda (slot)
- `(:value ,slot ,(princ-to-string (swank-mop:slot-definition-name slot)))))
- (:newline)
- "Effective Slots: "
- ,@(if (swank-mop:class-finalized-p class)
- (comma-separated
- (swank-mop:class-slots class)
- (lambda (slot)
- `(:value ,slot ,(princ-to-string
- (swank-mop:slot-definition-name slot)))))
- '("#<N/A (class not finalized)>"))
- (:newline)
- ,@(when (documentation class t)
- `("Documentation:" (:newline) ,(documentation class t) (:newline)))
- "Sub classes: "
- ,@(comma-separated (swank-mop:class-direct-subclasses class)
- (lambda (sub)
- `(:value ,sub ,(princ-to-string (class-name sub)))))
- (:newline)
- "Precedence List: "
- ,@(if (swank-mop:class-finalized-p class)
- (comma-separated (swank-mop:class-precedence-list class)
- (lambda (class)
- `(:value ,class ,(princ-to-string (class-name class)))))
- '("#<N/A (class not finalized)>"))
- (:newline))))
-
-(defmethod inspect-for-emacs ((slot cons) (inspector corman-inspector))
- ;; Inspects slot definitions
- (declare (ignore corman-inspector))
- (if (eq (car slot) :name)
- (values "A slot."
- `("Name: " (:value ,(swank-mop:slot-definition-name slot))
- (:newline)
- ,@(when (swank-mop:slot-definition-documentation slot)
- `("Documentation:" (:newline)
- (:value ,(swank-mop:slot-definition-documentation slot))
- (:newline)))
- "Init args: " (:value ,(swank-mop:slot-definition-initargs slot)) (:newline)
- "Init form: " ,(if (swank-mop:slot-definition-initfunction slot)
- `(:value ,(swank-mop:slot-definition-initform slot))
- "#<unspecified>") (:newline)
- "Init function: " (:value ,(swank-mop:slot-definition-initfunction slot))
- (:newline)))
- (call-next-method)))
-
-(defmethod inspect-for-emacs ((pathname pathnames::pathname-internal)
- inspector)
- (declare (ignore inspector))
- (values (if (wild-pathname-p pathname)
- "A wild pathname."
- "A pathname.")
- (append (label-value-line*
- ("Namestring" (namestring pathname))
- ("Host" (pathname-host pathname))
- ("Device" (pathname-device pathname))
- ("Directory" (pathname-directory pathname))
- ("Name" (pathname-name pathname))
- ("Type" (pathname-type pathname))
- ("Version" (pathname-version pathname)))
- (unless (or (wild-pathname-p pathname)
- (not (probe-file pathname)))
- (label-value-line "Truename" (truename pathname))))))
-
-;;; This is probably not good, but it WFM
-(in-package :common-lisp)
-
-(defvar *old-documentation* #'documentation)
-(defun documentation (thing &optional (type 'function))
- (if (symbolp thing)
- (funcall *old-documentation* thing type)
- (values)))
-
-(defmethod print-object ((restart restart) stream)
- (if (or *print-escape*
- *print-readably*)
- (print-unreadable-object (restart stream :type t :identity t)
- (princ (restart-name restart) stream))
- (when (functionp (restart-report-function restart))
- (funcall (restart-report-function restart) stream))))
+;;;
+;;; swank-corman.lisp --- Corman Lisp specific code for SLIME.
+;;;
+;;; Copyright (C) 2004, 2005 Espen Wiborg (espenhw at grumblesmurf.org)
+;;;
+;;; License
+;;; =======
+;;; This software is provided 'as-is', without any express or implied
+;;; warranty. In no event will the author be held liable for any damages
+;;; arising from the use of this software.
+;;;
+;;; Permission is granted to anyone to use this software for any purpose,
+;;; including commercial applications, and to alter it and redistribute
+;;; it freely, subject to the following restrictions:
+;;;
+;;; 1. The origin of this software must not be misrepresented; you must
+;;; not claim that you wrote the original software. If you use this
+;;; software in a product, an acknowledgment in the product documentation
+;;; would be appreciated but is not required.
+;;;
+;;; 2. Altered source versions must be plainly marked as such, and must
+;;; not be misrepresented as being the original software.
+;;;
+;;; 3. This notice may not be removed or altered from any source
+;;; distribution.
+;;;
+;;; Notes
+;;; =====
+;;; You will need CCL 2.51, and you will *definitely* need to patch
+;;; CCL with the patches at
+;;; http://www.grumblesmurf.org/lisp/corman-patches, otherwise SLIME
+;;; will blow up in your face. You should also follow the
+;;; instructions on http://www.grumblesmurf.org/lisp/corman-slime.
+;;;
+;;; The only communication style currently supported is NIL.
+;;;
+;;; Starting CCL inside emacs (with M-x slime) seems to work for me
+;;; with Corman Lisp 2.51, but I have seen random failures with 2.5
+;;; (sometimes it works, other times it hangs on start or hangs when
+;;; initializing WinSock) - starting CCL externally and using M-x
+;;; slime-connect always works fine.
+;;;
+;;; Sometimes CCL gets confused and starts giving you random memory
+;;; access violation errors on startup; if this happens, try redumping
+;;; your image.
+;;;
+;;; What works
+;;; ==========
+;;; * Basic editing and evaluation
+;;; * Arglist display
+;;; * Compilation
+;;; * Loading files
+;;; * apropos/describe
+;;; * Debugger
+;;; * Inspector
+;;;
+;;; TODO
+;;; ====
+;;; * More debugger functionality (missing bits: restart-frame,
+;;; return-from-frame, disassemble-frame, activate-stepping,
+;;; toggle-trace)
+;;; * XREF
+;;; * Profiling
+;;; * More sophisticated communication styles than NIL
+;;;
+
+(in-package :swank-backend)
+
+;;; Pull in various needed bits
+(require :composite-streams)
+(require :sockets)
+(require :winbase)
+(require :lp)
+
+(use-package :gs)
+
+;; MOP stuff
+
+(defclass swank-mop:standard-slot-definition ()
+ ()
+ (:documentation "Dummy class created so that swank.lisp will compile and load."))
+
+(defun named-by-gensym-p (c)
+ (null (symbol-package (class-name c))))
+
+(deftype swank-mop:eql-specializer ()
+ '(satisfies named-by-gensym-p))
+
+(defun swank-mop:eql-specializer-object (specializer)
+ (with-hash-table-iterator (next-entry cl::*clos-singleton-specializers*)
+ (loop (multiple-value-bind (more key value)
+ (next-entry)
+ (unless more (return nil))
+ (when (eq specializer value)
+ (return key))))))
+
+(defun swank-mop:class-finalized-p (class)
+ (declare (ignore class))
+ t)
+
+(defun swank-mop:class-prototype (class)
+ (make-instance class))
+
+(defun swank-mop:specializer-direct-methods (obj)
+ (declare (ignore obj))
+ nil)
+
+(defun swank-mop:generic-function-argument-precedence-order (gf)
+ (generic-function-lambda-list gf))
+
+(defun swank-mop:generic-function-method-combination (gf)
+ (declare (ignore gf))
+ :standard)
+
+(defun swank-mop:generic-function-declarations (gf)
+ (declare (ignore gf))
+ nil)
+
+(defun swank-mop:slot-definition-documentation (slot)
+ (declare (ignore slot))
+ (getf slot :documentation nil))
+
+(defun swank-mop:slot-definition-type (slot)
+ (declare (ignore slot))
+ t)
+
+(import-swank-mop-symbols :cl '(;; classes
+ :standard-slot-definition
+ :eql-specializer
+ :eql-specializer-object
+ ;; standard class readers
+ :class-default-initargs
+ :class-direct-default-initargs
+ :class-finalized-p
+ :class-prototype
+ :specializer-direct-methods
+ ;; gf readers
+ :generic-function-argument-precedence-order
+ :generic-function-declarations
+ :generic-function-method-combination
+ ;; method readers
+ ;; slot readers
+ :slot-definition-documentation
+ :slot-definition-type))
+
+;;;; swank implementations
+
+;;; Debugger
+
+(defvar *stack-trace* nil)
+(defvar *frame-trace* nil)
+
+(defstruct frame
+ name function address debug-info variables)
+
+(defimplementation call-with-debugging-environment (fn)
+ (let* ((real-stack-trace (cl::stack-trace))
+ (*stack-trace* (cdr (member 'cl:invoke-debugger real-stack-trace
+ :key #'car)))
+ (*frame-trace*
+ (let* ((db::*debug-level* 1)
+ (db::*debug-frame-pointer* (db::stash-ebp
+ (ct:create-foreign-ptr)))
+ (db::*debug-max-level* (length real-stack-trace))
+ (db::*debug-min-level* 1))
+ (cdr (member #'cl:invoke-debugger
+ (cons
+ (make-frame :function nil)
+ (loop for i from db::*debug-min-level*
+ upto db::*debug-max-level*
+ until (eq (db::get-frame-function i) cl::*top-level*)
+ collect
+ (make-frame :function (db::get-frame-function i)
+ :address (db::get-frame-address i))))
+ :key #'frame-function)))))
+ (funcall fn)))
+
+(defimplementation compute-backtrace (start end)
+ (subseq *stack-trace* start (min end (length *stack-trace*))))
+
+(defimplementation print-frame (frame stream)
+ (format stream "~S" frame))
+
+(defun get-frame-debug-info (frame)
+ (let ((info (frame-debug-info frame)))
+ (if info
+ info
+ (setf (frame-debug-info frame)
+ (db::prepare-frame-debug-info (frame-function frame)
+ (frame-address frame))))))
+
+(defimplementation frame-locals (frame-number)
+ (let* ((frame (elt *frame-trace* frame-number))
+ (info (get-frame-debug-info frame)))
+ (let ((var-list
+ (loop for i from 4 below (length info) by 2
+ collect `(list :name ',(svref info i) :id 0
+ :value (db::debug-filter ,(svref info i))))))
+ (let ((vars (eval-in-frame `(list , at var-list) frame-number)))
+ (setf (frame-variables frame) vars)))))
+
+(defimplementation eval-in-frame (form frame-number)
+ (let ((frame (elt *frame-trace* frame-number)))
+ (let ((cl::*compiler-environment* (get-frame-debug-info frame)))
+ (eval form))))
+
+(defimplementation frame-catch-tags (index)
+ (declare (ignore index))
+ nil)
+
+(defimplementation frame-var-value (frame-number var)
+ (let ((vars (frame-variables (elt *frame-trace* frame-number))))
+ (when vars
+ (second (elt vars var)))))
+
+(defimplementation frame-source-location-for-emacs (frame-number)
+ (fspec-location (frame-function (elt *frame-trace* frame-number))))
+
+;;; Socket communication
+
+(defimplementation create-socket (host port)
+ (sockets:start-sockets)
+ (sockets:make-server-socket :host host :port port))
+
+(defimplementation local-port (socket)
+ (sockets:socket-port socket))
+
+(defimplementation close-socket (socket)
+ (close socket))
+
+(defimplementation accept-connection (socket
+ &key (external-format :iso-latin-1-unix))
+ (ecase external-format
+ (:iso-latin-1-unix
+ (sockets:make-socket-stream (sockets:accept-socket socket)))))
+
+;;; Misc
+
+(defimplementation preferred-communication-style ()
+ nil)
+
+(defimplementation getpid ()
+ ccl:*current-process-id*)
+
+(defimplementation lisp-implementation-type-name ()
+ "cormanlisp")
+
+(defimplementation quit-lisp ()
+ (sockets:stop-sockets)
+ (win32:exitprocess 0))
+
+(defimplementation set-default-directory (directory)
+ (setf (ccl:current-directory) directory)
+ (directory-namestring (setf *default-pathname-defaults*
+ (truename (merge-pathnames directory)))))
+
+(defimplementation default-directory ()
+ (ccl:current-directory))
+
+(defimplementation macroexpand-all (form)
+ (ccl:macroexpand-all form))
+
+;;; Documentation
+
+(defun fspec-location (fspec)
+ (when (symbolp fspec)
+ (setq fspec (symbol-function fspec)))
+ (let ((file (ccl::function-source-file fspec)))
+ (if file
+ (handler-case
+ (let ((truename (truename
+ (merge-pathnames file
+ ccl:*cormanlisp-directory*))))
+ (make-location (list :file (namestring truename))
+ (if (ccl::function-source-line fspec)
+ (list :line (ccl::function-source-line fspec))
+ (list :function-name (princ-to-string
+ (function-name fspec))))))
+ (error (c) (list :error (princ-to-string c))))
+ (list :error (format nil "No source information available for ~S"
+ fspec)))))
+
+(defimplementation find-definitions (name)
+ (list (list name (fspec-location name))))
+
+(defimplementation arglist (name)
+ (handler-case
+ (cond ((and (symbolp name)
+ (macro-function name))
+ (ccl::macro-lambda-list (symbol-function name)))
+ (t
+ (when (symbolp name)
+ (setq name (symbol-function name)))
+ (if (eq (class-of name) cl::the-class-standard-gf)
+ (generic-function-lambda-list name)
+ (ccl:function-lambda-list name))))
+ (error () :not-available)))
+
+(defimplementation function-name (fn)
+ (handler-case (getf (cl::function-info-list fn) 'cl::function-name)
+ (error () nil)))
+
+(defimplementation describe-symbol-for-emacs (symbol)
+ (let ((result '()))
+ (flet ((doc (kind &optional (sym symbol))
+ (or (documentation sym kind) :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
+ :class (if (find-class symbol nil)
+ (doc 'class)))
+ result)))
+
+(defimplementation describe-definition (symbol namespace)
+ (ecase namespace
+ (:variable
+ (describe symbol))
+ ((:function :generic-function)
+ (describe (symbol-function symbol)))
+ (:class
+ (describe (find-class symbol)))))
+
+;;; Compiler
+
+(defvar *buffer-name* nil)
+(defvar *buffer-position*)
+(defvar *buffer-string*)
+(defvar *compile-filename* nil)
+
+;; FIXME
+(defimplementation call-with-compilation-hooks (FN)
+ (handler-bind ((error (lambda (c)
+ (signal (make-condition
+ 'compiler-condition
+ :original-condition c
+ :severity :warning
+ :message (format nil "~A" c)
+ :location
+ (cond (*buffer-name*
+ (make-location
+ (list :buffer *buffer-name*)
+ (list :position *buffer-position*)))
+ (*compile-filename*
+ (make-location
+ (list :file *compile-filename*)
+ (list :position 1)))
+ (t
+ (list :error "No location"))))))))
+ (funcall fn)))
+
+(defimplementation swank-compile-file (*compile-filename* load-p)
+ (with-compilation-hooks ()
+ (let ((*buffer-name* nil))
+ (compile-file *compile-filename*)
+ (when load-p
+ (load (compile-file-pathname *compile-filename*))))))
+
+(defimplementation swank-compile-string (string &key buffer position directory)
+ (declare (ignore directory))
+ (with-compilation-hooks ()
+ (let ((*buffer-name* buffer)
+ (*buffer-position* position)
+ (*buffer-string* string))
+ (funcall (compile nil (read-from-string
+ (format nil "(~S () ~A)" 'lambda string)))))))
+
+;;;; Inspecting
+
+(defclass corman-inspector (inspector)
+ ())
+
+(defimplementation make-default-inspector ()
+ (make-instance 'corman-inspector))
+
+(defun comma-separated (list &optional (callback (lambda (v)
+ `(:value ,v))))
+ (butlast (loop for e in list
+ collect (funcall callback e)
+ collect ", ")))
+
+(defimplementation inspect-for-emacs ((class standard-class)
+ (inspector corman-inspector))
+ (declare (ignore inspector))
+ (values "A class."
+ `("Name: " (:value ,(class-name class))
+ (:newline)
+ "Super classes: "
+ ,@(comma-separated (swank-mop:class-direct-superclasses class))
+ (:newline)
+ "Direct Slots: "
+ ,@(comma-separated
+ (swank-mop:class-direct-slots class)
+ (lambda (slot)
+ `(:value ,slot ,(princ-to-string (swank-mop:slot-definition-name slot)))))
+ (:newline)
+ "Effective Slots: "
+ ,@(if (swank-mop:class-finalized-p class)
+ (comma-separated
+ (swank-mop:class-slots class)
+ (lambda (slot)
+ `(:value ,slot ,(princ-to-string
+ (swank-mop:slot-definition-name slot)))))
+ '("#<N/A (class not finalized)>"))
+ (:newline)
+ ,@(when (documentation class t)
+ `("Documentation:" (:newline) ,(documentation class t) (:newline)))
+ "Sub classes: "
+ ,@(comma-separated (swank-mop:class-direct-subclasses class)
+ (lambda (sub)
+ `(:value ,sub ,(princ-to-string (class-name sub)))))
+ (:newline)
+ "Precedence List: "
+ ,@(if (swank-mop:class-finalized-p class)
+ (comma-separated (swank-mop:class-precedence-list class)
+ (lambda (class)
+ `(:value ,class ,(princ-to-string (class-name class)))))
+ '("#<N/A (class not finalized)>"))
+ (:newline))))
+
+(defimplementation inspect-for-emacs ((slot cons) (inspector corman-inspector))
+ ;; Inspects slot definitions
+ (declare (ignore corman-inspector))
+ (if (eq (car slot) :name)
+ (values "A slot."
+ `("Name: " (:value ,(swank-mop:slot-definition-name slot))
+ (:newline)
+ ,@(when (swank-mop:slot-definition-documentation slot)
+ `("Documentation:" (:newline)
+ (:value ,(swank-mop:slot-definition-documentation slot))
+ (:newline)))
+ "Init args: " (:value ,(swank-mop:slot-definition-initargs slot)) (:newline)
+ "Init form: " ,(if (swank-mop:slot-definition-initfunction slot)
+ `(:value ,(swank-mop:slot-definition-initform slot))
+ "#<unspecified>") (:newline)
+ "Init function: " (:value ,(swank-mop:slot-definition-initfunction slot))
+ (:newline)))
+ (call-next-method)))
+
+(defimplementation inspect-for-emacs ((pathname pathnames::pathname-internal)
+ inspector)
+ (declare (ignore inspector))
+ (values (if (wild-pathname-p pathname)
+ "A wild pathname."
+ "A pathname.")
+ (append (label-value-line*
+ ("Namestring" (namestring pathname))
+ ("Host" (pathname-host pathname))
+ ("Device" (pathname-device pathname))
+ ("Directory" (pathname-directory pathname))
+ ("Name" (pathname-name pathname))
+ ("Type" (pathname-type pathname))
+ ("Version" (pathname-version pathname)))
+ (unless (or (wild-pathname-p pathname)
+ (not (probe-file pathname)))
+ (label-value-line "Truename" (truename pathname))))))
+
+;;; This is probably not good, but it WFM
+(in-package :common-lisp)
+
+(defvar *old-documentation* #'documentation)
+(defun documentation (thing &optional (type 'function))
+ (if (symbolp thing)
+ (funcall *old-documentation* thing type)
+ (values)))
+
+(defmethod print-object ((restart restart) stream)
+ (if (or *print-escape*
+ *print-readably*)
+ (print-unreadable-object (restart stream :type t :identity t)
+ (princ (restart-name restart) stream))
+ (when (functionp (restart-report-function restart))
+ (funcall (restart-report-function restart) stream))))
Index: slime/ChangeLog
diff -u slime/ChangeLog:1.708 slime/ChangeLog:1.709
--- slime/ChangeLog:1.708 Fri Jun 3 22:00:28 2005
+++ slime/ChangeLog Tue Jun 7 12:08:04 2005
@@ -1,3 +1,15 @@
+2005-06-07 Espen Wiborg <espenhw at grumblesmurf.org>
+
+ * swank-corman.lisp: Convert to Unix line-endings.
+ (create-socket): Pass through the port argument unmodified,
+ gettting a random port if 0. Requires supporting change in
+ <ccl>/modules/sockets.lisp.
+ (inspect-for-emacs): defimplementation instead of defmethod.
+
+2005-06-06 Espen Wiborg <espenhw at grumblesmurf.org>
+
+ * doc/slime.texi, PROBLEMS: Added notes about CCL.
+
2005-06-03 Helmut Eller <heller at common-lisp.net>
* slime.el (slime-background-activities-enabled-p): Allow
More information about the slime-cvs
mailing list