emacs/guile.el

   1 ;;; guile.el --- Emacs Guile interface
   2
   3 ;; Copyright (C) 2001 Keisuke Nishida <kxn30@po.cwru.edu>
   4
   5 ;; GNU Emacs is free software; you can redistribute it and/or modify
   6 ;; it under the terms of the GNU General Public License as published by
   7 ;; the Free Software Foundation; either version 2, or (at your option)
   8 ;; any later version.
   9
  10 ;; GNU Emacs 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
  13 ;; GNU General Public License for more details.
  14
  15 ;; You should have received a copy of the GNU General Public License
  16 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  17 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  18 ;; Boston, MA 02111-1307, USA.
  19
  20 ;;; Code:
  21
  22 ;;;
  23 ;;; Low level interface
  24 ;;;
  25
  26 (defvar guile-token "<guile>")
  27
  28 (defvar gulie-emacs-file
  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
  36 (defun guile:make-adapter (command channel)
  37   (let* ((buff (generate-new-buffer " *guile object channel*"))
  38          (proc (start-process "guile-oa" buff command
  39                               "-q" "-l" gulie-emacs-file)))
  40     (process-kill-without-query proc)
  41     (accept-process-output proc)
  42     (guile-process-require proc (format "(%s)\n" channel) "channel> ")
  43     proc))
  44
  45 (put 'guile-error 'error-conditions '(guile-error error))
  46 (put 'guile-error 'error-message "Guile error")
  47
  48 (defun guile:eval (string adapter)
  49   (let ((output (guile-process-require adapter (concat "eval " string "\n")
  50                                        "channel> ")))
  51     (cond
  52      ((string= output "") nil)
  53      ((string-match "^\\(\\(value\\)\\|\\(token\\)\\|\\(exception\\)\\) = "
  54                     output)
  55       (cond
  56        ;; value
  57        ((match-beginning 2)
  58         (car (read-from-string (substring output (match-end 0)))))
  59        ;; token
  60        ((match-beginning 3)
  61         (cons guile-token
  62               (car (read-from-string (substring output (match-end 0))))))
  63        ;; exception
  64        ((match-beginning 4)
  65         (signal 'guile-error
  66                 (car (read-from-string (substring output (match-end 0))))))))
  67      (t
  68       (error "Unsupported result" output)))))
  69
  70 \f
  71 ;;;
  72 ;;; Guile Lisp adapter
  73 ;;;
  74
  75 (defvar guile-lisp-command "guile")
  76 (defvar guile-lisp-adapter nil)
  77
  78 (defvar true "#t")
  79 (defvar false "#f")
  80
  81 (defun guile-lisp-adapter ()
  82   (if (and (processp guile-lisp-adapter)
  83            (eq (process-status guile-lisp-adapter) 'run))
  84       guile-lisp-adapter
  85     (setq guile-lisp-adapter
  86           (guile:make-adapter guile-lisp-command 'emacs-lisp-channel))))
  87
  88 (defun guile-lisp-convert (x)
  89   (cond
  90    ((or (eq x true) (eq x false)) x)
  91    ((stringp x) (prin1-to-string x))
  92    ((consp x)
  93     (if (eq (car x) guile-token)
  94         (cadr x)
  95       (cons (guile-lisp-convert (car x)) (guile-lisp-convert (cdr x)))))
  96    (t x)))
  97
  98 (defun guile-lisp-eval (exp)
  99   (guile:eval (format "%s" (guile-lisp-convert exp)) (guile-lisp-adapter)))
 100
 101 ;;;###autoload
 102 (defmacro guile-import (name)
 103   `(guile-process-import ',name))
 104
 105 (defun guile-process-import (name)
 106   (eval (guile-lisp-eval `(guile-emacs-export ',name))))
 107
 108 ;;;###autoload
 109 (defmacro guile-use-modules (&rest name-list)
 110   `(guile-process-use-modules ',name-list))
 111
 112 (defun guile-process-use-modules (list)
 113   (unless (boundp 'guile-emacs-export-procedures)
 114     (guile-import guile-emacs-export-procedures))
 115   (guile-lisp-eval `(use-modules ,@list))
 116   (mapc (lambda (name) (eval (guile-emacs-export-procedures name))) list))
 117
 118 \f
 119 ;;;
 120 ;;; Process handling
 121 ;;;
 122
 123 (defvar guile-process-output-start nil)
 124 (defvar guile-process-output-value nil)
 125 (defvar guile-process-output-finished nil)
 126 (defvar guile-process-output-separator nil)
 127
 128 (defun guile-process-require (process string separator)
 129   (setq guile-process-output-value nil)
 130   (setq guile-process-output-finished nil)
 131   (setq guile-process-output-separator separator)
 132   (let (temp-buffer)
 133     (unless (process-buffer process)
 134       (setq temp-buffer (guile-temp-buffer))
 135       (set-process-buffer process temp-buffer))
 136     (with-current-buffer (process-buffer process)
 137       (goto-char (point-max))
 138       (insert string)
 139       (setq guile-process-output-start (point))
 140       (set-process-filter process 'guile-process-filter)
 141       (process-send-string process string)
 142       (while (not guile-process-output-finished)
 143         (unless (accept-process-output process 3)
 144           (when (> (point) guile-process-output-start)
 145             (display-buffer (current-buffer))
 146             (error "BUG in Guile object channel!!")))))
 147     (when temp-buffer
 148       (set-process-buffer process nil)
 149       (kill-buffer temp-buffer)))
 150   guile-process-output-value)
 151
 152 (defun guile-process-filter (process string)
 153   (with-current-buffer (process-buffer process)
 154     (insert string)
 155     (forward-line -1)
 156     (if (< (point) guile-process-output-start)
 157         (goto-char guile-process-output-start))
 158     (when (re-search-forward guile-process-output-separator nil 0)
 159       (goto-char (match-beginning 0))
 160       (setq guile-process-output-value
 161             (buffer-substring guile-process-output-start (point)))
 162       (setq guile-process-output-finished t))))
 163
 164 (defun guile-process-kill (process)
 165   (set-process-filter process nil)
 166   (delete-process process)
 167   (if (process-buffer process)
 168       (kill-buffer (process-buffer process))))
 169
 170 (provide 'guile)
 171
 172 ;;; guile.el ends here