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

Contents of /slime/swank-clisp.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.10 - (hide 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 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     #+linux
46 heller 1.1 (defmacro without-interrupts (&body body)
47 wjenkner 1.10 `(with-blocked-signals (,linux:SIGINT) ,@body))
48 heller 1.1
49 vsedach 1.3 #-linux
50 wjenkner 1.10 (defmacro without-interrupts (&body body)
51     `(progn ,@body))
52 vsedach 1.3
53 heller 1.1 (defun without-interrupts* (fun)
54     (without-interrupts (funcall fun)))
55    
56 vsedach 1.3 #+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 heller 1.1
60 wjenkner 1.4
61 heller 1.1 ;;; TCP Server
62    
63 heller 1.8 (defmethod create-socket (port)
64     (socket:socket-server port))
65 lgorrie 1.7
66 heller 1.8 (defmethod local-port (socket)
67     (socket:socket-server-port socket))
68 vsedach 1.5
69 heller 1.8 (defmethod close-socket (socket)
70     (socket:socket-server-close socket))
71 vsedach 1.5
72 heller 1.8 (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 vsedach 1.3
80     ;;; Swank functions
81 heller 1.1
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 heller 1.2 (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 heller 1.1 (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 heller 1.2 (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 heller 1.1
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 heller 1.2 (list (debugger-condition-for-emacs)
290 heller 1.1 (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 vsedach 1.6 (compile-file ,@args)
311     (handler-case
312 heller 1.1 (with-input-from-string
313 vsedach 1.6 (*standard-input* (get-output-stream-string *error-output*))
314     ,@body)
315     (sys::simple-end-of-file () nil)))))
316 heller 1.1
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 vsedach 1.6 (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 heller 1.1
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 vsedach 1.6 (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 heller 1.1 (declare (ignore w-p))
368 vsedach 1.6 (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 heller 1.1
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