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

Contents of /slime/swank-cmucl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.45 - (hide annotations)
Mon Jan 12 00:52:25 2004 UTC (10 years, 3 months ago) by lgorrie
Branch: MAIN
Changes since 1.44: +62 -97 lines
(create-socket-server): Generic TCP server driven by SERVE-EVENT.

(serve-one-request, open-stream-to-emacs): Deleted. Now handled
portably in swank.lisp.

(make-fn-streams): Implement new stream-redirection interface.

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

  ViewVC Help
Powered by ViewVC 1.1.5