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

Contents of /slime/swank-clisp.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.33 - (show annotations)
Fri Jun 25 08:05:29 2004 UTC (9 years, 9 months ago) by heller
Branch: MAIN
CVS Tags: SLIME-1-0-ALPHA, SLIME-1-0-BETA
Changes since 1.32: +4 -1 lines
(frame-var-value): New backend function.
1 ;;;; SWANK support for CLISP.
2
3 ;;;; Copyright (C) 2003, 2004 W. Jenkner, V. Sedach
4
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 ;;; 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 "LINUX" packages. The
19 ;;; portable xref from the CMU AI repository and metering.lisp from
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
25 (in-package :swank-backend)
26
27 (eval-when (:compile-toplevel :load-toplevel :execute)
28 ;;(use-package "SOCKET")
29 (use-package "GRAY"))
30
31 (eval-when (:compile-toplevel :execute)
32 (when (find-package "LINUX")
33 (pushnew :linux *features*)))
34
35 #+linux
36 (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 ;; XXX currently only works in CVS version. 2.32 breaks.
50 ;; #+linux
51 ;; (defimplementation call-without-interrupts (fn)
52 ;; (with-blocked-signals (#.linux:SIGINT) (funcall fn)))
53 ;;
54 ;; #-linux
55 (defimplementation call-without-interrupts (fn)
56 (funcall fn))
57
58 #+unix (defmethod getpid () (system::program-id))
59 #+win32 (defmethod getpid () (or (system::getenv "PID") -1))
60 ;; the above is likely broken; we need windows NT users!
61
62 (defimplementation lisp-implementation-type-name ()
63 "clisp")
64
65 (defimplementation set-default-directory (directory)
66 (setf (ext:default-directory) directory)
67 (namestring (setf *default-pathname-defaults* (ext:default-directory))))
68
69
70 ;;; TCP Server
71
72 (defimplementation create-socket (host port)
73 (declare (ignore host))
74 (socket:socket-server port))
75
76 (defimplementation local-port (socket)
77 (socket:socket-server-port socket))
78
79 (defimplementation close-socket (socket)
80 (socket:socket-server-close socket))
81
82 (defimplementation accept-connection (socket)
83 (socket:socket-accept socket
84 :buffered nil ;; XXX should be t
85 :element-type 'character
86 :external-format (ext:make-encoding
87 :charset 'charset:iso-8859-1
88 :line-terminator :unix)))
89
90 ;;; Swank functions
91
92 (defimplementation arglist (fname)
93 (block nil
94 (or (ignore-errors (return (ext:arglist fname)))
95 :not-available)))
96
97 (defimplementation macroexpand-all (form)
98 (ext:expand-form form))
99
100 (defimplementation describe-symbol-for-emacs (symbol)
101 "Return a plist describing SYMBOL.
102 Return NIL if the symbol is unbound."
103 (let ((result ()))
104 (labels ((doc (kind)
105 (or (documentation symbol kind) :not-documented))
106 (maybe-push (property value)
107 (when value
108 (setf result (list* property value result)))))
109 (when (fboundp symbol)
110 (if (macro-function symbol)
111 (setf (getf result :macro) (doc 'function))
112 (setf (getf result :function) (doc 'function))))
113 (maybe-push :variable (when (boundp symbol) (doc 'variable)))
114 (maybe-push :class (when (find-class symbol nil)
115 (doc 'type))) ;this should be fixed
116 result)))
117
118 (defimplementation describe-definition (symbol namespace)
119 (ecase namespace
120 (:variable (describe symbol))
121 (:macro (describe (macro-function symbol)))
122 (:function (describe (symbol-function symbol)))
123 (:class (describe (find-class symbol)))))
124
125 (defun fspec-pathname (symbol)
126 (let ((path (getf (gethash symbol sys::*documentation*) 'sys::file)))
127 (if (and path
128 (member (pathname-type path)
129 custom:*compiled-file-types* :test #'string=))
130 (loop for suffix in custom:*source-file-types*
131 thereis (make-pathname :defaults path :type suffix))
132 path)))
133
134 (defun fspec-location (fspec)
135 (let ((file (fspec-pathname fspec)))
136 (cond (file
137 (multiple-value-bind (truename c) (ignore-errors (truename file))
138 (cond (truename
139 (make-location (list :file (namestring truename))
140 (list :function-name (string fspec))))
141 (t (list :error (princ-to-string c))))))
142 (t (list :error (format nil "No source information available for: ~S"
143 fspec))))))
144
145 (defimplementation find-definitions (name)
146 (list (list name (fspec-location name))))
147
148 (defvar *sldb-topframe*)
149 (defvar *sldb-botframe*)
150 (defvar *sldb-source*)
151 (defvar *sldb-debugmode* 4)
152
153 (defun frame-down (frame)
154 (sys::frame-down-1 frame sys::*debug-mode*))
155
156 (defun frame-up (frame)
157 (sys::frame-up-1 frame sys::*debug-mode*))
158
159 (defimplementation call-with-debugging-environment (debugger-loop-fn)
160 (let* ((sys::*break-count* (1+ sys::*break-count*))
161 (sys::*driver* debugger-loop-fn)
162 (sys::*fasoutput-stream* nil)
163 (sys::*frame-limit1* (sys::frame-limit1 0))
164 (sys::*frame-limit2* (sys::frame-limit2))
165 (sys::*debug-mode* *sldb-debugmode*)
166 (*sldb-topframe* sys::*frame-limit1*))
167 (funcall debugger-loop-fn)))
168
169 (defun nth-frame (index)
170 (loop for frame = *sldb-topframe* then (frame-up frame)
171 repeat index
172 finally (return frame)))
173
174 (defimplementation compute-backtrace (start end)
175 (let ((end (or end most-positive-fixnum)))
176 (loop for last = nil then frame
177 for frame = (nth-frame start) then (frame-up frame)
178 for i from start below end
179 until (or (eq frame last) (system::driver-frame-p frame))
180 collect frame)))
181
182 (defimplementation print-frame (frame stream)
183 (write-string (string-left-trim '(#\Newline)
184 (with-output-to-string (stream)
185 (sys::describe-frame stream frame)))
186 stream))
187
188 (defimplementation eval-in-frame (form frame-number)
189 (sys::eval-at (nth-frame frame-number) form))
190
191 (defimplementation frame-locals (frame-number)
192 (let* ((frame (nth-frame frame-number))
193 (frame-env (sys::eval-at frame '(sys::the-environment))))
194 (append
195 (frame-do-venv frame (svref frame-env 0))
196 (frame-do-fenv frame (svref frame-env 1))
197 (frame-do-benv frame (svref frame-env 2))
198 (frame-do-genv frame (svref frame-env 3))
199 (frame-do-denv frame (svref frame-env 4)))))
200
201 (defimplementation frame-var-value (frame var)
202 (getf (nth var (frame-locals frame)) :value))
203
204 ;; Interpreter-Variablen-Environment has the shape
205 ;; NIL or #(v1 val1 ... vn valn NEXT-ENV).
206
207 (defun frame-do-venv (frame venv)
208 (loop for i from 1 below (length venv) by 2
209 as symbol = (svref venv (1- i))
210 and value = (svref venv i)
211 collect (list :name symbol :id 0
212 :value (if (eq sys::specdecl value)
213 ;; special variable
214 (sys::eval-at frame symbol)
215 ;; lexical variable or symbol macro
216 value))))
217
218 (defun frame-do-fenv (frame fenv)
219 (declare (ignore frame fenv))
220 nil)
221
222 (defun frame-do-benv (frame benv)
223 (declare (ignore frame benv))
224 nil)
225
226 (defun frame-do-genv (frame genv)
227 (declare (ignore frame genv))
228 nil)
229
230 (defun frame-do-denv (frame denv)
231 (declare (ignore frame denv))
232 nil)
233
234 (defimplementation frame-catch-tags (index)
235 (declare (ignore index))
236 nil)
237
238 (defimplementation return-from-frame (index form)
239 (sys::return-from-eval-frame (nth-frame index) form))
240
241 (defimplementation restart-frame (index)
242 (sys::redo-eval-frame (nth-frame index)))
243
244 (defimplementation frame-source-location-for-emacs (index)
245 (list :error (format nil "Cannot find source for frame: ~A"
246 (nth-frame index))))
247
248 ;;; Profiling
249
250 (defimplementation profile (fname)
251 (eval `(mon:monitor ,fname))) ;monitor is a macro
252
253 (defimplementation profiled-functions ()
254 mon:*monitored-functions*)
255
256 (defimplementation unprofile (fname)
257 (eval `(mon:unmonitor ,fname))) ;unmonitor is a macro
258
259 (defimplementation unprofile-all ()
260 (mon:unmonitor))
261
262 (defimplementation profile-report ()
263 (mon:report-monitoring))
264
265 (defimplementation profile-reset ()
266 (mon:reset-all-monitoring))
267
268 (defimplementation profile-package (package callers-p methods)
269 (declare (ignore callers-p methods))
270 (mon:monitor-all package))
271
272 ;;; Handle compiler conditions (find out location of error etc.)
273
274 (defmacro compile-file-frobbing-notes ((&rest args) &body body)
275 "Pass ARGS to COMPILE-FILE, send the compiler notes to
276 *STANDARD-INPUT* and frob them in BODY."
277 `(let ((*error-output* (make-string-output-stream))
278 (*compile-verbose* t))
279 (multiple-value-prog1
280 (compile-file ,@args)
281 (handler-case
282 (with-input-from-string
283 (*standard-input* (get-output-stream-string *error-output*))
284 ,@body)
285 (sys::simple-end-of-file () nil)))))
286
287 (defvar *orig-c-warn* (symbol-function 'system::c-warn))
288 (defvar *orig-c-style-warn* (symbol-function 'system::c-style-warn))
289 (defvar *orig-c-error* (symbol-function 'system::c-error))
290 (defvar *orig-c-report-problems* (symbol-function 'system::c-report-problems))
291
292 (defmacro dynamic-flet (names-functions &body body)
293 "(dynamic-flet ((NAME FUNCTION) ...) BODY ...)
294 Execute BODY with NAME's funtion slot set to FUNCTION."
295 `(ext:letf* ,(loop for (name function) in names-functions
296 collect `((symbol-function ',name) ,function))
297 ,@body))
298
299 (defun compiler-note-location ()
300 "Return the current compiler location."
301 (let ((lineno1 sys::*compile-file-lineno1*)
302 (lineno2 sys::*compile-file-lineno2*)
303 (file sys::*compile-file-truename*))
304 (cond ((and file lineno1 lineno2)
305 (make-location (list ':file (namestring file))
306 (list ':line lineno1)))
307 (*buffer-name*
308 (make-location (list ':buffer *buffer-name*)
309 (list ':position *buffer-offset*)))
310 (t
311 (list :error "No error location available")))))
312
313 (defun signal-compiler-warning (cstring args severity orig-fn)
314 (signal (make-condition 'compiler-condition
315 :severity severity
316 :message (apply #'format nil cstring args)
317 :location (compiler-note-location)))
318 (apply orig-fn cstring args))
319
320 (defun c-warn (cstring &rest args)
321 (signal-compiler-warning cstring args :warning *orig-c-warn*))
322
323 (defun c-style-warn (cstring &rest args)
324 (dynamic-flet ((sys::c-warn *orig-c-warn*))
325 (signal-compiler-warning cstring args :style-warning *orig-c-style-warn*)))
326
327 (defun c-error (cstring &rest args)
328 (signal-compiler-warning cstring args :error *orig-c-error*))
329
330 (defimplementation call-with-compilation-hooks (function)
331 (handler-bind ((warning #'handle-notification-condition))
332 (dynamic-flet ((system::c-warn #'c-warn)
333 (system::c-style-warn #'c-style-warn)
334 (system::c-error #'c-error))
335 (funcall function))))
336
337 (defun handle-notification-condition (condition)
338 "Handle a condition caused by a compiler warning."
339 (signal (make-condition 'compiler-condition
340 :original-condition condition
341 :severity :warning
342 :message (princ-to-string condition)
343 :location (compiler-note-location))))
344
345 (defvar *buffer-name* nil)
346 (defvar *buffer-offset*)
347
348 (defimplementation swank-compile-file (filename load-p)
349 (with-compilation-hooks ()
350 (with-compilation-unit ()
351 (let ((fasl-file (compile-file filename)))
352 (when (and load-p fasl-file)
353 (load fasl-file))
354 nil))))
355
356 (defimplementation swank-compile-string (string &key buffer position)
357 (with-compilation-hooks ()
358 (let ((*buffer-name* buffer)
359 (*buffer-offset* position))
360 (funcall (compile nil (read-from-string
361 (format nil "(~S () ~A)" 'lambda string)))))))
362
363 ;;; Portable XREF from the CMU AI repository.
364
365 (setq pxref::*handle-package-forms* '(cl:in-package))
366
367 (defmacro defxref (name function)
368 `(defimplementation ,name (name)
369 (xref-results (,function name))))
370
371 (defxref who-calls pxref:list-callers)
372 (defxref who-references pxref:list-readers)
373 (defxref who-binds pxref:list-setters)
374 (defxref who-sets pxref:list-setters)
375 (defxref list-callers pxref:list-callers)
376 (defxref list-callees pxref:list-callees)
377
378 (defun xref-results (symbols)
379 (let ((xrefs '()))
380 (dolist (symbol symbols)
381 (push (list symbol (fspec-location symbol)) xrefs))
382 xrefs))
383
384 (when (find-package :swank-loader)
385 (setf (symbol-function (intern "USER-INIT-FILE" :swank-loader))
386 (lambda ()
387 (let ((home (user-homedir-pathname)))
388 (and (ext:probe-directory home)
389 (probe-file (format nil "~A/.swank.lisp"
390 (namestring (truename home)))))))))
391
392 ;; Don't set *debugger-hook* to nil on break.
393 (ext:without-package-lock ()
394 (defun break (&optional (format-string "Break") &rest args)
395 (if (not sys::*use-clcs*)
396 (progn
397 (terpri *error-output*)
398 (apply #'format *error-output*
399 (concatenate 'string "*** - " format-string)
400 args)
401 (funcall ext:*break-driver* t))
402 (let ((condition
403 (make-condition 'simple-condition
404 :format-control format-string
405 :format-arguments args))
406 ;;(*debugger-hook* nil)
407 ;; Issue 91
408 )
409 (ext:with-restarts
410 ((continue
411 :report (lambda (stream)
412 (format stream (sys::text "Return from ~S loop")
413 'break))
414 ()))
415 (with-condition-restarts condition (list (find-restart 'continue))
416 (invoke-debugger condition)))))
417 nil))
418
419 ;;; Inspecting
420
421 (defmethod inspected-parts (o)
422 (let* ((*print-array* nil) (*print-pretty* t)
423 (*print-circle* t) (*print-escape* t)
424 (*print-lines* custom:*inspect-print-lines*)
425 (*print-level* custom:*inspect-print-level*)
426 (*print-length* custom:*inspect-print-length*)
427 (sys::*inspect-all* (make-array 10 :fill-pointer 0 :adjustable t))
428 (tmp-pack (make-package (gensym "INSPECT-TMP-PACKAGE-")))
429 (*package* tmp-pack)
430 (sys::*inspect-unbound-value* (intern "#<unbound>" tmp-pack)))
431 (let ((inspection (sys::inspect-backend o)))
432 (values (format nil "~S~% ~A~{~%~A~}" o
433 (sys::insp-title inspection)
434 (sys::insp-blurb inspection))
435 (let ((count (sys::insp-num-slots inspection))
436 (pairs '()))
437 (dotimes (i count)
438 (multiple-value-bind (value name)
439 (funcall (sys::insp-nth-slot inspection) i)
440 (push (cons (princ-to-string (or name i)) value)
441 pairs)))
442 (nreverse pairs))))))
443
444 (defimplementation quit-lisp ()
445 (#+lisp=cl ext:quit #-lisp=cl lisp:quit code))
446
447 ;;; Local Variables:
448 ;;; eval: (put 'compile-file-frobbing-notes 'lisp-indent-function 1)
449 ;;; eval: (put 'dynamic-flet 'common-lisp-indent-function 1)
450 ;;; End:

  ViewVC Help
Powered by ViewVC 1.1.5