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

Contents of /slime/swank-clisp.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.55 - (show annotations)
Mon Sep 12 22:58:17 2005 UTC (8 years, 7 months ago) by heller
Branch: MAIN
Changes since 1.54: +2 -0 lines
Add EUC-JP as coding system.  This patch eliminates the requirement of
Mule-UCS to use Japanese characters.  (Nice for pre-22 Emacs
users.)  Patch from NIIMI Satoshi.
1 ;;;; SWANK support for CLISP.
2
3 ;;;; Copyright (C) 2003, 2004 W. Jenkner, V. Sedach
4
5 ;;;; This program 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 of
8 ;;;; the License, or (at your option) any later version.
9
10 ;;;; This program is distributed in the hope that it will be useful,
11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 ;;;; GNU General Public License for more details.
14
15 ;;;; You should have received a copy of the GNU General Public
16 ;;;; License along with this program; if not, write to the Free
17 ;;;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
18 ;;;; MA 02111-1307, USA.
19
20 ;;; This is work in progress, but it's already usable. Many things
21 ;;; are adapted from other swank-*.lisp, in particular from
22 ;;; swank-allegro (I don't use allegro at all, but it's the shortest
23 ;;; one and I found Helmut Eller's code there enlightening).
24
25 ;;; This code will work better with recent versions of CLISP (say, the
26 ;;; last release or CVS HEAD) while it may not work at all with older
27 ;;; versions. It is reasonable to expect it to work on platforms with
28 ;;; a "SOCKET" package, in particular on GNU/Linux or Unix-like
29 ;;; systems, but also on Win32. This backend uses the portable xref
30 ;;; from the CMU AI repository and metering.lisp from CLOCC [1], which
31 ;;; are conveniently included in SLIME.
32
33 ;;; [1] http://cvs.sourceforge.net/viewcvs.py/clocc/clocc/src/tools/metering/
34
35 (in-package :swank-backend)
36
37 (eval-when (:compile-toplevel :load-toplevel :execute)
38 ;;(use-package "SOCKET")
39 (use-package "GRAY"))
40
41 ;;;; if this lisp has the complete CLOS then we use it, otherwise we
42 ;;;; build up a "fake" swank-mop and then override the methods in the
43 ;;;; inspector.
44
45 (eval-when (:compile-toplevel :load-toplevel :execute)
46 (defvar *have-mop*
47 (and (find-package :clos)
48 (eql :external
49 (nth-value 1 (find-symbol (string ':standard-slot-definition)
50 :clos))))
51 "True in those CLISP images which have a complete MOP implementation."))
52
53 #+#.(cl:if swank-backend::*have-mop* '(cl:and) '(cl:or))
54 (progn
55 (import-swank-mop-symbols :clos '(:slot-definition-documentation))
56
57 (defun swank-mop:slot-definition-documentation (slot)
58 (clos::slot-definition-documentation slot)))
59
60 #-#.(cl:if swank-backend::*have-mop* '(and) '(or))
61 (defclass swank-mop:standard-slot-definition ()
62 ()
63 (:documentation
64 "Dummy class created so that swank.lisp will compile and load."))
65
66 ;; #+#.(cl:if (cl:find-package "LINUX") '(and) '(or))
67 ;; (progn
68 ;; (defmacro with-blocked-signals ((&rest signals) &body body)
69 ;; (ext:with-gensyms ("SIGPROCMASK" ret mask)
70 ;; `(multiple-value-bind (,ret ,mask)
71 ;; (linux:sigprocmask-set-n-save
72 ;; ,linux:SIG_BLOCK
73 ;; ,(do ((sigset (linux:sigset-empty)
74 ;; (linux:sigset-add sigset (the fixnum (pop signals)))))
75 ;; ((null signals) sigset)))
76 ;; (linux:check-res ,ret 'linux:sigprocmask-set-n-save)
77 ;; (unwind-protect
78 ;; (progn ,@body)
79 ;; (linux:sigprocmask-set ,linux:SIG_SETMASK ,mask nil)))))
80
81 ;; (defimplementation call-without-interrupts (fn)
82 ;; (with-blocked-signals (#.linux:SIGINT) (funcall fn))))
83
84 ;; #+#.(cl:if (cl:find-package "LINUX") '(or) '(and))
85 (defimplementation call-without-interrupts (fn)
86 (funcall fn))
87
88 (let ((getpid (or (find-symbol "PROCESS-ID" :system)
89 ;; old name prior to 2005-03-01, clisp <= 2.33.2
90 (find-symbol "PROGRAM-ID" :system)
91 #+win32 ; integrated into the above since 2005-02-24
92 (and (find-package :win32) ; optional modules/win32
93 (find-symbol "GetCurrentProcessId" :win32)))))
94 (defimplementation getpid () ; a required interface
95 (cond
96 (getpid (funcall getpid))
97 #+win32 ((ext:getenv "PID")) ; where does that come from?
98 (t -1))))
99
100 (defimplementation lisp-implementation-type-name ()
101 "clisp")
102
103 (defimplementation set-default-directory (directory)
104 (setf (ext:default-directory) directory)
105 (namestring (setf *default-pathname-defaults* (ext:default-directory))))
106
107
108 ;;; TCP Server
109
110 (defimplementation create-socket (host port)
111 (declare (ignore host))
112 (socket:socket-server port))
113
114 (defimplementation local-port (socket)
115 (socket:socket-server-port socket))
116
117 (defimplementation close-socket (socket)
118 (socket:socket-server-close socket))
119
120 (defun find-encoding (external-format)
121 (ecase external-format
122 (:iso-latin-1-unix (ext:make-encoding :charset 'charset:iso-8859-1
123 :line-terminator :unix))
124 (:utf-8-unix (ext:make-encoding :charset 'charset:utf-8
125 :line-terminator :unix))
126 (:euc-jp-unix (ext:make-encoding :charset 'charset:euc-jp
127 :line-terminator :unix))))
128
129 (defimplementation accept-connection (socket
130 &key (external-format :iso-latin-1-unix))
131 (socket:socket-accept socket
132 :buffered nil ;; XXX should be t
133 :element-type 'character
134 :external-format (find-encoding external-format)))
135
136 ;;; Swank functions
137
138 (defimplementation arglist (fname)
139 (block nil
140 (or (ignore-errors (return (ext:arglist fname)))
141 :not-available)))
142
143 (defimplementation macroexpand-all (form)
144 (ext:expand-form form))
145
146 (defimplementation describe-symbol-for-emacs (symbol)
147 "Return a plist describing SYMBOL.
148 Return NIL if the symbol is unbound."
149 (let ((result ()))
150 (flet ((doc (kind)
151 (or (documentation symbol kind) :not-documented))
152 (maybe-push (property value)
153 (when value
154 (setf result (list* property value result)))))
155 (maybe-push :variable (when (boundp symbol) (doc 'variable)))
156 (when (fboundp symbol)
157 (maybe-push
158 ;; Report WHEN etc. as macros, even though they may be
159 ;; implemented as special operators.
160 (if (macro-function symbol) :macro
161 (typecase (fdefinition symbol)
162 (generic-function :generic-function)
163 (function :function)
164 ;; (type-of 'progn) -> ext:special-operator
165 (t :special-operator)))
166 (doc 'function)))
167 (when (or (get symbol 'system::setf-function) ; e.g. #'(setf elt)
168 (get symbol 'system::setf-expander)); defsetf
169 (maybe-push :setf (doc 'setf)))
170 (when (or (get symbol 'system::type-symbol); cf. clisp/src/describe.lisp
171 (get symbol 'system::defstruct-description)
172 (get symbol 'system::deftype-expander))
173 (maybe-push :type (doc 'type))) ; even for 'structure
174 (when (find-class symbol nil)
175 (maybe-push :class (doc 'type)))
176 ;; Let this code work compiled in images without FFI
177 (let ((types (load-time-value
178 (and (find-package "FFI")
179 (symbol-value
180 (find-symbol "*C-TYPE-TABLE*" "FFI"))))))
181 ;; Use ffi::*c-type-table* so as not to suffer the overhead of
182 ;; (ignore-errors (ffi:parse-c-type symbol)) for 99.9% of symbols
183 ;; which are not FFI type names.
184 (when (and types (nth-value 1 (gethash symbol types)))
185 ;; Maybe use (case (head (ffi:deparse-c-type)))
186 ;; to distinguish struct and union types?
187 (maybe-push :alien-type :not-documented)))
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 (documentation symbol 'sys::file))
199 lines)
200 (when (consp path)
201 (psetq path (car path)
202 lines (cdr path)))
203 (when (and path
204 (member (pathname-type path)
205 custom:*compiled-file-types* :test #'equal))
206 (setq path
207 (loop for suffix in custom:*source-file-types*
208 thereis (probe-file (make-pathname :defaults path
209 :type suffix)))))
210 (values path lines)))
211
212 (defun fspec-location (fspec)
213 (multiple-value-bind (file lines)
214 (fspec-pathname fspec)
215 (cond (file
216 (multiple-value-bind (truename c) (ignore-errors (truename file))
217 (cond (truename
218 (make-location (list :file (namestring truename))
219 (if (consp lines)
220 (list* :line lines)
221 (list :function-name (string fspec)))))
222 (t (list :error (princ-to-string c))))))
223 (t (list :error (format nil "No source information available for: ~S"
224 fspec))))))
225
226 (defimplementation find-definitions (name)
227 (list (list name (fspec-location name))))
228
229 (defvar *sldb-topframe*)
230 (defvar *sldb-botframe*)
231 (defvar *sldb-source*)
232 (defvar *sldb-debugmode* 4)
233
234 (defun frame-down (frame)
235 (sys::frame-down-1 frame sys::*debug-mode*))
236
237 (defun frame-up (frame)
238 (sys::frame-up-1 frame sys::*debug-mode*))
239
240 (defimplementation call-with-debugging-environment (debugger-loop-fn)
241 (let* ((sys::*break-count* (1+ sys::*break-count*))
242 (sys::*driver* debugger-loop-fn)
243 (sys::*fasoutput-stream* nil)
244 (sys::*frame-limit1* (sys::frame-limit1 0))
245 (sys::*frame-limit2* (sys::frame-limit2))
246 (sys::*debug-mode* *sldb-debugmode*)
247 (*sldb-topframe* sys::*frame-limit1*))
248 (funcall debugger-loop-fn)))
249
250 (defun nth-frame (index)
251 (loop for frame = *sldb-topframe* then (frame-up frame)
252 repeat index
253 finally (return frame)))
254
255 (defimplementation compute-backtrace (start end)
256 (let ((end (or end most-positive-fixnum)))
257 (loop for last = nil then frame
258 for frame = (nth-frame start) then (frame-up frame)
259 for i from start below end
260 until (or (eq frame last) (system::driver-frame-p frame))
261 collect frame)))
262
263 (defimplementation print-frame (frame stream)
264 (write-string (string-left-trim '(#\Newline)
265 (with-output-to-string (stream)
266 (sys::describe-frame stream frame)))
267 stream))
268
269 (defimplementation eval-in-frame (form frame-number)
270 (sys::eval-at (nth-frame frame-number) form))
271
272 (defimplementation frame-locals (frame-number)
273 (let* ((frame (nth-frame frame-number))
274 (frame-env (sys::eval-at frame '(sys::the-environment))))
275 (append
276 (frame-do-venv frame (svref frame-env 0))
277 (frame-do-fenv frame (svref frame-env 1))
278 (frame-do-benv frame (svref frame-env 2))
279 (frame-do-genv frame (svref frame-env 3))
280 (frame-do-denv frame (svref frame-env 4)))))
281
282 (defimplementation frame-var-value (frame var)
283 (getf (nth var (frame-locals frame)) :value))
284
285 ;; Interpreter-Variablen-Environment has the shape
286 ;; NIL or #(v1 val1 ... vn valn NEXT-ENV).
287
288 (defun frame-do-venv (frame venv)
289 (loop for i from 1 below (length venv) by 2
290 as symbol = (svref venv (1- i))
291 and value = (svref venv i)
292 collect (list :name symbol :id 0
293 :value (if (eq sys::specdecl value)
294 ;; special variable
295 (sys::eval-at frame symbol)
296 ;; lexical variable or symbol macro
297 value))))
298
299 (defun frame-do-fenv (frame fenv)
300 (declare (ignore frame fenv))
301 nil)
302
303 (defun frame-do-benv (frame benv)
304 (declare (ignore frame benv))
305 nil)
306
307 (defun frame-do-genv (frame genv)
308 (declare (ignore frame genv))
309 nil)
310
311 (defun frame-do-denv (frame denv)
312 (declare (ignore frame denv))
313 nil)
314
315 (defimplementation frame-catch-tags (index)
316 (declare (ignore index))
317 nil)
318
319 (defimplementation return-from-frame (index form)
320 (sys::return-from-eval-frame (nth-frame index) form))
321
322 (defimplementation restart-frame (index)
323 (sys::redo-eval-frame (nth-frame index)))
324
325 (defimplementation frame-source-location-for-emacs (index)
326 (let ((f (nth-frame index)))
327 (list :error (format nil "Cannot find source for frame: ~A ~A ~A"
328 f
329 (sys::eval-frame-p f)
330 (sys::the-frame)))))
331
332 ;;; Profiling
333
334 (defimplementation profile (fname)
335 (eval `(mon:monitor ,fname))) ;monitor is a macro
336
337 (defimplementation profiled-functions ()
338 mon:*monitored-functions*)
339
340 (defimplementation unprofile (fname)
341 (eval `(mon:unmonitor ,fname))) ;unmonitor is a macro
342
343 (defimplementation unprofile-all ()
344 (mon:unmonitor))
345
346 (defimplementation profile-report ()
347 (mon:report-monitoring))
348
349 (defimplementation profile-reset ()
350 (mon:reset-all-monitoring))
351
352 (defimplementation profile-package (package callers-p methods)
353 (declare (ignore callers-p methods))
354 (mon:monitor-all package))
355
356 ;;; Handle compiler conditions (find out location of error etc.)
357
358 (defmacro compile-file-frobbing-notes ((&rest args) &body body)
359 "Pass ARGS to COMPILE-FILE, send the compiler notes to
360 *STANDARD-INPUT* and frob them in BODY."
361 `(let ((*error-output* (make-string-output-stream))
362 (*compile-verbose* t))
363 (multiple-value-prog1
364 (compile-file ,@args)
365 (handler-case
366 (with-input-from-string
367 (*standard-input* (get-output-stream-string *error-output*))
368 ,@body)
369 (sys::simple-end-of-file () nil)))))
370
371 (defvar *orig-c-warn* (symbol-function 'system::c-warn))
372 (defvar *orig-c-style-warn* (symbol-function 'system::c-style-warn))
373 (defvar *orig-c-error* (symbol-function 'system::c-error))
374 (defvar *orig-c-report-problems* (symbol-function 'system::c-report-problems))
375
376 (defmacro dynamic-flet (names-functions &body body)
377 "(dynamic-flet ((NAME FUNCTION) ...) BODY ...)
378 Execute BODY with NAME's function slot set to FUNCTION."
379 `(ext:letf* ,(loop for (name function) in names-functions
380 collect `((symbol-function ',name) ,function))
381 ,@body))
382
383 (defvar *buffer-name* nil)
384 (defvar *buffer-offset*)
385
386 (defun compiler-note-location ()
387 "Return the current compiler location."
388 (let ((lineno1 sys::*compile-file-lineno1*)
389 (lineno2 sys::*compile-file-lineno2*)
390 (file sys::*compile-file-truename*))
391 (cond ((and file lineno1 lineno2)
392 (make-location (list ':file (namestring file))
393 (list ':line lineno1)))
394 (*buffer-name*
395 (make-location (list ':buffer *buffer-name*)
396 (list ':position *buffer-offset*)))
397 (t
398 (list :error "No error location available")))))
399
400 (defun signal-compiler-warning (cstring args severity orig-fn)
401 (signal (make-condition 'compiler-condition
402 :severity severity
403 :message (apply #'format nil cstring args)
404 :location (compiler-note-location)))
405 (apply orig-fn cstring args))
406
407 (defun c-warn (cstring &rest args)
408 (signal-compiler-warning cstring args :warning *orig-c-warn*))
409
410 (defun c-style-warn (cstring &rest args)
411 (dynamic-flet ((sys::c-warn *orig-c-warn*))
412 (signal-compiler-warning cstring args :style-warning *orig-c-style-warn*)))
413
414 (defun c-error (cstring &rest args)
415 (signal-compiler-warning cstring args :error *orig-c-error*))
416
417 (defimplementation call-with-compilation-hooks (function)
418 (handler-bind ((warning #'handle-notification-condition))
419 (dynamic-flet ((system::c-warn #'c-warn)
420 (system::c-style-warn #'c-style-warn)
421 (system::c-error #'c-error))
422 (funcall function))))
423
424 (defun handle-notification-condition (condition)
425 "Handle a condition caused by a compiler warning."
426 (signal (make-condition 'compiler-condition
427 :original-condition condition
428 :severity :warning
429 :message (princ-to-string condition)
430 :location (compiler-note-location))))
431
432 (defimplementation swank-compile-file (filename load-p
433 &optional external-format)
434 (let ((ef (if external-format
435 (find-encoding external-format)
436 :default)))
437 (with-compilation-hooks ()
438 (with-compilation-unit ()
439 (let ((fasl-file (compile-file filename :external-format ef)))
440 (when (and load-p fasl-file)
441 (load fasl-file))
442 nil)))))
443
444 (defimplementation swank-compile-string (string &key buffer position directory)
445 (declare (ignore directory))
446 (with-compilation-hooks ()
447 (let ((*buffer-name* buffer)
448 (*buffer-offset* position))
449 (funcall (compile nil (read-from-string
450 (format nil "(~S () ~A)" 'lambda string)))))))
451
452 ;;; Portable XREF from the CMU AI repository.
453
454 (setq pxref::*handle-package-forms* '(cl:in-package))
455
456 (defmacro defxref (name function)
457 `(defimplementation ,name (name)
458 (xref-results (,function name))))
459
460 (defxref who-calls pxref:list-callers)
461 (defxref who-references pxref:list-readers)
462 (defxref who-binds pxref:list-setters)
463 (defxref who-sets pxref:list-setters)
464 (defxref list-callers pxref:list-callers)
465 (defxref list-callees pxref:list-callees)
466
467 (defun xref-results (symbols)
468 (let ((xrefs '()))
469 (dolist (symbol symbols)
470 (push (list symbol (fspec-location symbol)) xrefs))
471 xrefs))
472
473 (when (find-package :swank-loader)
474 (setf (symbol-function (intern "USER-INIT-FILE" :swank-loader))
475 (lambda ()
476 (let ((home (user-homedir-pathname)))
477 (and (ext:probe-directory home)
478 (probe-file (format nil "~A/.swank.lisp"
479 (namestring (truename home)))))))))
480
481 ;; Don't set *debugger-hook* to nil on break.
482 (ext:without-package-lock ()
483 (defun break (&optional (format-string "Break") &rest args)
484 (if (not sys::*use-clcs*)
485 (progn
486 (terpri *error-output*)
487 (apply #'format *error-output*
488 (concatenate 'string "*** - " format-string)
489 args)
490 (funcall ext:*break-driver* t))
491 (let ((condition
492 (make-condition 'simple-condition
493 :format-control format-string
494 :format-arguments args))
495 ;;(*debugger-hook* nil)
496 ;; Issue 91
497 )
498 (ext:with-restarts
499 ((continue
500 :report (lambda (stream)
501 (format stream (sys::text "Return from ~S loop")
502 'break))
503 ()))
504 (with-condition-restarts condition (list (find-restart 'continue))
505 (invoke-debugger condition)))))
506 nil))
507
508 ;;; Inspecting
509
510 (defclass clisp-inspector (inspector)
511 ())
512
513 (defimplementation make-default-inspector ()
514 (make-instance 'clisp-inspector))
515
516 (defmethod inspect-for-emacs ((o t) (inspector clisp-inspector))
517 (declare (ignore inspector))
518 (let* ((*print-array* nil) (*print-pretty* t)
519 (*print-circle* t) (*print-escape* t)
520 (*print-lines* custom:*inspect-print-lines*)
521 (*print-level* custom:*inspect-print-level*)
522 (*print-length* custom:*inspect-print-length*)
523 (sys::*inspect-all* (make-array 10 :fill-pointer 0 :adjustable t))
524 (tmp-pack (make-package (gensym "INSPECT-TMP-PACKAGE-")))
525 (*package* tmp-pack)
526 (sys::*inspect-unbound-value* (intern "#<unbound>" tmp-pack)))
527 (let ((inspection (sys::inspect-backend o)))
528 (values (format nil "~S~% ~A~{~%~A~}" o
529 (sys::insp-title inspection)
530 (sys::insp-blurb inspection))
531 (loop with count = (sys::insp-num-slots inspection)
532 for i upto count
533 for (value name) = (multiple-value-list
534 (funcall (sys::insp-nth-slot
535 inspection) i))
536 collect `((:value ,name) " = " (:value ,value)
537 (:newline)))))))
538
539 (defimplementation quit-lisp ()
540 #+lisp=cl (ext:quit)
541 #-lisp=cl (lisp:quit))
542
543 ;;; Local Variables:
544 ;;; eval: (put 'compile-file-frobbing-notes 'lisp-indent-function 1)
545 ;;; eval: (put 'dynamic-flet 'common-lisp-indent-function 1)
546 ;;; End:

  ViewVC Help
Powered by ViewVC 1.1.5