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

Contents of /slime/swank-cmucl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.53 - (show annotations)
Sat Jan 17 10:23:19 2004 UTC (10 years, 3 months ago) by heller
Branch: MAIN
Changes since 1.52: +4 -3 lines
(arglist-string): Handle zero argument functions correctly.
1 ;;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;+" -*-
2
3 (declaim (optimize debug))
4
5 (in-package :swank)
6
7 (defun without-interrupts* (body)
8 (sys:without-interrupts (funcall body)))
9
10
11 ;;;; TCP server.
12
13 (setq *swank-in-background* :fd-handler)
14
15 (defmethod create-socket (port)
16 (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
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 #+MP (when *multiprocessing-enabled*
32 (mp:process-wait-until-fd-usable socket :input))
33 (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
41 (defmethod remove-input-handlers (socket)
42 (sys:invalidate-descriptor (socket-fd socket))
43 (close socket))
44
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
50 (defmethod spawn (fn &key (name "Anonymous"))
51 (mp:make-process fn :name name))
52
53 ;;;
54 ;;;;; Socket helpers.
55
56 (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
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 (defun make-socket-io-stream (fd)
69 "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 (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
81 ;;;; Stream handling
82
83 (defstruct (slime-output-stream
84 (: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 (buffer (make-string 512) :type string)
93 (index 0 :type kernel:index)
94 (column 0 :type kernel:index))
95
96 (defun %print-slime-output-stream (s stream d)
97 (declare (ignore d))
98 (print-unreadable-object (s stream :type t :identity t)))
99
100 (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 (when (char= #\newline char)
107 (setf (sos.column stream) 0))
108 (when (= index (1- (length buffer)))
109 (force-output stream)))
110 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
116 (defun sos/misc (stream operation &optional arg1 arg2)
117 (declare (ignore arg1 arg2))
118 (case operation
119 ((:force-output :finish-output)
120 (let ((end (sos.index stream)))
121 (unless (zerop end)
122 (funcall (sos.output-fn stream) (subseq (sos.buffer stream) 0 end))
123 (setf (sos.index stream) 0))))
124 (:charpos (sos.column stream))
125 (:line-length 75)
126 (:file-position nil)
127 (:element-type 'base-char)
128 (:get-command nil)
129 (:close nil)
130 (t (format *terminal-io* "~&~Astream: ~S~%" stream operation))))
131
132 (defstruct (slime-input-stream
133 (: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
146 (defun sis/in (stream eof-errorp eof-value)
147 (declare (ignore eof-errorp eof-value))
148 (let ((index (sis.index stream))
149 (buffer (sis.buffer stream)))
150 (when (= index (length buffer))
151 (force-output (sis.sos stream))
152 (setf buffer (funcall (sis.input-fn stream)))
153 (setf (sis.buffer stream) buffer)
154 (setf index 0))
155 (prog1 (aref buffer index)
156 (setf (sis.index stream) (1+ index)))))
157
158 (defun sis/misc (stream operation &optional arg1 arg2)
159 (declare (ignore arg2))
160 (ecase operation
161 (:file-position nil)
162 (: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 (:element-type 'base-char)
173 (:close nil)))
174
175
176 ;;;; Compilation Commands
177
178 (defvar *swank-source-info* nil
179 "Bound to a SOURCE-INFO object during compilation.")
180
181 (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 (defvar *buffer-name* nil)
191 (defvar *buffer-start-position* nil)
192 (defvar *buffer-substring* nil)
193 (defvar *compile-filename* nil)
194
195
196 ;;;;; Trapping notes
197
198 (defun handle-notification-condition (condition)
199 "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 (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 (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
239 (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 (defmethod resolve-note-location (b (f (eql :lisp)) pos path (source string))
265 (make-location
266 `(:source-form ,source)
267 `(:position 1)))
268
269 (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 ;; XXX is this _ever_ used? By what? *compile-file-truename*
282 ;; should be set by the implementation inside any call to compile-file
283 (make-location (list :file *compile-filename*) (list :position 0)))
284 (t
285 (list :error "No error location available"))))
286
287 (defmethod call-with-compilation-hooks (function)
288 (let ((*previous-compiler-condition* nil)
289 (*previous-context* nil)
290 (*print-readably* nil))
291 (handler-bind ((c::compiler-error #'handle-notification-condition)
292 (c::style-warning #'handle-notification-condition)
293 (c::warning #'handle-notification-condition))
294 (funcall function))))
295
296 (defmethod compile-file-for-emacs (filename load-p)
297 (clear-xref-info filename)
298 (with-compilation-hooks ()
299 (let ((*buffer-name* nil)
300 (*compile-filename* filename))
301 (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
307 (defmethod compile-string-for-emacs (string &key buffer position)
308 (with-compilation-hooks ()
309 (let ((*package* *buffer-package*)
310 (*compile-filename* nil)
311 (*buffer-name* buffer)
312 (*buffer-start-position* position)
313 (*buffer-substring* string))
314 (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
321 (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
330 ;;;; XREF
331
332 (defun lookup-xrefs (finder name)
333 (xref-results-for-emacs (funcall finder (from-string name))))
334
335 (defslimefun who-calls (function-name)
336 "Return the places where FUNCTION-NAME is called."
337 (lookup-xrefs #'xref:who-calls function-name))
338
339 (defslimefun who-references (variable)
340 "Return the places where the global variable VARIABLE is referenced."
341 (lookup-xrefs #'xref:who-references variable))
342
343 (defslimefun who-binds (variable)
344 "Return the places where the global variable VARIABLE is bound."
345 (lookup-xrefs #'xref:who-binds variable))
346
347 (defslimefun who-sets (variable)
348 "Return the places where the global variable VARIABLE is set."
349 (lookup-xrefs #'xref:who-sets variable))
350
351 #+cmu19
352 (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
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
384 (defun xref-results-for-emacs (contexts)
385 "Prepare a list of xref contexts for Emacs.
386 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 (let ((name (xref:xref-context-name cxt)))
392 (push (cons (to-string name)
393 (resolve-xref-location cxt))
394 xrefs)))
395 (group-xrefs xrefs)))
396
397 (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 ;;; 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 "Return FUNCTION's callees as a list of functions."
445 (let ((callees '()))
446 (map-code-constants
447 (vm::find-code-object function)
448 (lambda (obj)
449 (when (kernel:fdefn-p obj)
450 (push (kernel:fdefn-function obj) callees))))
451 callees))
452
453 (declaim (ext:maybe-inline map-allocated-code-components))
454 (defun map-allocated-code-components (spaces fn)
455 "Call FN for each allocated code component in one of SPACES. FN
456 receives the object as argument. SPACES should be a list of the
457 symbols :dynamic, :static, or :read-only."
458 (dolist (space spaces)
459 (declare (inline vm::map-allocated-objects))
460 (vm::map-allocated-objects
461 (lambda (obj header size)
462 (declare (type fixnum size) (ignore size))
463 (when (= vm:code-header-type header)
464 (funcall fn obj)))
465 space)))
466
467 (declaim (ext:maybe-inline map-caller-code-components))
468 (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 (declare (inline map-allocated-code-components))
473 (map-allocated-code-components
474 spaces
475 (lambda (obj)
476 (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 "Return FUNCTION's callers. The result is a list of code-objects."
487 (let ((referrers '()))
488 (declare (inline map-caller-code-components))
489 (ext:gc :full t)
490 (map-caller-code-components function spaces
491 (lambda (code) (push code referrers)))
492 referrers))
493
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
523 (defslimefun list-callers (symbol-name)
524 "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
537
538 (defslimefun list-callees (symbol-name)
539 (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
545
546 ;;;; Definitions
547
548 (defvar *debug-definition-finding* nil
549 "When true don't handle errors while looking for definitions.
550 This is useful when debugging the definition-finding code.")
551
552 (defmacro safe-definition-finding (&body body)
553 "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 `(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 (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 (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
580 (defun struct-closure-dd (function)
581 (assert (= (kernel:get-type function) vm:closure-header-type))
582 (flet ((find-layout (function)
583 (sys:find-if-in-closure
584 (lambda (x)
585 (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 function)))
591 (kernel:layout-info (find-layout function))))
592
593 (defun dd-source-location (dd)
594 (let ((constructor (or (kernel:dd-default-constructor dd)
595 (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
604 (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 (pathname (make-location
616 `(:file ,(guess-source-file def-source))
617 `(:function-name ,name)))
618 (cons
619 (destructuring-bind ((dg name) pathname) def-source
620 (declare (ignore dg))
621 (etypecase pathname
622 (pathname
623 (make-location `(:file ,(guess-source-file pathname))
624 `(:function-name ,(string name)))))))))))
625
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 (defun function-source-locations (function)
639 "Return a list of source locations for FUNCTION."
640 ;; 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 (cond ((struct-closure-p function)
649 (list
650 (safe-definition-finding
651 (dd-source-location (struct-closure-dd function)))))
652 ((genericp function)
653 (gf-source-locations function))
654 (t
655 (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
665 (defmethod find-function-locations (symbol-name)
666 "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 (list (list :error (format nil "~A is a special-operator" symbol))))
674 ((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
681 ;;;; Documentation.
682
683 (defmethod describe-symbol-for-emacs (symbol)
684 (let ((result '()))
685 (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 (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 :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 (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 (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 result)))
728
729 (defslimefun describe-setf-function (symbol-name)
730 (print-description-to-string
731 (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 (print-description-to-string
736 (kernel:values-specifier-type (from-string symbol-name))))
737
738 (defslimefun describe-class (symbol-name)
739 (print-description-to-string (find-class (from-string symbol-name) nil)))
740
741 (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 (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 (pcl::arg-info-lambda-list (pcl::gf-arg-info fun)))
786 (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 (etypecase arglist
793 (string arglist)
794 (cons (to-string arglist))
795 (null "()")))))
796
797
798 ;;;; Miscellaneous.
799
800 (defmethod macroexpand-all (form)
801 (walker:macroexpand-all form))
802
803 (in-package :c)
804
805 (defun swank::expand-ir1-top-level (form)
806 "A scaled down version of the first pass of the compiler."
807 (with-compilation-unit ()
808 (let* ((*lexical-environment*
809 (make-lexenv :default (make-null-environment)
810 :cookie *default-cookie*
811 :interface-cookie *default-interface-cookie*))
812 (*source-info* (make-lisp-source-info form))
813 (*block-compile* nil)
814 (*block-compile-default* nil))
815 (with-ir1-namespace
816 (clear-stuff)
817 (find-source-paths form 0)
818 (ir1-top-level form '(0) t)))))
819
820 (in-package :swank)
821
822 (defslimefun print-ir1-converted-blocks (form)
823 (with-output-to-string (*standard-output*)
824 (c::print-all-blocks (expand-ir1-top-level (from-string form)))))
825
826 (defslimefun set-default-directory (directory)
827 (setf (ext:default-directory) (namestring directory))
828 ;; Setting *default-pathname-defaults* to an absolute directory
829 ;; makes the behavior of MERGE-PATHNAMES a bit more intuitive.
830 (setf *default-pathname-defaults* (pathname (ext:default-directory)))
831 (namestring (ext:default-directory)))
832
833 ;;; source-path-{stream,file,string,etc}-position moved into
834 ;;; swank-source-path-parser
835
836 (defun code-location-stream-position (code-location stream)
837 "Return the byte offset of CODE-LOCATION in STREAM. Extract the
838 toplevel-form-number and form-number from CODE-LOCATION and use that
839 to find the position of the corresponding form."
840 (let* ((location (debug::maybe-block-start-location code-location))
841 (tlf-offset (di:code-location-top-level-form-offset location))
842 (form-number (di:code-location-form-number location))
843 (*read-suppress* t))
844 (dotimes (i tlf-offset) (read stream))
845 (multiple-value-bind (tlf position-map) (read-and-record-source-map stream)
846 (let* ((path-table (di:form-number-translations tlf 0))
847 (source-path
848 (if (<= (length path-table) form-number) ; source out of sync?
849 (list 0) ; should probably signal a condition
850 (reverse (cdr (aref path-table form-number))))))
851 (source-path-source-position source-path tlf position-map)))))
852
853 (defun code-location-string-offset (code-location string)
854 (with-input-from-string (s string)
855 (code-location-stream-position code-location s)))
856
857 (defun code-location-file-position (code-location filename)
858 (with-open-file (s filename :direction :input)
859 (code-location-stream-position code-location s)))
860
861 (defun debug-source-info-from-emacs-buffer-p (debug-source)
862 (let ((info (c::debug-source-info debug-source)))
863 (and info
864 (consp info)
865 (eq :emacs-buffer (car info)))))
866
867 (defun source-location-from-code-location (code-location)
868 "Return the source location for CODE-LOCATION."
869 (let ((debug-fun (di:code-location-debug-function code-location)))
870 (when (di::bogus-debug-function-p debug-fun)
871 (error "Bogus debug function: ~A" debug-fun)))
872 (let* ((debug-source (di:code-location-debug-source code-location))
873 (from (di:debug-source-from debug-source))
874 (name (di:debug-source-name debug-source)))
875 (ecase from
876 (:file
877 (make-location (list :file (unix-truename name))
878 (list :position (1+ (code-location-file-position
879 code-location name)))))
880 (:stream
881 (assert (debug-source-info-from-emacs-buffer-p debug-source))
882 (let ((info (c::debug-source-info debug-source)))
883 (make-location
884 (list :buffer (getf info :emacs-buffer))
885 (list :position (+ (getf info :emacs-buffer-offset)
886 (code-location-string-offset
887 code-location
888 (getf info :emacs-buffer-string)))))))
889 (:lisp
890 (make-location
891 (list :source-form (with-output-to-string (*standard-output*)
892 (debug::print-code-location-source-form
893 code-location 100 t)))
894 (list :position 1))))))
895
896 (defun code-location-source-location (code-location)
897 "Safe wrapper around `code-location-from-source-location'."
898 (safe-definition-finding
899 (source-location-from-code-location code-location)))
900
901 (defslimefun getpid ()
902 (unix:unix-getpid))
903
904
905 ;;;; Debugging
906
907 (defvar *sldb-stack-top*)
908 (defvar *sldb-restarts*)
909
910 (defmethod call-with-debugging-environment (debugger-loop-fn)
911 (unix:unix-sigsetmask 0)
912 (let* ((*sldb-stack-top* (or debug:*stack-top-hint* (di:top-frame)))
913 (*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 (*print-length* debug:*debug-print-length*)
919 (*print-readably* nil))
920 (handler-bind ((di:debug-condition
921 (lambda (condition)
922 (signal (make-condition
923 'sldb-condition
924 :original-condition condition)))))
925 (funcall debugger-loop-fn))))
926
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 (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
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 collect (cons i f))))
956
957 (defmethod backtrace (start end)
958 (loop for (n . frame) in (compute-backtrace start end)
959 collect (list n (format-frame-for-emacs n frame))))
960
961 (defmethod debugger-info-for-emacs (start end)
962 (list (debugger-condition-for-emacs)
963 (format-restarts-for-emacs)
964 (backtrace start end)))
965
966 (defmethod frame-source-location-for-emacs (index)
967 (code-location-source-location (di:frame-code-location (nth-frame index))))
968
969 (defmethod eval-in-frame (form index)
970 (di:eval-in-frame (nth-frame index) form))
971
972 (defslimefun pprint-eval-string-in-frame (string index)
973 (swank-pprint
974 (multiple-value-list
975 (di:eval-in-frame (nth-frame index) (from-string string)))))
976
977 (defslimefun inspect-in-frame (string index)
978 (reset-inspector)
979 (inspect-object (di:eval-in-frame (nth-frame index) (from-string string))))
980
981 (defmethod frame-locals (index)
982 (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 (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
995 (defmethod frame-catch-tags (index)
996 (loop for (tag . code-location) in (di:frame-catches (nth-frame index))
997 collect `(,tag . ,(code-location-source-location code-location))))
998
999 (defslimefun invoke-nth-restart (index)
1000 (invoke-restart-interactively (nth-restart index)))
1001
1002 (defslimefun sldb-abort ()
1003 (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name)))
1004
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 (debug::*bad-code-location-types*
1011 (remove :call-site debug::*bad-code-location-types*))
1012 (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 (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 (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 (di:delete-breakpoint breakpoint)
1031 (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
1046 (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 (format t "Frame: ~S~%~:[Real Frame: ~S~%~;~]Frame Pointer: ~S~%"
1055 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 (format t "Instruction pointer: #x~X [pc: ~S kind: ~S]~%~%~%"
1068 ip pc kind)
1069 (if fun
1070 (disassemble fun)
1071 (disassem:disassemble-code-component component))))
1072 (di::bogus-debug-function
1073 (format t "~%[Disassembling bogus frames not implemented]"))))))
1074
1075 ;;;; Inspecting
1076
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 (defmethod describe-primitive-type (object)
1102 (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 (defmethod inspected-parts ((o function))
1132 (let ((header (kernel:get-type o)))
1133 (cond ((= header vm:function-header-type)
1134 (values
1135 (format nil "~A~% is a function." o)
1136 (list (cons "Self" (kernel:%function-self o))
1137 (cons "Next" (kernel:%function-next o))
1138 (cons "Name" (kernel:%function-name o))
1139 (cons "Arglist" (kernel:%function-arglist o))
1140 (cons "Type" (kernel:%function-type o))
1141 (cons "Code Object" (kernel:function-code-header o)))))
1142 ((= header vm:closure-header-type)
1143 (values (format nil "~A~% is a closure." o)
1144 (list*
1145 (cons "Function" (kernel:%closure-function o))
1146 (loop for i from 0 below (- (kernel:get-closure-length o)
1147 (1- vm:closure-info-offset))
1148 collect (cons (format nil "~D" i)
1149 (kernel:%closure-index-ref o i))))))
1150 (t (call-next-method o)))))
1151
1152 (defmethod inspected-parts ((o kernel:code-component))
1153 (values (format nil "~A~% is a code data-block." o)
1154 `(("First entry point" . ,(kernel:%code-entry-points o))
1155 ,@(loop for i from vm:code-constants-offset
1156 below (kernel:get-header-data o)
1157 collect (cons (format nil "Constant#~D" i)
1158 (kernel:code-header-ref o i)))
1159 ("Debug info" . ,(kernel:%code-debug-info o))
1160 ("Instructions" . ,(kernel:code-instructions o)))))
1161
1162 (defmethod inspected-parts ((o kernel:fdefn))
1163 (values (format nil "~A~% is a fdefn object." o)
1164 `(("Name" . ,(kernel:fdefn-name o))
1165 ("Function" . ,(kernel:fdefn-function o)))))
1166
1167
1168 ;;;; Multiprocessing
1169
1170 #+MP
1171 (progn
1172 (defvar *known-processes* '() ; FIXME: leakage. -luke
1173 "List of processes that have been assigned IDs.
1174 The ID is the position in the list.")
1175
1176 (defmethod startup-multiprocessing ()
1177 (setq *swank-in-background* :spawn)
1178 ;; Threads magic: this never returns! But top-level becomes
1179 ;; available again.
1180 (mp::startup-idle-and-top-level-loops))
1181
1182 (defmethod thread-id ()
1183 (mp:without-scheduling
1184 (or (find-thread-id)
1185 (prog1 (length *known-processes*)
1186 (setq *known-processes*
1187 (append *known-processes* (list (mp:current-process))))))))
1188
1189 (defun find-thread-id (&optional (process (mp:current-process)))
1190 (position process *known-processes*))
1191
1192 (defun lookup-thread (thread-id)
1193 (or (nth thread-id *known-processes*)
1194 (error "Unknown Thread-ID: ~S" thread-id)))
1195
1196 (defmethod thread-name (thread-id)
1197 (mp:process-name (lookup-thread thread-id)))
1198
1199 (defmethod make-lock (&key name)
1200 (mp:make-lock name))
1201
1202 (defmethod call-with-lock-held (lock function)
1203 (mp:with-lock-held (lock)
1204 (funcall function)))
1205 )
1206
1207
1208 ;;;; Epilogue
1209 ;;; Local Variables:
1210 ;;; eval: (font-lock-add-keywords 'lisp-mode '(("(\\(defslimefun\\)\\s +\\(\\(\\w\\|\\s_\\)+\\)" (1 font-lock-keyword-face) (2 font-lock-function-name-face))))
1211 ;;; End:

  ViewVC Help
Powered by ViewVC 1.1.5