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

Contents of /slime/swank-cmucl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5