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

Contents of /slime/swank-cmucl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.44 - (show annotations)
Sat Jan 10 06:45:05 2004 UTC (10 years, 3 months ago) by lgorrie
Branch: MAIN
CVS Tags: SLIME-0-10
Changes since 1.43: +41 -39 lines
Don't enable xref (let the user decide).

(set-fd-non-blocking): Removed unused function.

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

  ViewVC Help
Powered by ViewVC 1.1.5