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

Contents of /slime/swank-clisp.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.36 - (show annotations)
Thu Sep 16 15:58:27 2004 UTC (9 years, 7 months ago) by mbaringer
Branch: MAIN
Changes since 1.35: +54 -3 lines
(swank-mop, inspect-for-emacs): Only define the CLOS parts of the
inspector if the underlying lisp provides the required
functionality. If not enough MOP is present to implement the inspector
then we define some very simple replacement methods.
1 ;;;; SWANK support for CLISP.
2
3 ;;;; Copyright (C) 2003, 2004 W. Jenkner, V. Sedach
4
5 ;;;; swank-clisp.lisp is free software; you can redistribute it and/or
6 ;;;; modify it under the terms of the GNU General Public License as
7 ;;;; published by the Free Software Foundation; either version 2, or
8 ;;;; (at your option) any later version.
9
10 ;;; This is work in progress, but it's already usable. Many things
11 ;;; are adapted from other swank-*.lisp, in particular from
12 ;;; swank-allegro (I don't use allegro at all, but it's the shortest
13 ;;; one and I found Helmut Eller's code there enlightening).
14
15 ;;; This code is developed using the current CVS version of CLISP and
16 ;;; CLISP 2.32 on Linux. Older versions may not work (2.29 and below
17 ;;; are confirmed non-working; please upgrade). You need an image
18 ;;; containing the "SOCKET", "REGEXP", and "LINUX" packages. The
19 ;;; portable xref from the CMU AI repository and metering.lisp from
20 ;;; CLOCC [1] are also required (alternatively, you have to manually
21 ;;; comment out some code below).
22 ;;;
23 ;;; [1] http://cvs.sourceforge.net/viewcvs.py/clocc/clocc/src/tools/metering/
24
25 (in-package :swank-backend)
26
27 (eval-when (:compile-toplevel :load-toplevel :execute)
28 ;;(use-package "SOCKET")
29 (use-package "GRAY"))
30
31 (eval-when (:compile-toplevel :execute)
32 (when (find-package "LINUX")
33 (pushnew :linux *features*)))
34
35 ;;;; if this listp has the complete CLOS then we use it, othewise we
36 ;;;; build up a "fake" swank-mop and then overide the methods in the
37 ;;;; inspector.
38
39 (eval-when (:compile-toplevel :load-toplevel :execute)
40 (defvar *have-mop*
41 (if (and (find-package :clos)
42 (eql :external
43 (nth-value 1 (find-symbol (string ':standard-slot-definition) :clos))))
44 '(and)
45 '(or))))
46
47 #+#.*have-mop*
48 (import-to-swank-mop
49 '(;; classes
50 cl:standard-generic-function
51 clos:standard-slot-definition
52 cl:method
53 cl:standard-class
54 ;; standard-class readers
55 clos:class-default-initargs
56 clos:class-direct-default-initargs
57 clos:class-direct-slots
58 clos:class-direct-subclasses
59 clos:class-direct-superclasses
60 clos:class-finalized-p
61 cl:class-name
62 clos:class-precedence-list
63 clos:class-prototype
64 clos:class-slots
65 ;; generic function readers
66 clos:generic-function-argument-precedence-order
67 clos:generic-function-declarations
68 clos:generic-function-lambda-list
69 clos:generic-function-methods
70 clos:generic-function-method-class
71 clos:generic-function-method-combination
72 clos:generic-function-name
73 ;; method readers
74 clos:method-generic-function
75 clos:method-function
76 clos:method-lambda-list
77 clos:method-specializers
78 clos:method-qualifiers
79 ;; slot readers
80 clos:slot-definition-allocation
81 clos:slot-definition-initargs
82 clos:slot-definition-initform
83 clos:slot-definition-initfunction
84 clos:slot-definition-name
85 clos:slot-definition-type
86 clos:slot-definition-readers
87 clos:slot-definition-writers
88 ))
89
90 #+#.*have-mop*
91 (defun swank-mop:slot-definition-documentation (slot)
92 (clos::slot-definition-documentation slot))
93
94 #-#.*have-mop*
95 (defclass swank-mop:standard-slot-definition ()
96 ()
97 (:documentation "Dummy class created so that swank.lisp will compile and load."))
98
99 #+linux
100 (defmacro with-blocked-signals ((&rest signals) &body body)
101 (ext:with-gensyms ("SIGPROCMASK" ret mask)
102 `(multiple-value-bind (,ret ,mask)
103 (linux:sigprocmask-set-n-save
104 ,linux:SIG_BLOCK
105 ,(do ((sigset (linux:sigset-empty)
106 (linux:sigset-add sigset (the fixnum (pop signals)))))
107 ((null signals) sigset)))
108 (linux:check-res ,ret 'linux:sigprocmask-set-n-save)
109 (unwind-protect
110 (progn ,@body)
111 (linux:sigprocmask-set ,linux:SIG_SETMASK ,mask nil)))))
112
113 ;; XXX currently only works in CVS version. 2.32 breaks.
114 ;; #+linux
115 ;; (defimplementation call-without-interrupts (fn)
116 ;; (with-blocked-signals (#.linux:SIGINT) (funcall fn)))
117 ;;
118 ;; #-linux
119 (defimplementation call-without-interrupts (fn)
120 (funcall fn))
121
122 #+unix (defmethod getpid () (system::program-id))
123 #+win32 (defmethod getpid () (or (system::getenv "PID") -1))
124 ;; the above is likely broken; we need windows NT users!
125
126 (defimplementation lisp-implementation-type-name ()
127 "clisp")
128
129 (defimplementation set-default-directory (directory)
130 (setf (ext:default-directory) directory)
131 (namestring (setf *default-pathname-defaults* (ext:default-directory))))
132
133
134 ;;; TCP Server
135
136 (defimplementation create-socket (host port)
137 (declare (ignore host))
138 (socket:socket-server port))
139
140 (defimplementation local-port (socket)
141 (socket:socket-server-port socket))
142
143 (defimplementation close-socket (socket)
144 (socket:socket-server-close socket))
145
146 (defimplementation accept-connection (socket)
147 (socket:socket-accept socket
148 :buffered nil ;; XXX should be t
149 :element-type 'character
150 :external-format (ext:make-encoding
151 :charset 'charset:iso-8859-1
152 :line-terminator :unix)))
153
154 ;;; Swank functions
155
156 (defimplementation arglist (fname)
157 (block nil
158 (or (ignore-errors (return (ext:arglist fname)))
159 :not-available)))
160
161 (defimplementation macroexpand-all (form)
162 (ext:expand-form form))
163
164 (defimplementation describe-symbol-for-emacs (symbol)
165 "Return a plist describing SYMBOL.
166 Return NIL if the symbol is unbound."
167 (let ((result ()))
168 (labels ((doc (kind)
169 (or (documentation symbol kind) :not-documented))
170 (maybe-push (property value)
171 (when value
172 (setf result (list* property value result)))))
173 (when (fboundp symbol)
174 (if (macro-function symbol)
175 (setf (getf result :macro) (doc 'function))
176 (setf (getf result :function) (doc 'function))))
177 (maybe-push :variable (when (boundp symbol) (doc 'variable)))
178 (maybe-push :class (when (find-class symbol nil)
179 (doc 'type))) ;this should be fixed
180 result)))
181
182 (defimplementation describe-definition (symbol namespace)
183 (ecase namespace
184 (:variable (describe symbol))
185 (:macro (describe (macro-function symbol)))
186 (:function (describe (symbol-function symbol)))
187 (:class (describe (find-class symbol)))))
188
189 (defun fspec-pathname (symbol)
190 (let ((path (getf (gethash symbol sys::*documentation*) 'sys::file)))
191 (if (and path
192 (member (pathname-type path)
193 custom:*compiled-file-types* :test #'string=))
194 (loop for suffix in custom:*source-file-types*
195 thereis (make-pathname :defaults path :type suffix))
196 path)))
197
198 (defun fspec-location (fspec)
199 (let ((file (fspec-pathname fspec)))
200 (cond (file
201 (multiple-value-bind (truename c) (ignore-errors (truename file))
202 (cond (truename
203 (make-location (list :file (namestring truename))
204 (list :function-name (string fspec))))
205 (t (list :error (princ-to-string c))))))
206 (t (list :error (format nil "No source information available for: ~S"
207 fspec))))))
208
209 (defimplementation find-definitions (name)
210 (list (list name (fspec-location name))))
211
212 (defvar *sldb-topframe*)
213 (defvar *sldb-botframe*)
214 (defvar *sldb-source*)
215 (defvar *sldb-debugmode* 4)
216
217 (defun frame-down (frame)
218 (sys::frame-down-1 frame sys::*debug-mode*))
219
220 (defun frame-up (frame)
221 (sys::frame-up-1 frame sys::*debug-mode*))
222
223 (defimplementation call-with-debugging-environment (debugger-loop-fn)
224 (let* ((sys::*break-count* (1+ sys::*break-count*))
225 (sys::*driver* debugger-loop-fn)
226 (sys::*fasoutput-stream* nil)
227 (sys::*frame-limit1* (sys::frame-limit1 0))
228 (sys::*frame-limit2* (sys::frame-limit2))
229 (sys::*debug-mode* *sldb-debugmode*)
230 (*sldb-topframe* sys::*frame-limit1*))
231 (funcall debugger-loop-fn)))
232
233 (defun nth-frame (index)
234 (loop for frame = *sldb-topframe* then (frame-up frame)
235 repeat index
236 finally (return frame)))
237
238 (defimplementation compute-backtrace (start end)
239 (let ((end (or end most-positive-fixnum)))
240 (loop for last = nil then frame
241 for frame = (nth-frame start) then (frame-up frame)
242 for i from start below end
243 until (or (eq frame last) (system::driver-frame-p frame))
244 collect frame)))
245
246 (defimplementation print-frame (frame stream)
247 (write-string (string-left-trim '(#\Newline)
248 (with-output-to-string (stream)
249 (sys::describe-frame stream frame)))
250 stream))
251
252 (defimplementation eval-in-frame (form frame-number)
253 (sys::eval-at (nth-frame frame-number) form))
254
255 (defimplementation frame-locals (frame-number)
256 (let* ((frame (nth-frame frame-number))
257 (frame-env (sys::eval-at frame '(sys::the-environment))))
258 (append
259 (frame-do-venv frame (svref frame-env 0))
260 (frame-do-fenv frame (svref frame-env 1))
261 (frame-do-benv frame (svref frame-env 2))
262 (frame-do-genv frame (svref frame-env 3))
263 (frame-do-denv frame (svref frame-env 4)))))
264
265 (defimplementation frame-var-value (frame var)
266 (getf (nth var (frame-locals frame)) :value))
267
268 ;; Interpreter-Variablen-Environment has the shape
269 ;; NIL or #(v1 val1 ... vn valn NEXT-ENV).
270
271 (defun frame-do-venv (frame venv)
272 (loop for i from 1 below (length venv) by 2
273 as symbol = (svref venv (1- i))
274 and value = (svref venv i)
275 collect (list :name symbol :id 0
276 :value (if (eq sys::specdecl value)
277 ;; special variable
278 (sys::eval-at frame symbol)
279 ;; lexical variable or symbol macro
280 value))))
281
282 (defun frame-do-fenv (frame fenv)
283 (declare (ignore frame fenv))
284 nil)
285
286 (defun frame-do-benv (frame benv)
287 (declare (ignore frame benv))
288 nil)
289
290 (defun frame-do-genv (frame genv)
291 (declare (ignore frame genv))
292 nil)
293
294 (defun frame-do-denv (frame denv)
295 (declare (ignore frame denv))
296 nil)
297
298 (defimplementation frame-catch-tags (index)
299 (declare (ignore index))
300 nil)
301
302 (defimplementation return-from-frame (index form)
303 (sys::return-from-eval-frame (nth-frame index) form))
304
305 (defimplementation restart-frame (index)
306 (sys::redo-eval-frame (nth-frame index)))
307
308 (defimplementation frame-source-location-for-emacs (index)
309 (list :error (format nil "Cannot find source for frame: ~A"
310 (nth-frame index))))
311
312 ;;; Profiling
313
314 (defimplementation profile (fname)
315 (eval `(mon:monitor ,fname))) ;monitor is a macro
316
317 (defimplementation profiled-functions ()
318 mon:*monitored-functions*)
319
320 (defimplementation unprofile (fname)
321 (eval `(mon:unmonitor ,fname))) ;unmonitor is a macro
322
323 (defimplementation unprofile-all ()
324 (mon:unmonitor))
325
326 (defimplementation profile-report ()
327 (mon:report-monitoring))
328
329 (defimplementation profile-reset ()
330 (mon:reset-all-monitoring))
331
332 (defimplementation profile-package (package callers-p methods)
333 (declare (ignore callers-p methods))
334 (mon:monitor-all package))
335
336 ;;; Handle compiler conditions (find out location of error etc.)
337
338 (defmacro compile-file-frobbing-notes ((&rest args) &body body)
339 "Pass ARGS to COMPILE-FILE, send the compiler notes to
340 *STANDARD-INPUT* and frob them in BODY."
341 `(let ((*error-output* (make-string-output-stream))
342 (*compile-verbose* t))
343 (multiple-value-prog1
344 (compile-file ,@args)
345 (handler-case
346 (with-input-from-string
347 (*standard-input* (get-output-stream-string *error-output*))
348 ,@body)
349 (sys::simple-end-of-file () nil)))))
350
351 (defvar *orig-c-warn* (symbol-function 'system::c-warn))
352 (defvar *orig-c-style-warn* (symbol-function 'system::c-style-warn))
353 (defvar *orig-c-error* (symbol-function 'system::c-error))
354 (defvar *orig-c-report-problems* (symbol-function 'system::c-report-problems))
355
356 (defmacro dynamic-flet (names-functions &body body)
357 "(dynamic-flet ((NAME FUNCTION) ...) BODY ...)
358 Execute BODY with NAME's funtion slot set to FUNCTION."
359 `(ext:letf* ,(loop for (name function) in names-functions
360 collect `((symbol-function ',name) ,function))
361 ,@body))
362
363 (defun compiler-note-location ()
364 "Return the current compiler location."
365 (let ((lineno1 sys::*compile-file-lineno1*)
366 (lineno2 sys::*compile-file-lineno2*)
367 (file sys::*compile-file-truename*))
368 (cond ((and file lineno1 lineno2)
369 (make-location (list ':file (namestring file))
370 (list ':line lineno1)))
371 (*buffer-name*
372 (make-location (list ':buffer *buffer-name*)
373 (list ':position *buffer-offset*)))
374 (t
375 (list :error "No error location available")))))
376
377 (defun signal-compiler-warning (cstring args severity orig-fn)
378 (signal (make-condition 'compiler-condition
379 :severity severity
380 :message (apply #'format nil cstring args)
381 :location (compiler-note-location)))
382 (apply orig-fn cstring args))
383
384 (defun c-warn (cstring &rest args)
385 (signal-compiler-warning cstring args :warning *orig-c-warn*))
386
387 (defun c-style-warn (cstring &rest args)
388 (dynamic-flet ((sys::c-warn *orig-c-warn*))
389 (signal-compiler-warning cstring args :style-warning *orig-c-style-warn*)))
390
391 (defun c-error (cstring &rest args)
392 (signal-compiler-warning cstring args :error *orig-c-error*))
393
394 (defimplementation call-with-compilation-hooks (function)
395 (handler-bind ((warning #'handle-notification-condition))
396 (dynamic-flet ((system::c-warn #'c-warn)
397 (system::c-style-warn #'c-style-warn)
398 (system::c-error #'c-error))
399 (funcall function))))
400
401 (defun handle-notification-condition (condition)
402 "Handle a condition caused by a compiler warning."
403 (signal (make-condition 'compiler-condition
404 :original-condition condition
405 :severity :warning
406 :message (princ-to-string condition)
407 :location (compiler-note-location))))
408
409 (defvar *buffer-name* nil)
410 (defvar *buffer-offset*)
411
412 (defimplementation swank-compile-file (filename load-p)
413 (with-compilation-hooks ()
414 (with-compilation-unit ()
415 (let ((fasl-file (compile-file filename)))
416 (when (and load-p fasl-file)
417 (load fasl-file))
418 nil))))
419
420 (defimplementation swank-compile-string (string &key buffer position directory)
421 (declare (ignore directory))
422 (with-compilation-hooks ()
423 (let ((*buffer-name* buffer)
424 (*buffer-offset* position))
425 (funcall (compile nil (read-from-string
426 (format nil "(~S () ~A)" 'lambda string)))))))
427
428 ;;; Portable XREF from the CMU AI repository.
429
430 (setq pxref::*handle-package-forms* '(cl:in-package))
431
432 (defmacro defxref (name function)
433 `(defimplementation ,name (name)
434 (xref-results (,function name))))
435
436 (defxref who-calls pxref:list-callers)
437 (defxref who-references pxref:list-readers)
438 (defxref who-binds pxref:list-setters)
439 (defxref who-sets pxref:list-setters)
440 (defxref list-callers pxref:list-callers)
441 (defxref list-callees pxref:list-callees)
442
443 (defun xref-results (symbols)
444 (let ((xrefs '()))
445 (dolist (symbol symbols)
446 (push (list symbol (fspec-location symbol)) xrefs))
447 xrefs))
448
449 (when (find-package :swank-loader)
450 (setf (symbol-function (intern "USER-INIT-FILE" :swank-loader))
451 (lambda ()
452 (let ((home (user-homedir-pathname)))
453 (and (ext:probe-directory home)
454 (probe-file (format nil "~A/.swank.lisp"
455 (namestring (truename home)))))))))
456
457 ;; Don't set *debugger-hook* to nil on break.
458 (ext:without-package-lock ()
459 (defun break (&optional (format-string "Break") &rest args)
460 (if (not sys::*use-clcs*)
461 (progn
462 (terpri *error-output*)
463 (apply #'format *error-output*
464 (concatenate 'string "*** - " format-string)
465 args)
466 (funcall ext:*break-driver* t))
467 (let ((condition
468 (make-condition 'simple-condition
469 :format-control format-string
470 :format-arguments args))
471 ;;(*debugger-hook* nil)
472 ;; Issue 91
473 )
474 (ext:with-restarts
475 ((continue
476 :report (lambda (stream)
477 (format stream (sys::text "Return from ~S loop")
478 'break))
479 ()))
480 (with-condition-restarts condition (list (find-restart 'continue))
481 (invoke-debugger condition)))))
482 nil))
483
484 ;;; Inspecting
485
486 (defclass clisp-inspector (inspector)
487 ())
488
489 (defimplementation make-default-inspector ()
490 (make-instance 'clisp-inspector))
491
492 (defmethod inspect-for-emacs ((o t) (inspector clisp-inspector))
493 (declare (ignore inspector))
494 (let* ((*print-array* nil) (*print-pretty* t)
495 (*print-circle* t) (*print-escape* t)
496 (*print-lines* custom:*inspect-print-lines*)
497 (*print-level* custom:*inspect-print-level*)
498 (*print-length* custom:*inspect-print-length*)
499 (sys::*inspect-all* (make-array 10 :fill-pointer 0 :adjustable t))
500 (tmp-pack (make-package (gensym "INSPECT-TMP-PACKAGE-")))
501 (*package* tmp-pack)
502 (sys::*inspect-unbound-value* (intern "#<unbound>" tmp-pack)))
503 (let ((inspection (sys::inspect-backend o)))
504 (values (format nil "~S~% ~A~{~%~A~}" o
505 (sys::insp-title inspection)
506 (sys::insp-blurb inspection))
507 (loop with count = (sys::insp-num-slots inspection)
508 for i upto count
509 for (value name) = (multiple-value-list (funcall (sys::insp-nth-slot inspection) i))
510 collect `(:value ,name)
511 collect " = "
512 collect `(:value ,value)
513 collect '(:newline))))))
514
515 #-#.*have-mop*
516 (defmethod inspect-for-emacs ((o standard-object) (inspector clisp-inspector))
517 (declare (ignore inspector))
518 (values (format nil "An instance of the class" (class-of o))
519 `("Sorry, inspecting of instances is not supported in this version of CLISP."
520 (:newline)
521 "Please upgrade to a recent version of CLISP.")))
522
523 #-#.*have-mop*
524 (defmethod inspect-for-emacs ((gf standard-generic-function) (inspector clisp-inspector))
525 (declare (ignore inspector))
526 (values "A generic function."
527 `("Sorry, inspecting of generic functions is not supported in this version of CLISP."
528 (:newline)
529 "Please upgrade to a recent version of CLISP.")))
530
531 #-#.*have-mop*
532 (defmethod inspect-for-emacs ((method standard-method) (inspector t))
533 (declare (ignore inspector))
534 (values "A standard method."
535 `("Sorry, inspecting of methods is not supported in this version of CLISP."
536 (:newline)
537 "Please upgrade to a recent version of CLISP.")))
538
539 #-#.*have-mop*
540 (defmethod inspect-for-emacs ((class standard-class) (inspector t))
541 (declare (ignore inspector))
542 (values "A class."
543 `("Sorry, inspecting of classes is not supported in this version of CLISP."
544 (:newline)
545 "Please upgrade to a recent version of CLISP.")))
546
547 #-#.*have-mop*
548 (defmethod inspect-for-emacs ((slot swank-mop:standard-slot-definition) (inspector t))
549 (declare (ignore inspector)))
550
551 (defimplementation quit-lisp ()
552 (#+lisp=cl ext:quit #-lisp=cl lisp:quit code))
553
554 ;;; Local Variables:
555 ;;; eval: (put 'compile-file-frobbing-notes 'lisp-indent-function 1)
556 ;;; eval: (put 'dynamic-flet 'common-lisp-indent-function 1)
557 ;;; End:

  ViewVC Help
Powered by ViewVC 1.1.5