guile18/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., 51 Franklin Street, Fifth Floor,
  18 ;; Boston, MA 02110-1301, USA.
  19
  20 ;;; Code:
  21
  22 (require 'cl)
  23
  24 ;;;
  25 ;;; Low level interface
  26 ;;;
  27
  28 (defvar guile-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 (defvar guile-channel-file
  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))))
  41           load-path)
  42     (error "Cannot find channel.scm")))
  43
  44 (defvar guile-libs
  45   (nconc (if guile-channel-file (list "-l" guile-channel-file) '())
  46          (list "-l" guile-emacs-file)))
  47
  48 ;;;###autoload
  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> ")
  56     proc))
  57
  58 (put 'guile-error 'error-conditions '(guile-error error))
  59 (put 'guile-error 'error-message "Guile error")
  60
  61 (defvar guile-token-tag "<guile>")
  62
  63 (defun guile-tokenp (x) (and (consp x) (eq (car x) guile-token-tag)))
  64
  65 ;;;###autoload
  66 (defun guile:eval (string adapter)
  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))))
  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
 103 (unless (boundp 'keywordp)
 104   (defun keywordp (x) (and (symbolp x) (eq (aref (symbol-name x) 0) ?:))))
 105
 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)
 116    ((null x) "'()")
 117    ((keywordp x) (concat "#" (prin1-to-string x)))
 118    ((stringp x) (prin1-to-string x))
 119    ((guile-tokenp x) (cadr x))
 120    ((consp x)
 121     (if (null (cdr x))
 122         (list (guile-lisp-convert (car x)))
 123       (cons (guile-lisp-convert (car x)) (guile-lisp-convert (cdr x)))))
 124    (t x)))
 125
 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))))
 135
 136 ;;;###autoload
 137 (defmacro guile-import (name &optional new-name &rest opts)
 138   `(guile-process-import ',name ',new-name ',opts))
 139
 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)))))
 144
 145 ;;;###autoload
 146 (defmacro guile-use-module (name)
 147   `(guile-lisp-eval '(use-modules ,name)))
 148
 149 ;;;###autoload
 150 (defmacro guile-import-module (name &rest opts)
 151   `(guile-process-import-module ',name ',opts))
 152
 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))
 159     name))
 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