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

Contents of /slime/swank-backend.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.50 - (show annotations)
Wed Jun 9 12:35:22 2004 UTC (9 years, 10 months ago) by msimmons
Branch: MAIN
Changes since 1.49: +1 -1 lines
(network-error): Inherit from simple-error to get correct initargs.
1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil; outline-regexp: ";;;;;*" -*-
2 ;;;
3 ;;; slime-backend.lisp --- SLIME backend interface.
4 ;;;
5 ;;; Created by James Bielman in 2003. Released into the public domain.
6 ;;;
7 ;;; This file defines the functions that must be implemented
8 ;;; separately for each Lisp. Each is declared as a generic function
9 ;;; for which swank-<implementation>.lisp provides methods.
10
11 (defpackage :swank-backend
12 (:use :common-lisp)
13 (:export #:sldb-condition
14 #:original-condition
15 #:compiler-condition
16 #:message
17 #:short-message
18 #:condition
19 #:severity
20 #:location
21 #:location-p
22 #:location-buffer
23 #:location-position
24 #:position-p
25 #:position-pos
26 #:print-output-to-string
27 #:quit-lisp
28 ))
29
30 (in-package :swank-backend)
31
32
33 ;;;; Metacode
34
35 (defparameter *interface-functions* '()
36 "The names of all interface functions.")
37
38 (defparameter *unimplemented-interfaces* '()
39 "List of interface functions that are not implemented.
40 DEFINTERFACE adds to this list and DEFIMPLEMENTATION removes.")
41
42 (defmacro definterface (name args documentation &body default-body)
43 "Define an interface function for the backend to implement.
44 A generic function is defined with NAME, ARGS, and DOCUMENTATION.
45
46 If a DEFAULT-BODY is supplied then NO-APPLICABLE-METHOD is specialized
47 to execute the body if the backend doesn't provide a specific
48 implementation.
49
50 Backends implement these functions using DEFIMPLEMENTATION."
51 (check-type documentation string "a documentation string")
52 (flet ((gen-default-impl ()
53 (let ((received-args (gensym "ARGS-")))
54 `(defmethod no-applicable-method ((#:method
55 (eql (function ,name)))
56 &rest ,received-args)
57 (destructuring-bind ,args ,received-args
58 ,@default-body)))))
59 `(progn (defgeneric ,name ,args (:documentation ,documentation))
60 (pushnew ',name *interface-functions*)
61 ,(if (null default-body)
62 `(pushnew ',name *unimplemented-interfaces*)
63 (gen-default-impl))
64 ;; see <http://www.franz.com/support/documentation/6.2/doc/pages/variables/compiler/s_cltl1-compile-file-toplevel-compatibility-p_s.htm>
65 (eval-when (:compile-toplevel :load-toplevel :execute)
66 (export ',name :swank-backend))
67 ',name)))
68
69 (defmacro defimplementation (name args &body body)
70 `(progn (defmethod ,name ,args ,@body)
71 (if (member ',name *interface-functions*)
72 (setq *unimplemented-interfaces*
73 (remove ',name *unimplemented-interfaces*))
74 (warn "DEFIMPLEMENTATION of undefined interface (~S)" ',name))
75 ',name))
76
77 (defun warn-unimplemented-interfaces ()
78 "Warn the user about unimplemented backend features.
79 The portable code calls this function at startup."
80 (warn "These Swank interfaces are unimplemented:~% ~A"
81 (sort (copy-list *unimplemented-interfaces*) #'string<)))
82
83
84 ;;;; Utilities
85
86 (defmacro with-struct ((conc-name &rest names) obj &body body)
87 "Like with-slots but works only for structs."
88 (flet ((reader (slot) (intern (concatenate 'string
89 (symbol-name conc-name)
90 (symbol-name slot))
91 (symbol-package conc-name))))
92 (let ((tmp (gensym "OO-")))
93 ` (let ((,tmp ,obj))
94 (symbol-macrolet
95 ,(loop for name in names collect
96 (typecase name
97 (symbol `(,name (,(reader name) ,tmp)))
98 (cons `(,(first name) (,(reader (second name)) ,tmp)))
99 (t (error "Malformed syntax in WITH-STRUCT: ~A" name))))
100 ,@body)))))
101
102 ;;;; TCP server
103
104 (definterface create-socket (host port)
105 "Create a listening TCP socket on interface HOST and port PORT .")
106
107 (definterface local-port (socket)
108 "Return the local port number of SOCKET.")
109
110 (definterface close-socket (socket)
111 "Close the socket SOCKET.")
112
113 (definterface accept-connection (socket)
114 "Accept a client connection on the listening socket SOCKET. Return
115 a stream for the new connection.")
116
117 (definterface add-sigio-handler (socket fn)
118 "Call FN whenever SOCKET is readable.")
119
120 (definterface remove-sigio-handlers (socket)
121 "Remove all sigio handlers for SOCKET.")
122
123 (definterface add-fd-handler (socket fn)
124 "Call FN when Lisp is waiting for input and SOCKET is readable.")
125
126 (definterface remove-fd-handlers (socket)
127 "Remove all fd-handlers for SOCKET.")
128
129 (definterface preferred-communication-style ()
130 "Return one of the symbols :spawn, :sigio, :fd-handler, or NIL."
131 nil)
132
133 ;;; Base condition for networking errors.
134 (define-condition network-error (simple-error) ())
135
136 (definterface emacs-connected ()
137 "Hook called when the first connection from Emacs is established.
138 Called from the INIT-FN of the socket server that accepts the
139 connection.
140
141 This is intended for setting up extra context, e.g. to discover
142 that the calling thread is the one that interacts with Emacs."
143 nil)
144
145
146 ;;;; Unix signals
147
148 (defconstant +sigint+ 2)
149
150 (definterface call-without-interrupts (fn)
151 "Call FN in a context where interrupts are disabled."
152 (funcall fn))
153
154 (definterface getpid ()
155 "Return the (Unix) process ID of this superior Lisp.")
156
157 (definterface lisp-implementation-type-name ()
158 "Return a short name for the Lisp implementation."
159 (lisp-implementation-type))
160
161 (definterface set-default-directory (directory)
162 "Set the default directory.
163 This is used to resolve filenames without directory component."
164 (setf *default-pathname-defaults* (truename (merge-pathnames directory)))
165 (namestring *default-pathname-defaults*))
166
167
168 ;;;; Compilation
169
170 (definterface call-with-compilation-hooks (func)
171 "Call FUNC with hooks to record compiler conditions.")
172
173 (defmacro with-compilation-hooks ((&rest ignore) &body body)
174 "Execute BODY as in CALL-WITH-COMPILATION-HOOKS."
175 (declare (ignore ignore))
176 `(call-with-compilation-hooks (lambda () (progn ,@body))))
177
178 (definterface swank-compile-string (string &key buffer position)
179 "Compile source from STRING. During compilation, compiler
180 conditions must be trapped and resignalled as COMPILER-CONDITIONs.
181
182 If supplied, BUFFER and POSITION specify the source location in Emacs.
183
184 Additionally, if POSITION is supplied, it must be added to source
185 positions reported in compiler conditions.")
186
187 (definterface operate-on-system (system-name operation-name &rest keyword-args)
188 "Perform OPERATION-NAME on SYSTEM-NAME using ASDF.
189 The KEYWORD-ARGS are passed on to the operation.
190 Example:
191 \(operate-on-system \"SWANK\" \"COMPILE-OP\" :force t)"
192 (unless (member :asdf *features*)
193 (error "ASDF is not loaded."))
194 (with-compilation-hooks ()
195 (let ((operate (find-symbol "OPERATE" :asdf))
196 (operation (find-symbol operation-name :asdf)))
197 (when (null operation)
198 (error "Couldn't find ASDF operation ~S" operation-name))
199 (apply operate operation system-name keyword-args))))
200
201 (definterface swank-compile-file (filename load-p)
202 "Compile FILENAME signalling COMPILE-CONDITIONs.
203 If LOAD-P is true, load the file after compilation.")
204
205 (deftype severity () '(member :error :warning :style-warning :note))
206
207 ;; Base condition type for compiler errors, warnings and notes.
208 (define-condition compiler-condition (condition)
209 ((original-condition
210 ;; The original condition thrown by the compiler if appropriate.
211 ;; May be NIL if a compiler does not report using conditions.
212 :type (or null condition)
213 :initarg :original-condition
214 :accessor original-condition)
215
216 (severity :type severity
217 :initarg :severity
218 :accessor severity)
219
220 (message :initarg :message
221 :accessor message)
222
223 (short-message :initarg :short-message
224 :initform nil
225 :accessor short-message)
226
227 (location :initarg :location
228 :accessor location)))
229
230
231 ;;;; Streams
232
233 (definterface make-fn-streams (input-fn output-fn)
234 "Return character input and output streams backended by functions.
235 When input is needed, INPUT-FN is called with no arguments to
236 return a string.
237 When output is ready, OUTPUT-FN is called with the output as its
238 argument.
239
240 Output should be forced to OUTPUT-FN before calling INPUT-FN.
241
242 The streams are returned as two values.")
243
244
245 ;;;; Documentation
246
247 (definterface arglist (name)
248 "Return the lambda list for the symbol NAME.
249
250 The result can be a list or the :not-available if the arglist cannot
251 be determined.")
252
253 (definterface macroexpand-all (form)
254 "Recursively expand all macros in FORM.
255 Return the resulting form.")
256
257 (definterface describe-symbol-for-emacs (symbol)
258 "Return a property list describing SYMBOL.
259
260 The property list has an entry for each interesting aspect of the
261 symbol. The recognised keys are:
262
263 :VARIABLE :FUNCTION :SETF :TYPE :CLASS :MACRO :COMPILER-MACRO
264 :ALIEN-TYPE :ALIEN-STRUCT :ALIEN-UNION :ALIEN-ENUM
265
266 The value of each property is the corresponding documentation string,
267 or :NOT-DOCUMENTED. It is legal to include keys not listed here.
268
269 Properties should be included if and only if they are applicable to
270 the symbol. For example, only (and all) fbound symbols should include
271 the :FUNCTION property.
272
273 Example:
274 \(describe-symbol-for-emacs 'vector)
275 => (:CLASS :NOT-DOCUMENTED
276 :TYPE :NOT-DOCUMENTED
277 :FUNCTION \"Constructs a simple-vector from the given objects.\")")
278
279 (definterface describe-definition (name type)
280 "Describe the definition NAME of TYPE.
281 TYPE can be any value returned by DESCRIBE-SYMBOL-FOR-EMACS.
282
283 Return a documentation string, or NIL if none is available.")
284
285
286 ;;;; Debugging
287
288 (definterface call-with-debugging-environment (debugger-loop-fn)
289 "Call DEBUGGER-LOOP-FN in a suitable debugging environment.
290
291 This function is called recursively at each debug level to invoke the
292 debugger loop. The purpose is to setup any necessary environment for
293 other debugger callbacks that will be called within the debugger loop.
294
295 For example, this is a reasonable place to compute a backtrace, switch
296 to safe reader/printer settings, and so on.")
297
298 (define-condition sldb-condition (condition)
299 ((original-condition
300 :initarg :original-condition
301 :accessor original-condition))
302 (:documentation
303 "Wrapper for conditions that should not be debugged.
304
305 When a condition arises from the internals of the debugger, it is not
306 desirable to debug it -- we'd risk entering an endless loop trying to
307 debug the debugger! Instead, such conditions can be reported to the
308 user without (re)entering the debugger by wrapping them as
309 `sldb-condition's."))
310
311 (definterface compute-backtrace (start end)
312 "Return a list containing a backtrace of the condition current
313 being debugged. The results are unspecified if this function is
314 called outside the dynamic contour CALL-WITH-DEBUGGING-ENVIRONMENT.
315
316 START and END are zero-based indices constraining the number of frames
317 returned. Frame zero is defined as the frame which invoked the
318 debugger. If END is nil, return the frames from START to the end of
319 the stack.")
320
321 (definterface print-frame (frame stream)
322 "Print frame to stream.")
323
324 (definterface frame-source-location-for-emacs (frame-number)
325 "Return the source location for FRAME-NUMBER.")
326
327 (definterface frame-catch-tags (frame-number)
328 "Return a list of XXX list of what? catch tags for a debugger
329 stack frame. The results are undefined unless this is called
330 within the dynamic contour of a function defined by
331 DEFINE-DEBUGGER-HOOK.")
332
333 (definterface frame-locals (frame-number)
334 "Return a list of XXX local variable designators define me
335 for a debugger stack frame. The results are undefined unless
336 this is called within the dynamic contour of a function defined
337 by DEFINE-DEBUGGER-HOOK.")
338
339 (definterface disassemble-frame (frame-number)
340 "Disassemble the code for the FRAME-NUMBER.
341 The output should be written to standard output.
342 FRAME-NUMBER is a non-negative interger.")
343
344 (definterface eval-in-frame (form frame-number)
345 "Evaluate a Lisp form in the lexical context of a stack frame
346 in the debugger. The results are undefined unless called in the
347 dynamic contour of a function defined by DEFINE-DEBUGGER-HOOK.
348
349 FRAME-NUMBER must be a positive integer with 0 indicating the
350 frame which invoked the debugger.
351
352 The return value is the result of evaulating FORM in the
353 appropriate context.")
354
355 (definterface return-from-frame (frame-number form)
356 "Unwind the stack to the frame FRAME-NUMBER and return the value(s)
357 produced by evaluating FORM in the frame context to its caller.
358
359 Execute any clean-up code from unwind-protect forms above the frame
360 during unwinding.
361
362 Return a string describing the error if it's not possible to return
363 from the frame.")
364
365 (definterface restart-frame (frame-number)
366 "Restart execution of the frame FRAME-NUMBER with the same arguments
367 as it was called originally.")
368
369 (definterface format-sldb-condition (condition)
370 "Format a condition for display in SLDB."
371 (princ-to-string condition))
372
373 (definterface condition-references (condition)
374 "Return a list of documentation references for a condition.
375 Each reference is one of:
376 (:ANSI-CL
377 {:FUNCTION | :SPECIAL-OPERATOR | :MACRO | :SECTION | :GLOSSARY }
378 symbol-or-name)
379 (:SBCL :NODE node-name)"
380 '())
381
382
383 ;;;; Definition finding
384
385 (defstruct (:location (:type list) :named
386 (:constructor make-location
387 (buffer position &optional hints)))
388 buffer position
389 ;; Hints is a property list optionally containing:
390 ;; :snippet SOURCE-TEXT
391 ;; This is a snippet of the actual source text at the start of
392 ;; the definition, which could be used in a text search.
393 hints)
394
395 (defstruct (:error (:type list) :named (:constructor)) message)
396 (defstruct (:file (:type list) :named (:constructor)) name)
397 (defstruct (:buffer (:type list) :named (:constructor)) name)
398 (defstruct (:position (:type list) :named (:constructor)) pos)
399
400 (definterface find-definitions (name)
401 "Return a list ((DSPEC LOCATION) ...) for NAME's definitions.
402
403 NAME is a \"definition specifier\".
404
405 DSPEC is a \"definition specifier\" describing the
406 definition, e.g., FOO or (METHOD FOO (STRING NUMBER)) or
407 \(DEFVAR FOO).
408
409 LOCATION is the source location for the definition.")
410
411
412 ;;;; XREF
413
414 (definterface who-calls (function-name)
415 "Return the call sites of FUNCTION-NAME (a symbol).
416 The results is a list ((DSPEC LOCATION) ...).")
417
418 (definterface who-references (variable-name)
419 "Return the locations where VARIABLE-NAME (a symbol) is referenced.
420 See WHO-CALLS for a description of the return value.")
421
422 (definterface who-binds (variable-name)
423 "Return the locations where VARIABLE-NAME (a symbol) is bound.
424 See WHO-CALLS for a description of the return value.")
425
426 (definterface who-sets (variable-name)
427 "Return the locations where VARIABLE-NAME (a symbol) is set.
428 See WHO-CALLS for a description of the return value.")
429
430 (definterface who-macroexpands (macro-name)
431 "Return the locations where MACRO-NAME (a symbol) is expanded.
432 See WHO-CALLS for a description of the return value.")
433
434 (definterface who-specializes (class-name)
435 "Return the locations where CLASS-NAME (a symbol) is specialized.
436 See WHO-CALLS for a description of the return value.")
437
438 ;;; Simpler variants.
439
440 (definterface list-callers (function-name)
441 "List the callers of FUNCTION-NAME.
442 This function is like WHO-CALLS except that it is expected to use
443 lower-level means. Whereas WHO-CALLS is usually implemented with
444 special compiler support, LIST-CALLERS is usually implemented by
445 groveling for constants in function objects throughout the heap.
446
447 The return value is as for WHO-CALLS.")
448
449 (definterface list-callees (function-name)
450 "List the functions called by FUNCTION-NAME.
451 See LIST-CALLERS for a description of the return value.")
452
453
454 ;;;; Profiling
455
456 ;;; The following functions define a minimal profiling interface.
457
458 (definterface profile (fname)
459 "Marks symbol FNAME for profiling.")
460
461 (definterface profiled-functions ()
462 "Returns a list of profiled functions.")
463
464 (definterface unprofile (fname)
465 "Marks symbol FNAME as not profiled.")
466
467 (definterface unprofile-all ()
468 "Marks all currently profiled functions as not profiled."
469 (dolist (f (profiled-functions))
470 (unprofile f)))
471
472 (definterface profile-report ()
473 "Prints profile report.")
474
475 (definterface profile-reset ()
476 "Resets profile counters.")
477
478 (definterface profile-package (package callers-p methods)
479 "Wrap profiling code around all functions in PACKAGE. If a function
480 is already profiled, then unprofile and reprofile (useful to notice
481 function redefinition.)
482
483 If CALLERS-P is T names have counts of the most common calling
484 functions recorded.
485
486 When called with arguments :METHODS T, profile all methods of all
487 generic functions having names in the given package. Generic functions
488 themselves, that is, their dispatch functions, are left alone.")
489
490
491 ;;;; Inspector
492
493 (definterface inspected-parts (object)
494 "Return a short description and a list of (LABEL . VALUE) pairs."
495 (values (format nil "~S is an atom." object) '()))
496
497 (definterface describe-primitive-type (object)
498 "Return a string describing the primitive type of object."
499 (declare (ignore object))
500 "N/A")
501
502
503 ;;;; Multithreading
504 ;;;
505 ;;; The default implementations are sufficient for non-multiprocessing
506 ;;; implementations.
507
508 (definterface startup-multiprocessing ()
509 "Initialize multiprocessing, if necessary.
510
511 This function is called directly through the listener, not in an RPC
512 from Emacs. This is to support interfaces such as CMUCL's
513 MP::STARTUP-IDLE-AND-TOP-LEVEL-LOOPS which does not return like a
514 normal function."
515 nil)
516
517 (definterface spawn (fn &key name)
518 "Create a new thread to call FN.")
519
520 (definterface thread-name (thread)
521 "Return the name of THREAD.
522
523 Thread names are be single-line strings and are meaningful to the
524 user. They do not have to be unique."
525 (declare (ignore thread))
526 "The One True Thread")
527
528 (definterface thread-status (thread)
529 "Return a string describing THREAD's state."
530 (declare (ignore thread))
531 "")
532
533 (definterface make-lock (&key name)
534 "Make a lock for thread synchronization.
535 Only one thread may hold the lock (via CALL-WITH-LOCK-HELD) at a time."
536 (declare (ignore name))
537 :null-lock)
538
539 (definterface call-with-lock-held (lock function)
540 "Call FUNCTION with LOCK held, queueing if necessary."
541 (declare (ignore lock)
542 (type function function))
543 (funcall function))
544
545 (definterface current-thread ()
546 "Return the currently executing thread."
547 0)
548
549 (definterface all-threads ()
550 "Return a list of all threads.")
551
552 (definterface thread-alive-p (thread)
553 "Test if THREAD is termintated."
554 (member thread (all-threads)))
555
556 (definterface interrupt-thread (thread fn)
557 "Cause THREAD to execute FN.")
558
559 (definterface kill-thread (thread)
560 "Kill THREAD."
561 (declare (ignore thread))
562 nil)
563
564 (definterface send (thread object)
565 "Send OBJECT to thread THREAD.")
566
567 (definterface receive ()
568 "Return the next message from current thread's mailbox.")
569
570 (definterface quit-lisp ()
571 "Exit the current lisp image.")

  ViewVC Help
Powered by ViewVC 1.1.5