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

Contents of /slime/swank-clisp.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5