;; Copyright (C) 2001 Keisuke Nishida <kxn30@po.cwru.edu>
-;; GNU Emacs is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free
+;;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+;;;; 02111-1307 USA
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
+;;; Code:
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to the
-;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+(require 'cl)
-;;; Code:
+;;;
+;;; Low level interface
+;;;
+
+(defvar guile-emacs-file
+ (catch 'return
+ (mapc (lambda (dir)
+ (let ((file (expand-file-name "guile-emacs.scm" dir)))
+ (if (file-exists-p file) (throw 'return file))))
+ load-path)
+ (error "Cannot find guile-emacs.scm")))
+
+(defvar guile-channel-file
+ (catch 'return
+ (mapc (lambda (dir)
+ (let ((file (expand-file-name "channel.scm" dir)))
+ (if (file-exists-p file) (throw 'return file))))
+ load-path)
+ (error "Cannot find channel.scm")))
-(defun guile:make-adapter (command)
+(defvar guile-libs
+ (nconc (if guile-channel-file (list "-l" guile-channel-file) '())
+ (list "-l" guile-emacs-file)))
+
+;;;###autoload
+(defun guile:make-adapter (command channel)
(let* ((buff (generate-new-buffer " *guile object channel*"))
- (proc (start-process "guile-oa" buff command "-q")))
+ (libs (if guile-channel-file (list "-l" guile-channel-file) nil))
+ (proc (apply 'start-process "guile-oa" buff command "-q" guile-libs)))
(process-kill-without-query proc)
- (process-send-string proc "(use-modules (guile channel))\n")
- (process-send-string proc "(open-object-channel)\n")
(accept-process-output proc)
+ (guile-process-require proc (format "(%s)\n" channel) "channel> ")
proc))
-(defun guile:eval (exp adapter)
- (let ((str (format "eval %S\n" exp)))
- (guile-process-require adapter str "channel> " 'guile:eval-filter)))
+(put 'guile-error 'error-conditions '(guile-error error))
+(put 'guile-error 'error-message "Guile error")
+
+(defvar guile-token-tag "<guile>")
+
+(defun guile-tokenp (x) (and (consp x) (eq (car x) guile-token-tag)))
+
+;;;###autoload
+(defun guile:eval (string adapter)
+ (condition-case error
+ (let ((output (guile-process-require adapter (concat "eval " string "\n")
+ "channel> ")))
+ (cond
+ ((string= output "") nil)
+ ((string-match "^\\(\\(value\\)\\|\\(token\\)\\|\\(exception\\)\\) = "
+ output)
+ (cond
+ ;; value
+ ((match-beginning 2)
+ (car (read-from-string (substring output (match-end 0)))))
+ ;; token
+ ((match-beginning 3)
+ (cons guile-token-tag
+ (car (read-from-string (substring output (match-end 0))))))
+ ;; exception
+ ((match-beginning 4)
+ (signal 'guile-error
+ (car (read-from-string (substring output (match-end 0))))))))
+ (t
+ (error "Unsupported result" output))))
+ (quit
+ (signal-process (process-id adapter) 'SIGINT)
+ (signal 'quit nil))))
+
+\f
+;;;
+;;; Guile Lisp adapter
+;;;
+
+(defvar guile-lisp-command "guile")
+(defvar guile-lisp-adapter nil)
+
+(defvar true "#t")
+(defvar false "#f")
-(defun guile:eval-filter (proc)
+(unless (boundp 'keywordp)
+ (defun keywordp (x) (and (symbolp x) (eq (aref (symbol-name x) 0) ?:))))
+
+(defun guile-lisp-adapter ()
+ (if (and (processp guile-lisp-adapter)
+ (eq (process-status guile-lisp-adapter) 'run))
+ guile-lisp-adapter
+ (setq guile-lisp-adapter
+ (guile:make-adapter guile-lisp-command 'emacs-lisp-channel))))
+
+(defun guile-lisp-convert (x)
(cond
- ((looking-at "value = ")
- (car (read-from-string (buffer-substring (match-end 0) (point-max)))))
- ((looking-at "token = ")
- (caar (read-from-string (buffer-substring (match-end 0) (point-max)))))
- ((looking-at "exception = ")
- (apply 'signal (car (read-from-string
- (buffer-substring (match-end 0) (point-max))))))
- (t
- (error "Unsupported result"))))
+ ((or (eq x true) (eq x false)) x)
+ ((null x) "'()")
+ ((keywordp x) (concat "#" (prin1-to-string x)))
+ ((stringp x) (prin1-to-string x))
+ ((guile-tokenp x) (cadr x))
+ ((consp x)
+ (if (null (cdr x))
+ (list (guile-lisp-convert (car x)))
+ (cons (guile-lisp-convert (car x)) (guile-lisp-convert (cdr x)))))
+ (t x)))
+
+;;;###autoload
+(defun guile-lisp-eval (form)
+ (guile:eval (format "%s" (guile-lisp-convert form)) (guile-lisp-adapter)))
+
+(defun guile-lisp-flat-eval (&rest form)
+ (let ((args (mapcar (lambda (x)
+ (if (guile-tokenp x) (cadr x) (list 'quote x)))
+ (cdr form))))
+ (guile-lisp-eval (cons (car form) args))))
+
+;;;###autoload
+(defmacro guile-import (name &optional new-name &rest opts)
+ `(guile-process-import ',name ',new-name ',opts))
+
+(defun guile-process-import (name new-name opts)
+ (let ((real (or new-name name))
+ (docs (if (memq :with-docs opts) true false)))
+ (eval (guile-lisp-eval `(guile-emacs-export ',name ',real ,docs)))))
+
+;;;###autoload
+(defmacro guile-use-module (name)
+ `(guile-lisp-eval '(use-modules ,name)))
+
+;;;###autoload
+(defmacro guile-import-module (name &rest opts)
+ `(guile-process-import-module ',name ',opts))
+
+(defun guile-process-import-module (name opts)
+ (unless (boundp 'guile-emacs-export-procedures)
+ (guile-import guile-emacs-export-procedures))
+ (let ((docs (if (memq :with-docs opts) true false)))
+ (guile-lisp-eval `(use-modules ,name))
+ (eval (guile-emacs-export-procedures name docs))
+ name))
+\f
;;;
;;; Process handling
;;;
(defvar guile-process-output-start nil)
(defvar guile-process-output-value nil)
-(defvar guile-process-output-filter nil)
(defvar guile-process-output-finished nil)
(defvar guile-process-output-separator nil)
-(defvar guile-process-output-separator-lines 2)
-(defun guile-process-require (process string separator &optional filter)
+(defun guile-process-require (process string separator)
(setq guile-process-output-value nil)
- (setq guile-process-output-filter filter)
(setq guile-process-output-finished nil)
(setq guile-process-output-separator separator)
(let (temp-buffer)
(set-process-filter process 'guile-process-filter)
(process-send-string process string)
(while (not guile-process-output-finished)
- (unless (accept-process-output process 5)
+ (unless (accept-process-output process 3)
(when (> (point) guile-process-output-start)
(display-buffer (current-buffer))
- (error "BUG in the filter!!")))))
+ (error "BUG in Guile object channel!!")))))
(when temp-buffer
(set-process-buffer process nil)
(kill-buffer temp-buffer)))
(defun guile-process-filter (process string)
(with-current-buffer (process-buffer process)
(insert string)
- (forward-line (- guile-process-output-separator-lines))
+ (forward-line -1)
(if (< (point) guile-process-output-start)
(goto-char guile-process-output-start))
(when (re-search-forward guile-process-output-separator nil 0)
(goto-char (match-beginning 0))
- (if guile-process-output-filter
- (save-current-buffer
- (narrow-to-region guile-process-output-start (point))
- (goto-char (point-min))
- (setq guile-process-output-value
- (funcall guile-process-output-filter process))
- (widen))
- (setq guile-process-output-value
- (buffer-substring guile-process-output-start (point))))
+ (setq guile-process-output-value
+ (buffer-substring guile-process-output-start (point)))
(setq guile-process-output-finished t))))
(defun guile-process-kill (process)