[bpt/guile.git] / emacs / guile.el

;;; guile.el --- Emacs Guile interface

;; Copyright (C) 2001 Keisuke Nishida <kxn30@po.cwru.edu>

;;;; 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

;;; Code:

(require 'cl)

;;;
;;; 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")))

(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*"))
	 (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)
    (accept-process-output proc)
    (guile-process-require proc (format "(%s)\n" channel) "channel> ")
    proc))

(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")

(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
   ((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-finished nil)
(defvar guile-process-output-separator nil)

(defun guile-process-require (process string separator)
  (setq guile-process-output-value nil)
  (setq guile-process-output-finished nil)
  (setq guile-process-output-separator separator)
  (let (temp-buffer)
    (unless (process-buffer process)
      (setq temp-buffer (guile-temp-buffer))
      (set-process-buffer process temp-buffer))
    (with-current-buffer (process-buffer process)
      (goto-char (point-max))
      (insert string)
      (setq guile-process-output-start (point))
      (set-process-filter process 'guile-process-filter)
      (process-send-string process string)
      (while (not guile-process-output-finished)
	(unless (accept-process-output process 3)
	  (when (> (point) guile-process-output-start)
	    (display-buffer (current-buffer))
	    (error "BUG in Guile object channel!!")))))
    (when temp-buffer
      (set-process-buffer process nil)
      (kill-buffer temp-buffer)))
  guile-process-output-value)

(defun guile-process-filter (process string)
  (with-current-buffer (process-buffer process)
    (insert string)
    (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))
      (setq guile-process-output-value
	    (buffer-substring guile-process-output-start (point)))
      (setq guile-process-output-finished t))))

(defun guile-process-kill (process)
  (set-process-filter process nil)
  (delete-process process)
  (if (process-buffer process)
      (kill-buffer (process-buffer process))))

(provide 'guile)

;;; guile.el ends here
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)
b77e2f28 KN	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)
9d459193 NJ	42	(error "Cannot find channel.scm")))
9ab0d788 KN	43
9ab0d788 KN	44	(defvar guile-libs
9d459193 NJ	45	(nconc (if guile-channel-file (list "-l" guile-channel-file) '())
9d459193 NJ	46	(list "-l" guile-emacs-file)))
9ab0d788 KN	47
9ab0d788 KN	48	;;;###autoload
2d857fb1 KN	49	(defun guile:make-adapter (command channel)
2d857fb1 KN	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))
37052e60 KN	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
2d857fb1 KN	136	;;;###autoload
9ab0d788 KN	137	(defmacro guile-import (name &optional new-name &rest opts)
9ab0d788 KN	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)
2d857fb1 KN	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