;;; swank-clisp.lisp - SWANK for CLISP
;;; Created 2003, Vladimir Sedach <sedachv@cpsc.ucalgary.ca>
;;;
;;; As seems to be fashionable,
;;; This code has been placed in the Public Domain.  All warranties are 
;;; disclaimed.

;;; Confirmed working under CLISP 2.31. Maybe also works on 2.30 (untested)
;;; Definitly will not run on CLISP 2.29 or below

;;; The goodies (what's working):
;; - All communication stuff seems to have been massaged
;; - Completion, arglist, apropos, describe symbol, disassemble symbol, macroexpansion
;; - Everything in eval easy-menu
;; - Most things to do with compiling
;; - A lot (most?) of debugging stuff

;;; What doesn't work:
;; - Most debugging conditions use *query-io*, and the slime state-machine gets stuck on :read-string
;; - Compiler notes aren't implemented
;; - SLIME's completion fails, so we use CLISP's native one (you won't notice the difference!)
;; - CLISP apropos seems a little funny
;; - ASDF and hence the system functions
;; - XREF (until it's ported)
;; - Frame source location
;; - Multiprocessing (until someone finishes it for CLISP)

(in-package :swank)

;;; Gray streams stuff
(import
 '(gray:fundamental-character-output-stream
   gray:stream-write-char
   gray:stream-force-output
   gray:fundamental-character-input-stream
   gray:stream-read-char
   gray:stream-listen
   gray:stream-unread-char
   gray:stream-clear-input
   gray:stream-line-column))

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

;;; Multiprocessing stuff

(setq *multiprocessing-enabled* nil)

(defun without-interrupts* (body)
  (funcall body))

;;; System stuff

;;;; !!! Does this work on windows?
(defslimefun getpid ()
   (system::program-id))

;;; Networking code

(defvar *use-dedicated-output-stream* t
  "Right now in CLISP, we have no choice but to use it. This is here mostly for
documentation purposes")

(defun get-socket-stream (port announce close-socket-p)
  (let ((socket (socket:socket-server port)))
    (socket:socket-wait socket 0)
    (funcall announce (socket:socket-server-port socket))
    (prog1
	(socket:socket-accept socket :external-format charset:iso-8859-1) ; note that we need 8-bit chars
	(when close-socket-p
	  (socket:socket-server-close socket)))))

(defun serve-request (*emacs-io* *slime-output* *slime-input* *slime-io*)
  "Read and process a request from a SWANK client.
The request is read from the socket as a sexp and then evaluated."
  (catch 'slime-toplevel
    (handler-case (read-from-emacs)
		  (ext:simple-charset-type-error (err)
					       (format *debug-io* "Wrong slime stream encoding:~%~A" err))
		  (slime-read-error (e)
				    (when *swank-debug-p*
				      (format *debug-io* "~&;; Connection to Emacs lost.~%;; [~A]~%" e))
				    (close *emacs-io* :abort t)
				    (when *use-dedicated-output-stream* 
				      (close *slime-output* :abort t))
				    (throw 'closed-connection
					   (print "Connection to emacs closed" *debug-io*))))))

(defun open-stream-to-emacs ()
  "Return an output-stream to Emacs' output buffer."
  (let* ((listener (socket:socket-server))
 	 (port (socket:socket-server-port listener)))
    (unwind-protect
	(prog2
	  (eval-in-emacs `(slime-open-stream-to-lisp ,port))
	  (socket:socket-accept listener))
      (socket:socket-server-close listener))))

(defun create-swank-server (port &key (announce #'simple-announce-function)
				 reuse-address
				 background
				 (close-socket-p t))
  (declare (ignore reuse-address background))
  (let* ((emacs (get-socket-stream port announce close-socket-p))
	 (slime-out (let ((*emacs-io* emacs)) (open-stream-to-emacs)))
	 (slime-in (make-instance 'slime-input-stream))
	 (slime-io (make-two-way-stream slime-in slime-out)))
    (catch 'closed-connection
      (loop (serve-request emacs slime-out slime-in slime-io)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Utilities

;;; Cribbed from swank-sbcl
(defslimefun set-default-directory (directory)
  (setf *default-pathname-defaults* (merge-pathnames directory))
  (namestring *default-pathname-defaults*))

(defmethod arglist-string (fname)
  (let ((*print-case* :downcase))
    (multiple-value-bind (arglist condition)
 	(ignore-errors (let ((*package* *buffer-package*))
 			 (cl-user::arglist (read-from-string fname))))
      (if condition
	  (return-from arglist-string (format nil "(-- ~A)" condition))
	(princ-to-string arglist)))))

(defslimefun completions (string default-package-name)
  "CLISP doesn't like SLIME's routine."
  (let ((comps (system::completion string 0 (length string))))
    (list comps (car comps))))

;;; Cribbed from SBCL
(defmethod describe-symbol-for-emacs (symbol)
  "Return a plist describing SYMBOL.
Return NIL if the symbol is unbound."
  (let ((result ()))
    (labels ((doc (kind)
	       (or (documentation symbol kind) :not-documented))
	     (maybe-push (property value)
	       (when value
		 (setf result (list* property value result)))))
      (when (fboundp symbol)
	(if (macro-function symbol)
	    (setf (getf result :macro) (doc 'function))
	  (setf (getf result :function) (doc 'function))))
      (maybe-push :variable (when (boundp symbol) (doc 'variable)))
      (maybe-push :class (when (find-class symbol nil) (doc 'type))) ;this should be fixed
      result)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Debugging stuff

(defvar *swank-debugger-stack-frame* nil)
(defvar *swank-debugger-condition*)
(defvar *sldb-restarts* nil)
(defvar *sldb-topframe* nil)
(setq *sldb-initial-frames* 5)

; debugging hooks

(defmethod call-with-debugging-environment (func)
  (let ((*sldb-topframe* (system::the-frame))
	(*sldb-restarts*
         (compute-restarts *swank-debugger-condition*))
	(*debugger-hook* nil)
	(*print-level* nil)
	(*print-length* nil)
	(*print-circle* t)
	(*print-escape* nil)
	(*print-readably* nil)
	(*print-pretty* nil))
  (system::same-env-as *sldb-topframe* (funcall func))))

;;; Taken from swank-sbcl
(defun format-condition-for-emacs ()
  (format nil "~A~%   [Condition of type ~S]"
	  (ignore-errors *swank-debugger-condition*)
          (type-of *swank-debugger-condition*)))

;;; Taken from swank-cmucl
(defun format-restarts-for-emacs ()
  "Return a list of restarts for *swank-debugger-condition* in a
format suitable for Emacs."
  (loop for restart in *sldb-restarts*
	collect (list (princ-to-string (restart-name restart))
		      (princ-to-string restart))))

;;; cribbed from swank-cmucl
 (defun nth-frame (index)
   (do ((frame *sldb-topframe* (system::frame-down-1 frame 1))
        (i index (1- i)))
       ((zerop i) frame)))

;(defun nth-frame (index)
;  (system::frame-limit1 index))

;;; from swank-cmucl
(defun nth-restart (index)
  (nth index *sldb-restarts*))

;;; from swank-cmucl
(defun 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."
  (loop for f = (nth-frame start) then (system::frame-down-1 f 1)
	for i from start below end
	while f
	collect (cons i f)))

;;; from swank-cmucl
(defun format-frame-for-emacs (frame)
  (remove #\Newline 
	  (with-output-to-string (*frame-output*) 
				 (let ((*print-pretty* *sldb-pprint-frames*))
				   (system::describe-frame *frame-output* frame)))))

;;; from swank-cmucl
(defmethod backtrace (start end)
  (loop for (n . frame) in (compute-backtrace start end)
        collect (list n (format-frame-for-emacs frame))))

;;; Cribbed from swank-sbcl
(defmethod debugger-info-for-emacs (start end)
  (list (format-condition-for-emacs)
	(format-restarts-for-emacs)
	(backtrace start end)))

(defmethod eval-in-frame (form index)
  (system::same-env-as (nth-frame index) (eval form)))

;;; from swank-sbcl
(defslimefun invoke-nth-restart (index)
  (invoke-restart-interactively (nth-restart index)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; Compilation hooks

(defmethod compile-system-for-emacs (system-name)
  nil)

;;; Cribbed from swank-sbcl
(defmethod compile-file-for-emacs (filename load-p)
  (with-compilation-hooks ()
    (multiple-value-bind (comp-file w-p f-p) (compile-file filename)
      (cond ((and comp-file (not f-p) load-p)
             (load comp-file))
            (t comp-file)))))

;;; Cribbed from swank-sbcl
(defmethod compile-string-for-emacs (string &key buffer position)
  (with-compilation-hooks ()
    (let ((*package* *buffer-package*)
          (*buffer-name* buffer)
          (*buffer-offset* position))
      (eval (from-string
             (format nil "(funcall (compile nil '(lambda () ~A)))"
                     string))))))

(defun handle-compiler-error (comp-error)
  (signal (make-condition
	   'compiler-condition
	   :original-condition condition
	   :severity :error
	   :message (format nil "~A" condition))))

;;; borrowed from swank-sbcl
(defmethod call-with-compilation-hooks (func)
  (handler-bind ((system::compiler-error  #'handle-compiler-error)
		 ;(cl-user::style-warning  #'handle-notification-condition) in the future there will be warnings
                 ;(cl-user::simple-warning #'handle-notification-condition)
		 ;(cl-user::warning        #'handle-notification-condition)
		 )
    (funcall func)))

(defmethod macroexpand-all (form)
  "Expand-form returns the expanded form as the primary value and t if
any macroexpansion has been done."
  (ext:expand-form form))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Unimplemented
;;; Cribbed from swank-sbcl (CLISP likewise has an xref deficiency)

(defslimefun-unimplemented who-calls (function-name))

(defslimefun-unimplemented who-references (variable))

(defslimefun-unimplemented who-binds (variable))

(defslimefun-unimplemented who-sets (variable))

(defslimefun-unimplemented who-macroexpands (macro))