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

Contents of /slime/swank-clisp.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.18 - (show annotations)
Mon Feb 16 21:40:55 2004 UTC (10 years, 2 months ago) by heller
Branch: MAIN
Changes since 1.17: +20 -16 lines
(set-sigio-handler, add-input-handler): Conditionalize for linux.
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 are also required (alternatively, you have to manually
21 ;;; comment out some code below). Note that currently SLIME comes
22 ;;; with xref but not with metering. Please fetch it from
23
24 ;;; http://cvs.sourceforge.net/viewcvs.py/clocc/clocc/src/tools/metering/
25
26 ;;; and put it (or a link to it) in the directory containing the other
27 ;;; SLIME source files.
28
29 (in-package "SWANK")
30
31 (eval-when (:compile-toplevel :load-toplevel :execute)
32 (use-package "SOCKET")
33 (use-package "GRAY"))
34
35 (eval-when (:compile-toplevel :execute)
36 (when (find-package "LINUX")
37 (pushnew :linux *features*)))
38
39 #+linux
40 (defmacro with-blocked-signals ((&rest signals) &body body)
41 (ext:with-gensyms ("SIGPROCMASK" ret mask)
42 `(multiple-value-bind (,ret ,mask)
43 (linux:sigprocmask-set-n-save
44 ,linux:SIG_BLOCK
45 ,(do ((sigset (linux:sigset-empty)
46 (linux:sigset-add sigset (the fixnum (pop signals)))))
47 ((null signals) sigset)))
48 (linux:check-res ,ret 'linux:sigprocmask-set-n-save)
49 (unwind-protect
50 (progn ,@body)
51 (linux:sigprocmask-set ,linux:SIG_SETMASK ,mask nil)))))
52
53 ;; #+linux
54 ;; (defmethod call-without-interrupts (fn)
55 ;; (with-blocked-signals (#.linux:SIGINT) (funcall fn)))
56 ;;
57 ;; #-linux
58 (defmethod call-without-interrupts (fn)
59 (funcall fn))
60
61 #+unix (defmethod getpid () (system::program-id))
62 #+win32 (defmethod getpid () (or (system::getenv "PID") -1))
63 ;; the above is likely broken; we need windows NT users!
64
65
66 ;;; TCP Server
67
68 (setq *swank-in-background* nil)
69
70 (defimplementation create-socket (host port)
71 (declare (ignore host))
72 (socket:socket-server port))
73
74 (defimplementation local-port (socket)
75 (socket:socket-server-port socket))
76
77 (defimplementation close-socket (socket)
78 (socket:socket-server-close socket))
79
80 (defimplementation accept-connection (socket)
81 (socket:socket-accept socket
82 :buffered nil ;; XXX should be t
83 :element-type 'character
84 :external-format (ext:make-encoding
85 :charset 'charset:iso-8859-1
86 :line-terminator :unix)))
87
88 (defvar *sigio-handlers* '()
89 "List of (key . fn) pairs to be called on SIGIO.")
90
91 (defun sigio-handler (signal)
92 (mapc (lambda (handler) (funcall (cdr handler))) *sigio-handlers*))
93
94 ;(trace sigio-handler)
95
96 (defvar *saved-sigio-handler*)
97
98 #+linux
99 (progn
100 (defun set-sigio-handler ()
101 (setf *saved-sigio-handler*
102 (linux:set-signal-handler linux:SIGIO
103 (lambda (signal) (sigio-handler signal))))
104 (let* ((action (linux:signal-action-retrieve linux:SIGIO))
105 (flags (linux:sa-flags action)))
106 (setf (linux:sa-flags action) (logior flags linux:SA_NODEFER))
107 (linux:signal-action-install linux:SIGIO action)))
108
109
110 (defimplementation add-input-handler (socket fn)
111 (set-sigio-handler)
112 (let ((fd (socket:socket-stream-handle socket)))
113 (format *debug-io* "Adding input handler: ~S ~%" fd)
114 ;; XXX error checking
115 (linux:fcntl3l fd linux:F_SETOWN (getpid))
116 (linux:fcntl3l fd linux:F_SETFL linux:O_ASYNC)
117 (push (cons fd fn) *sigio-handlers*)))
118 )
119
120 (defimplementation remove-input-handlers (socket)
121 (let ((fd (socket:socket-stream-handle socket)))
122 (remove-sigio-handler fd)
123 (setf *sigio-handlers* (delete fd *sigio-handlers* :key #'car)))
124 (close socket))
125
126 ;;; Swank functions
127
128 (defimplementation arglist-string (fname)
129 (format-arglist fname #'ext:arglist))
130
131 (defimplementation macroexpand-all (form)
132 (ext:expand-form form))
133
134 (defimplementation describe-symbol-for-emacs (symbol)
135 "Return a plist describing SYMBOL.
136 Return NIL if the symbol is unbound."
137 (let ((result ()))
138 (labels ((doc (kind)
139 (or (documentation symbol kind) :not-documented))
140 (maybe-push (property value)
141 (when value
142 (setf result (list* property value result)))))
143 (when (fboundp symbol)
144 (if (macro-function symbol)
145 (setf (getf result :macro) (doc 'function))
146 (setf (getf result :function) (doc 'function))))
147 (maybe-push :variable (when (boundp symbol) (doc 'variable)))
148 (maybe-push :class (when (find-class symbol nil)
149 (doc 'type))) ;this should be fixed
150 result)))
151
152 (defun fspec-pathname (symbol &optional type)
153 (declare (ignore type))
154 (let ((path (getf (gethash symbol sys::*documentation*) 'sys::file)))
155 (if (and path
156 (member (pathname-type path)
157 custom:*compiled-file-types* :test #'string=))
158 (loop
159 for suffix in custom:*source-file-types*
160 thereis (make-pathname :defaults path :type suffix))
161 path)))
162
163 (defun find-multiple-definitions (fspec)
164 (list `(,fspec t)))
165
166 (defun find-definition-in-file (fspec type file)
167 (declare (ignore fspec type file))
168 ;; FIXME
169 0)
170
171 (defun fspec-source-locations (fspec)
172 (let ((defs (find-multiple-definitions fspec)))
173 (let ((locations '()))
174 (loop for (fspec type) in defs do
175 (let ((file (fspec-pathname fspec type)))
176 (etypecase file
177 (pathname
178 (let ((start (find-definition-in-file fspec type file)))
179 (push (make-location
180 (list :file (namestring (truename file)))
181 (if start
182 (list :position (1+ start))
183 (list :function-name (string fspec))))
184 locations)))
185 ((member :top-level)
186 (push (list :error (format nil "Defined at toplevel: ~A"
187 fspec))
188 locations))
189 (null
190 (push (list :error (format nil
191 "Unkown source location for ~A"
192 fspec))
193 locations))
194 )))
195 locations)))
196
197 (defimplementation find-function-locations (symbol-name)
198 (multiple-value-bind (symbol foundp) (find-symbol-designator symbol-name)
199 (cond ((not foundp)
200 (list (list :error (format nil "Unkown symbol: ~A" symbol-name))))
201 ((macro-function symbol)
202 (fspec-source-locations symbol))
203 ((special-operator-p symbol)
204 (list (list :error (format nil "~A is a special-operator" symbol))))
205 ((fboundp symbol)
206 (fspec-source-locations symbol))
207 (t (list (list :error
208 (format nil "Symbol not fbound: ~A" symbol-name))))
209 )))
210
211 (defvar *sldb-topframe*)
212 (defvar *sldb-botframe*)
213 (defvar *sldb-source*)
214 (defvar *sldb-restarts*)
215 (defvar *sldb-debugmode* 4)
216
217 (defimplementation call-with-debugging-environment (debugger-loop-fn)
218 (let* ((sys::*break-count* (1+ sys::*break-count*))
219 (sys::*driver* debugger-loop-fn)
220 (sys::*fasoutput-stream* nil)
221 ;;; (sys::*frame-limit1* (sys::frame-limit1 43))
222 (sys::*frame-limit1* (sys::frame-limit1 0))
223 ;;; (sys::*frame-limit2* (sys::frame-limit2))
224 (sys::*debug-mode* *sldb-debugmode*)
225 (*sldb-topframe*
226 (sys::frame-down-1
227 (sys::frame-up-1 sys::*frame-limit1* sys::*debug-mode*)
228 sys::*debug-mode*))
229 (*sldb-botframe* (sys::frame-up *sldb-topframe* sys::*debug-mode*))
230 (*debugger-hook* nil)
231 (*package* *buffer-package*)
232 (*sldb-restarts*
233 (compute-restarts *swank-debugger-condition*))
234 (*print-pretty* nil)
235 (*print-readably* nil))
236 ;;; (*print-level* 3)
237 ;;; (*print-length* 10))
238 (funcall debugger-loop-fn)))
239
240 (defun format-restarts-for-emacs ()
241 (loop for restart in *sldb-restarts*
242 collect (list (princ-to-string (restart-name restart))
243 (princ-to-string restart))))
244
245 (defun nth-frame (index)
246 (loop for frame = *sldb-topframe* then (sys::frame-up-1 frame
247 sys::*debug-mode*)
248 repeat index
249 never (eq frame *sldb-botframe*)
250 finally (return frame)))
251
252 (defun compute-backtrace (start end)
253 (let ((end (or end most-positive-fixnum)))
254 (loop for f = (nth-frame start)
255 then (sys::frame-up-1 f sys::*debug-mode*)
256 for i from start below end
257 until (eq f *sldb-botframe*)
258 collect f)))
259
260 (defimplementation backtrace (start-frame-number end-frame-number)
261 (flet ((format-frame (f i)
262 (print-with-frame-label
263 i (lambda (s)
264 (princ (string-left-trim
265 '(#\Newline)
266 (with-output-to-string (stream)
267 (sys::describe-frame stream f)))
268 s)))))
269 (loop for i from start-frame-number
270 for f in (compute-backtrace start-frame-number end-frame-number)
271 collect (list i (format-frame f i)))))
272
273 (defimplementation eval-in-frame (form frame-number)
274 (sys::eval-at (nth-frame frame-number) form))
275
276 (defimplementation frame-locals (frame-number)
277 (let* ((frame (nth-frame frame-number))
278 (frame-env (sys::eval-at frame '(sys::the-environment))))
279 (append
280 (frame-do-venv frame (svref frame-env 0))
281 (frame-do-fenv frame (svref frame-env 1))
282 (frame-do-benv frame (svref frame-env 2))
283 (frame-do-genv frame (svref frame-env 3))
284 (frame-do-denv frame (svref frame-env 4)))))
285
286 ;; Interpreter-Variablen-Environment has the shape
287 ;; NIL or #(v1 val1 ... vn valn NEXT-ENV).
288
289 (defun frame-do-venv (frame venv)
290 (loop for i from 1 below (length venv) by 2
291 as symbol = (svref venv (1- i))
292 and value = (svref venv i)
293 collect (list :name (to-string symbol) :id 0
294 :value-string (to-string
295 (if (eq sys::specdecl value)
296 ;; special variable
297 (sys::eval-at frame symbol)
298 ;; lexical variable or symbol macro
299 value)))))
300
301 (defun frame-do-fenv (frame fenv)
302 (declare (ignore frame fenv))
303 nil)
304
305 (defun frame-do-benv (frame benv)
306 (declare (ignore frame benv))
307 nil)
308
309 (defun frame-do-genv (frame genv)
310 (declare (ignore frame genv))
311 nil)
312
313 (defun frame-do-denv (frame denv)
314 (declare (ignore frame denv))
315 nil)
316
317 (defimplementation frame-catch-tags (index)
318 (declare (ignore index))
319 nil)
320
321 (defimplementation return-from-frame (index form)
322 (sys::return-from-eval-frame (nth-frame index) (from-string form)))
323
324 (defimplementation restart-frame (index)
325 (sys::redo-eval-frame (nth-frame index)))
326
327 (defimplementation frame-source-location-for-emacs (index)
328 (list :error (format nil "Cannot find source for frame: ~A"
329 (nth-frame index))))
330
331 (defimplementation debugger-info-for-emacs (start end)
332 (list (debugger-condition-for-emacs)
333 (format-restarts-for-emacs)
334 (backtrace start end)))
335
336 (defun nth-restart (index)
337 (nth index *sldb-restarts*))
338
339 (defslimefun invoke-nth-restart (index)
340 (invoke-restart-interactively (nth-restart index)))
341
342 (defslimefun sldb-abort ()
343 (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name)))
344
345 ;;; Profiling
346
347 (defimplementation profile (fname)
348 (eval `(mon:monitor ,fname))) ;monitor is a macro
349
350 (defimplementation profiled-functions ()
351 mon:*monitored-functions*)
352
353 (defimplementation unprofile (fname)
354 (eval `(mon:unmonitor ,fname))) ;unmonitor is a macro
355
356 (defimplementation unprofile-all ()
357 (mon:unmonitor))
358
359 (defimplementation profile-report ()
360 (mon:report-monitoring))
361
362 (defimplementation profile-reset ()
363 (mon:reset-all-monitoring))
364
365 (defimplementation profile-package (package callers-p methods)
366 (declare (ignore callers-p methods))
367 (mon:monitor-all package))
368
369 ;;; Handle compiler conditions (find out location of error etc.)
370
371 (defmacro compile-file-frobbing-notes ((&rest args) &body body)
372 "Pass ARGS to COMPILE-FILE, send the compiler notes to
373 *STANDARD-INPUT* and frob them in BODY."
374 `(let ((*error-output* (make-string-output-stream))
375 (*compile-verbose* t))
376 (multiple-value-prog1
377 (compile-file ,@args)
378 (handler-case
379 (with-input-from-string
380 (*standard-input* (get-output-stream-string *error-output*))
381 ,@body)
382 (sys::simple-end-of-file () nil)))))
383
384 (defimplementation call-with-compilation-hooks (function)
385 (handler-bind ((compiler-condition #'handle-notification-condition))
386 (funcall function)))
387
388 (defun handle-notification-condition (condition)
389 "Handle a condition caused by a compiler warning."
390 (declare (ignore condition)))
391
392 (defvar *buffer-name* nil)
393 (defvar *buffer-offset*)
394
395 (defvar *compiler-note-line-regexp*
396 (regexp:regexp-compile
397 "^(WARNING|ERROR) .* in lines ([0-9]+)\\.\\.[0-9]+ :$"
398 :extended t))
399
400 (defun split-compiler-note-line (line)
401 (multiple-value-bind (all head tail)
402 (regexp:regexp-exec *compiler-note-line-regexp* line)
403 (declare (ignore all))
404 (if head
405 (list (let ((*package* (find-package :keyword)))
406 (read-from-string (regexp:match-string line head)))
407 (read-from-string (regexp:match-string line tail)))
408 (list nil line))))
409
410 ;;; Ugly but essentially working.
411 ;;; TODO: Do something with the summary about undefined functions etc.
412
413 (defimplementation compile-file-for-emacs (filename load-p)
414 (with-compilation-hooks ()
415 (multiple-value-bind (fas-file w-p f-p)
416 (compile-file-frobbing-notes (filename)
417 (read-line) ;""
418 (read-line) ;"Compiling file ..."
419 (loop
420 with condition
421 for (severity message) = (split-compiler-note-line (read-line))
422 until (and (stringp message) (string= message ""))
423 if severity
424 do (when condition
425 (signal condition))
426 (setq condition
427 (make-condition 'compiler-condition
428 :severity severity
429 :message ""
430 :location `(:location (:file ,filename)
431 (:line ,message))))
432 else do (setf (message condition)
433 (format nil "~a~&~a" (message condition) message))
434 finally (when condition
435 (signal condition))))
436 ;; w-p = errors + warnings, f-p = errors + warnings - style warnings,
437 ;; where a result of 0 is replaced by NIL. It follows that w-p
438 ;; is non-NIL iff there was any note whatsoever and that f-p is
439 ;; non-NIL iff there was anything more severe than a style
440 ;; warning. This is completely ANSI compliant.
441 (declare (ignore w-p f-p))
442 (if (and fas-file load-p)
443 (load fas-file)
444 fas-file))))
445
446 (defimplementation compile-string-for-emacs (string &key buffer position)
447 (with-compilation-hooks ()
448 (let ((*package* *buffer-package*)
449 (*buffer-name* buffer)
450 (*buffer-offset* position))
451 (eval (from-string
452 (format nil "(funcall (compile nil '(lambda () ~A)))"
453 string))))))
454
455 ;;; Portable XREF from the CMU AI repository.
456
457 (setq xref::*handle-package-forms* '(cl:in-package))
458
459 (defun lookup-xrefs (finder name)
460 (xref-results-for-emacs (funcall finder (from-string name))))
461
462 (defimplementation who-calls (function-name)
463 (lookup-xrefs #'xref:list-callers function-name))
464
465 (defimplementation who-references (variable)
466 (lookup-xrefs #'xref:list-readers variable))
467
468 (defimplementation who-binds (variable)
469 (lookup-xrefs #'xref:list-setters variable))
470
471 (defimplementation who-sets (variable)
472 (lookup-xrefs #'xref:list-setters variable))
473
474 (defimplementation list-callers (symbol-name)
475 (lookup-xrefs #'xref:who-calls symbol-name))
476
477 (defimplementation list-callees (symbol-name)
478 (lookup-xrefs #'xref:list-callees symbol-name))
479
480 (defun xref-results-for-emacs (fspecs)
481 (let ((xrefs '()))
482 (dolist (fspec fspecs)
483 (dolist (location (fspec-source-locations fspec))
484 (push (cons (to-string fspec) location) xrefs)))
485 (group-xrefs xrefs)))
486
487 (when (find-package :swank-loader)
488 (setf (symbol-function (intern "USER-INIT-FILE" :swank-loader))
489 (lambda ()
490 (let ((home (user-homedir-pathname)))
491 (and (ext:probe-directory home)
492 (probe-file (format nil "~A/.swank.lisp"
493 (namestring (truename home)))))))))
494
495 ;; Don't set *debugger-hook* to nil on break.
496 (ext:without-package-lock ()
497 (defun break (&optional (format-string "Break") &rest args)
498 (if (not sys::*use-clcs*)
499 (progn
500 (terpri *error-output*)
501 (apply #'format *error-output*
502 (concatenate 'string "*** - " format-string)
503 args)
504 (funcall ext:*break-driver* t))
505 (let ((condition
506 (make-condition 'simple-condition
507 :format-control format-string
508 :format-arguments args))
509 ;;(*debugger-hook* nil)
510 ;; Issue 91
511 )
512 (ext:with-restarts
513 ((CONTINUE
514 :report (lambda (stream)
515 (format stream (sys::TEXT "Return from ~S loop")
516 'break))
517 ()))
518 (with-condition-restarts condition (list (find-restart 'CONTINUE))
519 (invoke-debugger condition)))))
520 nil))
521
522 ;;; Local Variables:
523 ;;; eval: (put 'compile-file-frobbing-notes 'lisp-indent-function 1)
524 ;;; End:

  ViewVC Help
Powered by ViewVC 1.1.5