guile18/emacs/gds-server.el

   1 ;;; gds-server.el -- infrastructure for running GDS server processes
   2
   3 ;;;; Copyright (C) 2003, 2004 Free Software Foundation, Inc.
   4 ;;;;
   5 ;;;; This library is free software; you can redistribute it and/or
   6 ;;;; modify it under the terms of the GNU Lesser General Public
   7 ;;;; License as published by the Free Software Foundation; either
   8 ;;;; version 2.1 of the License, or (at your option) any later
   9 ;;;; version.
  10 ;;;;
  11 ;;;; This library is distributed in the hope that it will be useful,
  12 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  14 ;;;; Lesser General Public License for more details.
  15 ;;;;
  16 ;;;; You should have received a copy of the GNU Lesser General Public
  17 ;;;; License along with this library; if not, write to the Free
  18 ;;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
  19 ;;;; 02111-1307 USA
  20
  21
  22 ;;;; Customization group setup.
  23
  24 (defgroup gds nil
  25   "Customization options for Guile Emacs frontend."
  26   :group 'scheme)
  27
  28
  29 ;;;; Communication with the (ice-9 gds-server) subprocess.
  30
  31 ;; Subprocess output goes into the `*GDS Process*' buffer, and
  32 ;; is then read from there one form at a time.  `gds-read-cursor' is
  33 ;; the buffer position of the start of the next unread form.
  34 (defvar gds-read-cursor nil)
  35
  36 ;; The guile executable used by the GDS server process.
  37 (defcustom gds-guile-program "guile"
  38   "*The guile executable used by the GDS server process."
  39   :type 'string
  40   :group 'gds)
  41
  42 (defcustom gds-scheme-directory nil
  43   "Where GDS's Scheme code is, if not in one of the standard places."
  44   :group 'gds
  45   :type '(choice (const :tag "nil" nil) directory))
  46
  47 (defun gds-start-server (procname port-or-path protocol-handler &optional bufname)
  48   "Start a GDS server process called PROCNAME, listening on TCP port
  49 or Unix domain socket PORT-OR-PATH.  PROTOCOL-HANDLER should be a
  50 function that accepts and processes one protocol form.  Optional arg
  51 BUFNAME specifies the name of the buffer that is used for process
  52 output; if not specified the buffer name is the same as the process
  53 name."
  54   (with-current-buffer (get-buffer-create (or bufname procname))
  55     (erase-buffer)
  56     (let* ((code (format "(begin
  57                             %s
  58                             (use-modules (ice-9 gds-server))
  59                             (run-server %S))"
  60                          (if gds-scheme-directory
  61                              (concat "(set! %load-path (cons "
  62                                      (format "%S" gds-scheme-directory)
  63                                      " %load-path))")
  64                            "")
  65                          port-or-path))
  66            (process-connection-type nil) ; use a pipe
  67            (proc (start-process procname
  68                                 (current-buffer)
  69                                 gds-guile-program
  70                                 "-q"
  71                                 "--debug"
  72                                 "-c"
  73                                 code)))
  74       (set (make-local-variable 'gds-read-cursor) (point-min))
  75       (set (make-local-variable 'gds-protocol-handler) protocol-handler)
  76       (set-process-filter proc (function gds-filter))
  77       (set-process-sentinel proc (function gds-sentinel))
  78       (set-process-coding-system proc 'latin-1-unix)
  79       (process-kill-without-query proc)
  80       proc)))
  81
  82 ;; Subprocess output filter: inserts normally into the process buffer,
  83 ;; then tries to reread the output one form at a time and delegates
  84 ;; processing of each form to `gds-protocol-handler'.
  85 (defun gds-filter (proc string)
  86   (with-current-buffer (process-buffer proc)
  87     (save-excursion
  88       (goto-char (process-mark proc))
  89       (insert-before-markers string))
  90     (goto-char gds-read-cursor)
  91     (while (let ((form (condition-case nil
  92                            (read (current-buffer))
  93                          (error nil))))
  94              (if form
  95                  (save-excursion
  96                    (funcall gds-protocol-handler (car form) (cdr form))))
  97              form)
  98       (setq gds-read-cursor (point)))))
  99
 100 ;; Subprocess sentinel: do nothing.  (Currently just here to avoid
 101 ;; inserting un-`read'able process status messages into the process
 102 ;; buffer.)
 103 (defun gds-sentinel (proc event)
 104   )
 105
 106
 107 ;;;; The end!
 108
 109 (provide 'gds-server)
 110
 111 ;;; gds-server.el ends here.