/[slime]/slime/swank-clisp.lisp
ViewVC logotype

Diff of /slime/swank-clisp.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.2 by heller, Fri Jan 2 18:23:14 2004 UTC revision 1.3 by vsedach, Thu Jan 8 07:02:20 2004 UTC
# Line 1  Line 1 
1  ;;;; SWANK support for CLISP.  ;;;; SWANK support for CLISP.
2    
3  ;;;; Copyright (C) 2003 W. Jenkner, V. Sedach  ;;;; Copyright (C) 2003, 2004 W. Jenkner, V. Sedach
4    
5  ;;;; swank-clisp.lisp is free software; you can redistribute it and/or  ;;;; swank-clisp.lisp is free software; you can redistribute it and/or
6  ;;;; modify it under the terms of the GNU General Public License as  ;;;; modify it under the terms of the GNU General Public License as
# Line 12  Line 12 
12  ;;; swank-allegro (I don't use allegro at all, but it's the shortest  ;;; swank-allegro (I don't use allegro at all, but it's the shortest
13  ;;; one and I found Helmut Eller's code there enlightening).  ;;; one and I found Helmut Eller's code there enlightening).
14    
15  ;;; Note that I use the current CVS version of CLISP and I haven't  ;;; This code is developed using the current CVS version of CLISP and
16  ;;; tested older versions.  You need an image containing the "SOCKET",  ;;; CLISP 2.32 on Linux. Older versions may not work (2.29 and below
17  ;;; "LINUX" and "REGEXP" packages.  You should also fetch the portable  ;;; are confirmed non-working; please upgrade).  You need an image
18  ;;; XREF from the CMU AI repository.  ;;; containing the "SOCKET", "REGEXP", and (optionally) "LINUX"
19    ;;; packages.
20    
21  (in-package "SWANK")  (in-package "SWANK")
22    
# Line 27  Line 28 
28  (setq *start-swank-in-background* nil)  (setq *start-swank-in-background* nil)
29  ;(setq *redirect-output* nil)  ;(setq *redirect-output* nil)
30    
31    #+linux
32  (defmacro without-interrupts (&body body)  (defmacro without-interrupts (&body body)
33    `(let ((sigact (linux:signal-action-retrieve linux:SIGINT)))    `(let ((sigact (linux:signal-action-retrieve linux:SIGINT)))
34       (unwind-protect       (unwind-protect
# Line 35  Line 37 
37              ,@body)              ,@body)
38         (linux:set-sigprocmask linux:SIG_UNBLOCK (linux:sa-mask sigact)))))         (linux:set-sigprocmask linux:SIG_UNBLOCK (linux:sa-mask sigact)))))
39    
40    #-linux
41    (defmacro without-interrupts (body)
42      body)
43    
44  (defun without-interrupts* (fun)  (defun without-interrupts* (fun)
45    (without-interrupts (funcall fun)))    (without-interrupts (funcall fun)))
46    
47  (defslimefun getpid () (linux::getpid))  #+linux (defslimefun getpid () (linux::getpid))
48    #+unix (defslimefun getpid () (system::program-id))
49    #+win32 (defslimefun getpid () (or (system::getenv "PID") -1))
50    ;; the above is likely broken; we need windows NT users!
51    
52  ;;; TCP Server  ;;; TCP Server
53    
54  (defun create-swank-server (port &key (reuse-address t)   (defun get-socket-stream (port announce close-socket-p)
55                              (announce #'simple-announce-function)     (let ((socket (socket:socket-server port)))
56                              (background *start-swank-in-background*)       (socket:socket-wait socket 0)
57                              (close *close-swank-socket-after-setup*))       (funcall announce (socket:socket-server-port socket))
58    "Create a Swank TCP server on `port'."       (prog1
59    (declare (ignore reuse-address))          (socket:socket-accept socket
60    (let ((server-socket (socket-server port)))                                :buffered nil
61      ;; :connect :passive :reuse-address reuse-address                                :element-type 'character
62      (funcall announce (socket-server-port server-socket))                                :external-format (ext:make-encoding
63      (cond (background                                                  :charset 'charset:iso-8859-1
64             (error "Starting swank server in background not implemented."))                                                  :line-terminator :unix))
65            (t          (when close-socket-p
66             (accept-loop server-socket close)))))            (socket:socket-server-close socket)))))
67    
68  (defun accept-loop (server-socket close)  (defun serve-request (*emacs-io* *slime-output* *slime-input* *slime-io*)
69    (unwind-protect (cond (close (accept-one-client server-socket))    "Read and process a request from a SWANK client.
70                          (t (loop (accept-one-client server-socket))))   The request is read from the socket as a sexp and then evaluated."
     (socket-server-close server-socket)))  
   
 (defun accept-one-client (server-socket)  
   (request-loop  
    (socket-accept server-socket  
                   :buffered nil  
                   :element-type 'character  
                   :external-format (ext:make-encoding  
                                     :charset 'charset:iso-8859-1  
                                     :line-terminator :unix))))  
   
 (defun request-loop (stream)  
   (let* ((out (if *use-dedicated-output-stream*  
                   (open-stream-to-emacs stream)  
                   (make-instance 'slime-output-stream)))  
          (in (make-instance 'slime-input-stream))  
          (io (make-two-way-stream in out)))  
     (do () ((serve-one-request stream out in io)))))  
   
 (defun serve-one-request (*emacs-io* *slime-output* *slime-input* *slime-io*)  
71    (catch 'slime-toplevel    (catch 'slime-toplevel
72      (with-simple-restart (abort "Return to Slime toplevel.")      (with-simple-restart (abort "Return to Slime toplevel.")
73        (handler-case (read-from-emacs)      (handler-case (read-from-emacs)
74          (slime-read-error (e)                    (ext:simple-charset-type-error (err)
75            (when *swank-debug-p*                                                   (format *debug-io* "Wrong slime stream encoding:~%~A" err))
76              (format *debug-io* "~&;; Connection to Emacs lost.~%;; [~A]~%" e))                    (slime-read-error (e)
77            (close *emacs-io*)                                      (when *swank-debug-p*
78            (return-from serve-one-request t)))))                                        (format *debug-io* "~&;; Connection to Emacs lost.~%;; [~A]~%" e))
79    nil)                                      (close *emacs-io* :abort t)
80                                        (when *use-dedicated-output-stream*
81                                          (close *slime-output* :abort t))
82                                        (throw 'closed-connection
83                                               (print "Connection to emacs closed" *debug-io*)))))))
84    
85  (defun open-stream-to-emacs (*emacs-io*)  (defun open-stream-to-emacs (*emacs-io*)
86    (let* ((listener (socket-server 0))    "Return an output-stream to Emacs' output buffer."
87           (port (socket-server-port listener)))    (let* ((listener (socket:socket-server))
88      (unwind-protect (progn           (port (socket:socket-server-port listener)))
89                        (eval-in-emacs `(slime-open-stream-to-lisp ,port))      (unwind-protect
90                        (socket-accept listener          (prog2
91                                       :buffered t              (eval-in-emacs `(slime-open-stream-to-lisp ,port))
92                                       :external-format charset:iso-8859-1              (socket:socket-accept listener
93                                       :element-type 'character                                    :buffered t
94                                       ))                                    :external-format charset:iso-8859-1
95        (socket-server-close listener))))                                    :element-type 'character))
96          (socket:socket-server-close listener))))
97    
98    (defun create-swank-server (port &key (announce #'simple-announce-function)
99                                     reuse-address
100                                     background
101                                     (close *close-swank-socket-after-setup*))
102      (declare (ignore reuse-address background))
103      (let* ((emacs (get-socket-stream port announce close))
104             (slime-out (if *use-dedicated-output-stream*
105                            (open-stream-to-emacs emacs)
106                          (make-instance 'slime-output-stream)))
107             (slime-in (make-instance 'slime-input-stream))
108             (slime-io (make-two-way-stream slime-in slime-out)))
109        (catch 'closed-connection
110          (loop (serve-request emacs slime-out slime-in slime-io)))))
111    
112    ;;; Swank functions
113    
114  (defmethod arglist-string (fname)  (defmethod arglist-string (fname)
115    (declare (type string fname))    (declare (type string fname))

Legend:
Removed from v.1.2  
changed lines
  Added in v.1.3

  ViewVC Help
Powered by ViewVC 1.1.5