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

Contents of /slime/swank-clisp.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5