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

Contents of /slime/swank-backend.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5