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

Contents of /slime/swank-backend.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.48 - (show annotations)
Mon Jun 7 18:27:30 2004 UTC (9 years, 10 months ago) by lgorrie
Branch: MAIN
CVS Tags: SLIME-0-14
Changes since 1.47: +9 -7 lines
Wrap EXPORT calls in EVAL-WHEN. Fixes many warnings in ACL.
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 (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
370 ;;;; Definition finding
371
372 (defstruct (:location (:type list) :named
373 (:constructor make-location
374 (buffer position &optional hints)))
375 buffer position
376 ;; Hints is a property list optionally containing:
377 ;; :snippet SOURCE-TEXT
378 ;; This is a snippet of the actual source text at the start of
379 ;; the definition, which could be used in a text search.
380 hints)
381
382 (defstruct (:error (:type list) :named (:constructor)) message)
383 (defstruct (:file (:type list) :named (:constructor)) name)
384 (defstruct (:buffer (:type list) :named (:constructor)) name)
385 (defstruct (:position (:type list) :named (:constructor)) pos)
386
387 (definterface find-definitions (name)
388 "Return a list ((DSPEC LOCATION) ...) for NAME's definitions.
389
390 NAME is a \"definition specifier\".
391
392 DSPEC is a \"definition specifier\" describing the
393 definition, e.g., FOO or (METHOD FOO (STRING NUMBER)) or
394 \(DEFVAR FOO).
395
396 LOCATION is the source location for the definition.")
397
398
399 ;;;; XREF
400
401 (definterface who-calls (function-name)
402 "Return the call sites of FUNCTION-NAME (a symbol).
403 The results is a list ((DSPEC LOCATION) ...).")
404
405 (definterface who-references (variable-name)
406 "Return the locations where VARIABLE-NAME (a symbol) is referenced.
407 See WHO-CALLS for a description of the return value.")
408
409 (definterface who-binds (variable-name)
410 "Return the locations where VARIABLE-NAME (a symbol) is bound.
411 See WHO-CALLS for a description of the return value.")
412
413 (definterface who-sets (variable-name)
414 "Return the locations where VARIABLE-NAME (a symbol) is set.
415 See WHO-CALLS for a description of the return value.")
416
417 (definterface who-macroexpands (macro-name)
418 "Return the locations where MACRO-NAME (a symbol) is expanded.
419 See WHO-CALLS for a description of the return value.")
420
421 (definterface who-specializes (class-name)
422 "Return the locations where CLASS-NAME (a symbol) is specialized.
423 See WHO-CALLS for a description of the return value.")
424
425 ;;; Simpler variants.
426
427 (definterface list-callers (function-name)
428 "List the callers of FUNCTION-NAME.
429 This function is like WHO-CALLS except that it is expected to use
430 lower-level means. Whereas WHO-CALLS is usually implemented with
431 special compiler support, LIST-CALLERS is usually implemented by
432 groveling for constants in function objects throughout the heap.
433
434 The return value is as for WHO-CALLS.")
435
436 (definterface list-callees (function-name)
437 "List the functions called by FUNCTION-NAME.
438 See LIST-CALLERS for a description of the return value.")
439
440
441 ;;;; Profiling
442
443 ;;; The following functions define a minimal profiling interface.
444
445 (definterface profile (fname)
446 "Marks symbol FNAME for profiling.")
447
448 (definterface profiled-functions ()
449 "Returns a list of profiled functions.")
450
451 (definterface unprofile (fname)
452 "Marks symbol FNAME as not profiled.")
453
454 (definterface unprofile-all ()
455 "Marks all currently profiled functions as not profiled."
456 (dolist (f (profiled-functions))
457 (unprofile f)))
458
459 (definterface profile-report ()
460 "Prints profile report.")
461
462 (definterface profile-reset ()
463 "Resets profile counters.")
464
465 (definterface profile-package (package callers-p methods)
466 "Wrap profiling code around all functions in PACKAGE. If a function
467 is already profiled, then unprofile and reprofile (useful to notice
468 function redefinition.)
469
470 If CALLERS-P is T names have counts of the most common calling
471 functions recorded.
472
473 When called with arguments :METHODS T, profile all methods of all
474 generic functions having names in the given package. Generic functions
475 themselves, that is, their dispatch functions, are left alone.")
476
477
478 ;;;; Inspector
479
480 (definterface inspected-parts (object)
481 "Return a short description and a list of (LABEL . VALUE) pairs."
482 (values (format nil "~S is an atom." object) '()))
483
484 (definterface describe-primitive-type (object)
485 "Return a string describing the primitive type of object."
486 (declare (ignore object))
487 "N/A")
488
489
490 ;;;; Multithreading
491 ;;;
492 ;;; The default implementations are sufficient for non-multiprocessing
493 ;;; implementations.
494
495 (definterface startup-multiprocessing ()
496 "Initialize multiprocessing, if necessary.
497
498 This function is called directly through the listener, not in an RPC
499 from Emacs. This is to support interfaces such as CMUCL's
500 MP::STARTUP-IDLE-AND-TOP-LEVEL-LOOPS which does not return like a
501 normal function."
502 nil)
503
504 (definterface spawn (fn &key name)
505 "Create a new thread to call FN.")
506
507 (definterface thread-name (thread)
508 "Return the name of THREAD.
509
510 Thread names are be single-line strings and are meaningful to the
511 user. They do not have to be unique."
512 (declare (ignore thread))
513 "The One True Thread")
514
515 (definterface thread-status (thread)
516 "Return a string describing THREAD's state."
517 (declare (ignore thread))
518 "")
519
520 (definterface make-lock (&key name)
521 "Make a lock for thread synchronization.
522 Only one thread may hold the lock (via CALL-WITH-LOCK-HELD) at a time."
523 (declare (ignore name))
524 :null-lock)
525
526 (definterface call-with-lock-held (lock function)
527 "Call FUNCTION with LOCK held, queueing if necessary."
528 (declare (ignore lock)
529 (type function function))
530 (funcall function))
531
532 (definterface current-thread ()
533 "Return the currently executing thread."
534 0)
535
536 (definterface all-threads ()
537 "Return a list of all threads.")
538
539 (definterface thread-alive-p (thread)
540 "Test if THREAD is termintated."
541 (member thread (all-threads)))
542
543 (definterface interrupt-thread (thread fn)
544 "Cause THREAD to execute FN.")
545
546 (definterface kill-thread (thread)
547 "Kill THREAD."
548 (declare (ignore thread))
549 nil)
550
551 (definterface send (thread object)
552 "Send OBJECT to thread THREAD.")
553
554 (definterface receive ()
555 "Return the next message from current thread's mailbox.")
556
557 (definterface quit-lisp ()
558 "Exit the current lisp image.")

  ViewVC Help
Powered by ViewVC 1.1.5