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

Contents of /slime/swank-clisp.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5