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

Contents of /slime/swank-clisp.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5