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

Contents of /slime/swank-cmucl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5