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

Contents of /slime/swank-clisp.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.13 - (hide annotations)
Sun Jan 18 15:46:07 2004 UTC (10 years, 3 months ago) by wjenkner
Branch: MAIN
Changes since 1.12: +4 -4 lines
swank-clisp.lisp (call-without-interrupts): Evaluate linux:SIGFOO at
read time since the macro with-blocked-signals expects a fixnum.

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

  ViewVC Help
Powered by ViewVC 1.1.5