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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (hide annotations)
Thu Sep 4 11:07:27 2003 UTC (10 years, 7 months ago) by lukeg
Branch: MAIN
CVS Tags: SLIME-0-2
Imported from slime-0.2
1 lukeg 1.1 (defpackage :swank
2     (:use :common-lisp :wire)
3     (:export #:start-server #:evaluate #:lookup-notes
4     #:swank-compile-file #:arglist-string #:completions))
5    
6     (in-package :swank)
7    
8     (defconstant server-port 4004
9     "Default port for the swank TCP server.")
10    
11     (defconstant +internal-error+ 56)
12     (defconstant +condition+ 57)
13     (defconstant +ok+ 42)
14    
15     (define-condition swank-error (simple-error) ())
16    
17     (defvar *notes-database* (make-hash-table :test #'equal)
18     "Database of recorded compiler notes/warnings/erros (keyed by filename).
19     Each value is a list of (LOCATION SEVERITY MESSAGE CONTEXT) lists.
20     LOCATION is a position in the source code (integer or source path).
21     SEVERITY is one of :ERROR, :WARNING, and :NOTE.
22     MESSAGE is a string describing the note.
23     CONTEXT is a string giving further details of where the error occured.")
24    
25     (defvar *swank-debug-p* nil
26     "When true extra debug printouts are enabled.")
27    
28     ;;; Setup and hooks.
29    
30     (defun start-server (&optional (port server-port))
31     (wire:create-request-server port nil :reuse-address t)
32     (setf c:*record-xref-info* t)
33     (ext:without-package-locks
34     (setq *debugger-hook* #'debugger-hook)
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     (send-value (eval (let ((*package* (find-package package)))
89     (read-from-string string))))
90     (swank-error (condition)
91     (send-reply +condition+
92     (format nil
93     (simple-condition-format-control condition)
94     (simple-condition-format-arguments condition))
95     ""))
96     (error (condition)
97     (send-and-log-internal-error condition))))
98    
99     ;;;; SWANK-COMPILE-FILE -- interface
100    
101     (defun swank-compile-file (filename load-p)
102     (remhash filename *notes-database*)
103     (if (not (probe-file filename))
104     (send-reply +condition+ "File does not exist" "")
105     (handler-case
106     (multiple-value-bind (output warnings failure)
107     (compile-file filename :load (read-from-string load-p))
108     (send-value (list (and output (namestring output))
109     warnings
110     failure)))
111     (reader-error (condition)
112     (send-condition condition))
113     (end-of-file (condition)
114     (send-condition condition))
115     (package-error (condition)
116     (send-condition condition))
117     (c::compiler-error (condition)
118     (send-condition condition (current-compiler-error-source-path)))
119     (error (condition)
120     (format *debug-io* "~&Condition: ~S / ~S~%" (type-of condition) condition)
121     ;; Oops.
122     (send-and-log-internal-error condition)))))
123    
124     (defun send-reply (status message result)
125     "Send a result triple over the wire to Emacs."
126     (declare (type integer status))
127     (when *swank-debug-p*
128     (format *debug-io* "~&;; SWANK Reply: ~S, ~S, ~S~%" status message result))
129     (wire-output-object *current-wire* status)
130     (wire-output-object *current-wire* message)
131     (wire-output-object *current-wire* result)
132     (wire-force-output *current-wire*))
133    
134     (defun send-value (value)
135     (send-reply +ok+ "ok" (prin1-to-string value)))
136    
137     (defun send-condition (condition &optional result)
138     (send-reply +condition+ (princ-to-string condition) (prin1-to-string result)))
139    
140     (defun send-and-log-internal-error (condition)
141     (format *debug-io* "~&Internal Swank Error: ~A~%" condition)
142     (send-reply +internal-error+
143     (format nil "~&Internal Swank Error: ~A~%" condition)
144     ""))
145    
146     ;;;; LOOKUP-NOTES -- interface
147    
148     (defun lookup-notes (filename)
149     "Return the compiler notes recorded for FILENAME.
150     \(See *NOTES-DATABASE* for a description of the return type.)"
151     (gethash filename *notes-database*))
152    
153     ;;;; ARGLIST-STRING -- interface
154    
155     (defun arglist-string (function)
156     "Return a string describing the argument list for FUNCTION.
157     The result has the format \"(...)\"."
158     (declare (type (or symbol function) function))
159     (let ((arglist
160     (if (not (or (fboundp function)
161     (functionp function)))
162     "(-- <Unknown-Function>)"
163     (let* ((fun (etypecase function
164     (symbol (or (macro-function function)
165     (symbol-function function)))
166     (function function)))
167     (df (di::function-debug-function fun))
168     (arglist (kernel:%function-arglist fun)))
169     (cond ((eval:interpreted-function-p fun)
170     (eval:interpreted-function-arglist fun))
171     ((pcl::generic-function-p fun)
172     (pcl::gf-pretty-arglist fun))
173     (arglist arglist)
174     ;; this should work both for
175     ;; compiled-debug-function and for
176     ;; interpreted-debug-function
177     (df (di::debug-function-lambda-list df))
178     (t "(<arglist-unavailable>)"))))))
179     (if (stringp arglist)
180     arglist
181     (prin1-to-string arglist))))
182    
183     ;;;; COMPLETIONS -- interface
184    
185     (defun completions (prefix package-name)
186     "Return a list of completions for a symbol's PREFIX and PACKAGE-NAME.
187     The result is a list of symbol-name strings. All symbols accessible in
188     the package are considered."
189     (let ((completions nil))
190     (do-symbols (symbol (find-package package-name))
191     (when (string-prefix-p prefix (symbol-name symbol))
192     (push (symbol-name symbol) completions)))
193     completions))
194    
195     (defun string-prefix-p (s1 s2)
196     "Return true iff the string S1 is a prefix of S2.
197     \(This includes the case where S1 is equal to S2.)"
198     (and (<= (length s1) (length s2))
199     (string= s1 s2 :end2 (length s1))))
200    

  ViewVC Help
Powered by ViewVC 1.1.5