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

Contents of /slime/swank-clisp.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5