Commit | Line | Data |
---|---|---|
2d857fb1 KN |
1 | ;;; guile.el --- Emacs Guile interface |
2 | ||
3 | ;; Copyright (C) 2001 Keisuke Nishida <kxn30@po.cwru.edu> | |
4 | ||
53befeb7 NJ |
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. | |
9 | ;;;; | |
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. | |
14 | ;;;; | |
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 | |
18 | ;;;; 02111-1307 USA | |
2d857fb1 KN |
19 | |
20 | ;;; Code: | |
21 | ||
b77e2f28 KN |
22 | (require 'cl) |
23 | ||
2d857fb1 KN |
24 | ;;; |
25 | ;;; Low level interface | |
26 | ;;; | |
27 | ||
9d459193 | 28 | (defvar guile-emacs-file |
2d857fb1 KN |
29 | (catch 'return |
30 | (mapc (lambda (dir) | |
31 | (let ((file (expand-file-name "guile-emacs.scm" dir))) | |
32 | (if (file-exists-p file) (throw 'return file)))) | |
33 | load-path) | |
34 | (error "Cannot find guile-emacs.scm"))) | |
35 | ||
9d459193 | 36 | (defvar guile-channel-file |
9ab0d788 KN |
37 | (catch 'return |
38 | (mapc (lambda (dir) | |
39 | (let ((file (expand-file-name "channel.scm" dir))) | |
40 | (if (file-exists-p file) (throw 'return file)))) | |
9d459193 NJ |
41 | load-path) |
42 | (error "Cannot find channel.scm"))) | |
9ab0d788 KN |
43 | |
44 | (defvar guile-libs | |
9d459193 NJ |
45 | (nconc (if guile-channel-file (list "-l" guile-channel-file) '()) |
46 | (list "-l" guile-emacs-file))) | |
9ab0d788 KN |
47 | |
48 | ;;;###autoload | |
2d857fb1 KN |
49 | (defun guile:make-adapter (command channel) |
50 | (let* ((buff (generate-new-buffer " *guile object channel*")) | |
9d459193 | 51 | (libs (if guile-channel-file (list "-l" guile-channel-file) nil)) |
9ab0d788 | 52 | (proc (apply 'start-process "guile-oa" buff command "-q" guile-libs))) |
2d857fb1 KN |
53 | (process-kill-without-query proc) |
54 | (accept-process-output proc) | |
55 | (guile-process-require proc (format "(%s)\n" channel) "channel> ") | |
56 | proc)) | |
57 | ||
58 | (put 'guile-error 'error-conditions '(guile-error error)) | |
59 | (put 'guile-error 'error-message "Guile error") | |
60 | ||
37052e60 KN |
61 | (defvar guile-token-tag "<guile>") |
62 | ||
63 | (defun guile-tokenp (x) (and (consp x) (eq (car x) guile-token-tag))) | |
64 | ||
9ab0d788 | 65 | ;;;###autoload |
2d857fb1 | 66 | (defun guile:eval (string adapter) |
19a96c8a KN |
67 | (condition-case error |
68 | (let ((output (guile-process-require adapter (concat "eval " string "\n") | |
69 | "channel> "))) | |
70 | (cond | |
71 | ((string= output "") nil) | |
72 | ((string-match "^\\(\\(value\\)\\|\\(token\\)\\|\\(exception\\)\\) = " | |
73 | output) | |
74 | (cond | |
75 | ;; value | |
76 | ((match-beginning 2) | |
77 | (car (read-from-string (substring output (match-end 0))))) | |
78 | ;; token | |
79 | ((match-beginning 3) | |
80 | (cons guile-token-tag | |
81 | (car (read-from-string (substring output (match-end 0)))))) | |
82 | ;; exception | |
83 | ((match-beginning 4) | |
84 | (signal 'guile-error | |
85 | (car (read-from-string (substring output (match-end 0)))))))) | |
86 | (t | |
87 | (error "Unsupported result" output)))) | |
88 | (quit | |
89 | (signal-process (process-id adapter) 'SIGINT) | |
90 | (signal 'quit nil)))) | |
2d857fb1 KN |
91 | |
92 | \f | |
93 | ;;; | |
94 | ;;; Guile Lisp adapter | |
95 | ;;; | |
96 | ||
97 | (defvar guile-lisp-command "guile") | |
98 | (defvar guile-lisp-adapter nil) | |
99 | ||
100 | (defvar true "#t") | |
101 | (defvar false "#f") | |
102 | ||
19a96c8a KN |
103 | (unless (boundp 'keywordp) |
104 | (defun keywordp (x) (and (symbolp x) (eq (aref (symbol-name x) 0) ?:)))) | |
105 | ||
2d857fb1 KN |
106 | (defun guile-lisp-adapter () |
107 | (if (and (processp guile-lisp-adapter) | |
108 | (eq (process-status guile-lisp-adapter) 'run)) | |
109 | guile-lisp-adapter | |
110 | (setq guile-lisp-adapter | |
111 | (guile:make-adapter guile-lisp-command 'emacs-lisp-channel)))) | |
112 | ||
113 | (defun guile-lisp-convert (x) | |
114 | (cond | |
115 | ((or (eq x true) (eq x false)) x) | |
37052e60 | 116 | ((null x) "'()") |
9ab0d788 | 117 | ((keywordp x) (concat "#" (prin1-to-string x))) |
2d857fb1 | 118 | ((stringp x) (prin1-to-string x)) |
37052e60 | 119 | ((guile-tokenp x) (cadr x)) |
2d857fb1 | 120 | ((consp x) |
37052e60 KN |
121 | (if (null (cdr x)) |
122 | (list (guile-lisp-convert (car x))) | |
2d857fb1 KN |
123 | (cons (guile-lisp-convert (car x)) (guile-lisp-convert (cdr x))))) |
124 | (t x))) | |
125 | ||
9ab0d788 KN |
126 | ;;;###autoload |
127 | (defun guile-lisp-eval (form) | |
128 | (guile:eval (format "%s" (guile-lisp-convert form)) (guile-lisp-adapter))) | |
129 | ||
130 | (defun guile-lisp-flat-eval (&rest form) | |
131 | (let ((args (mapcar (lambda (x) | |
132 | (if (guile-tokenp x) (cadr x) (list 'quote x))) | |
133 | (cdr form)))) | |
134 | (guile-lisp-eval (cons (car form) args)))) | |
2d857fb1 KN |
135 | |
136 | ;;;###autoload | |
9ab0d788 KN |
137 | (defmacro guile-import (name &optional new-name &rest opts) |
138 | `(guile-process-import ',name ',new-name ',opts)) | |
2d857fb1 | 139 | |
9ab0d788 KN |
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))))) | |
2d857fb1 | 144 | |
19a96c8a KN |
145 | ;;;###autoload |
146 | (defmacro guile-use-module (name) | |
147 | `(guile-lisp-eval '(use-modules ,name))) | |
148 | ||
2d857fb1 | 149 | ;;;###autoload |
9ab0d788 | 150 | (defmacro guile-import-module (name &rest opts) |
19a96c8a | 151 | `(guile-process-import-module ',name ',opts)) |
2d857fb1 | 152 | |
19a96c8a | 153 | (defun guile-process-import-module (name opts) |
2d857fb1 KN |
154 | (unless (boundp 'guile-emacs-export-procedures) |
155 | (guile-import guile-emacs-export-procedures)) | |
9ab0d788 KN |
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)) | |
159 | name)) | |
2d857fb1 KN |
160 | |
161 | \f | |
162 | ;;; | |
163 | ;;; Process handling | |
164 | ;;; | |
165 | ||
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) | |
170 | ||
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) | |
175 | (let (temp-buffer) | |
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)) | |
181 | (insert string) | |
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!!"))))) | |
190 | (when temp-buffer | |
191 | (set-process-buffer process nil) | |
192 | (kill-buffer temp-buffer))) | |
193 | guile-process-output-value) | |
194 | ||
195 | (defun guile-process-filter (process string) | |
196 | (with-current-buffer (process-buffer process) | |
197 | (insert string) | |
198 | (forward-line -1) | |
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)))) | |
206 | ||
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)))) | |
212 | ||
213 | (provide 'guile) | |
214 | ||
215 | ;;; guile.el ends here |