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

Diff of /slime/swank-cmucl.lisp

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

revision 1.43 by heller, Fri Jan 2 18:23:14 2004 UTC revision 1.44 by lgorrie, Sat Jan 10 06:45:05 2004 UTC
# Line 4  Line 4 
4    
5  (in-package :swank)  (in-package :swank)
6    
 ;; Turn on xref. [should we?]  
 (setf c:*record-xref-info* t)  
   
7  (defun without-interrupts* (body)  (defun without-interrupts* (body)
8    (sys:without-interrupts (funcall body)))    (sys:without-interrupts (funcall body)))
9    
 (defun set-fd-non-blocking (fd)  
   (flet ((fcntl (fd cmd arg)  
            (multiple-value-bind (flags errno) (unix:unix-fcntl fd cmd arg)  
              (or flags  
                  (error "fcntl: ~A" (unix:get-unix-error-msg errno))))))  
     (let ((flags (fcntl fd unix:F-GETFL 0)))  
       (fcntl fd unix:F-SETFL (logior flags unix:O_NONBLOCK)))))  
   
10    
11  ;;;; TCP server.  ;;;; TCP server.
12    
# Line 36  Line 25 
25           (fd (ext:create-inet-listener port :stream           (fd (ext:create-inet-listener port :stream
26                                         :reuse-address reuse-address                                         :reuse-address reuse-address
27                                         :host ip)))                                         :host ip)))
28      (funcall announce (nth-value 1 (ext::get-socket-host-and-port fd)))      (funcall announce (tcp-port fd))
29      (accept-loop fd background close)))      (accept-clients fd background close)))
   
 (defun emacs-io (fd)  
   "Create a new fd-stream for fd."  
   (sys:make-fd-stream fd :input t :output t :element-type 'base-char))  
30    
31  (defun add-input-handler (fd fn)  (defun accept-clients (fd background close)
   (system:add-fd-handler fd :input fn))  
   
 (defun accept-loop (fd background close)  
32    "Accept clients on the the server socket FD.  Use fd-handlers if    "Accept clients on the the server socket FD.  Use fd-handlers if
33  BACKGROUND is non-nil.  Close the server socket after the first client  BACKGROUND is non-nil.  Close the server socket after the first client
34  if CLOSE is non-nil, "  if CLOSE is non-nil, "
35    (cond (background    (flet ((accept-client (&optional (fdes fd))
36           (add-input-handler             (accept-one-client fd background close)))
37            fd (lambda (fd) (accept-one-client fd background close))))      (cond (background (add-input-handler fd #'accept-client))
38          (close            (close      (accept-client))
39           (accept-one-client fd background close))            (t          (loop (accept-client))))))
         (t  
          (loop (accept-one-client fd background close)))))  
40    
41  (defun accept-one-client (socket background close)  (defun accept-one-client (socket background close)
42    (let ((fd (ext:accept-tcp-connection socket)))    (let ((fd (ext:accept-tcp-connection socket)))
43      (when close      (when close
44        (sys:invalidate-descriptor socket)        (sys:invalidate-descriptor socket)
45        (unix:unix-close socket))        (unix:unix-close socket))
46      (request-loop fd background)))      (setup-request-loop fd background)))
47    
48  (defun request-loop (fd background)  (defun setup-request-loop (fd background)
49    "Process all request from the socket FD."    "Setup request handling for connection FD.
50    (let* ((stream (emacs-io fd))  If BACKGROUND is true, setup SERVE-EVENT handler and return immediately.
51    Otherwise enter a request handling loop until the connection closes."
52      (let* ((stream (make-emacs-io-stream fd))
53           (out (if *use-dedicated-output-stream*           (out (if *use-dedicated-output-stream*
54                    (open-stream-to-emacs stream)                    (open-stream-to-emacs stream)
55                    (make-slime-output-stream)))                    (make-slime-output-stream)))
56           (in (make-slime-input-stream))           (in (make-slime-input-stream))
57           (io (make-two-way-stream in out)))           (io (make-two-way-stream in out)))
58      (cond (background      (flet ((serve-request (&optional fdes)
59             (add-input-handler               (declare (ignore fdes))
60              fd (lambda (fd)               (serve-one-request stream out in io)))
61                   (declare (ignore fd))        (if background
62                   (serve-one-request stream out in io))))            (add-input-handler fd #'serve-request)
63            (t (do () ((serve-one-request stream out in io)))))))            (loop (serve-one-request stream out in io))))))
64    
65  (defun serve-one-request (*emacs-io* *slime-output* *slime-input* *slime-io*)  (defun serve-one-request (*emacs-io* *slime-output* *slime-input* *slime-io*)
66    "Read and process one request from a SWANK client.    "Read and process one request from a SWANK client.
# Line 95  Return non-nil iff a reader-error occure Line 77  Return non-nil iff a reader-error occure
77            (return-from serve-one-request t)))))            (return-from serve-one-request t)))))
78    nil)    nil)
79    
80    ;;;
81    ;;;;; Socket helpers.
82    
83    (defun tcp-port (fd)
84      "Return the TCP port of the socket represented by FD."
85      (nth-value 1 (ext::get-socket-host-and-port fd)))
86    
87    (defun resolve-hostname (hostname)
88      "Return the IP address of HOSTNAME as an integer."
89      (let* ((hostent (ext:lookup-host-entry hostname))
90             (address (car (ext:host-entry-addr-list hostent))))
91        (ext:htonl address)))
92    
93    (defun add-input-handler (fd fn)
94      (system:add-fd-handler fd :input fn))
95    
96    (defun make-emacs-io-stream (fd)
97      "Create a new input/output fd-stream for FD."
98      (sys:make-fd-stream fd :input t :output t :element-type 'base-char))
99    
100  (defun open-stream-to-emacs (*emacs-io*)  (defun open-stream-to-emacs (*emacs-io*)
101    "Return an output-stream to Emacs' output buffer."    "Return an output-stream to Emacs' output buffer."
102    (let* ((ip (resolve-hostname "localhost"))    (let* ((ip (resolve-hostname "localhost"))
103           (listener (ext:create-inet-listener 0 :stream :host ip))           (listener (ext:create-inet-listener 0 :stream :host ip))
104           (port (nth-value 1 (ext::get-socket-host-and-port listener))))           (port (tcp-port listener)))
105      (unwind-protect      (unwind-protect
106           (progn           (progn
107             (eval-in-emacs `(slime-open-stream-to-lisp ,port))             (eval-in-emacs `(slime-open-stream-to-lisp ,port))

Legend:
Removed from v.1.43  
changed lines
  Added in v.1.44

  ViewVC Help
Powered by ViewVC 1.1.5