/local-lisp/slime/swank-cmucl.lisp
Lisp | 2578 lines | 2025 code | 318 blank | 235 comment | 69 complexity | ff4a846397a167fa5dd1d90df48a40dc MD5 | raw file
Possible License(s): GPL-3.0, CC-BY-SA-4.0, GPL-2.0, Unlicense
Large files files are truncated, but you can click here to view the full file
- ;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;+" -*-
- ;;;
- ;;; License: Public Domain
- ;;;
- ;;;; Introduction
- ;;;
- ;;; This is the CMUCL implementation of the `swank-backend' package.
- (in-package :swank-backend)
- (import-swank-mop-symbols :pcl '(:slot-definition-documentation))
- (defun swank-mop:slot-definition-documentation (slot)
- (documentation slot t))
- ;;;; "Hot fixes"
- ;;;
- ;;; Here are necessary bugfixes to the oldest supported version of
- ;;; CMUCL (currently 18e). Any fixes placed here should also be
- ;;; submitted to the `cmucl-imp' mailing list and confirmed as
- ;;; good. When a new release is made that includes the fixes we should
- ;;; promptly delete them from here. It is enough to be compatible with
- ;;; the latest release.
- (in-package :lisp)
- ;;; `READ-SEQUENCE' with large sequences has problems in 18e. This new
- ;;; definition works better.
- #+cmu18
- (progn
- (let ((s (find-symbol (string :*enable-package-locked-errors*) :lisp)))
- (when s
- (setf (symbol-value s) nil)))
- (defun read-into-simple-string (s stream start end)
- (declare (type simple-string s))
- (declare (type stream stream))
- (declare (type index start end))
- (unless (subtypep (stream-element-type stream) 'character)
- (error 'type-error
- :datum (read-char stream nil #\Null)
- :expected-type (stream-element-type stream)
- :format-control "Trying to read characters from a binary stream."))
- ;; Let's go as low level as it seems reasonable.
- (let* ((numbytes (- end start))
- (total-bytes 0))
- ;; read-n-bytes may return fewer bytes than requested, so we need
- ;; to keep trying.
- (loop while (plusp numbytes) do
- (let ((bytes-read (system:read-n-bytes stream s start numbytes nil)))
- (when (zerop bytes-read)
- (return-from read-into-simple-string total-bytes))
- (incf total-bytes bytes-read)
- (incf start bytes-read)
- (decf numbytes bytes-read)))
- total-bytes))
- (let ((s (find-symbol (string :*enable-package-locked-errors*) :lisp)))
- (when s
- (setf (symbol-value s) t)))
- )
- (in-package :swank-backend)
- ;;;; TCP server
- ;;;
- ;;; In CMUCL we support all communication styles. By default we use
- ;;; `:SIGIO' because it is the most responsive, but it's somewhat
- ;;; dangerous: CMUCL is not in general "signal safe", and you don't
- ;;; know for sure what you'll be interrupting. Both `:FD-HANDLER' and
- ;;; `:SPAWN' are reasonable alternatives.
- (defimplementation preferred-communication-style ()
- :sigio)
- #-(or darwin mips)
- (defimplementation create-socket (host port)
- (let* ((addr (resolve-hostname host))
- (addr (if (not (find-symbol "SOCKET-ERROR" :ext))
- (ext:htonl addr)
- addr)))
- (ext:create-inet-listener port :stream :reuse-address t :host addr)))
- ;; There seems to be a bug in create-inet-listener on Mac/OSX and Irix.
- #+(or darwin mips)
- (defimplementation create-socket (host port)
- (declare (ignore host))
- (ext:create-inet-listener port :stream :reuse-address t))
- (defimplementation local-port (socket)
- (nth-value 1 (ext::get-socket-host-and-port (socket-fd socket))))
- (defimplementation close-socket (socket)
- (let ((fd (socket-fd socket)))
- (sys:invalidate-descriptor fd)
- (ext:close-socket fd)))
- (defimplementation accept-connection (socket &key
- external-format buffering timeout)
- (declare (ignore timeout))
- (make-socket-io-stream (ext:accept-tcp-connection socket)
- (or buffering :full)
- (or external-format :iso-8859-1)))
- ;;;;; Sockets
- (defimplementation socket-fd (socket)
- "Return the filedescriptor for the socket represented by SOCKET."
- (etypecase socket
- (fixnum socket)
- (sys:fd-stream (sys:fd-stream-fd socket))))
- (defun resolve-hostname (hostname)
- "Return the IP address of HOSTNAME as an integer (in host byte-order)."
- (let ((hostent (ext:lookup-host-entry hostname)))
- (car (ext:host-entry-addr-list hostent))))
- (defvar *external-format-to-coding-system*
- '((:iso-8859-1
- "latin-1" "latin-1-unix" "iso-latin-1-unix"
- "iso-8859-1" "iso-8859-1-unix")
- #+unicode
- (:utf-8 "utf-8" "utf-8-unix")))
- (defimplementation find-external-format (coding-system)
- (car (rassoc-if (lambda (x) (member coding-system x :test #'equal))
- *external-format-to-coding-system*)))
- (defun make-socket-io-stream (fd buffering external-format)
- "Create a new input/output fd-stream for FD."
- #-unicode(declare (ignore external-format))
- (sys:make-fd-stream fd :input t :output t :element-type 'base-char
- :buffering buffering
- #+unicode :external-format
- #+unicode external-format))
- (defimplementation make-fd-stream (fd external-format)
- (make-socket-io-stream fd :full external-format))
- (defimplementation dup (fd)
- (multiple-value-bind (clone error) (unix:unix-dup fd)
- (unless clone (error "dup failed: ~a" (unix:get-unix-error-msg error)))
- clone))
- (defimplementation command-line-args ()
- ext:*command-line-strings*)
- (defimplementation exec-image (image-file args)
- (multiple-value-bind (ok error)
- (unix:unix-execve (car (command-line-args))
- (list* (car (command-line-args))
- "-core" image-file
- "-noinit"
- args))
- (error "~a" (unix:get-unix-error-msg error))
- ok))
- ;;;;; Signal-driven I/O
- (defimplementation install-sigint-handler (function)
- (sys:enable-interrupt :sigint (lambda (signal code scp)
- (declare (ignore signal code scp))
- (funcall function))))
- (defvar *sigio-handlers* '()
- "List of (key . function) pairs.
- All functions are called on SIGIO, and the key is used for removing
- specific functions.")
- (defun reset-sigio-handlers () (setq *sigio-handlers* '()))
- ;; All file handlers are invalid afer reload.
- (pushnew 'reset-sigio-handlers ext:*after-save-initializations*)
- (defun set-sigio-handler ()
- (sys:enable-interrupt :sigio (lambda (signal code scp)
- (sigio-handler signal code scp))))
- (defun sigio-handler (signal code scp)
- (declare (ignore signal code scp))
- (mapc #'funcall (mapcar #'cdr *sigio-handlers*)))
- (defun fcntl (fd command arg)
- "fcntl(2) - manipulate a file descriptor."
- (multiple-value-bind (ok error) (unix:unix-fcntl fd command arg)
- (cond (ok)
- (t (error "fcntl: ~A" (unix:get-unix-error-msg error))))))
- (defimplementation add-sigio-handler (socket fn)
- (set-sigio-handler)
- (let ((fd (socket-fd socket)))
- (fcntl fd unix:f-setown (unix:unix-getpid))
- (let ((old-flags (fcntl fd unix:f-getfl 0)))
- (fcntl fd unix:f-setfl (logior old-flags unix:fasync)))
- (assert (not (assoc fd *sigio-handlers*)))
- (push (cons fd fn) *sigio-handlers*)))
- (defimplementation remove-sigio-handlers (socket)
- (let ((fd (socket-fd socket)))
- (when (assoc fd *sigio-handlers*)
- (setf *sigio-handlers* (remove fd *sigio-handlers* :key #'car))
- (let ((old-flags (fcntl fd unix:f-getfl 0)))
- (fcntl fd unix:f-setfl (logandc2 old-flags unix:fasync)))
- (sys:invalidate-descriptor fd))
- (assert (not (assoc fd *sigio-handlers*)))
- (when (null *sigio-handlers*)
- (sys:default-interrupt :sigio))))
- ;;;;; SERVE-EVENT
- (defimplementation add-fd-handler (socket fn)
- (let ((fd (socket-fd socket)))
- (sys:add-fd-handler fd :input (lambda (_) _ (funcall fn)))))
- (defimplementation remove-fd-handlers (socket)
- (sys:invalidate-descriptor (socket-fd socket)))
- (defimplementation wait-for-input (streams &optional timeout)
- (assert (member timeout '(nil t)))
- (loop
- (let ((ready (remove-if-not #'listen streams)))
- (when ready (return ready)))
- (when timeout (return nil))
- (multiple-value-bind (in out) (make-pipe)
- (let* ((f (constantly t))
- (handlers (loop for s in (cons in (mapcar #'to-fd-stream streams))
- collect (add-one-shot-handler s f))))
- (unwind-protect
- (let ((*interrupt-queued-handler* (lambda ()
- (write-char #\! out))))
- (when (check-slime-interrupts) (return :interrupt))
- (sys:serve-event))
- (mapc #'sys:remove-fd-handler handlers)
- (close in)
- (close out))))))
- (defun to-fd-stream (stream)
- (etypecase stream
- (sys:fd-stream stream)
- (synonym-stream
- (to-fd-stream
- (symbol-value (synonym-stream-symbol stream))))
- (two-way-stream
- (to-fd-stream (two-way-stream-input-stream stream)))))
-
- (defun add-one-shot-handler (stream function)
- (let (handler)
- (setq handler (sys:add-fd-handler (sys:fd-stream-fd stream) :input
- (lambda (fd)
- (declare (ignore fd))
- (sys:remove-fd-handler handler)
- (funcall function stream))))))
- (defun make-pipe ()
- (multiple-value-bind (in out) (unix:unix-pipe)
- (values (sys:make-fd-stream in :input t :buffering :none)
- (sys:make-fd-stream out :output t :buffering :none))))
- ;;;; Stream handling
- ;;; XXX: How come we don't use Gray streams in CMUCL too? -luke (15/May/2004)
- (defimplementation make-output-stream (write-string)
- (make-slime-output-stream write-string))
- (defimplementation make-input-stream (read-string)
- (make-slime-input-stream read-string))
- (defstruct (slime-output-stream
- (:include lisp::lisp-stream
- (lisp::misc #'sos/misc)
- (lisp::out #'sos/write-char)
- (lisp::sout #'sos/write-string))
- (:conc-name sos.)
- (:print-function %print-slime-output-stream)
- (:constructor make-slime-output-stream (output-fn)))
- (output-fn nil :type function)
- (buffer (make-string 4000) :type string)
- (index 0 :type kernel:index)
- (column 0 :type kernel:index))
- (defun %print-slime-output-stream (s stream d)
- (declare (ignore d))
- (print-unreadable-object (s stream :type t :identity t)))
- (defun sos/write-char (stream char)
- (let ((pending-output nil))
- (system:without-interrupts
- (let ((buffer (sos.buffer stream))
- (index (sos.index stream)))
- (setf (schar buffer index) char)
- (setf (sos.index stream) (1+ index))
- (incf (sos.column stream))
- (when (char= #\newline char)
- (setf (sos.column stream) 0)
- #+(or)(setq pending-output (sos/reset-buffer stream))
- )
- (when (= index (1- (length buffer)))
- (setq pending-output (sos/reset-buffer stream)))))
- (when pending-output
- (funcall (sos.output-fn stream) pending-output)))
- char)
- (defun sos/write-string (stream string start end)
- (loop for i from start below end
- do (sos/write-char stream (aref string i))))
- (defun sos/flush (stream)
- (let ((string (sos/reset-buffer stream)))
- (when string
- (funcall (sos.output-fn stream) string))
- nil))
- (defun sos/reset-buffer (stream)
- (system:without-interrupts
- (let ((end (sos.index stream)))
- (unless (zerop end)
- (prog1 (subseq (sos.buffer stream) 0 end)
- (setf (sos.index stream) 0))))))
- (defun sos/misc (stream operation &optional arg1 arg2)
- (declare (ignore arg1 arg2))
- (case operation
- ((:force-output :finish-output) (sos/flush stream))
- (:charpos (sos.column stream))
- (:line-length 75)
- (:file-position nil)
- (:element-type 'base-char)
- (:get-command nil)
- (:close nil)
- (t (format *terminal-io* "~&~Astream: ~S~%" stream operation))))
- (defstruct (slime-input-stream
- (:include string-stream
- (lisp::in #'sis/in)
- (lisp::misc #'sis/misc))
- (:conc-name sis.)
- (:print-function %print-slime-output-stream)
- (:constructor make-slime-input-stream (input-fn)))
- (input-fn nil :type function)
- (buffer "" :type string)
- (index 0 :type kernel:index))
- (defun sis/in (stream eof-errorp eof-value)
- (let ((index (sis.index stream))
- (buffer (sis.buffer stream)))
- (when (= index (length buffer))
- (let ((string (funcall (sis.input-fn stream))))
- (cond ((zerop (length string))
- (return-from sis/in
- (if eof-errorp
- (error (make-condition 'end-of-file :stream stream))
- eof-value)))
- (t
- (setf buffer string)
- (setf (sis.buffer stream) buffer)
- (setf index 0)))))
- (prog1 (aref buffer index)
- (setf (sis.index stream) (1+ index)))))
- (defun sis/misc (stream operation &optional arg1 arg2)
- (declare (ignore arg2))
- (ecase operation
- (:file-position nil)
- (:file-length nil)
- (:unread (setf (aref (sis.buffer stream)
- (decf (sis.index stream)))
- arg1))
- (:clear-input
- (setf (sis.index stream) 0
- (sis.buffer stream) ""))
- (:listen (< (sis.index stream) (length (sis.buffer stream))))
- (:charpos nil)
- (:line-length nil)
- (:get-command nil)
- (:element-type 'base-char)
- (:close nil)
- (:interactive-p t)))
- ;;;; Compilation Commands
- (defvar *previous-compiler-condition* nil
- "Used to detect duplicates.")
- (defvar *previous-context* nil
- "Previous compiler error context.")
- (defvar *buffer-name* nil
- "The name of the Emacs buffer we are compiling from.
- NIL if we aren't compiling from a buffer.")
- (defvar *buffer-start-position* nil)
- (defvar *buffer-substring* nil)
- (defimplementation call-with-compilation-hooks (function)
- (let ((*previous-compiler-condition* nil)
- (*previous-context* nil)
- (*print-readably* nil))
- (handler-bind ((c::compiler-error #'handle-notification-condition)
- (c::style-warning #'handle-notification-condition)
- (c::warning #'handle-notification-condition))
- (funcall function))))
- (defimplementation swank-compile-file (input-file output-file
- load-p external-format
- &key policy)
- (declare (ignore external-format policy))
- (clear-xref-info input-file)
- (with-compilation-hooks ()
- (let ((*buffer-name* nil)
- (ext:*ignore-extra-close-parentheses* nil))
- (multiple-value-bind (output-file warnings-p failure-p)
- (compile-file input-file :output-file output-file)
- (values output-file warnings-p
- (or failure-p
- (when load-p
- ;; Cache the latest source file for definition-finding.
- (source-cache-get input-file
- (file-write-date input-file))
- (not (load output-file)))))))))
- (defimplementation swank-compile-string (string &key buffer position filename
- policy)
- (declare (ignore filename policy))
- (with-compilation-hooks ()
- (let ((*buffer-name* buffer)
- (*buffer-start-position* position)
- (*buffer-substring* string)
- (source-info (list :emacs-buffer buffer
- :emacs-buffer-offset position
- :emacs-buffer-string string)))
- (with-input-from-string (stream string)
- (let ((failurep (ext:compile-from-stream stream :source-info
- source-info)))
- (not failurep))))))
-
- ;;;;; Trapping notes
- ;;;
- ;;; We intercept conditions from the compiler and resignal them as
- ;;; `SWANK:COMPILER-CONDITION's.
- (defun handle-notification-condition (condition)
- "Handle a condition caused by a compiler warning."
- (unless (eq condition *previous-compiler-condition*)
- (let ((context (c::find-error-context nil)))
- (setq *previous-compiler-condition* condition)
- (setq *previous-context* context)
- (signal-compiler-condition condition context))))
- (defun signal-compiler-condition (condition context)
- (signal (make-condition
- 'compiler-condition
- :original-condition condition
- :severity (severity-for-emacs condition)
- :message (compiler-condition-message condition)
- :source-context (compiler-error-context context)
- :location (if (read-error-p condition)
- (read-error-location condition)
- (compiler-note-location context)))))
- (defun severity-for-emacs (condition)
- "Return the severity of CONDITION."
- (etypecase condition
- ((satisfies read-error-p) :read-error)
- (c::compiler-error :error)
- (c::style-warning :note)
- (c::warning :warning)))
- (defun read-error-p (condition)
- (eq (type-of condition) 'c::compiler-read-error))
- (defun compiler-condition-message (condition)
- "Briefly describe a compiler error for Emacs.
- When Emacs presents the message it already has the source popped up
- and the source form highlighted. This makes much of the information in
- the error-context redundant."
- (princ-to-string condition))
- (defun compiler-error-context (error-context)
- "Describe context information for Emacs."
- (declare (type (or c::compiler-error-context null) error-context))
- (multiple-value-bind (enclosing source)
- (if error-context
- (values (c::compiler-error-context-enclosing-source error-context)
- (c::compiler-error-context-source error-context)))
- (if (or enclosing source)
- (format nil "~@[--> ~{~<~%--> ~1:;~A ~>~}~%~]~
- ~@[==>~{~&~A~}~]"
- enclosing source))))
- (defun read-error-location (condition)
- (let* ((finfo (car (c::source-info-current-file c::*source-info*)))
- (file (c::file-info-name finfo))
- (pos (c::compiler-read-error-position condition)))
- (cond ((and (eq file :stream) *buffer-name*)
- (make-location (list :buffer *buffer-name*)
- (list :offset *buffer-start-position* pos)))
- ((and (pathnamep file) (not *buffer-name*))
- (make-location (list :file (unix-truename file))
- (list :position (1+ pos))))
- (t (break)))))
- (defun compiler-note-location (context)
- "Derive the location of a complier message from its context.
- Return a `location' record, or (:error REASON) on failure."
- (if (null context)
- (note-error-location)
- (with-struct (c::compiler-error-context- file-name
- original-source
- original-source-path) context
- (or (locate-compiler-note file-name original-source
- (reverse original-source-path))
- (note-error-location)))))
- (defun note-error-location ()
- "Pseudo-location for notes that can't be located."
- (cond (*compile-file-truename*
- (make-location (list :file (unix-truename *compile-file-truename*))
- (list :eof)))
- (*buffer-name*
- (make-location (list :buffer *buffer-name*)
- (list :position *buffer-start-position*)))
- (t (list :error "No error location available."))))
- (defun locate-compiler-note (file source source-path)
- (cond ((and (eq file :stream) *buffer-name*)
- ;; Compiling from a buffer
- (make-location (list :buffer *buffer-name*)
- (list :offset *buffer-start-position*
- (source-path-string-position
- source-path *buffer-substring*))))
- ((and (pathnamep file) (null *buffer-name*))
- ;; Compiling from a file
- (make-location (list :file (unix-truename file))
- (list :position (1+ (source-path-file-position
- source-path file)))))
- ((and (eq file :lisp) (stringp source))
- ;; No location known, but we have the source form.
- ;; XXX How is this case triggered? -luke (16/May/2004)
- ;; This can happen if the compiler needs to expand a macro
- ;; but the macro-expander is not yet compiled. Calling the
- ;; (interpreted) macro-expander triggers IR1 conversion of
- ;; the lambda expression for the expander and invokes the
- ;; compiler recursively.
- (make-location (list :source-form source)
- (list :position 1)))))
- (defun unix-truename (pathname)
- (ext:unix-namestring (truename pathname)))
- ;;;; XREF
- ;;;
- ;;; Cross-reference support is based on the standard CMUCL `XREF'
- ;;; package. This package has some caveats: XREF information is
- ;;; recorded during compilation and not preserved in fasl files, and
- ;;; XREF recording is disabled by default. Redefining functions can
- ;;; also cause duplicate references to accumulate, but
- ;;; `swank-compile-file' will automatically clear out any old records
- ;;; from the same filename.
- ;;;
- ;;; To enable XREF recording, set `c:*record-xref-info*' to true. To
- ;;; clear out the XREF database call `xref:init-xref-database'.
- (defmacro defxref (name function)
- `(defimplementation ,name (name)
- (xref-results (,function name))))
- (defxref who-calls xref:who-calls)
- (defxref who-references xref:who-references)
- (defxref who-binds xref:who-binds)
- (defxref who-sets xref:who-sets)
- ;;; More types of XREF information were added since 18e:
- ;;;
- #-cmu18
- (progn
- (defxref who-macroexpands xref:who-macroexpands)
- ;; XXX
- (defimplementation who-specializes (symbol)
- (let* ((methods (xref::who-specializes (find-class symbol)))
- (locations (mapcar #'method-location methods)))
- (mapcar #'list methods locations))))
- (defun xref-results (contexts)
- (mapcar (lambda (xref)
- (list (xref:xref-context-name xref)
- (resolve-xref-location xref)))
- contexts))
- (defun resolve-xref-location (xref)
- (let ((name (xref:xref-context-name xref))
- (file (xref:xref-context-file xref))
- (source-path (xref:xref-context-source-path xref)))
- (cond ((and file source-path)
- (let ((position (source-path-file-position source-path file)))
- (make-location (list :file (unix-truename file))
- (list :position (1+ position)))))
- (file
- (make-location (list :file (unix-truename file))
- (list :function-name (string name))))
- (t
- `(:error ,(format nil "Unknown source location: ~S ~S ~S "
- name file source-path))))))
- (defun clear-xref-info (namestring)
- "Clear XREF notes pertaining to NAMESTRING.
- This is a workaround for a CMUCL bug: XREF records are cumulative."
- (when c:*record-xref-info*
- (let ((filename (truename namestring)))
- (dolist (db (list xref::*who-calls*
- #-cmu18 xref::*who-is-called*
- #-cmu18 xref::*who-macroexpands*
- xref::*who-references*
- xref::*who-binds*
- xref::*who-sets*))
- (maphash (lambda (target contexts)
- ;; XXX update during traversal?
- (setf (gethash target db)
- (delete filename contexts
- :key #'xref:xref-context-file
- :test #'equalp)))
- db)))))
- ;;;; Find callers and callees
- ;;;
- ;;; Find callers and callees by looking at the constant pool of
- ;;; compiled code objects. We assume every fdefn object in the
- ;;; constant pool corresponds to a call to that function. A better
- ;;; strategy would be to use the disassembler to find actual
- ;;; call-sites.
- (labels ((make-stack () (make-array 100 :fill-pointer 0 :adjustable t))
- (map-cpool (code fun)
- (declare (type kernel:code-component code) (type function fun))
- (loop for i from vm:code-constants-offset
- below (kernel:get-header-data code)
- do (funcall fun (kernel:code-header-ref code i))))
- (callees (fun)
- (let ((callees (make-stack)))
- (map-cpool (vm::find-code-object fun)
- (lambda (o)
- (when (kernel:fdefn-p o)
- (vector-push-extend (kernel:fdefn-function o)
- callees))))
- (coerce callees 'list)))
- (callers (fun)
- (declare (function fun))
- (let ((callers (make-stack)))
- (ext:gc :full t)
- ;; scan :dynamic first to avoid the need for even more gcing
- (dolist (space '(:dynamic :read-only :static))
- (vm::map-allocated-objects
- (lambda (obj header size)
- (declare (type fixnum header) (ignore size))
- (when (= vm:code-header-type header)
- (map-cpool obj
- (lambda (c)
- (when (and (kernel:fdefn-p c)
- (eq (kernel:fdefn-function c) fun))
- (vector-push-extend obj callers))))))
- space)
- (ext:gc))
- (coerce callers 'list)))
- (entry-points (code)
- (loop for entry = (kernel:%code-entry-points code)
- then (kernel::%function-next entry)
- while entry
- collect entry))
-
- (guess-main-entry-point (entry-points)
- (or (find-if (lambda (fun)
- (ext:valid-function-name-p
- (kernel:%function-name fun)))
- entry-points)
- (car entry-points)))
- (fun-dspec (fun)
- (list (kernel:%function-name fun) (function-location fun)))
-
- (code-dspec (code)
- (let ((eps (entry-points code))
- (di (kernel:%code-debug-info code)))
- (cond (eps (fun-dspec (guess-main-entry-point eps)))
- (di (list (c::debug-info-name di)
- (debug-info-function-name-location di)))
- (t (list (princ-to-string code)
- `(:error "No src-loc available")))))))
- (declare (inline map-cpool))
- (defimplementation list-callers (symbol)
- (mapcar #'code-dspec (callers (coerce symbol 'function) )))
- (defimplementation list-callees (symbol)
- (mapcar #'fun-dspec (callees symbol))))
- (defun test-list-callers (count)
- (let ((funsyms '()))
- (do-all-symbols (s)
- (when (and (fboundp s)
- (functionp (symbol-function s))
- (not (macro-function s))
- (not (special-operator-p s)))
- (push s funsyms)))
- (let ((len (length funsyms)))
- (dotimes (i count)
- (let ((sym (nth (random len) funsyms)))
- (format t "~s -> ~a~%" sym (mapcar #'car (list-callers sym))))))))
- ;; (test-list-callers 100)
- ;;;; Resolving source locations
- ;;;
- ;;; Our mission here is to "resolve" references to code locations into
- ;;; actual file/buffer names and character positions. The references
- ;;; we work from come out of the compiler's statically-generated debug
- ;;; information, such as `code-location''s and `debug-source''s. For
- ;;; more details, see the "Debugger Programmer's Interface" section of
- ;;; the CMUCL manual.
- ;;;
- ;;; The first step is usually to find the corresponding "source-path"
- ;;; for the location. Once we have the source-path we can pull up the
- ;;; source file and `READ' our way through to the right position. The
- ;;; main source-code groveling work is done in
- ;;; `swank-source-path-parser.lisp'.
- (defvar *debug-definition-finding* nil
- "When true don't handle errors while looking for definitions.
- This is useful when debugging the definition-finding code.")
- (defvar *source-snippet-size* 256
- "Maximum number of characters in a snippet of source code.
- Snippets at the beginning of definitions are used to tell Emacs what
- the definitions looks like, so that it can accurately find them by
- text search.")
- (defmacro safe-definition-finding (&body body)
- "Execute BODY and return the source-location it returns.
- If an error occurs and `*debug-definition-finding*' is false, then
- return an error pseudo-location.
- The second return value is NIL if no error occurs, otherwise it is the
- condition object."
- `(flet ((body () ,@body))
- (if *debug-definition-finding*
- (body)
- (handler-case (values (progn ,@body) nil)
- (error (c) (values `(:error ,(trim-whitespace (princ-to-string c)))
- c))))))
- (defun trim-whitespace (string)
- (string-trim #(#\newline #\space #\tab) string))
- (defun code-location-source-location (code-location)
- "Safe wrapper around `code-location-from-source-location'."
- (safe-definition-finding
- (source-location-from-code-location code-location)))
- (defun source-location-from-code-location (code-location)
- "Return the source location for CODE-LOCATION."
- (let ((debug-fun (di:code-location-debug-function code-location)))
- (when (di::bogus-debug-function-p debug-fun)
- ;; Those lousy cheapskates! They've put in a bogus debug source
- ;; because the code was compiled at a low debug setting.
- (error "Bogus debug function: ~A" debug-fun)))
- (let* ((debug-source (di:code-location-debug-source code-location))
- (from (di:debug-source-from debug-source))
- (name (di:debug-source-name debug-source)))
- (ecase from
- (:file
- (location-in-file name code-location debug-source))
- (:stream
- (location-in-stream code-location debug-source))
- (:lisp
- ;; The location comes from a form passed to `compile'.
- ;; The best we can do is return the form itself for printing.
- (make-location
- (list :source-form (with-output-to-string (*standard-output*)
- (debug::print-code-location-source-form
- code-location 100 t)))
- (list :position 1))))))
- (defun location-in-file (filename code-location debug-source)
- "Resolve the source location for CODE-LOCATION in FILENAME."
- (let* ((code-date (di:debug-source-created debug-source))
- (root-number (di:debug-source-root-number debug-source))
- (source-code (get-source-code filename code-date)))
- (with-input-from-string (s source-code)
- (make-location (list :file (unix-truename filename))
- (list :position (1+ (code-location-stream-position
- code-location s root-number)))
- `(:snippet ,(read-snippet s))))))
- (defun location-in-stream (code-location debug-source)
- "Resolve the source location for a CODE-LOCATION from a stream.
- This only succeeds if the code was compiled from an Emacs buffer."
- (unless (debug-source-info-from-emacs-buffer-p debug-source)
- (error "The code is compiled from a non-SLIME stream."))
- (let* ((info (c::debug-source-info debug-source))
- (string (getf info :emacs-buffer-string))
- (position (code-location-string-offset
- code-location
- string)))
- (make-location
- (list :buffer (getf info :emacs-buffer))
- (list :offset (getf info :emacs-buffer-offset) position)
- (list :snippet (with-input-from-string (s string)
- (file-position s position)
- (read-snippet s))))))
- ;;;;; Function-name locations
- ;;;
- (defun debug-info-function-name-location (debug-info)
- "Return a function-name source-location for DEBUG-INFO.
- Function-name source-locations are a fallback for when precise
- positions aren't available."
- (with-struct (c::debug-info- (fname name) source) debug-info
- (with-struct (c::debug-source- info from name) (car source)
- (ecase from
- (:file
- (make-location (list :file (namestring (truename name)))
- (list :function-name (string fname))))
- (:stream
- (assert (debug-source-info-from-emacs-buffer-p (car source)))
- (make-location (list :buffer (getf info :emacs-buffer))
- (list :function-name (string fname))))
- (:lisp
- (make-location (list :source-form (princ-to-string (aref name 0)))
- (list :position 1)))))))
- (defun debug-source-info-from-emacs-buffer-p (debug-source)
- "Does the `info' slot of DEBUG-SOURCE contain an Emacs buffer location?
- This is true for functions that were compiled directly from buffers."
- (info-from-emacs-buffer-p (c::debug-source-info debug-source)))
- (defun info-from-emacs-buffer-p (info)
- (and info
- (consp info)
- (eq :emacs-buffer (car info))))
- ;;;;; Groveling source-code for positions
- (defun code-location-stream-position (code-location stream root)
- "Return the byte offset of CODE-LOCATION in STREAM. Extract the
- toplevel-form-number and form-number from CODE-LOCATION and use that
- to find the position of the corresponding form.
- Finish with STREAM positioned at the start of the code location."
- (let* ((location (debug::maybe-block-start-location code-location))
- (tlf-offset (- (di:code-location-top-level-form-offset location)
- root))
- (form-number (di:code-location-form-number location)))
- (let ((pos (form-number-stream-position tlf-offset form-number stream)))
- (file-position stream pos)
- pos)))
- (defun form-number-stream-position (tlf-number form-number stream)
- "Return the starting character position of a form in STREAM.
- TLF-NUMBER is the top-level-form number.
- FORM-NUMBER is an index into a source-path table for the TLF."
- (multiple-value-bind (tlf position-map) (read-source-form tlf-number stream)
- (let* ((path-table (di:form-number-translations tlf 0))
- (source-path
- (if (<= (length path-table) form-number) ; source out of sync?
- (list 0) ; should probably signal a condition
- (reverse (cdr (aref path-table form-number))))))
- (source-path-source-position source-path tlf position-map))))
-
- (defun code-location-string-offset (code-location string)
- "Return the byte offset of CODE-LOCATION in STRING.
- See CODE-LOCATION-STREAM-POSITION."
- (with-input-from-string (s string)
- (code-location-stream-position code-location s 0)))
- ;;;; Finding definitions
- ;;; There are a great many different types of definition for us to
- ;;; find. We search for definitions of every kind and return them in a
- ;;; list.
- (defimplementation find-definitions (name)
- (append (function-definitions name)
- (setf-definitions name)
- (variable-definitions name)
- (class-definitions name)
- (type-definitions name)
- (compiler-macro-definitions name)
- (source-transform-definitions name)
- (function-info-definitions name)
- (ir1-translator-definitions name)
- (template-definitions name)
- (primitive-definitions name)
- (vm-support-routine-definitions name)
- ))
- ;;;;; Functions, macros, generic functions, methods
- ;;;
- ;;; We make extensive use of the compile-time debug information that
- ;;; CMUCL records, in particular "debug functions" and "code
- ;;; locations." Refer to the "Debugger Programmer's Interface" section
- ;;; of the CMUCL manual for more details.
- (defun function-definitions (name)
- "Return definitions for NAME in the \"function namespace\", i.e.,
- regular functions, generic functions, methods and macros.
- NAME can any valid function name (e.g, (setf car))."
- (let ((macro? (and (symbolp name) (macro-function name)))
- (function? (and (ext:valid-function-name-p name)
- (ext:info :function :definition name)
- (if (symbolp name) (fboundp name) t))))
- (cond (macro?
- (list `((defmacro ,name)
- ,(function-location (macro-function name)))))
- (function?
- (let ((function (fdefinition name)))
- (if (genericp function)
- (gf-definitions name function)
- (list (list `(function ,name)
- (function-location function)))))))))
- ;;;;;; Ordinary (non-generic/macro/special) functions
- ;;;
- ;;; First we test if FUNCTION is a closure created by defstruct, and
- ;;; if so extract the defstruct-description (`dd') from the closure
- ;;; and find the constructor for the struct. Defstruct creates a
- ;;; defun for the default constructor and we use that as an
- ;;; approximation to the source location of the defstruct.
- ;;;
- ;;; For an ordinary function we return the source location of the
- ;;; first code-location we find.
- ;;;
- (defun function-location (function)
- "Return the source location for FUNCTION."
- (cond ((struct-closure-p function)
- (struct-closure-location function))
- ((c::byte-function-or-closure-p function)
- (byte-function-location function))
- (t
- (compiled-function-location function))))
- (defun compiled-function-location (function)
- "Return the location of a regular compiled function."
- (multiple-value-bind (code-location error)
- (safe-definition-finding (function-first-code-location function))
- (cond (error (list :error (princ-to-string error)))
- (t (code-location-source-location code-location)))))
- (defun function-first-code-location (function)
- "Return the first code-location we can find for FUNCTION."
- (and (function-has-debug-function-p function)
- (di:debug-function-start-location
- (di:function-debug-function function))))
- (defun function-has-debug-function-p (function)
- (di:function-debug-function function))
- (defun function-code-object= (closure function)
- (and (eq (vm::find-code-object closure)
- (vm::find-code-object function))
- (not (eq closure function))))
- (defun byte-function-location (fun)
- "Return the location of the byte-compiled function FUN."
- (etypecase fun
- ((or c::hairy-byte-function c::simple-byte-function)
- (let* ((di (kernel:%code-debug-info (c::byte-function-component fun))))
- (if di
- (debug-info-function-name-location di)
- `(:error
- ,(format nil "Byte-function without debug-info: ~a" fun)))))
- (c::byte-closure
- (byte-function-location (c::byte-closure-function fun)))))
- ;;; Here we deal with structure accessors. Note that `dd' is a
- ;;; "defstruct descriptor" structure in CMUCL. A `dd' describes a
- ;;; `defstruct''d structure.
- (defun struct-closure-p (function)
- "Is FUNCTION a closure created by defstruct?"
- (or (function-code-object= function #'kernel::structure-slot-accessor)
- (function-code-object= function #'kernel::structure-slot-setter)
- (function-code-object= function #'kernel::%defstruct)))
- (defun struct-closure-location (function)
- "Return the location of the structure that FUNCTION belongs to."
- (assert (struct-closure-p function))
- (safe-definition-finding
- (dd-location (struct-closure-dd function))))
- (defun struct-closure-dd (function)
- "Return the defstruct-definition (dd) of FUNCTION."
- (assert (= (kernel:get-type function) vm:closure-header-type))
- (flet ((find-layout (function)
- (sys:find-if-in-closure
- (lambda (x)
- (let ((value (if (di::indirect-value-cell-p x)
- (c:value-cell-ref x)
- x)))
- (when (kernel::layout-p value)
- (return-from find-layout value))))
- function)))
- (kernel:layout-info (find-layout function))))
- (defun dd-location (dd)
- "Return the location of a `defstruct'."
- ;; Find the location in a constructor.
- (function-location (struct-constructor dd)))
- (defun struct-constructor (dd)
- "Return a constructor function from a defstruct definition.
- Signal an error if no constructor can be found."
- (let* ((constructor (or (kernel:dd-default-constructor dd)
- (car (kernel::dd-constructors dd))))
- (sym (if (consp constructor) (car constructor) constructor)))
- (unless sym
- (error "Cannot find structure's constructor: ~S" (kernel::dd-name dd)))
- (coerce sym 'function)))
- ;;;;;; Generic functions and methods
- (defun gf-definitions (name function)
- "Return the definitions of a generic function and its methods."
- (cons (list `(defgeneric ,name) (gf-location function))
- (gf-method-definitions function)))
- (defun gf-location (gf)
- "Return the location of the generic function GF."
- (definition-source-location gf (pcl::generic-function-name gf)))
- (defun gf-method-definitions (gf)
- "Return the locations of all methods of the generic function GF."
- (mapcar #'method-definition (pcl::generic-function-methods gf)))
- (defun method-definition (method)
- (list (method-dspec method)
- (method-location method)))
- (defun method-dspec (method)
- "Return a human-readable \"definition specifier\" for METHOD."
- (let* ((gf (pcl:method-generic-function method))
- (name (pcl:generic-function-name gf))
- (specializers (pcl:method-specializers method))
- (qualifiers (pcl:method-qualifiers method)))
- `(method ,name ,@qualifiers ,(pcl::unparse-specializers specializers))))
- ;; XXX maybe special case setters/getters
- (defun method-location (method)
- (function-location (or (pcl::method-fast-function method)
- (pcl:method-function method))))
- (defun genericp (fn)
- (typep fn 'generic-function))
- ;;;;;; Types and classes
- (defun type-definitions (name)
- "Return `deftype' locations for type NAME."
- (maybe-make-definition (ext:info :type :expander name) 'deftype name))
- (defun maybe-make-definition (function kind name)
- "If FUNCTION is non-nil then return its definition location."
- (if function
- (list (list `(,kind ,name) (function-location function)))))
- (defun class-definitions (name)
- "Return the definition locations for the class called NAME."
- (if (symbolp name)
- (let ((class (kernel::find-class name nil)))
- (etypecase class
- (null '())
- (kernel::structure-class
- (list (list `(defstruct ,name) (dd-location (find-dd name)))))
- #+(or)
- (conditions::condition-class
- (list (list `(define-condition ,name)
- (condition-class-location class))))
- (kernel::standard-class
- (list (list `(defclass ,name)
- (class-location (find-class name)))))
- ((or kernel::built-in-class
- conditions::condition-class
- kernel:funcallable-structure-class)
- (list (list `(kernel::define-type-class ,name)
- `(:error
- ,(format nil "No source info for ~A" name)))))))))
- (defun class-location (class)
- "Return the `defclass' location for CLASS."
- (definition-source-location class (pcl:class-name class)))
- (defun find-dd (name)
- "Find the defstruct-definition by the name of its structure-class."
- (let ((layout (ext:info :type :compiler-layout name)))
- (if layout
- (kernel:layout-info layout))))
- (defun condition-class-location (class)
- (let ((slots (conditions::condition-class-slots class))
- (name (conditions::condition-class-name class)))
- (cond ((null slots)
- `(:error ,(format nil "No location info for condition: ~A" name)))
- (t
- ;; Find the class via one of its slot-reader methods.
- (let* ((slot (first slots))
- (gf (fdefinition
- (first (conditions::condition-slot-readers slot)))))
- (method-location
- (first
- (pcl:compute-applicable-methods-using-classes
- gf (list (find-class name))))))))))
- (defun make-name-in-file-location (file string)
- (multiple-value-bind (filename c)
- (ignore-errors
- (unix-truename (merge-pathnames (make-pathname :type "lisp")
- file)))
- (cond (filename (make-location `(:file ,filename)
- `(:function-name ,(string string))))
- (t (list :error (princ-to-string c))))))
- (defun source-location-form-numbers (location)
- (c::decode-form-numbers (c::form-numbers-form-numbers location)))
- (defun source-location-tlf-number (location)
- (nth-value 0 (source-location-form-numbers location)))
- (defun source-location-form-number (location)
- (nth-value 1 (source-location-form-numbers location)))
- (defun resolve-file-source-location (location)
- (let ((filename (c::file-source-location-pathname location))
- (tlf-number (source-location-tlf-number location))
- (form-number (source-location-form-number location)))
- (with-open-file (s filename)
- (let ((pos (form-number-stream-position tlf-number form-number s)))
- (make-location `(:file ,(unix-truename filename))
- `(:position ,(1+ pos)))))))
- (defun resolve-stream-source-location (location)
- (let ((info (c::stream-source-location-user-info location))
- (tlf-number (source-location-tlf-number location))
- (form-number (source-location-form-number location)))
- ;; XXX duplication in frame-source-location
- (assert (info-from-emacs-buffer-p info))
- (destructuring-bind (&key emacs-buffer emacs-buffer-string
- emacs-buffer-offset) info
- (with-input-from-string (s emacs-buffer-string)
- (let ((pos (form-number-stream-position tlf-number form-number s)))
- (make-location `(:buffer ,emacs-buffer)
- `(:offset ,emacs-buffer-offset ,pos)))))))
- ;; XXX predicates for 18e backward compatibilty. Remove them when
- ;; we're 19a only.
- (defun file-source-location-p (object)
- (when (fboundp 'c::file-source-location-p)
- (c::file-source-location-p object)))
- (defun stream-source-location-p (object)
- (when (fboundp 'c::stream-source-location-p)
- (c::stream-source-location-p object)))
- (defun source-location-p (object)
- (or (file-source-location-p object)
- (stream-source-location-p object)))
- (defun resolve-source-location (location)
- (etypecase location
- ((satisfies file-source-location-p)
- (resolve-file-source-location location))
- ((satisfies stream-source-location-p)
- (resolve-stream-source-location location))))
- (defun definition-source-location (object name)
- (let ((source (pcl::definition-source object)))
- (etypecase source
- (null
- `(:error ,(format nil "No source info for: ~A" object)))
- ((satisfies source-location-p)
- (resolve-source-location source))
- (pathname
- (make-name-in-file-location source name))
- (cons
- (destructuring-bind ((dg name) pathname) source
- (declare (ignore dg))
- (etypecase pathname
- (pathname (make-name-in-file-location pathname (string name)))
- (null `(:error ,(format nil "Cannot resolve: ~S" source)))))))))
- (defun setf-definitions (name)
- (let ((f (or (ext:info :setf :inverse name)
- (ext:info :setf :expander name)
- (and (symbolp name)
- (fboundp `(setf ,name))
- (fdefinition `(setf ,name))))))
- (if f
- `(((setf ,name) ,(function-location (cond ((functionp f) f)
- ((macro-function f))
- ((fdefinition f)))))))))
- (defun variable-location (symbol)
- (multiple-value-bind (location foundp)
- ;; XXX for 18e compatibilty. rewrite this when we drop 18e
- ;; support.
- (ignore-errors (eval `(ext:info :source-location :defvar ',symbol)))
- (if (and foundp location)
- (resolve-source-location location)
- `(:error ,(format nil "No source info for variable ~S" symbol)))))
- (defun variable-definitions (name)
- (if (symbolp name)
- (multiple-value-bind (kind recorded-p) (ext:info :variable :kind name)
- (if recorded-p
- (list (list `(variable ,kind ,name)
- (variable-location name)))))))
- (defun compiler-macro-definitions (symbol)
- (maybe-make-definition (compiler-macro-function symbol)
- 'define-compiler-macro
- symbol))
- (defun source-transform-definitions (name)
- (maybe-make-definition (ext:info :function :source-transform name)
- 'c:def-source-transform
- name))
- (defun function-info-definitions (name)
- (let ((info (ext:info :function :info name)))
- (if info
- (append (loop for transform in (c::function-info-transforms info)
- collect (list `(c:deftransform ,name
- ,(c::type-specifier
- (c::transform-type transform)))
- (function-location (c::transform-function
- transform))))
- (maybe-make-definition (c::function-info-derive-type info)
- 'c::derive-type name)
- (maybe-make-definition (c::function-info-optimizer info)
- 'c::optimizer name)
- (maybe-make-definition (c::function-info-ltn-annotate info)
- 'c::ltn-annotate name)
- (maybe-make-definition (c::function-info-ir2-convert info)
- 'c::ir2-convert name)
- (loop for template in (c::function-info-templates info)
- collect (list `(,(type-of template)
- ,(c::template-name templ…
Large files files are truncated, but you can click here to view the full file