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

Contents of /slime/swank-clisp.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.70 - (show annotations)
Sun Aug 3 18:23:10 2008 UTC (5 years, 8 months ago) by heller
Branch: MAIN
Changes since 1.69: +4 -0 lines
Add some flow-control.

* swank.lisp (make-output-function): Synchronize with Emacs on
every 100th chunk of output.
(wait-for-event,wait-for-event/event-loop,event-match-p): New
functions.  Used to selectively wait for some events and to queue
the other events.
(dispatch-event, read-from-socket-io): Tag non-queueable events
with :call.
(read-from-control-thread, read-from-emacs): Process
:call events only; enqueue the others.

(*log-output*): Don't use synonym-streams here.  Dereference the
symbol until we get at the real stream.
(log-event): Escape non-ascii characters more carefully.

* swank-backend.lisp (receive-if): New function.
Update backends accordingly. (not yet for ABCL and SCL)

* slime.el (slime-dispatch-event): Handle ping event.
1 ;;;; -*- 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 (eval-when (:compile-toplevel :load-toplevel :execute)
253 (when (string< "2.44" (lisp-implementation-version))
254 (pushnew :clisp-2.44+ *features*)))
255
256 (defun sldb-backtrace ()
257 "Return a list ((ADDRESS . DESCRIPTION) ...) of frames."
258 (do ((frames '())
259 (last nil frame)
260 (frame (sys::the-frame)
261 #+clisp-2.44+ (sys::frame-up 1 frame 1)
262 #-clisp-2.44+ (sys::frame-up-1 frame 1))) ; 1 = "all frames"
263 ((eq frame last) (nreverse frames))
264 (unless (boring-frame-p frame)
265 (push frame frames))))
266
267 (defimplementation call-with-debugging-environment (debugger-loop-fn)
268 (let* (;;(sys::*break-count* (1+ sys::*break-count*))
269 ;;(sys::*driver* debugger-loop-fn)
270 ;;(sys::*fasoutput-stream* nil)
271 (*sldb-backtrace*
272 (nthcdr 3 (member (sys::the-frame) (sldb-backtrace)))))
273 (funcall debugger-loop-fn)))
274
275 (defun nth-frame (index)
276 (nth index *sldb-backtrace*))
277
278 (defun boring-frame-p (frame)
279 (member (frame-type frame) '(stack-value bind-var bind-env)))
280
281 (defun frame-to-string (frame)
282 (with-output-to-string (s)
283 (sys::describe-frame s frame)))
284
285 ;; FIXME: they changed the layout in 2.44 so the frame-to-string &
286 ;; string-matching silliness no longer works.
287 (defun frame-type (frame)
288 ;; FIXME: should bind *print-length* etc. to small values.
289 (frame-string-type (frame-to-string frame)))
290
291 (defvar *frame-prefixes*
292 '(("frame binding variables" bind-var)
293 ("<1> #<compiled-function" compiled-fun)
294 ("<1> #<system-function" sys-fun)
295 ("<1> #<special-operator" special-op)
296 ("EVAL frame" eval)
297 ("APPLY frame" apply)
298 ("compiled tagbody frame" compiled-tagbody)
299 ("compiled block frame" compiled-block)
300 ("block frame" block)
301 ("nested block frame" block)
302 ("tagbody frame" tagbody)
303 ("nested tagbody frame" tagbody)
304 ("catch frame" catch)
305 ("handler frame" handler)
306 ("unwind-protect frame" unwind-protect)
307 ("driver frame" driver)
308 ("frame binding environments" bind-env)
309 ("CALLBACK frame" callback)
310 ("- " stack-value)
311 ("<1> " fun)
312 ("<2> " 2nd-frame)))
313
314 (defun frame-string-type (string)
315 (cadr (assoc-if (lambda (pattern) (is-prefix-p pattern string))
316 *frame-prefixes*)))
317
318 (defimplementation compute-backtrace (start end)
319 (let* ((bt *sldb-backtrace*)
320 (len (length bt)))
321 (subseq bt start (min (or end len) len))))
322
323 ;;; CLISP's REPL sets up an ABORT restart that kills SWANK. Here we
324 ;;; can omit that restart so that users don't select it by mistake.
325 (defimplementation compute-sane-restarts (condition)
326 ;; The outermost restart is specified to be the last element of the
327 ;; list, hopefully that's our unwanted ABORT restart.
328 (butlast (compute-restarts condition)))
329
330 (defimplementation print-frame (frame stream)
331 (let ((str (frame-to-string frame)))
332 ;; (format stream "~A " (frame-string-type str))
333 (write-string (extract-frame-line str)
334 stream)))
335
336 (defun extract-frame-line (frame-string)
337 (let ((s frame-string))
338 (trim-whitespace
339 (case (frame-string-type s)
340 ((eval special-op)
341 (string-match "EVAL frame .*for form \\(.*\\)" s 1))
342 (apply
343 (string-match "APPLY frame for call \\(.*\\)" s 1))
344 ((compiled-fun sys-fun fun)
345 (extract-function-name s))
346 (t s)))))
347
348 (defun extract-function-name (string)
349 (let ((1st (car (split-frame-string string))))
350 (or (string-match (format nil "^<1>[ ~%]*#<[-A-Za-z]* \\(.*\\)>")
351 1st
352 1)
353 (string-match (format nil "^<1>[ ~%]*\\(.*\\)") 1st 1)
354 1st)))
355
356 (defun split-frame-string (string)
357 (let ((rx (format nil "~%\\(~{~A~^\\|~}\\)"
358 (mapcar #'car *frame-prefixes*))))
359 (loop for pos = 0 then (1+ (regexp:match-start match))
360 for match = (regexp:match rx string :start pos)
361 if match collect (subseq string pos (regexp:match-start match))
362 else collect (subseq string pos)
363 while match)))
364
365 (defun string-match (pattern string n)
366 (let* ((match (nth-value n (regexp:match pattern string))))
367 (if match (regexp:match-string string match))))
368
369 (defimplementation format-sldb-condition (condition)
370 (trim-whitespace (princ-to-string condition)))
371
372 (defimplementation eval-in-frame (form frame-number)
373 (sys::eval-at (nth-frame frame-number) form))
374
375 (defimplementation frame-locals (frame-number)
376 (let ((frame (nth-frame frame-number)))
377 (loop for i below (%frame-count-vars frame)
378 collect (list :name (%frame-var-name frame i)
379 :value (%frame-var-value frame i)
380 :id 0))))
381
382 (defimplementation frame-var-value (frame var)
383 (%frame-var-value (nth-frame frame) var))
384
385 ;;; Interpreter-Variablen-Environment has the shape
386 ;;; NIL or #(v1 val1 ... vn valn NEXT-ENV).
387
388 (defun %frame-count-vars (frame)
389 (cond ((sys::eval-frame-p frame)
390 (do ((venv (frame-venv frame) (next-venv venv))
391 (count 0 (+ count (/ (1- (length venv)) 2))))
392 ((not venv) count)))
393 ((member (frame-type frame) '(compiled-fun sys-fun fun special-op))
394 (length (%parse-stack-values frame)))
395 (t 0)))
396
397 (defun %frame-var-name (frame i)
398 (cond ((sys::eval-frame-p frame)
399 (nth-value 0 (venv-ref (frame-venv frame) i)))
400 (t (format nil "~D" i))))
401
402 (defun %frame-var-value (frame i)
403 (cond ((sys::eval-frame-p frame)
404 (let ((name (venv-ref (frame-venv frame) i)))
405 (multiple-value-bind (v c) (ignore-errors (sys::eval-at frame name))
406 (if c
407 (format-sldb-condition c)
408 v))))
409 ((member (frame-type frame) '(compiled-fun sys-fun fun special-op))
410 (let ((str (nth i (%parse-stack-values frame))))
411 (trim-whitespace (subseq str 2))))
412 (t (break "Not implemented"))))
413
414 (defun frame-venv (frame)
415 (let ((env (sys::eval-at frame '(sys::the-environment))))
416 (svref env 0)))
417
418 (defun next-venv (venv) (svref venv (1- (length venv))))
419
420 (defun venv-ref (env i)
421 "Reference the Ith binding in ENV.
422 Return two values: NAME and VALUE"
423 (let ((idx (* i 2)))
424 (if (< idx (1- (length env)))
425 (values (svref env idx) (svref env (1+ idx)))
426 (venv-ref (next-venv env) (- i (/ (1- (length env)) 2))))))
427
428 (defun %parse-stack-values (frame)
429 (labels ((next (fp)
430 #+clisp-2.44+ (sys::frame-down 1 fp 1)
431 #-clisp-2.44+ (sys::frame-down-1 fp 1))
432 (parse (fp accu)
433 (let ((str (frame-to-string fp)))
434 (cond ((is-prefix-p "- " str)
435 (parse (next fp) (cons str accu)))
436 ((is-prefix-p "<1> " str)
437 ;;(when (eq (frame-type frame) 'compiled-fun)
438 ;; (pop accu))
439 (dolist (str (cdr (split-frame-string str)))
440 (when (is-prefix-p "- " str)
441 (push str accu)))
442 (nreverse accu))
443 (t (parse (next fp) accu))))))
444 (parse (next frame) '())))
445
446 (setq *features* (remove :clisp-2.44+ *features*))
447
448 (defun is-prefix-p (pattern string)
449 (not (mismatch pattern string :end2 (min (length pattern)
450 (length string)))))
451
452 (defimplementation frame-catch-tags (index)
453 (declare (ignore index))
454 nil)
455
456 (defimplementation return-from-frame (index form)
457 (sys::return-from-eval-frame (nth-frame index) form))
458
459 (defimplementation restart-frame (index)
460 (sys::redo-eval-frame (nth-frame index)))
461
462 (defimplementation frame-source-location-for-emacs (index)
463 `(:error
464 ,(format nil "frame-source-location not implemented. (frame: ~A)"
465 (nth-frame index))))
466
467 ;;;; Profiling
468
469 (defimplementation profile (fname)
470 (eval `(mon:monitor ,fname))) ;monitor is a macro
471
472 (defimplementation profiled-functions ()
473 mon:*monitored-functions*)
474
475 (defimplementation unprofile (fname)
476 (eval `(mon:unmonitor ,fname))) ;unmonitor is a macro
477
478 (defimplementation unprofile-all ()
479 (mon:unmonitor))
480
481 (defimplementation profile-report ()
482 (mon:report-monitoring))
483
484 (defimplementation profile-reset ()
485 (mon:reset-all-monitoring))
486
487 (defimplementation profile-package (package callers-p methods)
488 (declare (ignore callers-p methods))
489 (mon:monitor-all package))
490
491 ;;;; Handle compiler conditions (find out location of error etc.)
492
493 (defmacro compile-file-frobbing-notes ((&rest args) &body body)
494 "Pass ARGS to COMPILE-FILE, send the compiler notes to
495 *STANDARD-INPUT* and frob them in BODY."
496 `(let ((*error-output* (make-string-output-stream))
497 (*compile-verbose* t))
498 (multiple-value-prog1
499 (compile-file ,@args)
500 (handler-case
501 (with-input-from-string
502 (*standard-input* (get-output-stream-string *error-output*))
503 ,@body)
504 (sys::simple-end-of-file () nil)))))
505
506 (defvar *orig-c-warn* (symbol-function 'system::c-warn))
507 (defvar *orig-c-style-warn* (symbol-function 'system::c-style-warn))
508 (defvar *orig-c-error* (symbol-function 'system::c-error))
509 (defvar *orig-c-report-problems* (symbol-function 'system::c-report-problems))
510
511 (defmacro dynamic-flet (names-functions &body body)
512 "(dynamic-flet ((NAME FUNCTION) ...) BODY ...)
513 Execute BODY with NAME's function slot set to FUNCTION."
514 `(ext:letf* ,(loop for (name function) in names-functions
515 collect `((symbol-function ',name) ,function))
516 ,@body))
517
518 (defvar *buffer-name* nil)
519 (defvar *buffer-offset*)
520
521 (defun compiler-note-location ()
522 "Return the current compiler location."
523 (let ((lineno1 sys::*compile-file-lineno1*)
524 (lineno2 sys::*compile-file-lineno2*)
525 (file sys::*compile-file-truename*))
526 (cond ((and file lineno1 lineno2)
527 (make-location (list ':file (namestring file))
528 (list ':line lineno1)))
529 (*buffer-name*
530 (make-location (list ':buffer *buffer-name*)
531 (list ':position *buffer-offset*)))
532 (t
533 (list :error "No error location available")))))
534
535 (defun signal-compiler-warning (cstring args severity orig-fn)
536 (signal (make-condition 'compiler-condition
537 :severity severity
538 :message (apply #'format nil cstring args)
539 :location (compiler-note-location)))
540 (apply orig-fn cstring args))
541
542 (defun c-warn (cstring &rest args)
543 (signal-compiler-warning cstring args :warning *orig-c-warn*))
544
545 (defun c-style-warn (cstring &rest args)
546 (dynamic-flet ((sys::c-warn *orig-c-warn*))
547 (signal-compiler-warning cstring args :style-warning *orig-c-style-warn*)))
548
549 (defun c-error (cstring &rest args)
550 (signal-compiler-warning cstring args :error *orig-c-error*))
551
552 (defimplementation call-with-compilation-hooks (function)
553 (handler-bind ((warning #'handle-notification-condition))
554 (dynamic-flet ((system::c-warn #'c-warn)
555 (system::c-style-warn #'c-style-warn)
556 (system::c-error #'c-error))
557 (funcall function))))
558
559 (defun handle-notification-condition (condition)
560 "Handle a condition caused by a compiler warning."
561 (signal (make-condition 'compiler-condition
562 :original-condition condition
563 :severity :warning
564 :message (princ-to-string condition)
565 :location (compiler-note-location))))
566
567 (defimplementation swank-compile-file (filename load-p external-format)
568 (with-compilation-hooks ()
569 (with-compilation-unit ()
570 (let ((fasl-file (compile-file filename
571 :external-format external-format)))
572 (when (and load-p fasl-file)
573 (load fasl-file))
574 nil))))
575
576 (defimplementation swank-compile-string (string &key buffer position directory
577 debug)
578 (declare (ignore directory debug))
579 (with-compilation-hooks ()
580 (let ((*buffer-name* buffer)
581 (*buffer-offset* position))
582 (funcall (compile nil (read-from-string
583 (format nil "(~S () ~A)" 'lambda string)))))))
584
585 ;;;; Portable XREF from the CMU AI repository.
586
587 (setq pxref::*handle-package-forms* '(cl:in-package))
588
589 (defmacro defxref (name function)
590 `(defimplementation ,name (name)
591 (xref-results (,function name))))
592
593 (defxref who-calls pxref:list-callers)
594 (defxref who-references pxref:list-readers)
595 (defxref who-binds pxref:list-setters)
596 (defxref who-sets pxref:list-setters)
597 (defxref list-callers pxref:list-callers)
598 (defxref list-callees pxref:list-callees)
599
600 (defun xref-results (symbols)
601 (let ((xrefs '()))
602 (dolist (symbol symbols)
603 (push (list symbol (fspec-location symbol)) xrefs))
604 xrefs))
605
606 (when (find-package :swank-loader)
607 (setf (symbol-function (intern "USER-INIT-FILE" :swank-loader))
608 (lambda ()
609 (let ((home (user-homedir-pathname)))
610 (and (ext:probe-directory home)
611 (probe-file (format nil "~A/.swank.lisp"
612 (namestring (truename home)))))))))
613
614 ;;; Don't set *debugger-hook* to nil on break.
615 (ext:without-package-lock ()
616 (defun break (&optional (format-string "Break") &rest args)
617 (if (not sys::*use-clcs*)
618 (progn
619 (terpri *error-output*)
620 (apply #'format *error-output*
621 (concatenate 'string "*** - " format-string)
622 args)
623 (funcall ext:*break-driver* t))
624 (let ((condition
625 (make-condition 'simple-condition
626 :format-control format-string
627 :format-arguments args))
628 ;;(*debugger-hook* nil)
629 ;; Issue 91
630 )
631 (ext:with-restarts
632 ((continue
633 :report (lambda (stream)
634 (format stream (sys::text "Return from ~S loop")
635 'break))
636 ()))
637 (with-condition-restarts condition (list (find-restart 'continue))
638 (invoke-debugger condition)))))
639 nil))
640
641 ;;;; Inspecting
642
643 (defmethod emacs-inspect ((o t))
644 (let* ((*print-array* nil) (*print-pretty* t)
645 (*print-circle* t) (*print-escape* t)
646 (*print-lines* custom:*inspect-print-lines*)
647 (*print-level* custom:*inspect-print-level*)
648 (*print-length* custom:*inspect-print-length*)
649 (sys::*inspect-all* (make-array 10 :fill-pointer 0 :adjustable t))
650 (tmp-pack (make-package (gensym "INSPECT-TMP-PACKAGE-")))
651 (*package* tmp-pack)
652 (sys::*inspect-unbound-value* (intern "#<unbound>" tmp-pack)))
653 (let ((inspection (sys::inspect-backend o)))
654 (append (list
655 (format nil "~S~% ~A~{~%~A~}~%" o
656 (sys::insp-title inspection)
657 (sys::insp-blurb inspection)))
658 (loop with count = (sys::insp-num-slots inspection)
659 for i below count
660 append (multiple-value-bind (value name)
661 (funcall (sys::insp-nth-slot inspection)
662 i)
663 `((:value ,name) " = " (:value ,value)
664 (:newline))))))))
665
666 (defimplementation quit-lisp ()
667 #+lisp=cl (ext:quit)
668 #-lisp=cl (lisp:quit))
669
670 (defimplementation thread-id (thread)
671 (declare (ignore thread))
672 0)
673
674 ;;;; Weak hashtables
675
676 (defimplementation make-weak-key-hash-table (&rest args)
677 (apply #'make-hash-table :weak :key args))
678
679 (defimplementation make-weak-value-hash-table (&rest args)
680 (apply #'make-hash-table :weak :value args))
681
682 ;;; Local Variables:
683 ;;; eval: (put 'compile-file-frobbing-notes 'lisp-indent-function 1)
684 ;;; eval: (put 'dynamic-flet 'common-lisp-indent-function 1)
685 ;;; End:

  ViewVC Help
Powered by ViewVC 1.1.5