(defpackage :swank
  (:use :cl :swank-backend :swank-match :swank-rpc)
  (:export #:startup-multiprocessing
           #:start-server 
           #:create-server
           #:stop-server
           #:restart-server
           #:ed-in-emacs
           #:inspect-in-emacs
           #:print-indentation-lossage
           #:invoke-slime-debugger
           #:swank-debugger-hook
           #:emacs-inspect
           ;;#:inspect-slot-for-emacs
           ;; These are user-configurable variables:
           #:*communication-style*
           #:*dont-close*
           #:*fasl-pathname-function*
           #:*log-events*
           #:*log-output*
           #:*use-dedicated-output-stream*
           #:*dedicated-output-stream-port*
           #:*configure-emacs-indentation*
           #:*readtable-alist*
           #:*globally-redirect-io*
           #:*global-debugger*
           #:*sldb-quit-restart*
           #:*backtrace-printer-bindings*
           #:*default-worker-thread-bindings*
           #:*macroexpand-printer-bindings*
           #:*swank-pprint-bindings*
           #:*record-repl-results*
           #:*inspector-verbose*
           ;; This is SETFable.
           #:debug-on-swank-error
           ;; These are re-exported directly from the backend:
           #:buffer-first-change
           #:frame-source-location
           #:gdb-initial-commands
           #:restart-frame
           #:sldb-step 
           #:sldb-break
           #:sldb-break-on-return
           #:profiled-functions
           #:profile-report
           #:profile-reset
           #:unprofile-all
           #:profile-package
           #:default-directory
           #:set-default-directory
           #:quit-lisp
           #:eval-for-emacs
           #:eval-in-emacs
           #:y-or-n-p-in-emacs
           #:*find-definitions-right-trim*
           #:*find-definitions-left-trim*))

(in-package :swank)

#+mkcl
(eval-when (:compile-toplevel :load-toplevel :execute)
  (shadowing-import '(gray:open-stream-p gray:output-stream-p)))


;;;; Top-level variables, constants, macros

(defconstant cl-package (find-package :cl)
  "The COMMON-LISP package.")

(defconstant keyword-package (find-package :keyword)
  "The KEYWORD package.")

(defconstant default-server-port 4005
  "The default TCP port for the server (when started manually).")

(defvar *swank-debug-p* t
  "When true, print extra debugging information.")

(defvar *backtrace-pprint-dispatch-table*
  (let ((table (copy-pprint-dispatch nil)))
    (flet ((print-string (stream string)
             (cond (*print-escape* 
                    (escape-string string stream
                                   :map '((#\" . "\\\"")
                                          (#\\ . "\\\\")
                                          (#\newline . "\\n")
                                          (#\return . "\\r"))))
                   (t (write-string string stream)))))
      (set-pprint-dispatch 'string  #'print-string 0 table)
      table)))

(defvar *backtrace-printer-bindings*
  `((*print-pretty*           . t)
    (*print-readably*         . nil)
    (*print-level*            . 4)
    (*print-length*           . 6)
    (*print-lines*            . 1)
    (*print-right-margin*     . 200)
    (*print-pprint-dispatch*  . ,*backtrace-pprint-dispatch-table*))
  "Pretter settings for printing backtraces.")

(defvar *default-worker-thread-bindings* '()
  "An alist to initialize dynamic variables in worker threads.  
The list has the form ((VAR . VALUE) ...).  Each variable VAR will be
bound to the corresponding VALUE.")

(defun call-with-bindings (alist fun)
  "Call FUN with variables bound according to ALIST.
ALIST is a list of the form ((VAR . VAL) ...)."
  (if (null alist)
      (funcall fun)
      (let* ((rlist (reverse alist))
             (vars (mapcar #'car rlist))
             (vals (mapcar #'cdr rlist)))
        (progv vars vals
          (funcall fun)))))

(defmacro with-bindings (alist &body body)
  "See `call-with-bindings'."
  `(call-with-bindings ,alist (lambda () ,@body)))

;;; The `DEFSLIMEFUN' macro defines a function that Emacs can call via
;;; RPC.

(defmacro defslimefun (name arglist &body rest)
  "A DEFUN for functions that Emacs can call by RPC."
  `(progn
     (defun ,name ,arglist ,@rest)
     ;; see <http://www.franz.com/support/documentation/6.2/\
     ;; doc/pages/variables/compiler/\
     ;; s_cltl1-compile-file-toplevel-compatibility-p_s.htm>
     (eval-when (:compile-toplevel :load-toplevel :execute)
       (export ',name (symbol-package ',name)))))

(defun missing-arg ()
  "A function that the compiler knows will never to return a value.
You can use (MISSING-ARG) as the initform for defstruct slots that
must always be supplied. This way the :TYPE slot option need not
include some arbitrary initial value like NIL."
  (error "A required &KEY or &OPTIONAL argument was not supplied."))


;;;; Hooks
;;;
;;; We use Emacs-like `add-hook' and `run-hook' utilities to support
;;; simple indirection. The interface is more CLish than the Emacs
;;; Lisp one.

(defmacro add-hook (place function)
  "Add FUNCTION to the list of values on PLACE."
  `(pushnew ,function ,place))

(defun run-hook (functions &rest arguments)
  "Call each of FUNCTIONS with ARGUMENTS."
  (dolist (function functions)
    (apply function arguments)))

(defvar *new-connection-hook* '()
  "This hook is run each time a connection is established.
The connection structure is given as the argument.
Backend code should treat the connection structure as opaque.")

(defvar *connection-closed-hook* '()
  "This hook is run when a connection is closed.
The connection as passed as an argument.
Backend code should treat the connection structure as opaque.")

(defvar *pre-reply-hook* '()
  "Hook run (without arguments) immediately before replying to an RPC.")

(defvar *after-init-hook* '()
  "Hook run after user init files are loaded.")


;;;; Connections
;;;
;;; Connection structures represent the network connections between
;;; Emacs and Lisp. Each has a socket stream, a set of user I/O
;;; streams that redirect to Emacs, and optionally a second socket
;;; used solely to pipe user-output to Emacs (an optimization).  This
;;; is also the place where we keep everything that needs to be
;;; freed/closed/killed when we disconnect.

(defstruct (connection
             (:constructor %make-connection)
             (:conc-name connection.)
             (:print-function print-connection))
  ;; The listening socket. (usually closed)
  (socket           (missing-arg) :type t :read-only t)
  ;; Character I/O stream of socket connection.  Read-only to avoid
  ;; race conditions during initialization.
  (socket-io        (missing-arg) :type stream :read-only t)
  ;; Optional dedicated output socket (backending `user-output' slot).
  ;; Has a slot so that it can be closed with the connection.
  (dedicated-output nil :type (or stream null))
  ;; Streams that can be used for user interaction, with requests
  ;; redirected to Emacs.
  (user-input       nil :type (or stream null))
  (user-output      nil :type (or stream null))
  (user-io          nil :type (or stream null))
  ;; Bindings used for this connection (usually streams)
  (env '() :type list)
  ;; A stream that we use for *trace-output*; if nil, we user user-output.
  (trace-output     nil :type (or stream null))
  ;; A stream where we send REPL results.
  (repl-results     nil :type (or stream null))
  ;; Cache of macro-indentation information that has been sent to Emacs.
  ;; This is used for preparing deltas to update Emacs's knowledge.
  ;; Maps: symbol -> indentation-specification
  (indentation-cache (make-hash-table :test 'eq) :type hash-table)
  ;; The list of packages represented in the cache:
  (indentation-cache-packages '())
  ;; The communication style used.
  (communication-style nil :type (member nil :spawn :sigio :fd-handler))
  )

(defun print-connection (conn stream depth)
  (declare (ignore depth))
  (print-unreadable-object (conn stream :type t :identity t)))

(defstruct (singlethreaded-connection (:include connection)
                                      (:conc-name sconn.))
  ;; The SIGINT handler we should restore when the connection is
  ;; closed.
  saved-sigint-handler
  ;; A queue of events.  Not all events can be processed in order and
  ;; we need a place to stored them.
  (event-queue '() :type list)
  ;; A counter that is incremented whenever an event is added to the
  ;; queue.  This is used to detected modifications to the event queue
  ;; by interrupts.  The counter wraps around.
  (events-enqueued 0 :type fixnum))

(defstruct (multithreaded-connection (:include connection)
                                     (:conc-name mconn.))
  ;; In multithreaded systems we delegate certain tasks to specific
  ;; threads. The `reader-thread' is responsible for reading network
  ;; requests from Emacs and sending them to the `control-thread'; the
  ;; `control-thread' is responsible for dispatching requests to the
  ;; threads that should handle them; the `repl-thread' is the one
  ;; that evaluates REPL expressions. The control thread dispatches
  ;; all REPL evaluations to the REPL thread and for other requests it
  ;; spawns new threads.
  reader-thread
  control-thread
  repl-thread
  auto-flush-thread
  indentation-cache-thread
  ;; List of threads that are currently processing requests.  We use
  ;; this to find the newest/current thread for an interrupt.  In the
  ;; future we may store here (thread . request-tag) pairs so that we
  ;; can interrupt specific requests.
  (active-threads '() :type list)
  )

(defvar *emacs-connection* nil
  "The connection to Emacs currently in use.")

(defun make-connection (socket stream style)
  (let ((conn (funcall (ecase style
                         (:spawn 
                          #'make-multithreaded-connection)
                         ((:sigio nil :fd-handler)
                          #'make-singlethreaded-connection))
                       :socket socket
                       :socket-io stream
                       :communication-style style)))
    (run-hook *new-connection-hook* conn)
    (send-to-sentinel `(:add-connection ,conn))
    conn))

(defslimefun ping (tag)
  tag)

(defun safe-backtrace ()
  (ignore-errors 
    (call-with-debugging-environment 
     (lambda () (backtrace 0 nil)))))

(define-condition swank-error (error) 
  ((backtrace :initarg :backtrace :reader swank-error.backtrace)
   (condition :initarg :condition :reader swank-error.condition))
  (:report (lambda (c s) (princ (swank-error.condition c) s)))
  (:documentation "Condition which carries a backtrace."))

(defun signal-swank-error (condition &optional (backtrace (safe-backtrace)))
  (error 'swank-error :condition condition :backtrace backtrace))

(defvar *debug-on-swank-protocol-error* nil
  "When non-nil invoke the system debugger on errors that were
signalled during decoding/encoding the wire protocol.  Do not set this
to T unless you want to debug swank internals.")

(defmacro with-swank-error-handler ((connection) &body body)
  "Close the connection on internal `swank-error's."
  (let ((conn (gensym)))
  `(let ((,conn ,connection))
     (handler-case 
         (handler-bind ((swank-error 
                         (lambda (condition)
                           (when *debug-on-swank-protocol-error*
                             (invoke-default-debugger condition)))))
           (progn . ,body))
       (swank-error (condition)
         (close-connection ,conn
                           (swank-error.condition condition)
                           (swank-error.backtrace condition)))))))

(defmacro with-panic-handler ((connection) &body body)
  "Close the connection on unhandled `serious-condition's."
  (let ((conn (gensym)))
  `(let ((,conn ,connection))
     (handler-bind ((serious-condition
                     (lambda (condition)
                       (close-connection ,conn condition (safe-backtrace)))))
       . ,body))))

(add-hook *new-connection-hook* 'notify-backend-of-connection)
(defun notify-backend-of-connection (connection)
  (declare (ignore connection))
  (emacs-connected))


;;;; Utilities


;;;;; Logging

(defvar *swank-io-package*
  (let ((package (make-package :swank-io-package :use '())))
    (import '(nil t quote) package)
    package))

(defvar *log-events* nil)
(defvar *log-output* nil) ; should be nil for image dumpers

(defun init-log-output ()
  (unless *log-output*
    (setq *log-output* (real-output-stream *error-output*))))

(add-hook *after-init-hook* 'init-log-output)

(defun real-input-stream (stream)
  (typecase stream
    (synonym-stream 
     (real-input-stream (symbol-value (synonym-stream-symbol stream))))
    (two-way-stream
     (real-input-stream (two-way-stream-input-stream stream)))
    (t stream)))

(defun real-output-stream (stream)
  (typecase stream
    (synonym-stream 
     (real-output-stream (symbol-value (synonym-stream-symbol stream))))
    (two-way-stream
     (real-output-stream (two-way-stream-output-stream stream)))
    (t stream)))

(defvar *event-history* (make-array 40 :initial-element nil)
  "A ring buffer to record events for better error messages.")
(defvar *event-history-index* 0)
(defvar *enable-event-history* t)

(defun log-event (format-string &rest args)
  "Write a message to *terminal-io* when *log-events* is non-nil.
Useful for low level debugging."
  (with-standard-io-syntax
    (let ((*print-readably* nil)
          (*print-pretty* nil)
          (*package* *swank-io-package*))
      (when *enable-event-history*
        (setf (aref *event-history* *event-history-index*) 
              (format nil "~?" format-string args))
        (setf *event-history-index* 
              (mod (1+ *event-history-index*) (length *event-history*))))
      (when *log-events*
        (write-string (escape-non-ascii (format nil "~?" format-string args))
                      *log-output*)
        (force-output *log-output*)))))

(defun event-history-to-list ()
  "Return the list of events (older events first)."
  (let ((arr *event-history*)
        (idx *event-history-index*))
    (concatenate 'list (subseq arr idx) (subseq arr 0 idx))))

(defun clear-event-history ()
  (fill *event-history* nil)
  (setq *event-history-index* 0))

(defun dump-event-history (stream)
  (dolist (e (event-history-to-list))
    (dump-event e stream)))

(defun dump-event (event stream)
  (cond ((stringp event)
         (write-string (escape-non-ascii event) stream))
        ((null event))
        (t 
         (write-string
          (escape-non-ascii (format nil "Unexpected event: ~A~%" event))
          stream))))

(defun escape-non-ascii (string)
  "Return a string like STRING but with non-ascii chars escaped."
  (cond ((ascii-string-p string) string)
        (t (with-output-to-string (out)
             (loop for c across string do
               (cond ((ascii-char-p c) (write-char c out))
                     (t (format out "\\x~4,'0X" (char-code c)))))))))

(defun ascii-string-p (o)
  (and (stringp o)
       (every #'ascii-char-p o)))

(defun ascii-char-p (c) 
  (<= (char-code c) 127))


;;;;; Helper macros

(defmacro destructure-case (value &rest patterns)
  "Dispatch VALUE to one of PATTERNS.
A cross between `case' and `destructuring-bind'.
The pattern syntax is:
  ((HEAD . ARGS) . BODY)
The list of patterns is searched for a HEAD `eq' to the car of
VALUE. If one is found, the BODY is executed with ARGS bound to the
corresponding values in the CDR of VALUE."
  (let ((operator (gensym "op-"))
	(operands (gensym "rand-"))
	(tmp (gensym "tmp-")))
    `(let* ((,tmp ,value)
	    (,operator (car ,tmp))
	    (,operands (cdr ,tmp)))
       (case ,operator
         ,@(loop for (pattern . body) in patterns collect 
                 (if (eq pattern t)
                     `(t ,@body)
                     (destructuring-bind (op &rest rands) pattern
                       `(,op (destructuring-bind ,rands ,operands 
                               ,@body)))))
         ,@(if (eq (caar (last patterns)) t)
               '()
               `((t (error "destructure-case failed: ~S" ,tmp))))))))


;;;; Interrupt handling 

;; Usually we'd like to enter the debugger when an interrupt happens.
;; But for some operations, in particular send&receive, it's crucial
;; that those are not interrupted when the mailbox is in an
;; inconsistent/locked state. Obviously, if send&receive don't work we
;; can't communicate and the debugger will not work.  To solve that
;; problem, we try to handle interrupts only at certain safe-points.
;;
;; Whenever an interrupt happens we call the function
;; INVOKE-OR-QUEUE-INTERRUPT.  Usually this simply invokes the
;; debugger, but if interrupts are disabled the interrupt is put in a
;; queue for later processing.  At safe-points, we call
;; CHECK-SLIME-INTERRUPTS which looks at the queue and invokes the
;; debugger if needed.
;;
;; The queue for interrupts is stored in a thread local variable.
;; WITH-CONNECTION sets it up.  WITH-SLIME-INTERRUPTS allows
;; interrupts, i.e. the debugger is entered immediately.  When we call
;; "user code" or non-problematic code we allow interrupts.  When
;; inside WITHOUT-SLIME-INTERRUPTS, interrupts are queued.  When we
;; switch from "user code" to more delicate operations we need to
;; disable interrupts.  In particular, interrupts should be disabled
;; for SEND and RECEIVE-IF.

;; If true execute interrupts, otherwise queue them.
;; Note: `with-connection' binds *pending-slime-interrupts*.
(defvar *slime-interrupts-enabled*)

(defmacro with-interrupts-enabled% (flag body)
  `(progn
     ,@(if flag '((check-slime-interrupts)))
     (multiple-value-prog1
         (let ((*slime-interrupts-enabled* ,flag))
           ,@body)
       ,@(if flag '((check-slime-interrupts))))))

(defmacro with-slime-interrupts (&body body)
  `(with-interrupts-enabled% t ,body))

(defmacro without-slime-interrupts (&body body)
  `(with-interrupts-enabled% nil ,body))

(defun invoke-or-queue-interrupt (function)
  (log-event "invoke-or-queue-interrupt: ~a~%" function)
  (cond ((not (boundp '*slime-interrupts-enabled*))
         (without-slime-interrupts
           (funcall function)))
        (*slime-interrupts-enabled*
         (log-event "interrupts-enabled~%")
         (funcall function))
        (t
         (setq *pending-slime-interrupts*
               (nconc *pending-slime-interrupts*
                      (list function)))
         (cond ((cdr *pending-slime-interrupts*)
                (log-event "too many queued interrupts~%")
                (with-simple-restart (continue "Continue from interrupt")
                  (handler-bind ((serious-condition #'invoke-slime-debugger))
                    (check-slime-interrupts))))
               (t
                (log-event "queue-interrupt: ~a~%" function)
                (when *interrupt-queued-handler*
                  (funcall *interrupt-queued-handler*)))))))


;;; FIXME: poor name?
(defmacro with-io-redirection ((connection) &body body)
  "Execute BODY I/O redirection to CONNECTION. "
  `(with-bindings (connection.env ,connection)
     . ,body))

;; Thread local variable used for flow-control.
;; It's bound by `with-connection'.
(defvar *send-counter*)

(defmacro with-connection ((connection) &body body)
  "Execute BODY in the context of CONNECTION."
  `(let ((connection ,connection)
         (function (lambda () . ,body)))
     (if (eq *emacs-connection* connection)
         (funcall function)
         (let ((*emacs-connection* connection)
               (*pending-slime-interrupts* '())
               (*send-counter* 0))
           (without-slime-interrupts
             (with-swank-error-handler (connection)
               (with-io-redirection (connection)
                 (call-with-debugger-hook #'swank-debugger-hook 
                                          function))))))))

(defun call-with-retry-restart (msg thunk)
  (loop (with-simple-restart (retry "~a" msg)
          (return (funcall thunk)))))

(defmacro with-retry-restart ((&key (msg "Retry.")) &body body)
  (check-type msg string)
  `(call-with-retry-restart ,msg (lambda () ,@body)))

(defmacro with-struct* ((conc-name get obj) &body body)
  (let ((var (gensym)))
    `(let ((,var ,obj))
       (macrolet ((,get (slot)
                    (let ((getter (intern (concatenate 'string
                                                       ',(string conc-name)
                                                       (string slot))
                                          (symbol-package ',conc-name))))
                      `(,getter ,',var))))
         ,@body))))

(defmacro define-special (name doc)
  "Define a special variable NAME with doc string DOC.
This is like defvar, but NAME will not be initialized."
  `(progn
    (defvar ,name)
    (setf (documentation ',name 'variable) ,doc)))


;;;;; Sentinel
;;;
;;; The sentinel thread manages some global lists.
;;; FIXME: Overdesigned?

(defvar *connections* '()
  "List of all active connections, with the most recent at the front.")

(defvar *servers* '()
  "A list ((server-socket port thread) ...) describing the listening sockets.
Used to close sockets on server shutdown or restart.")

;; FIXME: we simply access the global variable here.  We could ask the
;; sentinel thread instead but then we still have the problem that the
;; connection could be closed before we use it.  
(defun default-connection ()
  "Return the 'default' Emacs connection.
This connection can be used to talk with Emacs when no specific
connection is in use, i.e. *EMACS-CONNECTION* is NIL.

The default connection is defined (quite arbitrarily) as the most
recently established one."
  (car *connections*))

(defun start-sentinel () 
  (unless (find-registered 'sentinel)
    (let ((thread (spawn #'sentinel :name "Swank Sentinel")))
      (register-thread 'sentinel thread))))

(defun sentinel ()
  (catch 'exit-sentinel
    (loop (sentinel-serve (receive)))))

(defun send-to-sentinel (msg)
  (let ((sentinel (find-registered 'sentinel)))
    (cond (sentinel (send sentinel msg))
          (t (sentinel-serve msg)))))

(defun sentinel-serve (msg)
  (destructure-case msg
    ((:add-connection conn)
     (push conn *connections*))
    ((:close-connection connection condition backtrace)
     (close-connection% connection condition backtrace)
     (sentinel-maybe-exit))
    ((:add-server socket port thread)
     (push (list socket port thread) *servers*))
    ((:stop-server key port)
     (sentinel-stop-server key port)
     (sentinel-maybe-exit))))

(defun sentinel-stop-server (key value)
  (let ((probe (find value *servers* :key (ecase key 
                                            (:socket #'car)
                                            (:port #'cadr)))))
    (cond (probe 
           (setq *servers* (delete probe *servers*))
           (destructuring-bind (socket _port thread) probe
             (declare (ignore _port))
             (ignore-errors (close-socket socket))
             (when (and thread 
                        (thread-alive-p thread)
                        (not (eq thread (current-thread))))
               (kill-thread thread))))
          (t
           (warn "No server for ~s: ~s" key value)))))

(defun sentinel-maybe-exit ()
  (when (and (null *connections*)
             (null *servers*)
             (and (current-thread)
                  (eq (find-registered 'sentinel)
                      (current-thread))))
    (register-thread 'sentinel nil)
    (throw 'exit-sentinel nil)))


;;;;; Misc

(defun use-threads-p ()
  (eq (connection.communication-style *emacs-connection*) :spawn))

(defun current-thread-id ()
  (thread-id (current-thread)))

(declaim (inline ensure-list))
(defun ensure-list (thing)
  (if (listp thing) thing (list thing)))


;;;;; Symbols

;; FIXME: this docstring is more confusing than helpful.
(defun symbol-status (symbol &optional (package (symbol-package symbol)))
  "Returns one of 

  :INTERNAL  if the symbol is _present_ in PACKAGE as an _internal_ symbol,

  :EXTERNAL  if the symbol is _present_ in PACKAGE as an _external_ symbol,

  :INHERITED if the symbol is _inherited_ by PACKAGE through USE-PACKAGE,
             but is not _present_ in PACKAGE,

  or NIL     if SYMBOL is not _accessible_ in PACKAGE.


Be aware not to get confused with :INTERNAL and how \"internal
symbols\" are defined in the spec; there is a slight mismatch of
definition with the Spec and what's commonly meant when talking
about internal symbols most times. As the spec says:

  In a package P, a symbol S is
  
     _accessible_  if S is either _present_ in P itself or was
                   inherited from another package Q (which implies
                   that S is _external_ in Q.)
  
        You can check that with: (AND (SYMBOL-STATUS S P) T)
  
  
     _present_     if either P is the /home package/ of S or S has been
                   imported into P or exported from P by IMPORT, or
                   EXPORT respectively.
  
                   Or more simply, if S is not _inherited_.
  
        You can check that with: (LET ((STATUS (SYMBOL-STATUS S P)))
                                   (AND STATUS 
                                        (NOT (EQ STATUS :INHERITED))))
  
  
     _external_    if S is going to be inherited into any package that
                   /uses/ P by means of USE-PACKAGE, MAKE-PACKAGE, or
                   DEFPACKAGE.
  
                   Note that _external_ implies _present_, since to
                   make a symbol _external_, you'd have to use EXPORT
                   which will automatically make the symbol _present_.
  
        You can check that with: (EQ (SYMBOL-STATUS S P) :EXTERNAL)
  
  
     _internal_    if S is _accessible_ but not _external_.

        You can check that with: (LET ((STATUS (SYMBOL-STATUS S P)))
                                   (AND STATUS 
                                        (NOT (EQ STATUS :EXTERNAL))))
  

        Notice that this is *different* to
                                 (EQ (SYMBOL-STATUS S P) :INTERNAL)
        because what the spec considers _internal_ is split up into two
        explicit pieces: :INTERNAL, and :INHERITED; just as, for instance,
        CL:FIND-SYMBOL does. 

        The rationale is that most times when you speak about \"internal\"
        symbols, you're actually not including the symbols inherited 
        from other packages, but only about the symbols directly specific
        to the package in question.
"
  (when package     ; may be NIL when symbol is completely uninterned.
    (check-type symbol symbol) (check-type package package)
    (multiple-value-bind (present-symbol status)
        (find-symbol (symbol-name symbol) package)
      (and (eq symbol present-symbol) status))))

(defun symbol-external-p (symbol &optional (package (symbol-package symbol)))
  "True if SYMBOL is external in PACKAGE.
If PACKAGE is not specified, the home package of SYMBOL is used."
  (eq (symbol-status symbol package) :external))


;;;; TCP Server

(defvar *communication-style* (preferred-communication-style))

(defvar *dont-close* nil
  "Default value of :dont-close argument to start-server and
  create-server.")

(defun start-server (port-file &key (style *communication-style*)
                                    (dont-close *dont-close*))
  "Start the server and write the listen port number to PORT-FILE.
This is the entry point for Emacs."
  (setup-server 0
                (lambda (port) (announce-server-port port-file port))
                style dont-close nil))

(defun create-server (&key (port default-server-port)
                        (style *communication-style*)
                        (dont-close *dont-close*)
                        backlog)
  "Start a SWANK server on PORT running in STYLE.
If DONT-CLOSE is true then the listen socket will accept multiple
connections, otherwise it will be closed after the first."
  (setup-server port #'simple-announce-function
                style dont-close backlog))

(defun find-external-format-or-lose (coding-system)
  (or (find-external-format coding-system)
      (error "Unsupported coding system: ~s" coding-system)))

(defparameter *loopback-interface* "127.0.0.1")

(defun setup-server (port announce-fn style dont-close backlog)
  (init-log-output)
  (let* ((socket (create-socket *loopback-interface* port :backlog backlog))
         (port (local-port socket)))
    (funcall announce-fn port)
    (labels ((serve () (accept-connections socket style dont-close))
             (note () (send-to-sentinel `(:add-server ,socket ,port 
                                                      ,(current-thread))))
             (serve-loop () (note) (loop do (serve) while dont-close)))
      (ecase style
        (:spawn (initialize-multiprocessing 
                 (lambda ()
                   (start-sentinel)
                   (spawn #'serve-loop :name (format nil "Swank ~s" port)))))
        ((:fd-handler :sigio) 
         (note) 
         (add-fd-handler socket #'serve))
        ((nil) (serve-loop))))
    port))

(defun stop-server (port)
  "Stop server running on PORT."
  (send-to-sentinel `(:stop-server :port ,port)))

(defun restart-server (&key (port default-server-port)
                       (style *communication-style*)
                       (dont-close *dont-close*))
  "Stop the server listening on PORT, then start a new SWANK server 
on PORT running in STYLE. If DONT-CLOSE is true then the listen socket 
will accept multiple connections, otherwise it will be closed after the 
first."
  (stop-server port)
  (sleep 5)
  (create-server :port port :style style :dont-close dont-close))

(defun accept-connections (socket style dont-close)
  (let ((client (unwind-protect 
                     (accept-connection socket :external-format nil
                                               :buffering t)
                  (unless dont-close
                    (close-socket socket)))))
    (authenticate-client client)
    (serve-requests (make-connection socket client style))
    (unless dont-close
      (send-to-sentinel `(:stop-server :socket ,socket)))))

(defun authenticate-client (stream)
  (let ((secret (slime-secret)))
    (when secret
      (set-stream-timeout stream 20)
      (let ((first-val (decode-message stream)))
        (unless (and (stringp first-val) (string= first-val secret))
          (error "Incoming connection doesn't know the password.")))
      (set-stream-timeout stream nil))))

(defun slime-secret ()
  "Finds the magic secret from the user's home directory.  Returns nil
if the file doesn't exist; otherwise the first line of the file."
  (with-open-file (in
                   (merge-pathnames (user-homedir-pathname) #p".slime-secret")
                   :if-does-not-exist nil)
    (and in (read-line in nil ""))))

(defun serve-requests (connection)
  "Read and process all requests on connections."
  (etypecase connection
    (multithreaded-connection
     (spawn-threads-for-connection connection))
    (singlethreaded-connection
     (ecase (connection.communication-style connection)
       ((nil) (simple-serve-requests connection))
       (:sigio (install-sigio-handler connection))
       (:fd-handler (install-fd-handler connection))))))

(defun stop-serving-requests (connection)
  (etypecase connection
    (multithreaded-connection
     (cleanup-connection-threads connection))
    (singlethreaded-connection
     (ecase (connection.communication-style connection)
       ((nil))
       (:sigio (deinstall-sigio-handler connection))
       (:fd-handler (deinstall-fd-handler connection))))))

(defun announce-server-port (file port)
  (with-open-file (s file
                     :direction :output
                     :if-exists :error
                     :if-does-not-exist :create)
    (format s "~S~%" port))
  (simple-announce-function port))

(defun simple-announce-function (port)
  (when *swank-debug-p*
    (format *log-output* "~&;; Swank started at port: ~D.~%" port)
    (force-output *log-output*)))


;;;;; Event Decoding/Encoding

(defun decode-message (stream)
  "Read an S-expression from STREAM using the SLIME protocol."
  (log-event "decode-message~%")
  (without-slime-interrupts
    (handler-bind ((error #'signal-swank-error))
      (handler-case (read-message stream *swank-io-package*)
        (swank-reader-error (c) 
          `(:reader-error ,(swank-reader-error.packet c)
                          ,(swank-reader-error.cause c)))))))

(defun encode-message (message stream)
  "Write an S-expression to STREAM using the SLIME protocol."
  (log-event "encode-message~%")
  (without-slime-interrupts
    (handler-bind ((error #'signal-swank-error))
      (write-message message *swank-io-package* stream))))


;;;;; Event Processing

(defvar *sldb-quit-restart* nil
  "The restart that will be invoked when the user calls sldb-quit.")

;; Establish a top-level restart and execute BODY.
;; Execute K if the restart is invoked.
(defmacro with-top-level-restart ((connection k) &body body)
  `(with-connection (,connection)
     (restart-case
         (let ((*sldb-quit-restart* (find-restart 'abort)))
           ,@body)
       (abort (&optional v)
         :report "Return to SLIME's top level."
         (declare (ignore v))
         (force-user-output)
         ,k))))

(defun handle-requests (connection &optional timeout)
  "Read and process :emacs-rex requests.
The processing is done in the extent of the toplevel restart."
  (with-connection (connection)
    (cond (*sldb-quit-restart*
           (process-requests timeout))
          (t
           (tagbody
            start
              (with-top-level-restart (connection (go start))
                (process-requests timeout)))))))

(defun process-requests (timeout)
  "Read and process requests from Emacs."
  (loop
   (multiple-value-bind (event timeout?)
       (wait-for-event `(or (:emacs-rex . _)
                            (:emacs-channel-send . _))
                       timeout)
    (when timeout? (return))
    (destructure-case event
      ((:emacs-rex &rest args) (apply #'eval-for-emacs args))
      ((:emacs-channel-send channel (selector &rest args))
       (channel-send channel selector args))))))

(defun current-socket-io ()
  (connection.socket-io *emacs-connection*))

(defun close-connection (connection condition backtrace)
  (send-to-sentinel `(:close-connection ,connection ,condition ,backtrace)))

(defun close-connection% (c condition backtrace)
  (let ((*debugger-hook* nil))
    (log-event "close-connection: ~a ...~%" condition))
  (format *log-output* "~&;; swank:close-connection: ~A~%"
          (escape-non-ascii (safe-condition-message condition)))
  (stop-serving-requests c)
  (close (connection.socket-io c))
  (when (connection.dedicated-output c)
    (close (connection.dedicated-output c)))
  (setf *connections* (remove c *connections*))
  (run-hook *connection-closed-hook* c)
  (when (and condition (not (typep condition 'end-of-file)))
    (finish-output *log-output*)
    (format *log-output* "~&;; Event history start:~%")
    (dump-event-history *log-output*)
    (format *log-output* ";; Event history end.~%~
                        ;; Backtrace:~%~{~A~%~}~
                        ;; Connection to Emacs lost. [~%~
                        ;;  condition: ~A~%~
                        ;;  type: ~S~%~
                        ;;  style: ~S]~%"
            (loop for (i f) in backtrace collect 
                  (ignore-errors (format nil "~d: ~a" i (escape-non-ascii f))))
            (escape-non-ascii (safe-condition-message condition) )
            (type-of condition)
            (connection.communication-style c)))
  (finish-output *log-output*)
  (log-event "close-connection ~a ... done.~%" condition))

;;;;;; Thread based communication

(defun read-loop (connection)
  (let ((input-stream (connection.socket-io connection))
        (control-thread (mconn.control-thread connection)))
    (with-swank-error-handler (connection)
      (loop (send control-thread (decode-message input-stream))))))

(defun dispatch-loop (connection)
  (let ((*emacs-connection* connection))
    (with-panic-handler (connection)
      (loop (dispatch-event connection (receive))))))

(defvar *auto-flush-interval* 0.2)

(defun auto-flush-loop (stream)
  (loop
   (when (not (and (open-stream-p stream)
                   (output-stream-p stream)))
     (return nil))
   (force-output stream)