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

Contents of /slime/swank-cmucl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.80 - (show annotations)
Tue Mar 9 12:46:27 2004 UTC (10 years, 1 month ago) by heller
Branch: MAIN
Changes since 1.79: +154 -266 lines
Merge package-split branch into main trunk.
1 ;;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;+" -*-
2
3 (declaim (optimize (debug 2)))
4
5 (in-package :swank-backend)
6
7 (in-package :lisp)
8
9 ;; Fix for read-sequence in 18e
10 #+cmu18e
11 (progn
12 (let ((s (find-symbol (string :*enable-package-locked-errors*) :lisp)))
13 (when s
14 (setf (symbol-value s) nil)))
15
16 (defun read-into-simple-string (s stream start end)
17 (declare (type simple-string s))
18 (declare (type stream stream))
19 (declare (type index start end))
20 (unless (subtypep (stream-element-type stream) 'character)
21 (error 'type-error
22 :datum (read-char stream nil #\Null)
23 :expected-type (stream-element-type stream)
24 :format-control "Trying to read characters from a binary stream."))
25 ;; Let's go as low level as it seems reasonable.
26 (let* ((numbytes (- end start))
27 (total-bytes 0))
28 ;; read-n-bytes may return fewer bytes than requested, so we need
29 ;; to keep trying.
30 (loop while (plusp numbytes) do
31 (let ((bytes-read (system:read-n-bytes stream s start numbytes nil)))
32 (when (zerop bytes-read)
33 (return-from read-into-simple-string total-bytes))
34 (incf total-bytes bytes-read)
35 (incf start bytes-read)
36 (decf numbytes bytes-read)))
37 total-bytes))
38
39 (let ((s (find-symbol (string :*enable-package-locked-errors*) :lisp)))
40 (when s
41 (setf (symbol-value s) t)))
42
43 )
44
45 (in-package :swank-backend)
46
47
48 ;;;; TCP server.
49
50 (defimplementation preferred-communication-style ()
51 :sigio)
52
53 (defimplementation create-socket (host port)
54 (ext:create-inet-listener port :stream
55 :reuse-address t
56 :host (resolve-hostname host)))
57
58 (defimplementation local-port (socket)
59 (nth-value 1 (ext::get-socket-host-and-port (socket-fd socket))))
60
61 (defimplementation close-socket (socket)
62 (ext:close-socket (socket-fd socket)))
63
64 (defimplementation accept-connection (socket)
65 #+MP (mp:process-wait-until-fd-usable socket :input)
66 (make-socket-io-stream (ext:accept-tcp-connection socket)))
67
68 (defvar *sigio-handlers* '()
69 "List of (key . (fn . args)) pairs to be called on SIGIO.")
70
71 (defun sigio-handler (signal code scp)
72 (declare (ignore signal code scp))
73 (mapc (lambda (handler) (funcall (cdr handler))) *sigio-handlers*))
74
75 (defun set-sigio-handler ()
76 (sys:enable-interrupt unix:SIGIO (lambda (signal code scp)
77 (sigio-handler signal code scp))))
78
79 (defun fcntl (fd command arg)
80 (multiple-value-bind (ok error) (unix:unix-fcntl fd command arg)
81 (cond (ok)
82 (t (error "fcntl: ~A" (unix:get-unix-error-msg error))))))
83
84 (defimplementation add-sigio-handler (socket fn)
85 (set-sigio-handler)
86 (let ((fd (socket-fd socket)))
87 (format *debug-io* "; Adding input handler: ~S ~%" fd)
88 (fcntl fd unix:f-setown (unix:unix-getpid))
89 (fcntl fd unix:f-setfl unix:FASYNC)
90 (push (cons fd fn) *sigio-handlers*)))
91
92 (defimplementation remove-sigio-handlers (socket)
93 (let ((fd (socket-fd socket)))
94 (setf *sigio-handlers* (delete fd *sigio-handlers* :key #'car))
95 (sys:invalidate-descriptor fd))
96 (close socket))
97
98 (defimplementation add-fd-handler (socket fn)
99 (let ((fd (socket-fd socket)))
100 (format *debug-io* "; Adding fd handler: ~S ~%" fd)
101 (sys:add-fd-handler fd :input (lambda (_)
102 _
103 (funcall fn)))))
104
105 (defimplementation remove-fd-handlers (socket)
106 (sys:invalidate-descriptor (socket-fd socket)))
107
108 (defimplementation make-fn-streams (input-fn output-fn)
109 (let* ((output (make-slime-output-stream output-fn))
110 (input (make-slime-input-stream input-fn output)))
111 (values input output)))
112
113 ;;;;; Socket helpers.
114
115 (defun socket-fd (socket)
116 "Return the filedescriptor for the socket represented by SOCKET."
117 (etypecase socket
118 (fixnum socket)
119 (sys:fd-stream (sys:fd-stream-fd socket))))
120
121 (defun resolve-hostname (hostname)
122 "Return the IP address of HOSTNAME as an integer."
123 (let* ((hostent (ext:lookup-host-entry hostname))
124 (address (car (ext:host-entry-addr-list hostent))))
125 (ext:htonl address)))
126
127 (defun make-socket-io-stream (fd)
128 "Create a new input/output fd-stream for FD."
129 (sys:make-fd-stream fd :input t :output t :element-type 'base-char))
130
131 (defun set-fd-non-blocking (fd)
132 (flet ((fcntl (fd cmd arg)
133 (multiple-value-bind (flags errno) (unix:unix-fcntl fd cmd arg)
134 (or flags
135 (error "fcntl: ~A" (unix:get-unix-error-msg errno))))))
136 (let ((flags (fcntl fd unix:F-GETFL 0)))
137 (fcntl fd unix:F-SETFL (logior flags unix:O_NONBLOCK)))))
138
139
140 ;;;; Unix signals
141
142 (defmethod call-without-interrupts (fn)
143 (sys:without-interrupts (funcall fn)))
144
145 (defimplementation getpid ()
146 (unix:unix-getpid))
147
148 (defimplementation lisp-implementation-type-name ()
149 "cmucl")
150
151
152 ;;;; Stream handling
153
154 (defstruct (slime-output-stream
155 (:include lisp::lisp-stream
156 (lisp::misc #'sos/misc)
157 (lisp::out #'sos/out)
158 (lisp::sout #'sos/sout))
159 (:conc-name sos.)
160 (:print-function %print-slime-output-stream)
161 (:constructor make-slime-output-stream (output-fn)))
162 (output-fn nil :type function)
163 (buffer (make-string 512) :type string)
164 (index 0 :type kernel:index)
165 (column 0 :type kernel:index))
166
167 (defun %print-slime-output-stream (s stream d)
168 (declare (ignore d))
169 (print-unreadable-object (s stream :type t :identity t)))
170
171 (defun sos/out (stream char)
172 (let ((buffer (sos.buffer stream))
173 (index (sos.index stream)))
174 (setf (schar buffer index) char)
175 (setf (sos.index stream) (1+ index))
176 (incf (sos.column stream))
177 (when (char= #\newline char)
178 (setf (sos.column stream) 0))
179 (when (= index (1- (length buffer)))
180 (force-output stream)))
181 char)
182
183 (defun sos/sout (stream string start end)
184 (loop for i from start below end
185 do (sos/out stream (aref string i))))
186
187 (defun sos/misc (stream operation &optional arg1 arg2)
188 (declare (ignore arg1 arg2))
189 (case operation
190 ((:force-output :finish-output)
191 (let ((end (sos.index stream)))
192 (unless (zerop end)
193 (funcall (sos.output-fn stream) (subseq (sos.buffer stream) 0 end))
194 (setf (sos.index stream) 0))))
195 (:charpos (sos.column stream))
196 (:line-length 75)
197 (:file-position nil)
198 (:element-type 'base-char)
199 (:get-command nil)
200 (:close nil)
201 (t (format *terminal-io* "~&~Astream: ~S~%" stream operation))))
202
203 (defstruct (slime-input-stream
204 (:include string-stream
205 (lisp::in #'sis/in)
206 (lisp::misc #'sis/misc))
207 (:conc-name sis.)
208 (:print-function %print-slime-output-stream)
209 (:constructor make-slime-input-stream (input-fn sos)))
210 (input-fn nil :type function)
211 ;; We know our sibling output stream, so that we can force it before
212 ;; requesting input.
213 (sos nil :type slime-output-stream)
214 (buffer "" :type string)
215 (index 0 :type kernel:index))
216
217 (defun sis/in (stream eof-errorp eof-value)
218 (declare (ignore eof-errorp eof-value))
219 (let ((index (sis.index stream))
220 (buffer (sis.buffer stream)))
221 (when (= index (length buffer))
222 (force-output (sis.sos stream))
223 (setf buffer (funcall (sis.input-fn stream)))
224 (setf (sis.buffer stream) buffer)
225 (setf index 0))
226 (prog1 (aref buffer index)
227 (setf (sis.index stream) (1+ index)))))
228
229 (defun sis/misc (stream operation &optional arg1 arg2)
230 (declare (ignore arg2))
231 (ecase operation
232 (:file-position nil)
233 (:file-length nil)
234 (:unread (setf (aref (sis.buffer stream)
235 (decf (sis.index stream)))
236 arg1))
237 (:clear-input
238 (setf (sis.index stream) 0
239 (sis.buffer stream) ""))
240 (:listen (< (sis.index stream) (length (sis.buffer stream))))
241 (:charpos nil)
242 (:line-length nil)
243 (:get-command nil)
244 (:element-type 'base-char)
245 (:close nil)))
246
247
248 ;;;; Compilation Commands
249
250 (defvar *previous-compiler-condition* nil
251 "Used to detect duplicates.")
252
253 (defvar *previous-context* nil
254 "Previous compiler error context.")
255
256 (defvar *buffer-name* nil)
257 (defvar *buffer-start-position* nil)
258 (defvar *buffer-substring* nil)
259
260
261 ;;;;; Trapping notes
262
263 (defun handle-notification-condition (condition)
264 "Handle a condition caused by a compiler warning.
265 This traps all compiler conditions at a lower-level than using
266 C:*COMPILER-NOTIFICATION-FUNCTION*. The advantage is that we get to
267 craft our own error messages, which can omit a lot of redundant
268 information."
269 (unless (eq condition *previous-compiler-condition*)
270 (let ((context (c::find-error-context nil)))
271 (setq *previous-compiler-condition* condition)
272 (setq *previous-context* context)
273 (signal-compiler-condition condition context))))
274
275 (defun signal-compiler-condition (condition context)
276 (signal (make-condition
277 'compiler-condition
278 :original-condition condition
279 :severity (severity-for-emacs condition)
280 :short-message (brief-compiler-message-for-emacs condition)
281 :message (long-compiler-message-for-emacs condition context)
282 :location (compiler-note-location context))))
283
284 (defun severity-for-emacs (condition)
285 "Return the severity of CONDITION."
286 (etypecase condition
287 (c::compiler-error :error)
288 (c::style-warning :note)
289 (c::warning :warning)))
290
291 (defun brief-compiler-message-for-emacs (condition)
292 "Briefly describe a compiler error for Emacs.
293 When Emacs presents the message it already has the source popped up
294 and the source form highlighted. This makes much of the information in
295 the error-context redundant."
296 (princ-to-string condition))
297
298 (defun long-compiler-message-for-emacs (condition error-context)
299 "Describe a compiler error for Emacs including context information."
300 (declare (type (or c::compiler-error-context null) error-context))
301 (multiple-value-bind (enclosing source)
302 (if error-context
303 (values (c::compiler-error-context-enclosing-source error-context)
304 (c::compiler-error-context-source error-context)))
305 (format nil "~@[--> ~{~<~%--> ~1:;~A~> ~}~%~]~@[~{==>~%~A~^~%~}~]~A"
306 enclosing source condition)))
307
308 (defun compiler-note-location (context)
309 (cond (context
310 (resolve-note-location
311 *buffer-name*
312 (c::compiler-error-context-file-name context)
313 (c::compiler-error-context-file-position context)
314 (reverse (c::compiler-error-context-original-source-path context))
315 (c::compiler-error-context-original-source context)))
316 (t
317 (resolve-note-location *buffer-name* nil nil nil nil))))
318
319 (defgeneric resolve-note-location (buffer file-name file-position
320 source-path source))
321
322 (defmethod resolve-note-location ((b (eql nil)) (f pathname) pos path source)
323 (make-location
324 `(:file ,(unix-truename f))
325 `(:position ,(1+ (source-path-file-position path f)))))
326
327 (defmethod resolve-note-location ((b string) (f (eql :stream)) pos path source)
328 (make-location
329 `(:buffer ,b)
330 `(:position ,(+ *buffer-start-position*
331 (source-path-string-position path *buffer-substring*)))))
332
333 (defmethod resolve-note-location (b (f (eql :lisp)) pos path (source string))
334 (make-location
335 `(:source-form ,source)
336 `(:position 1)))
337
338 (defmethod resolve-note-location (buffer
339 (file (eql nil))
340 (pos (eql nil))
341 (path (eql nil))
342 (source (eql nil)))
343 (list :error "No error location available"))
344
345 (defimplementation call-with-compilation-hooks (function)
346 (let ((*previous-compiler-condition* nil)
347 (*previous-context* nil)
348 (*print-readably* nil))
349 (handler-bind ((c::compiler-error #'handle-notification-condition)
350 (c::style-warning #'handle-notification-condition)
351 (c::warning #'handle-notification-condition))
352 (funcall function))))
353
354 (defimplementation swank-compile-file (filename load-p)
355 (clear-xref-info filename)
356 (with-compilation-hooks ()
357 (let ((*buffer-name* nil))
358 (compile-file filename :load load-p))))
359
360 (defimplementation swank-compile-string (string &key buffer position)
361 (with-compilation-hooks ()
362 (let ((*buffer-name* buffer)
363 (*buffer-start-position* position)
364 (*buffer-substring* string))
365 (with-input-from-string (stream string)
366 (ext:compile-from-stream
367 stream
368 :source-info `(:emacs-buffer ,buffer
369 :emacs-buffer-offset ,position
370 :emacs-buffer-string ,string))))))
371
372
373 ;;;; XREF
374
375 (defimplementation who-calls (symbol)
376 (xrefs (xref:who-calls symbol)))
377
378 (defimplementation who-references (symbol)
379 (xrefs (xref:who-references symbol)))
380
381 (defimplementation who-binds (symbol)
382 (xrefs (xref:who-binds symbol)))
383
384 (defimplementation who-sets (symbol)
385 (xrefs (xref:who-sets symbol)))
386
387 #+cmu19
388 (progn
389 (defimplementation who-macroexpands (macro)
390 (xrefs (xref:who-macroexpands macro)))
391 ;; XXX
392 (defimplementation who-specializes (symbol)
393 (let* ((methods (xref::who-specializes (find-class symbol)))
394 (locations (mapcar #'method-source-location methods)))
395 (mapcar #'list methods locations))))
396
397 (defun xrefs (contexts)
398 (mapcar (lambda (xref)
399 (list (xref:xref-context-name xref)
400 (resolve-xref-location xref)))
401 contexts))
402
403 (defun resolve-xref-location (xref)
404 (let ((name (xref:xref-context-name xref))
405 (file (xref:xref-context-file xref))
406 (source-path (xref:xref-context-source-path xref)))
407 (cond ((and file source-path)
408 (let ((position (source-path-file-position source-path file)))
409 (make-location (list :file (unix-truename file))
410 (list :position (1+ position)))))
411 (file
412 (make-location (list :file (unix-truename file))
413 (list :function-name (string name))))
414 (t
415 `(:error ,(format nil "Unkown source location: ~S ~S ~S "
416 name file source-path))))))
417
418 (defun clear-xref-info (namestring)
419 "Clear XREF notes pertaining to NAMESTRING.
420 This is a workaround for a CMUCL bug: XREF records are cumulative."
421 (when c:*record-xref-info*
422 (let ((filename (truename namestring)))
423 (dolist (db (list xref::*who-calls*
424 #+cmu19 xref::*who-is-called*
425 #+cmu19 xref::*who-macroexpands*
426 xref::*who-references*
427 xref::*who-binds*
428 xref::*who-sets*))
429 (maphash (lambda (target contexts)
430 ;; XXX update during traversal?
431 (setf (gethash target db)
432 (delete filename contexts
433 :key #'xref:xref-context-file
434 :test #'equalp)))
435 db)))))
436
437 (defun unix-truename (pathname)
438 (ext:unix-namestring (truename pathname)))
439
440
441 ;;;; Find callers and callees
442
443 ;;; Find callers and callees by looking at the constant pool of
444 ;;; compiled code objects. We assume every fdefn object in the
445 ;;; constant pool corresponds to a call to that function. A better
446 ;;; strategy would be to use the disassembler to find actual
447 ;;; call-sites.
448
449 (declaim (inline map-code-constants))
450 (defun map-code-constants (code fn)
451 "Call FN for each constant in CODE's constant pool."
452 (check-type code kernel:code-component)
453 (loop for i from vm:code-constants-offset below (kernel:get-header-data code)
454 do (funcall fn (kernel:code-header-ref code i))))
455
456 (defun function-callees (function)
457 "Return FUNCTION's callees as a list of functions."
458 (let ((callees '()))
459 (map-code-constants
460 (vm::find-code-object function)
461 (lambda (obj)
462 (when (kernel:fdefn-p obj)
463 (push (kernel:fdefn-function obj) callees))))
464 callees))
465
466 (declaim (ext:maybe-inline map-allocated-code-components))
467 (defun map-allocated-code-components (spaces fn)
468 "Call FN for each allocated code component in one of SPACES. FN
469 receives the object as argument. SPACES should be a list of the
470 symbols :dynamic, :static, or :read-only."
471 (dolist (space spaces)
472 (declare (inline vm::map-allocated-objects))
473 (vm::map-allocated-objects
474 (lambda (obj header size)
475 (declare (type fixnum size) (ignore size))
476 (when (= vm:code-header-type header)
477 (funcall fn obj)))
478 space)))
479
480 (declaim (ext:maybe-inline map-caller-code-components))
481 (defun map-caller-code-components (function spaces fn)
482 "Call FN for each code component with a fdefn for FUNCTION in its
483 constant pool."
484 (let ((function (coerce function 'function)))
485 (declare (inline map-allocated-code-components))
486 (map-allocated-code-components
487 spaces
488 (lambda (obj)
489 (map-code-constants
490 obj
491 (lambda (constant)
492 (when (and (kernel:fdefn-p constant)
493 (eq (kernel:fdefn-function constant)
494 function))
495 (funcall fn obj))))))))
496
497 (defun function-callers (function &optional (spaces '(:read-only :static
498 :dynamic)))
499 "Return FUNCTION's callers. The result is a list of code-objects."
500 (let ((referrers '()))
501 (declare (inline map-caller-code-components))
502 (ext:gc :full t)
503 (map-caller-code-components function spaces
504 (lambda (code) (push code referrers)))
505 referrers))
506
507 (defun debug-info-definitions (debug-info)
508 "Return the defintions for a debug-info. This should only be used
509 for code-object without entry points, i.e., byte compiled
510 code (are theree others?)"
511 ;; This mess has only been tested with #'ext::skip-whitespace, a
512 ;; byte-compiled caller of #'read-char .
513 (check-type debug-info (and (not c::compiled-debug-info) c::debug-info))
514 (let ((name (c::debug-info-name debug-info))
515 (source (c::debug-info-source debug-info)))
516 (destructuring-bind (first) source
517 (ecase (c::debug-source-from first)
518 (:file
519 (list (list name
520 (make-location
521 (list :file (unix-truename (c::debug-source-name first)))
522 (list :function-name name)))))))))
523
524 (defun code-component-entry-points (code)
525 "Return a list ((NAME LOCATION) ...) of function definitons for
526 the code omponent CODE."
527 (delete-duplicates
528 (loop for e = (kernel:%code-entry-points code)
529 then (kernel::%function-next e)
530 while e
531 collect (list (kernel:%function-name e)
532 (function-source-location e)))
533 :test #'equal))
534
535 (defimplementation list-callers (symbol)
536 "Return a list ((NAME LOCATION) ...) of callers."
537 (let ((components (function-callers symbol))
538 (xrefs '()))
539 (dolist (code components)
540 (let* ((entry (kernel:%code-entry-points code))
541 (defs (if entry
542 (code-component-entry-points code)
543 ;; byte compiled stuff
544 (debug-info-definitions
545 (kernel:%code-debug-info code)))))
546 (setq xrefs (nconc defs xrefs))))
547 xrefs))
548
549 (defimplementation list-callees (symbol)
550 (let ((fns (function-callees symbol)))
551 (mapcar (lambda (fn)
552 (list (kernel:%function-name fn)
553 (function-source-location fn)))
554 fns)))
555
556
557 ;;;; Definitions
558
559 (defvar *debug-definition-finding* nil
560 "When true don't handle errors while looking for definitions.
561 This is useful when debugging the definition-finding code.")
562
563 (defmacro safe-definition-finding (&body body)
564 "Execute BODY ignoring errors. Return the source location returned
565 by BODY or if an error occurs a description of the error. The second
566 return value is the condition or nil."
567 `(flet ((body () ,@body))
568 (if *debug-definition-finding*
569 (body)
570 (handler-case (values (progn ,@body) nil)
571 (error (c) (values (list :error (princ-to-string c)) c))))))
572
573 (defun function-first-code-location (function)
574 (and (function-has-debug-function-p function)
575 (di:debug-function-start-location
576 (di:function-debug-function function))))
577
578 (defun function-has-debug-function-p (function)
579 (di:function-debug-function function))
580
581 (defun function-code-object= (closure function)
582 (and (eq (vm::find-code-object closure)
583 (vm::find-code-object function))
584 (not (eq closure function))))
585
586 (defun struct-closure-p (function)
587 (or (function-code-object= function #'kernel::structure-slot-accessor)
588 (function-code-object= function #'kernel::structure-slot-setter)
589 (function-code-object= function #'kernel::%defstruct)))
590
591 (defun struct-closure-dd (function)
592 (assert (= (kernel:get-type function) vm:closure-header-type))
593 (flet ((find-layout (function)
594 (sys:find-if-in-closure
595 (lambda (x)
596 (let ((value (if (di::indirect-value-cell-p x)
597 (c:value-cell-ref x)
598 x)))
599 (when (kernel::layout-p value)
600 (return-from find-layout value))))
601 function)))
602 (kernel:layout-info (find-layout function))))
603
604 (defun dd-source-location (dd)
605 (let ((constructor (or (kernel:dd-default-constructor dd)
606 (car (kernel::dd-constructors dd)))))
607 (when (or (not constructor) (and (consp constructor)
608 (not (car constructor))))
609 (error "Cannot locate struct without constructor: ~S"
610 (kernel::dd-name dd)))
611 (function-source-location
612 (coerce (if (consp constructor) (car constructor) constructor)
613 'function))))
614
615 (defun genericp (fn)
616 (typep fn 'generic-function))
617
618 (defun gf-definition-location (gf)
619 (flet ((guess-source-file (faslfile)
620 (unix-truename
621 (merge-pathnames (make-pathname :type "lisp")
622 faslfile))))
623 (let ((def-source (pcl::definition-source gf))
624 (name (string (pcl:generic-function-name gf))))
625 (etypecase def-source
626 (pathname (make-location
627 `(:file ,(guess-source-file def-source))
628 `(:function-name ,name)))
629 (cons
630 (destructuring-bind ((dg name) pathname) def-source
631 (declare (ignore dg))
632 (etypecase pathname
633 (pathname
634 (make-location `(:file ,(guess-source-file pathname))
635 `(:function-name ,(string name))))
636 (null `(:error ,(format nil "Cannot resolve: ~S" def-source)))
637 )))))))
638
639 (defun method-source-location (method)
640 (function-source-location (or (pcl::method-fast-function method)
641 (pcl:method-function method))))
642
643 (defun gf-method-locations (gf)
644 (let ((ms (pcl::generic-function-methods gf)))
645 (mapcar #'method-source-location ms)))
646
647 (defun gf-source-locations (gf)
648 (list* (gf-definition-location gf)
649 (gf-method-locations gf)))
650
651 (defun function-source-locations (function)
652 "Return a list of source locations for FUNCTION."
653 ;; First test if FUNCTION is a closure created by defstruct; if so
654 ;; extract the defstruct-description (dd) from the closure and find
655 ;; the constructor for the struct. Defstruct creates a defun for
656 ;; the default constructor and we use that as an approximation to
657 ;; the source location of the defstruct.
658 ;;
659 ;; For an ordinary function we return the source location of the
660 ;; first code-location we find.
661 (cond ((struct-closure-p function)
662 (list
663 (safe-definition-finding
664 (dd-source-location (struct-closure-dd function)))))
665 ((genericp function)
666 (gf-source-locations function))
667 (t
668 (list
669 (multiple-value-bind (code-location error)
670 (safe-definition-finding (function-first-code-location function))
671 (cond (error (list :error (princ-to-string error)))
672 (t (code-location-source-location code-location))))))))
673
674 (defun function-source-location (function)
675 (destructuring-bind (first) (function-source-locations function)
676 first))
677
678 (defimplementation find-definitions (symbol)
679 (cond ((macro-function symbol)
680 (mapcar (lambda (loc) `((macro ,symbol) ,loc))
681 (function-source-locations (macro-function symbol))))
682 ((fboundp symbol)
683 ;; XXX fixme
684 (mapcar (lambda (loc) `((function ,symbol) ,loc))
685 (function-source-locations (coerce symbol 'function))))))
686
687 ;;;; Documentation.
688
689 (defimplementation describe-symbol-for-emacs (symbol)
690 (let ((result '()))
691 (flet ((doc (kind)
692 (or (documentation symbol kind) :not-documented))
693 (maybe-push (property value)
694 (when value
695 (setf result (list* property value result)))))
696 (maybe-push
697 :variable (multiple-value-bind (kind recorded-p)
698 (ext:info variable kind symbol)
699 (declare (ignore kind))
700 (if (or (boundp symbol) recorded-p)
701 (doc 'variable))))
702 (maybe-push
703 :generic-function
704 (if (and (fboundp symbol)
705 (typep (fdefinition symbol) 'generic-function))
706 (doc 'function)))
707 (maybe-push
708 :function (if (and (fboundp symbol)
709 (not (typep (fdefinition symbol) 'generic-function)))
710 (doc 'function)))
711 (maybe-push
712 :setf (if (or (ext:info setf inverse symbol)
713 (ext:info setf expander symbol))
714 (doc 'setf)))
715 (maybe-push
716 :type (if (ext:info type kind symbol)
717 (doc 'type)))
718 (maybe-push
719 :class (if (find-class symbol nil)
720 (doc 'class)))
721 (maybe-push
722 :alien-type (if (not (eq (ext:info alien-type kind symbol) :unknown))
723 (doc 'alien-type)))
724 (maybe-push
725 :alien-struct (if (ext:info alien-type struct symbol)
726 (doc nil)))
727 (maybe-push
728 :alien-union (if (ext:info alien-type union symbol)
729 (doc nil)))
730 (maybe-push
731 :alien-enum (if (ext:info alien-type enum symbol)
732 (doc nil)))
733 result)))
734
735 (defimplementation describe-definition (symbol namespace)
736 (ecase namespace
737 (:variable
738 (describe symbol))
739 ((:function :generic-function)
740 (describe (symbol-function symbol)))
741 (:setf
742 (describe (or (ext:info setf inverse symbol))
743 (ext:info setf expander symbol)))
744 (:type
745 (describe (kernel:values-specifier-type symbol)))
746 (:class
747 (describe (find-class symbol)))
748 (:alien-type
749 (ecase (ext:info :alien-type :kind symbol)
750 (:primitive
751 (describe (let ((alien::*values-type-okay* t))
752 (funcall (ext:info :alien-type :translator symbol)
753 (list symbol)))))
754 ((:defined)
755 (describe (ext:info :alien-type :definition symbol)))
756 (:unknown
757 (format nil "Unkown alien type: ~S" symbol))))
758 (:alien-struct
759 (describe (ext:info :alien-type :struct symbol)))
760 (:alien-union
761 (describe (ext:info :alien-type :union symbol)))
762 (:alien-enum
763 (describe (ext:info :alien-type :enum symbol)))))
764
765 (defimplementation arglist (symbol)
766 (let* ((fun (or (macro-function symbol)
767 (symbol-function symbol)))
768 (arglist
769 (cond ((eval:interpreted-function-p fun)
770 (eval:interpreted-function-arglist fun))
771 ((pcl::generic-function-p fun)
772 (pcl:generic-function-lambda-list fun))
773 ((kernel:%function-arglist (kernel:%function-self fun)))
774 ;; this should work both for
775 ;; compiled-debug-function and for
776 ;; interpreted-debug-function
777 (t (let ((df (di::function-debug-function fun)))
778 (if df
779 (di::debug-function-lambda-list df)
780 "(<arglist-unavailable>)"))))))
781 (check-type arglist (or list string))
782 arglist))
783
784
785 ;;;; Miscellaneous.
786
787 (defimplementation macroexpand-all (form)
788 (walker:macroexpand-all form))
789
790 ;; (in-package :c)
791 ;;
792 ;; (defun swank-backend::expand-ir1-top-level (form)
793 ;; "A scaled down version of the first pass of the compiler."
794 ;; (with-compilation-unit ()
795 ;; (let* ((*lexical-environment*
796 ;; (make-lexenv :default (make-null-environment)
797 ;; :cookie *default-cookie*
798 ;; :interface-cookie *default-interface-cookie*))
799 ;; (*source-info* (make-lisp-source-info form))
800 ;; (*block-compile* nil)
801 ;; (*block-compile-default* nil))
802 ;; (with-ir1-namespace
803 ;; (clear-stuff)
804 ;; (find-source-paths form 0)
805 ;; (ir1-top-level form '(0) t)))))
806 ;;
807 ;; (in-package :swank-backend)
808 ;;
809 ;; (defun print-ir1-converted-blocks (form)
810 ;; (with-output-to-string (*standard-output*)
811 ;; (c::print-all-blocks (expand-ir1-top-level (from-string form)))))
812 ;;
813 ;; (defun print-compilation-trace (form)
814 ;; (with-output-to-string (*standard-output*)
815 ;; (with-input-from-string (s form)
816 ;; (ext:compile-from-stream s
817 ;; :verbose t
818 ;; :progress t
819 ;; :trace-stream *standard-output*))))
820
821 (defun set-default-directory (directory)
822 (setf (ext:default-directory) (namestring directory))
823 ;; Setting *default-pathname-defaults* to an absolute directory
824 ;; makes the behavior of MERGE-PATHNAMES a bit more intuitive.
825 (setf *default-pathname-defaults* (pathname (ext:default-directory)))
826 (namestring (ext:default-directory)))
827
828 ;;; source-path-{stream,file,string,etc}-position moved into
829 ;;; swank-source-path-parser
830
831 (defun code-location-stream-position (code-location stream)
832 "Return the byte offset of CODE-LOCATION in STREAM. Extract the
833 toplevel-form-number and form-number from CODE-LOCATION and use that
834 to find the position of the corresponding form."
835 (let* ((location (debug::maybe-block-start-location code-location))
836 (tlf-offset (di:code-location-top-level-form-offset location))
837 (form-number (di:code-location-form-number location))
838 (*read-suppress* t))
839 (dotimes (i tlf-offset) (read stream))
840 (multiple-value-bind (tlf position-map) (read-and-record-source-map stream)
841 (let* ((path-table (di:form-number-translations tlf 0))
842 (source-path
843 (if (<= (length path-table) form-number) ; source out of sync?
844 (list 0) ; should probably signal a condition
845 (reverse (cdr (aref path-table form-number))))))
846 (source-path-source-position source-path tlf position-map)))))
847
848 (defun code-location-string-offset (code-location string)
849 (with-input-from-string (s string)
850 (code-location-stream-position code-location s)))
851
852 (defun code-location-file-position (code-location filename)
853 (with-open-file (s filename :direction :input)
854 (code-location-stream-position code-location s)))
855
856 (defun debug-source-info-from-emacs-buffer-p (debug-source)
857 (let ((info (c::debug-source-info debug-source)))
858 (and info
859 (consp info)
860 (eq :emacs-buffer (car info)))))
861
862 (defun source-location-from-code-location (code-location)
863 "Return the source location for CODE-LOCATION."
864 (let ((debug-fun (di:code-location-debug-function code-location)))
865 (when (di::bogus-debug-function-p debug-fun)
866 (error "Bogus debug function: ~A" debug-fun)))
867 (let* ((debug-source (di:code-location-debug-source code-location))
868 (from (di:debug-source-from debug-source))
869 (name (di:debug-source-name debug-source)))
870 (ecase from
871 (:file
872 (make-location (list :file (unix-truename name))
873 (list :position (1+ (code-location-file-position
874 code-location name)))))
875 (:stream
876 (assert (debug-source-info-from-emacs-buffer-p debug-source))
877 (let ((info (c::debug-source-info debug-source)))
878 (make-location
879 (list :buffer (getf info :emacs-buffer))
880 (list :position (+ (getf info :emacs-buffer-offset)
881 (code-location-string-offset
882 code-location
883 (getf info :emacs-buffer-string)))))))
884 (:lisp
885 (make-location
886 (list :source-form (with-output-to-string (*standard-output*)
887 (debug::print-code-location-source-form
888 code-location 100 t)))
889 (list :position 1))))))
890
891 (defun code-location-source-location (code-location)
892 "Safe wrapper around `code-location-from-source-location'."
893 (safe-definition-finding
894 (source-location-from-code-location code-location)))
895
896
897 ;;;; Debugging
898
899 (defvar *sldb-stack-top*)
900
901 (defimplementation call-with-debugging-environment (debugger-loop-fn)
902 (unix:unix-sigsetmask 0)
903 (let* ((*sldb-stack-top* (or debug:*stack-top-hint* (di:top-frame)))
904 (debug:*stack-top-hint* nil))
905 (handler-bind ((di:debug-condition
906 (lambda (condition)
907 (signal (make-condition
908 'sldb-condition
909 :original-condition condition)))))
910 (funcall debugger-loop-fn))))
911
912 (defun nth-frame (index)
913 (do ((frame *sldb-stack-top* (di:frame-down frame))
914 (i index (1- i)))
915 ((zerop i) frame)))
916
917 (defimplementation compute-backtrace (start end)
918 (let ((end (or end most-positive-fixnum)))
919 (loop for f = (nth-frame start) then (di:frame-down f)
920 for i from start below end
921 while f
922 collect f)))
923
924 (defimplementation print-frame (frame stream)
925 (let ((*standard-output* stream))
926 (debug::print-frame-call frame :verbosity 1 :number nil)))
927
928 (defimplementation frame-source-location-for-emacs (index)
929 (code-location-source-location (di:frame-code-location (nth-frame index))))
930
931 (defimplementation eval-in-frame (form index)
932 (di:eval-in-frame (nth-frame index) form))
933
934 (defimplementation frame-locals (index)
935 (let* ((frame (nth-frame index))
936 (location (di:frame-code-location frame))
937 (debug-function (di:frame-debug-function frame))
938 (debug-variables (di::debug-function-debug-variables debug-function)))
939 (loop for v across debug-variables collect
940 (list :name (di:debug-variable-symbol v)
941 :id (di:debug-variable-id v)
942 :value (ecase (di:debug-variable-validity v location)
943 (:valid
944 (di:debug-variable-value v frame))
945 ((:invalid :unknown)
946 ':not-available))))))
947
948 (defimplementation frame-catch-tags (index)
949 (mapcar #'car (di:frame-catches (nth-frame index))))
950
951 (defun set-step-breakpoints (frame)
952 (when (di:debug-block-elsewhere-p (di:code-location-debug-block
953 (di:frame-code-location frame)))
954 (error "Cannot step, in elsewhere code~%"))
955 (let* ((code-location (di:frame-code-location frame))
956 (debug::*bad-code-location-types*
957 (remove :call-site debug::*bad-code-location-types*))
958 (next (debug::next-code-locations code-location)))
959 (cond (next
960 (let ((steppoints '()))
961 (flet ((hook (frame breakpoint)
962 (let ((debug:*stack-top-hint* frame))
963 (mapc #'di:delete-breakpoint steppoints)
964 (let ((cl (di::breakpoint-what breakpoint)))
965 (break "Breakpoint: ~S ~S"
966 (di:code-location-kind cl)
967 (di::compiled-code-location-pc cl))))))
968 (dolist (code-location next)
969 (let ((bp (di:make-breakpoint #'hook code-location
970 :kind :code-location)))
971 (di:activate-breakpoint bp)
972 (push bp steppoints))))))
973 (t
974 (flet ((hook (frame breakpoint values cookie)
975 (declare (ignore cookie))
976 (di:delete-breakpoint breakpoint)
977 (let ((debug:*stack-top-hint* frame))
978 (break "Function-end: ~A ~A" breakpoint values))))
979 (let* ((debug-function (di:frame-debug-function frame))
980 (bp (di:make-breakpoint #'hook debug-function
981 :kind :function-end)))
982 (di:activate-breakpoint bp)))))))
983
984 ;; (defslimefun sldb-step (frame)
985 ;; (cond ((find-restart 'continue *swank-debugger-condition*)
986 ;; (set-step-breakpoints (nth-frame frame))
987 ;; (continue *swank-debugger-condition*))
988 ;; (t
989 ;; (error "Cannot continue in from condition: ~A"
990 ;; *swank-debugger-condition*))))
991
992 (defun frame-cfp (frame)
993 "Return the Control-Stack-Frame-Pointer for FRAME."
994 (etypecase frame
995 (di::compiled-frame (di::frame-pointer frame))
996 ((or di::interpreted-frame null) -1)))
997
998 (defun frame-ip (frame)
999 "Return the (absolute) instruction pointer and the relative pc of FRAME."
1000 (if (not frame)
1001 -1
1002 (let ((debug-fun (di::frame-debug-function frame)))
1003 (etypecase debug-fun
1004 (di::compiled-debug-function
1005 (let* ((code-loc (di:frame-code-location frame))
1006 (component (di::compiled-debug-function-component debug-fun))
1007 (pc (di::compiled-code-location-pc code-loc))
1008 (ip (sys:without-gcing
1009 (sys:sap-int
1010 (sys:sap+ (kernel:code-instructions component) pc)))))
1011 (values ip pc)))
1012 ((or di::bogus-debug-function di::interpreted-debug-function)
1013 -1)))))
1014
1015 (defun frame-registers (frame)
1016 "Return the lisp registers CSP, CFP, IP, OCFP, LRA for FRAME-NUMBER."
1017 (let* ((cfp (frame-cfp frame))
1018 (csp (frame-cfp (di::frame-up frame)))
1019 (ip (frame-ip frame))
1020 (ocfp (frame-cfp (di::frame-down frame)))
1021 (lra (frame-ip (di::frame-down frame))))
1022 (values csp cfp ip ocfp lra)))
1023
1024 (defun print-frame-registers (frame-number)
1025 (let ((frame (di::frame-real-frame (nth-frame frame-number))))
1026 (flet ((fixnum (p) (etypecase p
1027 (integer p)
1028 (sys:system-area-pointer (sys:sap-int p)))))
1029 (apply #'format t "~
1030 CSP = ~X
1031 CFP = ~X
1032 IP = ~X
1033 OCFP = ~X
1034 LRA = ~X~%" (mapcar #'fixnum
1035 (multiple-value-list (frame-registers frame)))))))
1036
1037 ;; (defslimefun sldb-disassemble (frame-number)
1038 ;; "Return a string with the disassembly of frames code."
1039 ;; (with-output-to-string (*standard-output*)
1040 ;; (print-frame-registers frame-number)
1041 ;; (terpri)
1042 ;; (let* ((frame (di::frame-real-frame (nth-frame frame-number)))
1043 ;; (debug-fun (di::frame-debug-function frame)))
1044 ;; (etypecase debug-fun
1045 ;; (di::compiled-debug-function
1046 ;; (let* ((component (di::compiled-debug-function-component debug-fun))
1047 ;; (fun (di:debug-function-function debug-fun)))
1048 ;; (if fun
1049 ;; (disassemble fun)
1050 ;; (disassem:disassemble-code-component component))))
1051 ;; (di::bogus-debug-function
1052 ;; (format t "~%[Disassembling bogus frames not implemented]"))))))
1053
1054 #+(or)
1055 (defun print-binding-stack ()
1056 (flet ((bsp- (p) (sys:sap+ p (- (* vm:binding-size vm:word-bytes))))
1057 (frob (p offset) (kernel:make-lisp-obj (sys:sap-ref-32 p offset))))
1058 (do ((bsp (bsp- (kernel:binding-stack-pointer-sap)) (bsp- bsp))
1059 (start (sys:int-sap (lisp::binding-stack-start))))
1060 ((sys:sap= bsp start))
1061 (format t "~X: ~S = ~S~%"
1062 (sys:sap-int bsp)
1063 (frob bsp (* vm:binding-symbol-slot vm:word-bytes))
1064 (frob bsp (* vm:binding-value-slot vm:word-bytes))))))
1065
1066 ;; (print-binding-stack)
1067
1068 #+(or)
1069 (defun print-catch-blocks ()
1070 (do ((b (di::descriptor-sap lisp::*current-catch-block*)
1071 (sys:sap-ref-sap b (* vm:catch-block-previous-catch-slot
1072 vm:word-bytes))))
1073 (nil)
1074 (let ((int (sys:sap-int b)))
1075 (when (zerop int) (return))
1076 (flet ((ref (offset) (sys:sap-ref-32 b (* offset vm:word-bytes))))
1077 (let ((uwp (ref vm:catch-block-current-uwp-slot))
1078 (cfp (ref vm:catch-block-current-cont-slot))
1079 (tag (ref vm:catch-block-tag-slot))
1080 )
1081 (format t "~X: uwp = ~8X cfp = ~8X tag = ~X~%"
1082 int uwp cfp (kernel:make-lisp-obj tag)))))))
1083
1084 ;; (print-catch-blocks)
1085
1086 #+(or)
1087 (defun print-unwind-blocks ()
1088 (do ((b (di::descriptor-sap lisp::*current-unwind-protect-block*)
1089 (sys:sap-ref-sap b (* vm:unwind-block-current-uwp-slot
1090 vm:word-bytes))))
1091 (nil)
1092 (let ((int (sys:sap-int b)))
1093 (when (zerop int) (return))
1094 (flet ((ref (offset) (sys:sap-ref-32 b (* offset vm:word-bytes))))
1095 (let ((cfp (ref vm:unwind-block-current-cont-slot)))
1096 (format t "~X: cfp = ~X~%" int cfp))))))
1097
1098 ;; (print-unwind-blocks)
1099
1100
1101 ;;;; Inspecting
1102
1103 (defconstant +lowtag-symbols+
1104 '(vm:even-fixnum-type
1105 vm:function-pointer-type
1106 vm:other-immediate-0-type
1107 vm:list-pointer-type
1108 vm:odd-fixnum-type
1109 vm:instance-pointer-type
1110 vm:other-immediate-1-type
1111 vm:other-pointer-type))
1112
1113 (defconstant +header-type-symbols+
1114 ;; Is there a convinient place for all those constants?
1115 (flet ((tail-comp (string tail)
1116 (and (>= (length string) (length tail))
1117 (string= string tail :start1 (- (length string)
1118 (length tail))))))
1119 (remove-if-not
1120 (lambda (x) (and (tail-comp (symbol-name x) "-TYPE")
1121 (not (member x +lowtag-symbols+))
1122 (boundp x)
1123 (typep (symbol-value x) 'fixnum)))
1124 (append (apropos-list "-TYPE" "VM" t)
1125 (apropos-list "-TYPE" "BIGNUM" t)))))
1126
1127
1128 (defimplementation describe-primitive-type (object)
1129 (with-output-to-string (*standard-output*)
1130 (let* ((lowtag (kernel:get-lowtag object))
1131 (lowtag-symbol (find lowtag +lowtag-symbols+ :key #'symbol-value)))
1132 (format t "lowtag: ~A" lowtag-symbol)
1133 (when (member lowtag (list vm:other-pointer-type
1134 vm:function-pointer-type
1135 vm:other-immediate-0-type
1136 vm:other-immediate-1-type
1137 ))
1138 (let* ((type (kernel:get-type object))
1139 (type-symbol (find type +header-type-symbols+
1140 :key #'symbol-value)))
1141 (format t ", type: ~A" type-symbol))))))
1142
1143 (defimplementation inspected-parts (o)
1144 (cond ((di::indirect-value-cell-p o)
1145 (inspected-parts-of-value-cell o))
1146 (t
1147 (destructuring-bind (text labeledp . parts)
1148 (inspect::describe-parts o)
1149 (let ((parts (if labeledp
1150 (loop for (label . value) in parts
1151 collect (cons (string label) value))
1152 (loop for value in parts
1153 for i from 0
1154 collect (cons (format nil "~D" i) value)))))
1155 (values text parts))))))
1156
1157 (defun inspected-parts-of-value-cell (o)
1158 (values (format nil "~A~% is a value cell." o)
1159 (list (cons "Value" (c:value-cell-ref o)))))
1160
1161 (defmethod inspected-parts ((o function))
1162 (let ((header (kernel:get-type o)))
1163 (cond ((= header vm:function-header-type)
1164 (values
1165 (format nil "~A~% is a function." o)
1166 (list (cons "Self" (kernel:%function-self o))
1167 (cons "Next" (kernel:%function-next o))
1168 (cons "Name" (kernel:%function-name o))
1169 (cons "Arglist" (kernel:%function-arglist o))
1170 (cons "Type" (kernel:%function-type o))
1171 (cons "Code Object" (kernel:function-code-header o)))))
1172 ((= header vm:closure-header-type)
1173 (values (format nil "~A~% is a closure." o)
1174 (list*
1175 (cons "Function" (kernel:%closure-function o))
1176 (loop for i from 0 below (- (kernel:get-closure-length o)
1177 (1- vm:closure-info-offset))
1178 collect (cons (format nil "~D" i)
1179 (kernel:%closure-index-ref o i))))))
1180 (t (call-next-method o)))))
1181
1182 (defmethod inspected-parts ((o kernel:code-component))
1183 (values (format nil "~A~% is a code data-block." o)
1184 `(("First entry point" . ,(kernel:%code-entry-points o))
1185 ,@(loop for i from vm:code-constants-offset
1186 below (kernel:get-header-data o)
1187 collect (cons (format nil "Constant#~D" i)
1188 (kernel:code-header-ref o i)))
1189 ("Debug info" . ,(kernel:%code-debug-info o))
1190 ("Instructions" . ,(kernel:code-instructions o)))))
1191
1192 (defmethod inspected-parts ((o kernel:fdefn))
1193 (values (format nil "~A~% is a fdefn object." o)
1194 `(("Name" . ,(kernel:fdefn-name o))
1195 ("Function" . ,(kernel:fdefn-function o)))))
1196
1197
1198 ;;;; Profiling
1199 (defimplementation profile (fname)
1200 (eval `(profile:profile ,fname)))
1201
1202 (defimplementation unprofile (fname)
1203 (eval `(profile:unprofile ,fname)))
1204
1205 (defimplementation unprofile-all ()
1206 (profile:unprofile)
1207 "All functions unprofiled.")
1208
1209 (defimplementation profile-report ()
1210 (profile:report-time))
1211
1212 (defimplementation profile-reset ()
1213 (profile:reset-time)
1214 "Reset profiling counters.")
1215
1216 (defimplementation profiled-functions ()
1217 profile:*timed-functions*)
1218
1219 (defimplementation profile-package (package callers methods)
1220 (profile:profile-all :package package
1221 :callers-p callers
1222 :methods methods))
1223
1224
1225 ;;;; Multiprocessing
1226
1227 #+MP
1228 (progn
1229 (defimplementation startup-multiprocessing ()
1230 ;; Threads magic: this never returns! But top-level becomes
1231 ;; available again.
1232 (mp::startup-idle-and-top-level-loops))
1233
1234 (defimplementation spawn (fn &key (name "Anonymous"))
1235 (mp:make-process fn :name name))
1236
1237 (defimplementation thread-name (thread)
1238 (mp:process-name thread))
1239
1240 (defimplementation thread-status (thread)
1241 (mp:process-whostate thread))
1242
1243 (defimplementation current-thread ()
1244 mp:*current-process*)
1245
1246 (defimplementation all-threads ()
1247 (copy-list mp:*all-processes*))
1248
1249 (defimplementation interrupt-thread (thread fn)
1250 (mp:process-interrupt thread fn))
1251
1252 (defimplementation kill-thread (thread)
1253 (mp:destroy-process thread))
1254
1255 (defvar *mailbox-lock* (mp:make-lock "mailbox lock"))
1256
1257 (defstruct (mailbox (:conc-name mailbox.))
1258 (mutex (mp:make-lock "process mailbox"))
1259 (queue '() :type list))
1260
1261 (defun mailbox (thread)
1262 "Return THREAD's mailbox."
1263 (mp:with-lock-held (*mailbox-lock*)
1264 (or (getf (mp:process-property-list thread) 'mailbox)
1265 (setf (getf (mp:process-property-list thread) 'mailbox)
1266 (make-mailbox)))))
1267
1268 (defimplementation send (thread message)
1269 (let* ((mbox (mailbox thread))
1270 (mutex (mailbox.mutex mbox)))
1271 (mp:with-lock-held (mutex)
1272 (setf (mailbox.queue mbox)
1273 (nconc (mailbox.queue mbox) (list message))))))
1274
1275 (defimplementation receive ()
1276 (let* ((mbox (mailbox mp:*current-process*))
1277 (mutex (mailbox.mutex mbox)))
1278 (mp:process-wait "receive" #'mailbox.queue mbox)
1279 (mp:with-lock-held (mutex)
1280 (pop (mailbox.queue mbox)))))
1281
1282 )

  ViewVC Help
Powered by ViewVC 1.1.5