[slime-devel] swank-clisp, bug report, stream encoding proposal, and a few bugfixes
sedachv
sedachv at cpsc.ucalgary.ca
Fri Jan 2 00:59:18 UTC 2004
On Wed, Dec 31, 2003 at 07:43:18AM +0100, Wolfgang Jenkner wrote:
> sedachv <sedachv at cpsc.ucalgary.ca> writes:
>
> > I've gotten the swank backend mostly working on CLISP.
>
> Me too :-) For purposes of comparison:
>
> http://members.inode.at/wjenkner/clisp/swank-clisp.lisp
>
> There is support for frame locals, the portable xref and some proof of
> concept support for compiler notes. On the other hand, you have given
> more thought to the socket interface. Perhaps we could combine our
> efforts.
Excellent! It looks like your debugging code is a lot better than
mine, and I didn't even know there was a portable xref. I threw a
quick cut-and-paste job together that somewhat works. It's attached,
and distributed under the GPL (since most of it is your code, and I
just realized I should have put my previous version under the GPL too
since it is technically an extension to CLISP). One thing to note is
that under CLISP 2.32, trying to compile a file from SLIME causes this
error: "NO-APPLICABLE-METHOD: When calling #<GENERIC-FUNCTION
SWANK::MESSAGE> with arguments (NIL), no method is applicable." The
backtrace is a little hairy, and I've decided not to look into it
right now.
> My set of patches for the other files is at
>
> http://members.inode.at/wjenkner/clisp/slime.diff
>
> By the way, with my version I didn't run into the problem with symbol
> completion you described (I use the current CVS version of CLISP).
Hmm, it seems that I'm doing something wrong in my code (possibly
stemming from stream-handling). Your version seems to work just fine
(I did just upgrade to 2.32, but mine still fails with the same error
as before; in particular it says: "Illegal START index <1+ (length
string)> for <string>" for any completion string it tries to
get). Same thing for the attached file.
> Wolfgang
Vladimir
-------------- next part --------------
;;; SWANK for CLISP
;;; Copyright (C) 2003 W. Jenkner, V. Sedach
;;;; This file is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published
;;;; by the Free Software Foundation; either version 2, or (at your
;;;; option) any later version.
(in-package "SWANK")
(defparameter *xref-load-path* "~/.emacs.d/slime/xref")
(eval-when (:compile-toplevel :load-toplevel :execute)
(use-package "SOCKET")
(use-package "GRAY")
(defpackage "XREF")
(load *xref-load-path*))
(setq *multiprocessing-enabled* nil)
(defun without-interrupts* (body)
(funcall body))
(defslimefun getpid ()
(system::program-id))
(defslimefun completions (string default-package-name)
"CLISP doesn't like SLIME's routine."
(let ((comps (system::completion string 0 (length string))))
(list (cdr comps) (car comps))))
(defvar *use-dedicated-output-stream* t
"Right now in CLISP, we have no choice but to use it. This is here mostly for
documentation purposes")
(defun get-socket-stream (port announce close-socket-p)
(let ((socket (socket:socket-server port)))
(socket:socket-wait socket 0)
(funcall announce (socket:socket-server-port socket))
(prog1
(socket:socket-accept socket :external-format charset:iso-8859-1) ; note that we need 8-bit chars
(when close-socket-p
(socket:socket-server-close socket)))))
(defun serve-request (*emacs-io* *slime-output* *slime-input* *slime-io*)
"Read and process a request from a SWANK client.
The request is read from the socket as a sexp and then evaluated."
(catch 'slime-toplevel
(handler-case (read-from-emacs)
(ext:simple-charset-type-error (err)
(format *debug-io* "Wrong slime stream encoding:~%~A" err))
(slime-read-error (e)
(when *swank-debug-p*
(format *debug-io* "~&;; Connection to Emacs lost.~%;; [~A]~%" e))
(close *emacs-io* :abort t)
(when *use-dedicated-output-stream*
(close *slime-output* :abort t))
(throw 'closed-connection
(print "Connection to emacs closed" *debug-io*))))))
(defun open-stream-to-emacs ()
"Return an output-stream to Emacs' output buffer."
(let* ((listener (socket:socket-server))
(port (socket:socket-server-port listener)))
(unwind-protect
(prog2
(eval-in-emacs `(slime-open-stream-to-lisp ,port))
(socket:socket-accept listener))
(socket:socket-server-close listener))))
(defun create-swank-server (port &key (announce #'simple-announce-function)
reuse-address
background
(close-socket-p t))
(declare (ignore reuse-address background))
(let* ((emacs (get-socket-stream port announce close-socket-p))
(slime-out (let ((*emacs-io* emacs)) (open-stream-to-emacs)))
(slime-in (make-instance 'slime-input-stream))
(slime-io (make-two-way-stream slime-in slime-out)))
(catch 'closed-connection
(loop (serve-request emacs slime-out slime-in slime-io)))))
(defmethod arglist-string (fname)
(declare (type string fname))
(multiple-value-bind (function condition)
(ignore-errors (values (from-string fname)))
(when condition
(return-from arglist-string (format nil "(-- ~A)" condition)))
(multiple-value-bind (arglist condition)
(ignore-errors (values (ext:arglist function)))
(cond (condition (format nil "(-- ~A)" condition))
(t (format nil "(~{~A~^ ~})" arglist))))))
(defmethod describe-symbol-for-emacs (symbol)
"Return a plist describing SYMBOL.
Return NIL if the symbol is unbound."
(let ((result ()))
(labels ((doc (kind)
(or (documentation symbol kind) :not-documented))
(maybe-push (property value)
(when value
(setf result (list* property value result)))))
(when (fboundp symbol)
(if (macro-function symbol)
(setf (getf result :macro) (doc 'function))
(setf (getf result :function) (doc 'function))))
(maybe-push :variable (when (boundp symbol) (doc 'variable)))
(maybe-push :class (when (find-class symbol nil) (doc 'type))) ;this should be fixed
result)))
(defmethod macroexpand-all (form)
"Expand-form returns the expanded form as the primary value and t if
any macroexpansion has been done."
(ext:expand-form form))
(defun fspec-pathname (symbol &optional type)
(declare (ignore type))
(let ((path (getf (gethash symbol sys::*documentation*) 'sys::file)))
(if (and path
(member (pathname-type path)
custom:*compiled-file-types* :test #'string=))
(loop
for suffix in custom:*source-file-types*
thereis (make-pathname :defaults path :type suffix))
path)))
(defun find-multiple-definitions (fspec)
(list `(,fspec t)))
(defun find-definition-in-file (fspec type file)
(declare (ignore fspec type file))
;; FIXME
0)
(defun fspec-source-locations (fspec)
(let ((defs (find-multiple-definitions fspec)))
(let ((locations '()))
(loop for (fspec type) in defs do
(let ((file (fspec-pathname fspec type)))
(etypecase file
(pathname
(let ((start (find-definition-in-file fspec type file)))
(push (make-location
(list :file (namestring (truename file)))
(if start
(list :position (1+ start))
(list :function-name (string fspec))))
locations)))
((member :top-level)
(push (list :error (format nil "Defined at toplevel: ~A"
fspec))
locations))
(null
(push (list :error (format nil
"Unkown source location for ~A"
fspec))
locations))
)))
locations)))
(defmethod find-function-locations (symbol-name)
(multiple-value-bind (symbol foundp) (find-symbol-designator symbol-name)
(cond ((not foundp)
(list (list :error (format nil "Unkown symbol: ~A" symbol-name))))
((macro-function symbol)
(fspec-source-locations symbol))
((special-operator-p symbol)
(list (list :error (format nil "~A is a special-operator" symbol))))
((fboundp symbol)
(fspec-source-locations symbol))
(t (list (list :error
(format nil "Symbol not fbound: ~A" symbol-name))))
)))
(defvar *sldb-topframe*)
(defvar *sldb-botframe*)
(defvar *sldb-source*)
(defvar *sldb-restarts*)
(defvar *sldb-debugmode* 4)
(defvar *debug-frame*)
(defmethod call-with-debugging-environment (debugger-loop-fn)
(let* ((sys::*break-count* (1+ sys::*break-count*))
(sys::*driver* debugger-loop-fn)
(sys::*fasoutput-stream* nil)
;;; (sys::*frame-limit1* (sys::frame-limit1 43))
(sys::*frame-limit1* (sys::frame-limit1 0))
;;; (sys::*frame-limit2* (sys::frame-limit2))
(sys::*debug-mode* *sldb-debugmode*)
(*debug-frame*
(sys::frame-down-1
(sys::frame-up-1 sys::*frame-limit1* sys::*debug-mode*)
sys::*debug-mode*))
(*sldb-topframe* *debug-frame*)
(*sldb-botframe* (sys::frame-up *sldb-topframe* sys::*debug-mode*))
(*debugger-hook* nil)
(*package* *buffer-package*)
(*sldb-restarts*
(compute-restarts *swank-debugger-condition*))
(*print-pretty* nil)
(*print-readably* nil))
;;; (*print-level* 3)
;;; (*print-length* 10))
(funcall debugger-loop-fn)))
(defun format-condition-for-emacs ()
(format nil "~A~% [Condition of type ~S]"
*swank-debugger-condition* (type-of *swank-debugger-condition*)))
(defun format-restarts-for-emacs ()
(loop for restart in *sldb-restarts*
collect (list (princ-to-string (restart-name restart))
(princ-to-string restart))))
(defun nth-frame (index)
(loop
for frame = *sldb-topframe* then (sys::frame-up-1 frame sys::*debug-mode*)
repeat index
never (eq frame *sldb-botframe*)
finally (return (setq *debug-frame* frame))))
(defun compute-backtrace (start end)
(let ((end (or end most-positive-fixnum)))
(loop for f = (nth-frame start)
then (sys::frame-up-1 f sys::*debug-mode*)
for i from start below end
until (eq f *sldb-botframe*)
collect f)))
(defmethod backtrace (start-frame-number end-frame-number)
(flet ((format-frame (f i)
(format nil "~d: ~a" i
(string-left-trim
'(#\Newline)
(with-output-to-string (stream)
(let ((*print-pretty* *sldb-pprint-frames*))
(sys::describe-frame stream f)))))))
(loop for i from start-frame-number
for f in (compute-backtrace start-frame-number end-frame-number)
collect (list i (format-frame f i)))))
(defmethod eval-in-frame (form frame-number)
(sys::eval-at (nth-frame frame-number) form))
(defmethod frame-locals (frame-number)
(let* ((frame (nth-frame frame-number))
(frame-env (sys::eval-at frame '(sys::the-environment))))
(append
(frame-do-venv frame (svref frame-env 0))
(frame-do-fenv frame (svref frame-env 1))
(frame-do-benv frame (svref frame-env 2))
(frame-do-genv frame (svref frame-env 3))
(frame-do-denv frame (svref frame-env 4)))))
(defun frame-do-venv (frame venv)
(loop
for i from 1 below (length venv) by 2
as symbol = (svref venv (1- i))
and value = (svref venv i)
collect (list :symbol symbol :id 0
:value-string
(to-string
(if (eq sys::specdecl value)
;; special variable
(sys::eval-at frame symbol)
;; lexical variable or symbol macro
value)))))
(defun frame-do-fenv (frame fenv)
(declare (ignore frame fenv))
nil)
(defun frame-do-benv (frame benv)
(declare (ignore frame benv))
nil)
(defun frame-do-genv (frame genv)
(declare (ignore frame genv))
nil)
(defun frame-do-denv (frame denv)
(declare (ignore frame denv))
nil)
(defmethod frame-catch-tags (index)
(declare (ignore index))
nil)
(defmethod frame-source-location-for-emacs (index)
(list :error (format nil "Cannot find source for frame: ~A"
(nth-frame index))))
(defmethod debugger-info-for-emacs (start end)
(list (format-condition-for-emacs)
(format-restarts-for-emacs)
(backtrace start end)))
(defun nth-restart (index)
(nth index *sldb-restarts*))
(defslimefun invoke-nth-restart (index)
(invoke-restart-interactively (nth-restart index)))
(defslimefun sldb-abort ()
(invoke-restart (find 'abort *sldb-restarts* :key #'restart-name)))
;;; Handle compiler conditions (find out location of error etc.)
(defmacro compile-file-frobbing-notes ((&rest args) &body body)
"Pass ARGS to COMPILE-FILE, send the compiler notes to
*STANDARD-INPUT* and frob them in BODY."
`(let ((*error-output* (make-string-output-stream))
(*compile-verbose* t))
(multiple-value-prog1
(compile-file , at args)
(with-input-from-string
(*standard-input* (get-output-stream-string *error-output*))
, at body))))
(defmethod call-with-compilation-hooks (function)
(handler-bind ((compiler-condition #'handle-notification-condition))
(funcall function)))
(defun handle-notification-condition (condition)
"Handle a condition caused by a compiler warning."
(signal condition))
(defvar *buffer-name* nil)
(defvar *buffer-offset*)
(defvar *compiler-note-line-regexp*
(regexp:regexp-compile
"^\\(WARNING\\|ERROR\\) .* in lines \\([0-9]\\+\\)..[0-9]\\+ :$"))
(defun split-compiler-note-line (line)
(multiple-value-bind (all head tail)
(regexp:regexp-exec *compiler-note-line-regexp* line)
(declare (ignore all))
(if head
(list (let ((*package* (find-package :keyword)))
(read-from-string (regexp:match-string line head)))
(read-from-string (regexp:match-string line tail)))
(list nil line))))
;;; Ugly but essentially working.
;;; FIXME: I get all notes twice.
;;; TODO: Support for line number position in slime.el
(defmethod compile-file-for-emacs (filename load-p)
(with-compilation-hooks ()
(multiple-value-bind (fasl-file w-p f-p)
(compile-file-frobbing-notes (filename)
(read-line) ;""
(read-line) ;"Compiling file ..."
(loop
with condition
for (severity message) = (split-compiler-note-line (read-line))
until (and (stringp message) (string= message ""))
if severity
do (when condition
(print (message condition))
(signal condition))
(setq condition
(make-condition 'compiler-condition
:severity severity
:message ""
:location `(:location (:file ,filename) (:position ,message)))) ; bogus: should be (:line ,message)
else do (setf (message condition)
(format nil "~a~&~a" (message condition) message))
finally (when condition
(print (message condition))
(signal condition))))
(declare (ignore w-p))
(cond ((and fasl-file (not f-p) load-p)
(load fasl-file))
(t fasl-file)))))
(defmethod compile-string-for-emacs (string &key buffer position)
(with-compilation-hooks ()
(let ((*package* *buffer-package*)
(*buffer-name* buffer)
(*buffer-offset* position))
(eval (from-string
(format nil "(funcall (compile nil '(lambda () ~A)))"
string))))))
;;; Portable XREF from the CMU AI repository.
(setq xref::*handle-package-forms* '(cl:in-package))
(defun lookup-xrefs (finder name)
(xref-results-for-emacs (funcall finder (from-string name))))
(defslimefun who-calls (function-name)
(lookup-xrefs #'xref:list-callers function-name))
(defslimefun who-references (variable)
(lookup-xrefs #'xref:list-readers variable))
(defslimefun who-binds (variable)
(lookup-xrefs #'xref:list-setters variable))
(defslimefun who-sets (variable)
(lookup-xrefs #'xref:list-setters variable))
(defslimefun list-callers (symbol-name)
(lookup-xrefs #'xref:who-calls symbol-name))
(defslimefun list-callees (symbol-name)
(lookup-xrefs #'xref:list-callees symbol-name))
(defun xref-results-for-emacs (fspecs)
(let ((xrefs '()))
(dolist (fspec fspecs)
(dolist (location (fspec-source-locations fspec))
(push (cons (to-string fspec) location) xrefs)))
(group-xrefs xrefs)))
(when (find-package :swank-loader)
(defun swank-loader::user-init-file ()
(let ((home (user-homedir-pathname)))
(and (ext:probe-directory home)
(probe-file (format nil "~A/.swank.lisp"
(namestring (truename home))))))))
More information about the slime-devel
mailing list