Much maturering of vim configs

1 files changed, 1726 insertions, 0 deletions

diff --git a/vim/bundle/slimv/slime/swank/scl.lisp b/vim/bundle/slimv/slime/swank/scl.lisp
new file mode 100644
index 0000000..7327133
--- /dev/null
+++ b/vim/bundle/slimv/slime/swank/scl.lisp
@@ -0,0 +1,1726 @@
+;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;+" -*-
+;;;
+;;; Scieneer Common Lisp code for SLIME.
+;;;
+;;; This code has been placed in the Public Domain.  All warranties
+;;; are disclaimed.
+;;;
+
+(defpackage swank/scl
+  (:use cl swank/backend swank/source-path-parser swank/source-file-cache))
+
+(in-package swank/scl)
+
+
+
+;;; swank-mop
+
+(import-swank-mop-symbols :clos '(:slot-definition-documentation))
+
+(defun swank-mop:slot-definition-documentation (slot)
+  (documentation slot t))
+
+
+;;;; TCP server
+;;;
+;;; SCL only supports the :spawn communication style.
+;;;
+
+(defimplementation preferred-communication-style ()
+  :spawn)
+
+(defimplementation create-socket (host port &key backlog)
+  (let ((addr (resolve-hostname host)))
+    (ext:create-inet-listener port :stream :host addr :reuse-address t
+                              :backlog (or backlog 5))))
+
+(defimplementation local-port (socket)
+  (nth-value 1 (ext::get-socket-host-and-port (socket-fd socket))))
+
+(defimplementation close-socket (socket)
+  (ext:close-socket (socket-fd socket)))
+
+(defimplementation accept-connection (socket 
+                                      &key external-format buffering timeout)
+  (let ((buffering (or buffering :full))
+        (fd (socket-fd socket)))
+      (loop
+       (let ((ready (sys:wait-until-fd-usable fd :input timeout)))
+         (unless ready
+           (error "Timeout accepting connection on socket: ~S~%" socket)))
+       (let ((new-fd (ignore-errors (ext:accept-tcp-connection fd))))
+         (when new-fd
+           (return (make-socket-io-stream new-fd external-format 
+                                          (ecase buffering
+                                            ((t) :full)
+                                            ((nil) :none)
+                                            (:line :line)))))))))
+
+(defimplementation set-stream-timeout (stream timeout)
+  (check-type timeout (or null real))
+  (if (fboundp 'ext::stream-timeout)
+      (setf (ext::stream-timeout stream) timeout)
+      (setf (slot-value (slot-value stream 'lisp::stream) 'lisp::timeout)
+            timeout)))
+
+;;;;; Sockets
+
+(defun socket-fd (socket)
+  "Return the file descriptor for the socket represented by 'socket."
+  (etypecase socket
+    (fixnum socket)
+    (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")
+    (:utf-8 "utf-8" "utf-8-unix")
+    (:euc-jp "euc-jp" "euc-jp-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 external-format buffering)
+  "Create a new input/output fd-stream for 'fd."
+  (cond ((not external-format)
+         (sys:make-fd-stream fd :input t :output t :buffering buffering
+                             :element-type '(unsigned-byte 8)))
+        (t
+         (let* ((stream (sys:make-fd-stream fd :input t :output t
+                                            :element-type 'base-char
+                                            :buffering buffering
+                                            :external-format external-format)))
+           ;; Ignore character conversion errors.  Without this the
+           ;; communication channel is prone to lockup if a character
+           ;; conversion error occurs.
+           (setf (lisp::character-conversion-stream-input-error-value stream)
+                 #\?)
+           (setf (lisp::character-conversion-stream-output-error-value stream)
+                 #\?)
+           stream))))
+
+
+;;;; Stream handling
+
+(defimplementation gray-package-name ()
+  '#:ext)
+
+
+;;;; 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 policy))
+  (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
+                        :external-format external-format)
+        (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))
+      (with-input-from-string (stream string)
+        (ext:compile-from-stream 
+         stream 
+         :source-info `(:emacs-buffer ,buffer 
+                        :emacs-buffer-offset ,position
+                        :emacs-buffer-string ,string))))))
+
+
+;;;;; 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 'compiler-condition
+          :original-condition condition
+          :severity (severity-for-emacs condition)
+          :message (brief-compiler-message-for-emacs 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 brief-compiler-message-for-emacs (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 a compiler error for Emacs including context information."
+  (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 (and 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)
+      (let ((file (c::compiler-error-context-file-name context))
+            (source (c::compiler-error-context-original-source context))
+            (path
+             (reverse 
+              (c::compiler-error-context-original-source-path context))))
+        (or (locate-compiler-note file source path)
+            (note-error-location)))))
+
+(defun note-error-location ()
+  "Pseudo-location for notes that can't be located."
+  (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)))
+
+
+
+;;; TODO
+(defimplementation who-calls (name) nil)
+(defimplementation who-references (name) nil)
+(defimplementation who-binds (name) nil)
+(defimplementation who-sets (name) nil)
+(defimplementation who-specializes (symbol) nil)
+(defimplementation who-macroexpands (name) nil)
+
+
+;;;; 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.
+
+(declaim (inline map-code-constants))
+(defun map-code-constants (code fn)
+  "Call 'fn for each constant in 'code's constant pool."
+  (check-type code kernel:code-component)
+  (loop for i from vm:code-constants-offset below (kernel:get-header-data code)
+	do (funcall fn (kernel:code-header-ref code i))))
+
+(defun function-callees (function)
+  "Return 'function's callees as a list of functions."
+  (let ((callees '()))
+    (map-code-constants 
+     (vm::find-code-object function)
+     (lambda (obj)
+       (when (kernel:fdefn-p obj)
+	 (push (kernel:fdefn-function obj) callees))))
+    callees))
+
+(declaim (ext:maybe-inline map-allocated-code-components))
+(defun map-allocated-code-components (spaces fn)
+  "Call FN for each allocated code component in one of 'spaces.  FN
+  receives the object as argument.  'spaces should be a list of the
+  symbols :dynamic, :static, or :read-only."
+  (dolist (space spaces)
+    (declare (inline vm::map-allocated-objects)
+             (optimize (ext:inhibit-warnings 3)))
+    (vm::map-allocated-objects
+     (lambda (obj header size)
+       (declare (type fixnum size) (ignore size))
+       (when (= vm:code-header-type header)
+	 (funcall fn obj)))
+     space)))
+
+(declaim (ext:maybe-inline map-caller-code-components))
+(defun map-caller-code-components (function spaces fn)
+  "Call 'fn for each code component with a fdefn for 'function in its
+  constant pool."
+  (let ((function (coerce function 'function)))
+    (declare (inline map-allocated-code-components))
+    (map-allocated-code-components
+     spaces 
+     (lambda (obj)
+       (map-code-constants 
+	obj 
+	(lambda (constant)
+	  (when (and (kernel:fdefn-p constant)
+		     (eq (kernel:fdefn-function constant)
+			 function))
+	    (funcall fn obj))))))))
+
+(defun function-callers (function &optional (spaces '(:read-only :static 
+						      :dynamic)))
+  "Return 'function's callers.  The result is a list of code-objects."
+  (let ((referrers '()))
+    (declare (inline map-caller-code-components))
+    (map-caller-code-components function spaces 
+                                (lambda (code) (push code referrers)))
+    referrers))
+
+(defun debug-info-definitions (debug-info)
+  "Return the defintions for a debug-info.  This should only be used
+  for code-object without entry points, i.e., byte compiled
+  code (are theree others?)"
+  ;; This mess has only been tested with #'ext::skip-whitespace, a
+  ;; byte-compiled caller of #'read-char .
+  (check-type debug-info (and (not c::compiled-debug-info) c::debug-info))
+  (let ((name (c::debug-info-name debug-info))
+        (source (c::debug-info-source debug-info)))
+    (destructuring-bind (first) source 
+      (ecase (c::debug-source-from first)
+        (:file 
+         (list (list name
+                     (make-location 
+                      (list :file (unix-truename (c::debug-source-name first)))
+                      (list :function-name (string name))))))))))
+
+(defun valid-function-name-p (name)
+  (or (symbolp name) (and (consp name)
+                          (eq (car name) 'setf)
+                          (symbolp (cadr name))
+                          (not (cddr name)))))
+
+(defun code-component-entry-points (code)
+  "Return a list ((name location) ...) of function definitons for
+  the code omponent 'code."
+  (let ((names '()))
+    (do ((f (kernel:%code-entry-points code) (kernel::%function-next f)))
+        ((not f))
+      (let ((name (kernel:%function-name f)))
+        (when (valid-function-name-p name)
+          (push (list name (function-location f)) names))))
+    names))
+
+(defimplementation list-callers (symbol)
+  "Return a list ((name location) ...) of callers."
+  (let ((components (function-callers symbol))
+        (xrefs '()))
+    (dolist (code components)
+      (let* ((entry (kernel:%code-entry-points code))
+             (defs (if entry
+                       (code-component-entry-points code)
+                       ;; byte compiled stuff
+                       (debug-info-definitions 
+                        (kernel:%code-debug-info code)))))
+        (setq xrefs (nconc defs xrefs))))
+    xrefs))
+
+(defimplementation list-callees (symbol)
+  (let ((fns (function-callees symbol)))
+    (mapcar (lambda (fn)
+              (list (kernel:%function-name fn)
+                    (function-location fn)))
+            fns)))
+
+
+;;;; 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 SCL 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
+;;; `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.")
+
+(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 (list :error (princ-to-string c)) c))))))
+
+(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))
+         (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)))
+                     `(: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)
+  "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))
+	 (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)))
+
+
+;;;; 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)))
+
+;;;;; Functions, macros, generic functions, methods
+;;;
+;;; We make extensive use of the compile-time debug information that
+;;; SCL records, in particular "debug functions" and "code
+;;; locations." Refer to the "Debugger Programmer's Interface" section
+;;; of the SCL 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)))
+        (special?  (and (symbolp name) (special-operator-p name)))
+        (function? (and (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)))))
+          (special?
+           (list `((:special-operator ,name) 
+                   (:error ,(format nil "Special operator: ~S" name)))))
+          (function?
+           (let ((function (fdefinition name)))
+             (if (genericp function)
+                 (generic-function-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 (fn)
+  "Return the location of the byte-compiled function 'fn."
+  (etypecase fn
+    ((or c::hairy-byte-function c::simple-byte-function)
+     (let* ((component (c::byte-function-component fn))
+            (debug-info (kernel:%code-debug-info component)))
+       (debug-info-function-name-location debug-info)))
+    (c::byte-closure
+     (byte-function-location (c::byte-closure-function fn)))))
+
+;;; Here we deal with structure accessors. Note that `dd' is a
+;;; "defstruct descriptor" structure in SCL. 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)))))
+    (when (or (null constructor)
+              (and (consp constructor) (null (car constructor))))
+      (error "Cannot find structure's constructor: ~S"
+             (kernel::dd-name dd)))
+    (coerce (if (consp constructor) (first constructor) constructor)
+            'function)))
+
+;;;;;; Generic functions and methods
+
+(defun generic-function-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 (clos:generic-function-name gf)))
+
+(defun gf-method-definitions (gf)
+  "Return the locations of all methods of the generic function GF."
+  (mapcar #'method-definition (clos: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 (clos:method-generic-function method))
+         (name (clos:generic-function-name gf))
+         (specializers (clos:method-specializers method))
+         (qualifiers (clos:method-qualifiers method)))
+    `(method ,name ,@qualifiers ,specializers 
+             #+nil (clos::unparse-specializers specializers))))
+
+;; XXX maybe special case setters/getters
+(defun method-location (method)
+  (function-location (clos: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 (find-class name nil)))
+        (etypecase class
+          (null '())
+          (structure-class
+           (list (list `(defstruct ,name)
+                       (dd-location (find-dd name)))))
+          (standard-class
+           (list (list `(defclass ,name) 
+                       (class-location (find-class name)))))
+          ((or built-in-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 (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 ((name (class-name class)))
+    `(:error ,(format nil "No location info for condition: ~A" 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 definition-source-location (object name)
+  `(:error ,(format nil "No source info for: ~A" object)))
+
+(defun setf-definitions (name)
+  (let ((function (or (ext:info :setf :inverse name)
+                      (ext:info :setf :expander name))))
+    (if function
+        (list (list `(setf ,name) 
+                    (function-location (coerce function 'function)))))))
+
+
+(defun variable-location (symbol)
+  `(: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 `(c::vop ,(c::template-name template))
+                                    (function-location 
+                                     (c::vop-info-generator-function 
+                                      template))))))))
+
+(defun ir1-translator-definitions (name)
+  (maybe-make-definition (ext:info :function :ir1-convert name)
+                         'c:def-ir1-translator name))
+
+
+;;;; Documentation.
+
+(defimplementation describe-symbol-for-emacs (symbol)
+  (let ((result '()))
+    (flet ((doc (kind)
+             (or (documentation symbol kind) :not-documented))
+           (maybe-push (property value)
+             (when value
+               (setf result (list* property value result)))))
+      (maybe-push
+       :variable (multiple-value-bind (kind recorded-p)
+		     (ext:info variable kind symbol)
+		   (declare (ignore kind))
+		   (if (or (boundp symbol) recorded-p)
+		       (doc 'variable))))
+      (when (fboundp symbol)
+	(maybe-push
+	 (cond ((macro-function symbol)     :macro)
+	       ((special-operator-p symbol) :special-operator)
+	       ((genericp (fdefinition symbol)) :generic-function)
+	       (t :function))
+	 (doc 'function)))
+      (maybe-push
+       :setf (if (or (ext:info setf inverse symbol)
+		     (ext:info setf expander symbol))
+		 (doc 'setf)))
+      (maybe-push
+       :type (if (ext:info type kind symbol)
+		 (doc 'type)))
+      (maybe-push
+       :class (if (find-class symbol nil) 
+		  (doc 'class)))
+      (maybe-push
+       :alien-type (if (not (eq (ext:info alien-type kind symbol) :unknown))
+		       (doc 'alien-type)))
+      (maybe-push
+       :alien-struct (if (ext:info alien-type struct symbol)
+			 (doc nil)))
+      (maybe-push
+       :alien-union (if (ext:info alien-type union symbol)
+			 (doc nil)))
+      (maybe-push
+       :alien-enum (if (ext:info alien-type enum symbol)
+		       (doc nil)))
+      result)))
+
+(defimplementation describe-definition (symbol namespace)
+  (describe (ecase namespace
+              (:variable
+               symbol)
+              ((:function :generic-function)
+               (symbol-function symbol))
+              (:setf
+               (or (ext:info setf inverse symbol)
+                   (ext:info setf expander symbol)))
+              (:type
+               (kernel:values-specifier-type symbol))
+              (:class
+               (find-class symbol))
+              (:alien-struct
+               (ext:info :alien-type :struct symbol))
+              (:alien-union
+               (ext:info :alien-type :union symbol))
+              (:alien-enum
+               (ext:info :alien-type :enum symbol))
+              (:alien-type
+               (ecase (ext:info :alien-type :kind symbol)
+                 (:primitive
+                  (let ((alien::*values-type-okay* t))
+                    (funcall (ext:info :alien-type :translator symbol) 
+                             (list symbol))))
+                 ((:defined)
+                  (ext:info :alien-type :definition symbol))
+                 (:unknown :unknown))))))
+
+;;;;; Argument lists
+
+(defimplementation arglist (fun)
+  (multiple-value-bind (args winp)
+      (ext:function-arglist fun)
+    (if winp args :not-available)))
+
+(defimplementation function-name (function)
+  (cond ((eval:interpreted-function-p function)
+         (eval:interpreted-function-name function))
+        ((typep function 'generic-function)
+         (clos:generic-function-name function))
+        ((c::byte-function-or-closure-p function)
+         (c::byte-function-name function))
+        (t (kernel:%function-name (kernel:%function-self function)))))
+
+
+;;; A harder case: an approximate arglist is derived from available
+;;; debugging information.
+
+(defun debug-function-arglist (debug-function)
+  "Derive the argument list of DEBUG-FUNCTION from debug info."
+  (let ((args (di::debug-function-lambda-list debug-function))
+        (required '())
+        (optional '())
+        (rest '())
+        (key '()))
+    ;; collect the names of debug-vars
+    (dolist (arg args)
+      (etypecase arg
+        (di::debug-variable 
+         (push (di::debug-variable-symbol arg) required))
+        ((member :deleted)
+         (push ':deleted required))
+        (cons
+         (ecase (car arg)
+           (:keyword 
+            (push (second arg) key))
+           (:optional
+            (push (debug-variable-symbol-or-deleted (second arg)) optional))
+           (:rest 
+            (push (debug-variable-symbol-or-deleted (second arg)) rest))))))
+    ;; intersperse lambda keywords as needed
+    (append (nreverse required)
+            (if optional (cons '&optional (nreverse optional)))
+            (if rest (cons '&rest (nreverse rest)))
+            (if key (cons '&key (nreverse key))))))
+
+(defun debug-variable-symbol-or-deleted (var)
+  (etypecase var
+    (di:debug-variable
+     (di::debug-variable-symbol var))
+    ((member :deleted)
+     '#:deleted)))
+
+(defun symbol-debug-function-arglist (fname)
+  "Return FNAME's debug-function-arglist and %function-arglist.
+  A utility for debugging DEBUG-FUNCTION-ARGLIST."
+  (let ((fn (fdefinition fname)))
+    (values (debug-function-arglist (di::function-debug-function fn))
+            (kernel:%function-arglist (kernel:%function-self fn)))))
+
+
+;;;; Miscellaneous.
+
+(defimplementation macroexpand-all (form &optional env)
+  (declare (ignore env))
+  (macroexpand form))
+
+(defimplementation set-default-directory (directory)
+  (setf (ext:default-directory) (namestring directory))
+  ;; Setting *default-pathname-defaults* to an absolute directory
+  ;; makes the behavior of MERGE-PATHNAMES a bit more intuitive.
+  (setf *default-pathname-defaults* (pathname (ext:default-directory)))
+  (default-directory))
+
+(defimplementation default-directory ()
+  (namestring (ext:default-directory)))
+
+(defimplementation pathname-to-filename (pathname)
+  (ext:unix-namestring pathname nil))
+
+(defimplementation getpid ()
+  (unix:unix-getpid))
+
+(defimplementation lisp-implementation-type-name ()
+  (if (eq ext:*case-mode* :upper) "scl" "scl-lower"))
+
+(defimplementation quit-lisp ()
+  (ext:quit))
+
+;;; source-path-{stream,file,string,etc}-position moved into 
+;;; source-path-parser
+
+
+;;;; Debugging
+
+(defvar *sldb-stack-top*)
+
+(defimplementation call-with-debugging-environment (debugger-loop-fn)
+  (let* ((*sldb-stack-top* (or debug:*stack-top-hint* (di:top-frame)))
+	 (debug:*stack-top-hint* nil)
+         (kernel:*current-level* 0))
+    (handler-bind ((di::unhandled-condition
+		    (lambda (condition)
+                      (error 'sldb-condition
+                             :original-condition condition))))
+      (funcall debugger-loop-fn))))
+
+(defun frame-down (frame)
+  (handler-case (di:frame-down frame)
+    (di:no-debug-info () nil)))
+
+(defun nth-frame (index)
+  (do ((frame *sldb-stack-top* (frame-down frame))
+       (i index (1- i)))
+      ((zerop i) frame)))
+
+(defimplementation compute-backtrace (start end)
+  (let ((end (or end most-positive-fixnum)))
+    (loop for f = (nth-frame start) then (frame-down f)
+	  for i from start below end
+	  while f collect f)))
+
+(defimplementation print-frame (frame stream)
+  (let ((*standard-output* stream))
+    (handler-case 
+        (debug::print-frame-call frame :verbosity 1 :number nil)
+      (error (e)
+        (ignore-errors (princ e stream))))))
+
+(defimplementation frame-source-location (index)
+  (code-location-source-location (di:frame-code-location (nth-frame index))))
+
+(defimplementation eval-in-frame (form index)
+  (di:eval-in-frame (nth-frame index) form))
+
+(defun frame-debug-vars (frame)
+  "Return a vector of debug-variables in frame."
+  (di::debug-function-debug-variables (di:frame-debug-function frame)))
+
+(defun debug-var-value (var frame location)
+  (let ((validity (di:debug-variable-validity var location)))
+    (ecase validity
+      (:valid (di:debug-variable-value var frame))
+      ((:invalid :unknown) (make-symbol (string validity))))))
+
+(defimplementation frame-locals (index)
+  (let* ((frame (nth-frame index))
+	 (loc (di:frame-code-location frame))
+	 (vars (frame-debug-vars frame)))
+    (loop for v across vars collect
+          (list :name (di:debug-variable-symbol v)
+                :id (di:debug-variable-id v)
+                :value (debug-var-value v frame loc)))))
+
+(defimplementation frame-var-value (frame var)
+  (let* ((frame (nth-frame frame))
+         (dvar (aref (frame-debug-vars frame) var)))
+    (debug-var-value dvar frame (di:frame-code-location frame))))
+
+(defimplementation frame-catch-tags (index)
+  (mapcar #'car (di:frame-catches (nth-frame index))))
+
+(defimplementation return-from-frame (index form)
+  (let ((sym (find-symbol (symbol-name '#:find-debug-tag-for-frame)
+                          :debug-internals)))
+    (if sym
+        (let* ((frame (nth-frame index))
+               (probe (funcall sym frame)))
+          (cond (probe (throw (car probe) (eval-in-frame form index)))
+                (t (format nil "Cannot return from frame: ~S" frame))))
+        "return-from-frame is not implemented in this version of SCL.")))
+
+(defimplementation activate-stepping (frame)
+  (set-step-breakpoints (nth-frame frame)))
+
+(defimplementation sldb-break-on-return (frame)
+  (break-on-return (nth-frame frame)))
+
+;;; We set the breakpoint in the caller which might be a bit confusing.
+;;;
+(defun break-on-return (frame)
+  (let* ((caller (di:frame-down frame))
+         (cl (di:frame-code-location caller)))
+    (flet ((hook (frame bp)
+             (when (frame-pointer= frame caller)
+               (di:delete-breakpoint bp)
+               (signal-breakpoint bp frame))))
+      (let* ((info (ecase (di:code-location-kind cl)
+                     ((:single-value-return :unknown-return) nil)
+                     (:known-return (debug-function-returns 
+                                     (di:frame-debug-function frame)))))
+             (bp (di:make-breakpoint #'hook cl :kind :code-location
+                                     :info info)))
+        (di:activate-breakpoint bp)
+        `(:ok ,(format nil "Set breakpoint in ~A" caller))))))
+
+(defun frame-pointer= (frame1 frame2)
+  "Return true if the frame pointers of FRAME1 and FRAME2 are the same."
+  (sys:sap= (di::frame-pointer frame1) (di::frame-pointer frame2)))
+
+;;; The PC in escaped frames at a single-return-value point is
+;;; actually vm:single-value-return-byte-offset bytes after the
+;;; position given in the debug info.  Here we try to recognize such
+;;; cases.
+;;;
+(defun next-code-locations (frame code-location)
+  "Like `debug::next-code-locations' but be careful in escaped frames."
+  (let ((next (debug::next-code-locations code-location)))
+    (flet ((adjust-pc ()
+             (let ((cl (di::copy-compiled-code-location code-location)))
+               (incf (di::compiled-code-location-pc cl) 
+                     vm:single-value-return-byte-offset)
+               cl)))
+      (cond ((and (di::compiled-frame-escaped frame)
+                  (eq (di:code-location-kind code-location)
+                      :single-value-return)
+                  (= (length next) 1)
+                  (di:code-location= (car next) (adjust-pc)))
+             (debug::next-code-locations (car next)))
+            (t
+             next)))))
+
+(defun set-step-breakpoints (frame)
+  (let ((cl (di:frame-code-location frame)))
+    (when (di:debug-block-elsewhere-p (di:code-location-debug-block cl))
+      (error "Cannot step in elsewhere code"))
+    (let* ((debug::*bad-code-location-types*
+            (remove :call-site debug::*bad-code-location-types*))
+           (next (next-code-locations frame cl)))
+      (cond (next
+             (let ((steppoints '()))
+               (flet ((hook (bp-frame bp)
+                        (signal-breakpoint bp bp-frame)
+                        (mapc #'di:delete-breakpoint steppoints)))
+                 (dolist (code-location next)
+                   (let ((bp (di:make-breakpoint #'hook code-location
+                                                 :kind :code-location)))
+                     (di:activate-breakpoint bp)
+                     (push bp steppoints))))))
+            (t
+             (break-on-return frame))))))
+
+
+;; XXX the return values at return breakpoints should be passed to the
+;; user hooks. debug-int.lisp should be changed to do this cleanly.
+
+;;; The sigcontext and the PC for a breakpoint invocation are not
+;;; passed to user hook functions, but we need them to extract return
+;;; values. So we advice di::handle-breakpoint and bind the values to
+;;; special variables.  
+;;;
+(defvar *breakpoint-sigcontext*)
+(defvar *breakpoint-pc*)
+
+(defun sigcontext-object (sc index)
+  "Extract the lisp object in sigcontext SC at offset INDEX."
+  (kernel:make-lisp-obj (vm:ucontext-register sc index)))
+
+(defun known-return-point-values (sigcontext sc-offsets)
+  (let ((fp (system:int-sap (vm:ucontext-register sigcontext
+                                                  vm::cfp-offset))))
+    (system:without-gcing
+     (loop for sc-offset across sc-offsets
+           collect (di::sub-access-debug-var-slot fp sc-offset sigcontext)))))
+
+;;; SCL returns the first few values in registers and the rest on
+;;; the stack. In the multiple value case, the number of values is
+;;; stored in a dedicated register. The values of the registers can be
+;;; accessed in the sigcontext for the breakpoint.  There are 3 kinds
+;;; of return conventions: :single-value-return, :unknown-return, and
+;;; :known-return.
+;;;
+;;; The :single-value-return convention returns the value in a
+;;; register without setting the nargs registers.  
+;;;
+;;; The :unknown-return variant is used for multiple values. A
+;;; :unknown-return point consists actually of 2 breakpoints: one for
+;;; the single value case and one for the general case.  The single
+;;; value breakpoint comes vm:single-value-return-byte-offset after
+;;; the multiple value breakpoint.
+;;;
+;;; The :known-return convention is used by local functions.
+;;; :known-return is currently not supported because we don't know
+;;; where the values are passed.
+;;;
+(defun breakpoint-values (breakpoint)
+  "Return the list of return values for a return point."
+  (flet ((1st (sc) (sigcontext-object sc (car vm::register-arg-offsets))))
+    (let ((sc (locally (declare (optimize (ext:inhibit-warnings 3)))
+                (alien:sap-alien *breakpoint-sigcontext* (* unix:ucontext))))
+          (cl (di:breakpoint-what breakpoint)))
+      (ecase (di:code-location-kind cl)
+        (:single-value-return
+         (list (1st sc)))
+        (:known-return
+         (let ((info (di:breakpoint-info breakpoint)))
+           (if (vectorp info)
+               (known-return-point-values sc info)
+               (progn 
+                 ;;(break)
+                 (list "<<known-return convention not supported>>" info)))))
+        (:unknown-return
+         (let ((mv-return-pc (di::compiled-code-location-pc cl)))
+           (if (= mv-return-pc *breakpoint-pc*)
+               (mv-function-end-breakpoint-values sc)
+               (list (1st sc)))))))))
+
+(defun mv-function-end-breakpoint-values (sigcontext)
+  (let ((sym (find-symbol 
+              (symbol-name '#:function-end-breakpoint-values/standard)
+              :debug-internals)))
+    (cond (sym (funcall sym sigcontext))
+          (t (di::get-function-end-breakpoint-values sigcontext)))))
+
+(defun debug-function-returns (debug-fun)
+  "Return the return style of DEBUG-FUN."
+  (let* ((cdfun (di::compiled-debug-function-compiler-debug-fun debug-fun)))
+    (c::compiled-debug-function-returns cdfun)))
+
+(define-condition breakpoint (simple-condition) 
+  ((message :initarg :message :reader breakpoint.message)
+   (values  :initarg :values  :reader breakpoint.values))
+  (:report (lambda (c stream) (princ (breakpoint.message c) stream))))
+
+#+nil
+(defimplementation condition-extras ((c breakpoint))
+  ;; simply pop up the source buffer
+  `((:short-frame-source 0)))
+
+(defun signal-breakpoint (breakpoint frame)
+  "Signal a breakpoint condition for BREAKPOINT in FRAME.
+Try to create a informative message."
+  (flet ((brk (values fstring &rest args)
+           (let ((msg (apply #'format nil fstring args))
+                 (debug:*stack-top-hint* frame))
+             (break 'breakpoint :message msg :values values))))
+    (with-struct (di::breakpoint- kind what) breakpoint
+      (case kind
+        (:code-location
+         (case (di:code-location-kind what)
+           ((:single-value-return :known-return :unknown-return)
+            (let ((values (breakpoint-values breakpoint)))
+              (brk values "Return value: ~{~S ~}" values)))
+           (t
+            #+(or)
+            (when (eq (di:code-location-kind what) :call-site)
+              (call-site-function breakpoint frame))
+            (brk nil "Breakpoint: ~S ~S" 
+                 (di:code-location-kind what)
+                 (di::compiled-code-location-pc what)))))
+        (:function-start
+         (brk nil "Function start breakpoint"))
+        (t (brk nil "Breakpoint: ~A in ~A" breakpoint frame))))))
+
+#+nil
+(defimplementation sldb-break-at-start (fname)
+  (let ((debug-fun (di:function-debug-function (coerce fname 'function))))
+    (cond ((not debug-fun)
+           `(:error ,(format nil "~S has no debug-function" fname)))
+          (t
+           (flet ((hook (frame bp &optional args cookie)
+                    (declare (ignore args cookie))
+                    (signal-breakpoint bp frame)))
+             (let ((bp (di:make-breakpoint #'hook debug-fun
+                                           :kind :function-start)))
+               (di:activate-breakpoint bp)
+               `(:ok ,(format nil "Set breakpoint in ~S" fname))))))))
+
+(defun frame-cfp (frame)
+  "Return the Control-Stack-Frame-Pointer for FRAME."
+  (etypecase frame
+    (di::compiled-frame (di::frame-pointer frame))
+    ((or di::interpreted-frame null) -1)))
+
+(defun frame-ip (frame)
+  "Return the (absolute) instruction pointer and the relative pc of FRAME."
+  (if (not frame)
+      -1
+      (let ((debug-fun (di::frame-debug-function frame)))
+        (etypecase debug-fun
+          (di::compiled-debug-function 
+           (let* ((code-loc (di:frame-code-location frame))
+                  (component (di::compiled-debug-function-component debug-fun))
+                  (pc (di::compiled-code-location-pc code-loc))
+                  (ip (sys:without-gcing
+                       (sys:sap-int
+                        (sys:sap+ (kernel:code-instructions component) pc)))))
+             (values ip pc)))
+          ((or di::bogus-debug-function di::interpreted-debug-function)
+           -1)))))
+
+(defun frame-registers (frame)
+  "Return the lisp registers CSP, CFP, IP, OCFP, LRA for FRAME-NUMBER."
+  (let* ((cfp (frame-cfp frame))
+         (csp (frame-cfp (di::frame-up frame)))
+         (ip (frame-ip frame))
+         (ocfp (frame-cfp (di::frame-down frame)))
+         (lra (frame-ip (di::frame-down frame))))
+    (values csp cfp ip ocfp lra)))
+
+(defun print-frame-registers (frame-number)
+  (let ((frame (di::frame-real-frame (nth-frame frame-number))))
+    (flet ((fixnum (p) (etypecase p
+                         (integer p)
+                         (sys:system-area-pointer (sys:sap-int p)))))
+      (apply #'format t "~
+CSP  =  ~X
+CFP  =  ~X
+IP   =  ~X
+OCFP =  ~X
+LRA  =  ~X~%" (mapcar #'fixnum 
+                      (multiple-value-list (frame-registers frame)))))))
+
+
+(defimplementation disassemble-frame (frame-number)
+  "Return a string with the disassembly of frames code."
+  (print-frame-registers frame-number)
+  (terpri)
+  (let* ((frame (di::frame-real-frame (nth-frame frame-number)))
+         (debug-fun (di::frame-debug-function frame)))
+    (etypecase debug-fun
+      (di::compiled-debug-function
+       (let* ((component (di::compiled-debug-function-component debug-fun))
+              (fun (di:debug-function-function debug-fun)))
+         (if fun
+             (disassemble fun)
+             (disassem:disassemble-code-component component))))
+      (di::bogus-debug-function
+       (format t "~%[Disassembling bogus frames not implemented]")))))
+
+
+;;;; Inspecting
+
+(defconstant +lowtag-symbols+ 
+  '(vm:even-fixnum-type
+    vm:instance-pointer-type
+    vm:other-immediate-0-type
+    vm:list-pointer-type
+    vm:odd-fixnum-type
+    vm:function-pointer-type
+    vm:other-immediate-1-type
+    vm:other-pointer-type)
+  "Names of the constants that specify type tags.
+The `symbol-value' of each element is a type tag.")
+
+(defconstant +header-type-symbols+
+  (labels ((suffixp (suffix string)
+             (and (>= (length string) (length suffix))
+                  (string= string suffix :start1 (- (length string) 
+                                                    (length suffix)))))
+           (header-type-symbol-p (x)
+             (and (suffixp (symbol-name '#:-type) (symbol-name x))
+                  (not (member x +lowtag-symbols+))
+                  (boundp x)
+                  (typep (symbol-value x) 'fixnum))))
+    (remove-if-not #'header-type-symbol-p
+                   (append (apropos-list (symbol-name '#:-type) :vm)
+                           (apropos-list (symbol-name '#:-type) :bignum))))
+  "A list of names of the type codes in boxed objects.")
+
+(defimplementation describe-primitive-type (object)
+  (with-output-to-string (*standard-output*)
+    (let* ((lowtag (kernel:get-lowtag object))
+	   (lowtag-symbol (find lowtag +lowtag-symbols+ :key #'symbol-value)))
+      (format t "lowtag: ~A" lowtag-symbol)
+      (when (member lowtag (list vm:other-pointer-type
+                                 vm:function-pointer-type
+                                 vm:other-immediate-0-type
+                                 vm:other-immediate-1-type
+                                 ))
+        (let* ((type (kernel:get-type object))
+               (type-symbol (find type +header-type-symbols+
+                                  :key #'symbol-value)))
+          (format t ", type: ~A" type-symbol))))))
+
+(defmethod emacs-inspect ((o t))
+  (cond ((di::indirect-value-cell-p o)
+                 `("Value: " (:value ,(c:value-cell-ref o))))
+        ((alien::alien-value-p o)
+         (inspect-alien-value o))
+	(t
+         (scl-inspect o))))
+
+(defun scl-inspect (o)
+  (destructuring-bind (text labeledp . parts)
+      (inspect::describe-parts o)
+    (list*  (format nil "~A~%" text)
+            (if labeledp
+                (loop for (label . value) in parts
+                      append (label-value-line label value))
+                (loop for value in parts  for i from 0 
+                      append (label-value-line i value))))))
+
+(defmethod emacs-inspect ((o function))
+  (let ((header (kernel:get-type o)))
+    (cond ((= header vm:function-header-type)
+           (list*  (format nil "~A is a function.~%" o)
+                   (append (label-value-line*
+                            ("Self" (kernel:%function-self o))
+                            ("Next" (kernel:%function-next o))
+                            ("Name" (kernel:%function-name o))
+                            ("Arglist" (kernel:%function-arglist o))
+                            ("Type" (kernel:%function-type o))
+                            ("Code" (kernel:function-code-header o)))
+                           (list 
+                            (with-output-to-string (s)
+                              (disassem:disassemble-function o :stream s))))))
+          ((= header vm:closure-header-type)
+           (list* (format nil "~A is a closure.~%" o)
+                   (append 
+                    (label-value-line "Function" (kernel:%closure-function o))
+                    `("Environment:" (:newline))
+                    (loop for i from 0 below (- (kernel:get-closure-length o)
+                                                (1- vm:closure-info-offset))
+                          append (label-value-line 
+                                  i (kernel:%closure-index-ref o i))))))
+          ((eval::interpreted-function-p o)
+           (scl-inspect o))
+          (t
+           (call-next-method)))))
+
+
+(defmethod emacs-inspect ((o kernel:code-component))
+          (append 
+           (label-value-line* 
+            ("code-size" (kernel:%code-code-size o))
+            ("entry-points" (kernel:%code-entry-points o))
+            ("debug-info" (kernel:%code-debug-info o))
+            ("trace-table-offset" (kernel:code-header-ref 
+                                   o vm:code-trace-table-offset-slot)))
+           `("Constants:" (:newline))
+           (loop for i from vm:code-constants-offset 
+                 below (kernel:get-header-data o)
+                 append (label-value-line i (kernel:code-header-ref o i)))
+           `("Code:" (:newline)
+             , (with-output-to-string (s)
+                 (cond ((kernel:%code-debug-info o)
+                        (disassem:disassemble-code-component o :stream s))
+                       (t
+                        (disassem:disassemble-memory 
+                         (disassem::align 
+                          (+ (logandc2 (kernel:get-lisp-obj-address o)
+                                       vm:lowtag-mask)
+                             (* vm:code-constants-offset vm:word-bytes))
+                          (ash 1 vm:lowtag-bits))
+                         (ash (kernel:%code-code-size o) vm:word-shift)
+                         :stream s)))))))
+
+(defmethod emacs-inspect ((o kernel:fdefn))
+  (label-value-line*
+           ("name" (kernel:fdefn-name o))
+           ("function" (kernel:fdefn-function o))
+           ("raw-addr" (sys:sap-ref-32
+                        (sys:int-sap (kernel:get-lisp-obj-address o))
+                        (* vm:fdefn-raw-addr-slot vm:word-bytes)))))
+
+(defmethod emacs-inspect ((o array))
+  (cond ((kernel:array-header-p o)
+         (list*  (format nil "~A is an array.~%" o)
+                 (label-value-line*
+                  (:header (describe-primitive-type o))
+                  (:rank (array-rank o))
+                  (:fill-pointer (kernel:%array-fill-pointer o))
+                  (:fill-pointer-p (kernel:%array-fill-pointer-p o))
+                  (:elements (kernel:%array-available-elements o))           
+                  (:data (kernel:%array-data-vector o))
+                  (:displacement (kernel:%array-displacement o))
+                  (:displaced-p (kernel:%array-displaced-p o))
+                  (:dimensions (array-dimensions o)))))
+        (t
+         (list*  (format nil "~A is an simple-array.~%" o)
+                 (label-value-line*
+                  (:header (describe-primitive-type o))
+                  (:length (length o)))))))
+
+(defmethod emacs-inspect ((o simple-vector))
+  (list*  (format nil "~A is a vector.~%" o)
+          (append 
+           (label-value-line*
+            (:header (describe-primitive-type o))
+            (:length (c::vector-length o)))
+           (unless (eq (array-element-type o) 'nil)
+             (loop for i below (length o)
+                   append (label-value-line i (aref o i)))))))
+
+(defun inspect-alien-record (alien)
+   (with-struct (alien::alien-value- sap type) alien
+     (with-struct (alien::alien-record-type- kind name fields) type
+       (append
+        (label-value-line*
+         (:sap sap)
+         (:kind kind)
+         (:name name))
+        (loop for field in fields 
+              append (let ((slot (alien::alien-record-field-name field)))
+                       (label-value-line slot (alien:slot alien slot))))))))
+
+(defun inspect-alien-pointer (alien)
+  (with-struct (alien::alien-value- sap type) alien
+     (label-value-line* 
+      (:sap sap)
+      (:type type)
+      (:to (alien::deref alien)))))
+  
+(defun inspect-alien-value (alien)
+  (typecase (alien::alien-value-type alien)
+    (alien::alien-record-type (inspect-alien-record alien))
+    (alien::alien-pointer-type (inspect-alien-pointer alien))
+    (t (scl-inspect alien))))
+
+;;;; Profiling
+(defimplementation profile (fname)
+  (eval `(profile:profile ,fname)))
+
+(defimplementation unprofile (fname)
+  (eval `(profile:unprofile ,fname)))
+
+(defimplementation unprofile-all ()
+  (eval `(profile:unprofile))
+  "All functions unprofiled.")
+
+(defimplementation profile-report ()
+  (eval `(profile:report-time)))
+
+(defimplementation profile-reset ()
+  (eval `(profile:reset-time))
+  "Reset profiling counters.")
+
+(defimplementation profiled-functions ()
+  profile:*timed-functions*)
+
+(defimplementation profile-package (package callers methods)
+  (profile:profile-all :package package
+                       :callers-p callers
+                       #+nil :methods #+nil methods))
+
+
+;;;; Multiprocessing
+
+(defimplementation spawn (fn &key name)
+  (thread:thread-create fn :name (or name "Anonymous")))
+
+(defvar *thread-id-counter* 0)
+(defvar *thread-id-counter-lock* (thread:make-lock "Thread ID counter"))
+
+(defimplementation thread-id (thread)
+  (thread:with-lock-held (*thread-id-counter-lock*)
+    (or (getf (thread:thread-plist thread) 'id)
+        (setf (getf (thread:thread-plist thread) 'id)
+              (incf *thread-id-counter*)))))
+
+(defimplementation find-thread (id)
+  (block find-thread
+    (thread:map-over-threads
+     #'(lambda (thread)
+         (when (eql (getf (thread:thread-plist thread) 'id) id)
+           (return-from find-thread thread))))))
+
+(defimplementation thread-name (thread)
+  (princ-to-string (thread:thread-name thread)))
+
+(defimplementation thread-status (thread)
+  (let ((dynamic-values (thread::thread-dynamic-values thread)))
+    (if (zerop dynamic-values) "Exited" "Running")))
+
+(defimplementation make-lock (&key name)
+  (thread:make-lock name))
+
+(defimplementation call-with-lock-held (lock function)
+  (declare (type function function))
+  (thread:with-lock-held (lock) (funcall function)))
+
+(defimplementation current-thread ()
+  thread:*thread*)
+
+(defimplementation all-threads ()
+  (let ((all-threads nil))
+    (thread:map-over-threads #'(lambda (thread) (push thread all-threads)))
+    all-threads))
+
+(defimplementation interrupt-thread (thread fn)
+  (thread:thread-interrupt thread #'(lambda ()
+                                      (sys:with-interrupts
+                                        (funcall fn)))))
+
+(defimplementation kill-thread (thread)
+  (thread:destroy-thread thread))
+
+(defimplementation thread-alive-p (thread)
+  (not (zerop (thread::thread-dynamic-values thread))))
+
+(defvar *mailbox-lock* (thread:make-lock "Mailbox lock" :interruptible nil))
+  
+(defstruct (mailbox)
+  (lock (thread:make-lock "Thread mailbox" :type :error-check
+                          :interruptible nil)
+        :type thread:error-check-lock)
+  (queue '() :type list))
+
+(defun mailbox (thread)
+  "Return 'thread's mailbox."
+  (sys:without-interrupts
+    (thread:with-lock-held (*mailbox-lock*)
+      (or (getf (thread:thread-plist thread) 'mailbox)
+          (setf (getf (thread:thread-plist thread) 'mailbox)
+                (make-mailbox))))))
+  
+(defimplementation send (thread message)
+  (let* ((mbox (mailbox thread))
+         (lock (mailbox-lock mbox)))
+    (sys:without-interrupts
+      (thread:with-lock-held (lock "Mailbox Send")
+        (setf (mailbox-queue mbox) (nconc (mailbox-queue mbox)
+                                          (list message)))))
+    (mp:process-wakeup thread)))
+
+#+nil
+(defimplementation receive ()
+  (receive-if (constantly t)))
+
+(defimplementation receive-if (test &optional timeout)
+  (let ((mbox (mailbox thread:*thread*)))
+    (assert (or (not timeout) (eq timeout t)))
+    (loop
+     (check-slime-interrupts)
+     (sys:without-interrupts
+       (mp:with-lock-held ((mailbox-lock mbox))
+         (let* ((q (mailbox-queue mbox))
+                (tail (member-if test q)))
+           (when tail
+             (setf (mailbox-queue mbox) 
+                   (nconc (ldiff q tail) (cdr tail)))
+             (return (car tail))))))
+     (when (eq timeout t) (return (values nil t)))
+     (mp:process-wait-with-timeout
+      "Mailbox read wait" 0.5 (lambda () (some test (mailbox-queue mbox)))))))
+
+
+
+(defimplementation emacs-connected ())
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;Trace implementations
+;; In SCL, we have:
+;;  (trace <name>)
+;;  (trace (method <name> <qualifier>? (<specializer>+)))
+;;  (trace :methods t '<name>) ;;to trace all methods of the gf <name>
+;;  <name> can be a normal name or a (setf name)
+
+(defun tracedp (spec)
+  (member spec (eval '(trace)) :test #'equal))
+
+(defun toggle-trace-aux (spec &rest options)
+  (cond ((tracedp spec)
+         (eval `(untrace ,spec))
+         (format nil "~S is now untraced." spec))
+        (t
+         (eval `(trace ,spec ,@options))
+         (format nil "~S is now traced." spec))))
+
+(defimplementation toggle-trace (spec)
+  (ecase (car spec)
+    ((setf)
+     (toggle-trace-aux spec))
+    ((:defgeneric)
+     (let ((name (second spec)))
+       (toggle-trace-aux name :methods name)))
+    ((:defmethod)
+     nil)
+    ((:call)
+     (destructuring-bind (caller callee) (cdr spec)
+       (toggle-trace-aux (process-fspec callee) 
+                         :wherein (list (process-fspec caller)))))))
+
+(defun process-fspec (fspec)
+  (cond ((consp fspec)
+         (ecase (first fspec)
+           ((:defun :defgeneric) (second fspec))
+           ((:defmethod) 
+            `(method ,(second fspec) ,@(third fspec) ,(fourth fspec)))
+           ;; this isn't actually supported
+           ((:labels) `(labels ,(process-fspec (second fspec)) ,(third fspec)))
+           ((:flet) `(flet ,(process-fspec (second fspec)) ,(third fspec)))))
+        (t
+         fspec)))
+
+;;; Weak datastructures
+
+;;; Not implemented in SCL.
+(defimplementation make-weak-key-hash-table (&rest args)
+  (apply #'make-hash-table :weak-p t args))