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

Contents of /slime/swank-backend.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5