(in-package :interface)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Interface macros lifted from swank-backend.lisp
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defparameter *interface-functions* '()
   "The names of all interface functions.")

(defparameter *unimplemented-interfaces* '()
   "List of interface functions that are not implemented.
   DEFINTERFACE adds to this list and DEFIMPLEMENTATION removes.")

(defmacro definterface (name args documentation &rest default-body)
  "Define an interface function for the backend to implement.
A generic function is defined with NAME, ARGS, and DOCUMENTATION.

If a DEFAULT-BODY is supplied then NO-APPLICABLE-METHOD is specialized
to execute the body if the backend doesn't provide a specific
implementation.

Backends implement these functions using DEFIMPLEMENTATION."
  (check-type documentation string "a documentation string")
  (flet ((gen-default-impl ()
           `(defmethod ,name ,args ,@default-body)))
    `(progn (defgeneric ,name ,args (:documentation ,documentation))
            (pushnew ',name *interface-functions*)
            ,(if (null default-body)
                 `(pushnew ',name *unimplemented-interfaces*)
                 (gen-default-impl))
            ;; 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 :interface))
            ',name)))

(defmacro defimplementation (name args &body body)
  `(progn (defmethod ,name ,args ,@body)
          (if (member ',name *interface-functions*)
              (setq *unimplemented-interfaces*
                    (remove ',name *unimplemented-interfaces*))
              (warn "DEFIMPLEMENTATION of undefined interface (~S)" ',name))
          ',name))

(defun warn-unimplemented-interfaces ()
  "Warn the user about unimplemented backend features.
The portable code calls this function at startup."
  (warn "These Swank interfaces are unimplemented:~% ~A"
        (sort (copy-list *unimplemented-interfaces*) #'string<)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(definterface connect-socket (host port)
 "Create a TCP connection to host on port")

(definterface make-socket-io-stream (socket)
 "Convert a socket to a Lisp stream")

(definterface sldb-activate (thread level)
 "Called in response to a :debug-activate message"
 (format t "Got generic sldb-activate~%"))

(definterface sldb-setup (thread level condition restarts frames conts)
 "Prepare the debugger"
 (format t "Got generic sldb-setup~%"))

(definterface sldb-exit (thread level &optional stepping)
 "Exit the debug interface"
 (format t "Got generic sldb-exit~%"))

(definterface handle-indentation-update (alist)
 "Swank sends the message :indentation-update, which will call this function"
 (format t "Got generic handle-indentation-update~%"))

(definterface new-listener-package (package prompt-string)
 "Swank sends :new-package when the REPL listener changes package.  This function gets called then"
 (format t "Got generic new-listener-package~%"))

(definterface slime-send-sigint (pid)
 "Sending signals is pretty platform specific"
 (format t "Got generic slime-send-sigint~%"))

(definterface slime-send-sigterm (pid)
 "Sending signals is pretty platform specific"
 (format t "Got generic slime-send-sigterm~%"))