;;;;; -*- indent-tabs-mode: nil -*-
;;;
  swank-sbcl.lisp --- SLIME backend for SBCL .
;;;
  Created 2003 ,   <  >
;;;
;;; This code has been placed in the Public Domain.  All warranties are
;;; disclaimed.

;;; Requires the SB-INTROSPECT contrib.

  Administrivia

(defpackage swank/sbcl
  (:use cl swank/backend swank/source-path-parser swank/source-file-cache))

(in-package swank/sbcl)

(eval-when (:compile-toplevel :load-toplevel :execute)
  (require 'sb-bsd-sockets)
  (require 'sb-introspect)
  (require 'sb-posix)
  (require 'sb-cltl2))

(declaim (optimize (debug 2)
                   (sb-c::insert-step-conditions 0)
                   (sb-c::insert-debug-catch 0)))

;;; backwards compability tests

(eval-when (:compile-toplevel :load-toplevel :execute)
  ;; Generate a form suitable for testing for stepper support (0.9.17)
  ;; with #+.
  (defun sbcl-with-new-stepper-p ()
    (with-symbol 'enable-stepping 'sb-impl))
  ;; Ditto for weak hash-tables
  (defun sbcl-with-weak-hash-tables ()
    (with-symbol 'hash-table-weakness 'sb-ext))
  And for xref support ( 1.0.1 )
  (defun sbcl-with-xref-p ()
    (with-symbol 'who-calls 'sb-introspect))
  ... for restart - frame support ( 1.0.2 )
  (defun sbcl-with-restart-frame ()
    (with-symbol 'frame-has-debug-tag-p 'sb-debug))
  ... for : setf : inverse info ( 1.1.17 )
  (defun sbcl-with-setf-inverse-meta-info ()
    (boolean-to-feature-expression
  going through FIND - SYMBOL since META - INFO was renamed from
  TYPE - INFO in 1.2.10 .
     (let ((sym (find-symbol "META-INFO" "SB-C")))
       (and sym
            (fboundp sym)
            (funcall sym :setf :inverse ()))))))

;;; swank-mop

(import-swank-mop-symbols :sb-mop '(:slot-definition-documentation))

(defun swank-mop:slot-definition-documentation (slot)
  (sb-pcl::documentation slot t))

;; stream support

(defimplementation gray-package-name ()
  "SB-GRAY")

;; Pretty printer calls this, apparently
(defmethod sb-gray:stream-line-length
    ((s sb-gray:fundamental-character-input-stream))
  nil)

  Connection info

(defimplementation lisp-implementation-type-name ()
  "sbcl")

;; Declare return type explicitly to shut up STYLE-WARNINGS about
  % SAP - ALIEN in ENABLE - SIGIO - ON - FD below .
(declaim (ftype (function () (values (signed-byte 32) &optional)) getpid))
(defimplementation getpid ()
  (sb-posix:getpid))

;;; UTF8

(defimplementation string-to-utf8 (string)
  (sb-ext:string-to-octets string :external-format :utf8))

(defimplementation utf8-to-string (octets)
  (sb-ext:octets-to-string octets :external-format :utf8))

;;; TCP Server

(defimplementation preferred-communication-style ()
  (cond
  fixme : when SBCL / win32 gains better select ( ) support , remove
    ;; this.
    ((member :sb-thread *features*) :spawn)
    ((member :win32 *features*) nil)
    (t :fd-handler)))


(defun resolve-hostname (host)
  "Returns valid IPv4 or IPv6 address for the host."
  ;; get all IPv4 and IPv6 addresses as a list
  (let* ((host-ents (multiple-value-list (sb-bsd-sockets:get-host-by-name host)))
         ;; remove protocols for which we don't have an address
         (addresses (remove-if-not #'sb-bsd-sockets:host-ent-address host-ents)))
  Return the first one or nil ,
    ;; but actually, it shouln't return nil, because
    ;; get-host-by-name will signal NAME-SERVICE-ERROR condition
    ;; if there isn't any address for the host.
    (first addresses)))


(defimplementation create-socket (host port &key backlog)
  (let* ((host-ent (resolve-hostname host))
         (socket (make-instance (cond #+#.(swank/backend:with-symbol 'inet6-socket 'sb-bsd-sockets)
                                      ((eql (sb-bsd-sockets:host-ent-address-type host-ent) 10)
                                       'sb-bsd-sockets:inet6-socket)
                                      (t
                                       'sb-bsd-sockets:inet-socket))
                                :type :stream
                                :protocol :tcp)))
    (setf (sb-bsd-sockets:sockopt-reuse-address socket) t)
    (sb-bsd-sockets:socket-bind socket (sb-bsd-sockets:host-ent-address host-ent) port)

    (sb-bsd-sockets:socket-listen socket (or backlog 5))
    socket))

(defimplementation local-port (socket)
  (nth-value 1 (sb-bsd-sockets:socket-name socket)))

(defimplementation close-socket (socket)
  (sb-sys:invalidate-descriptor (socket-fd socket))
  (sb-bsd-sockets:socket-close socket))

(defimplementation accept-connection (socket &key
                                      external-format
                                      buffering timeout)
  (declare (ignore timeout))
  (make-socket-io-stream (accept socket) external-format
                         (ecase buffering
                           ((t :full) :full)
                           ((nil :none) :none)
                           ((:line) :line))))


  The  stuff should probably be removed as it 's unlikey that
;; anybody uses it.
#-win32
(progn
  (defimplementation install-sigint-handler (function)
    (sb-sys:enable-interrupt sb-unix:sigint
                             (lambda (&rest args)
                               (declare (ignore args))
                               (sb-sys:invoke-interruption
                                (lambda ()
                                  (sb-sys:with-interrupts
                                    (funcall function)))))))

  (defvar *sigio-handlers* '()
    "List of (key . fn) pairs to be called on SIGIO.")

  (defun sigio-handler (signal code scp)
    (declare (ignore signal code scp))
    (sb-sys:with-interrupts
      (mapc (lambda (handler)
              (funcall (the function (cdr handler))))
            *sigio-handlers*)))

  (defun set-sigio-handler ()
    (sb-sys:enable-interrupt sb-unix:sigio #'sigio-handler))

  (defun enable-sigio-on-fd (fd)
    (sb-posix::fcntl fd sb-posix::f-setfl sb-posix::o-async)
    (sb-posix::fcntl fd sb-posix::f-setown (getpid))
    (values))

  (defimplementation add-sigio-handler (socket fn)
    (set-sigio-handler)
    (let ((fd (socket-fd socket)))
      (enable-sigio-on-fd fd)
      (push (cons fd fn) *sigio-handlers*)))

  (defimplementation remove-sigio-handlers (socket)
    (let ((fd (socket-fd socket)))
      (setf *sigio-handlers* (delete fd *sigio-handlers* :key #'car))
      (sb-sys:invalidate-descriptor fd))
    (close socket)))


(defimplementation add-fd-handler (socket fun)
  (let ((fd (socket-fd socket))
        (handler nil))
    (labels ((add ()
               (setq handler (sb-sys:add-fd-handler fd :input #'run)))
             (run (fd)
               (sb-sys:remove-fd-handler handler) ; prevent recursion
               (unwind-protect
                    (funcall fun)
                 (when (sb-unix:unix-fstat fd) ; still open?
                   (add)))))
      (add))))

(defimplementation remove-fd-handlers (socket)
  (sb-sys:invalidate-descriptor (socket-fd socket)))

(defimplementation socket-fd (socket)
  (etypecase socket
    (fixnum socket)
    (sb-bsd-sockets:socket (sb-bsd-sockets:socket-file-descriptor socket))
    (file-stream (sb-sys:fd-stream-fd socket))))

(defimplementation command-line-args ()
  sb-ext:*posix-argv*)

(defimplementation dup (fd)
  (sb-posix:dup fd))

(defvar *wait-for-input-called*)

(defimplementation wait-for-input (streams &optional timeout)
  (assert (member timeout '(nil t)))
  (when (boundp '*wait-for-input-called*)
    (setq *wait-for-input-called* t))
  (let ((*wait-for-input-called* nil))
    (loop
      (let ((ready (remove-if-not #'input-ready-p streams)))
        (when ready (return ready)))
      (when (check-slime-interrupts)
        (return :interrupt))
      (when *wait-for-input-called*
        (return :interrupt))
      (when timeout
        (return nil))
      (sleep 0.1))))

(defun fd-stream-input-buffer-empty-p (stream)
  (let ((buffer (sb-impl::fd-stream-ibuf stream)))
    (or (not buffer)
        (= (sb-impl::buffer-head buffer)
           (sb-impl::buffer-tail buffer)))))

#-win32
(defun input-ready-p (stream)
  (or (not (fd-stream-input-buffer-empty-p stream))
      #+#.(swank/backend:with-symbol 'fd-stream-fd-type 'sb-impl)
      (eq :regular (sb-impl::fd-stream-fd-type stream))
      (not (sb-impl::sysread-may-block-p stream))))

#+win32
(progn
  (defun input-ready-p (stream)
    (or (not (fd-stream-input-buffer-empty-p stream))
        (handle-listen (sockint::fd->handle (sb-impl::fd-stream-fd stream)))))

  (sb-alien:define-alien-routine ("WSACreateEvent" wsa-create-event)
      sb-win32:handle)

  (sb-alien:define-alien-routine ("WSACloseEvent" wsa-close-event)
      sb-alien:int
    (event sb-win32:handle))

  (defconstant +fd-read+ #.(ash 1 0))
  (defconstant +fd-close+ #.(ash 1 5))

  (sb-alien:define-alien-routine ("WSAEventSelect" wsa-event-select)
      sb-alien:int
    (fd sb-alien:int)
    (handle sb-win32:handle)
    (mask sb-alien:long))

  (sb-alien:load-shared-object "kernel32.dll")
  (sb-alien:define-alien-routine ("WaitForSingleObjectEx"
                                  wait-for-single-object-ex)
      sb-alien:int
    (event sb-win32:handle)
    (milliseconds sb-alien:long)
    (alertable sb-alien:int))

  see    : HANDLE - LISTEN
  (defun handle-listen (handle)
    (sb-alien:with-alien ((avail sb-win32:dword)
                          (buf (array char #.sb-win32::input-record-size)))
      (unless (zerop (sb-win32:peek-named-pipe handle nil 0 nil
                                               (sb-alien:alien-sap
                                                (sb-alien:addr avail))
                                               nil))
        (return-from handle-listen (plusp avail)))

      (unless (zerop (sb-win32:peek-console-input handle
                                                  (sb-alien:alien-sap buf)
                                                  sb-win32::input-record-size
                                                  (sb-alien:alien-sap
                                                   (sb-alien:addr avail))))
        (return-from handle-listen (plusp avail))))

    (let ((event (wsa-create-event)))
      (wsa-event-select handle event (logior +fd-read+ +fd-close+))
      (let ((val (wait-for-single-object-ex event 0 0)))
        (wsa-close-event event)
        (unless (= val -1)
          (return-from handle-listen (zerop val)))))

    nil)

  )

(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")
    (:us-ascii "us-ascii" "us-ascii-unix")))

  C.f . R.M.Kreuter in <  > on sbcl - general ,
  2008 - 08 - 22 .
(defvar *physical-pathname-host* (pathname-host (user-homedir-pathname)))

(defimplementation filename-to-pathname (filename)
  (sb-ext:parse-native-namestring filename *physical-pathname-host*))

(defimplementation find-external-format (coding-system)
  (car (rassoc-if (lambda (x) (member coding-system x :test #'equal))
                  *external-format-to-coding-system*)))

(defimplementation set-default-directory (directory)
  (let ((directory (truename (merge-pathnames directory))))
    (sb-posix:chdir directory)
    (setf *default-pathname-defaults* directory)
    (default-directory)))

(defun make-socket-io-stream (socket external-format buffering)
  (let ((args `(:output t
                :input t
                :element-type ,(if external-format
                                   'character
                                   '(unsigned-byte 8))
                :buffering ,buffering
                ,@(cond ((and external-format (sb-int:featurep :sb-unicode))
                         `(:external-format ,external-format))
                        (t '()))
                :serve-events ,(eq :fd-handler swank:*communication-style*)
  SBCL < 1.0.42.43 does n't support : SERVE - EVENTS
                  ;; argument.
                :allow-other-keys t)))
  (apply #'sb-bsd-sockets:socket-make-stream socket args)))

(defun accept (socket)
  "Like socket-accept, but retry on EAGAIN."
  (loop (handler-case
            (return (sb-bsd-sockets:socket-accept socket))
          (sb-bsd-sockets:interrupted-error ()))))


  Support for  syntax

  SBCL 's source code is riddled with # ! reader macros .   Also symbols
;;; containing `!' have special meaning.  We have to work long and
;;; hard to be able to read the source.  To deal with #! reader
;;; macros, we use a special readtable.  The special symbols are
;;; converted by a condition handler.

(defun feature-in-list-p (feature list)
  (etypecase feature
    (symbol (member feature list :test #'eq))
    (cons (flet ((subfeature-in-list-p (subfeature)
                   (feature-in-list-p subfeature list)))
  Do n't use ECASE since SBCL also has : host - feature ,
            ;; don't need to handle it or anything else appearing in
            ;; the future or in erronous code.
            (case (first feature)
              (:or  (some  #'subfeature-in-list-p (rest feature)))
              (:and (every #'subfeature-in-list-p (rest feature)))
              (:not (destructuring-bind (e) (cdr feature)
                      (not (subfeature-in-list-p e)))))))))

(defun shebang-reader (stream sub-character infix-parameter)
  (declare (ignore sub-character))
  (when infix-parameter
    (error "illegal read syntax: #~D!" infix-parameter))
  (let ((next-char (read-char stream)))
    (unless (find next-char "+-")
      (error "illegal read syntax: #!~C" next-char))
    ;; When test is not satisfied
    ;; FIXME: clearer if order of NOT-P and (NOT NOT-P) were reversed? then
    ;; would become "unless test is satisfied"..
    (when (let* ((*package* (find-package "KEYWORD"))
                 (*read-suppress* nil)
                 (not-p (char= next-char #\-))
                 (feature (read stream)))
            (if (feature-in-list-p feature *features*)
		not-p
		(not not-p)))
      ;; Read (and discard) a form from input.
      (let ((*read-suppress* t))
	(read stream t nil t))))
 (values))

(defvar *shebang-readtable*
  (let ((*readtable* (copy-readtable nil)))
    (set-dispatch-macro-character #\# #\!
                                  (lambda (s c n) (shebang-reader s c n))
                                  *readtable*)
    *readtable*))

(defun shebang-readtable ()
  *shebang-readtable*)

(defun sbcl-package-p (package)
  (let ((name (package-name package)))
    (eql (mismatch "SB-" name) 3)))

(defun sbcl-source-file-p (filename)
  (when filename
    (loop for (nil pattern) in (logical-pathname-translations "SYS")
          thereis (pathname-match-p filename pattern))))

(defun guess-readtable-for-filename (filename)
  (if (sbcl-source-file-p filename)
      (shebang-readtable)
      *readtable*))

(defvar *debootstrap-packages* t)

(defun call-with-debootstrapping (fun)
  (handler-bind ((sb-int:bootstrap-package-not-found
                  #'sb-int:debootstrap-package))
    (funcall fun)))

(defmacro with-debootstrapping (&body body)
  `(call-with-debootstrapping (lambda () ,@body)))

(defimplementation call-with-syntax-hooks (fn)
  (cond ((and *debootstrap-packages*
              (sbcl-package-p *package*))
         (with-debootstrapping (funcall fn)))
        (t
         (funcall fn))))

(defimplementation default-readtable-alist ()
  (let ((readtable (shebang-readtable)))
    (loop for p in (remove-if-not #'sbcl-package-p (list-all-packages))
          collect (cons (package-name p) readtable))))

;;; Packages

#+#.(swank/backend:with-symbol 'package-local-nicknames 'sb-ext)
(defimplementation package-local-nicknames (package)
  (sb-ext:package-local-nicknames package))

  Utilities

#+#.(swank/backend:with-symbol 'function-lambda-list 'sb-introspect)
(defimplementation arglist (fname)
  (sb-introspect:function-lambda-list fname))

#-#.(swank/backend:with-symbol 'function-lambda-list 'sb-introspect)
(defimplementation arglist (fname)
  (sb-introspect:function-arglist fname))

(defimplementation function-name (f)
  (check-type f function)
  (sb-impl::%fun-name f))

(defmethod declaration-arglist ((decl-identifier (eql 'optimize)))
  (flet ((ensure-list (thing) (if (listp thing) thing (list thing))))
    (let* ((flags (sb-cltl2:declaration-information decl-identifier)))
      (if flags
          ;; Symbols aren't printed with package qualifiers, but the
  FLAGS would have to be fully qualified when used inside a
          ;; declaration. So we strip those as long as there's no
          ;; better way. (FIXME)
          `(&any ,@(remove-if-not
                    #'(lambda (qualifier)
                        (find-symbol (symbol-name (first qualifier)) :cl))
                    flags :key #'ensure-list))
          (call-next-method)))))

#+#.(swank/backend:with-symbol 'deftype-lambda-list 'sb-introspect)
(defmethod type-specifier-arglist :around (typespec-operator)
  (multiple-value-bind (arglist foundp)
      (sb-introspect:deftype-lambda-list typespec-operator)
    (if foundp arglist (call-next-method))))

(defimplementation type-specifier-p (symbol)
  (or (sb-ext:valid-type-specifier-p symbol)
      (not (eq (type-specifier-arglist symbol) :not-available))))

(defvar *buffer-name* nil)
(defvar *buffer-tmpfile* nil)
(defvar *buffer-offset*)
(defvar *buffer-substring* nil)

(defvar *previous-compiler-condition* nil
  "Used to detect duplicates.")

(defun handle-notification-condition (condition)
  "Handle a condition caused by a compiler warning.
This traps all compiler conditions at a lower-level than using
C:*COMPILER-NOTIFICATION-FUNCTION*. The advantage is that we get to
craft our own error messages, which can omit a lot of redundant
information."
  (unless (or (eq condition *previous-compiler-condition*))
    ;; First resignal warnings, so that outer handlers -- which may choose to
    ;; muffle this -- get a chance to run.
    (when (typep condition 'warning)
      (signal condition))
    (setq *previous-compiler-condition* condition)
    (signal-compiler-condition (real-condition condition)
                               (sb-c::find-error-context nil))))

(defun signal-compiler-condition (condition context)
  (signal 'compiler-condition
          :original-condition condition
          :severity (etypecase condition
                      (sb-ext:compiler-note :note)
                      (sb-c:compiler-error  :error)
                      (reader-error         :read-error)
                      (error                :error)
                      #+#.(swank/backend:with-symbol early-deprecation-warning sb-ext)
                      (sb-ext:early-deprecation-warning :early-deprecation-warning)
                      #+#.(swank/backend:with-symbol late-deprecation-warning sb-ext)
                      (sb-ext:late-deprecation-warning :late-deprecation-warning)
                      #+#.(swank/backend:with-symbol final-deprecation-warning sb-ext)
                      (sb-ext:final-deprecation-warning :final-deprecation-warning)
                      #+#.(swank/backend:with-symbol redefinition-warning
                            sb-kernel)
                      (sb-kernel:redefinition-warning
                       :redefinition)
                      (style-warning        :style-warning)
                      (warning              :warning))
          :references (condition-references condition)
          :message (brief-compiler-message-for-emacs condition)
          :source-context (compiler-error-context context)
          :location (compiler-note-location condition context)))

(defun real-condition (condition)
  "Return the encapsulated condition or CONDITION itself."
  (typecase condition
    (sb-int:encapsulated-condition (sb-int:encapsulated-condition condition))
    (t condition)))

(defun condition-references (condition)
  (if (typep condition 'sb-int:reference-condition)
      (externalize-reference
       (sb-int:reference-condition-references condition))))

(defun compiler-note-location (condition context)
  (flet ((bailout ()
           (return-from compiler-note-location
             (make-error-location "No error location available"))))
    (cond (context
           (locate-compiler-note
            (sb-c::compiler-error-context-file-name context)
            (compiler-source-path context)
            (sb-c::compiler-error-context-original-source context)))
          ((typep condition 'reader-error)
           (let* ((stream (stream-error-stream condition))
                  (file   (pathname stream)))
             (unless (open-stream-p stream)
               (bailout))
             (if (compiling-from-buffer-p file)
                 ;; The stream position for e.g. "comma not inside
                 ;; backquote" is at the character following the
                 ;; comma, :offset is 0-based, hence the 1-.
                 (make-location (list :buffer *buffer-name*)
                                (list :offset *buffer-offset*
                                      (1- (file-position stream))))
                 (progn
                   (assert (compiling-from-file-p file))
  No 1- because : position is 1 - based .
                   (make-location (list :file (namestring file))
                                  (list :position (file-position stream)))))))
          (t (bailout)))))

(defun compiling-from-buffer-p (filename)
  (and *buffer-name*
       ;; The following is to trigger COMPILING-FROM-GENERATED-CODE-P
       ;; in LOCATE-COMPILER-NOTE, and allows handling nested
       ;; compilation from eg. hitting C-C on (eval-when ... (require ..))).
       ;;
       ;; PROBE-FILE to handle tempfile directory being a symlink.
       (pathnamep filename)
       (let ((true1 (probe-file filename))
             (true2 (probe-file *buffer-tmpfile*)))
         (and true1 (equal true1 true2)))))

(defun compiling-from-file-p (filename)
  (and (pathnamep filename)
       (or (null *buffer-name*)
           (null *buffer-tmpfile*)
           (let ((true1 (probe-file filename))
                 (true2 (probe-file *buffer-tmpfile*)))
             (not (and true1 (equal true1 true2)))))))

(defun compiling-from-generated-code-p (filename source)
  (and (eq filename :lisp) (stringp source)))

(defun locate-compiler-note (file source-path source)
  (cond ((compiling-from-buffer-p file)
         (make-location (list :buffer *buffer-name*)
                        (list :offset  *buffer-offset*
                              (source-path-string-position
                               source-path *buffer-substring*))))
        ((compiling-from-file-p file)
         (let ((position (source-path-file-position source-path file)))
           (make-location (list :file (namestring file))
                          (list :position (and position
                                               (1+ position))))))
        ((compiling-from-generated-code-p file source)
         (make-location (list :source-form source)
                        (list :position 1)))
        (t
         (error "unhandled case in compiler note ~S ~S ~S"
                file source-path source))))

(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."
  (let ((sb-int:*print-condition-references* nil))
    (princ-to-string condition)))

(defun compiler-error-context (error-context)
  "Describe a compiler error for Emacs including context information."
  (declare (type (or sb-c::compiler-error-context null) error-context))
  (multiple-value-bind (enclosing source)
      (if error-context
          (values (sb-c::compiler-error-context-enclosing-source error-context)
                  (sb-c::compiler-error-context-source error-context)))
    (and (or enclosing source)
         (format nil "~@[--> ~{~<~%--> ~1:;~A~> ~}~%~]~@[~{==>~%~A~%~}~]"
                 enclosing source))))

(defun compiler-source-path (context)
  "Return the source-path for the current compiler error.
Returns NIL if this cannot be determined by examining internal
compiler state."
  (cond ((sb-c::node-p context)
         (reverse
          (sb-c::source-path-original-source
           (sb-c::node-source-path context))))
        ((sb-c::compiler-error-context-p context)
         (reverse
          (sb-c::compiler-error-context-original-source-path context)))))

(defimplementation call-with-compilation-hooks (function)
  (declare (type function function))
  (handler-bind
      ;; N.B. Even though these handlers are called HANDLE-FOO they
      ;; actually decline, i.e. the signalling of the original
      ;; condition continues upward.
      ((sb-c:fatal-compiler-error #'handle-notification-condition)
       (sb-c:compiler-error       #'handle-notification-condition)
       (sb-ext:compiler-note      #'handle-notification-condition)
       (error                     #'handle-notification-condition)
       (warning                   #'handle-notification-condition))
    (funcall function)))

  HACK : SBCL 1.2.12 shipped with a bug where
;;; SB-EXT:RESTRICT-COMPILER-POLICY would signal an error when there
;;; were no policy restrictions in place. This workaround ensures the
  existence of at least one dummy restriction .
(handler-case (sb-ext:restrict-compiler-policy)
  (error () (sb-ext:restrict-compiler-policy 'debug)))

(defun compiler-policy (qualities)
  "Return compiler policy qualities present in the QUALITIES alist.
QUALITIES is an alist with (quality . value)"
  #+#.(swank/backend:with-symbol 'restrict-compiler-policy 'sb-ext)
  (loop with policy = (sb-ext:restrict-compiler-policy)
        for (quality) in qualities
        collect (cons quality
                      (or (cdr (assoc quality policy))
                          0))))

(defun (setf compiler-policy) (policy)
  (declare (ignorable policy))
  #+#.(swank/backend:with-symbol 'restrict-compiler-policy 'sb-ext)
  (loop for (qual . value) in policy
        do (sb-ext:restrict-compiler-policy qual value)))

(defmacro with-compiler-policy (policy &body body)
  (let ((current-policy (gensym)))
    `(let ((,current-policy (compiler-policy ,policy)))
       (setf (compiler-policy) ,policy)
       (unwind-protect (progn ,@body)
         (setf (compiler-policy) ,current-policy)))))

(defimplementation swank-compile-file (input-file output-file
                                       load-p external-format
                                       &key policy)
  (multiple-value-bind (output-file warnings-p failure-p)
      (with-compiler-policy policy
        (with-compilation-hooks ()
          (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)))))))

;;;; compile-string

;;; We copy the string to a temporary file in order to get adequate
;;; semantics for :COMPILE-TOPLEVEL and :LOAD-TOPLEVEL EVAL-WHEN forms
;;; which the previous approach using
;;;     (compile nil `(lambda () ,(read-from-string string)))
;;; did not provide.

(locally (declare (sb-ext:muffle-conditions sb-ext:compiler-note))

(sb-alien:define-alien-routine (#-win32 "tempnam" #+win32 "_tempnam" tempnam)
    sb-alien:c-string
  (dir sb-alien:c-string)
  (prefix sb-alien:c-string)))

(defun temp-file-name ()
  "Return a temporary file name to compile strings into."
  (tempnam nil "slime"))

(defvar *trap-load-time-warnings* t)

(defimplementation swank-compile-string (string &key buffer position filename
                                         policy)
  (let ((*buffer-name* buffer)
        (*buffer-offset* position)
        (*buffer-substring* string)
        (*buffer-tmpfile* (temp-file-name)))
    (labels ((load-it (filename)
               (cond (*trap-load-time-warnings*
                      (with-compilation-hooks () (load filename)))
                     (t (load filename))))
             (cf ()
               (with-compiler-policy policy
                 (with-compilation-unit
                     (:source-plist (list :emacs-buffer buffer
                                          :emacs-filename filename
                                          :emacs-package (package-name *package*)
                                          :emacs-position position
                                          :emacs-string string)
                      :source-namestring filename
                      :allow-other-keys t)
                   (compile-file *buffer-tmpfile* :external-format :utf-8)))))
      (with-open-file (s *buffer-tmpfile* :direction :output :if-exists :error
                         :external-format :utf-8)
        (write-string string s))
      (unwind-protect
           (multiple-value-bind (output-file warningsp failurep)
               (with-compilation-hooks () (cf))
             (declare (ignore warningsp))
             (when output-file
               (load-it output-file))
             (not failurep))
        (ignore-errors
          (delete-file *buffer-tmpfile*)
          (delete-file (compile-file-pathname *buffer-tmpfile*)))))))

;;;; Definitions

(defparameter *definition-types*
  '(:variable defvar
    :constant defconstant
    :type deftype
    :symbol-macro define-symbol-macro
    :macro defmacro
    :compiler-macro define-compiler-macro
    :function defun
    :generic-function defgeneric
    :method defmethod
    :setf-expander define-setf-expander
    :structure defstruct
    :condition define-condition
    :class defclass
    :method-combination define-method-combination
    :package defpackage
    :transform :deftransform
    :optimizer :defoptimizer
    :vop :define-vop
    :source-transform :define-source-transform
    :ir1-convert :def-ir1-translator
    :declaration declaim
    :alien-type :define-alien-type)
  "Map SB-INTROSPECT definition type names to Slime-friendly forms")

(defun definition-specifier (type)
  "Return a pretty specifier for NAME representing a definition of type TYPE."
  (getf *definition-types* type))

(defun make-dspec (type name source-location)
  (list* (definition-specifier type)
         name
         (sb-introspect::definition-source-description source-location)))

(defimplementation find-definitions (name)
  (loop for type in *definition-types* by #'cddr
        for defsrcs = (sb-introspect:find-definition-sources-by-name name type)
        append (loop for defsrc in defsrcs collect
                     (list (make-dspec type name defsrc)
                           (converting-errors-to-error-location
                             (definition-source-for-emacs defsrc
                                 type name))))))

(defimplementation find-source-location (obj)
  (flet ((general-type-of (obj)
           (typecase obj
             (method             :method)
             (generic-function   :generic-function)
             (function           :function)
             (structure-class    :structure-class)
             (class              :class)
             (method-combination :method-combination)
             (package            :package)
             (condition          :condition)
             (structure-object   :structure-object)
             (standard-object    :standard-object)
             (t                  :thing)))
         (to-string (obj)
           (typecase obj
             ;; Packages are possibly named entities.
             (package (princ-to-string obj))
             ((or structure-object standard-object condition)
              (with-output-to-string (s)
                (print-unreadable-object (obj s :type t :identity t))))
             (t (princ-to-string obj)))))
    (converting-errors-to-error-location
      (let ((defsrc (sb-introspect:find-definition-source obj)))
        (definition-source-for-emacs defsrc
                                     (general-type-of obj)
                                     (to-string obj))))))

(defmacro with-definition-source ((&rest names) obj &body body)
  "Like with-slots but works only for structs."
  (flet ((reader (slot)
           ;; Use read-from-string instead of intern so that
           ;; conc-name can be a string such as ext:struct- and not
           ;; cause errors and not force interning ext::struct-
           (read-from-string
            (concatenate 'string "sb-introspect:definition-source-"
                         (string slot)))))
    (let ((tmp (gensym "OO-")))
      ` (let ((,tmp ,obj))
          (symbol-macrolet
              ,(loop for name in names collect
                     (typecase name
                       (symbol `(,name (,(reader name) ,tmp)))
                       (cons `(,(first name) (,(reader (second name)) ,tmp)))
                       (t (error "Malformed syntax in WITH-STRUCT: ~A" name))))
            ,@body)))))

(defun categorize-definition-source (definition-source)
  (with-definition-source (pathname form-path character-offset plist)
    definition-source
    (let ((file-p (and pathname (probe-file pathname)
                       (or form-path character-offset))))
      (cond ((and (getf plist :emacs-buffer) file-p) :buffer-and-file)
            ((getf plist :emacs-buffer) :buffer)
            (file-p :file)
            (pathname :file-without-position)
            (t :invalid)))))

#+#.(swank/backend:with-symbol 'definition-source-form-number 'sb-introspect)
(defun form-number-position (definition-source stream)
  (let* ((tlf-number (car (sb-introspect:definition-source-form-path definition-source)))
         (form-number (sb-introspect:definition-source-form-number definition-source)))
    (multiple-value-bind (tlf pos-map) (read-source-form tlf-number stream)
      (let* ((path-table (sb-di::form-number-translations tlf 0))
             (path (cond ((<= (length path-table) form-number)
                          (warn "inconsistent form-number-translations")
                          (list 0))
                         (t
                          (reverse (cdr (aref path-table form-number)))))))
        (source-path-source-position path tlf pos-map)))))

#+#.(swank/backend:with-symbol 'definition-source-form-number 'sb-introspect)
(defun file-form-number-position (definition-source)
  (let* ((code-date (sb-introspect:definition-source-file-write-date definition-source))
         (filename (sb-introspect:definition-source-pathname definition-source))
         (*readtable* (guess-readtable-for-filename filename))
         (source-code (get-source-code filename code-date)))
    (with-debootstrapping
      (with-input-from-string (s source-code)
        (form-number-position definition-source s)))))

#+#.(swank/backend:with-symbol 'definition-source-form-number 'sb-introspect)
(defun string-form-number-position (definition-source string)
  (with-input-from-string (s string)
    (form-number-position definition-source s)))

(defun definition-source-buffer-location (definition-source)
  (with-definition-source (form-path character-offset plist) definition-source
    (destructuring-bind (&key emacs-buffer emacs-position emacs-directory
                              emacs-string &allow-other-keys)
        plist
      (let ((*readtable* (guess-readtable-for-filename emacs-directory))
            start
            end)
        (with-debootstrapping
          (or
           (and form-path
                (or
                 #+#.(swank/backend:with-symbol 'definition-source-form-number 'sb-introspect)
                 (setf (values start end)
                       (and (sb-introspect:definition-source-form-number definition-source)
                            (string-form-number-position definition-source emacs-string)))
                 (setf (values start end)
                       (source-path-string-position form-path emacs-string))))
           (setf start character-offset
                 end most-positive-fixnum)))
        (make-location
         `(:buffer ,emacs-buffer)
         `(:offset ,emacs-position ,start)
         `(:snippet
           ,(subseq emacs-string
                    start
                    (min end (+ start *source-snippet-size*)))))))))

(defun definition-source-file-location (definition-source)
  (with-definition-source (pathname form-path character-offset plist
                           file-write-date) definition-source
    (let* ((namestring (namestring (translate-logical-pathname pathname)))
           (pos (or (and form-path
                         (or
                          #+#.(swank/backend:with-symbol 'definition-source-form-number 'sb-introspect)
                          (and (sb-introspect:definition-source-form-number definition-source)
                               (ignore-errors (file-form-number-position definition-source)))
                          (ignore-errors
                           (source-file-position namestring file-write-date
                                                 form-path))))
                    character-offset))
           (snippet (source-hint-snippet namestring file-write-date pos)))
      (make-location `(:file ,namestring)
                     ;; /file positions/ in Common Lisp start from
  0 , buffer positions in Emacs start from 1 .
                     `(:position ,(1+ pos))
                     `(:snippet ,snippet)))))

(defun definition-source-buffer-and-file-location (definition-source)
  (let ((buffer (definition-source-buffer-location definition-source)))
    (make-location (list :buffer-and-file
                         (cadr (location-buffer buffer))
                         (namestring (sb-introspect:definition-source-pathname
                                      definition-source)))
                   (location-position buffer)
                   (location-hints buffer))))

(defun definition-source-for-emacs (definition-source type name)
  (with-definition-source (pathname form-path character-offset plist
                                    file-write-date)
      definition-source
    (ecase (categorize-definition-source definition-source)
      (:buffer-and-file
       (definition-source-buffer-and-file-location definition-source))
      (:buffer
       (definition-source-buffer-location definition-source))
      (:file
       (definition-source-file-location definition-source))
      (:file-without-position
       (make-location `(:file ,(namestring
                                (translate-logical-pathname pathname)))
                      '(:position 1)
                      (when (eql type :function)
                        `(:snippet ,(format nil "(defun ~a "
                                            (symbol-name name))))))
      (:invalid
       (error "DEFINITION-SOURCE of ~(~A~) ~A did not contain ~
               meaningful information."
              type name)))))

(defun source-file-position (filename write-date form-path)
  (let ((source (get-source-code filename write-date))
        (*readtable* (guess-readtable-for-filename filename)))
    (with-debootstrapping
      (source-path-string-position form-path source))))

(defun source-hint-snippet (filename write-date position)
  (read-snippet-from-string (get-source-code filename write-date) position))

(defun function-source-location (function &optional name)
  (declare (type function function))
  (definition-source-for-emacs (sb-introspect:find-definition-source function)
                               :function
                               (or name (function-name function))))

(defun setf-expander (symbol)
  (or
   #+#.(swank/sbcl::sbcl-with-setf-inverse-meta-info)
   (sb-int:info :setf :inverse symbol)
   (sb-int:info :setf :expander symbol)))

(defimplementation describe-symbol-for-emacs (symbol)
  "Return a plist describing SYMBOL.
Return NIL if the symbol is unbound."
  (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)
                     (sb-int: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)
               ((typep (fdefinition symbol) 'generic-function)
                :generic-function)
               (t :function))
         (doc 'function)))
      (maybe-push
       :setf (and (setf-expander symbol) 
                  (doc 'setf)))
      (maybe-push
       :type (if (sb-int:info :type :kind symbol)
                 (doc 'type)))
      result)))

(defimplementation describe-definition (symbol type)
  (case type
    (:variable
     (describe symbol))
    (:function
     (describe (symbol-function symbol)))
    (:setf
     (describe (setf-expander symbol)))
    (:class
     (describe (find-class symbol)))
    (:type
     (describe (sb-kernel:values-specifier-type symbol)))))

#+#.(swank/sbcl::sbcl-with-xref-p)
(progn
  (defmacro defxref (name &optional fn-name)
    `(defimplementation ,name (what)
       (sanitize-xrefs
        (mapcar #'source-location-for-xref-data
                (,(find-symbol (symbol-name (if fn-name
                                                fn-name
                                                name))
                               "SB-INTROSPECT")
                  what)))))
  (defxref who-calls)
  (defxref who-binds)
  (defxref who-sets)
  (defxref who-references)
  (defxref who-macroexpands)
  #+#.(swank/backend:with-symbol 'who-specializes-directly 'sb-introspect)
  (defxref who-specializes who-specializes-directly))

(defun source-location-for-xref-data (xref-data)
  (destructuring-bind (name . defsrc) xref-data
    (list name (converting-errors-to-error-location
                 (definition-source-for-emacs defsrc 'function name)))))

(defimplementation list-callers (symbol)
  (let ((fn (fdefinition symbol)))
    (sanitize-xrefs
     (mapcar #'function-dspec (sb-introspect:find-function-callers fn)))))

(defimplementation list-callees (symbol)
  (let ((fn (fdefinition symbol)))
    (sanitize-xrefs
     (mapcar #'function-dspec (sb-introspect:find-function-callees fn)))))

(defun sanitize-xrefs (xrefs)
  (remove-duplicates
   (remove-if (lambda (f)
                (member f (ignored-xref-function-names)))
              (loop for entry in xrefs
                    for name = (car entry)
                    collect (if (and (consp name)
                                     (member (car name)
                                             '(sb-pcl::fast-method
                                               sb-pcl::slow-method
                                               sb-pcl::method)))
                                (cons (cons 'defmethod (cdr name))
                                      (cdr entry))
                                entry))
              :key #'car)
   :test (lambda (a b)
           (and (eq (first a) (first b))
                (equal (second a) (second b))))))

(defun ignored-xref-function-names ()
  #-#.(swank/sbcl::sbcl-with-new-stepper-p)
  '(nil sb-c::step-form sb-c::step-values)
  #+#.(swank/sbcl::sbcl-with-new-stepper-p)
  '(nil))

(defun function-dspec (fn)
  "Describe where the function FN was defined.
Return a list of the form (NAME LOCATION)."
  (let ((name (function-name fn)))
    (list name (converting-errors-to-error-location
                 (function-source-location fn name)))))

;;; macroexpansion

(defimplementation macroexpand-all (form &optional env)
  (sb-cltl2:macroexpand-all form env))

(defimplementation collect-macro-forms (form &optional environment)
  (let ((macro-forms '())
        (compiler-macro-forms '())
        (function-quoted-forms '()))
    (sb-walker:walk-form
     form environment
     (lambda (form context environment)
       (declare (ignore context))
       (when (and (consp form)
                  (symbolp (car form)))
         (cond ((eq (car form) 'function)
                (push (cadr form) function-quoted-forms))
               ((member form function-quoted-forms)
                nil)
               ((macro-function (car form) environment)
                (push form macro-forms))
               ((not (eq form (compiler-macroexpand-1 form environment)))
                (push form compiler-macro-forms))))
       form))
    (values macro-forms compiler-macro-forms)))


;;; Debugging

  Notice that SB - EXT:*INVOKE - DEBUGGER - HOOK * is slightly stronger
;;; than just a hook into BREAK. In particular, it'll make
;;; (LET ((*DEBUGGER-HOOK* NIL)) ..error..) drop into SLDB rather
;;; than the native debugger. That should probably be considered a
;;; feature.

(defun make-invoke-debugger-hook (hook)
  (when hook
    #'(sb-int:named-lambda swank-invoke-debugger-hook
          (condition old-hook)
        (if *debugger-hook*
            nil         ; decline, *DEBUGGER-HOOK* will be tried next.
            (funcall hook condition old-hook)))))

(defun set-break-hook (hook)
  (setq sb-ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook)))

(defun call-with-break-hook (hook continuation)
  (let ((sb-ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook)))
    (funcall continuation)))

(defimplementation install-debugger-globally (function)
  (setq *debugger-hook* function)
  (set-break-hook function))

(defimplementation condition-extras (condition)
  (cond #+#.(swank/sbcl::sbcl-with-new-stepper-p)
        ((typep condition 'sb-impl::step-form-condition)
         `((:show-frame-source 0)))
        ((typep condition 'sb-int:reference-condition)
         (let ((refs (sb-int:reference-condition-references condition)))
           (if refs
               `((:references ,(externalize-reference refs))))))))

(defun externalize-reference (ref)
  (etypecase ref
    (null nil)
    (cons (cons (externalize-reference (car ref))
                (externalize-reference (cdr ref))))
    ((or string number) ref)
    (symbol
     (cond ((eq (symbol-package ref) (symbol-package :test))
            ref)
           (t (symbol-name ref))))))

(defvar *sldb-stack-top*)

(defimplementation call-with-debugging-environment (debugger-loop-fn)
  (declare (type function debugger-loop-fn))
  (let ((*sldb-stack-top*
          (if (and (not *debug-swank-backend*)
                   sb-debug:*stack-top-hint*)
              #+#.(swank/backend:with-symbol 'resolve-stack-top-hint 'sb-debug)
              (sb-debug::resolve-stack-top-hint)
              #-#.(swank/backend:with-symbol 'resolve-stack-top-hint 'sb-debug)
              sb-debug:*stack-top-hint*
              (sb-di:top-frame)))
        (sb-debug:*stack-top-hint* nil))
    (handler-bind ((sb-di:debug-condition
                     (lambda (condition)
                       (signal 'sldb-condition
                               :original-condition condition))))
      (funcall debugger-loop-fn))))

#+#.(swank/sbcl::sbcl-with-new-stepper-p)
(progn
  (defimplementation activate-stepping (frame)
    (declare (ignore frame))
    (sb-impl::enable-stepping))
  (defimplementation sldb-stepper-condition-p (condition)
    (typep condition 'sb-ext:step-form-condition))
  (defimplementation sldb-step-into ()
    (invoke-restart 'sb-ext:step-into))
  (defimplementation sldb-step-next ()
    (invoke-restart 'sb-ext:step-next))
  (defimplementation sldb-step-out ()
    (invoke-restart 'sb-ext:step-out)))

(defimplementation call-with-debugger-hook (hook fun)
  (let ((*debugger-hook* hook)
        #+#.(swank/sbcl::sbcl-with-new-stepper-p)
        (sb-ext:*stepper-hook*
         (lambda (condition)
           (typecase condition
             (sb-ext:step-form-condition
              (let ((sb-debug:*stack-top-hint* (sb-di::find-stepped-frame)))
                (sb-impl::invoke-debugger condition)))))))
    (handler-bind (#+#.(swank/sbcl::sbcl-with-new-stepper-p)
                   (sb-ext:step-condition #'sb-impl::invoke-stepper))
      (call-with-break-hook hook fun))))

(defun nth-frame (index)
  (do ((frame *sldb-stack-top* (sb-di:frame-down frame))
       (i index (1- i)))
      ((zerop i) frame)))

(defimplementation compute-backtrace (start end)
  "Return a list of frames starting with frame number START and
continuing to frame number END or, if END is nil, the last frame on the
stack."
  (let ((end (or end most-positive-fixnum)))
    (loop for f = (nth-frame start) then (sb-di:frame-down f)
          for i from start below end
          while f collect f)))

(defimplementation print-frame (frame stream)
  (sb-debug::print-frame-call frame stream))

(defimplementation frame-restartable-p (frame)
  #+#.(swank/sbcl::sbcl-with-restart-frame)
  (not (null (sb-debug:frame-has-debug-tag-p frame))))

(defimplementation frame-call (frame-number)
  (multiple-value-bind (name args)
      (sb-debug::frame-call (nth-frame frame-number))
    (with-output-to-string (stream)
      (locally (declare (sb-ext:muffle-conditions sb-ext:compiler-note))
        (pprint-logical-block (stream nil :prefix "(" :suffix ")")
          (locally (declare (sb-ext:unmuffle-conditions sb-ext:compiler-note))
            (let ((*print-length* nil)
                  (*print-level* nil))
              (prin1 (sb-debug::ensure-printable-object name) stream))
            (let ((args (sb-debug::ensure-printable-object args)))
              (if (listp args)
                  (format stream "~{ ~_~S~}" args)
                  (format stream " ~S" args)))))))))

;;;; Code-location -> source-location translation

;;; If debug-block info is avaibale, we determine the file position of
;;; the source-path for a code-location.  If the code was compiled
  with C - c C - c , we have to search the position in the source string .
;;; If there's no debug-block info, we return the (less precise)
;;; source-location of the corresponding function.

(defun code-location-source-location (code-location)
  (let* ((dsource (sb-di:code-location-debug-source code-location))
         (plist (sb-c::debug-source-plist dsource))
         (package (getf plist :emacs-package))
         (*package* (or (and package
                             (find-package package))
                        *package*)))
    (if (getf plist :emacs-buffer)
        (emacs-buffer-source-location code-location plist)
        #+#.(swank/backend:with-symbol 'debug-source-from 'sb-di)
        (ecase (sb-di:debug-source-from dsource)
          (:file (file-source-location code-location))
          (:lisp (lisp-source-location code-location)))
        #-#.(swank/backend:with-symbol 'debug-source-from 'sb-di)
        (if (sb-di:debug-source-namestring dsource)
            (file-source-location code-location)
            (lisp-source-location code-location)))))

;;; FIXME: The naming policy of source-location functions is a bit
;;; fuzzy: we have FUNCTION-SOURCE-LOCATION which returns the
  source - location for a function , and we also have FILE - SOURCE - LOCATION & co
;;; which returns the source location for a _code-location_.
;;;
;;; Maybe these should be named code-location-file-source-location,
;;; etc, turned into generic functions, or something. In the very
;;; least the names should indicate the main entry point vs. helper
;;; status.

(defun file-source-location (code-location)
  (if (code-location-has-debug-block-info-p code-location)
      (source-file-source-location code-location)
      (fallback-source-location code-location)))

(defun fallback-source-location (code-location)
  (let ((fun (code-location-debug-fun-fun code-location)))
    (cond (fun (function-source-location fun))
          (t (error "Cannot find source location for: ~A " code-location)))))

(defun lisp-source-location (code-location)
  (let ((source (prin1-to-string
                 (sb-debug::code-location-source-form code-location 100)))
        (condition swank:*swank-debugger-condition*))
    (if (and (typep condition 'sb-impl::step-form-condition)
             (search "SB-IMPL::WITH-STEPPING-ENABLED" source
                     :test #'char-equal)
             (search "SB-IMPL::STEP-FINISHED" source :test #'char-equal))
        ;; The initial form is utterly uninteresting -- and almost
        ;; certainly right there in the REPL.
        (make-error-location "Stepping...")
        (make-location `(:source-form ,source) '(:position 1)))))

(defun emacs-buffer-source-location (code-location plist)
  (if (code-location-has-debug-block-info-p code-location)
      (destructuring-bind (&key emacs-buffer emacs-position emacs-string
                                &allow-other-keys)
          plist
        (let* ((pos (string-source-position code-location emacs-string))
               (snipped (read-snippet-from-string emacs-string pos)))
          (make-location `(:buffer ,emacs-buffer)
                         `(:offset ,emacs-position ,pos)
                         `(:snippet ,snipped))))
      (fallback-source-location code-location)))

(defun source-file-source-location (code-location)
  (let* ((code-date (code-location-debug-source-created code-location))
         (filename (code-location-debug-source-name code-location))
         (*readtable* (guess-readtable-for-filename filename))
         (source-code (get-source-code filename code-date)))
    (with-debootstrapping
      (with-input-from-string (s source-code)
        (let* ((pos (stream-source-position code-location s))
               (snippet (read-snippet s pos)))
          (make-location `(:file ,filename)
                         `(:position ,pos)
                         `(:snippet ,snippet)))))))

(defun code-location-debug-source-name (code-location)
  (namestring (truename (#.(swank/backend:choose-symbol
                            'sb-c 'debug-source-name
                            'sb-c 'debug-source-namestring)
                           (sb-di::code-location-debug-source code-location)))))

(defun code-location-debug-source-created (code-location)
  (sb-c::debug-source-created
   (sb-di::code-location-debug-source code-location)))

(defun code-location-debug-fun-fun (code-location)
  (sb-di:debug-fun-fun (sb-di:code-location-debug-fun code-location)))

(defun code-location-has-debug-block-info-p (code-location)
  (handler-case
      (progn (sb-di:code-location-debug-block code-location)
             t)
    (sb-di:no-debug-blocks  () nil)))

(defun stream-source-position (code-location stream)
  (let* ((cloc (sb-debug::maybe-block-start-location code-location))
         (tlf-number (sb-di::code-location-toplevel-form-offset cloc))
         (form-number (sb-di::code-location-form-number cloc)))
    (multiple-value-bind (tlf pos-map) (read-source-form tlf-number stream)
      (let* ((path-table (sb-di::form-number-translations tlf 0))
             (path (cond ((<= (length path-table) form-number)
                          (warn "inconsistent form-number-translations")
                          (list 0))
                         (t
                          (reverse (cdr (aref path-table form-number)))))))
        (source-path-source-position path tlf pos-map)))))

(defun string-source-position (code-location string)
  (with-input-from-string (s string)
    (stream-source-position code-location s)))

;;; source-path-file-position and friends are in source-path-parser

(defimplementation frame-source-location (index)
  (converting-errors-to-error-location
    (code-location-source-location
     (sb-di:frame-code-location (nth-frame index)))))

(defvar *keep-non-valid-locals* nil)

(defun frame-debug-vars (frame)
  "Return a vector of debug-variables in frame."
  (let ((all-vars (sb-di::debug-fun-debug-vars (sb-di:frame-debug-fun frame))))
    (cond (*keep-non-valid-locals* all-vars)
          (t (let ((loc (sb-di:frame-code-location frame)))
               (remove-if (lambda (var)
                            (ecase (sb-di:debug-var-validity var loc)
                              (:valid nil)
                              ((:invalid :unknown) t)))
                          all-vars))))))

(defun debug-var-value (var frame location)
  (ecase (sb-di:debug-var-validity var location)
    (:valid (sb-di:debug-var-value var frame))
    ((:invalid :unknown) ':<not-available>)))

(defun debug-var-info (var)
  Introduced by SBCL 1.0.49.76 .
  (let ((s (find-symbol "DEBUG-VAR-INFO" :sb-di)))
    (when (and s (fboundp s))
      (funcall s var))))

(defimplementation frame-locals (index)
  (let* ((frame (nth-frame index))
         (loc (sb-di:frame-code-location frame))
         (vars (frame-debug-vars frame))
  Since  1.0.49.76 PREPROCESS - FOR - EVAL understands SB - DEBUG::MORE
         ;; specially.
         (more-name (or (find-symbol "MORE" :sb-debug) 'more))
         (more-context nil)
         (more-count nil))
    (when vars
      (let ((locals
              (loop for v across vars
                    unless 
                    (case (debug-var-info v)
                      (:more-context
                       (setf more-context (debug-var-value v frame loc))
                       t)
                      (:more-count
                       (setf more-count (debug-var-value v frame loc))
                       t))
                    collect
                    (list :name (sb-di:debug-var-symbol v)
                          :id (sb-di:debug-var-id v)
                          :value (debug-var-value v frame loc)))))
        (when (and more-context more-count)
          (setf locals (append locals
                               (list
                                (list :name more-name
                                      :id 0
                                      :value (multiple-value-list
                                              (sb-c:%more-arg-values
                                               more-context
                                               0 more-count)))))))
        locals))))

(defimplementation frame-var-value (frame var)
  (let* ((frame (nth-frame frame))
         (vars (frame-debug-vars frame))
         (loc (sb-di:frame-code-location frame))
         (dvar (if (= var (length vars))
  If VAR is out of bounds , it must be the fake var
                   ;; we made up for &MORE.
                   (let* ((context-var (find :more-context vars
                                             :key #'debug-var-info))
                          (more-context (debug-var-value context-var frame
                                                         loc))
                          (count-var (find :more-count vars
                                           :key #'debug-var-info))
                          (more-count (debug-var-value count-var frame loc)))
                     (return-from frame-var-value
                       (multiple-value-list (sb-c:%more-arg-values
                                             more-context
                                             0 more-count))))
                   (aref vars var))))
    (debug-var-value dvar frame loc)))

(defimplementation frame-catch-tags (index)
  (mapcar #'car (sb-di:frame-catches (nth-frame index))))

(defimplementation eval-in-frame (form index)
  (let ((frame (nth-frame index)))
    (funcall (the function
               (sb-di:preprocess-for-eval form
                                          (sb-di:frame-code-location frame)))
             frame)))

(defimplementation frame-package (frame-number)
  (let* ((frame (nth-frame frame-number))
         (fun (sb-di:debug-fun-fun (sb-di:frame-debug-fun frame))))
    (when fun
      (let ((name (function-name fun)))
        (typecase name
          (null nil)
          (symbol (symbol-package name))
          ((cons (eql setf) (cons symbol)) (symbol-package (cadr name))))))))

#+#.(swank/sbcl::sbcl-with-restart-frame)
(progn
  (defimplementation return-from-frame (index form)
    (let* ((frame (nth-frame index)))
      (cond ((sb-debug:frame-has-debug-tag-p frame)
             (let ((values (multiple-value-list (eval-in-frame form index))))
               (sb-debug:unwind-to-frame-and-call frame
                                                   (lambda ()
                                                     (values-list values)))))
            (t (format nil "Cannot return from frame: ~S" frame)))))

  (defimplementation restart-frame (index)
    (let ((frame (nth-frame index)))
      (when (sb-debug:frame-has-debug-tag-p frame)
        (multiple-value-bind (fname args) (sb-debug::frame-call frame)
          (multiple-value-bind (fun arglist)
              (if (and (sb-int:legal-fun-name-p fname) (fboundp fname))
                  (values (fdefinition fname) args)
                  (values (sb-di:debug-fun-fun (sb-di:frame-debug-fun frame))
                          (sb-debug::frame-args-as-list frame)))
            (when (functionp fun)
              (sb-debug:unwind-to-frame-and-call
               frame
               (lambda ()
                 ;; Ensure TCO.
                 (declare (optimize (debug 0)))
                 (apply fun arglist)))))))
      (format nil "Cannot restart frame: ~S" frame))))

;; FIXME: this implementation doesn't unwind the stack before
;; re-invoking the function, but it's better than no implementation at
;; all.
#-#.(swank/sbcl::sbcl-with-restart-frame)
(progn
  (defun sb-debug-catch-tag-p (tag)
    (and (symbolp tag)
         (not (symbol-package tag))
         (string= tag :sb-debug-catch-tag)))

  (defimplementation return-from-frame (index form)
    (let* ((frame (nth-frame index))
           (probe (assoc-if #'sb-debug-catch-tag-p
                            (sb-di::frame-catches frame))))
      (cond (probe (throw (car probe) (eval-in-frame form index)))
            (t (format nil "Cannot return from frame: ~S" frame)))))

  (defimplementation restart-frame (index)
    (let ((frame (nth-frame index)))
      (return-from-frame index (sb-debug::frame-call-as-list frame)))))

;;;;; reference-conditions

(defimplementation print-condition (condition stream)
  (let ((sb-int:*print-condition-references* nil))
    (princ condition stream)))


;;;; Profiling

(defimplementation profile (fname)
  (when fname (eval `(sb-profile:profile ,fname))))

(defimplementation unprofile (fname)
  (when fname (eval `(sb-profile:unprofile ,fname))))

(defimplementation unprofile-all ()
  (sb-profile:unprofile)
  "All functions unprofiled.")

(defimplementation profile-report ()
  (sb-profile:report))

(defimplementation profile-reset ()
  (sb-profile:reset)
  "Reset profiling counters.")

(defimplementation profiled-functions ()
  (sb-profile:profile))

(defimplementation profile-package (package callers methods)
  (declare (ignore callers methods))
  (eval `(sb-profile:profile ,(package-name (find-package package)))))


;;;; Inspector

(defmethod emacs-inspect ((o t))
  (cond ((sb-di::indirect-value-cell-p o)
         (label-value-line* (:value (sb-kernel:value-cell-ref o))))
	(t
         (multiple-value-bind (text label parts) (sb-impl::inspected-parts o)
           (list* (string-right-trim '(#\Newline) text)
                  '(:newline)
                  (if label
                      (loop for (l . v) in parts
                            append (label-value-line l v))
                      (loop for value in parts
                            for i from 0
                            append (label-value-line i value))))))))

(defmethod emacs-inspect ((o function))
    (cond ((sb-kernel:simple-fun-p o)
                   (label-value-line*
                    (:name (sb-kernel:%simple-fun-name o))
                    (:arglist (sb-kernel:%simple-fun-arglist o))
                    (:next (sb-kernel:%simple-fun-next o))
                    (:type (sb-kernel:%simple-fun-type o))
                    (:code (sb-kernel:fun-code-header o))))
          ((sb-kernel:closurep o)
                   (append
                    (label-value-line :function (sb-kernel:%closure-fun o))
                    `("Closed over values:" (:newline))
                    (loop for i below (1- (sb-kernel:get-closure-length o))
                          append (label-value-line
                                  i (sb-kernel:%closure-index-ref o i)))))
          (t (call-next-method o))))

(defmethod emacs-inspect ((o sb-kernel:code-component))
  (append
   (label-value-line*
    (:code-size (sb-kernel:%code-code-size o))
    (:entry-points (sb-kernel:%code-entry-points o))
    (:debug-info (sb-kernel:%code-debug-info o)))
   `("Constants:" (:newline))
   (loop for i from sb-vm:code-constants-offset
         below
         (#.(swank/backend:choose-symbol 'sb-kernel 'code-header-words
                                         'sb-kernel 'get-header-data)
            o)
         append (label-value-line i (sb-kernel:code-header-ref o i)))
   `("Code:" (:newline)
             ,(with-output-to-string (s)
                (sb-disassem:disassemble-code-component o :stream s)))))

(defmethod emacs-inspect ((o sb-ext:weak-pointer))
          (label-value-line*
           (:value (sb-ext:weak-pointer-value o))))

(defmethod emacs-inspect ((o sb-kernel:fdefn))
          (label-value-line*
           (:name (sb-kernel:fdefn-name o))
           (:function (sb-kernel:fdefn-fun o))))

(defmethod emacs-inspect :around ((o generic-function))
            (append
             (call-next-method)
             (label-value-line*
              (:pretty-arglist (sb-pcl::generic-function-pretty-arglist o))
              (:initial-methods (sb-pcl::generic-function-initial-methods o))
              )))


;;;; Multiprocessing

#+(and sb-thread
       #.(swank/backend:with-symbol "THREAD-NAME" "SB-THREAD"))
(progn
  (defvar *thread-id-counter* 0)

  (defvar *thread-id-counter-lock*
    (sb-thread:make-mutex :name "thread id counter lock"))

  (defun next-thread-id ()
    (sb-thread:with-mutex (*thread-id-counter-lock*)
      (incf *thread-id-counter*)))

  (defparameter *thread-id-map* (make-hash-table))

  ;; This should be a thread -> id map but as weak keys are not
  ;; supported it is id -> map instead.
  (defvar *thread-id-map-lock*
    (sb-thread:make-mutex :name "thread id map lock"))

  (defimplementation spawn (fn &key name)
    (sb-thread:make-thread fn :name name))

  (defimplementation thread-id (thread)
    (block thread-id
      (sb-thread:with-mutex (*thread-id-map-lock*)
        (loop for id being the hash-key in *thread-id-map*
              using (hash-value thread-pointer)
              do
              (let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer)))
                (cond ((null maybe-thread)
  the value is gc'd , remove it manually
                       (remhash id *thread-id-map*))
                      ((eq thread maybe-thread)
                       (return-from thread-id id)))))
        ;; lazy numbering
        (let ((id (next-thread-id)))
          (setf (gethash id *thread-id-map*) (sb-ext:make-weak-pointer thread))
          id))))

  (defimplementation find-thread (id)
    (sb-thread:with-mutex (*thread-id-map-lock*)
      (let ((thread-pointer (gethash id *thread-id-map*)))
        (if thread-pointer
            (let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer)))
              (if maybe-thread
                  maybe-thread
  the value is gc'd , remove it manually
                  (progn
                    (remhash id *thread-id-map*)
                    nil)))
            nil))))

  (defimplementation thread-name (thread)
  sometimes the name is not a string ( e.g. NIL )
    (princ-to-string (sb-thread:thread-name thread)))

  (defimplementation thread-status (thread)
    (if (sb-thread:thread-alive-p thread)
        "Running"
        "Stopped"))

  (defimplementation make-lock (&key name)
    (sb-thread:make-mutex :name name))

  (defimplementation call-with-lock-held (lock function)
    (declare (type function function))
    (sb-thread:with-recursive-lock (lock) (funcall function)))

  (defimplementation current-thread ()
    sb-thread:*current-thread*)

  (defimplementation all-threads ()
    (sb-thread:list-all-threads))

  (defimplementation interrupt-thread (thread fn)
    (sb-thread:interrupt-thread thread fn))

  (defimplementation kill-thread (thread)
    (sb-thread:terminate-thread thread))

  (defimplementation thread-alive-p (thread)
    (sb-thread:thread-alive-p thread))

  (defvar *mailbox-lock* (sb-thread:make-mutex :name "mailbox lock"))
  (defvar *mailboxes* (list))
  (declaim (type list *mailboxes*))

  (defstruct (mailbox (:conc-name mailbox.))
    thread
    (mutex (sb-thread:make-mutex))
    (waitqueue  (sb-thread:make-waitqueue))
    (queue '() :type list))

  (defun mailbox (thread)
    "Return THREAD's mailbox."
    (sb-thread:with-mutex (*mailbox-lock*)
      (or (find thread *mailboxes* :key #'mailbox.thread)
          (let ((mb (make-mailbox :thread thread)))
            (push mb *mailboxes*)
            mb))))

  (defimplementation wake-thread (thread)
    (let* ((mbox (mailbox thread))
           (mutex (mailbox.mutex mbox)))
      (sb-thread:with-recursive-lock (mutex)
        (sb-thread:condition-broadcast (mailbox.waitqueue mbox)))))

  (defimplementation send (thread message)
    (let* ((mbox (mailbox thread))
           (mutex (mailbox.mutex mbox)))
      (sb-thread:with-mutex (mutex)
        (setf (mailbox.queue mbox)
              (nconc (mailbox.queue mbox) (list message)))
        (sb-thread:condition-broadcast (mailbox.waitqueue mbox)))))
  
  (defimplementation receive-if (test &optional timeout)
    (let* ((mbox (mailbox (current-thread)))
           (mutex (mailbox.mutex mbox))
           (waitq (mailbox.waitqueue mbox)))
      (assert (or (not timeout) (eq timeout t)))
      (loop
       (check-slime-interrupts)
       (sb-thread:with-mutex (mutex)
         (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)))
         (sb-thread:condition-wait waitq mutex)))))

  (let ((alist '())
        (mutex (sb-thread:make-mutex :name "register-thread")))

    (defimplementation register-thread (name thread)
      (declare (type symbol name))
      (sb-thread:with-mutex (mutex)
        (etypecase thread
          (null
           (setf alist (delete name alist :key #'car)))
          (sb-thread:thread
           (let ((probe (assoc name alist)))
             (cond (probe (setf (cdr probe) thread))
                   (t (setf alist (acons name thread alist))))))))
      nil)

    (defimplementation find-registered (name)
      (sb-thread:with-mutex (mutex)
        (cdr (assoc name alist))))))

(defimplementation quit-lisp ()
  #+#.(swank/backend:with-symbol 'exit 'sb-ext)
  (sb-ext:exit)
  #-#.(swank/backend:with-symbol 'exit 'sb-ext)
  (progn
    #+sb-thread
    (dolist (thread (remove (current-thread) (all-threads)))
      (ignore-errors (sb-thread:terminate-thread thread)))
    (sb-ext:quit)))



Trace implementations
In  , we have :
;; (trace <name>)
;; (trace :methods '<name>) ;to trace all methods of the gf <name>
;; (trace (method <name> <qualifier>? (<specializer>+)))
  < name > can be a normal name or a ( setf name )

(defun toggle-trace-aux (fspec &rest args)
  (cond ((member fspec (eval '(trace)) :test #'equal)
         (eval `(untrace ,fspec))
         (format nil "~S is now untraced." fspec))
        (t
         (eval `(trace ,@(if args `(:encapsulate nil) (list)) ,fspec ,@args))
         (format nil "~S is now traced." fspec))))

(defun process-fspec (fspec)
  (cond ((consp fspec)
         (ecase (first fspec)
           ((:defun :defgeneric) (second fspec))
           ((:defmethod) `(method ,@(rest fspec)))
           ((:labels) `(labels ,(process-fspec (second fspec)) ,(third fspec)))
           ((:flet) `(flet ,(process-fspec (second fspec)) ,(third fspec)))))
        (t
         fspec)))

(defimplementation toggle-trace (spec)
  (ecase (car spec)
    ((setf)
     (toggle-trace-aux spec))
    ((:defmethod)
     (toggle-trace-aux `(sb-pcl::fast-method ,@(rest (process-fspec spec)))))
    ((:defgeneric)
     (toggle-trace-aux (second spec) :methods t))
    ((:call)
     (destructuring-bind (caller callee) (cdr spec)
       (toggle-trace-aux callee :wherein (list (process-fspec caller)))))))

;;; Weak datastructures

(defimplementation make-weak-key-hash-table (&rest args)
  #+#.(swank/sbcl::sbcl-with-weak-hash-tables)
  (apply #'make-hash-table :weakness :key args)
  #-#.(swank/sbcl::sbcl-with-weak-hash-tables)
  (apply #'make-hash-table args))

(defimplementation make-weak-value-hash-table (&rest args)
  #+#.(swank/sbcl::sbcl-with-weak-hash-tables)
  (apply #'make-hash-table :weakness :value args)
  #-#.(swank/sbcl::sbcl-with-weak-hash-tables)
  (apply #'make-hash-table args))

(defimplementation hash-table-weakness (hashtable)
  #+#.(swank/sbcl::sbcl-with-weak-hash-tables)
  (sb-ext:hash-table-weakness hashtable))

;;; Floating point

(defimplementation float-nan-p (float)
  (sb-ext:float-nan-p float))

(defimplementation float-infinity-p (float)
  (sb-ext:float-infinity-p float))

#-win32
(defimplementation save-image (filename &optional restart-function)
  (flet ((restart-sbcl ()
           (sb-debug::enable-debugger)
           (setf sb-impl::*descriptor-handlers* nil)
           (funcall restart-function)))
    (let ((pid (sb-posix:fork)))
      (cond ((= pid 0)
             (sb-debug::disable-debugger)
             (apply #'sb-ext:save-lisp-and-die filename
                    (when restart-function
                      (list :toplevel #'restart-sbcl))))
            (t
             (multiple-value-bind (rpid status) (sb-posix:waitpid pid 0)
               (assert (= pid rpid))
               (assert (and (sb-posix:wifexited status)
                            (zerop (sb-posix:wexitstatus status))))))))))

#+unix
(progn
  (sb-alien:define-alien-routine ("execv" sys-execv) sb-alien:int
    (program sb-alien:c-string)
    (argv (* sb-alien:c-string)))

  (defun execv (program args)
    "Replace current executable with another one."
    (let ((a-args (sb-alien:make-alien sb-alien:c-string
                                       (+ 1 (length args)))))
      (unwind-protect
           (progn
             (loop for index from 0 by 1
                   and item in (append args '(nil))
                   do (setf (sb-alien:deref a-args index)
                            item))
             (when (minusp
                    (sys-execv program a-args))
               (error "execv(3) returned.")))
        (sb-alien:free-alien a-args))))

  (defun runtime-pathname ()
    #+#.(swank/backend:with-symbol
            '*runtime-pathname* 'sb-ext)
    sb-ext:*runtime-pathname*
    #-#.(swank/backend:with-symbol
            '*runtime-pathname* 'sb-ext)
    (car sb-ext:*posix-argv*))

  (defimplementation exec-image (image-file args)
    (loop with fd-arg =
          (loop for arg in args
                and key = "" then arg
                when (string-equal key "--swank-fd")
                return (parse-integer arg))
          for my-fd from 3 to 1024
          when (/= my-fd fd-arg)
          do (ignore-errors (sb-posix:fcntl my-fd sb-posix:f-setfd 1)))
    (let* ((self-string (pathname-to-filename (runtime-pathname))))
      (execv
       self-string
       (apply 'list self-string "--core" image-file args)))))

(defimplementation make-fd-stream (fd external-format)
  (sb-sys:make-fd-stream fd :input t :output t
                         :element-type 'character
                         :buffering :full
                         :dual-channel-p t
                         :external-format external-format))

#-win32
(defimplementation background-save-image (filename &key restart-function
                                                   completion-function)
  (flet ((restart-sbcl ()
           (sb-debug::enable-debugger)
           (setf sb-impl::*descriptor-handlers* nil)
           (funcall restart-function)))
    (multiple-value-bind (pipe-in pipe-out) (sb-posix:pipe)
      (let ((pid (sb-posix:fork)))
        (cond ((= pid 0)
               (sb-posix:close pipe-in)
               (sb-debug::disable-debugger)
               (apply #'sb-ext:save-lisp-and-die filename
                      (when restart-function
                        (list :toplevel #'restart-sbcl))))
              (t
               (sb-posix:close pipe-out)
               (sb-sys:add-fd-handler
                pipe-in :input
                (lambda (fd)
                  (sb-sys:invalidate-descriptor fd)
                  (sb-posix:close fd)
                  (multiple-value-bind (rpid status) (sb-posix:waitpid pid 0)
                    (assert (= pid rpid))
                    (assert (sb-posix:wifexited status))
                    (funcall completion-function
                             (zerop (sb-posix:wexitstatus status))))))))))))

(pushnew 'deinit-log-output sb-ext:*save-hooks*)


;;;; wrap interface implementation

(defun sbcl-version>= (&rest subversions)
  #+#.(swank/backend:with-symbol 'assert-version->= 'sb-ext)
  (values (ignore-errors (apply #'sb-ext:assert-version->= subversions) t))
  #-#.(swank/backend:with-symbol 'assert-version->= 'sb-ext)
  nil)

(defimplementation wrap (spec indicator &key before after replace)
  (when (wrapped-p spec indicator)
    (warn "~a already wrapped with indicator ~a, unwrapping first"
          spec indicator)
    (sb-int:unencapsulate spec indicator))
  (sb-int:encapsulate spec indicator
                      #-#.(swank/backend:with-symbol 'arg-list 'sb-int)
                      (lambda (function &rest args)
                        (sbcl-wrap spec before after replace function args))
                      #+#.(swank/backend:with-symbol 'arg-list 'sb-int)
                      (if (sbcl-version>= 1 1 16)
                          (lambda ()
                            (sbcl-wrap spec before after replace
                                       (symbol-value 'sb-int:basic-definition)
                                       (symbol-value 'sb-int:arg-list)))
                          `(sbcl-wrap ',spec ,before ,after ,replace
                                      (symbol-value 'sb-int:basic-definition)
                                      (symbol-value 'sb-int:arg-list)))))

(defimplementation unwrap (spec indicator)
  (sb-int:unencapsulate spec indicator))

(defimplementation wrapped-p (spec indicator)
  (sb-int:encapsulated-p spec indicator))

(defun sbcl-wrap (spec before after replace function args)
  (declare (ignore spec))
  (let (retlist completed)
    (unwind-protect
         (progn
           (when before
             (funcall before args))
           (setq retlist (multiple-value-list (if replace
                                                  (funcall replace
                                                           args)
                                                  (apply function args))))
           (setq completed t)
           (values-list retlist))
      (when after
        (funcall after (if completed retlist :exited-non-locally))))))

#+#.(swank/backend:with-symbol 'comma-expr 'sb-impl)
(progn
  (defmethod sexp-in-bounds-p ((s sb-impl::comma) i)
    (= i 1))

  (defmethod sexp-ref ((s sb-impl::comma) i)
    (sb-impl::comma-expr s)))

 -*- indent-tabs-mode: nil -*-



 This code has been placed in the Public Domain.  All warranties are
 disclaimed.
 Requires the SB-INTROSPECT contrib.
 backwards compability tests
 Generate a form suitable for testing for stepper support (0.9.17)
 with #+.
 Ditto for weak hash-tables
 swank-mop
 stream support
 Pretty printer calls this, apparently
 Declare return type explicitly to shut up STYLE-WARNINGS about
 UTF8
 TCP Server
 this.
 get all IPv4 and IPv6 addresses as a list
 remove protocols for which we don't have an address
 but actually, it shouln't return nil, because
 get-host-by-name will signal NAME-SERVICE-ERROR condition
 if there isn't any address for the host.
 anybody uses it.
 prevent recursion
 still open?
 argument.
 containing `!' have special meaning.  We have to work long and
 hard to be able to read the source.  To deal with #! reader
 macros, we use a special readtable.  The special symbols are
 converted by a condition handler.
 don't need to handle it or anything else appearing in
 the future or in erronous code.
 When test is not satisfied
 FIXME: clearer if order of NOT-P and (NOT NOT-P) were reversed? then
 would become "unless test is satisfied"..
 Read (and discard) a form from input.
 Packages
 Symbols aren't printed with package qualifiers, but the
 declaration. So we strip those as long as there's no
 better way. (FIXME)
 First resignal warnings, so that outer handlers -- which may choose to
 muffle this -- get a chance to run.
 The stream position for e.g. "comma not inside
 backquote" is at the character following the
 comma, :offset is 0-based, hence the 1-.
 The following is to trigger COMPILING-FROM-GENERATED-CODE-P
 in LOCATE-COMPILER-NOTE, and allows handling nested
 compilation from eg. hitting C-C on (eval-when ... (require ..))).

 PROBE-FILE to handle tempfile directory being a symlink.
 N.B. Even though these handlers are called HANDLE-FOO they
 actually decline, i.e. the signalling of the original
 condition continues upward.
 SB-EXT:RESTRICT-COMPILER-POLICY would signal an error when there
 were no policy restrictions in place. This workaround ensures the
 Cache the latest source file for definition-finding.
 compile-string
 We copy the string to a temporary file in order to get adequate
 semantics for :COMPILE-TOPLEVEL and :LOAD-TOPLEVEL EVAL-WHEN forms
 which the previous approach using
     (compile nil `(lambda () ,(read-from-string string)))
 did not provide.
 Definitions
 Packages are possibly named entities.
 Use read-from-string instead of intern so that
 conc-name can be a string such as ext:struct- and not
 cause errors and not force interning ext::struct-
 /file positions/ in Common Lisp start from
 macroexpansion
 Debugging
 than just a hook into BREAK. In particular, it'll make
 (LET ((*DEBUGGER-HOOK* NIL)) ..error..) drop into SLDB rather
 than the native debugger. That should probably be considered a
 feature.
 decline, *DEBUGGER-HOOK* will be tried next.
 Code-location -> source-location translation
 If debug-block info is avaibale, we determine the file position of
 the source-path for a code-location.  If the code was compiled
 If there's no debug-block info, we return the (less precise)
 source-location of the corresponding function.
 FIXME: The naming policy of source-location functions is a bit
 fuzzy: we have FUNCTION-SOURCE-LOCATION which returns the
 which returns the source location for a _code-location_.

 Maybe these should be named code-location-file-source-location,
 etc, turned into generic functions, or something. In the very
 least the names should indicate the main entry point vs. helper
 status.
 The initial form is utterly uninteresting -- and almost
 certainly right there in the REPL.
 source-path-file-position and friends are in source-path-parser
 specially.
 we made up for &MORE.
 Ensure TCO.
 FIXME: this implementation doesn't unwind the stack before
 re-invoking the function, but it's better than no implementation at
 all.
 reference-conditions
 Profiling
 Inspector
 Multiprocessing
 This should be a thread -> id map but as weak keys are not
 supported it is id -> map instead.
 lazy numbering
 (trace <name>)
 (trace :methods '<name>) ;to trace all methods of the gf <name>
 (trace (method <name> <qualifier>? (<specializer>+)))
 Weak datastructures
 Floating point
 wrap interface implementation
  swank-sbcl.lisp --- SLIME backend for SBCL .
  Created 2003 ,   <  >


  Administrivia

(defpackage swank/sbcl
  (:use cl swank/backend swank/source-path-parser swank/source-file-cache))

(in-package swank/sbcl)

(eval-when (:compile-toplevel :load-toplevel :execute)
  (require 'sb-bsd-sockets)
  (require 'sb-introspect)
  (require 'sb-posix)
  (require 'sb-cltl2))

(declaim (optimize (debug 2)
                   (sb-c::insert-step-conditions 0)
                   (sb-c::insert-debug-catch 0)))


(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun sbcl-with-new-stepper-p ()
    (with-symbol 'enable-stepping 'sb-impl))
  (defun sbcl-with-weak-hash-tables ()
    (with-symbol 'hash-table-weakness 'sb-ext))
  And for xref support ( 1.0.1 )
  (defun sbcl-with-xref-p ()
    (with-symbol 'who-calls 'sb-introspect))
  ... for restart - frame support ( 1.0.2 )
  (defun sbcl-with-restart-frame ()
    (with-symbol 'frame-has-debug-tag-p 'sb-debug))
  ... for : setf : inverse info ( 1.1.17 )
  (defun sbcl-with-setf-inverse-meta-info ()
    (boolean-to-feature-expression
  going through FIND - SYMBOL since META - INFO was renamed from
  TYPE - INFO in 1.2.10 .
     (let ((sym (find-symbol "META-INFO" "SB-C")))
       (and sym
            (fboundp sym)
            (funcall sym :setf :inverse ()))))))


(import-swank-mop-symbols :sb-mop '(:slot-definition-documentation))

(defun swank-mop:slot-definition-documentation (slot)
  (sb-pcl::documentation slot t))


(defimplementation gray-package-name ()
  "SB-GRAY")

(defmethod sb-gray:stream-line-length
    ((s sb-gray:fundamental-character-input-stream))
  nil)

  Connection info

(defimplementation lisp-implementation-type-name ()
  "sbcl")

  % SAP - ALIEN in ENABLE - SIGIO - ON - FD below .
(declaim (ftype (function () (values (signed-byte 32) &optional)) getpid))
(defimplementation getpid ()
  (sb-posix:getpid))


(defimplementation string-to-utf8 (string)
  (sb-ext:string-to-octets string :external-format :utf8))

(defimplementation utf8-to-string (octets)
  (sb-ext:octets-to-string octets :external-format :utf8))


(defimplementation preferred-communication-style ()
  (cond
  fixme : when SBCL / win32 gains better select ( ) support , remove
    ((member :sb-thread *features*) :spawn)
    ((member :win32 *features*) nil)
    (t :fd-handler)))


(defun resolve-hostname (host)
  "Returns valid IPv4 or IPv6 address for the host."
  (let* ((host-ents (multiple-value-list (sb-bsd-sockets:get-host-by-name host)))
         (addresses (remove-if-not #'sb-bsd-sockets:host-ent-address host-ents)))
  Return the first one or nil ,
    (first addresses)))


(defimplementation create-socket (host port &key backlog)
  (let* ((host-ent (resolve-hostname host))
         (socket (make-instance (cond #+#.(swank/backend:with-symbol 'inet6-socket 'sb-bsd-sockets)
                                      ((eql (sb-bsd-sockets:host-ent-address-type host-ent) 10)
                                       'sb-bsd-sockets:inet6-socket)
                                      (t
                                       'sb-bsd-sockets:inet-socket))
                                :type :stream
                                :protocol :tcp)))
    (setf (sb-bsd-sockets:sockopt-reuse-address socket) t)
    (sb-bsd-sockets:socket-bind socket (sb-bsd-sockets:host-ent-address host-ent) port)

    (sb-bsd-sockets:socket-listen socket (or backlog 5))
    socket))

(defimplementation local-port (socket)
  (nth-value 1 (sb-bsd-sockets:socket-name socket)))

(defimplementation close-socket (socket)
  (sb-sys:invalidate-descriptor (socket-fd socket))
  (sb-bsd-sockets:socket-close socket))

(defimplementation accept-connection (socket &key
                                      external-format
                                      buffering timeout)
  (declare (ignore timeout))
  (make-socket-io-stream (accept socket) external-format
                         (ecase buffering
                           ((t :full) :full)
                           ((nil :none) :none)
                           ((:line) :line))))


  The  stuff should probably be removed as it 's unlikey that
#-win32
(progn
  (defimplementation install-sigint-handler (function)
    (sb-sys:enable-interrupt sb-unix:sigint
                             (lambda (&rest args)
                               (declare (ignore args))
                               (sb-sys:invoke-interruption
                                (lambda ()
                                  (sb-sys:with-interrupts
                                    (funcall function)))))))

  (defvar *sigio-handlers* '()
    "List of (key . fn) pairs to be called on SIGIO.")

  (defun sigio-handler (signal code scp)
    (declare (ignore signal code scp))
    (sb-sys:with-interrupts
      (mapc (lambda (handler)
              (funcall (the function (cdr handler))))
            *sigio-handlers*)))

  (defun set-sigio-handler ()
    (sb-sys:enable-interrupt sb-unix:sigio #'sigio-handler))

  (defun enable-sigio-on-fd (fd)
    (sb-posix::fcntl fd sb-posix::f-setfl sb-posix::o-async)
    (sb-posix::fcntl fd sb-posix::f-setown (getpid))
    (values))

  (defimplementation add-sigio-handler (socket fn)
    (set-sigio-handler)
    (let ((fd (socket-fd socket)))
      (enable-sigio-on-fd fd)
      (push (cons fd fn) *sigio-handlers*)))

  (defimplementation remove-sigio-handlers (socket)
    (let ((fd (socket-fd socket)))
      (setf *sigio-handlers* (delete fd *sigio-handlers* :key #'car))
      (sb-sys:invalidate-descriptor fd))
    (close socket)))


(defimplementation add-fd-handler (socket fun)
  (let ((fd (socket-fd socket))
        (handler nil))
    (labels ((add ()
               (setq handler (sb-sys:add-fd-handler fd :input #'run)))
             (run (fd)
               (unwind-protect
                    (funcall fun)
                   (add)))))
      (add))))

(defimplementation remove-fd-handlers (socket)
  (sb-sys:invalidate-descriptor (socket-fd socket)))

(defimplementation socket-fd (socket)
  (etypecase socket
    (fixnum socket)
    (sb-bsd-sockets:socket (sb-bsd-sockets:socket-file-descriptor socket))
    (file-stream (sb-sys:fd-stream-fd socket))))

(defimplementation command-line-args ()
  sb-ext:*posix-argv*)

(defimplementation dup (fd)
  (sb-posix:dup fd))

(defvar *wait-for-input-called*)

(defimplementation wait-for-input (streams &optional timeout)
  (assert (member timeout '(nil t)))
  (when (boundp '*wait-for-input-called*)
    (setq *wait-for-input-called* t))
  (let ((*wait-for-input-called* nil))
    (loop
      (let ((ready (remove-if-not #'input-ready-p streams)))
        (when ready (return ready)))
      (when (check-slime-interrupts)
        (return :interrupt))
      (when *wait-for-input-called*
        (return :interrupt))
      (when timeout
        (return nil))
      (sleep 0.1))))

(defun fd-stream-input-buffer-empty-p (stream)
  (let ((buffer (sb-impl::fd-stream-ibuf stream)))
    (or (not buffer)
        (= (sb-impl::buffer-head buffer)
           (sb-impl::buffer-tail buffer)))))

#-win32
(defun input-ready-p (stream)
  (or (not (fd-stream-input-buffer-empty-p stream))
      #+#.(swank/backend:with-symbol 'fd-stream-fd-type 'sb-impl)
      (eq :regular (sb-impl::fd-stream-fd-type stream))
      (not (sb-impl::sysread-may-block-p stream))))

#+win32
(progn
  (defun input-ready-p (stream)
    (or (not (fd-stream-input-buffer-empty-p stream))
        (handle-listen (sockint::fd->handle (sb-impl::fd-stream-fd stream)))))

  (sb-alien:define-alien-routine ("WSACreateEvent" wsa-create-event)
      sb-win32:handle)

  (sb-alien:define-alien-routine ("WSACloseEvent" wsa-close-event)
      sb-alien:int
    (event sb-win32:handle))

  (defconstant +fd-read+ #.(ash 1 0))
  (defconstant +fd-close+ #.(ash 1 5))

  (sb-alien:define-alien-routine ("WSAEventSelect" wsa-event-select)
      sb-alien:int
    (fd sb-alien:int)
    (handle sb-win32:handle)
    (mask sb-alien:long))

  (sb-alien:load-shared-object "kernel32.dll")
  (sb-alien:define-alien-routine ("WaitForSingleObjectEx"
                                  wait-for-single-object-ex)
      sb-alien:int
    (event sb-win32:handle)
    (milliseconds sb-alien:long)
    (alertable sb-alien:int))

  see    : HANDLE - LISTEN
  (defun handle-listen (handle)
    (sb-alien:with-alien ((avail sb-win32:dword)
                          (buf (array char #.sb-win32::input-record-size)))
      (unless (zerop (sb-win32:peek-named-pipe handle nil 0 nil
                                               (sb-alien:alien-sap
                                                (sb-alien:addr avail))
                                               nil))
        (return-from handle-listen (plusp avail)))

      (unless (zerop (sb-win32:peek-console-input handle
                                                  (sb-alien:alien-sap buf)
                                                  sb-win32::input-record-size
                                                  (sb-alien:alien-sap
                                                   (sb-alien:addr avail))))
        (return-from handle-listen (plusp avail))))

    (let ((event (wsa-create-event)))
      (wsa-event-select handle event (logior +fd-read+ +fd-close+))
      (let ((val (wait-for-single-object-ex event 0 0)))
        (wsa-close-event event)
        (unless (= val -1)
          (return-from handle-listen (zerop val)))))

    nil)

  )

(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")
    (:us-ascii "us-ascii" "us-ascii-unix")))

  C.f . R.M.Kreuter in <  > on sbcl - general ,
  2008 - 08 - 22 .
(defvar *physical-pathname-host* (pathname-host (user-homedir-pathname)))

(defimplementation filename-to-pathname (filename)
  (sb-ext:parse-native-namestring filename *physical-pathname-host*))

(defimplementation find-external-format (coding-system)
  (car (rassoc-if (lambda (x) (member coding-system x :test #'equal))
                  *external-format-to-coding-system*)))

(defimplementation set-default-directory (directory)
  (let ((directory (truename (merge-pathnames directory))))
    (sb-posix:chdir directory)
    (setf *default-pathname-defaults* directory)
    (default-directory)))

(defun make-socket-io-stream (socket external-format buffering)
  (let ((args `(:output t
                :input t
                :element-type ,(if external-format
                                   'character
                                   '(unsigned-byte 8))
                :buffering ,buffering
                ,@(cond ((and external-format (sb-int:featurep :sb-unicode))
                         `(:external-format ,external-format))
                        (t '()))
                :serve-events ,(eq :fd-handler swank:*communication-style*)
  SBCL < 1.0.42.43 does n't support : SERVE - EVENTS
                :allow-other-keys t)))
  (apply #'sb-bsd-sockets:socket-make-stream socket args)))

(defun accept (socket)
  "Like socket-accept, but retry on EAGAIN."
  (loop (handler-case
            (return (sb-bsd-sockets:socket-accept socket))
          (sb-bsd-sockets:interrupted-error ()))))


  Support for  syntax

  SBCL 's source code is riddled with # ! reader macros .   Also symbols

(defun feature-in-list-p (feature list)
  (etypecase feature
    (symbol (member feature list :test #'eq))
    (cons (flet ((subfeature-in-list-p (subfeature)
                   (feature-in-list-p subfeature list)))
  Do n't use ECASE since SBCL also has : host - feature ,
            (case (first feature)
              (:or  (some  #'subfeature-in-list-p (rest feature)))
              (:and (every #'subfeature-in-list-p (rest feature)))
              (:not (destructuring-bind (e) (cdr feature)
                      (not (subfeature-in-list-p e)))))))))

(defun shebang-reader (stream sub-character infix-parameter)
  (declare (ignore sub-character))
  (when infix-parameter
    (error "illegal read syntax: #~D!" infix-parameter))
  (let ((next-char (read-char stream)))
    (unless (find next-char "+-")
      (error "illegal read syntax: #!~C" next-char))
    (when (let* ((*package* (find-package "KEYWORD"))
                 (*read-suppress* nil)
                 (not-p (char= next-char #\-))
                 (feature (read stream)))
            (if (feature-in-list-p feature *features*)
		not-p
		(not not-p)))
      (let ((*read-suppress* t))
	(read stream t nil t))))
 (values))

(defvar *shebang-readtable*
  (let ((*readtable* (copy-readtable nil)))
    (set-dispatch-macro-character #\# #\!
                                  (lambda (s c n) (shebang-reader s c n))
                                  *readtable*)
    *readtable*))

(defun shebang-readtable ()
  *shebang-readtable*)

(defun sbcl-package-p (package)
  (let ((name (package-name package)))
    (eql (mismatch "SB-" name) 3)))

(defun sbcl-source-file-p (filename)
  (when filename
    (loop for (nil pattern) in (logical-pathname-translations "SYS")
          thereis (pathname-match-p filename pattern))))

(defun guess-readtable-for-filename (filename)
  (if (sbcl-source-file-p filename)
      (shebang-readtable)
      *readtable*))

(defvar *debootstrap-packages* t)

(defun call-with-debootstrapping (fun)
  (handler-bind ((sb-int:bootstrap-package-not-found
                  #'sb-int:debootstrap-package))
    (funcall fun)))

(defmacro with-debootstrapping (&body body)
  `(call-with-debootstrapping (lambda () ,@body)))

(defimplementation call-with-syntax-hooks (fn)
  (cond ((and *debootstrap-packages*
              (sbcl-package-p *package*))
         (with-debootstrapping (funcall fn)))
        (t
         (funcall fn))))

(defimplementation default-readtable-alist ()
  (let ((readtable (shebang-readtable)))
    (loop for p in (remove-if-not #'sbcl-package-p (list-all-packages))
          collect (cons (package-name p) readtable))))


#+#.(swank/backend:with-symbol 'package-local-nicknames 'sb-ext)
(defimplementation package-local-nicknames (package)
  (sb-ext:package-local-nicknames package))

  Utilities

#+#.(swank/backend:with-symbol 'function-lambda-list 'sb-introspect)
(defimplementation arglist (fname)
  (sb-introspect:function-lambda-list fname))

#-#.(swank/backend:with-symbol 'function-lambda-list 'sb-introspect)
(defimplementation arglist (fname)
  (sb-introspect:function-arglist fname))

(defimplementation function-name (f)
  (check-type f function)
  (sb-impl::%fun-name f))

(defmethod declaration-arglist ((decl-identifier (eql 'optimize)))
  (flet ((ensure-list (thing) (if (listp thing) thing (list thing))))
    (let* ((flags (sb-cltl2:declaration-information decl-identifier)))
      (if flags
  FLAGS would have to be fully qualified when used inside a
          `(&any ,@(remove-if-not
                    #'(lambda (qualifier)
                        (find-symbol (symbol-name (first qualifier)) :cl))
                    flags :key #'ensure-list))
          (call-next-method)))))

#+#.(swank/backend:with-symbol 'deftype-lambda-list 'sb-introspect)
(defmethod type-specifier-arglist :around (typespec-operator)
  (multiple-value-bind (arglist foundp)
      (sb-introspect:deftype-lambda-list typespec-operator)
    (if foundp arglist (call-next-method))))

(defimplementation type-specifier-p (symbol)
  (or (sb-ext:valid-type-specifier-p symbol)
      (not (eq (type-specifier-arglist symbol) :not-available))))

(defvar *buffer-name* nil)
(defvar *buffer-tmpfile* nil)
(defvar *buffer-offset*)
(defvar *buffer-substring* nil)

(defvar *previous-compiler-condition* nil
  "Used to detect duplicates.")

(defun handle-notification-condition (condition)
  "Handle a condition caused by a compiler warning.
This traps all compiler conditions at a lower-level than using
C:*COMPILER-NOTIFICATION-FUNCTION*. The advantage is that we get to
craft our own error messages, which can omit a lot of redundant
information."
  (unless (or (eq condition *previous-compiler-condition*))
    (when (typep condition 'warning)
      (signal condition))
    (setq *previous-compiler-condition* condition)
    (signal-compiler-condition (real-condition condition)
                               (sb-c::find-error-context nil))))

(defun signal-compiler-condition (condition context)
  (signal 'compiler-condition
          :original-condition condition
          :severity (etypecase condition
                      (sb-ext:compiler-note :note)
                      (sb-c:compiler-error  :error)
                      (reader-error         :read-error)
                      (error                :error)
                      #+#.(swank/backend:with-symbol early-deprecation-warning sb-ext)
                      (sb-ext:early-deprecation-warning :early-deprecation-warning)
                      #+#.(swank/backend:with-symbol late-deprecation-warning sb-ext)
                      (sb-ext:late-deprecation-warning :late-deprecation-warning)
                      #+#.(swank/backend:with-symbol final-deprecation-warning sb-ext)
                      (sb-ext:final-deprecation-warning :final-deprecation-warning)
                      #+#.(swank/backend:with-symbol redefinition-warning
                            sb-kernel)
                      (sb-kernel:redefinition-warning
                       :redefinition)
                      (style-warning        :style-warning)
                      (warning              :warning))
          :references (condition-references condition)
          :message (brief-compiler-message-for-emacs condition)
          :source-context (compiler-error-context context)
          :location (compiler-note-location condition context)))

(defun real-condition (condition)
  "Return the encapsulated condition or CONDITION itself."
  (typecase condition
    (sb-int:encapsulated-condition (sb-int:encapsulated-condition condition))
    (t condition)))

(defun condition-references (condition)
  (if (typep condition 'sb-int:reference-condition)
      (externalize-reference
       (sb-int:reference-condition-references condition))))

(defun compiler-note-location (condition context)
  (flet ((bailout ()
           (return-from compiler-note-location
             (make-error-location "No error location available"))))
    (cond (context
           (locate-compiler-note
            (sb-c::compiler-error-context-file-name context)
            (compiler-source-path context)
            (sb-c::compiler-error-context-original-source context)))
          ((typep condition 'reader-error)
           (let* ((stream (stream-error-stream condition))
                  (file   (pathname stream)))
             (unless (open-stream-p stream)
               (bailout))
             (if (compiling-from-buffer-p file)
                 (make-location (list :buffer *buffer-name*)
                                (list :offset *buffer-offset*
                                      (1- (file-position stream))))
                 (progn
                   (assert (compiling-from-file-p file))
  No 1- because : position is 1 - based .
                   (make-location (list :file (namestring file))
                                  (list :position (file-position stream)))))))
          (t (bailout)))))

(defun compiling-from-buffer-p (filename)
  (and *buffer-name*
       (pathnamep filename)
       (let ((true1 (probe-file filename))
             (true2 (probe-file *buffer-tmpfile*)))
         (and true1 (equal true1 true2)))))

(defun compiling-from-file-p (filename)
  (and (pathnamep filename)
       (or (null *buffer-name*)
           (null *buffer-tmpfile*)
           (let ((true1 (probe-file filename))
                 (true2 (probe-file *buffer-tmpfile*)))
             (not (and true1 (equal true1 true2)))))))

(defun compiling-from-generated-code-p (filename source)
  (and (eq filename :lisp) (stringp source)))

(defun locate-compiler-note (file source-path source)
  (cond ((compiling-from-buffer-p file)
         (make-location (list :buffer *buffer-name*)
                        (list :offset  *buffer-offset*
                              (source-path-string-position
                               source-path *buffer-substring*))))
        ((compiling-from-file-p file)
         (let ((position (source-path-file-position source-path file)))
           (make-location (list :file (namestring file))
                          (list :position (and position
                                               (1+ position))))))
        ((compiling-from-generated-code-p file source)
         (make-location (list :source-form source)
                        (list :position 1)))
        (t
         (error "unhandled case in compiler note ~S ~S ~S"
                file source-path source))))

(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."
  (let ((sb-int:*print-condition-references* nil))
    (princ-to-string condition)))

(defun compiler-error-context (error-context)
  "Describe a compiler error for Emacs including context information."
  (declare (type (or sb-c::compiler-error-context null) error-context))
  (multiple-value-bind (enclosing source)
      (if error-context
          (values (sb-c::compiler-error-context-enclosing-source error-context)
                  (sb-c::compiler-error-context-source error-context)))
    (and (or enclosing source)
         (format nil "~@[--> ~{~<~%--> ~1:;~A~> ~}~%~]~@[~{==>~%~A~%~}~]"
                 enclosing source))))

(defun compiler-source-path (context)
  "Return the source-path for the current compiler error.
Returns NIL if this cannot be determined by examining internal
compiler state."
  (cond ((sb-c::node-p context)
         (reverse
          (sb-c::source-path-original-source
           (sb-c::node-source-path context))))
        ((sb-c::compiler-error-context-p context)
         (reverse
          (sb-c::compiler-error-context-original-source-path context)))))

(defimplementation call-with-compilation-hooks (function)
  (declare (type function function))
  (handler-bind
      ((sb-c:fatal-compiler-error #'handle-notification-condition)
       (sb-c:compiler-error       #'handle-notification-condition)
       (sb-ext:compiler-note      #'handle-notification-condition)
       (error                     #'handle-notification-condition)
       (warning                   #'handle-notification-condition))
    (funcall function)))

  HACK : SBCL 1.2.12 shipped with a bug where
  existence of at least one dummy restriction .
(handler-case (sb-ext:restrict-compiler-policy)
  (error () (sb-ext:restrict-compiler-policy 'debug)))

(defun compiler-policy (qualities)
  "Return compiler policy qualities present in the QUALITIES alist.
QUALITIES is an alist with (quality . value)"
  #+#.(swank/backend:with-symbol 'restrict-compiler-policy 'sb-ext)
  (loop with policy = (sb-ext:restrict-compiler-policy)
        for (quality) in qualities
        collect (cons quality
                      (or (cdr (assoc quality policy))
                          0))))

(defun (setf compiler-policy) (policy)
  (declare (ignorable policy))
  #+#.(swank/backend:with-symbol 'restrict-compiler-policy 'sb-ext)
  (loop for (qual . value) in policy
        do (sb-ext:restrict-compiler-policy qual value)))

(defmacro with-compiler-policy (policy &body body)
  (let ((current-policy (gensym)))
    `(let ((,current-policy (compiler-policy ,policy)))
       (setf (compiler-policy) ,policy)
       (unwind-protect (progn ,@body)
         (setf (compiler-policy) ,current-policy)))))

(defimplementation swank-compile-file (input-file output-file
                                       load-p external-format
                                       &key policy)
  (multiple-value-bind (output-file warnings-p failure-p)
      (with-compiler-policy policy
        (with-compilation-hooks ()
          (compile-file input-file :output-file output-file
                        :external-format external-format)))
    (values output-file warnings-p
            (or failure-p
                (when load-p
                  (source-cache-get input-file
                                    (file-write-date input-file))
                  (not (load output-file)))))))



(locally (declare (sb-ext:muffle-conditions sb-ext:compiler-note))

(sb-alien:define-alien-routine (#-win32 "tempnam" #+win32 "_tempnam" tempnam)
    sb-alien:c-string
  (dir sb-alien:c-string)
  (prefix sb-alien:c-string)))

(defun temp-file-name ()
  "Return a temporary file name to compile strings into."
  (tempnam nil "slime"))

(defvar *trap-load-time-warnings* t)

(defimplementation swank-compile-string (string &key buffer position filename
                                         policy)
  (let ((*buffer-name* buffer)
        (*buffer-offset* position)
        (*buffer-substring* string)
        (*buffer-tmpfile* (temp-file-name)))
    (labels ((load-it (filename)
               (cond (*trap-load-time-warnings*
                      (with-compilation-hooks () (load filename)))
                     (t (load filename))))
             (cf ()
               (with-compiler-policy policy
                 (with-compilation-unit
                     (:source-plist (list :emacs-buffer buffer
                                          :emacs-filename filename
                                          :emacs-package (package-name *package*)
                                          :emacs-position position
                                          :emacs-string string)
                      :source-namestring filename
                      :allow-other-keys t)
                   (compile-file *buffer-tmpfile* :external-format :utf-8)))))
      (with-open-file (s *buffer-tmpfile* :direction :output :if-exists :error
                         :external-format :utf-8)
        (write-string string s))
      (unwind-protect
           (multiple-value-bind (output-file warningsp failurep)
               (with-compilation-hooks () (cf))
             (declare (ignore warningsp))
             (when output-file
               (load-it output-file))
             (not failurep))
        (ignore-errors
          (delete-file *buffer-tmpfile*)
          (delete-file (compile-file-pathname *buffer-tmpfile*)))))))


(defparameter *definition-types*
  '(:variable defvar
    :constant defconstant
    :type deftype
    :symbol-macro define-symbol-macro
    :macro defmacro
    :compiler-macro define-compiler-macro
    :function defun
    :generic-function defgeneric
    :method defmethod
    :setf-expander define-setf-expander
    :structure defstruct
    :condition define-condition
    :class defclass
    :method-combination define-method-combination
    :package defpackage
    :transform :deftransform
    :optimizer :defoptimizer
    :vop :define-vop
    :source-transform :define-source-transform
    :ir1-convert :def-ir1-translator
    :declaration declaim
    :alien-type :define-alien-type)
  "Map SB-INTROSPECT definition type names to Slime-friendly forms")

(defun definition-specifier (type)
  "Return a pretty specifier for NAME representing a definition of type TYPE."
  (getf *definition-types* type))

(defun make-dspec (type name source-location)
  (list* (definition-specifier type)
         name
         (sb-introspect::definition-source-description source-location)))

(defimplementation find-definitions (name)
  (loop for type in *definition-types* by #'cddr
        for defsrcs = (sb-introspect:find-definition-sources-by-name name type)
        append (loop for defsrc in defsrcs collect
                     (list (make-dspec type name defsrc)
                           (converting-errors-to-error-location
                             (definition-source-for-emacs defsrc
                                 type name))))))

(defimplementation find-source-location (obj)
  (flet ((general-type-of (obj)
           (typecase obj
             (method             :method)
             (generic-function   :generic-function)
             (function           :function)
             (structure-class    :structure-class)
             (class              :class)
             (method-combination :method-combination)
             (package            :package)
             (condition          :condition)
             (structure-object   :structure-object)
             (standard-object    :standard-object)
             (t                  :thing)))
         (to-string (obj)
           (typecase obj
             (package (princ-to-string obj))
             ((or structure-object standard-object condition)
              (with-output-to-string (s)
                (print-unreadable-object (obj s :type t :identity t))))
             (t (princ-to-string obj)))))
    (converting-errors-to-error-location
      (let ((defsrc (sb-introspect:find-definition-source obj)))
        (definition-source-for-emacs defsrc
                                     (general-type-of obj)
                                     (to-string obj))))))

(defmacro with-definition-source ((&rest names) obj &body body)
  "Like with-slots but works only for structs."
  (flet ((reader (slot)
           (read-from-string
            (concatenate 'string "sb-introspect:definition-source-"
                         (string slot)))))
    (let ((tmp (gensym "OO-")))
      ` (let ((,tmp ,obj))
          (symbol-macrolet
              ,(loop for name in names collect
                     (typecase name
                       (symbol `(,name (,(reader name) ,tmp)))
                       (cons `(,(first name) (,(reader (second name)) ,tmp)))
                       (t (error "Malformed syntax in WITH-STRUCT: ~A" name))))
            ,@body)))))

(defun categorize-definition-source (definition-source)
  (with-definition-source (pathname form-path character-offset plist)
    definition-source
    (let ((file-p (and pathname (probe-file pathname)
                       (or form-path character-offset))))
      (cond ((and (getf plist :emacs-buffer) file-p) :buffer-and-file)
            ((getf plist :emacs-buffer) :buffer)
            (file-p :file)
            (pathname :file-without-position)
            (t :invalid)))))

#+#.(swank/backend:with-symbol 'definition-source-form-number 'sb-introspect)
(defun form-number-position (definition-source stream)
  (let* ((tlf-number (car (sb-introspect:definition-source-form-path definition-source)))
         (form-number (sb-introspect:definition-source-form-number definition-source)))
    (multiple-value-bind (tlf pos-map) (read-source-form tlf-number stream)
      (let* ((path-table (sb-di::form-number-translations tlf 0))
             (path (cond ((<= (length path-table) form-number)
                          (warn "inconsistent form-number-translations")
                          (list 0))
                         (t
                          (reverse (cdr (aref path-table form-number)))))))
        (source-path-source-position path tlf pos-map)))))

#+#.(swank/backend:with-symbol 'definition-source-form-number 'sb-introspect)
(defun file-form-number-position (definition-source)
  (let* ((code-date (sb-introspect:definition-source-file-write-date definition-source))
         (filename (sb-introspect:definition-source-pathname definition-source))
         (*readtable* (guess-readtable-for-filename filename))
         (source-code (get-source-code filename code-date)))
    (with-debootstrapping
      (with-input-from-string (s source-code)
        (form-number-position definition-source s)))))

#+#.(swank/backend:with-symbol 'definition-source-form-number 'sb-introspect)
(defun string-form-number-position (definition-source string)
  (with-input-from-string (s string)
    (form-number-position definition-source s)))

(defun definition-source-buffer-location (definition-source)
  (with-definition-source (form-path character-offset plist) definition-source
    (destructuring-bind (&key emacs-buffer emacs-position emacs-directory
                              emacs-string &allow-other-keys)
        plist
      (let ((*readtable* (guess-readtable-for-filename emacs-directory))
            start
            end)
        (with-debootstrapping
          (or
           (and form-path
                (or
                 #+#.(swank/backend:with-symbol 'definition-source-form-number 'sb-introspect)
                 (setf (values start end)
                       (and (sb-introspect:definition-source-form-number definition-source)
                            (string-form-number-position definition-source emacs-string)))
                 (setf (values start end)
                       (source-path-string-position form-path emacs-string))))
           (setf start character-offset
                 end most-positive-fixnum)))
        (make-location
         `(:buffer ,emacs-buffer)
         `(:offset ,emacs-position ,start)
         `(:snippet
           ,(subseq emacs-string
                    start
                    (min end (+ start *source-snippet-size*)))))))))

(defun definition-source-file-location (definition-source)
  (with-definition-source (pathname form-path character-offset plist
                           file-write-date) definition-source
    (let* ((namestring (namestring (translate-logical-pathname pathname)))
           (pos (or (and form-path
                         (or
                          #+#.(swank/backend:with-symbol 'definition-source-form-number 'sb-introspect)
                          (and (sb-introspect:definition-source-form-number definition-source)
                               (ignore-errors (file-form-number-position definition-source)))
                          (ignore-errors
                           (source-file-position namestring file-write-date
                                                 form-path))))
                    character-offset))
           (snippet (source-hint-snippet namestring file-write-date pos)))
      (make-location `(:file ,namestring)
  0 , buffer positions in Emacs start from 1 .
                     `(:position ,(1+ pos))
                     `(:snippet ,snippet)))))

(defun definition-source-buffer-and-file-location (definition-source)
  (let ((buffer (definition-source-buffer-location definition-source)))
    (make-location (list :buffer-and-file
                         (cadr (location-buffer buffer))
                         (namestring (sb-introspect:definition-source-pathname
                                      definition-source)))
                   (location-position buffer)
                   (location-hints buffer))))

(defun definition-source-for-emacs (definition-source type name)
  (with-definition-source (pathname form-path character-offset plist
                                    file-write-date)
      definition-source
    (ecase (categorize-definition-source definition-source)
      (:buffer-and-file
       (definition-source-buffer-and-file-location definition-source))
      (:buffer
       (definition-source-buffer-location definition-source))
      (:file
       (definition-source-file-location definition-source))
      (:file-without-position
       (make-location `(:file ,(namestring
                                (translate-logical-pathname pathname)))
                      '(:position 1)
                      (when (eql type :function)
                        `(:snippet ,(format nil "(defun ~a "
                                            (symbol-name name))))))
      (:invalid
       (error "DEFINITION-SOURCE of ~(~A~) ~A did not contain ~
               meaningful information."
              type name)))))

(defun source-file-position (filename write-date form-path)
  (let ((source (get-source-code filename write-date))
        (*readtable* (guess-readtable-for-filename filename)))
    (with-debootstrapping
      (source-path-string-position form-path source))))

(defun source-hint-snippet (filename write-date position)
  (read-snippet-from-string (get-source-code filename write-date) position))

(defun function-source-location (function &optional name)
  (declare (type function function))
  (definition-source-for-emacs (sb-introspect:find-definition-source function)
                               :function
                               (or name (function-name function))))

(defun setf-expander (symbol)
  (or
   #+#.(swank/sbcl::sbcl-with-setf-inverse-meta-info)
   (sb-int:info :setf :inverse symbol)
   (sb-int:info :setf :expander symbol)))

(defimplementation describe-symbol-for-emacs (symbol)
  "Return a plist describing SYMBOL.
Return NIL if the symbol is unbound."
  (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)
                     (sb-int: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)
               ((typep (fdefinition symbol) 'generic-function)
                :generic-function)
               (t :function))
         (doc 'function)))
      (maybe-push
       :setf (and (setf-expander symbol) 
                  (doc 'setf)))
      (maybe-push
       :type (if (sb-int:info :type :kind symbol)
                 (doc 'type)))
      result)))

(defimplementation describe-definition (symbol type)
  (case type
    (:variable
     (describe symbol))
    (:function
     (describe (symbol-function symbol)))
    (:setf
     (describe (setf-expander symbol)))
    (:class
     (describe (find-class symbol)))
    (:type
     (describe (sb-kernel:values-specifier-type symbol)))))

#+#.(swank/sbcl::sbcl-with-xref-p)
(progn
  (defmacro defxref (name &optional fn-name)
    `(defimplementation ,name (what)
       (sanitize-xrefs
        (mapcar #'source-location-for-xref-data
                (,(find-symbol (symbol-name (if fn-name
                                                fn-name
                                                name))
                               "SB-INTROSPECT")
                  what)))))
  (defxref who-calls)
  (defxref who-binds)
  (defxref who-sets)
  (defxref who-references)
  (defxref who-macroexpands)
  #+#.(swank/backend:with-symbol 'who-specializes-directly 'sb-introspect)
  (defxref who-specializes who-specializes-directly))

(defun source-location-for-xref-data (xref-data)
  (destructuring-bind (name . defsrc) xref-data
    (list name (converting-errors-to-error-location
                 (definition-source-for-emacs defsrc 'function name)))))

(defimplementation list-callers (symbol)
  (let ((fn (fdefinition symbol)))
    (sanitize-xrefs
     (mapcar #'function-dspec (sb-introspect:find-function-callers fn)))))

(defimplementation list-callees (symbol)
  (let ((fn (fdefinition symbol)))
    (sanitize-xrefs
     (mapcar #'function-dspec (sb-introspect:find-function-callees fn)))))

(defun sanitize-xrefs (xrefs)
  (remove-duplicates
   (remove-if (lambda (f)
                (member f (ignored-xref-function-names)))
              (loop for entry in xrefs
                    for name = (car entry)
                    collect (if (and (consp name)
                                     (member (car name)
                                             '(sb-pcl::fast-method
                                               sb-pcl::slow-method
                                               sb-pcl::method)))
                                (cons (cons 'defmethod (cdr name))
                                      (cdr entry))
                                entry))
              :key #'car)
   :test (lambda (a b)
           (and (eq (first a) (first b))
                (equal (second a) (second b))))))

(defun ignored-xref-function-names ()
  #-#.(swank/sbcl::sbcl-with-new-stepper-p)
  '(nil sb-c::step-form sb-c::step-values)
  #+#.(swank/sbcl::sbcl-with-new-stepper-p)
  '(nil))

(defun function-dspec (fn)
  "Describe where the function FN was defined.
Return a list of the form (NAME LOCATION)."
  (let ((name (function-name fn)))
    (list name (converting-errors-to-error-location
                 (function-source-location fn name)))))


(defimplementation macroexpand-all (form &optional env)
  (sb-cltl2:macroexpand-all form env))

(defimplementation collect-macro-forms (form &optional environment)
  (let ((macro-forms '())
        (compiler-macro-forms '())
        (function-quoted-forms '()))
    (sb-walker:walk-form
     form environment
     (lambda (form context environment)
       (declare (ignore context))
       (when (and (consp form)
                  (symbolp (car form)))
         (cond ((eq (car form) 'function)
                (push (cadr form) function-quoted-forms))
               ((member form function-quoted-forms)
                nil)
               ((macro-function (car form) environment)
                (push form macro-forms))
               ((not (eq form (compiler-macroexpand-1 form environment)))
                (push form compiler-macro-forms))))
       form))
    (values macro-forms compiler-macro-forms)))



  Notice that SB - EXT:*INVOKE - DEBUGGER - HOOK * is slightly stronger

(defun make-invoke-debugger-hook (hook)
  (when hook
    #'(sb-int:named-lambda swank-invoke-debugger-hook
          (condition old-hook)
        (if *debugger-hook*
            (funcall hook condition old-hook)))))

(defun set-break-hook (hook)
  (setq sb-ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook)))

(defun call-with-break-hook (hook continuation)
  (let ((sb-ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook)))
    (funcall continuation)))

(defimplementation install-debugger-globally (function)
  (setq *debugger-hook* function)
  (set-break-hook function))

(defimplementation condition-extras (condition)
  (cond #+#.(swank/sbcl::sbcl-with-new-stepper-p)
        ((typep condition 'sb-impl::step-form-condition)
         `((:show-frame-source 0)))
        ((typep condition 'sb-int:reference-condition)
         (let ((refs (sb-int:reference-condition-references condition)))
           (if refs
               `((:references ,(externalize-reference refs))))))))

(defun externalize-reference (ref)
  (etypecase ref
    (null nil)
    (cons (cons (externalize-reference (car ref))
                (externalize-reference (cdr ref))))
    ((or string number) ref)
    (symbol
     (cond ((eq (symbol-package ref) (symbol-package :test))
            ref)
           (t (symbol-name ref))))))

(defvar *sldb-stack-top*)

(defimplementation call-with-debugging-environment (debugger-loop-fn)
  (declare (type function debugger-loop-fn))
  (let ((*sldb-stack-top*
          (if (and (not *debug-swank-backend*)
                   sb-debug:*stack-top-hint*)
              #+#.(swank/backend:with-symbol 'resolve-stack-top-hint 'sb-debug)
              (sb-debug::resolve-stack-top-hint)
              #-#.(swank/backend:with-symbol 'resolve-stack-top-hint 'sb-debug)
              sb-debug:*stack-top-hint*
              (sb-di:top-frame)))
        (sb-debug:*stack-top-hint* nil))
    (handler-bind ((sb-di:debug-condition
                     (lambda (condition)
                       (signal 'sldb-condition
                               :original-condition condition))))
      (funcall debugger-loop-fn))))

#+#.(swank/sbcl::sbcl-with-new-stepper-p)
(progn
  (defimplementation activate-stepping (frame)
    (declare (ignore frame))
    (sb-impl::enable-stepping))
  (defimplementation sldb-stepper-condition-p (condition)
    (typep condition 'sb-ext:step-form-condition))
  (defimplementation sldb-step-into ()
    (invoke-restart 'sb-ext:step-into))
  (defimplementation sldb-step-next ()
    (invoke-restart 'sb-ext:step-next))
  (defimplementation sldb-step-out ()
    (invoke-restart 'sb-ext:step-out)))

(defimplementation call-with-debugger-hook (hook fun)
  (let ((*debugger-hook* hook)
        #+#.(swank/sbcl::sbcl-with-new-stepper-p)
        (sb-ext:*stepper-hook*
         (lambda (condition)
           (typecase condition
             (sb-ext:step-form-condition
              (let ((sb-debug:*stack-top-hint* (sb-di::find-stepped-frame)))
                (sb-impl::invoke-debugger condition)))))))
    (handler-bind (#+#.(swank/sbcl::sbcl-with-new-stepper-p)
                   (sb-ext:step-condition #'sb-impl::invoke-stepper))
      (call-with-break-hook hook fun))))

(defun nth-frame (index)
  (do ((frame *sldb-stack-top* (sb-di:frame-down frame))
       (i index (1- i)))
      ((zerop i) frame)))

(defimplementation compute-backtrace (start end)
  "Return a list of frames starting with frame number START and
continuing to frame number END or, if END is nil, the last frame on the
stack."
  (let ((end (or end most-positive-fixnum)))
    (loop for f = (nth-frame start) then (sb-di:frame-down f)
          for i from start below end
          while f collect f)))

(defimplementation print-frame (frame stream)
  (sb-debug::print-frame-call frame stream))

(defimplementation frame-restartable-p (frame)
  #+#.(swank/sbcl::sbcl-with-restart-frame)
  (not (null (sb-debug:frame-has-debug-tag-p frame))))

(defimplementation frame-call (frame-number)
  (multiple-value-bind (name args)
      (sb-debug::frame-call (nth-frame frame-number))
    (with-output-to-string (stream)
      (locally (declare (sb-ext:muffle-conditions sb-ext:compiler-note))
        (pprint-logical-block (stream nil :prefix "(" :suffix ")")
          (locally (declare (sb-ext:unmuffle-conditions sb-ext:compiler-note))
            (let ((*print-length* nil)
                  (*print-level* nil))
              (prin1 (sb-debug::ensure-printable-object name) stream))
            (let ((args (sb-debug::ensure-printable-object args)))
              (if (listp args)
                  (format stream "~{ ~_~S~}" args)
                  (format stream " ~S" args)))))))))


  with C - c C - c , we have to search the position in the source string .

(defun code-location-source-location (code-location)
  (let* ((dsource (sb-di:code-location-debug-source code-location))
         (plist (sb-c::debug-source-plist dsource))
         (package (getf plist :emacs-package))
         (*package* (or (and package
                             (find-package package))
                        *package*)))
    (if (getf plist :emacs-buffer)
        (emacs-buffer-source-location code-location plist)
        #+#.(swank/backend:with-symbol 'debug-source-from 'sb-di)
        (ecase (sb-di:debug-source-from dsource)
          (:file (file-source-location code-location))
          (:lisp (lisp-source-location code-location)))
        #-#.(swank/backend:with-symbol 'debug-source-from 'sb-di)
        (if (sb-di:debug-source-namestring dsource)
            (file-source-location code-location)
            (lisp-source-location code-location)))))

  source - location for a function , and we also have FILE - SOURCE - LOCATION & co

(defun file-source-location (code-location)
  (if (code-location-has-debug-block-info-p code-location)
      (source-file-source-location code-location)
      (fallback-source-location code-location)))

(defun fallback-source-location (code-location)
  (let ((fun (code-location-debug-fun-fun code-location)))
    (cond (fun (function-source-location fun))
          (t (error "Cannot find source location for: ~A " code-location)))))

(defun lisp-source-location (code-location)
  (let ((source (prin1-to-string
                 (sb-debug::code-location-source-form code-location 100)))
        (condition swank:*swank-debugger-condition*))
    (if (and (typep condition 'sb-impl::step-form-condition)
             (search "SB-IMPL::WITH-STEPPING-ENABLED" source
                     :test #'char-equal)
             (search "SB-IMPL::STEP-FINISHED" source :test #'char-equal))
        (make-error-location "Stepping...")
        (make-location `(:source-form ,source) '(:position 1)))))

(defun emacs-buffer-source-location (code-location plist)
  (if (code-location-has-debug-block-info-p code-location)
      (destructuring-bind (&key emacs-buffer emacs-position emacs-string
                                &allow-other-keys)
          plist
        (let* ((pos (string-source-position code-location emacs-string))
               (snipped (read-snippet-from-string emacs-string pos)))
          (make-location `(:buffer ,emacs-buffer)
                         `(:offset ,emacs-position ,pos)
                         `(:snippet ,snipped))))
      (fallback-source-location code-location)))

(defun source-file-source-location (code-location)
  (let* ((code-date (code-location-debug-source-created code-location))
         (filename (code-location-debug-source-name code-location))
         (*readtable* (guess-readtable-for-filename filename))
         (source-code (get-source-code filename code-date)))
    (with-debootstrapping
      (with-input-from-string (s source-code)
        (let* ((pos (stream-source-position code-location s))
               (snippet (read-snippet s pos)))
          (make-location `(:file ,filename)
                         `(:position ,pos)
                         `(:snippet ,snippet)))))))

(defun code-location-debug-source-name (code-location)
  (namestring (truename (#.(swank/backend:choose-symbol
                            'sb-c 'debug-source-name
                            'sb-c 'debug-source-namestring)
                           (sb-di::code-location-debug-source code-location)))))

(defun code-location-debug-source-created (code-location)
  (sb-c::debug-source-created
   (sb-di::code-location-debug-source code-location)))

(defun code-location-debug-fun-fun (code-location)
  (sb-di:debug-fun-fun (sb-di:code-location-debug-fun code-location)))

(defun code-location-has-debug-block-info-p (code-location)
  (handler-case
      (progn (sb-di:code-location-debug-block code-location)
             t)
    (sb-di:no-debug-blocks  () nil)))

(defun stream-source-position (code-location stream)
  (let* ((cloc (sb-debug::maybe-block-start-location code-location))
         (tlf-number (sb-di::code-location-toplevel-form-offset cloc))
         (form-number (sb-di::code-location-form-number cloc)))
    (multiple-value-bind (tlf pos-map) (read-source-form tlf-number stream)
      (let* ((path-table (sb-di::form-number-translations tlf 0))
             (path (cond ((<= (length path-table) form-number)
                          (warn "inconsistent form-number-translations")
                          (list 0))
                         (t
                          (reverse (cdr (aref path-table form-number)))))))
        (source-path-source-position path tlf pos-map)))))

(defun string-source-position (code-location string)
  (with-input-from-string (s string)
    (stream-source-position code-location s)))


(defimplementation frame-source-location (index)
  (converting-errors-to-error-location
    (code-location-source-location
     (sb-di:frame-code-location (nth-frame index)))))

(defvar *keep-non-valid-locals* nil)

(defun frame-debug-vars (frame)
  "Return a vector of debug-variables in frame."
  (let ((all-vars (sb-di::debug-fun-debug-vars (sb-di:frame-debug-fun frame))))
    (cond (*keep-non-valid-locals* all-vars)
          (t (let ((loc (sb-di:frame-code-location frame)))
               (remove-if (lambda (var)
                            (ecase (sb-di:debug-var-validity var loc)
                              (:valid nil)
                              ((:invalid :unknown) t)))
                          all-vars))))))

(defun debug-var-value (var frame location)
  (ecase (sb-di:debug-var-validity var location)
    (:valid (sb-di:debug-var-value var frame))
    ((:invalid :unknown) ':<not-available>)))

(defun debug-var-info (var)
  Introduced by SBCL 1.0.49.76 .
  (let ((s (find-symbol "DEBUG-VAR-INFO" :sb-di)))
    (when (and s (fboundp s))
      (funcall s var))))

(defimplementation frame-locals (index)
  (let* ((frame (nth-frame index))
         (loc (sb-di:frame-code-location frame))
         (vars (frame-debug-vars frame))
  Since  1.0.49.76 PREPROCESS - FOR - EVAL understands SB - DEBUG::MORE
         (more-name (or (find-symbol "MORE" :sb-debug) 'more))
         (more-context nil)
         (more-count nil))
    (when vars
      (let ((locals
              (loop for v across vars
                    unless 
                    (case (debug-var-info v)
                      (:more-context
                       (setf more-context (debug-var-value v frame loc))
                       t)
                      (:more-count
                       (setf more-count (debug-var-value v frame loc))
                       t))
                    collect
                    (list :name (sb-di:debug-var-symbol v)
                          :id (sb-di:debug-var-id v)
                          :value (debug-var-value v frame loc)))))
        (when (and more-context more-count)
          (setf locals (append locals
                               (list
                                (list :name more-name
                                      :id 0
                                      :value (multiple-value-list
                                              (sb-c:%more-arg-values
                                               more-context
                                               0 more-count)))))))
        locals))))

(defimplementation frame-var-value (frame var)
  (let* ((frame (nth-frame frame))
         (vars (frame-debug-vars frame))
         (loc (sb-di:frame-code-location frame))
         (dvar (if (= var (length vars))
  If VAR is out of bounds , it must be the fake var
                   (let* ((context-var (find :more-context vars
                                             :key #'debug-var-info))
                          (more-context (debug-var-value context-var frame
                                                         loc))
                          (count-var (find :more-count vars
                                           :key #'debug-var-info))
                          (more-count (debug-var-value count-var frame loc)))
                     (return-from frame-var-value
                       (multiple-value-list (sb-c:%more-arg-values
                                             more-context
                                             0 more-count))))
                   (aref vars var))))
    (debug-var-value dvar frame loc)))

(defimplementation frame-catch-tags (index)
  (mapcar #'car (sb-di:frame-catches (nth-frame index))))

(defimplementation eval-in-frame (form index)
  (let ((frame (nth-frame index)))
    (funcall (the function
               (sb-di:preprocess-for-eval form
                                          (sb-di:frame-code-location frame)))
             frame)))

(defimplementation frame-package (frame-number)
  (let* ((frame (nth-frame frame-number))
         (fun (sb-di:debug-fun-fun (sb-di:frame-debug-fun frame))))
    (when fun
      (let ((name (function-name fun)))
        (typecase name
          (null nil)
          (symbol (symbol-package name))
          ((cons (eql setf) (cons symbol)) (symbol-package (cadr name))))))))

#+#.(swank/sbcl::sbcl-with-restart-frame)
(progn
  (defimplementation return-from-frame (index form)
    (let* ((frame (nth-frame index)))
      (cond ((sb-debug:frame-has-debug-tag-p frame)
             (let ((values (multiple-value-list (eval-in-frame form index))))
               (sb-debug:unwind-to-frame-and-call frame
                                                   (lambda ()
                                                     (values-list values)))))
            (t (format nil "Cannot return from frame: ~S" frame)))))

  (defimplementation restart-frame (index)
    (let ((frame (nth-frame index)))
      (when (sb-debug:frame-has-debug-tag-p frame)
        (multiple-value-bind (fname args) (sb-debug::frame-call frame)
          (multiple-value-bind (fun arglist)
              (if (and (sb-int:legal-fun-name-p fname) (fboundp fname))
                  (values (fdefinition fname) args)
                  (values (sb-di:debug-fun-fun (sb-di:frame-debug-fun frame))
                          (sb-debug::frame-args-as-list frame)))
            (when (functionp fun)
              (sb-debug:unwind-to-frame-and-call
               frame
               (lambda ()
                 (declare (optimize (debug 0)))
                 (apply fun arglist)))))))
      (format nil "Cannot restart frame: ~S" frame))))

#-#.(swank/sbcl::sbcl-with-restart-frame)
(progn
  (defun sb-debug-catch-tag-p (tag)
    (and (symbolp tag)
         (not (symbol-package tag))
         (string= tag :sb-debug-catch-tag)))

  (defimplementation return-from-frame (index form)
    (let* ((frame (nth-frame index))
           (probe (assoc-if #'sb-debug-catch-tag-p
                            (sb-di::frame-catches frame))))
      (cond (probe (throw (car probe) (eval-in-frame form index)))
            (t (format nil "Cannot return from frame: ~S" frame)))))

  (defimplementation restart-frame (index)
    (let ((frame (nth-frame index)))
      (return-from-frame index (sb-debug::frame-call-as-list frame)))))


(defimplementation print-condition (condition stream)
  (let ((sb-int:*print-condition-references* nil))
    (princ condition stream)))



(defimplementation profile (fname)
  (when fname (eval `(sb-profile:profile ,fname))))

(defimplementation unprofile (fname)
  (when fname (eval `(sb-profile:unprofile ,fname))))

(defimplementation unprofile-all ()
  (sb-profile:unprofile)
  "All functions unprofiled.")

(defimplementation profile-report ()
  (sb-profile:report))

(defimplementation profile-reset ()
  (sb-profile:reset)
  "Reset profiling counters.")

(defimplementation profiled-functions ()
  (sb-profile:profile))

(defimplementation profile-package (package callers methods)
  (declare (ignore callers methods))
  (eval `(sb-profile:profile ,(package-name (find-package package)))))



(defmethod emacs-inspect ((o t))
  (cond ((sb-di::indirect-value-cell-p o)
         (label-value-line* (:value (sb-kernel:value-cell-ref o))))
	(t
         (multiple-value-bind (text label parts) (sb-impl::inspected-parts o)
           (list* (string-right-trim '(#\Newline) text)
                  '(:newline)
                  (if label
                      (loop for (l . v) in parts
                            append (label-value-line l v))
                      (loop for value in parts
                            for i from 0
                            append (label-value-line i value))))))))

(defmethod emacs-inspect ((o function))
    (cond ((sb-kernel:simple-fun-p o)
                   (label-value-line*
                    (:name (sb-kernel:%simple-fun-name o))
                    (:arglist (sb-kernel:%simple-fun-arglist o))
                    (:next (sb-kernel:%simple-fun-next o))
                    (:type (sb-kernel:%simple-fun-type o))
                    (:code (sb-kernel:fun-code-header o))))
          ((sb-kernel:closurep o)
                   (append
                    (label-value-line :function (sb-kernel:%closure-fun o))
                    `("Closed over values:" (:newline))
                    (loop for i below (1- (sb-kernel:get-closure-length o))
                          append (label-value-line
                                  i (sb-kernel:%closure-index-ref o i)))))
          (t (call-next-method o))))

(defmethod emacs-inspect ((o sb-kernel:code-component))
  (append
   (label-value-line*
    (:code-size (sb-kernel:%code-code-size o))
    (:entry-points (sb-kernel:%code-entry-points o))
    (:debug-info (sb-kernel:%code-debug-info o)))
   `("Constants:" (:newline))
   (loop for i from sb-vm:code-constants-offset
         below
         (#.(swank/backend:choose-symbol 'sb-kernel 'code-header-words
                                         'sb-kernel 'get-header-data)
            o)
         append (label-value-line i (sb-kernel:code-header-ref o i)))
   `("Code:" (:newline)
             ,(with-output-to-string (s)
                (sb-disassem:disassemble-code-component o :stream s)))))

(defmethod emacs-inspect ((o sb-ext:weak-pointer))
          (label-value-line*
           (:value (sb-ext:weak-pointer-value o))))

(defmethod emacs-inspect ((o sb-kernel:fdefn))
          (label-value-line*
           (:name (sb-kernel:fdefn-name o))
           (:function (sb-kernel:fdefn-fun o))))

(defmethod emacs-inspect :around ((o generic-function))
            (append
             (call-next-method)
             (label-value-line*
              (:pretty-arglist (sb-pcl::generic-function-pretty-arglist o))
              (:initial-methods (sb-pcl::generic-function-initial-methods o))
              )))



#+(and sb-thread
       #.(swank/backend:with-symbol "THREAD-NAME" "SB-THREAD"))
(progn
  (defvar *thread-id-counter* 0)

  (defvar *thread-id-counter-lock*
    (sb-thread:make-mutex :name "thread id counter lock"))

  (defun next-thread-id ()
    (sb-thread:with-mutex (*thread-id-counter-lock*)
      (incf *thread-id-counter*)))

  (defparameter *thread-id-map* (make-hash-table))

  (defvar *thread-id-map-lock*
    (sb-thread:make-mutex :name "thread id map lock"))

  (defimplementation spawn (fn &key name)
    (sb-thread:make-thread fn :name name))

  (defimplementation thread-id (thread)
    (block thread-id
      (sb-thread:with-mutex (*thread-id-map-lock*)
        (loop for id being the hash-key in *thread-id-map*
              using (hash-value thread-pointer)
              do
              (let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer)))
                (cond ((null maybe-thread)
  the value is gc'd , remove it manually
                       (remhash id *thread-id-map*))
                      ((eq thread maybe-thread)
                       (return-from thread-id id)))))
        (let ((id (next-thread-id)))
          (setf (gethash id *thread-id-map*) (sb-ext:make-weak-pointer thread))
          id))))

  (defimplementation find-thread (id)
    (sb-thread:with-mutex (*thread-id-map-lock*)
      (let ((thread-pointer (gethash id *thread-id-map*)))
        (if thread-pointer
            (let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer)))
              (if maybe-thread
                  maybe-thread
  the value is gc'd , remove it manually
                  (progn
                    (remhash id *thread-id-map*)
                    nil)))
            nil))))

  (defimplementation thread-name (thread)
  sometimes the name is not a string ( e.g. NIL )
    (princ-to-string (sb-thread:thread-name thread)))

  (defimplementation thread-status (thread)
    (if (sb-thread:thread-alive-p thread)
        "Running"
        "Stopped"))

  (defimplementation make-lock (&key name)
    (sb-thread:make-mutex :name name))

  (defimplementation call-with-lock-held (lock function)
    (declare (type function function))
    (sb-thread:with-recursive-lock (lock) (funcall function)))

  (defimplementation current-thread ()
    sb-thread:*current-thread*)

  (defimplementation all-threads ()
    (sb-thread:list-all-threads))

  (defimplementation interrupt-thread (thread fn)
    (sb-thread:interrupt-thread thread fn))

  (defimplementation kill-thread (thread)
    (sb-thread:terminate-thread thread))

  (defimplementation thread-alive-p (thread)
    (sb-thread:thread-alive-p thread))

  (defvar *mailbox-lock* (sb-thread:make-mutex :name "mailbox lock"))
  (defvar *mailboxes* (list))
  (declaim (type list *mailboxes*))

  (defstruct (mailbox (:conc-name mailbox.))
    thread
    (mutex (sb-thread:make-mutex))
    (waitqueue  (sb-thread:make-waitqueue))
    (queue '() :type list))

  (defun mailbox (thread)
    "Return THREAD's mailbox."
    (sb-thread:with-mutex (*mailbox-lock*)
      (or (find thread *mailboxes* :key #'mailbox.thread)
          (let ((mb (make-mailbox :thread thread)))
            (push mb *mailboxes*)
            mb))))

  (defimplementation wake-thread (thread)
    (let* ((mbox (mailbox thread))
           (mutex (mailbox.mutex mbox)))
      (sb-thread:with-recursive-lock (mutex)
        (sb-thread:condition-broadcast (mailbox.waitqueue mbox)))))

  (defimplementation send (thread message)
    (let* ((mbox (mailbox thread))
           (mutex (mailbox.mutex mbox)))
      (sb-thread:with-mutex (mutex)
        (setf (mailbox.queue mbox)
              (nconc (mailbox.queue mbox) (list message)))
        (sb-thread:condition-broadcast (mailbox.waitqueue mbox)))))
  
  (defimplementation receive-if (test &optional timeout)
    (let* ((mbox (mailbox (current-thread)))
           (mutex (mailbox.mutex mbox))
           (waitq (mailbox.waitqueue mbox)))
      (assert (or (not timeout) (eq timeout t)))
      (loop
       (check-slime-interrupts)
       (sb-thread:with-mutex (mutex)
         (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)))
         (sb-thread:condition-wait waitq mutex)))))

  (let ((alist '())
        (mutex (sb-thread:make-mutex :name "register-thread")))

    (defimplementation register-thread (name thread)
      (declare (type symbol name))
      (sb-thread:with-mutex (mutex)
        (etypecase thread
          (null
           (setf alist (delete name alist :key #'car)))
          (sb-thread:thread
           (let ((probe (assoc name alist)))
             (cond (probe (setf (cdr probe) thread))
                   (t (setf alist (acons name thread alist))))))))
      nil)

    (defimplementation find-registered (name)
      (sb-thread:with-mutex (mutex)
        (cdr (assoc name alist))))))

(defimplementation quit-lisp ()
  #+#.(swank/backend:with-symbol 'exit 'sb-ext)
  (sb-ext:exit)
  #-#.(swank/backend:with-symbol 'exit 'sb-ext)
  (progn
    #+sb-thread
    (dolist (thread (remove (current-thread) (all-threads)))
      (ignore-errors (sb-thread:terminate-thread thread)))
    (sb-ext:quit)))



Trace implementations
In  , we have :
  < name > can be a normal name or a ( setf name )

(defun toggle-trace-aux (fspec &rest args)
  (cond ((member fspec (eval '(trace)) :test #'equal)
         (eval `(untrace ,fspec))
         (format nil "~S is now untraced." fspec))
        (t
         (eval `(trace ,@(if args `(:encapsulate nil) (list)) ,fspec ,@args))
         (format nil "~S is now traced." fspec))))

(defun process-fspec (fspec)
  (cond ((consp fspec)
         (ecase (first fspec)
           ((:defun :defgeneric) (second fspec))
           ((:defmethod) `(method ,@(rest fspec)))
           ((:labels) `(labels ,(process-fspec (second fspec)) ,(third fspec)))
           ((:flet) `(flet ,(process-fspec (second fspec)) ,(third fspec)))))
        (t
         fspec)))

(defimplementation toggle-trace (spec)
  (ecase (car spec)
    ((setf)
     (toggle-trace-aux spec))
    ((:defmethod)
     (toggle-trace-aux `(sb-pcl::fast-method ,@(rest (process-fspec spec)))))
    ((:defgeneric)
     (toggle-trace-aux (second spec) :methods t))
    ((:call)
     (destructuring-bind (caller callee) (cdr spec)
       (toggle-trace-aux callee :wherein (list (process-fspec caller)))))))


(defimplementation make-weak-key-hash-table (&rest args)
  #+#.(swank/sbcl::sbcl-with-weak-hash-tables)
  (apply #'make-hash-table :weakness :key args)
  #-#.(swank/sbcl::sbcl-with-weak-hash-tables)
  (apply #'make-hash-table args))

(defimplementation make-weak-value-hash-table (&rest args)
  #+#.(swank/sbcl::sbcl-with-weak-hash-tables)
  (apply #'make-hash-table :weakness :value args)
  #-#.(swank/sbcl::sbcl-with-weak-hash-tables)
  (apply #'make-hash-table args))

(defimplementation hash-table-weakness (hashtable)
  #+#.(swank/sbcl::sbcl-with-weak-hash-tables)
  (sb-ext:hash-table-weakness hashtable))


(defimplementation float-nan-p (float)
  (sb-ext:float-nan-p float))

(defimplementation float-infinity-p (float)
  (sb-ext:float-infinity-p float))

#-win32
(defimplementation save-image (filename &optional restart-function)
  (flet ((restart-sbcl ()
           (sb-debug::enable-debugger)
           (setf sb-impl::*descriptor-handlers* nil)
           (funcall restart-function)))
    (let ((pid (sb-posix:fork)))
      (cond ((= pid 0)
             (sb-debug::disable-debugger)
             (apply #'sb-ext:save-lisp-and-die filename
                    (when restart-function
                      (list :toplevel #'restart-sbcl))))
            (t
             (multiple-value-bind (rpid status) (sb-posix:waitpid pid 0)
               (assert (= pid rpid))
               (assert (and (sb-posix:wifexited status)
                            (zerop (sb-posix:wexitstatus status))))))))))

#+unix
(progn
  (sb-alien:define-alien-routine ("execv" sys-execv) sb-alien:int
    (program sb-alien:c-string)
    (argv (* sb-alien:c-string)))

  (defun execv (program args)
    "Replace current executable with another one."
    (let ((a-args (sb-alien:make-alien sb-alien:c-string
                                       (+ 1 (length args)))))
      (unwind-protect
           (progn
             (loop for index from 0 by 1
                   and item in (append args '(nil))
                   do (setf (sb-alien:deref a-args index)
                            item))
             (when (minusp
                    (sys-execv program a-args))
               (error "execv(3) returned.")))
        (sb-alien:free-alien a-args))))

  (defun runtime-pathname ()
    #+#.(swank/backend:with-symbol
            '*runtime-pathname* 'sb-ext)
    sb-ext:*runtime-pathname*
    #-#.(swank/backend:with-symbol
            '*runtime-pathname* 'sb-ext)
    (car sb-ext:*posix-argv*))

  (defimplementation exec-image (image-file args)
    (loop with fd-arg =
          (loop for arg in args
                and key = "" then arg
                when (string-equal key "--swank-fd")
                return (parse-integer arg))
          for my-fd from 3 to 1024
          when (/= my-fd fd-arg)
          do (ignore-errors (sb-posix:fcntl my-fd sb-posix:f-setfd 1)))
    (let* ((self-string (pathname-to-filename (runtime-pathname))))
      (execv
       self-string
       (apply 'list self-string "--core" image-file args)))))

(defimplementation make-fd-stream (fd external-format)
  (sb-sys:make-fd-stream fd :input t :output t
                         :element-type 'character
                         :buffering :full
                         :dual-channel-p t
                         :external-format external-format))

#-win32
(defimplementation background-save-image (filename &key restart-function
                                                   completion-function)
  (flet ((restart-sbcl ()
           (sb-debug::enable-debugger)
           (setf sb-impl::*descriptor-handlers* nil)
           (funcall restart-function)))
    (multiple-value-bind (pipe-in pipe-out) (sb-posix:pipe)
      (let ((pid (sb-posix:fork)))
        (cond ((= pid 0)
               (sb-posix:close pipe-in)
               (sb-debug::disable-debugger)
               (apply #'sb-ext:save-lisp-and-die filename
                      (when restart-function
                        (list :toplevel #'restart-sbcl))))
              (t
               (sb-posix:close pipe-out)
               (sb-sys:add-fd-handler
                pipe-in :input
                (lambda (fd)
                  (sb-sys:invalidate-descriptor fd)
                  (sb-posix:close fd)
                  (multiple-value-bind (rpid status) (sb-posix:waitpid pid 0)
                    (assert (= pid rpid))
                    (assert (sb-posix:wifexited status))
                    (funcall completion-function
                             (zerop (sb-posix:wexitstatus status))))))))))))

(pushnew 'deinit-log-output sb-ext:*save-hooks*)



(defun sbcl-version>= (&rest subversions)
  #+#.(swank/backend:with-symbol 'assert-version->= 'sb-ext)
  (values (ignore-errors (apply #'sb-ext:assert-version->= subversions) t))
  #-#.(swank/backend:with-symbol 'assert-version->= 'sb-ext)
  nil)

(defimplementation wrap (spec indicator &key before after replace)
  (when (wrapped-p spec indicator)
    (warn "~a already wrapped with indicator ~a, unwrapping first"
          spec indicator)
    (sb-int:unencapsulate spec indicator))
  (sb-int:encapsulate spec indicator
                      #-#.(swank/backend:with-symbol 'arg-list 'sb-int)
                      (lambda (function &rest args)
                        (sbcl-wrap spec before after replace function args))
                      #+#.(swank/backend:with-symbol 'arg-list 'sb-int)
                      (if (sbcl-version>= 1 1 16)
                          (lambda ()
                            (sbcl-wrap spec before after replace
                                       (symbol-value 'sb-int:basic-definition)
                                       (symbol-value 'sb-int:arg-list)))
                          `(sbcl-wrap ',spec ,before ,after ,replace
                                      (symbol-value 'sb-int:basic-definition)
                                      (symbol-value 'sb-int:arg-list)))))

(defimplementation unwrap (spec indicator)
  (sb-int:unencapsulate spec indicator))

(defimplementation wrapped-p (spec indicator)
  (sb-int:encapsulated-p spec indicator))

(defun sbcl-wrap (spec before after replace function args)
  (declare (ignore spec))
  (let (retlist completed)
    (unwind-protect
         (progn
           (when before
             (funcall before args))
           (setq retlist (multiple-value-list (if replace
                                                  (funcall replace
                                                           args)
                                                  (apply function args))))
           (setq completed t)
           (values-list retlist))
      (when after
        (funcall after (if completed retlist :exited-non-locally))))))

#+#.(swank/backend:with-symbol 'comma-expr 'sb-impl)
(progn
  (defmethod sexp-in-bounds-p ((s sb-impl::comma) i)
    (= i 1))

  (defmethod sexp-ref ((s sb-impl::comma) i)
    (sb-impl::comma-expr s)))
