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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.257 - (hide annotations)
Thu Dec 10 20:51:33 2009 UTC (4 years, 4 months ago) by trittweiler
Branch: MAIN
Changes since 1.256: +20 -11 lines
	* swank-sbcl.lisp (set-break-hook): New.
	(call-with-break-hook): New, too. Both extracted from elsewhere.
	(install-debugger-globally, call-with-debugger-hook): Use them.
	(make-invoke-debugger-hook): Adapted not to call *debugger-hook*
	on its own; it should rather decline because *debugger-hook* is
	tried after *invoke-debugger-hook* anyway. Previously, a
	custom *debugger-hook* (which declines itself) would have been
	executed twice.
1 trittweiler 1.246 ;;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
2 dbarlow 1.1 ;;;
3     ;;; swank-sbcl.lisp --- SLIME backend for SBCL.
4     ;;;
5     ;;; Created 2003, Daniel Barlow <dan@metacircles.com>
6     ;;;
7 jsnellman 1.158 ;;; This code has been placed in the Public Domain. All warranties are
8 dbarlow 1.1 ;;; disclaimed.
9    
10 heller 1.106 ;;; Requires the SB-INTROSPECT contrib.
11 dbarlow 1.1
12     ;;; Administrivia
13    
14 heller 1.146 (in-package :swank-backend)
15    
16 dbarlow 1.1 (eval-when (:compile-toplevel :load-toplevel :execute)
17     (require 'sb-bsd-sockets)
18 heller 1.59 (require 'sb-introspect)
19 trittweiler 1.179 (require 'sb-posix)
20     (require 'sb-cltl2))
21 heller 1.107
22 heller 1.196 (declaim (optimize (debug 2)
23     (sb-c::insert-step-conditions 0)
24     (sb-c::insert-debug-catch 0)
25     (sb-c::merge-tail-calls 2)))
26 dbarlow 1.1
27 heller 1.146 (import-from :sb-gray *gray-stream-symbols* :swank-backend)
28 heller 1.23
29 jsnellman 1.166 ;;; backwards compability tests
30    
31     (eval-when (:compile-toplevel :load-toplevel :execute)
32     ;; Generate a form suitable for testing for stepper support (0.9.17)
33     ;; with #+.
34     (defun sbcl-with-new-stepper-p ()
35 trittweiler 1.233 (with-symbol 'enable-stepping 'sb-impl))
36 nsiivola 1.170 ;; Ditto for weak hash-tables
37     (defun sbcl-with-weak-hash-tables ()
38 trittweiler 1.233 (with-symbol 'hash-table-weakness 'sb-ext))
39 jsnellman 1.172 ;; And for xref support (1.0.1)
40     (defun sbcl-with-xref-p ()
41 trittweiler 1.233 (with-symbol 'who-calls 'sb-introspect))
42 jsnellman 1.174 ;; ... for restart-frame support (1.0.2)
43     (defun sbcl-with-restart-frame ()
44 trittweiler 1.233 (with-symbol 'frame-has-debug-tag-p 'sb-debug)))
45 jsnellman 1.166
46 mbaringer 1.100 ;;; swank-mop
47    
48 heller 1.106 (import-swank-mop-symbols :sb-mop '(:slot-definition-documentation))
49 mbaringer 1.100
50 mbaringer 1.101 (defun swank-mop:slot-definition-documentation (slot)
51 jsnellman 1.158 (sb-pcl::documentation slot t))
52 mbaringer 1.100
53 trittweiler 1.194 ;;; Connection info
54    
55     (defimplementation lisp-implementation-type-name ()
56     "sbcl")
57    
58     ;; Declare return type explicitly to shut up STYLE-WARNINGS about
59     ;; %SAP-ALIEN in ENABLE-SIGIO-ON-FD below.
60     (declaim (ftype (function () (values (signed-byte 32) &optional)) getpid))
61     (defimplementation getpid ()
62     (sb-posix:getpid))
63    
64 dbarlow 1.1 ;;; TCP Server
65    
66 lgorrie 1.132 (defimplementation preferred-communication-style ()
67 crhodes 1.155 (cond
68     ;; fixme: when SBCL/win32 gains better select() support, remove
69     ;; this.
70     ((member :win32 *features*) nil)
71 jsnellman 1.159 ((member :sb-thread *features*) :spawn)
72 crhodes 1.155 (t :fd-handler)))
73 jsnellman 1.158
74 heller 1.65 (defun resolve-hostname (name)
75     (car (sb-bsd-sockets:host-ent-addresses
76     (sb-bsd-sockets:get-host-by-name name))))
77    
78     (defimplementation create-socket (host port)
79 dbarlow 1.6 (let ((socket (make-instance 'sb-bsd-sockets:inet-socket
80     :type :stream
81     :protocol :tcp)))
82 heller 1.48 (setf (sb-bsd-sockets:sockopt-reuse-address socket) t)
83 heller 1.65 (sb-bsd-sockets:socket-bind socket (resolve-hostname host) port)
84 dbarlow 1.6 (sb-bsd-sockets:socket-listen socket 5)
85 heller 1.29 socket))
86    
87 lgorrie 1.54 (defimplementation local-port (socket)
88 lgorrie 1.46 (nth-value 1 (sb-bsd-sockets:socket-name socket)))
89    
90 lgorrie 1.54 (defimplementation close-socket (socket)
91 lgorrie 1.86 (sb-sys:invalidate-descriptor (socket-fd socket))
92 heller 1.48 (sb-bsd-sockets:socket-close socket))
93    
94 jsnellman 1.158 (defimplementation accept-connection (socket &key
95 heller 1.160 external-format
96     buffering timeout)
97 dcrosher 1.153 (declare (ignore timeout))
98 heller 1.160 (make-socket-io-stream (accept socket)
99     (or external-format :iso-latin-1-unix)
100     (or buffering :full)))
101 heller 1.48
102 heller 1.214 #-win32
103 heller 1.213 (defimplementation install-sigint-handler (function)
104     (sb-sys:enable-interrupt sb-unix:sigint
105     (lambda (&rest args)
106     (declare (ignore args))
107 heller 1.221 (sb-sys:invoke-interruption
108     (lambda ()
109     (sb-sys:with-interrupts
110     (funcall function)))))))
111 heller 1.213
112 heller 1.59 (defvar *sigio-handlers* '()
113     "List of (key . fn) pairs to be called on SIGIO.")
114    
115     (defun sigio-handler (signal code scp)
116 heller 1.60 (declare (ignore signal code scp))
117     (mapc (lambda (handler)
118     (funcall (the function (cdr handler))))
119     *sigio-handlers*))
120 heller 1.59
121     (defun set-sigio-handler ()
122 heller 1.82 (sb-sys:enable-interrupt sb-unix:sigio (lambda (signal code scp)
123 heller 1.59 (sigio-handler signal code scp))))
124    
125 heller 1.62 (defun enable-sigio-on-fd (fd)
126 heller 1.82 (sb-posix::fcntl fd sb-posix::f-setfl sb-posix::o-async)
127 trittweiler 1.194 (sb-posix::fcntl fd sb-posix::f-setown (getpid))
128     (values))
129 heller 1.62
130 heller 1.67 (defimplementation add-sigio-handler (socket fn)
131 heller 1.62 (set-sigio-handler)
132     (let ((fd (socket-fd socket)))
133     (enable-sigio-on-fd fd)
134     (push (cons fd fn) *sigio-handlers*)))
135    
136 heller 1.67 (defimplementation remove-sigio-handlers (socket)
137 heller 1.59 (let ((fd (socket-fd socket)))
138     (setf *sigio-handlers* (delete fd *sigio-handlers* :key #'car))
139 jsnellman 1.158 (sb-sys:invalidate-descriptor fd))
140 heller 1.51 (close socket))
141 heller 1.67
142 heller 1.244 (defimplementation add-fd-handler (socket fun)
143     (let ((fd (socket-fd socket))
144     (handler nil))
145     (labels ((add ()
146     (setq handler (sb-sys:add-fd-handler fd :input #'run)))
147     (run (fd)
148     (sb-sys:remove-fd-handler handler) ; prevent recursion
149     (unwind-protect
150     (funcall fun)
151     (when (sb-unix:unix-fstat fd) ; still open?
152     (add)))))
153     (add))))
154 heller 1.67
155     (defimplementation remove-fd-handlers (socket)
156     (sb-sys:invalidate-descriptor (socket-fd socket)))
157 heller 1.51
158 heller 1.48 (defun socket-fd (socket)
159     (etypecase socket
160     (fixnum socket)
161     (sb-bsd-sockets:socket (sb-bsd-sockets:socket-file-descriptor socket))
162     (file-stream (sb-sys:fd-stream-fd socket))))
163    
164 heller 1.221 (defvar *wait-for-input-called*)
165    
166     (defimplementation wait-for-input (streams &optional timeout)
167     (assert (member timeout '(nil t)))
168     (when (boundp '*wait-for-input-called*)
169     (setq *wait-for-input-called* t))
170     (let ((*wait-for-input-called* nil))
171     (loop
172 heller 1.242 (let ((ready (remove-if-not #'input-ready-p streams)))
173 heller 1.221 (when ready (return ready)))
174     (when timeout (return nil))
175     (when (check-slime-interrupts) (return :interrupt))
176 heller 1.242 (when *wait-for-input-called* (return :interrupt))
177     (sleep 0.2))))
178    
179     #-win32
180     (defun input-ready-p (stream)
181     (let ((c (read-char-no-hang stream nil :eof)))
182     (etypecase c
183     (character (unread-char c stream) t)
184     (null nil)
185     ((member :eof) t))))
186    
187     #+win32
188     (progn
189     (defun input-ready-p (stream)
190     (or (has-buffered-input-p stream)
191     (handle-listen (sockint::fd->handle
192     (sb-impl::fd-stream-fd stream)))))
193    
194     (defun has-buffered-input-p (stream)
195     (let ((ibuf (sb-impl::fd-stream-ibuf stream)))
196     (/= (sb-impl::buffer-head ibuf)
197     (sb-impl::buffer-tail ibuf))))
198    
199     (sb-alien:define-alien-routine ("WSACreateEvent" wsa-create-event)
200     sb-win32:handle)
201    
202     (sb-alien:define-alien-routine ("WSACloseEvent" wsa-close-event)
203     sb-alien:int
204     (event sb-win32:handle))
205    
206     (defconstant +fd-read+ #.(ash 1 0))
207     (defconstant +fd-close+ #.(ash 1 5))
208    
209     (sb-alien:define-alien-routine ("WSAEventSelect" wsa-event-select)
210     sb-alien:int
211     (fd sb-alien:int)
212     (handle sb-win32:handle)
213     (mask sb-alien:long))
214    
215     (sb-alien:load-shared-object "kernel32.dll")
216     (sb-alien:define-alien-routine ("WaitForSingleObjectEx"
217     wait-for-single-object-ex)
218     sb-alien:int
219     (event sb-win32:handle)
220     (milliseconds sb-alien:long)
221     (alertable sb-alien:int))
222    
223     ;; see SB-WIN32:HANDLE-LISTEN
224     (defun handle-listen (handle)
225     (sb-alien:with-alien ((avail sb-win32:dword)
226     (buf (array char #.sb-win32::input-record-size)))
227     (unless (zerop (sb-win32:peek-named-pipe handle nil 0 nil
228     (sb-alien:alien-sap
229     (sb-alien:addr avail))
230     nil))
231     (return-from handle-listen (plusp avail)))
232    
233     (unless (zerop (sb-win32:peek-console-input handle
234     (sb-alien:alien-sap buf)
235     sb-win32::input-record-size
236     (sb-alien:alien-sap
237     (sb-alien:addr avail))))
238     (return-from handle-listen (plusp avail))))
239    
240     (let ((event (wsa-create-event)))
241     (wsa-event-select handle event (logior +fd-read+ +fd-close+))
242     (let ((val (wait-for-single-object-ex event 0 0)))
243     (wsa-close-event event)
244     (unless (= val -1)
245     (return-from handle-listen (zerop val)))))
246    
247     nil)
248    
249     )
250 heller 1.221
251 heller 1.171 (defvar *external-format-to-coding-system*
252     '((:iso-8859-1
253     "latin-1" "latin-1-unix" "iso-latin-1-unix"
254     "iso-8859-1" "iso-8859-1-unix")
255     (:utf-8 "utf-8" "utf-8-unix")
256     (:euc-jp "euc-jp" "euc-jp-unix")
257     (:us-ascii "us-ascii" "us-ascii-unix")))
258    
259 trittweiler 1.216 ;; C.f. R.M.Kreuter in <20536.1219412774@progn.net> on sbcl-general, 2008-08-22.
260     (defvar *physical-pathname-host* (pathname-host (user-homedir-pathname)))
261    
262 heller 1.223 (defimplementation filename-to-pathname (filename)
263 trittweiler 1.216 (sb-ext:parse-native-namestring filename *physical-pathname-host*))
264    
265 heller 1.171 (defimplementation find-external-format (coding-system)
266     (car (rassoc-if (lambda (x) (member coding-system x :test #'equal))
267     *external-format-to-coding-system*)))
268 heller 1.137
269 heller 1.150 (defun make-socket-io-stream (socket external-format buffering)
270 heller 1.171 (sb-bsd-sockets:socket-make-stream socket
271     :output t
272     :input t
273     :element-type 'character
274     :buffering buffering
275     #+sb-unicode :external-format
276     #+sb-unicode external-format
277     ))
278 lgorrie 1.46
279 heller 1.29 (defun accept (socket)
280     "Like socket-accept, but retry on EAGAIN."
281 jsnellman 1.158 (loop (handler-case
282 heller 1.29 (return (sb-bsd-sockets:socket-accept socket))
283     (sb-bsd-sockets:interrupted-error ()))))
284 dbarlow 1.6
285 heller 1.124
286     ;;;; Support for SBCL syntax
287    
288 heller 1.129 ;;; SBCL's source code is riddled with #! reader macros. Also symbols
289     ;;; containing `!' have special meaning. We have to work long and
290     ;;; hard to be able to read the source. To deal with #! reader
291     ;;; macros, we use a special readtable. The special symbols are
292     ;;; converted by a condition handler.
293    
294 heller 1.124 (defun feature-in-list-p (feature list)
295     (etypecase feature
296     (symbol (member feature list :test #'eq))
297     (cons (flet ((subfeature-in-list-p (subfeature)
298     (feature-in-list-p subfeature list)))
299     (ecase (first feature)
300     (:or (some #'subfeature-in-list-p (rest feature)))
301     (:and (every #'subfeature-in-list-p (rest feature)))
302     (:not (destructuring-bind (e) (cdr feature)
303     (not (subfeature-in-list-p e)))))))))
304    
305     (defun shebang-reader (stream sub-character infix-parameter)
306     (declare (ignore sub-character))
307     (when infix-parameter
308     (error "illegal read syntax: #~D!" infix-parameter))
309     (let ((next-char (read-char stream)))
310     (unless (find next-char "+-")
311     (error "illegal read syntax: #!~C" next-char))
312     ;; When test is not satisfied
313     ;; FIXME: clearer if order of NOT-P and (NOT NOT-P) were reversed? then
314     ;; would become "unless test is satisfied"..
315     (when (let* ((*package* (find-package "KEYWORD"))
316     (*read-suppress* nil)
317     (not-p (char= next-char #\-))
318     (feature (read stream)))
319     (if (feature-in-list-p feature *features*)
320     not-p
321     (not not-p)))
322     ;; Read (and discard) a form from input.
323     (let ((*read-suppress* t))
324     (read stream t nil t))))
325     (values))
326    
327 jsnellman 1.158 (defvar *shebang-readtable*
328 heller 1.124 (let ((*readtable* (copy-readtable nil)))
329 jsnellman 1.158 (set-dispatch-macro-character #\# #\!
330 heller 1.124 (lambda (s c n) (shebang-reader s c n))
331     *readtable*)
332     *readtable*))
333    
334     (defun shebang-readtable ()
335     *shebang-readtable*)
336    
337     (defun sbcl-package-p (package)
338     (let ((name (package-name package)))
339     (eql (mismatch "SB-" name) 3)))
340    
341 heller 1.126 (defun sbcl-source-file-p (filename)
342 nsiivola 1.187 (when filename
343 trittweiler 1.218 (loop for (nil pattern) in (logical-pathname-translations "SYS")
344 nsiivola 1.187 thereis (pathname-match-p filename pattern))))
345 heller 1.126
346     (defun guess-readtable-for-filename (filename)
347     (if (sbcl-source-file-p filename)
348     (shebang-readtable)
349     *readtable*))
350    
351 heller 1.124 (defvar *debootstrap-packages* t)
352    
353 heller 1.126 (defun call-with-debootstrapping (fun)
354 jsnellman 1.158 (handler-bind ((sb-int:bootstrap-package-not-found
355 heller 1.126 #'sb-int:debootstrap-package))
356     (funcall fun)))
357    
358 heller 1.124 (defmacro with-debootstrapping (&body body)
359 heller 1.126 `(call-with-debootstrapping (lambda () ,@body)))
360 heller 1.124
361     (defimplementation call-with-syntax-hooks (fn)
362 jsnellman 1.158 (cond ((and *debootstrap-packages*
363 heller 1.124 (sbcl-package-p *package*))
364     (with-debootstrapping (funcall fn)))
365     (t
366     (funcall fn))))
367    
368     (defimplementation default-readtable-alist ()
369     (let ((readtable (shebang-readtable)))
370     (loop for p in (remove-if-not #'sbcl-package-p (list-all-packages))
371     collect (cons (package-name p) readtable))))
372    
373 dbarlow 1.1 ;;; Utilities
374    
375 trittweiler 1.233 #+#.(swank-backend::with-symbol 'function-lambda-list 'sb-introspect)
376 trittweiler 1.230 (defimplementation arglist (fname)
377     (sb-introspect:function-lambda-list fname))
378    
379 trittweiler 1.233 #-#.(swank-backend::with-symbol 'function-lambda-list 'sb-introspect)
380 heller 1.160 (defimplementation arglist (fname)
381 heller 1.74 (sb-introspect:function-arglist fname))
382 mbaringer 1.100
383 heller 1.160 (defimplementation function-name (f)
384     (check-type f function)
385 mbaringer 1.100 (sb-impl::%fun-name f))
386 dbarlow 1.1
387 trittweiler 1.179 (defmethod declaration-arglist ((decl-identifier (eql 'optimize)))
388     (flet ((ensure-list (thing) (if (listp thing) thing (list thing))))
389     (let* ((flags (sb-cltl2:declaration-information decl-identifier)))
390     (if flags
391     ;; Symbols aren't printed with package qualifiers, but the FLAGS would
392     ;; have to be fully qualified when used inside a declaration. So we
393     ;; strip those as long as there's no better way. (FIXME)
394     `(&any ,@(remove-if-not #'(lambda (qualifier)
395     (find-symbol (symbol-name (first qualifier)) :cl))
396     flags :key #'ensure-list))
397     (call-next-method)))))
398    
399 trittweiler 1.233 #+#.(swank-backend::with-symbol 'deftype-lambda-list 'sb-introspect)
400 trittweiler 1.229 (defmethod type-specifier-arglist :around (typespec-operator)
401     (multiple-value-bind (arglist foundp)
402     (sb-introspect:deftype-lambda-list typespec-operator)
403     (if foundp arglist (call-next-method))))
404    
405 trittweiler 1.246
406 dbarlow 1.42 (defvar *buffer-name* nil)
407 dbarlow 1.1 (defvar *buffer-offset*)
408 heller 1.70 (defvar *buffer-substring* nil)
409 dbarlow 1.1
410 lgorrie 1.24 (defvar *previous-compiler-condition* nil
411     "Used to detect duplicates.")
412    
413 dbarlow 1.1 (defun handle-notification-condition (condition)
414     "Handle a condition caused by a compiler warning.
415     This traps all compiler conditions at a lower-level than using
416     C:*COMPILER-NOTIFICATION-FUNCTION*. The advantage is that we get to
417     craft our own error messages, which can omit a lot of redundant
418     information."
419 nsiivola 1.206 (unless (or (eq condition *previous-compiler-condition*))
420     ;; First resignal warnings, so that outer handlers -- which may choose to
421     ;; muffle this -- get a chance to run.
422     (when (typep condition 'warning)
423     (signal condition))
424     (setq *previous-compiler-condition* condition)
425     (signal-compiler-condition condition (sb-c::find-error-context nil))))
426 lgorrie 1.24
427     (defun signal-compiler-condition (condition context)
428     (signal (make-condition
429     'compiler-condition
430     :original-condition condition
431     :severity (etypecase condition
432     (sb-c:compiler-error :error)
433     (sb-ext:compiler-note :note)
434 sboukarev 1.247 #+#.(swank-backend::with-symbol redefinition-warning sb-kernel)
435 trittweiler 1.246 (sb-kernel:redefinition-warning
436     :redefinition)
437 lgorrie 1.24 (style-warning :style-warning)
438 lgorrie 1.96 (warning :warning)
439 trittweiler 1.237 (reader-error :read-error)
440 lgorrie 1.96 (error :error))
441 heller 1.107 :references (condition-references (real-condition condition))
442 heller 1.248 :message (brief-compiler-message-for-emacs condition)
443     :source-context (compiler-error-context context)
444 trittweiler 1.235 :location (compiler-note-location condition context))))
445 heller 1.107
446     (defun real-condition (condition)
447     "Return the encapsulated condition or CONDITION itself."
448     (typecase condition
449     (sb-int:encapsulated-condition (sb-int:encapsulated-condition condition))
450     (t condition)))
451 lgorrie 1.24
452 heller 1.184 (defun condition-references (condition)
453     (if (typep condition 'sb-int:reference-condition)
454     (externalize-reference
455     (sb-int:reference-condition-references condition))))
456    
457 trittweiler 1.235 (defun compiler-note-location (condition context)
458     (flet ((bailout ()
459     (list :error "No error location available")))
460     (cond (context
461     (locate-compiler-note
462     (sb-c::compiler-error-context-file-name context)
463     (compiler-source-path context)
464     (sb-c::compiler-error-context-original-source context)))
465     ((typep condition 'reader-error)
466 trittweiler 1.236 (let* ((stream (stream-error-stream condition))
467     (file (pathname stream)))
468     (unless (open-stream-p stream)
469     (bailout))
470     (if (compiling-from-buffer-p file)
471 trittweiler 1.237 ;; The stream position for e.g. "comma not inside backquote"
472     ;; is at the character following the comma, :offset is 0-based,
473     ;; hence the 1-.
474 trittweiler 1.236 (make-location (list :buffer *buffer-name*)
475     (list :offset *buffer-offset*
476 trittweiler 1.237 (1- (file-position stream))))
477 trittweiler 1.236 (progn
478     (assert (compiling-from-file-p file))
479 trittweiler 1.237 ;; No 1- because :position is 1-based.
480 trittweiler 1.236 (make-location (list :file (namestring file))
481     (list :position (file-position stream)))))))
482 trittweiler 1.235 (t (bailout)))))
483 heller 1.124
484 trittweiler 1.236 (defun compiling-from-buffer-p (filename)
485     (and (not (eq filename :lisp)) *buffer-name*))
486    
487     (defun compiling-from-file-p (filename)
488     (and (pathnamep filename) (null *buffer-name*)))
489    
490     (defun compiling-from-generated-code-p (filename source)
491     (and (eq filename :lisp) (stringp source)))
492    
493 heller 1.127 (defun locate-compiler-note (file source-path source)
494 trittweiler 1.236 (cond ((compiling-from-buffer-p file)
495 heller 1.219 (make-location (list :buffer *buffer-name*)
496     (list :offset *buffer-offset*
497     (source-path-string-position
498     source-path *buffer-substring*))))
499 trittweiler 1.236 ((compiling-from-file-p file)
500 heller 1.124 (make-location (list :file (namestring file))
501 heller 1.219 (list :position (1+ (source-path-file-position
502     source-path file)))))
503 trittweiler 1.236 ((compiling-from-generated-code-p file source)
504 heller 1.127 (make-location (list :source-form source)
505     (list :position 1)))
506 dbarlow 1.42 (t
507 mbaringer 1.165 (error "unhandled case in compiler note ~S ~S ~S" file source-path source))))
508 dbarlow 1.42
509 heller 1.66 (defun brief-compiler-message-for-emacs (condition)
510 dbarlow 1.1 "Briefly describe a compiler error for Emacs.
511     When Emacs presents the message it already has the source popped up
512     and the source form highlighted. This makes much of the information in
513     the error-context redundant."
514 crhodes 1.95 (let ((sb-int:*print-condition-references* nil))
515     (princ-to-string condition)))
516 heller 1.66
517 heller 1.248 (defun compiler-error-context (error-context)
518 heller 1.66 "Describe a compiler error for Emacs including context information."
519 heller 1.45 (declare (type (or sb-c::compiler-error-context null) error-context))
520 heller 1.66 (multiple-value-bind (enclosing source)
521     (if error-context
522     (values (sb-c::compiler-error-context-enclosing-source error-context)
523     (sb-c::compiler-error-context-source error-context)))
524 heller 1.248 (and (or enclosing source)
525     (format nil "~@[--> ~{~<~%--> ~1:;~A~> ~}~%~]~@[~{==>~%~A~%~}~]"
526     enclosing source))))
527 dbarlow 1.1
528 heller 1.124 (defun compiler-source-path (context)
529 dbarlow 1.1 "Return the source-path for the current compiler error.
530     Returns NIL if this cannot be determined by examining internal
531     compiler state."
532     (cond ((sb-c::node-p context)
533     (reverse
534     (sb-c::source-path-original-source
535     (sb-c::node-source-path context))))
536     ((sb-c::compiler-error-context-p context)
537     (reverse
538     (sb-c::compiler-error-context-original-source-path context)))))
539    
540 lgorrie 1.54 (defimplementation call-with-compilation-hooks (function)
541 heller 1.58 (declare (type function function))
542 trittweiler 1.238 (handler-bind
543     ;; N.B. Even though these handlers are called HANDLE-FOO they
544     ;; actually decline, i.e. the signalling of the original
545     ;; condition continues upward.
546     ((sb-c:fatal-compiler-error #'handle-file-compiler-termination)
547     (sb-c:compiler-error #'handle-notification-condition)
548     (sb-ext:compiler-note #'handle-notification-condition)
549     (warning #'handle-notification-condition))
550 dbarlow 1.41 (funcall function)))
551 lgorrie 1.24
552 lgorrie 1.96 (defun handle-file-compiler-termination (condition)
553     "Handle a condition that caused the file compiler to terminate."
554     (handle-notification-condition
555     (sb-int:encapsulated-condition condition)))
556    
557 heller 1.91 (defvar *trap-load-time-warnings* nil)
558    
559 heller 1.232 (defimplementation swank-compile-file (input-file output-file
560     load-p external-format)
561 heller 1.171 (handler-case
562 heller 1.226 (multiple-value-bind (output-file warnings-p failure-p)
563 heller 1.224 (with-compilation-hooks ()
564 heller 1.232 (compile-file input-file :output-file output-file
565     :external-format external-format))
566 heller 1.224 (values output-file warnings-p
567     (or failure-p
568     (when load-p
569     ;; Cache the latest source file for definition-finding.
570 heller 1.232 (source-cache-get input-file
571     (file-write-date input-file))
572 heller 1.224 (not (load output-file))))))
573 trittweiler 1.238 ;; N.B. This comes through despite of WITH-COMPILATION-HOOKS.
574     (sb-c:fatal-compiler-error () (values nil nil t))))
575 lgorrie 1.24
576 heller 1.124 ;;;; compile-string
577    
578 heller 1.156 ;;; We copy the string to a temporary file in order to get adequate
579     ;;; semantics for :COMPILE-TOPLEVEL and :LOAD-TOPLEVEL EVAL-WHEN forms
580     ;;; which the previous approach using
581     ;;; (compile nil `(lambda () ,(read-from-string string)))
582     ;;; did not provide.
583    
584 heller 1.245 (locally (declare (sb-ext:muffle-conditions sb-ext:compiler-note))
585    
586 heller 1.242 (sb-alien:define-alien-routine (#-win32 "tempnam" #+win32 "_tempnam" tempnam)
587     sb-alien:c-string
588     (dir sb-alien:c-string)
589     (prefix sb-alien:c-string))
590 heller 1.156
591 heller 1.245 )
592    
593 heller 1.156 (defun temp-file-name ()
594     "Return a temporary file name to compile strings into."
595 heller 1.242 (tempnam nil nil))
596 heller 1.156
597 trittweiler 1.228 (defun get-compiler-policy (default-policy)
598     (declare (ignorable default-policy))
599 trittweiler 1.233 #+#.(swank-backend::with-symbol 'restrict-compiler-policy 'sb-ext)
600 trittweiler 1.228 (remove-duplicates (append default-policy (sb-ext:restrict-compiler-policy))
601     :key #'car))
602    
603     (defun set-compiler-policy (policy)
604     (declare (ignorable policy))
605 trittweiler 1.233 #+#.(swank-backend::with-symbol 'restrict-compiler-policy 'sb-ext)
606 trittweiler 1.228 (loop for (qual . value) in policy
607     do (sb-ext:restrict-compiler-policy qual value)))
608    
609 heller 1.231 (defimplementation swank-compile-string (string &key buffer position filename
610     policy)
611 heller 1.156 (let ((*buffer-name* buffer)
612     (*buffer-offset* position)
613     (*buffer-substring* string)
614 heller 1.231 (temp-file-name (temp-file-name))
615 trittweiler 1.228 (saved-policy (get-compiler-policy '((debug . 0) (speed . 0)))))
616     (when policy
617     (set-compiler-policy policy))
618 trittweiler 1.200 (flet ((load-it (filename)
619     (when filename (load filename)))
620     (compile-it (cont)
621 heller 1.139 (with-compilation-hooks ()
622 heller 1.156 (with-compilation-unit
623     (:source-plist (list :emacs-buffer buffer
624 heller 1.231 :emacs-filename filename
625 heller 1.156 :emacs-string string
626     :emacs-position position))
627 trittweiler 1.249 (multiple-value-bind (output-file warningsp failurep)
628     (compile-file temp-file-name)
629 sboukarev 1.251 (declare (ignore warningsp))
630 trittweiler 1.249 (unless failurep
631     (funcall cont output-file)))))))
632 heller 1.231 (with-open-file (s temp-file-name :direction :output :if-exists :error)
633 heller 1.156 (write-string string s))
634     (unwind-protect
635     (if *trap-load-time-warnings*
636 trittweiler 1.200 (compile-it #'load-it)
637     (load-it (compile-it #'identity)))
638 heller 1.156 (ignore-errors
639 trittweiler 1.228 (set-compiler-policy saved-policy)
640 heller 1.231 (delete-file temp-file-name)
641     (delete-file (compile-file-pathname temp-file-name)))))))
642 dbarlow 1.1
643     ;;;; Definitions
644    
645     (defvar *debug-definition-finding* nil
646     "When true don't handle errors while looking for definitions.
647     This is useful when debugging the definition-finding code.")
648    
649 jsnellman 1.149 (defparameter *definition-types*
650     '(:variable defvar
651     :constant defconstant
652     :type deftype
653     :symbol-macro define-symbol-macro
654     :macro defmacro
655     :compiler-macro define-compiler-macro
656     :function defun
657     :generic-function defgeneric
658     :method defmethod
659     :setf-expander define-setf-expander
660     :structure defstruct
661 jsnellman 1.159 :condition define-condition
662 jsnellman 1.149 :class defclass
663     :method-combination define-method-combination
664     :package defpackage
665     :transform :deftransform
666     :optimizer :defoptimizer
667     :vop :define-vop
668     :source-transform :define-source-transform)
669     "Map SB-INTROSPECT definition type names to Slime-friendly forms")
670    
671 trittweiler 1.234 (defun definition-specifier (type name)
672     "Return a pretty specifier for NAME representing a definition of type TYPE."
673     (if (and (symbolp name)
674     (eq type :function)
675     (sb-int:info :function :ir1-convert name))
676     :def-ir1-translator
677     (getf *definition-types* type)))
678    
679    
680 jsnellman 1.149 (defimplementation find-definitions (name)
681     (loop for type in *definition-types* by #'cddr
682     for locations = (sb-introspect:find-definition-sources-by-name
683     name type)
684     append (loop for source-location in locations collect
685     (make-source-location-specification type name
686     source-location))))
687    
688 trittweiler 1.193 (defimplementation find-source-location (obj)
689     (flet ((general-type-of (obj)
690     (typecase obj
691     (method :method)
692     (generic-function :generic-function)
693     (function :function)
694     (structure-class :structure-class)
695     (class :class)
696     (method-combination :method-combination)
697 trittweiler 1.200 (package :package)
698     (condition :condition)
699 trittweiler 1.193 (structure-object :structure-object)
700     (standard-object :standard-object)
701     (t :thing)))
702     (to-string (obj)
703     (typecase obj
704 trittweiler 1.200 (package (princ-to-string obj)) ; Packages are possibly named entities.
705 trittweiler 1.193 ((or structure-object standard-object condition)
706     (with-output-to-string (s)
707     (print-unreadable-object (obj s :type t :identity t))))
708 trittweiler 1.200 (t (princ-to-string obj)))))
709 trittweiler 1.193 (handler-case
710     (make-definition-source-location
711     (sb-introspect:find-definition-source obj) (general-type-of obj) (to-string obj))
712     (error (e)
713     (list :error (format nil "Error: ~A" e))))))
714    
715    
716 jsnellman 1.149 (defun make-source-location-specification (type name source-location)
717 trittweiler 1.234 (list (make-dspec type name source-location)
718 jsnellman 1.149 (if *debug-definition-finding*
719     (make-definition-source-location source-location type name)
720 nsiivola 1.176 (handler-case
721     (make-definition-source-location source-location type name)
722 jsnellman 1.149 (error (e)
723 nsiivola 1.176 (list :error (format nil "Error: ~A" e)))))))
724 jsnellman 1.149
725 trittweiler 1.234 (defun make-dspec (type name source-location)
726     (list* (definition-specifier type name)
727     name
728     (sb-introspect::definition-source-description source-location)))
729    
730 jsnellman 1.149 (defun make-definition-source-location (definition-source type name)
731     (with-struct (sb-introspect::definition-source-
732     pathname form-path character-offset plist
733     file-write-date)
734     definition-source
735 nsiivola 1.176 (destructuring-bind (&key emacs-buffer emacs-position emacs-directory
736 jsnellman 1.149 emacs-string &allow-other-keys)
737     plist
738     (cond
739     (emacs-buffer
740 trittweiler 1.252 (let ((*readtable* (guess-readtable-for-filename emacs-directory)))
741     (multiple-value-bind (start end)
742     (if form-path
743     (with-debootstrapping
744     (source-path-string-position form-path emacs-string))
745     (values character-offset most-positive-fixnum))
746     (make-location `(:buffer ,emacs-buffer)
747     `(:offset ,emacs-position ,start)
748     `(:snippet
749     ,(subseq emacs-string
750     start
751     (min end (+ start *source-snippet-size*))))))))
752 jsnellman 1.149 ((not pathname)
753 trittweiler 1.192 `(:error ,(format nil "Source definition of ~A ~A not found"
754 jsnellman 1.149 (string-downcase type) name)))
755     (t
756     (let* ((namestring (namestring (translate-logical-pathname pathname)))
757 jsnellman 1.172 (pos (source-file-position namestring file-write-date form-path
758     character-offset))
759     (snippet (source-hint-snippet namestring file-write-date pos)))
760 jsnellman 1.149 (make-location `(:file ,namestring)
761 trittweiler 1.192 ;; /file positions/ in Common Lisp start
762     ;; from 0, in Emacs they start from 1.
763 trittweiler 1.220 `(:position ,(1+ pos))
764 jsnellman 1.149 `(:snippet ,snippet))))))))
765    
766 jsnellman 1.172 (defun source-file-position (filename write-date form-path character-offset)
767     (let ((source (get-source-code filename write-date))
768     (*readtable* (guess-readtable-for-filename filename)))
769 trittweiler 1.192 (with-debootstrapping
770     (if form-path
771     (source-path-string-position form-path source)
772     (or character-offset 0)))))
773 jsnellman 1.172
774 jsnellman 1.149 (defun source-hint-snippet (filename write-date position)
775 trittweiler 1.241 (read-snippet-from-string (get-source-code filename write-date) position))
776 jsnellman 1.149
777 jsnellman 1.151 (defun function-source-location (function &optional name)
778     (declare (type function function))
779     (let ((location (sb-introspect:find-definition-source function)))
780     (make-definition-source-location location :function name)))
781    
782     (defun safe-function-source-location (fun name)
783     (if *debug-definition-finding*
784     (function-source-location fun name)
785     (handler-case (function-source-location fun name)
786     (error (e)
787     (list :error (format nil "Error: ~A" e))))))
788 heller 1.105
789 lgorrie 1.54 (defimplementation describe-symbol-for-emacs (symbol)
790 dbarlow 1.1 "Return a plist describing SYMBOL.
791     Return NIL if the symbol is unbound."
792     (let ((result '()))
793 heller 1.133 (flet ((doc (kind)
794     (or (documentation symbol kind) :not-documented))
795     (maybe-push (property value)
796     (when value
797     (setf result (list* property value result)))))
798 dbarlow 1.1 (maybe-push
799     :variable (multiple-value-bind (kind recorded-p)
800     (sb-int:info :variable :kind symbol)
801     (declare (ignore kind))
802     (if (or (boundp symbol) recorded-p)
803     (doc 'variable))))
804 heller 1.133 (when (fboundp symbol)
805     (maybe-push
806     (cond ((macro-function symbol) :macro)
807     ((special-operator-p symbol) :special-operator)
808     ((typep (fdefinition symbol) 'generic-function)
809     :generic-function)
810     (t :function))
811     (doc 'function)))
812 dbarlow 1.1 (maybe-push
813     :setf (if (or (sb-int:info :setf :inverse symbol)
814     (sb-int:info :setf :expander symbol))
815     (doc 'setf)))
816     (maybe-push
817     :type (if (sb-int:info :type :kind symbol)
818     (doc 'type)))
819 lgorrie 1.24 result)))
820 dbarlow 1.1
821 heller 1.74 (defimplementation describe-definition (symbol type)
822 lgorrie 1.54 (case type
823     (:variable
824 heller 1.74 (describe symbol))
825     (:function
826     (describe (symbol-function symbol)))
827 lgorrie 1.54 (:setf
828 heller 1.74 (describe (or (sb-int:info :setf :inverse symbol)
829     (sb-int:info :setf :expander symbol))))
830 lgorrie 1.54 (:class
831 heller 1.74 (describe (find-class symbol)))
832 lgorrie 1.54 (:type
833 heller 1.74 (describe (sb-kernel:values-specifier-type symbol)))))
834 jsnellman 1.172
835     #+#.(swank-backend::sbcl-with-xref-p)
836     (progn
837 trittweiler 1.255 (defmacro defxref (name &optional fn-name)
838 jsnellman 1.172 `(defimplementation ,name (what)
839     (sanitize-xrefs
840     (mapcar #'source-location-for-xref-data
841 trittweiler 1.255 (,(find-symbol (symbol-name (if fn-name
842     fn-name
843     name))
844     "SB-INTROSPECT")
845 jsnellman 1.172 what)))))
846     (defxref who-calls)
847     (defxref who-binds)
848     (defxref who-sets)
849     (defxref who-references)
850 trittweiler 1.222 (defxref who-macroexpands)
851 trittweiler 1.255 #+#.(swank-backend::with-symbol 'who-specializes-directly 'sb-introspect)
852     (defxref who-specializes who-specializes-directly))
853 jsnellman 1.172
854     (defun source-location-for-xref-data (xref-data)
855     (let ((name (car xref-data))
856     (source-location (cdr xref-data)))
857     (list name
858     (handler-case (make-definition-source-location source-location
859     'function
860     name)
861     (error (e)
862     (list :error (format nil "Error: ~A" e)))))))
863 dbarlow 1.1
864 heller 1.97 (defimplementation list-callers (symbol)
865     (let ((fn (fdefinition symbol)))
866 heller 1.168 (sanitize-xrefs
867     (mapcar #'function-dspec (sb-introspect:find-function-callers fn)))))
868 heller 1.97
869     (defimplementation list-callees (symbol)
870     (let ((fn (fdefinition symbol)))
871 heller 1.168 (sanitize-xrefs
872     (mapcar #'function-dspec (sb-introspect:find-function-callees fn)))))
873 heller 1.97
874 jsnellman 1.172 (defun sanitize-xrefs (xrefs)
875 heller 1.168 (remove-duplicates
876     (remove-if (lambda (f)
877     (member f (ignored-xref-function-names)))
878 jsnellman 1.172 (loop for entry in xrefs
879     for name = (car entry)
880     collect (if (and (consp name)
881     (member (car name)
882     '(sb-pcl::fast-method
883     sb-pcl::slow-method
884     sb-pcl::method)))
885     (cons (cons 'defmethod (cdr name))
886     (cdr entry))
887     entry))
888 heller 1.168 :key #'car)
889     :test (lambda (a b)
890     (and (eq (first a) (first b))
891     (equal (second a) (second b))))))
892    
893     (defun ignored-xref-function-names ()
894     #-#.(swank-backend::sbcl-with-new-stepper-p)
895     '(nil sb-c::step-form sb-c::step-values)
896     #+#.(swank-backend::sbcl-with-new-stepper-p)
897     '(nil))
898 jsnellman 1.166
899 lgorrie 1.122 (defun function-dspec (fn)
900     "Describe where the function FN was defined.
901     Return a list of the form (NAME LOCATION)."
902     (let ((name (sb-kernel:%fun-name fn)))
903     (list name (safe-function-source-location fn name))))
904    
905 dbarlow 1.4 ;;; macroexpansion
906 dbarlow 1.1
907 lgorrie 1.54 (defimplementation macroexpand-all (form)
908 heller 1.21 (let ((sb-walker:*walk-form-expand-macros-p* t))
909     (sb-walker:walk-form form)))
910 lgorrie 1.25
911 dbarlow 1.1
912     ;;; Debugging
913    
914 trittweiler 1.257 ;;; Notice that SB-EXT:*INVOKE-DEBUGGER-HOOK* is slightly stronger
915     ;;; than just a hook into BREAK. In particular, it'll make
916     ;;; (LET ((*DEBUGGER-HOOK* NIL)) ..error..) drop into SLDB rather
917     ;;; than the native debugger. That should probably be considered a
918     ;;; feature.
919 dbarlow 1.1
920 trittweiler 1.194 (defun make-invoke-debugger-hook (hook)
921 trittweiler 1.257 #'(sb-int:named-lambda swank-invoke-debugger-hook
922     (condition old-hook)
923 trittweiler 1.194 (if *debugger-hook*
924 trittweiler 1.257 nil ; decline, *DEBUGGER-HOOK* will be tried next.
925 trittweiler 1.194 (funcall hook condition old-hook))))
926    
927 trittweiler 1.257 (defun set-break-hook (hook)
928     (setq sb-ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook)))
929    
930     (defun call-with-break-hook (hook continuation)
931     (let ((sb-ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook)))
932     (funcall continuation)))
933    
934 heller 1.148 (defimplementation install-debugger-globally (function)
935 trittweiler 1.194 (setq *debugger-hook* function)
936 trittweiler 1.257 (set-break-hook function))
937 heller 1.148
938 jsnellman 1.162 (defimplementation condition-extras (condition)
939 heller 1.183 (cond #+#.(swank-backend::sbcl-with-new-stepper-p)
940     ((typep condition 'sb-impl::step-form-condition)
941     `((:show-frame-source 0)))
942     ((typep condition 'sb-int:reference-condition)
943     (let ((refs (sb-int:reference-condition-references condition)))
944     (if refs
945     `((:references ,(externalize-reference refs))))))))
946    
947     (defun externalize-reference (ref)
948     (etypecase ref
949     (null nil)
950     (cons (cons (externalize-reference (car ref))
951     (externalize-reference (cdr ref))))
952     ((or string number) ref)
953     (symbol
954     (cond ((eq (symbol-package ref) (symbol-package :test))
955     ref)
956     (t (symbol-name ref))))))
957 jsnellman 1.162
958 trittweiler 1.257 (defvar *sldb-stack-top*)
959    
960 lgorrie 1.54 (defimplementation call-with-debugging-environment (debugger-loop-fn)
961 heller 1.58 (declare (type function debugger-loop-fn))
962 lgorrie 1.25 (let* ((*sldb-stack-top* (or sb-debug:*stack-top-hint* (sb-di:top-frame)))
963 trittweiler 1.199 (sb-debug:*stack-top-hint* nil))
964 jsnellman 1.158 (handler-bind ((sb-di:debug-condition
965 dbarlow 1.1 (lambda (condition)
966 lgorrie 1.25 (signal (make-condition
967     'sldb-condition
968     :original-condition condition)))))
969     (funcall debugger-loop-fn))))
970 dbarlow 1.1
971 jsnellman 1.162 #+#.(swank-backend::sbcl-with-new-stepper-p)
972     (progn
973     (defimplementation activate-stepping (frame)
974     (declare (ignore frame))
975     (sb-impl::enable-stepping))
976     (defimplementation sldb-stepper-condition-p (condition)
977     (typep condition 'sb-ext:step-form-condition))
978     (defimplementation sldb-step-into ()
979     (invoke-restart 'sb-ext:step-into))
980     (defimplementation sldb-step-next ()
981     (invoke-restart 'sb-ext:step-next))
982     (defimplementation sldb-step-out ()
983     (invoke-restart 'sb-ext:step-out)))
984    
985 heller 1.118 (defimplementation call-with-debugger-hook (hook fun)
986 trittweiler 1.257 (let (#+#.(swank-backend::sbcl-with-new-stepper-p)
987 jsnellman 1.162 (sb-ext:*stepper-hook*
988     (lambda (condition)
989 jsnellman 1.164 (typecase condition
990     (sb-ext:step-form-condition
991     (let ((sb-debug:*stack-top-hint* (sb-di::find-stepped-frame)))
992     (sb-impl::invoke-debugger condition)))))))
993     (handler-bind (#+#.(swank-backend::sbcl-with-new-stepper-p)
994     (sb-ext:step-condition #'sb-impl::invoke-stepper))
995 trittweiler 1.257 (call-with-break-hook hook fun))))
996 heller 1.118
997 dbarlow 1.1 (defun nth-frame (index)
998     (do ((frame *sldb-stack-top* (sb-di:frame-down frame))
999     (i index (1- i)))
1000     ((zerop i) frame)))
1001    
1002 heller 1.74 (defimplementation compute-backtrace (start end)
1003 dbarlow 1.1 "Return a list of frames starting with frame number START and
1004     continuing to frame number END or, if END is nil, the last frame on the
1005     stack."
1006     (let ((end (or end most-positive-fixnum)))
1007 heller 1.45 (loop for f = (nth-frame start) then (sb-di:frame-down f)
1008     for i from start below end
1009 heller 1.225 while f collect f)))
1010 trittweiler 1.218
1011 heller 1.225 (defimplementation print-frame (frame stream)
1012     (sb-debug::print-frame-call frame stream))
1013 trittweiler 1.218
1014 heller 1.225 (defimplementation frame-restartable-p (frame)
1015 trittweiler 1.218 #+#.(swank-backend::sbcl-with-restart-frame)
1016 heller 1.225 (not (null (sb-debug:frame-has-debug-tag-p frame))))
1017 dbarlow 1.1
1018 heller 1.124 ;;;; Code-location -> source-location translation
1019    
1020 heller 1.129 ;;; If debug-block info is avaibale, we determine the file position of
1021     ;;; the source-path for a code-location. If the code was compiled
1022     ;;; with C-c C-c, we have to search the position in the source string.
1023     ;;; If there's no debug-block info, we return the (less precise)
1024     ;;; source-location of the corresponding function.
1025    
1026 nsiivola 1.134 (defun code-location-source-location (code-location)
1027     (let* ((dsource (sb-di:code-location-debug-source code-location))
1028     (plist (sb-c::debug-source-plist dsource)))
1029     (if (getf plist :emacs-buffer)
1030     (emacs-buffer-source-location code-location plist)
1031 trittweiler 1.233 #+#.(swank-backend::with-symbol 'debug-source-from 'sb-di)
1032 nsiivola 1.134 (ecase (sb-di:debug-source-from dsource)
1033     (:file (file-source-location code-location))
1034 trittweiler 1.197 (:lisp (lisp-source-location code-location)))
1035 trittweiler 1.233 #-#.(swank-backend::with-symbol 'debug-source-from 'sb-di)
1036 trittweiler 1.197 (if (sb-di:debug-source-namestring dsource)
1037     (file-source-location code-location)
1038     (lisp-source-location code-location)))))
1039 nsiivola 1.134
1040     ;;; FIXME: The naming policy of source-location functions is a bit
1041     ;;; fuzzy: we have FUNCTION-SOURCE-LOCATION which returns the
1042     ;;; source-location for a function, and we also have FILE-SOURCE-LOCATION &co
1043     ;;; which returns the source location for a _code-location_.
1044 jsnellman 1.158 ;;;
1045 nsiivola 1.134 ;;; Maybe these should be named code-location-file-source-location,
1046 heller 1.139 ;;; etc, turned into generic functions, or something. In the very
1047     ;;; least the names should indicate the main entry point vs. helper
1048     ;;; status.
1049 heller 1.124
1050 nsiivola 1.134 (defun file-source-location (code-location)
1051     (if (code-location-has-debug-block-info-p code-location)
1052     (source-file-source-location code-location)
1053     (fallback-source-location code-location)))
1054    
1055     (defun fallback-source-location (code-location)
1056     (let ((fun (code-location-debug-fun-fun code-location)))
1057     (cond (fun (function-source-location fun))
1058 heller 1.182 (t (error "Cannot find source location for: ~A " code-location)))))
1059 nsiivola 1.134
1060 heller 1.124 (defun lisp-source-location (code-location)
1061 jsnellman 1.158 (let ((source (prin1-to-string
1062 nsiivola 1.134 (sb-debug::code-location-source-form code-location 100))))
1063 heller 1.219 (make-location `(:source-form ,source) '(:position 1))))
1064 heller 1.124
1065 nsiivola 1.134 (defun emacs-buffer-source-location (code-location plist)
1066     (if (code-location-has-debug-block-info-p code-location)
1067 nsiivola 1.177 (destructuring-bind (&key emacs-buffer emacs-position emacs-string
1068     &allow-other-keys)
1069     plist
1070 nsiivola 1.134 (let* ((pos (string-source-position code-location emacs-string))
1071 trittweiler 1.241 (snipped (read-snippet-from-string emacs-string pos)))
1072 jsnellman 1.158 (make-location `(:buffer ,emacs-buffer)
1073 heller 1.219 `(:offset ,emacs-position ,pos)
1074 nsiivola 1.134 `(:snippet ,snipped))))
1075     (fallback-source-location code-location)))
1076    
1077 heller 1.124 (defun source-file-source-location (code-location)
1078     (let* ((code-date (code-location-debug-source-created code-location))
1079     (filename (code-location-debug-source-name code-location))
1080 jsnellman 1.186 (*readtable* (guess-readtable-for-filename filename))
1081 heller 1.126 (source-code (get-source-code filename code-date)))
1082 jsnellman 1.186 (with-debootstrapping
1083     (with-input-from-string (s source-code)
1084     (let* ((pos (stream-source-position code-location s))
1085     (snippet (read-snippet s pos)))
1086     (make-location `(:file ,filename)
1087 heller 1.219 `(:position ,pos)
1088 jsnellman 1.186 `(:snippet ,snippet)))))))
1089 heller 1.124
1090     (defun code-location-debug-source-name (code-location)
1091 trittweiler 1.233 (namestring (truename (#+#.(swank-backend::with-symbol
1092 trittweiler 1.197 'debug-source-name 'sb-di)
1093     sb-c::debug-source-name
1094 trittweiler 1.233 #-#.(swank-backend::with-symbol
1095 trittweiler 1.197 'debug-source-name 'sb-di)
1096     sb-c::debug-source-namestring
1097 jsnellman 1.186 (sb-di::code-location-debug-source code-location)))))
1098 heller 1.124
1099     (defun code-location-debug-source-created (code-location)
1100 jsnellman 1.158 (sb-c::debug-source-created
1101 heller 1.124 (sb-di::code-location-debug-source code-location)))
1102    
1103     (defun code-location-debug-fun-fun (code-location)
1104     (sb-di:debug-fun-fun (sb-di:code-location-debug-fun code-location)))
1105    
1106     (defun code-location-has-debug-block-info-p (code-location)
1107 jsnellman 1.158 (handler-case
1108 heller 1.124 (progn (sb-di:code-location-debug-block code-location)
1109     t)
1110     (sb-di:no-debug-blocks () nil)))
1111    
1112     (defun stream-source-position (code-location stream)
1113     (let* ((cloc (sb-debug::maybe-block-start-location code-location))
1114 heller 1.128 (tlf-number (sb-di::code-location-toplevel-form-offset cloc))
1115 heller 1.124 (form-number (sb-di::code-location-form-number cloc)))
1116     (multiple-value-bind (tlf pos-map) (read-source-form tlf-number stream)
1117     (let* ((path-table (sb-di::form-number-translations tlf 0))
1118 heller 1.128 (path (cond ((<= (length path-table) form-number)
1119 heller 1.129 (warn "inconsistent form-number-translations")
1120 heller 1.128 (list 0))
1121     (t
1122     (reverse (cdr (aref path-table form-number)))))))
1123     (source-path-source-position path tlf pos-map)))))
1124    
1125     (defun string-source-position (code-location string)
1126     (with-input-from-string (s string)
1127     (stream-source-position code-location s)))
1128 dbarlow 1.1
1129 dbarlow 1.44 ;;; source-path-file-position and friends are in swank-source-path-parser
1130 lgorrie 1.121
1131 dbarlow 1.1 (defun safe-source-location-for-emacs (code-location)
1132 heller 1.126 (if *debug-definition-finding*
1133     (code-location-source-location code-location)
1134     (handler-case (code-location-source-location code-location)
1135     (error (c) (list :error (format nil "~A" c))))))
1136 jsnellman 1.158
1137 heller 1.243 (defimplementation frame-source-location (index)
1138 jsnellman 1.158 (safe-source-location-for-emacs
1139 heller 1.22 (sb-di:frame-code-location (nth-frame index))))
1140 dbarlow 1.1
1141 heller 1.92 (defun frame-debug-vars (frame)
1142     "Return a vector of debug-variables in frame."
1143     (sb-di::debug-fun-debug-vars (sb-di:frame-debug-fun frame)))
1144    
1145     (defun debug-var-value (var frame location)
1146     (ecase (sb-di:debug-var-validity var location)
1147     (:valid (sb-di:debug-var-value var frame))
1148     ((:invalid :unknown) ':<not-available>)))
1149    
1150 lgorrie 1.54 (defimplementation frame-locals (index)
1151 dbarlow 1.1 (let* ((frame (nth-frame index))
1152 heller 1.92 (loc (sb-di:frame-code-location frame))
1153     (vars (frame-debug-vars frame)))
1154 sboukarev 1.256 (when vars
1155     (loop for v across vars collect
1156     (list :name (sb-di:debug-var-symbol v)
1157     :id (sb-di:debug-var-id v)
1158     :value (debug-var-value v frame loc))))))
1159 heller 1.92
1160     (defimplementation frame-var-value (frame var)
1161     (let* ((frame (nth-frame frame))
1162     (dvar (aref (frame-debug-vars frame) var)))
1163     (debug-var-value dvar frame (sb-di:frame-code-location frame))))
1164 dbarlow 1.1
1165 lgorrie 1.54 (defimplementation frame-catch-tags (index)
1166 heller 1.74 (mapcar #'car (sb-di:frame-catches (nth-frame index))))
1167 lgorrie 1.50
1168 heller 1.56 (defimplementation eval-in-frame (form index)
1169     (let ((frame (nth-frame index)))
1170 heller 1.58 (funcall (the function
1171 jsnellman 1.158 (sb-di:preprocess-for-eval form
1172 heller 1.58 (sb-di:frame-code-location frame)))
1173 heller 1.56 frame)))
1174    
1175 jsnellman 1.174 #+#.(swank-backend::sbcl-with-restart-frame)
1176     (progn
1177     (defimplementation return-from-frame (index form)
1178     (let* ((frame (nth-frame index)))
1179     (cond ((sb-debug:frame-has-debug-tag-p frame)
1180     (let ((values (multiple-value-list (eval-in-frame form index))))
1181     (sb-debug:unwind-to-frame-and-call frame
1182     (lambda ()
1183     (values-list values)))))
1184     (t (format nil "Cannot return from frame: ~S" frame)))))
1185    
1186     (defimplementation restart-frame (index)
1187     (let* ((frame (nth-frame index)))
1188     (cond ((sb-debug:frame-has-debug-tag-p frame)
1189     (let* ((call-list (sb-debug::frame-call-as-list frame))
1190     (fun (fdefinition (car call-list)))
1191     (thunk (lambda ()
1192     ;; Ensure that the thunk gets tail-call-optimized
1193     (declare (optimize (debug 1)))
1194     (apply fun (cdr call-list)))))
1195     (sb-debug:unwind-to-frame-and-call frame thunk)))
1196     (t (format nil "Cannot restart frame: ~S" frame))))))
1197 heller 1.152
1198     ;; FIXME: this implementation doesn't unwind the stack before
1199     ;; re-invoking the function, but it's better than no implementation at
1200     ;; all.
1201 jsnellman 1.174 #-#.(swank-backend::sbcl-with-restart-frame)
1202     (progn
1203     (defun sb-debug-catch-tag-p (tag)
1204     (and (symbolp tag)
1205     (not (symbol-package tag))
1206     (string= tag :sb-debug-catch-tag)))
1207    
1208     (defimplementation return-from-frame (index form)
1209     (let* ((frame (nth-frame index))
1210     (probe (assoc-if #'sb-debug-catch-tag-p
1211     (sb-di::frame-catches frame))))
1212     (cond (probe (throw (car probe) (eval-in-frame form index)))
1213     (t (format nil "Cannot return from frame: ~S" frame)))))
1214    
1215     (defimplementation restart-frame (index)
1216     (let ((frame (nth-frame index)))
1217     (return-from-frame index (sb-debug::frame-call-as-list frame)))))
1218 jsnellman 1.158
1219 lgorrie 1.87 ;;;;; reference-conditions
1220    
1221     (defimplementation format-sldb-condition (condition)
1222     (let ((sb-int:*print-condition-references* nil))
1223     (princ-to-string condition)))
1224    
1225 heller 1.57
1226     ;;;; Profiling
1227    
1228     (defimplementation profile (fname)
1229     (when fname (eval `(sb-profile:profile ,fname))))
1230    
1231     (defimplementation unprofile (fname)
1232     (when fname (eval `(sb-profile:unprofile ,fname))))
1233    
1234     (defimplementation unprofile-all ()
1235     (sb-profile:unprofile)
1236     "All functions unprofiled.")
1237    
1238     (defimplementation profile-report ()
1239     (sb-profile:report))
1240    
1241     (defimplementation profile-reset ()
1242     (sb-profile:reset)
1243     "Reset profiling counters.")
1244    
1245     (defimplementation profiled-functions ()
1246     (sb-profile:profile))
1247    
1248 heller 1.116 (defimplementation profile-package (package callers methods)
1249     (declare (ignore callers methods))
1250     (eval `(sb-profile:profile ,(package-name (find-package package)))))
1251    
1252 heller 1.57
1253 heller 1.64 ;;;; Inspector
1254 heller 1.63
1255 heller 1.190 (defmethod emacs-inspect ((o t))
1256 heller 1.64 (cond ((sb-di::indirect-value-cell-p o)
1257 heller 1.191 (label-value-line* (:value (sb-kernel:value-cell-ref o))))
1258 heller 1.64 (t
1259 heller 1.126 (multiple-value-bind (text label parts) (sb-impl::inspected-parts o)
1260 heller 1.191 (list* (format nil "~a~%" text)
1261     (if label
1262     (loop for (l . v) in parts
1263     append (label-value-line l v))
1264     (loop for value in parts for i from 0
1265     append (label-value-line i value))))))))
1266 heller 1.64
1267 heller 1.190 (defmethod emacs-inspect ((o function))
1268 heller 1.64 (let ((header (sb-kernel:widetag-of o)))
1269     (cond ((= header sb-vm:simple-fun-header-widetag)
1270 heller 1.126 (label-value-line*
1271     (:name (sb-kernel:%simple-fun-name o))
1272     (:arglist (sb-kernel:%simple-fun-arglist o))
1273     (:self (sb-kernel:%simple-fun-self o))
1274     (:next (sb-kernel:%simple-fun-next o))
1275     (:type (sb-kernel:%simple-fun-type o))
1276 heller 1.191 (:code (sb-kernel:fun-code-header o))))
1277 heller 1.64 ((= header sb-vm:closure-header-widetag)
1278 jsnellman 1.158 (append
1279 heller 1.126 (label-value-line :function (sb-kernel:%closure-fun o))
1280     `("Closed over values:" (:newline))
1281     (loop for i below (1- (sb-kernel:get-closure-length o))
1282 jsnellman 1.158 append (label-value-line
1283 heller 1.191 i (sb-kernel:%closure-index-ref o i)))))
1284 heller 1.64 (t (call-next-method o)))))
1285    
1286 heller 1.190 (defmethod emacs-inspect ((o sb-kernel:code-component))
1287 jsnellman 1.158 (append
1288     (label-value-line*
1289 heller 1.113 (:code-size (sb-kernel:%code-code-size o))
1290     (:entry-points (sb-kernel:%code-entry-points o))
1291     (:debug-info (sb-kernel:%code-debug-info o))
1292 jsnellman 1.158 (:trace-table-offset (sb-kernel:code-header-ref
1293 heller 1.113 o sb-vm:code-trace-table-offset-slot)))
1294     `("Constants:" (:newline))
1295 jsnellman 1.158 (loop for i from sb-vm:code-constants-offset
1296 mbaringer 1.102 below (sb-kernel:get-header-data o)
1297 heller 1.113 append (label-value-line i (sb-kernel:code-header-ref o i)))
1298     `("Code:" (:newline)
1299     , (with-output-to-string (s)
1300     (cond ((sb-kernel:%code-debug-info o)
1301     (sb-disassem:disassemble-code-component o :stream s))
1302     (t
1303 jsnellman 1.158 (sb-disassem:disassemble-memory
1304     (sb-disassem::align
1305 heller 1.113 (+ (logandc2 (sb-kernel:get-lisp-obj-address o)
1306     sb-vm:lowtag-mask)
1307 heller 1.126 (* sb-vm:code-constants-offset
1308     sb-vm:n-word-bytes))
1309 heller 1.113 (ash 1 sb-vm:n-lowtag-bits))
1310     (ash (sb-kernel:%code-code-size o) sb-vm:word-shift)
1311 heller 1.191 :stream s)))))))
1312 mbaringer 1.102
1313 heller 1.190 (defmethod emacs-inspect ((o sb-ext:weak-pointer))
1314 mbaringer 1.167 (label-value-line*
1315 heller 1.191 (:value (sb-ext:weak-pointer-value o))))
1316 mbaringer 1.167
1317 heller 1.190 (defmethod emacs-inspect ((o sb-kernel:fdefn))
1318 heller 1.126 (label-value-line*
1319     (:name (sb-kernel:fdefn-name o))
1320 heller 1.191 (:function (sb-kernel:fdefn-fun o))))
1321 mbaringer 1.102
1322 heller 1.190 (defmethod emacs-inspect :around ((o generic-function))
1323 jsnellman 1.158 (append
1324 heller 1.191 (call-next-method)
1325 heller 1.126 (label-value-line*
1326     (:pretty-arglist (sb-pcl::generic-function-pretty-arglist o))
1327     (:initial-methods (sb-pcl::generic-function-initial-methods o))
1328 heller 1.191 )))
1329 heller 1.90
1330 heller 1.63
1331 lgorrie 1.50 ;;;; Multiprocessing
1332    
1333 crhodes 1.136 #+(and sb-thread
1334     #.(cl:if (cl:find-symbol "THREAD-NAME" "SB-THREAD") '(and) '(or)))
1335     (progn
1336     (defvar *thread-id-counter* 0)
1337 jsnellman 1.158
1338 crhodes 1.136 (defvar *thread-id-counter-lock*
1339     (sb-thread:make-mutex :name "thread id counter lock"))
1340    
1341     (defun next-thread-id ()
1342     (sb-thread:with-mutex (*thread-id-counter-lock*)
1343     (incf *thread-id-counter*)))
1344 jsnellman 1.158
1345 crhodes 1.136 (defparameter *thread-id-map* (make-hash-table))
1346    
1347     ;; This should be a thread -> id map but as weak keys are not
1348     ;; supported it is id -> map instead.
1349     (defvar *thread-id-map-lock*
1350     (sb-thread:make-mutex :name "thread id map lock"))
1351 jsnellman 1.158
1352 crhodes 1.136 (defimplementation spawn (fn &key name)
1353     (sb-thread:make-thread fn :name name))
1354    
1355     (defimplementation thread-id (thread)
1356 heller 1.160 (block thread-id
1357     (sb-thread:with-mutex (*thread-id-map-lock*)
1358     (loop for id being the hash-key in *thread-id-map*
1359     using (hash-value thread-pointer)
1360     do
1361     (let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer)))
1362     (cond ((null maybe-thread)
1363     ;; the value is gc'd, remove it manually
1364     (remhash id *thread-id-map*))
1365     ((eq thread maybe-thread)
1366     (return-from thread-id id)))))
1367     ;; lazy numbering
1368     (let ((id (next-thread-id)))
1369     (setf (gethash id *thread-id-map*) (sb-ext:make-weak-pointer thread))
1370     id))))
1371 crhodes 1.136
1372     (defimplementation find-thread (id)
1373     (sb-thread:with-mutex (*thread-id-map-lock*)
1374     (let ((thread-pointer (gethash id *thread-id-map*)))
1375     (if thread-pointer
1376     (let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer)))
1377     (if maybe-thread
1378     maybe-thread
1379     ;; the value is gc'd, remove it manually
1380     (progn
1381     (remhash id *thread-id-map*)
1382     nil)))
1383     nil))))
1384 jsnellman 1.158
1385 crhodes 1.136 (defimplementation thread-name (thread)
1386     ;; sometimes the name is not a string (e.g. NIL)
1387     (princ-to-string (sb-thread:thread-name thread)))
1388    
1389     (defimplementation thread-status (thread)
1390     (if (sb-thread:thread-alive-p thread)
1391 sboukarev 1.253 "Running"
1392     "Stopped"))
1393    
1394 crhodes 1.136 (defimplementation make-lock (&key name)
1395     (sb-thread:make-mutex :name name))
1396    
1397     (defimplementation call-with-lock-held (lock function)
1398     (declare (type function function))
1399 nsiivola 1.154 (sb-thread:with-recursive-lock (lock) (funcall function)))
1400    
1401 crhodes 1.136 (defimplementation current-thread ()
1402     sb-thread:*current-thread*)
1403    
1404     (defimplementation all-threads ()
1405     (sb-thread:list-all-threads))
1406 jsnellman 1.158
1407 crhodes 1.136 (defimplementation interrupt-thread (thread fn)
1408     (sb-thread:interrupt-thread thread fn))
1409    
1410     (defimplementation kill-thread (thread)
1411     (sb-thread:terminate-thread thread))
1412    
1413     (defimplementation thread-alive-p (thread)
1414     (sb-thread:thread-alive-p thread))
1415    
1416     (defvar *mailbox-lock* (sb-thread:make-mutex :name "mailbox lock"))
1417     (defvar *mailboxes* (list))
1418     (declaim (type list *mailboxes*))
1419    
1420 jsnellman 1.158 (defstruct (mailbox (:conc-name mailbox.))
1421 crhodes 1.136 thread
1422     (mutex (sb-thread:make-mutex))
1423     (waitqueue (sb-thread:make-waitqueue))
1424     (queue '() :type list))
1425    
1426     (defun mailbox (thread)
1427     "Return THREAD's mailbox."
1428     (sb-thread:with-mutex (*mailbox-lock*)
1429     (or (find thread *mailboxes* :key #'mailbox.thread)
1430     (let ((mb (make-mailbox :thread thread)))
1431     (push mb *mailboxes*)
1432     mb))))
1433    
1434     (defimplementation send (thread message)
1435     (let* ((mbox (mailbox thread))
1436     (mutex (mailbox.mutex mbox)))
1437     (sb-thread:with-mutex (mutex)
1438     (setf (mailbox.queue mbox)
1439     (nconc (mailbox.queue mbox) (list message)))
1440     (sb-thread:condition-broadcast (mailbox.waitqueue mbox)))))
1441    
1442 heller 1.212 (defimplementation receive-if (test &optional timeout)
1443 heller 1.209 (let* ((mbox (mailbox (current-thread)))
1444     (mutex (mailbox.mutex mbox)))
1445 heller 1.212 (assert (or (not timeout) (eq timeout t)))
1446 heller 1.207 (loop
1447     (check-slime-interrupts)
1448 heller 1.209 (sb-thread:with-mutex (mutex)
1449 heller 1.202 (let* ((q (mailbox.queue mbox))
1450     (tail (member-if test q)))
1451 heller 1.207 (when tail
1452     (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail)))
1453     (return (car tail))))
1454 heller 1.212 (when (eq timeout t) (return (values nil t)))
1455 heller 1.217 ;; FIXME: with-timeout doesn't work properly on Darwin
1456     #+linux
1457 heller 1.250 (handler-case
1458     (let ((*break-on-signals* nil))
1459     (sb-ext:with-timeout 0.2
1460     (sb-thread:condition-wait (mailbox.waitqueue mbox)
1461     mutex)))
1462 heller 1.217 (sb-ext:timeout ()))
1463     #-linux
1464     (sb-thread:condition-wait (mailbox.waitqueue mbox)
1465     mutex)))))
1466 heller 1.59 )
1467 heller 1.126
1468     (defimplementation quit-lisp ()
1469     #+sb-thread
1470     (dolist (thread (remove (current-thread) (all-threads)))
1471 jsnellman 1.158 (ignore-errors (sb-thread:interrupt-thread
1472 heller 1.133 thread (lambda () (sb-ext:quit :recklessly-p t)))))
1473 heller 1.126 (sb-ext:quit))
1474 heller 1.133
1475 mbaringer 1.117
1476 heller 1.118
1477 mbaringer 1.117 ;;Trace implementations
1478     ;;In SBCL, we have:
1479     ;; (trace <name>)
1480 heller 1.118 ;; (trace :methods '<name>) ;to trace all methods of the gf <name>
1481 mbaringer 1.117 ;; (trace (method <name> <qualifier>? (<specializer>+)))
1482     ;; <name> can be a normal name or a (setf name)
1483    
1484 heller 1.119 (defun toggle-trace-aux (fspec &rest args)
1485 mbaringer 1.117 (cond ((member fspec (eval '(trace)) :test #'equal)
1486     (eval `(untrace ,fspec))
1487     (format nil "~S is now untraced." fspec))
1488     (t
1489     (eval `(trace ,@(if args `(:encapsulate nil) (list)) ,fspec ,@args))
1490     (format nil "~S is now traced." fspec))))
1491    
1492     (defun process-fspec (fspec)
1493     (cond ((consp fspec)
1494     (ecase (first fspec)
1495     ((:defun :defgeneric) (second fspec))
1496     ((:defmethod) `(method ,@(rest fspec)))
1497     ((:labels) `(labels ,(process-fspec (second fspec)) ,(third fspec)))
1498     ((:flet) `(flet ,(process-fspec (second fspec)) ,(third fspec)))))
1499     (t
1500     fspec)))
1501    
1502 heller 1.119 (defimplementation toggle-trace (spec)
1503     (ecase (car spec)
1504 jsnellman 1.158 ((setf)
1505 heller 1.119 (toggle-trace-aux spec))
1506     ((:defmethod)
1507     (toggle-trace-aux `(sb-pcl::fast-method ,@(rest (process-fspec spec)))))
1508     ((:defgeneric)
1509     (toggle-trace-aux (second spec) :methods t))
1510     ((:call)
1511     (destructuring-bind (caller callee) (cdr spec)
1512     (toggle-trace-aux callee :wherein (list (process-fspec caller)))))))
1513 mkoeppe 1.142
1514     ;;; Weak datastructures
1515    
1516 nsiivola 1.170 (defimplementation make-weak-key-hash-table (&rest args)
1517     #+#.(swank-backend::sbcl-with-weak-hash-tables)
1518     (apply #'make-hash-table :weakness :key args)
1519     #-#.(swank-backend::sbcl-with-weak-hash-tables)
1520     (apply #'make-hash-table args))
1521 mkoeppe 1.142
1522 mbaringer 1.169 (defimplementation make-weak-value-hash-table (&rest args)
1523 nsiivola 1.170 #+#.(swank-backend::sbcl-with-weak-hash-tables)
1524     (apply #'make-hash-table :weakness :value args)
1525     #-#.(swank-backend::sbcl-with-weak-hash-tables)
1526     (apply #'make-hash-table args))
1527 alendvai 1.173
1528     (defimplementation hash-table-weakness (hashtable)
1529     #+#.(swank-backend::sbcl-with-weak-hash-tables)
1530     (sb-ext:hash-table-weakness hashtable))
1531 heller 1.214
1532     #-win32
1533     (defimplementation save-image (filename &optional restart-function)
1534     (let ((pid (sb-posix:fork)))
1535     (cond ((= pid 0)
1536     (let ((args `(,filename
1537     ,@(if restart-function
1538     `((:toplevel ,restart-function))))))
1539     (apply #'sb-ext:save-lisp-and-die args)))
1540     (t
1541     (multiple-value-bind (rpid status) (sb-posix:waitpid pid 0)
1542     (assert (= pid rpid))
1543     (assert (and (sb-posix:wifexited status)
1544 trittweiler 1.234 (zerop (sb-posix:wexitstatus status)))))))))

  ViewVC Help
Powered by ViewVC 1.1.5