;;; SWANK for CLISP

;;; Copyright (C) 2003 W. Jenkner, V. Sedach

;;;; This file is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published
;;;; by the Free Software Foundation; either version 2, or (at your
;;;; option) any later version.

(in-package "SWANK")

(defparameter *xref-load-path* "~/.emacs.d/slime/xref")

(eval-when (:compile-toplevel :load-toplevel :execute)
  (use-package "SOCKET")
  (use-package "GRAY")
  (defpackage "XREF")
  (load *xref-load-path*))

(setq *multiprocessing-enabled* nil)

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

(defslimefun getpid ()
   (system::program-id))

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

(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)))))

(defmethod arglist-string (fname)
  (declare (type string fname))
  (multiple-value-bind (function condition)
      (ignore-errors (values (from-string fname)))
    (when condition
      (return-from arglist-string (format nil "(-- ~A)" condition)))
    (multiple-value-bind (arglist condition)
	(ignore-errors (values (ext:arglist function)))
      (cond (condition (format  nil "(-- ~A)" condition))
	    (t (format nil "(~{~A~^ ~})" arglist))))))

(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)))

(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))

(defun fspec-pathname (symbol &optional type)
  (declare (ignore type))
  (let ((path (getf (gethash symbol sys::*documentation*) 'sys::file)))
    (if (and path
	     (member (pathname-type path)
		     custom:*compiled-file-types* :test #'string=))
	(loop
	   for suffix in custom:*source-file-types*
	   thereis (make-pathname :defaults path :type suffix))
	path)))

(defun find-multiple-definitions (fspec)
  (list `(,fspec t)))

(defun find-definition-in-file (fspec type file)
  (declare (ignore fspec type file))
  ;; FIXME
  0)

(defun fspec-source-locations (fspec)
  (let ((defs (find-multiple-definitions fspec)))
    (let ((locations '()))
      (loop for (fspec type) in defs do
	    (let ((file (fspec-pathname fspec type)))
	      (etypecase file
		(pathname
		 (let ((start (find-definition-in-file fspec type file)))
		   (push (make-location
			  (list :file (namestring (truename file)))
			  (if start
			      (list :position (1+ start))
			      (list :function-name (string fspec))))
			 locations)))
		((member :top-level)
		 (push (list :error (format nil "Defined at toplevel: ~A"
					    fspec))
		       locations))
		(null
		 (push (list :error (format nil
					    "Unkown source location for ~A"
					    fspec))
		       locations))
		)))
      locations)))


(defmethod find-function-locations (symbol-name)
  (multiple-value-bind (symbol foundp) (find-symbol-designator symbol-name)
    (cond ((not foundp)
	   (list (list :error (format nil "Unkown symbol: ~A" symbol-name))))
	  ((macro-function symbol)
	   (fspec-source-locations symbol))
	  ((special-operator-p symbol)
	   (list (list :error (format nil "~A is a special-operator" symbol))))
	  ((fboundp symbol)
	   (fspec-source-locations symbol))
	  (t (list (list :error
			 (format nil "Symbol not fbound: ~A" symbol-name))))
	  )))

(defvar *sldb-topframe*)
(defvar *sldb-botframe*)
(defvar *sldb-source*)
(defvar *sldb-restarts*)
(defvar *sldb-debugmode* 4)
(defvar *debug-frame*)

(defmethod call-with-debugging-environment (debugger-loop-fn)
  (let* ((sys::*break-count* (1+ sys::*break-count*))
	 (sys::*driver* debugger-loop-fn)
	 (sys::*fasoutput-stream* nil)
;;;      (sys::*frame-limit1* (sys::frame-limit1 43))
	 (sys::*frame-limit1* (sys::frame-limit1 0))
;;;      (sys::*frame-limit2* (sys::frame-limit2))
	 (sys::*debug-mode* *sldb-debugmode*)
	 (*debug-frame*
	  (sys::frame-down-1
	   (sys::frame-up-1 sys::*frame-limit1* sys::*debug-mode*)
	   sys::*debug-mode*))
	 (*sldb-topframe* *debug-frame*)
	 (*sldb-botframe* (sys::frame-up *sldb-topframe* sys::*debug-mode*))
	 (*debugger-hook* nil)
	 (*package* *buffer-package*)
	 (*sldb-restarts*
	  (compute-restarts *swank-debugger-condition*))
	 (*print-pretty* nil)
	 (*print-readably* nil))
;;;    (*print-level* 3)
;;;    (*print-length* 10))
    (funcall debugger-loop-fn)))

(defun format-condition-for-emacs ()
  (format nil "~A~%   [Condition of type ~S]"
	  *swank-debugger-condition* (type-of *swank-debugger-condition*)))

(defun format-restarts-for-emacs ()
  (loop for restart in *sldb-restarts*
	collect (list (princ-to-string (restart-name restart))
		      (princ-to-string restart))))

(defun nth-frame (index)
  (loop
     for frame = *sldb-topframe* then (sys::frame-up-1 frame sys::*debug-mode*)
     repeat index
     never (eq frame *sldb-botframe*)
     finally (return (setq *debug-frame* frame))))

(defun compute-backtrace (start end)
  (let ((end (or end most-positive-fixnum)))
    (loop for f = (nth-frame start)
       then (sys::frame-up-1 f sys::*debug-mode*)
       for i from start below end
       until (eq f *sldb-botframe*)
       collect f)))

(defmethod backtrace (start-frame-number end-frame-number)
  (flet ((format-frame (f i)
	   (format nil "~d: ~a" i
		   (string-left-trim
		    '(#\Newline)
		    (with-output-to-string (stream)
		      (let ((*print-pretty* *sldb-pprint-frames*))
			(sys::describe-frame stream f)))))))
    (loop for i from start-frame-number
       for f in (compute-backtrace start-frame-number end-frame-number)
       collect (list i (format-frame f i)))))

(defmethod eval-in-frame (form frame-number)
  (sys::eval-at (nth-frame frame-number) form))

(defmethod frame-locals (frame-number)
  (let* ((frame (nth-frame frame-number))
	 (frame-env (sys::eval-at frame '(sys::the-environment))))
    (append
     (frame-do-venv frame (svref frame-env 0))
     (frame-do-fenv frame (svref frame-env 1))
     (frame-do-benv frame (svref frame-env 2))
     (frame-do-genv frame (svref frame-env 3))
     (frame-do-denv frame (svref frame-env 4)))))

(defun frame-do-venv (frame venv)
  (loop
     for i from 1 below (length venv) by 2
     as symbol = (svref venv (1- i))
     and value = (svref venv i)
     collect (list :symbol symbol :id 0
		   :value-string
		   (to-string
		    (if (eq sys::specdecl value)
			;; special variable
			(sys::eval-at frame symbol)
			;; lexical variable or symbol macro
			value)))))

(defun frame-do-fenv (frame fenv)
  (declare (ignore frame fenv))
  nil)

(defun frame-do-benv (frame benv)
  (declare (ignore frame benv))
  nil)

(defun frame-do-genv (frame genv)
  (declare (ignore frame genv))
  nil)

(defun frame-do-denv (frame denv)
  (declare (ignore frame denv))
  nil)

(defmethod frame-catch-tags (index)
  (declare (ignore index))
  nil)

(defmethod frame-source-location-for-emacs (index)
  (list :error (format nil "Cannot find source for frame: ~A"
		       (nth-frame index))))

(defmethod debugger-info-for-emacs (start end)
  (list (format-condition-for-emacs)
	(format-restarts-for-emacs)
	(backtrace start end)))

(defun nth-restart (index)
  (nth index *sldb-restarts*))

(defslimefun invoke-nth-restart (index)
  (invoke-restart-interactively (nth-restart index)))

(defslimefun sldb-abort ()
  (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name)))

;;; Handle compiler conditions (find out location of error etc.)

(defmacro compile-file-frobbing-notes ((&rest args) &body body)
  "Pass ARGS to COMPILE-FILE, send the compiler notes to
*STANDARD-INPUT* and frob them in BODY."
  `(let ((*error-output* (make-string-output-stream))
	 (*compile-verbose* t))
     (multiple-value-prog1
	 (compile-file ,@args)
       (with-input-from-string
	   (*standard-input* (get-output-stream-string *error-output*))
	 ,@body))))

(defmethod call-with-compilation-hooks (function)
  (handler-bind ((compiler-condition #'handle-notification-condition))
    (funcall function)))

(defun handle-notification-condition (condition)
  "Handle a condition caused by a compiler warning."
  (signal condition))

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

(defvar *compiler-note-line-regexp*
  (regexp:regexp-compile
   "^\\(WARNING\\|ERROR\\) .* in lines \\([0-9]\\+\\)..[0-9]\\+ :$"))

(defun split-compiler-note-line (line)
  (multiple-value-bind (all head tail)
      (regexp:regexp-exec *compiler-note-line-regexp* line)
    (declare (ignore all))
    (if head
	(list (let ((*package* (find-package :keyword)))
		(read-from-string (regexp:match-string line head)))
	      (read-from-string (regexp:match-string line tail)))
	(list nil line))))

;;; Ugly but essentially working.
;;; FIXME:  I get all notes twice.
;;; TODO: Support for line number position in slime.el

(defmethod compile-file-for-emacs (filename load-p)
  (with-compilation-hooks ()
    (multiple-value-bind (fasl-file w-p f-p)
	(compile-file-frobbing-notes (filename)
	  (read-line)                   ;""
	  (read-line)                   ;"Compiling file ..."
	  (loop
	     with condition
	     for (severity message) = (split-compiler-note-line (read-line))
	     until (and (stringp message) (string= message ""))
	     if severity
	     do (when condition
		  (print (message condition))
		  (signal condition))
	     (setq condition
		   (make-condition 'compiler-condition
				   :severity severity
				   :message ""
				   :location `(:location (:file ,filename) (:position ,message)))) ; bogus: should be (:line ,message)
	     else do (setf (message condition)
			   (format nil "~a~&~a" (message condition) message))
	     finally (when condition
		       (print (message condition))
		       (signal condition))))
      (declare (ignore w-p))
      (cond ((and fasl-file (not f-p) load-p)
	     (load fasl-file))
	    (t fasl-file)))))

(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))))))

;;; Portable XREF from the CMU AI repository.

(setq xref::*handle-package-forms* '(cl:in-package))

(defun lookup-xrefs (finder name)
  (xref-results-for-emacs (funcall finder (from-string name))))

(defslimefun who-calls (function-name)
  (lookup-xrefs #'xref:list-callers function-name))

(defslimefun who-references (variable)
  (lookup-xrefs #'xref:list-readers variable))

(defslimefun who-binds (variable)
  (lookup-xrefs #'xref:list-setters variable))

(defslimefun who-sets (variable)
  (lookup-xrefs #'xref:list-setters variable))

(defslimefun list-callers (symbol-name)
  (lookup-xrefs #'xref:who-calls symbol-name))

(defslimefun list-callees (symbol-name)
  (lookup-xrefs #'xref:list-callees symbol-name))

(defun xref-results-for-emacs (fspecs)
  (let ((xrefs '()))
    (dolist (fspec fspecs)
      (dolist (location (fspec-source-locations fspec))
	(push (cons (to-string fspec) location) xrefs)))
    (group-xrefs xrefs)))

(when (find-package :swank-loader)
  (defun swank-loader::user-init-file ()
    (let ((home (user-homedir-pathname)))
      (and (ext:probe-directory home)
	   (probe-file (format nil "~A/.swank.lisp"
			       (namestring (truename home))))))))