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

Contents of /slime/swank-clisp.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.35 - (show annotations)
Thu Sep 16 12:18:36 2004 UTC (9 years, 7 months ago) by mbaringer
Branch: MAIN
Changes since 1.34: +64 -9 lines
(swank-mop): Implement the MOP compatability package.
(inspectod-for-emacs): Update for new inspection API.
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 (import-to-swank-mop
36 '(;; classes
37 cl:standard-generic-function
38 clos:standard-slot-definition
39 cl:method
40 cl:standard-class
41 ;; standard-class readers
42 clos:class-default-initargs
43 clos:class-direct-default-initargs
44 clos:class-direct-slots
45 clos:class-direct-subclasses
46 clos:class-direct-superclasses
47 clos:class-finalized-p
48 cl:class-name
49 clos:class-precedence-list
50 clos:class-prototype
51 clos:class-slots
52 ;; generic function readers
53 clos:generic-function-argument-precedence-order
54 clos:generic-function-declarations
55 clos:generic-function-lambda-list
56 clos:generic-function-methods
57 clos:generic-function-method-class
58 clos:generic-function-method-combination
59 clos:generic-function-name
60 ;; method readers
61 clos:method-generic-function
62 clos:method-function
63 clos:method-lambda-list
64 clos:method-specializers
65 clos:method-qualifiers
66 ;; slot readers
67 clos:slot-definition-allocation
68 clos:slot-definition-initargs
69 clos:slot-definition-initform
70 clos:slot-definition-initfunction
71 clos:slot-definition-name
72 clos:slot-definition-type
73 clos:slot-definition-readers
74 clos:slot-definition-writers
75 ))
76
77 (defun swank-mop:slot-definition-documentation (slot)
78 (clos::slot-definition-documentation slot))
79
80 #+linux
81 (defmacro with-blocked-signals ((&rest signals) &body body)
82 (ext:with-gensyms ("SIGPROCMASK" ret mask)
83 `(multiple-value-bind (,ret ,mask)
84 (linux:sigprocmask-set-n-save
85 ,linux:SIG_BLOCK
86 ,(do ((sigset (linux:sigset-empty)
87 (linux:sigset-add sigset (the fixnum (pop signals)))))
88 ((null signals) sigset)))
89 (linux:check-res ,ret 'linux:sigprocmask-set-n-save)
90 (unwind-protect
91 (progn ,@body)
92 (linux:sigprocmask-set ,linux:SIG_SETMASK ,mask nil)))))
93
94 ;; XXX currently only works in CVS version. 2.32 breaks.
95 ;; #+linux
96 ;; (defimplementation call-without-interrupts (fn)
97 ;; (with-blocked-signals (#.linux:SIGINT) (funcall fn)))
98 ;;
99 ;; #-linux
100 (defimplementation call-without-interrupts (fn)
101 (funcall fn))
102
103 #+unix (defmethod getpid () (system::program-id))
104 #+win32 (defmethod getpid () (or (system::getenv "PID") -1))
105 ;; the above is likely broken; we need windows NT users!
106
107 (defimplementation lisp-implementation-type-name ()
108 "clisp")
109
110 (defimplementation set-default-directory (directory)
111 (setf (ext:default-directory) directory)
112 (namestring (setf *default-pathname-defaults* (ext:default-directory))))
113
114
115 ;;; TCP Server
116
117 (defimplementation create-socket (host port)
118 (declare (ignore host))
119 (socket:socket-server port))
120
121 (defimplementation local-port (socket)
122 (socket:socket-server-port socket))
123
124 (defimplementation close-socket (socket)
125 (socket:socket-server-close socket))
126
127 (defimplementation accept-connection (socket)
128 (socket:socket-accept socket
129 :buffered nil ;; XXX should be t
130 :element-type 'character
131 :external-format (ext:make-encoding
132 :charset 'charset:iso-8859-1
133 :line-terminator :unix)))
134
135 ;;; Swank functions
136
137 (defimplementation arglist (fname)
138 (block nil
139 (or (ignore-errors (return (ext:arglist fname)))
140 :not-available)))
141
142 (defimplementation macroexpand-all (form)
143 (ext:expand-form form))
144
145 (defimplementation describe-symbol-for-emacs (symbol)
146 "Return a plist describing SYMBOL.
147 Return NIL if the symbol is unbound."
148 (let ((result ()))
149 (labels ((doc (kind)
150 (or (documentation symbol kind) :not-documented))
151 (maybe-push (property value)
152 (when value
153 (setf result (list* property value result)))))
154 (when (fboundp symbol)
155 (if (macro-function symbol)
156 (setf (getf result :macro) (doc 'function))
157 (setf (getf result :function) (doc 'function))))
158 (maybe-push :variable (when (boundp symbol) (doc 'variable)))
159 (maybe-push :class (when (find-class symbol nil)
160 (doc 'type))) ;this should be fixed
161 result)))
162
163 (defimplementation describe-definition (symbol namespace)
164 (ecase namespace
165 (:variable (describe symbol))
166 (:macro (describe (macro-function symbol)))
167 (:function (describe (symbol-function symbol)))
168 (:class (describe (find-class symbol)))))
169
170 (defun fspec-pathname (symbol)
171 (let ((path (getf (gethash symbol sys::*documentation*) 'sys::file)))
172 (if (and path
173 (member (pathname-type path)
174 custom:*compiled-file-types* :test #'string=))
175 (loop for suffix in custom:*source-file-types*
176 thereis (make-pathname :defaults path :type suffix))
177 path)))
178
179 (defun fspec-location (fspec)
180 (let ((file (fspec-pathname fspec)))
181 (cond (file
182 (multiple-value-bind (truename c) (ignore-errors (truename file))
183 (cond (truename
184 (make-location (list :file (namestring truename))
185 (list :function-name (string fspec))))
186 (t (list :error (princ-to-string c))))))
187 (t (list :error (format nil "No source information available for: ~S"
188 fspec))))))
189
190 (defimplementation find-definitions (name)
191 (list (list name (fspec-location name))))
192
193 (defvar *sldb-topframe*)
194 (defvar *sldb-botframe*)
195 (defvar *sldb-source*)
196 (defvar *sldb-debugmode* 4)
197
198 (defun frame-down (frame)
199 (sys::frame-down-1 frame sys::*debug-mode*))
200
201 (defun frame-up (frame)
202 (sys::frame-up-1 frame sys::*debug-mode*))
203
204 (defimplementation call-with-debugging-environment (debugger-loop-fn)
205 (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 0))
209 (sys::*frame-limit2* (sys::frame-limit2))
210 (sys::*debug-mode* *sldb-debugmode*)
211 (*sldb-topframe* sys::*frame-limit1*))
212 (funcall debugger-loop-fn)))
213
214 (defun nth-frame (index)
215 (loop for frame = *sldb-topframe* then (frame-up frame)
216 repeat index
217 finally (return frame)))
218
219 (defimplementation compute-backtrace (start end)
220 (let ((end (or end most-positive-fixnum)))
221 (loop for last = nil then frame
222 for frame = (nth-frame start) then (frame-up frame)
223 for i from start below end
224 until (or (eq frame last) (system::driver-frame-p frame))
225 collect frame)))
226
227 (defimplementation print-frame (frame stream)
228 (write-string (string-left-trim '(#\Newline)
229 (with-output-to-string (stream)
230 (sys::describe-frame stream frame)))
231 stream))
232
233 (defimplementation eval-in-frame (form frame-number)
234 (sys::eval-at (nth-frame frame-number) form))
235
236 (defimplementation frame-locals (frame-number)
237 (let* ((frame (nth-frame frame-number))
238 (frame-env (sys::eval-at frame '(sys::the-environment))))
239 (append
240 (frame-do-venv frame (svref frame-env 0))
241 (frame-do-fenv frame (svref frame-env 1))
242 (frame-do-benv frame (svref frame-env 2))
243 (frame-do-genv frame (svref frame-env 3))
244 (frame-do-denv frame (svref frame-env 4)))))
245
246 (defimplementation frame-var-value (frame var)
247 (getf (nth var (frame-locals frame)) :value))
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 (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 symbol :id 0
257 :value (if (eq sys::specdecl value)
258 ;; special variable
259 (sys::eval-at frame symbol)
260 ;; lexical variable or symbol macro
261 value))))
262
263 (defun frame-do-fenv (frame fenv)
264 (declare (ignore frame fenv))
265 nil)
266
267 (defun frame-do-benv (frame benv)
268 (declare (ignore frame benv))
269 nil)
270
271 (defun frame-do-genv (frame genv)
272 (declare (ignore frame genv))
273 nil)
274
275 (defun frame-do-denv (frame denv)
276 (declare (ignore frame denv))
277 nil)
278
279 (defimplementation frame-catch-tags (index)
280 (declare (ignore index))
281 nil)
282
283 (defimplementation return-from-frame (index form)
284 (sys::return-from-eval-frame (nth-frame index) form))
285
286 (defimplementation restart-frame (index)
287 (sys::redo-eval-frame (nth-frame index)))
288
289 (defimplementation frame-source-location-for-emacs (index)
290 (list :error (format nil "Cannot find source for frame: ~A"
291 (nth-frame index))))
292
293 ;;; Profiling
294
295 (defimplementation profile (fname)
296 (eval `(mon:monitor ,fname))) ;monitor is a macro
297
298 (defimplementation profiled-functions ()
299 mon:*monitored-functions*)
300
301 (defimplementation unprofile (fname)
302 (eval `(mon:unmonitor ,fname))) ;unmonitor is a macro
303
304 (defimplementation unprofile-all ()
305 (mon:unmonitor))
306
307 (defimplementation profile-report ()
308 (mon:report-monitoring))
309
310 (defimplementation profile-reset ()
311 (mon:reset-all-monitoring))
312
313 (defimplementation profile-package (package callers-p methods)
314 (declare (ignore callers-p methods))
315 (mon:monitor-all package))
316
317 ;;; Handle compiler conditions (find out location of error etc.)
318
319 (defmacro compile-file-frobbing-notes ((&rest args) &body body)
320 "Pass ARGS to COMPILE-FILE, send the compiler notes to
321 *STANDARD-INPUT* and frob them in BODY."
322 `(let ((*error-output* (make-string-output-stream))
323 (*compile-verbose* t))
324 (multiple-value-prog1
325 (compile-file ,@args)
326 (handler-case
327 (with-input-from-string
328 (*standard-input* (get-output-stream-string *error-output*))
329 ,@body)
330 (sys::simple-end-of-file () nil)))))
331
332 (defvar *orig-c-warn* (symbol-function 'system::c-warn))
333 (defvar *orig-c-style-warn* (symbol-function 'system::c-style-warn))
334 (defvar *orig-c-error* (symbol-function 'system::c-error))
335 (defvar *orig-c-report-problems* (symbol-function 'system::c-report-problems))
336
337 (defmacro dynamic-flet (names-functions &body body)
338 "(dynamic-flet ((NAME FUNCTION) ...) BODY ...)
339 Execute BODY with NAME's funtion slot set to FUNCTION."
340 `(ext:letf* ,(loop for (name function) in names-functions
341 collect `((symbol-function ',name) ,function))
342 ,@body))
343
344 (defun compiler-note-location ()
345 "Return the current compiler location."
346 (let ((lineno1 sys::*compile-file-lineno1*)
347 (lineno2 sys::*compile-file-lineno2*)
348 (file sys::*compile-file-truename*))
349 (cond ((and file lineno1 lineno2)
350 (make-location (list ':file (namestring file))
351 (list ':line lineno1)))
352 (*buffer-name*
353 (make-location (list ':buffer *buffer-name*)
354 (list ':position *buffer-offset*)))
355 (t
356 (list :error "No error location available")))))
357
358 (defun signal-compiler-warning (cstring args severity orig-fn)
359 (signal (make-condition 'compiler-condition
360 :severity severity
361 :message (apply #'format nil cstring args)
362 :location (compiler-note-location)))
363 (apply orig-fn cstring args))
364
365 (defun c-warn (cstring &rest args)
366 (signal-compiler-warning cstring args :warning *orig-c-warn*))
367
368 (defun c-style-warn (cstring &rest args)
369 (dynamic-flet ((sys::c-warn *orig-c-warn*))
370 (signal-compiler-warning cstring args :style-warning *orig-c-style-warn*)))
371
372 (defun c-error (cstring &rest args)
373 (signal-compiler-warning cstring args :error *orig-c-error*))
374
375 (defimplementation call-with-compilation-hooks (function)
376 (handler-bind ((warning #'handle-notification-condition))
377 (dynamic-flet ((system::c-warn #'c-warn)
378 (system::c-style-warn #'c-style-warn)
379 (system::c-error #'c-error))
380 (funcall function))))
381
382 (defun handle-notification-condition (condition)
383 "Handle a condition caused by a compiler warning."
384 (signal (make-condition 'compiler-condition
385 :original-condition condition
386 :severity :warning
387 :message (princ-to-string condition)
388 :location (compiler-note-location))))
389
390 (defvar *buffer-name* nil)
391 (defvar *buffer-offset*)
392
393 (defimplementation swank-compile-file (filename load-p)
394 (with-compilation-hooks ()
395 (with-compilation-unit ()
396 (let ((fasl-file (compile-file filename)))
397 (when (and load-p fasl-file)
398 (load fasl-file))
399 nil))))
400
401 (defimplementation swank-compile-string (string &key buffer position directory)
402 (declare (ignore directory))
403 (with-compilation-hooks ()
404 (let ((*buffer-name* buffer)
405 (*buffer-offset* position))
406 (funcall (compile nil (read-from-string
407 (format nil "(~S () ~A)" 'lambda string)))))))
408
409 ;;; Portable XREF from the CMU AI repository.
410
411 (setq pxref::*handle-package-forms* '(cl:in-package))
412
413 (defmacro defxref (name function)
414 `(defimplementation ,name (name)
415 (xref-results (,function name))))
416
417 (defxref who-calls pxref:list-callers)
418 (defxref who-references pxref:list-readers)
419 (defxref who-binds pxref:list-setters)
420 (defxref who-sets pxref:list-setters)
421 (defxref list-callers pxref:list-callers)
422 (defxref list-callees pxref:list-callees)
423
424 (defun xref-results (symbols)
425 (let ((xrefs '()))
426 (dolist (symbol symbols)
427 (push (list symbol (fspec-location symbol)) xrefs))
428 xrefs))
429
430 (when (find-package :swank-loader)
431 (setf (symbol-function (intern "USER-INIT-FILE" :swank-loader))
432 (lambda ()
433 (let ((home (user-homedir-pathname)))
434 (and (ext:probe-directory home)
435 (probe-file (format nil "~A/.swank.lisp"
436 (namestring (truename home)))))))))
437
438 ;; Don't set *debugger-hook* to nil on break.
439 (ext:without-package-lock ()
440 (defun break (&optional (format-string "Break") &rest args)
441 (if (not sys::*use-clcs*)
442 (progn
443 (terpri *error-output*)
444 (apply #'format *error-output*
445 (concatenate 'string "*** - " format-string)
446 args)
447 (funcall ext:*break-driver* t))
448 (let ((condition
449 (make-condition 'simple-condition
450 :format-control format-string
451 :format-arguments args))
452 ;;(*debugger-hook* nil)
453 ;; Issue 91
454 )
455 (ext:with-restarts
456 ((continue
457 :report (lambda (stream)
458 (format stream (sys::text "Return from ~S loop")
459 'break))
460 ()))
461 (with-condition-restarts condition (list (find-restart 'continue))
462 (invoke-debugger condition)))))
463 nil))
464
465 ;;; Inspecting
466
467 (defclass clisp-inspector (inspector)
468 ())
469
470 (defimplementation make-default-inspector ()
471 (make-instance 'clisp-inspector))
472
473 (defmethod inspect-for-emacs ((o t) (inspector clisp-inspector))
474 (declare (ignore inspector))
475 (let* ((*print-array* nil) (*print-pretty* t)
476 (*print-circle* t) (*print-escape* t)
477 (*print-lines* custom:*inspect-print-lines*)
478 (*print-level* custom:*inspect-print-level*)
479 (*print-length* custom:*inspect-print-length*)
480 (sys::*inspect-all* (make-array 10 :fill-pointer 0 :adjustable t))
481 (tmp-pack (make-package (gensym "INSPECT-TMP-PACKAGE-")))
482 (*package* tmp-pack)
483 (sys::*inspect-unbound-value* (intern "#<unbound>" tmp-pack)))
484 (let ((inspection (sys::inspect-backend o)))
485 (values (format nil "~S~% ~A~{~%~A~}" o
486 (sys::insp-title inspection)
487 (sys::insp-blurb inspection))
488 (loop with count = (sys::insp-num-slots inspection)
489 for i upto count
490 for (value name) = (multiple-value-list (funcall (sys::insp-nth-slot inspection) i))
491 collect `(:value ,name)
492 collect " = "
493 collect `(:value ,value)
494 collect '(:newline))))))
495
496 (defmethod inspect-for-emacs :around ((n number) (inspector clisp-inspector))
497 (let ((custom:*warn-on-floating-point-rational-contagion* nil))
498 (call-next-method)))
499
500 (defimplementation quit-lisp ()
501 (#+lisp=cl ext:quit #-lisp=cl lisp:quit code))
502
503 ;;; Local Variables:
504 ;;; eval: (put 'compile-file-frobbing-notes 'lisp-indent-function 1)
505 ;;; eval: (put 'dynamic-flet 'common-lisp-indent-function 1)
506 ;;; End:

  ViewVC Help
Powered by ViewVC 1.1.5