;;; Copyright (C) 2004, Helmut Eller

(in-package :swank-backend)

(import-swank-mop-symbols :pcl '(:slot-definition-documentation))

(defun swank-mop:slot-definition-documentation (slot)
  (documentation slot t))

;;; missing ANSI stuff

(defun readtable-case (&optional x) :upcase)
(defun (setf readtable-case) (&optional x y) :upcase)
(defun compiler-macro-function (&rest args) nil)

(eval-when (compile load eval)
  (when (and (fboundp 'documentation)
	     (not (typep (symbol-function 'documentation) 'generic-function)))
    (fmakunbound 'documentation)))

(defmethod documentation (x y) nil)
(defmethod documentation ((symbol symbol) (type (eql 'variable)))
  (get symbol 'sys::variable-documentation))
(defmethod documentation ((symbol symbol) (type (eql 'function)))
  (get symbol 'sys::function-documentation))
(defmethod documentation ((symbol symbol) (type (eql 'structure)))
  (get symbol 'sys::structure-documentation))
(defmethod documentation ((symbol symbol) (type (eql 'type)))
  (get symbol 'sys::type-documentation))
(defmethod documentation ((symbol symbol) (type (eql 'setf)))
  (get symbol 'sys::setf-documentation))

;;; Socket interface

(lisp:clines "
#include <sys/types.h>
#include <sys/socket.h>
#include <netinet/in.h>
#include <errno.h>
#include <string.h>

static int
c_socket (void) 
{
  return socket (PF_INET, SOCK_STREAM, 0);
}

static int
c_bind (int socket, int port)
{
  struct sockaddr_in addr;
  addr.sin_family = AF_INET;
  addr.sin_port = htons (port);
  addr.sin_addr.s_addr = htonl (INADDR_ANY);
  return bind (socket, (struct sockaddr *)&addr, sizeof addr);
}

static int
c_local_port (int socket)
{
  struct sockaddr_in addr;
  socklen_t len = sizeof addr;
  int code = getsockname (socket, (struct sockaddr *)&addr, &len);
  return (code == -1) ? -1 : ntohs (addr.sin_port);
}

static int
c_errno (void)
{
  return errno;
}

static int
c_accept (int socket)
{
  struct sockaddr_in addr;
  socklen_t len = sizeof addr;
  return accept (socket, (struct sockaddr *)&addr, &len);
}

static int
c_set_reuse_address (int socket, int value)
{
  return setsockopt (socket, SOL_SOCKET, SO_REUSEADDR, &value, sizeof value);
}

extern void setup_stream_buffer (object x);

static object
make_fd_stream (int fd, object name, object output_p)
{
  object stream = (object) alloc_object (t_stream);
  enum smmode mode = ((output_p == Cnil) ? smm_input : smm_output);
  char* cmode =  ((output_p == Cnil) ? \"r\" : \"w\");
  FILE* fp = fdopen (fd, cmode);
  if (fp == NULL) RETURN1 (Cnil);
  stream->sm.sm_mode = mode;
  stream->sm.sm_fp = fp;
  stream->sm.sm_object0 = Cnil;
  stream->sm.sm_object1 = name;
  stream->sm.sm_int0 = fd;
  stream->sm.sm_int1 = 0;
  stream->sm.sm_flags = 0;
  setup_stream_buffer (stream);
  RETURN1 (stream);
}

static object
compiled_closure_p (object o)
{
  RETURN1 ((type_of (o) == t_cclosure) ? Ct : Cnil);
}

static object
compiled_closure_env (object o)
{
  RETURN1 (o->cc.cc_env);
}
")

(defmacro defentry (name (&rest atypes) (rtype cname)) 
  (let ((type-map '((:int lisp:int) 
		    (:string lisp:string) 
		    (:object lisp:object))))
    (flet ((long-type (type) (second (assoc type type-map))))
      `(lisp:defentry ,name ,(mapcar #'long-type atypes)
		      (,(long-type rtype) ,cname)))))

(defentry %errno () (:int c_errno))
(defentry %strerror (:int) (:string strerror))
(defentry %socket () (:int c_socket))
(defentry %set-reuse-address (:int :int) (:int c_set_reuse_address))
(defentry %bind (:int :int) (:int c_bind))
(defentry %listen (:int :int) (:int listen))
(defentry %local-port (:int) (:int c_local_port))
(defentry %accept (:int) (:int c_accept))
(defentry %make-fd-stream (:int :object :object) (:object make_fd_stream))
(defentry %getpid () (:int getpid))
(defentry %compiled-closure-p (:object) (:object compiled_closure_p))
(defentry %compiled-closure-env (:object) (:object compiled_closure_env))

(defmacro icall ((name &rest args) &optional (error-code -1))
  `(let* ((args (list ,@args))
	  (value (apply (function ,name) args)))
     (when (= value ,error-code)
       (error "~A ~A failed: ~A" ',name args (%strerror (%errno))))
     value))

(defimplementation create-socket (host port)
  (declare (ignore host))
  (let ((socket (icall (%socket))))
    (icall (%set-reuse-address socket 1))
    (icall (%bind socket port))
    (icall (%listen socket 1))
    socket))

(defimplementation local-port (socket)
  (icall (%local-port socket)))

(defimplementation close-socket (socket)
  (warn "close-socket not implemented"))

(defimplementation accept-connection (socket &key external-format)
  (flet ((name (string fd) (format nil "socket-~a: ~d" string fd)))
    (let* ((client (icall (%accept socket)))
	   (in (%make-fd-stream client (name "input" client) nil))
	   (out (%make-fd-stream client (name "output" client) t)))
      (make-two-way-stream in out))))

(defimplementation make-fn-streams (input output)
  (values *standard-input* *standard-output*))

(defvar *sldb-top-frame*)

(defimplementation call-with-debugging-environment (debugger)
  (let ((*sldb-top-frame* (si:ihs-top)))
    (funcall debugger)))

(defun nth-frame (n)
  (cond ((>= n *sldb-top-frame*) nil)
	(t (- *sldb-top-frame*  n))))

(defimplementation compute-backtrace (start end)
  (loop for i from start below end
	for f = (nth-frame i)
	while f
	collect f))

(defimplementation print-frame (frame stream)
  (format stream "~A" (si::ihs-fname frame)))

(defimplementation frame-locals (n)
  (flet ((gen-local-name (i)
	   (make-symbol (format nil "~A-~D" (string 'local) i))))
    (let* ((ihs (nth-frame n))
	   (fname (si::ihs-fname ihs))
	   (dvars (get fname 'sys::debug))
	   (base (si:ihs-vs ihs)))
      (loop for i from 0 for v in dvars collect 
	    (list :name (or v (gen-local-name i)) :id 0
		  :value (si:vs (+ base i)))))))

(defimplementation frame-var-value (frame n)
  (getf (nth n (frame-locals frame)) :value))

(defimplementation frame-catch-tags (n)
  ())

(defimplementation getpid ()
  (%getpid))

(defimplementation lisp-implementation-type-name ()
  "gcl")

(defimplementation describe-symbol-for-emacs (symbol)
  (let ((result '()))
    (flet ((doc (kind &optional (sym symbol))
             (or (documentation sym kind) :not-documented))
           (maybe-push (property value)
             (when value
               (setf result (list* property value result)))))
      (maybe-push :variable (if (boundp symbol)           (doc 'variable)))
      (maybe-push :function (if (fboundp symbol)          (doc 'function)))
      (maybe-push :class (if (find-class symbol nil)      (doc 'class)))
      (maybe-push :setf (if (pcl::setfboundp symbol)      (doc 'setf)))
      (maybe-push :type (if (sys::known-type-p symbol)    (doc 'type)))
      result)))

(defimplementation swank-compile-file (filename load-p)
  (multiple-value-bind (name warnings failure) (compile-file filename)
    (when (and load-p name (not failure))
      (load name))))

(defimplementation macroexpand-all (form)
  (walker:macroexpand-all form ))

(defclass gcl-inspector (inspector) ())

(defimplementation make-default-inspector ()
  (make-instance 'gcl-inspector))

(defun inspect-structure (struct)
  (values 
   (format nil "~A is a structure" struct)
   (let* ((name (type-of struct))
	  (slots (sys::s-data-slot-descriptions (get name 'si::s-data))))
     (loop for (name type _x _y offset) in slots
	   append (label-value-line
		   name (sys:structure-ref1 struct offset))))))

(defun filter-symbols (package status)
  (let ((accu '()))
    (do-symbols (sym package)
      (multiple-value-bind (sym sstatus) 
	  (find-symbol (string sym) package)
	(when (eq status sstatus)
	  (push sym accu))))
    accu))
    
(defun inspect-package (package)
  (values 
   (format nil "~A is a package" package)
   (label-value-line*
    (:nicknames (package-nicknames package))
    (:use-list (package-use-list package))
    (:used-by-list (package-used-by-list package))
    (:shadowing-symbols (package-shadowing-symbols package))
    (:external (filter-symbols package :external))
    (:internal (filter-symbols package :internal))
    (:inherited (filter-symbols package :inherited)))))

(defun inspect-compiled-closure (closure)
  (values
   (format nil "~A is a compiled closure" closure)
   (label-value-line*
    (:name (sys::compiled-function-name closure))
    (:env (%compiled-closure-env closure)))))

(defimplementation inspect-for-emacs (object (_ gcl-inspector))
  (declare (ignore _))
  (cond ((sys:structurep object) (inspect-structure object))
	((packagep object) (inspect-package object))
	((%compiled-closure-p object) (inspect-compiled-closure object))
	(t (values "~A is an atom" (list "no details available")))))