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

Contents of /slime/swank-clisp.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.23 - (show annotations)
Thu Mar 4 22:15:40 2004 UTC (10 years, 1 month ago) by heller
Branch: MAIN
Changes since 1.22: +26 -1 lines
(thread-alive-p): Add default implementation.

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

  ViewVC Help
Powered by ViewVC 1.1.5