;;; -*- Mode: LISP; Package: :cl-user; BASE: 10; Syntax: ANSI-Common-Lisp; -*-
;;;
;;;   Touched: Sun Aug 21 10:49:13 2005 +0530 <enometh@net.meer>
;;;   Time-stamp: <06/03/23 20:48:50 madhu>
;;;   Bugs-To: <enometh@net.meer>
;;;
;;; CMUCL client for the swank protocol in slime 050819
;;; Copyright (C) 2005 Madhu.
;;;
;;; Minor changes for compatability with MCL 5.1
;;; Copyright (C) 2007 Terje Norderhaug <terje@in-progress.com>
;;;
;;; You are hereby granted the rights to distribute and use this
;;; software as governed by the terms of the Lisp Lesser GNU Public
;;; License (http://opensource.franz.com/preamble.html), known as the
;;; LLGPL.
;;;
;;; This software is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.

;;; WARNING: meanings of symbols are are different from the `slime.el'
;;; file from which this file is derived.
;;;
(defpackage :swank-client (:use :cl))
(in-package :swank-client)

#+mcl ;; temporary hack, consider just loading package definition from swank instead!
(unless (find-package 'swank)
  (defpackage :swank
    (:export 
     connection-info
     quit-lisp
     throw-to-toplevel)))

(defvar slime-dispatching-connection nil
  "Network process currently executing.
This is dynamically bound while handling messages from Lisp; it
overrides `slime-default-connection'.")

(defvar slime-default-connection nil
  "Network connection to use by default.
Used for all Lisp communication, except when overridden by
`slime-dispatching-connection'")

(defvar slime-net-processes nil
  "List of processes (sockets) connected to Lisps.")

(defvar slime-net-coding-system nil	; bogus
  "*Coding system used for network connections.
See also `slime-net-valid-coding-systems'.")

(defvar slime-net-valid-coding-systems	; bogus
  '((iso-latin-1-unix nil :iso-latin-1-unix)
    (iso-8859-1-unix  nil :iso-latin-1-unix)
    (binary           nil :iso-latin-1-unix)
    (utf-8-unix       t   :utf-8-unix)
    (emacs-mule-unix  t   :emacs-mule-unix))
  "A list of valid coding systems.
Each element is of the form: (NAME MULTIBYTEP CL-NAME)")

(defun slime-secret (&optional
		     (file #p"home:.slime-secret") )
  ;; with cmucl 19c -- touch the file first, mad 060108
  "Finds the magic secret from the user's home directory.
Returns nil if the file doesn't exist or is empty; otherwise the first
line of the file."
  (with-open-file (stream file :if-does-not-exist nil)
    (when stream
      (read-line stream nil nil))))

;;; TODO integrate challenge authentication from auth2; crypticl;

;;; ----------------------------------------------------------------------
;;;
;;; start the server with, say: (swank 9006)
;;;
(defun swank (&optional (port 4005) (style nil))
  ;;(and style (ecase style ((:fd-handler :sigio :spawn))))
  (progn
    (cl:require 'swank #p"home:/elisp/pkg/slime/swank-loader") ; XXX
    (provide 'swank))
  (set (cl:find-symbol "*USE-DEDICATED-OUTPUT-STREAM*" :swank)
	nil)
  (set (cl:find-symbol "*LOG-EVENTS*" :SWANK)
       t)
  (set (cl:find-symbol "*GLOBAL-DEBUGGER*" :SWANK)
       nil)
  (set (cl:find-symbol "*GLOBALLY-REDIRECT-IO*" :SWANK)
       nil)
  (set (cl:find-symbol "*CONFIGURE-EMACS-INDENTATION*" :SWANK)
       nil)
  (unwind-protect
       (funcall (cl:find-symbol "SETUP-SERVER" :swank) port
		(lambda (x)
		  (print x)
		  (terpri)
		  (warn "set up ~a" x)
		  (force-output))
		style
		nil			; more crap.
		:iso-latin-1-unix)
    (setf *debugger-hook* nil)))

;;;
;;;
;;;

#+cmucl
(require 'simple-streams)

#+cmucl
(defun %open-network-connection (host port)
  "returns a socket simple stream"; mad 050826
   (make-instance 'stream::socket-simple-stream
		  :remote-host host
		  :remote-port port
		  :direction :io))

#+mcl
(require :opentransport)

#+mcl
(defun %open-network-connection (host port)
  (ccl::open-tcp-stream host port))

#+nil
(slime-secret)

;;; Interface
(defun slime-net-connect (host port &optional (set-default-p t))
  "Establish a connection with a CL."
  (let ((socket (%open-network-connection host port)
	 #+nil(ext:connect-to-inet-socket host port :stream)))
    #+cmucl
    (let ((fd (stream::stream-input-handle socket)))
      (when fd
	(unix:unix-fcntl fd unix:f-setfl unix:fndelay))
      (let ((ofd (stream::stream-output-handle socket)))
	(when (and ofd (not (= ofd fd)))
	  (unix:unix-fcntl ofd unix:f-setfl unix:fndelay))))
    (when set-default-p (setq slime-default-connection socket))
    (push socket slime-net-processes)
    (let ((secret (slime-secret)))
      (when secret
	(slime-net-send secret socket)
	#+ignore
	(write-line secret socket)))
    socket))

#+nil
(setq $a (slime-net-connect "localhost" 9066))


;;;  Event logging
;;;
(defvar slime-log-events #+mcl NIL #+cmucl T
  "Log protocol events")

(defun slime-log-event (event)
  "Record the fact that EVENT occurred."
  (when slime-log-events
    (warn "log-event: ~S" event)))


;;;
;;;
(defun slime-net-encode-length (n)
  "Encode an integer into a 24-bit hex string."
  (format nil "~6,'0,X" n))

(defun slime-safe-encoding-p (coding-system string) ; bogus
  (declare (ignore coding-system string))
  t)


;;; dummy package for sending package qualified sexps from LISP
;;;
(defvar +null-package+
  (let ((package (make-package :null-package :use nil)))
    package))

(defun %slime-send (sexp)
  (let* ((msg (concatenate 'string
			   (let ((*package* +null-package+))
			     (cl:prin1-to-string sexp))
			   #+nil
			   (string #\Return)))
         (string (concatenate 'string (slime-net-encode-length
				       (length msg)) msg))
         (coding-system			; XXX
          #+cmucl
	  (STREAM::STREAM-EXTERNAL-FORMAT proc)
          #+mcl
          (stream-external-format slime-default-connection)))
    (slime-log-event sexp)
    (cond ((slime-safe-encoding-p coding-system string)
	   (write-sequence string #+cmucl proc #+mcl slime-default-connection))
          (t (error "Coding system ~s not suitable for ~S"
                    coding-system string)))))


;;;
;;; Interface
(defun slime-net-send (sexp proc)
  "Send a SEXP to Lisp over the socket PROC.
This is the lowest level of communication. The sexp will be READ and
EVAL'd by Lisp."
  (let* ((msg (concatenate 'string
			   (let ((*package* +null-package+))
			     (cl:prin1-to-string sexp))
			   #+nil
			   (string #\Return)))
         (string (concatenate 'string (slime-net-encode-length
				       (length msg)) msg))
         (coding-system  ; XXX
          #+cmucl
	  (STREAM::STREAM-EXTERNAL-FORMAT proc)
          #+mcl
          (stream-external-format proc)))
    (slime-log-event sexp)
    (cond ((slime-safe-encoding-p coding-system string)
	   (write-sequence string proc))
          (t (error "Coding system ~s not suitable for ~S"
                    coding-system string)))))


(defun slime-net-close (process)
;;  (when (open-stream-p process)		;XXX
  (close process :abort t);;)
  (setq slime-net-processes (remove process slime-net-processes))
  (when (eq process slime-default-connection)
    (setq slime-default-connection nil)))


(let* ((max 10240)		    ; XXX "resourced via closure vars"
       (seq (make-array 6 :element-type 'character))
       (buf (make-array max :element-type 'character #+mcl :adjustable #+mcl T :fill-pointer t)))

  (defun slime-net-read (stream)
    "Read a message from the network buffer."
    (read-sequence seq stream)
    (let ((len (parse-integer seq :radix 16)))
      (assert (< len max))
      (setf (fill-pointer buf) len)
      (read-sequence buf stream)
      (let (*read-eval*)
	(read-from-string buf)))))



;;; Connection environment. values are plists
;;;
;;;
(defvar *connection-environment* (make-hash-table :test #'eq))

(defmacro slime-def-connection-var (varname &rest initial-value-and-doc)
  "Define a connection-local variable.
The value of the variable can be read by calling the function of the
same name (it must not be accessed directly). The accessor function is
setf-able.

The actual variable bindings are stored per connection in
`*connection-environment*'. The accessor function refers to the
binding for `slime-connection'."
  `(progn
     ;; Variable
     (defvar ,varname ,@initial-value-and-doc) ; holds the default!
     ;; Accessor
     (defun ,varname (&optional (process slime-dispatching-connection))
       (assert process)
       (getf (gethash process *connection-environment*) ',varname
	     ,varname))
     (defsetf ,varname (&optional (process 'slime-dispatching-connection))
	 (store)
       `(progn
	  (assert ,process)
	  (setf (getf (gethash ,process *connection-environment*) ',',varname)
		,store)))
     '(,varname)))


(slime-def-connection-var slime-connection-number nil
  "Serial number of a connection.
Bound in the connection's process-buffer.")

(slime-def-connection-var slime-lisp-features '()
  "The symbol-names of Lisp's *FEATURES*.
This is automatically synchronized from Lisp.")

(slime-def-connection-var slime-lisp-package
    "COMMON-LISP-USER"
  "The current package name of the Superior lisp.
This is automatically synchronized from Lisp.")

(slime-def-connection-var slime-lisp-package-prompt-string
    "CL-USER"
  "The current package name of the Superior lisp.
This is automatically synchronized from Lisp.")

(slime-def-connection-var slime-pid nil
  "The process id of the Lisp process.")

(slime-def-connection-var slime-lisp-implementation-type nil
  "The implementation type of the Lisp process.")

(slime-def-connection-var slime-lisp-implementation-version nil
  "The implementation type of the Lisp process.")

(slime-def-connection-var slime-lisp-implementation-type-name nil
  "The short name for the implementation type of the Lisp process.")

(slime-def-connection-var slime-connection-name nil
  "The short name for connection.")

(slime-def-connection-var slime-symbolic-lisp-name nil
  "The symbolic name passed to slime when starting connection.")

(slime-def-connection-var slime-inferior-process nil
  "The inferior process for the connection if any.")

(slime-def-connection-var slime-communication-style nil
  "The communication style.")

(slime-def-connection-var slime-machine-instance nil
  "The name of the (remote) machine running the Lisp process.")


;;; Connection setup
;;;
;;;
(defvar slime-connection-counter 0
  "The number of SLIME connections made. For generating serial numbers.")

(defun slime-generate-connection-name (lisp-name)
  (loop for i from 1
        for name = lisp-name then (format nil "~a<~d>" lisp-name i)
        while (find name slime-net-processes
                    :key #'slime-connection-name :test #'equal)
        finally (return name)))

(defun slime-generate-symbolic-lisp-name (lisp-name)
  (if lisp-name
    (loop for i from 1
       for name = lisp-name then (format nil "~a<~d>" lisp-name i)
       while (find name slime-net-processes
                   :key #'slime-symbolic-lisp-name :test #'equal)
       finally (return name))))

(defun slime-set-connection-info (connection info)
  "Initialize CONNECTION with INFO received from Lisp."
  (destructuring-bind (pid type name features style version host) info
    (setf (slime-pid) pid
          (slime-lisp-implementation-type) type
          (slime-lisp-implementation-type-name) name
          (slime-connection-name) (slime-generate-connection-name name)
          (slime-lisp-features) features
          (slime-communication-style) style
          (slime-lisp-implementation-version) version
          (slime-machine-instance) host))
  (warn "Connected. ~S: ~S" connection info))


;;; Evaluation bits
(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
	 ,@(mapcar (lambda (clause)
                     (if (eq (car clause) t)
                         `(t ,@(cdr clause))
                       (destructuring-bind ((op &rest rands) &rest body) clause
                         `(,op (destructuring-bind ,rands ,operands
                                 . ,body)))))
		   patterns)
	 ,@(if (eq (caar (last patterns)) t)
	       '()
	     `((t (error "destructure-case failed: ~S" ,tmp))))))))

;;
;;

#+mcl
(defparameter *debug* NIL)

(defun dummy-warn (&rest rest)
  (when #+mcl *debug* #+cmucl T
    (format t "~a" rest)))

(defun slime-connection ()
  "Return the connection to use for Lisp interaction.
Signal an error if there's no connection."
  (or slime-dispatching-connection
      slime-default-connection
      (error "No default connection selected.")))

(defun slime-send (sexp)
  "Send SEXP directly over the wire on the current connection."
  (slime-net-send sexp (slime-connection)) ; XXX
  (force-output (slime-connection)))

;;;
;;;
;;;
(slime-def-connection-var slime-rex-continuations '()
  "List of (ID . FUNCTION) continuations waiting for RPC results.")

(slime-def-connection-var slime-continuation-counter 0
  "Continuation serial number counter.")

;;; XXX Modified slime-current-package and slime-current-thread semantics
(slime-def-connection-var slime-current-package "COMMON-LISP-USER"
     "The Lisp package associated with the current buffer.
This is set only in buffers bound to specific packages.") ; XXX

(slime-def-connection-var slime-current-thread t
     "The id of the current thread on the Lisp side.
t means the \"current\" thread;")	; XXX

(defvar slime-current-output-id nil
  "The id of the current repl output.

This variable is rebound by the :RETURN event handler and used by
slime-repl-insert-prompt.")

;;;;; Protocol event handler (the guts)
(defun slime-dispatch-event (event &optional process)
  (let ((slime-dispatching-connection (or process (slime-connection))))
    (assert slime-dispatching-connection)
    (destructure-case event
      ((:write-string output #+mcl mode)
       (dummy-warn 'slime-write-string output #+mcl mode))
      ((:read-output output)
       (dummy-warn 'slime-output-string output))
      ((:presentation-start id)
       (dummy-warn 'slime-mark-presentation-start id))
      ((:presentation-end id)
       (dummy-warn 'slime-mark-presentation-end id))
      ;;
      ((:emacs-rex form package thread continuation)
       (dummy-warn 'slime-set-state "|eval...")
       #+todo
       (when (and (slime-use-sigint-for-interrupt) (slime-busy-p))
         (message "; pipelined request... %S" form))
       (let ((id (incf (slime-continuation-counter))))
         (push (cons id continuation) (slime-rex-continuations))
         (slime-send `(:emacs-rex ,form ,package ,thread ,id))))
      ((:return value id)
       (let ((rec (assoc id (slime-rex-continuations) :test #'eq)))
         (cond (rec (setf (slime-rex-continuations )
                          (remove rec (slime-rex-continuations)))
                    (when (null (slime-rex-continuations))
		      ;; eval done
                      )
                    (let ((slime-current-output-id id)) ;; this is not very
                      ;; elegant but it avoids changing the protocol
		      #+NIL(warn "TODO: (FUNCALL (CDR REC) VALUE) ~&(funcall ~a ~a)"
				 (cdr rec) value)
                      (funcall (cdr rec) value)))
               (t
                (error "Unexpected reply: ~S ~S" id value)))))
      ((:debug-activate thread level)
       (assert thread)
       #+cmucl
       (dummy-warn 'sldb-activate thread level))
      ((:debug thread level condition restarts frames conts)
       (assert thread)
       (dummy-warn 'sldb-setup thread level condition restarts frames conts))
      ((:debug-return thread level &optional stepping)
       (assert thread)
       (dummy-warn 'sldb-exit thread level stepping))
      ((:emacs-interrupt thread)
       (cond #+todo((slime-use-sigint-for-interrupt) (slime-send-sigint))
             (t (slime-send `(:emacs-interrupt ,thread)))))
      ((:read-string thread tag)
       (assert thread)
       (dummy-warn 'slime-repl-read-string thread tag))
      ((:evaluate-in-emacs string thread tag)
       (assert thread)
       (dummy-warn 'evaluate-in-emacs (car (read-from-string string))
		   thread tag))
      ((:read-aborted thread tag)
       (assert thread)
       (dummy-warn 'slime-repl-abort-read thread tag))
      ((:emacs-return-string thread tag string)
       (slime-send `(:emacs-return-string ,thread ,tag ,string)))
      ;;
      ((:new-package package prompt-string)
       (setf (slime-lisp-package) package)
       (setf (slime-lisp-package-prompt-string) prompt-string))
      ((:new-features features)
       (setf (slime-lisp-features) features))
      ((:indentation-update info)
       (dummy-warn 'slime-handle-indentation-update info))
      ((:open-dedicated-output-stream port)
       (dummy-warn 'slime-open-stream-to-lisp port))
      ((:eval-no-wait fun args)
       (dummy-warn ':eval-no-wait fun args) #+nil
       (apply (intern fun) args))
      ((:eval thread tag fun args)
       (dummy-warn 'slime-eval-for-lisp thread tag (intern fun) args))
      ((:emacs-return thread tag value)
       (slime-send `(:emacs-return ,thread ,tag ,value)))
      ((:ed what)
       (dummy-warn 'slime-ed what))
      ((:debug-condition thread message)
       (assert thread)
       (warn "debug-condition: (thread ~a) ~a" thread message)))))

;;; XXX cannot trace!
#+nil
(untrace slime-dispatch-event)


(defmacro slime-rex ((&rest saved-vars)
		     (sexp &optional
			    (package '(slime-current-package
				       (slime-connection)))
			    (thread '(slime-current-thread
				      (slime-connection)))
			    )
		     &rest continuations)
  "(slime-rex (VAR ...) (SEXP &optional PACKAGE THREAD) CLAUSES ...)

Remote EXecute SEXP.

VARs are a list of saved variables visible in the other forms.  Each
VAR is either a symbol or a list (VAR INIT-VALUE).

SEXP is evaluated and the princed version is sent to Lisp.

PACKAGE is evaluated and Lisp binds *BUFFER-PACKAGE* to this package.
The default value is (slime-current-package).

CONTINUATIONS are a list of patterns with same syntax as `destructure-case'.
The result of the evaluation is dispatched on CLAUSES.  The result is
either a sexp of the form (:ok VALUE) or (:abort).  CONTINUATIONS are
executed asynchronously.

;;;Note: don't use backquote syntax for SEXP, because Emacs20 cannot
;;;deal with that."
  (let ((result (gensym)))
    `(let ,(loop for var in saved-vars
		 collect (etypecase var
			   (symbol (list var var))
			   (cons var)))
       (slime-dispatch-event
        (list :emacs-rex ,sexp ,package ,thread
              (lambda (,result)
                (destructure-case ,result
                  ,@continuations)))))))


(defun slime-eval-async (sexp &optional cont package)
  "Evaluate SEXP on the superior Lisp and call CONT with the result."
  (slime-rex (cont)
      (sexp (or package (slime-current-package (slime-connection))))
    ((:ok result)
     (when cont
       (funcall cont result)))
    ((:abort)
     (warn "Evaluation aborted."))))

(defun %process-available-input-1 (stream)
  (when (listen stream)
    (let ((event (slime-net-read stream)))
      (values (slime-dispatch-event event stream) t))))

(defun %process-available-input (stream) ; blocking
  (let ((event (slime-net-read stream)))
    (values (slime-dispatch-event event stream) t)))


;; back to connections
;;
(defun slime-init-connection-state (proc symbolic-lisp-name)
  "Initialize connection state in the process-buffer of PROC."
  ;; To make life simpler for the user: if this is the only open
  ;; connection then reset the connection counter.
  (when (equal slime-net-processes (list proc))
    (setq slime-connection-counter 0))
  (setf (slime-connection-number proc) (incf slime-connection-counter))
  (setf (slime-symbolic-lisp-name proc)
        (slime-generate-symbolic-lisp-name symbolic-lisp-name))
  ;; We do our initialization asynchronously. The current function may
  ;; be called from a timer, and if we setup the REPL from a timer
  ;; then it mysteriously uses the wrong keymap for the first command.
  (slime-eval-async '(swank:connection-info)
                    (lambda (info)
                      (slime-set-connection-info proc info))))

;;; Interface
(defun slime-setup-connection (process symbolic-lisp-name)
  "Make a connection out of PROCESS."
  (let ((slime-dispatching-connection process))
    (slime-init-connection-state process symbolic-lisp-name)
    process))


;;; Synchronous requests are implemented in terms of asynchronous
;;; ones. We make an asynchronous request with a continuation function
;;; that `throw's its result up to a `catch' and then enter a loop of
;;; handling I/O until that happens.

(defvar slime-stack-eval-tags nil
  "List of stack-tags of continuations waiting on the stack.")

(defun slime-eval (sexp &optional package)
  "Evaluate SEXP on the superior Lisp and return the result."
  (when (null package) (setq package (slime-current-package
				      (slime-connection))))
  (let* ((tag (gensym "slime-result-"))
	 (slime-stack-eval-tags (cons tag slime-stack-eval-tags))
	 (goose
	  (catch tag
	    (slime-rex (tag sexp)
		(sexp package)
	      ((:ok value)
	       (unless (member tag slime-stack-eval-tags)
		 (error "tag = ~S eval-tags = ~S sexp = ~S"
			tag slime-stack-eval-tags sexp))
	       (throw tag (list #'identity value)))
	      ((:abort)
	       (throw tag
                 #+mcl
                 (abort)
                 #+cmucl
		 (list #'error "Synchronous Lisp Evaluation aborted."))))
	    (loop ;; block, discarding results
	       (%process-available-input (slime-connection))))))
    (assert goose)
    (apply #'funcall goose)))


(defun slime-reset (&optional (slime-dispatching-connection ; XXX
			       (slime-connection)))
  "Clear all pending continuations."
  (setf (slime-rex-continuations) '()))

(defun slime-quit-lisp ()
  "Quit lisp, kill the inferior process and associated buffers."
  (slime-eval-async '(swank:quit-lisp)))

(defun sldb-quit ()
  "Quit to toplevel."
  (slime-eval-async '(swank:throw-to-toplevel)
                    (lambda (_)
		      (declare (ignore _))
		      (error "sldb-quit returned"))))

(defun slime-disconnect ()
  "Disconnect all connections."
  (mapcar #'slime-net-close slime-net-processes))

(defun slime-interrupt ()
  "Interrupt Lisp."
  (slime-dispatch-event `(:emacs-interrupt ,(slime-current-thread
					     (slime-connection)))))

(defun slime-ping ()
  "Check that communication works."
  (format t "~s" (slime-eval "PONG")))

#+mcl ; hack
(defmethod stream-external-format (stream)
  NIL)

#|| SYNOPSIS
;; on one lisp
(swank 9006)
;; on this our other lisp
(setq $a (slime-net-connect "localhost" 9006)) ; sets default
(slime-eval '(cl:+ 2 3))
;;etc.

(slime-interrupt)
;; sink
(loop for (last-gander last-gander-p) = (list nil nil) then (list gander gander-p)
      for (gander gander-p) = (multiple-value-list (%process-available-input-1 (slime-connection)))
      unless gander-p return last-gander)
(sldb-quit)
(mapcar #'finish-output slime-net-processes)
(stream:stream-input-handle  $a)
(slime-eval-async '(cl:+ 2 3) #'identity)
(slime-disconnect)

(cons 'trace (loop for x being the external-symbols of :swank-backend 	   if (fboundp x) collect x))
||#

;;; Still doesnt work with CLISP running the server
;;;
;;; Elisp:
;;; (put 'slime-def-connection-var 'lisp-indent-function 2)
;;; (put 'destructure-case 'lisp-indent-function 1)