[slime-devel] GCL and slime

[Helmut Eller]

Pekka NIiranen <pekka.niiranen at wlanmail.com> writes:

> Hi,
>
> why is GCL (http://savannah.gnu.org/projects/gcl/) not supported?

Short answer: because nobody wrote a backend for it.

Long answer: it would be fairly difficult. GCL is still missing some
ANSI features (e.g. readtable-case) which make it hard to compile the
portable bits of SLIME.  Then you also need various extensions like
socket support, user extensible streams (e.g. Gray streams), a
debugger interface, source locations for compiler messages, and source
location recording (for find-definition). 

So you have to enhance GCL in various ways to make it usable with
SLIME.  It is more work for GCL than for the Lisps that we support
now, because the others have been used with IDEs before and most of
the required features are already available.

At at minimum you need (server) sockets and some debugger support.
User extensible streams are needed, if you want to use the Emacs based
REPL.

Below is a start of gcl backend.  It implements the socket stuff and
and some debugger bits. It used to work, with a few #-gcl in some
other files.  It isn't very comfortable because the REPL is missing.
I don't use GCL and wasn't motivated to implement the (rather more
difficult) rest.

Helmut.

-------------- next part --------------
;;; 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)))

(defgeneric documentation (x y)
  (:method (x y) nil)
  (:method ((s symbol) (k (eql 'variable))) 
    (get s 'sys::variable-documentation))
  (:method ((s symbol) (k (eql 'function)))
    (get s 'sys::function-documentation))
  (:method ((s symbol) (k (eql 'structure)))
    (get s 'sys::structure-documentation))
  (:method ((s symbol) (type (eql 'type))) 
    (get s 'sys::type-documentation))
  (:method ((s symbol) (type (eql 'setf))) 
    (get s '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 , at 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")))))