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

Contents of /slime/swank-clisp.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5