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

Contents of /slime/swank-clisp.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.64 - (show annotations)
Thu Aug 23 19:03:37 2007 UTC (6 years, 8 months ago) by heller
Branch: MAIN
Changes since 1.63: +3 -4 lines
Introduce backend-inspector class.

* swank-backend.lisp (backend-inspector): New class. Introduce a named
  class to give as another way to dispatch to backend methods.

* swank-cmucl.lisp: Use backend-inspector class.
* swank-sbcl.lisp: Use backend-inspector class.
* swank-clisp.lisp: Use backend-inspector class.
* swank-lispworks.lisp: Use backend-inspector class.
* swank-allegro.lisp: Use backend-inspector class.
* swank-openmcl.lisp: Use backend-inspector class.
* swank-abcl.lisp: Use backend-inspector class.
* swank-corman.lisp: Use backend-inspector class.
* swank-scl.lisp: Use backend-inspector class.
1 ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
2
3 ;;;; SWANK support for CLISP.
4
5 ;;;; Copyright (C) 2003, 2004 W. Jenkner, V. Sedach
6
7 ;;;; This program is free software; you can redistribute it and/or
8 ;;;; modify it under the terms of the GNU General Public License as
9 ;;;; published by the Free Software Foundation; either version 2 of
10 ;;;; the License, or (at your option) any later version.
11
12 ;;;; This program is distributed in the hope that it will be useful,
13 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
14 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 ;;;; GNU General Public License for more details.
16
17 ;;;; You should have received a copy of the GNU General Public
18 ;;;; License along with this program; if not, write to the Free
19 ;;;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
20 ;;;; MA 02111-1307, USA.
21
22 ;;; This is work in progress, but it's already usable. Many things
23 ;;; are adapted from other swank-*.lisp, in particular from
24 ;;; swank-allegro (I don't use allegro at all, but it's the shortest
25 ;;; one and I found Helmut Eller's code there enlightening).
26
27 ;;; This code will work better with recent versions of CLISP (say, the
28 ;;; last release or CVS HEAD) while it may not work at all with older
29 ;;; versions. It is reasonable to expect it to work on platforms with
30 ;;; a "SOCKET" package, in particular on GNU/Linux or Unix-like
31 ;;; systems, but also on Win32. This backend uses the portable xref
32 ;;; from the CMU AI repository and metering.lisp from CLOCC [1], which
33 ;;; are conveniently included in SLIME.
34
35 ;;; [1] http://cvs.sourceforge.net/viewcvs.py/clocc/clocc/src/tools/metering/
36
37 (in-package :swank-backend)
38
39 (eval-when (:compile-toplevel :load-toplevel :execute)
40 ;;(use-package "SOCKET")
41 (use-package "GRAY"))
42
43 ;;;; if this lisp has the complete CLOS then we use it, otherwise we
44 ;;;; build up a "fake" swank-mop and then override the methods in the
45 ;;;; inspector.
46
47 (eval-when (:compile-toplevel :load-toplevel :execute)
48 (defvar *have-mop*
49 (and (find-package :clos)
50 (eql :external
51 (nth-value 1 (find-symbol (string ':standard-slot-definition)
52 :clos))))
53 "True in those CLISP images which have a complete MOP implementation."))
54
55 #+#.(cl:if swank-backend::*have-mop* '(cl:and) '(cl:or))
56 (progn
57 (import-swank-mop-symbols :clos '(:slot-definition-documentation))
58
59 (defun swank-mop:slot-definition-documentation (slot)
60 (clos::slot-definition-documentation slot)))
61
62 #-#.(cl:if swank-backend::*have-mop* '(and) '(or))
63 (defclass swank-mop:standard-slot-definition ()
64 ()
65 (:documentation
66 "Dummy class created so that swank.lisp will compile and load."))
67
68 ;; #+#.(cl:if (cl:find-package "LINUX") '(and) '(or))
69 ;; (progn
70 ;; (defmacro with-blocked-signals ((&rest signals) &body body)
71 ;; (ext:with-gensyms ("SIGPROCMASK" ret mask)
72 ;; `(multiple-value-bind (,ret ,mask)
73 ;; (linux:sigprocmask-set-n-save
74 ;; ,linux:SIG_BLOCK
75 ;; ,(do ((sigset (linux:sigset-empty)
76 ;; (linux:sigset-add sigset (the fixnum (pop signals)))))
77 ;; ((null signals) sigset)))
78 ;; (linux:check-res ,ret 'linux:sigprocmask-set-n-save)
79 ;; (unwind-protect
80 ;; (progn ,@body)
81 ;; (linux:sigprocmask-set ,linux:SIG_SETMASK ,mask nil)))))
82
83 ;; (defimplementation call-without-interrupts (fn)
84 ;; (with-blocked-signals (#.linux:SIGINT) (funcall fn))))
85
86 ;; #+#.(cl:if (cl:find-package "LINUX") '(or) '(and))
87 (defimplementation call-without-interrupts (fn)
88 (funcall fn))
89
90 (let ((getpid (or (find-symbol "PROCESS-ID" :system)
91 ;; old name prior to 2005-03-01, clisp <= 2.33.2
92 (find-symbol "PROGRAM-ID" :system)
93 #+win32 ; integrated into the above since 2005-02-24
94 (and (find-package :win32) ; optional modules/win32
95 (find-symbol "GetCurrentProcessId" :win32)))))
96 (defimplementation getpid () ; a required interface
97 (cond
98 (getpid (funcall getpid))
99 #+win32 ((ext:getenv "PID")) ; where does that come from?
100 (t -1))))
101
102 (defimplementation lisp-implementation-type-name ()
103 "clisp")
104
105 (defimplementation set-default-directory (directory)
106 (setf (ext:default-directory) directory)
107 (namestring (setf *default-pathname-defaults* (ext:default-directory))))
108
109 ;;;; TCP Server
110
111 (defimplementation create-socket (host port)
112 (declare (ignore host))
113 (socket:socket-server port))
114
115 (defimplementation local-port (socket)
116 (socket:socket-server-port socket))
117
118 (defimplementation close-socket (socket)
119 (socket:socket-server-close socket))
120
121 (defimplementation accept-connection (socket
122 &key external-format buffering timeout)
123 (declare (ignore buffering timeout))
124 (socket:socket-accept socket
125 :buffered nil ;; XXX should be t
126 :element-type 'character
127 :external-format external-format))
128
129 ;;;; Coding systems
130
131 (defvar *external-format-to-coding-system*
132 '(((:charset "iso-8859-1" :line-terminator :unix)
133 "latin-1-unix" "iso-latin-1-unix" "iso-8859-1-unix")
134 ((:charset "iso-8859-1":latin-1)
135 "latin-1" "iso-latin-1" "iso-8859-1")
136 ((:charset "utf-8") "utf-8")
137 ((:charset "utf-8" :line-terminator :unix) "utf-8-unix")
138 ((:charset "euc-jp") "euc-jp")
139 ((:charset "euc-jp" :line-terminator :unix) "euc-jp-unix")
140 ((:charset "us-ascii") "us-ascii")
141 ((:charset "us-ascii" :line-terminator :unix) "us-ascii-unix")))
142
143 (defimplementation find-external-format (coding-system)
144 (let ((args (car (rassoc-if (lambda (x)
145 (member coding-system x :test #'equal))
146 *external-format-to-coding-system*))))
147 (and args (apply #'ext:make-encoding args))))
148
149
150 ;;;; Swank functions
151
152 (defimplementation arglist (fname)
153 (block nil
154 (or (ignore-errors
155 (let ((exp (function-lambda-expression fname)))
156 (and exp (return (second exp)))))
157 (ignore-errors
158 (return (ext:arglist fname)))
159 :not-available)))
160
161 (defimplementation macroexpand-all (form)
162 (ext:expand-form form))
163
164 (defimplementation describe-symbol-for-emacs (symbol)
165 "Return a plist describing SYMBOL.
166 Return NIL if the symbol is unbound."
167 (let ((result ()))
168 (flet ((doc (kind)
169 (or (documentation symbol kind) :not-documented))
170 (maybe-push (property value)
171 (when value
172 (setf result (list* property value result)))))
173 (maybe-push :variable (when (boundp symbol) (doc 'variable)))
174 (when (fboundp symbol)
175 (maybe-push
176 ;; Report WHEN etc. as macros, even though they may be
177 ;; implemented as special operators.
178 (if (macro-function symbol) :macro
179 (typecase (fdefinition symbol)
180 (generic-function :generic-function)
181 (function :function)
182 ;; (type-of 'progn) -> ext:special-operator
183 (t :special-operator)))
184 (doc 'function)))
185 (when (or (get symbol 'system::setf-function) ; e.g. #'(setf elt)
186 (get symbol 'system::setf-expander)); defsetf
187 (maybe-push :setf (doc 'setf)))
188 (when (or (get symbol 'system::type-symbol); cf. clisp/src/describe.lisp
189 (get symbol 'system::defstruct-description)
190 (get symbol 'system::deftype-expander))
191 (maybe-push :type (doc 'type))) ; even for 'structure
192 (when (find-class symbol nil)
193 (maybe-push :class (doc 'type)))
194 ;; Let this code work compiled in images without FFI
195 (let ((types (load-time-value
196 (and (find-package "FFI")
197 (symbol-value
198 (find-symbol "*C-TYPE-TABLE*" "FFI"))))))
199 ;; Use ffi::*c-type-table* so as not to suffer the overhead of
200 ;; (ignore-errors (ffi:parse-c-type symbol)) for 99.9% of symbols
201 ;; which are not FFI type names.
202 (when (and types (nth-value 1 (gethash symbol types)))
203 ;; Maybe use (case (head (ffi:deparse-c-type)))
204 ;; to distinguish struct and union types?
205 (maybe-push :alien-type :not-documented)))
206 result)))
207
208 (defimplementation describe-definition (symbol namespace)
209 (ecase namespace
210 (:variable (describe symbol))
211 (:macro (describe (macro-function symbol)))
212 (:function (describe (symbol-function symbol)))
213 (:class (describe (find-class symbol)))))
214
215 (defun fspec-pathname (symbol)
216 (let ((path (documentation symbol 'sys::file))
217 lines)
218 (when (consp path)
219 (psetq path (car path)
220 lines (cdr path)))
221 (when (and path
222 (member (pathname-type path)
223 custom:*compiled-file-types* :test #'equal))
224 (setq path
225 (loop for suffix in custom:*source-file-types*
226 thereis (probe-file (make-pathname :defaults path
227 :type suffix)))))
228 (values path lines)))
229
230 (defun fspec-location (fspec)
231 (multiple-value-bind (file lines)
232 (fspec-pathname fspec)
233 (cond (file
234 (multiple-value-bind (truename c) (ignore-errors (truename file))
235 (cond (truename
236 (make-location (list :file (namestring truename))
237 (if (consp lines)
238 (list* :line lines)
239 (list :function-name (string fspec)))))
240 (t (list :error (princ-to-string c))))))
241 (t (list :error (format nil "No source information available for: ~S"
242 fspec))))))
243
244 (defimplementation find-definitions (name)
245 (list (list name (fspec-location name))))
246
247 (defun trim-whitespace (string)
248 (string-trim #(#\newline #\space #\tab) string))
249
250 (defvar *sldb-backtrace*)
251
252 (defimplementation call-with-debugging-environment (debugger-loop-fn)
253 (let* (;;(sys::*break-count* (1+ sys::*break-count*))
254 ;;(sys::*driver* debugger-loop-fn)
255 ;;(sys::*fasoutput-stream* nil)
256 (*sldb-backtrace*
257 (nthcdr 3 (member (sys::the-frame) (sldb-backtrace)))))
258 (funcall debugger-loop-fn)))
259
260 (defun nth-frame (index)
261 (nth index *sldb-backtrace*))
262
263 (defun sldb-backtrace ()
264 "Return a list ((ADDRESS . DESCRIPTION) ...) of frames."
265 (do ((frames '())
266 (last nil frame)
267 (frame (sys::the-frame) (sys::frame-up-1 frame 1))) ; 1 = "all frames"
268 ((eq frame last) (nreverse frames))
269 (unless (boring-frame-p frame)
270 (push frame frames))))
271
272 (defun boring-frame-p (frame)
273 (member (frame-type frame) '(stack-value bind-var bind-env)))
274
275 (defun frame-to-string (frame)
276 (with-output-to-string (s)
277 (sys::describe-frame s frame)))
278
279 (defun frame-type (frame)
280 ;; FIXME: should bind *print-length* etc. to small values.
281 (frame-string-type (frame-to-string frame)))
282
283 (defvar *frame-prefixes*
284 '(("frame binding variables" bind-var)
285 ("<1> #<compiled-function" compiled-fun)
286 ("<1> #<system-function" sys-fun)
287 ("<1> #<special-operator" special-op)
288 ("EVAL frame" eval)
289 ("APPLY frame" apply)
290 ("compiled tagbody frame" compiled-tagbody)
291 ("compiled block frame" compiled-block)
292 ("block frame" block)
293 ("nested block frame" block)
294 ("tagbody frame" tagbody)
295 ("nested tagbody frame" tagbody)
296 ("catch frame" catch)
297 ("handler frame" handler)
298 ("unwind-protect frame" unwind-protect)
299 ("driver frame" driver)
300 ("frame binding environments" bind-env)
301 ("CALLBACK frame" callback)
302 ("- " stack-value)
303 ("<1> " fun)
304 ("<2> " 2nd-frame)))
305
306 (defun frame-string-type (string)
307 (cadr (assoc-if (lambda (pattern) (is-prefix-p pattern string))
308 *frame-prefixes*)))
309
310 (defimplementation compute-backtrace (start end)
311 (let* ((bt *sldb-backtrace*)
312 (len (length bt)))
313 (subseq bt start (min (or end len) len))))
314
315 ;;; CLISP's REPL sets up an ABORT restart that kills SWANK. Here we
316 ;;; can omit that restart so that users don't select it by mistake.
317 (defimplementation compute-sane-restarts (condition)
318 ;; The outermost restart is specified to be the last element of the
319 ;; list, hopefully that's our unwanted ABORT restart.
320 (butlast (compute-restarts condition)))
321
322 (defimplementation print-frame (frame stream)
323 (let ((str (frame-to-string frame)))
324 ;; (format stream "~A " (frame-string-type str))
325 (write-string (extract-frame-line str)
326 stream)))
327
328 (defun extract-frame-line (frame-string)
329 (let ((s frame-string))
330 (trim-whitespace
331 (case (frame-string-type s)
332 ((eval special-op)
333 (string-match "EVAL frame .*for form \\(.*\\)" s 1))
334 (apply
335 (string-match "APPLY frame for call \\(.*\\)" s 1))
336 ((compiled-fun sys-fun fun)
337 (extract-function-name s))
338 (t s)))))
339
340 (defun extract-function-name (string)
341 (let ((1st (car (split-frame-string string))))
342 (or (string-match (format nil "^<1>[ ~%]*#<[-A-Za-z]* \\(.*\\)>")
343 1st
344 1)
345 (string-match (format nil "^<1>[ ~%]*\\(.*\\)") 1st 1)
346 1st)))
347
348 (defun split-frame-string (string)
349 (let ((rx (format nil "~%\\(~{~A~^\\|~}\\)"
350 (mapcar #'car *frame-prefixes*))))
351 (loop for pos = 0 then (1+ (regexp:match-start match))
352 for match = (regexp:match rx string :start pos)
353 if match collect (subseq string pos (regexp:match-start match))
354 else collect (subseq string pos)
355 while match)))
356
357 (defun string-match (pattern string n)
358 (let* ((match (nth-value n (regexp:match pattern string))))
359 (if match (regexp:match-string string match))))
360
361 (defimplementation format-sldb-condition (condition)
362 (trim-whitespace (princ-to-string condition)))
363
364 (defimplementation eval-in-frame (form frame-number)
365 (sys::eval-at (nth-frame frame-number) form))
366
367 (defimplementation frame-locals (frame-number)
368 (let ((frame (nth-frame frame-number)))
369 (loop for i below (%frame-count-vars frame)
370 collect (list :name (%frame-var-name frame i)
371 :value (%frame-var-value frame i)
372 :id 0))))
373
374 (defimplementation frame-var-value (frame var)
375 (%frame-var-value (nth-frame frame) var))
376
377 ;;; Interpreter-Variablen-Environment has the shape
378 ;;; NIL or #(v1 val1 ... vn valn NEXT-ENV).
379
380 (defun %frame-count-vars (frame)
381 (cond ((sys::eval-frame-p frame)
382 (do ((venv (frame-venv frame) (next-venv venv))
383 (count 0 (+ count (/ (1- (length venv)) 2))))
384 ((not venv) count)))
385 ((member (frame-type frame) '(compiled-fun sys-fun fun special-op))
386 (length (%parse-stack-values frame)))
387 (t 0)))
388
389 (defun %frame-var-name (frame i)
390 (cond ((sys::eval-frame-p frame)
391 (nth-value 0 (venv-ref (frame-venv frame) i)))
392 (t (format nil "~D" i))))
393
394 (defun %frame-var-value (frame i)
395 (cond ((sys::eval-frame-p frame)
396 (let ((name (venv-ref (frame-venv frame) i)))
397 (multiple-value-bind (v c) (ignore-errors (sys::eval-at frame name))
398 (if c
399 (format-sldb-condition c)
400 v))))
401 ((member (frame-type frame) '(compiled-fun sys-fun fun special-op))
402 (let ((str (nth i (%parse-stack-values frame))))
403 (trim-whitespace (subseq str 2))))
404 (t (break "Not implemented"))))
405
406 (defun frame-venv (frame)
407 (let ((env (sys::eval-at frame '(sys::the-environment))))
408 (svref env 0)))
409
410 (defun next-venv (venv) (svref venv (1- (length venv))))
411
412 (defun venv-ref (env i)
413 "Reference the Ith binding in ENV.
414 Return two values: NAME and VALUE"
415 (let ((idx (* i 2)))
416 (if (< idx (1- (length env)))
417 (values (svref env idx) (svref env (1+ idx)))
418 (venv-ref (next-venv env) (- i (/ (1- (length env)) 2))))))
419
420 (defun %parse-stack-values (frame)
421 (labels ((next (fp) (sys::frame-down-1 fp 1))
422 (parse (fp accu)
423 (let ((str (frame-to-string fp)))
424 (cond ((is-prefix-p "- " str)
425 (parse (next fp) (cons str accu)))
426 ((is-prefix-p "<1> " str)
427 ;;(when (eq (frame-type frame) 'compiled-fun)
428 ;; (pop accu))
429 (dolist (str (cdr (split-frame-string str)))
430 (when (is-prefix-p "- " str)
431 (push str accu)))
432 (nreverse accu))
433 (t (parse (next fp) accu))))))
434 (parse (next frame) '())))
435
436 (defun is-prefix-p (pattern string)
437 (not (mismatch pattern string :end2 (min (length pattern)
438 (length string)))))
439
440 (defimplementation frame-catch-tags (index)
441 (declare (ignore index))
442 nil)
443
444 (defimplementation return-from-frame (index form)
445 (sys::return-from-eval-frame (nth-frame index) form))
446
447 (defimplementation restart-frame (index)
448 (sys::redo-eval-frame (nth-frame index)))
449
450 (defimplementation frame-source-location-for-emacs (index)
451 `(:error
452 ,(format nil "frame-source-location not implemented. (frame: ~A)"
453 (nth-frame index))))
454
455 ;;;; Profiling
456
457 (defimplementation profile (fname)
458 (eval `(mon:monitor ,fname))) ;monitor is a macro
459
460 (defimplementation profiled-functions ()
461 mon:*monitored-functions*)
462
463 (defimplementation unprofile (fname)
464 (eval `(mon:unmonitor ,fname))) ;unmonitor is a macro
465
466 (defimplementation unprofile-all ()
467 (mon:unmonitor))
468
469 (defimplementation profile-report ()
470 (mon:report-monitoring))
471
472 (defimplementation profile-reset ()
473 (mon:reset-all-monitoring))
474
475 (defimplementation profile-package (package callers-p methods)
476 (declare (ignore callers-p methods))
477 (mon:monitor-all package))
478
479 ;;;; Handle compiler conditions (find out location of error etc.)
480
481 (defmacro compile-file-frobbing-notes ((&rest args) &body body)
482 "Pass ARGS to COMPILE-FILE, send the compiler notes to
483 *STANDARD-INPUT* and frob them in BODY."
484 `(let ((*error-output* (make-string-output-stream))
485 (*compile-verbose* t))
486 (multiple-value-prog1
487 (compile-file ,@args)
488 (handler-case
489 (with-input-from-string
490 (*standard-input* (get-output-stream-string *error-output*))
491 ,@body)
492 (sys::simple-end-of-file () nil)))))
493
494 (defvar *orig-c-warn* (symbol-function 'system::c-warn))
495 (defvar *orig-c-style-warn* (symbol-function 'system::c-style-warn))
496 (defvar *orig-c-error* (symbol-function 'system::c-error))
497 (defvar *orig-c-report-problems* (symbol-function 'system::c-report-problems))
498
499 (defmacro dynamic-flet (names-functions &body body)
500 "(dynamic-flet ((NAME FUNCTION) ...) BODY ...)
501 Execute BODY with NAME's function slot set to FUNCTION."
502 `(ext:letf* ,(loop for (name function) in names-functions
503 collect `((symbol-function ',name) ,function))
504 ,@body))
505
506 (defvar *buffer-name* nil)
507 (defvar *buffer-offset*)
508
509 (defun compiler-note-location ()
510 "Return the current compiler location."
511 (let ((lineno1 sys::*compile-file-lineno1*)
512 (lineno2 sys::*compile-file-lineno2*)
513 (file sys::*compile-file-truename*))
514 (cond ((and file lineno1 lineno2)
515 (make-location (list ':file (namestring file))
516 (list ':line lineno1)))
517 (*buffer-name*
518 (make-location (list ':buffer *buffer-name*)
519 (list ':position *buffer-offset*)))
520 (t
521 (list :error "No error location available")))))
522
523 (defun signal-compiler-warning (cstring args severity orig-fn)
524 (signal (make-condition 'compiler-condition
525 :severity severity
526 :message (apply #'format nil cstring args)
527 :location (compiler-note-location)))
528 (apply orig-fn cstring args))
529
530 (defun c-warn (cstring &rest args)
531 (signal-compiler-warning cstring args :warning *orig-c-warn*))
532
533 (defun c-style-warn (cstring &rest args)
534 (dynamic-flet ((sys::c-warn *orig-c-warn*))
535 (signal-compiler-warning cstring args :style-warning *orig-c-style-warn*)))
536
537 (defun c-error (cstring &rest args)
538 (signal-compiler-warning cstring args :error *orig-c-error*))
539
540 (defimplementation call-with-compilation-hooks (function)
541 (handler-bind ((warning #'handle-notification-condition))
542 (dynamic-flet ((system::c-warn #'c-warn)
543 (system::c-style-warn #'c-style-warn)
544 (system::c-error #'c-error))
545 (funcall function))))
546
547 (defun handle-notification-condition (condition)
548 "Handle a condition caused by a compiler warning."
549 (signal (make-condition 'compiler-condition
550 :original-condition condition
551 :severity :warning
552 :message (princ-to-string condition)
553 :location (compiler-note-location))))
554
555 (defimplementation swank-compile-file (filename load-p external-format)
556 (with-compilation-hooks ()
557 (with-compilation-unit ()
558 (let ((fasl-file (compile-file filename
559 :external-format external-format)))
560 (when (and load-p fasl-file)
561 (load fasl-file))
562 nil))))
563
564 (defimplementation swank-compile-string (string &key buffer position directory)
565 (declare (ignore directory))
566 (with-compilation-hooks ()
567 (let ((*buffer-name* buffer)
568 (*buffer-offset* position))
569 (funcall (compile nil (read-from-string
570 (format nil "(~S () ~A)" 'lambda string)))))))
571
572 ;;;; Portable XREF from the CMU AI repository.
573
574 (setq pxref::*handle-package-forms* '(cl:in-package))
575
576 (defmacro defxref (name function)
577 `(defimplementation ,name (name)
578 (xref-results (,function name))))
579
580 (defxref who-calls pxref:list-callers)
581 (defxref who-references pxref:list-readers)
582 (defxref who-binds pxref:list-setters)
583 (defxref who-sets pxref:list-setters)
584 (defxref list-callers pxref:list-callers)
585 (defxref list-callees pxref:list-callees)
586
587 (defun xref-results (symbols)
588 (let ((xrefs '()))
589 (dolist (symbol symbols)
590 (push (list symbol (fspec-location symbol)) xrefs))
591 xrefs))
592
593 (when (find-package :swank-loader)
594 (setf (symbol-function (intern "USER-INIT-FILE" :swank-loader))
595 (lambda ()
596 (let ((home (user-homedir-pathname)))
597 (and (ext:probe-directory home)
598 (probe-file (format nil "~A/.swank.lisp"
599 (namestring (truename home)))))))))
600
601 ;;; Don't set *debugger-hook* to nil on break.
602 (ext:without-package-lock ()
603 (defun break (&optional (format-string "Break") &rest args)
604 (if (not sys::*use-clcs*)
605 (progn
606 (terpri *error-output*)
607 (apply #'format *error-output*
608 (concatenate 'string "*** - " format-string)
609 args)
610 (funcall ext:*break-driver* t))
611 (let ((condition
612 (make-condition 'simple-condition
613 :format-control format-string
614 :format-arguments args))
615 ;;(*debugger-hook* nil)
616 ;; Issue 91
617 )
618 (ext:with-restarts
619 ((continue
620 :report (lambda (stream)
621 (format stream (sys::text "Return from ~S loop")
622 'break))
623 ()))
624 (with-condition-restarts condition (list (find-restart 'continue))
625 (invoke-debugger condition)))))
626 nil))
627
628 ;;;; Inspecting
629
630 (defclass clisp-inspector (backend-inspector) ())
631
632 (defimplementation make-default-inspector () (make-instance 'clisp-inspector))
633
634 (defmethod inspect-for-emacs ((o t) (inspector backend-inspector))
635 (declare (ignore inspector))
636 (let* ((*print-array* nil) (*print-pretty* t)
637 (*print-circle* t) (*print-escape* t)
638 (*print-lines* custom:*inspect-print-lines*)
639 (*print-level* custom:*inspect-print-level*)
640 (*print-length* custom:*inspect-print-length*)
641 (sys::*inspect-all* (make-array 10 :fill-pointer 0 :adjustable t))
642 (tmp-pack (make-package (gensym "INSPECT-TMP-PACKAGE-")))
643 (*package* tmp-pack)
644 (sys::*inspect-unbound-value* (intern "#<unbound>" tmp-pack)))
645 (let ((inspection (sys::inspect-backend o)))
646 (values (format nil "~S~% ~A~{~%~A~}" o
647 (sys::insp-title inspection)
648 (sys::insp-blurb inspection))
649 (loop with count = (sys::insp-num-slots inspection)
650 for i below count
651 append (multiple-value-bind (value name)
652 (funcall (sys::insp-nth-slot inspection)
653 i)
654 `((:value ,name) " = " (:value ,value)
655 (:newline))))))))
656
657 (defimplementation quit-lisp ()
658 #+lisp=cl (ext:quit)
659 #-lisp=cl (lisp:quit))
660
661 ;;;; Weak hashtables
662
663 (defimplementation make-weak-key-hash-table (&rest args)
664 (apply #'make-hash-table :weak :key args))
665
666 (defimplementation make-weak-value-hash-table (&rest args)
667 (apply #'make-hash-table :weak :value args))
668
669 ;;; Local Variables:
670 ;;; eval: (put 'compile-file-frobbing-notes 'lisp-indent-function 1)
671 ;;; eval: (put 'dynamic-flet 'common-lisp-indent-function 1)
672 ;;; End:

  ViewVC Help
Powered by ViewVC 1.1.5