Commit | Line | Data |
---|---|---|
731bcf73 NJ |
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 | ||
fce4b99e | 29 | ;;;; Communication with the (ice-9 gds-server) subprocess. |
731bcf73 NJ |
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 protocol-handler &optional bufname) | |
48 | "Start a GDS server process called PROCNAME, listening on TCP port PORT. | |
49 | PROTOCOL-HANDLER should be a function that accepts and processes one | |
50 | protocol form. Optional arg BUFNAME specifies the name of the buffer | |
51 | that is used for process output\; if not specified the buffer name is | |
52 | the same as the process name." | |
53 | (with-current-buffer (get-buffer-create (or bufname procname)) | |
54 | (erase-buffer) | |
55 | (let* ((code (format "(begin | |
56 | %s | |
fce4b99e | 57 | (use-modules (ice-9 gds-server)) |
731bcf73 NJ |
58 | (run-server %d))" |
59 | (if gds-scheme-directory | |
60 | (concat "(set! %load-path (cons " | |
61 | (format "%S" gds-scheme-directory) | |
62 | " %load-path))") | |
63 | "") | |
64 | port)) | |
65 | (process-connection-type nil) ; use a pipe | |
66 | (proc (start-process procname | |
67 | (current-buffer) | |
68 | gds-guile-program | |
69 | "-q" | |
70 | "--debug" | |
71 | "-c" | |
72 | code))) | |
73 | (set (make-local-variable 'gds-read-cursor) (point-min)) | |
74 | (set (make-local-variable 'gds-protocol-handler) protocol-handler) | |
75 | (set-process-filter proc (function gds-filter)) | |
76 | (set-process-sentinel proc (function gds-sentinel)) | |
77 | (set-process-coding-system proc 'latin-1-unix) | |
78 | (process-kill-without-query proc) | |
79 | proc))) | |
80 | ||
81 | ;; Subprocess output filter: inserts normally into the process buffer, | |
82 | ;; then tries to reread the output one form at a time and delegates | |
83 | ;; processing of each form to `gds-protocol-handler'. | |
84 | (defun gds-filter (proc string) | |
85 | (with-current-buffer (process-buffer proc) | |
86 | (save-excursion | |
87 | (goto-char (process-mark proc)) | |
88 | (insert-before-markers string)) | |
89 | (goto-char gds-read-cursor) | |
90 | (while (let ((form (condition-case nil | |
91 | (read (current-buffer)) | |
92 | (error nil)))) | |
93 | (if form | |
94 | (save-excursion | |
95 | (funcall gds-protocol-handler (car form) (cdr form)))) | |
96 | form) | |
97 | (setq gds-read-cursor (point))))) | |
98 | ||
99 | ;; Subprocess sentinel: do nothing. (Currently just here to avoid | |
100 | ;; inserting un-`read'able process status messages into the process | |
101 | ;; buffer.) | |
102 | (defun gds-sentinel (proc event) | |
103 | ) | |
104 | ||
105 | ||
106 | ;;;; The end! | |
107 | ||
108 | (provide 'gds-server) | |
109 | ||
110 | ;;; gds-server.el ends here. |