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

Contents of /slime/swank-cmucl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5