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

Contents of /slime/swank-backend.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5