/[slime]/slime/swank.lisp
ViewVC logotype

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (hide annotations)
Mon Sep 8 13:34:01 2003 UTC (10 years, 7 months ago) by lukeg
Branch: MAIN
Changes since 1.2: +51 -1 lines
(find-fdefinition): Support for finding function/macro definitions for
Emacs.
1 lukeg 1.1 (defpackage :swank
2     (:use :common-lisp :wire)
3     (:export #:start-server #:evaluate #:lookup-notes
4 lukeg 1.3 #:swank-compile-file #:arglist-string #:completions
5     #:find-fdefinition))
6 lukeg 1.1
7     (in-package :swank)
8    
9     (defconstant server-port 4004
10     "Default port for the swank TCP server.")
11    
12     (defconstant +internal-error+ 56)
13     (defconstant +condition+ 57)
14     (defconstant +ok+ 42)
15    
16     (define-condition swank-error (simple-error) ())
17    
18     (defvar *notes-database* (make-hash-table :test #'equal)
19     "Database of recorded compiler notes/warnings/erros (keyed by filename).
20     Each value is a list of (LOCATION SEVERITY MESSAGE CONTEXT) lists.
21     LOCATION is a position in the source code (integer or source path).
22     SEVERITY is one of :ERROR, :WARNING, and :NOTE.
23     MESSAGE is a string describing the note.
24     CONTEXT is a string giving further details of where the error occured.")
25    
26     (defvar *swank-debug-p* nil
27     "When true extra debug printouts are enabled.")
28    
29     ;;; Setup and hooks.
30    
31     (defun start-server (&optional (port server-port))
32     (wire:create-request-server port nil :reuse-address t)
33     (setf c:*record-xref-info* t)
34     (ext:without-package-locks
35     (setf c:*compiler-notification-function* #'handle-notification))
36     (when *swank-debug-p*
37     (format *debug-io* "~&Swank ready.~%")))
38    
39     (defun debugger-hook (condition old-hook)
40     "Hook function to be invoked instead of the debugger.
41     See CL:*DEBUGGER-HOOK*."
42     ;; FIXME: Debug from Emacs!
43     (declare (ignore old-hook))
44     (handler-case
45     (progn (format *error-output*
46     "~@<SWANK: unhandled condition ~2I~_~A~:>~%"
47     condition)
48     (debug:backtrace 20 *error-output*)
49     (finish-output *error-output*))
50     (condition ()
51     nil)))
52    
53     (defun handle-notification (severity message context where-from position)
54     "Hook function called by the compiler.
55     See C:*COMPILER-NOTIFICATION-FUNCTION*"
56     (let ((location (or (current-compiler-error-source-path) position))
57     (namestring (cond ((stringp where-from) where-from)
58     ;; we can be passed a stream from READER-ERROR
59     ((lisp::fd-stream-p where-from)
60     (lisp::fd-stream-file where-from))
61     (t where-from))))
62     (when namestring
63     (push (list location severity message context)
64     (gethash namestring *notes-database*)))))
65    
66     (defun current-compiler-error-source-path ()
67     "Return the source-path for the current compiler error.
68     Returns NIL if this cannot be determined by examining internal
69     compiler state."
70     (let ((context c::*compiler-error-context*))
71     (cond ((c::node-p context)
72     (reverse
73     (c::source-path-original-source (c::node-source-path context))))
74     ((c::compiler-error-context-p context)
75     (reverse
76     (c::compiler-error-context-original-source-path context))))))
77    
78     ;;; Functions for Emacs to call.
79    
80     ;;;; EVALUATE -- interface
81    
82     (defun evaluate (string package)
83     "Evaluate an expression for Emacs."
84     (declare (type simple-string string))
85     (when *swank-debug-p*
86     (format *debug-io* "~&;; SWANK:EVALUATE (~S) |~S|~%" package string))
87     (handler-case
88 lukeg 1.2 (send-value (eval (let ((debug::*debugger-hook* #'debugger-hook)
89     (*package* (find-package package)))
90 lukeg 1.1 (read-from-string string))))
91     (swank-error (condition)
92     (send-reply +condition+
93     (format nil
94     (simple-condition-format-control condition)
95     (simple-condition-format-arguments condition))
96 lukeg 1.2 ""))))
97     ;; (error (condition)
98     ;; (send-and-log-internal-error condition))))
99 lukeg 1.1
100     ;;;; SWANK-COMPILE-FILE -- interface
101    
102     (defun swank-compile-file (filename load-p)
103     (remhash filename *notes-database*)
104     (if (not (probe-file filename))
105     (send-reply +condition+ "File does not exist" "")
106     (handler-case
107     (multiple-value-bind (output warnings failure)
108     (compile-file filename :load (read-from-string load-p))
109     (send-value (list (and output (namestring output))
110     warnings
111     failure)))
112     (reader-error (condition)
113     (send-condition condition))
114     (end-of-file (condition)
115     (send-condition condition))
116     (package-error (condition)
117     (send-condition condition))
118     (c::compiler-error (condition)
119     (send-condition condition (current-compiler-error-source-path)))
120     (error (condition)
121     (format *debug-io* "~&Condition: ~S / ~S~%" (type-of condition) condition)
122     ;; Oops.
123     (send-and-log-internal-error condition)))))
124    
125     (defun send-reply (status message result)
126     "Send a result triple over the wire to Emacs."
127     (declare (type integer status))
128     (when *swank-debug-p*
129     (format *debug-io* "~&;; SWANK Reply: ~S, ~S, ~S~%" status message result))
130     (wire-output-object *current-wire* status)
131     (wire-output-object *current-wire* message)
132     (wire-output-object *current-wire* result)
133     (wire-force-output *current-wire*))
134    
135     (defun send-value (value)
136     (send-reply +ok+ "ok" (prin1-to-string value)))
137    
138     (defun send-condition (condition &optional result)
139     (send-reply +condition+ (princ-to-string condition) (prin1-to-string result)))
140    
141     (defun send-and-log-internal-error (condition)
142     (format *debug-io* "~&Internal Swank Error: ~A~%" condition)
143     (send-reply +internal-error+
144     (format nil "~&Internal Swank Error: ~A~%" condition)
145     ""))
146    
147     ;;;; LOOKUP-NOTES -- interface
148    
149     (defun lookup-notes (filename)
150     "Return the compiler notes recorded for FILENAME.
151     \(See *NOTES-DATABASE* for a description of the return type.)"
152     (gethash filename *notes-database*))
153    
154     ;;;; ARGLIST-STRING -- interface
155    
156     (defun arglist-string (function)
157     "Return a string describing the argument list for FUNCTION.
158     The result has the format \"(...)\"."
159     (declare (type (or symbol function) function))
160     (let ((arglist
161     (if (not (or (fboundp function)
162     (functionp function)))
163     "(-- <Unknown-Function>)"
164     (let* ((fun (etypecase function
165     (symbol (or (macro-function function)
166     (symbol-function function)))
167     (function function)))
168     (df (di::function-debug-function fun))
169     (arglist (kernel:%function-arglist fun)))
170     (cond ((eval:interpreted-function-p fun)
171     (eval:interpreted-function-arglist fun))
172     ((pcl::generic-function-p fun)
173     (pcl::gf-pretty-arglist fun))
174     (arglist arglist)
175     ;; this should work both for
176     ;; compiled-debug-function and for
177     ;; interpreted-debug-function
178     (df (di::debug-function-lambda-list df))
179     (t "(<arglist-unavailable>)"))))))
180     (if (stringp arglist)
181     arglist
182     (prin1-to-string arglist))))
183    
184     ;;;; COMPLETIONS -- interface
185    
186 lukeg 1.2 (defun completions (prefix package-name &optional only-external-p)
187 lukeg 1.1 "Return a list of completions for a symbol's PREFIX and PACKAGE-NAME.
188     The result is a list of symbol-name strings. All symbols accessible in
189     the package are considered."
190 lukeg 1.2 (let ((completions nil)
191     (package (find-package package-name)))
192     (when package
193     (do-symbols (symbol package)
194     (when (and (or (not only-external-p) (symbol-external-p symbol))
195     (string-prefix-p prefix (symbol-name symbol)))
196     (push (symbol-name symbol) completions))))
197 lukeg 1.1 completions))
198 lukeg 1.2
199     (defun symbol-external-p (s)
200     (multiple-value-bind (_ status)
201     (find-symbol (symbol-name s) (symbol-package s))
202     (declare (ignore _))
203     (eq status :external)))
204 lukeg 1.1
205     (defun string-prefix-p (s1 s2)
206     "Return true iff the string S1 is a prefix of S2.
207     \(This includes the case where S1 is equal to S2.)"
208     (and (<= (length s1) (length s2))
209     (string= s1 s2 :end2 (length s1))))
210 lukeg 1.3
211     ;;;; Definitions
212    
213     ;;; FIND-FDEFINITION -- interface
214     ;;;
215     (defun find-fdefinition (symbol-name package-name)
216     "Return the name of the file in which the function was defined, or NIL."
217     (fdefinition-file (read-symbol/package symbol-name package-name)))
218    
219     ;;; Clone of HEMLOCK-INTERNALS::FUN-DEFINED-FROM-PATHNAME
220     (defun fdefinition-file (function)
221     "Return the name of the file in which FUNCTION was defined."
222     (declare (type (or symbol function) function))
223     (typecase function
224     (symbol
225     (let ((def (or (macro-function function)
226     (and (fboundp function)
227     (fdefinition function)))))
228     (when def (fdefinition-file def))))
229     (kernel:byte-closure
230     (fdefinition-file (kernel:byte-closure-function function)))
231     (kernel:byte-function
232     (code-definition-file (c::byte-function-component function)))
233     (function
234     (code-definition-file (kernel:function-code-header
235     (kernel:%function-self function))))
236     (t nil)))
237    
238     (defun code-definition-file (code)
239     "Return the name of the file in which CODE was defined."
240     (declare (type kernel:code-component code))
241     (flet ((to-namestring (pathname)
242     (handler-case (namestring (truename pathname))
243     (file-error () nil))))
244     (let ((info (kernel:%code-debug-info code)))
245     (when info
246     (let ((source (car (c::debug-info-source info))))
247     (when (and source (eq (c::debug-source-from source) :file))
248     (to-namestring (c::debug-source-name source))))))))
249    
250     ;;;; Utilities.
251    
252     (defun read-symbol/package (symbol-name package-name)
253     (let ((package (find-package package-name)))
254     (unless package (error "No such package: %S" package-name))
255     (handler-case
256     (let ((*package* package))
257     (read-from-string symbol-name))
258     (reader-error () nil))))
259 lukeg 1.1

  ViewVC Help
Powered by ViewVC 1.1.5