1 ;;; guile.el --- Emacs Guile interface
3 ;; Copyright (C) 2001 Keisuke Nishida <kxn30@po.cwru.edu>
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 3 of the License, or (at your option) any later version.
10 ;;;; This library is distributed in the hope that it will be useful,
11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 ;;;; Lesser General Public License for more details.
15 ;;;; You should have received a copy of the GNU Lesser General Public
16 ;;;; License along with this library; if not, write to the Free
17 ;;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
25 ;;; Low level interface
28 (defvar guile-emacs-file
31 (let ((file (expand-file-name "guile-emacs.scm" dir
)))
32 (if (file-exists-p file
) (throw 'return file
))))
34 (error "Cannot find guile-emacs.scm")))
36 (defvar guile-channel-file
39 (let ((file (expand-file-name "channel.scm" dir
)))
40 (if (file-exists-p file
) (throw 'return file
))))
42 (error "Cannot find channel.scm")))
45 (nconc (if guile-channel-file
(list "-l" guile-channel-file
) '())
46 (list "-l" guile-emacs-file
)))
49 (defun guile:make-adapter
(command channel
)
50 (let* ((buff (generate-new-buffer " *guile object channel*"))
51 (libs (if guile-channel-file
(list "-l" guile-channel-file
) nil
))
52 (proc (apply 'start-process
"guile-oa" buff command
"-q" guile-libs
)))
53 (process-kill-without-query proc
)
54 (accept-process-output proc
)
55 (guile-process-require proc
(format "(%s)\n" channel
) "channel> ")
58 (put 'guile-error
'error-conditions
'(guile-error error
))
59 (put 'guile-error
'error-message
"Guile error")
61 (defvar guile-token-tag
"<guile>")
63 (defun guile-tokenp (x) (and (consp x
) (eq (car x
) guile-token-tag
)))
66 (defun guile:eval
(string adapter
)
68 (let ((output (guile-process-require adapter
(concat "eval " string
"\n")
71 ((string= output
"") nil
)
72 ((string-match "^\\(\\(value\\)\\|\\(token\\)\\|\\(exception\\)\\) = "
77 (car (read-from-string (substring output
(match-end 0)))))
81 (car (read-from-string (substring output
(match-end 0))))))
85 (car (read-from-string (substring output
(match-end 0))))))))
87 (error "Unsupported result" output
))))
89 (signal-process (process-id adapter
) 'SIGINT
)
94 ;;; Guile Lisp adapter
97 (defvar guile-lisp-command
"guile")
98 (defvar guile-lisp-adapter nil
)
103 (unless (boundp 'keywordp
)
104 (defun keywordp (x) (and (symbolp x
) (eq (aref (symbol-name x
) 0) ?
:))))
106 (defun guile-lisp-adapter ()
107 (if (and (processp guile-lisp-adapter
)
108 (eq (process-status guile-lisp-adapter
) 'run
))
110 (setq guile-lisp-adapter
111 (guile:make-adapter guile-lisp-command
'emacs-lisp-channel
))))
113 (defun guile-lisp-convert (x)
115 ((or (eq x true
) (eq x false
)) x
)
117 ((keywordp x
) (concat "#" (prin1-to-string x
)))
118 ((stringp x
) (prin1-to-string x
))
119 ((guile-tokenp x
) (cadr x
))
122 (list (guile-lisp-convert (car x
)))
123 (cons (guile-lisp-convert (car x
)) (guile-lisp-convert (cdr x
)))))
127 (defun guile-lisp-eval (form)
128 (guile:eval
(format "%s" (guile-lisp-convert form
)) (guile-lisp-adapter)))
130 (defun guile-lisp-flat-eval (&rest form
)
131 (let ((args (mapcar (lambda (x)
132 (if (guile-tokenp x
) (cadr x
) (list 'quote x
)))
134 (guile-lisp-eval (cons (car form
) args
))))
137 (defmacro guile-import
(name &optional new-name
&rest opts
)
138 `(guile-process-import ',name
',new-name
',opts
))
140 (defun guile-process-import (name new-name opts
)
141 (let ((real (or new-name name
))
142 (docs (if (memq :with-docs opts
) true false
)))
143 (eval (guile-lisp-eval `(guile-emacs-export ',name
',real
,docs
)))))
146 (defmacro guile-use-module
(name)
147 `(guile-lisp-eval '(use-modules ,name
)))
150 (defmacro guile-import-module
(name &rest opts
)
151 `(guile-process-import-module ',name
',opts
))
153 (defun guile-process-import-module (name opts
)
154 (unless (boundp 'guile-emacs-export-procedures
)
155 (guile-import guile-emacs-export-procedures
))
156 (let ((docs (if (memq :with-docs opts
) true false
)))
157 (guile-lisp-eval `(use-modules ,name
))
158 (eval (guile-emacs-export-procedures name docs
))
166 (defvar guile-process-output-start nil
)
167 (defvar guile-process-output-value nil
)
168 (defvar guile-process-output-finished nil
)
169 (defvar guile-process-output-separator nil
)
171 (defun guile-process-require (process string separator
)
172 (setq guile-process-output-value nil
)
173 (setq guile-process-output-finished nil
)
174 (setq guile-process-output-separator separator
)
176 (unless (process-buffer process
)
177 (setq temp-buffer
(guile-temp-buffer))
178 (set-process-buffer process temp-buffer
))
179 (with-current-buffer (process-buffer process
)
180 (goto-char (point-max))
182 (setq guile-process-output-start
(point))
183 (set-process-filter process
'guile-process-filter
)
184 (process-send-string process string
)
185 (while (not guile-process-output-finished
)
186 (unless (accept-process-output process
3)
187 (when (> (point) guile-process-output-start
)
188 (display-buffer (current-buffer))
189 (error "BUG in Guile object channel!!")))))
191 (set-process-buffer process nil
)
192 (kill-buffer temp-buffer
)))
193 guile-process-output-value
)
195 (defun guile-process-filter (process string
)
196 (with-current-buffer (process-buffer process
)
199 (if (< (point) guile-process-output-start
)
200 (goto-char guile-process-output-start
))
201 (when (re-search-forward guile-process-output-separator nil
0)
202 (goto-char (match-beginning 0))
203 (setq guile-process-output-value
204 (buffer-substring guile-process-output-start
(point)))
205 (setq guile-process-output-finished t
))))
207 (defun guile-process-kill (process)
208 (set-process-filter process nil
)
209 (delete-process process
)
210 (if (process-buffer process
)
211 (kill-buffer (process-buffer process
))))
215 ;;; guile.el ends here