X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=guile18%2Femacs%2Fguile.el;fp=guile18%2Femacs%2Fguile.el;h=e85c81c29831488752c891a3a160885ead127c3c;hb=139c38d9204dd07f6b235f83bae644faedbc63fd;hp=0000000000000000000000000000000000000000;hpb=652ed35a2013489d0a14fede6307cd2595abb2c4;p=lilypond.git

diff --git a/guile18/emacs/guile.el b/guile18/emacs/guile.el
new file mode 100644
index 0000000000..e85c81c298
--- /dev/null
+++ b/guile18/emacs/guile.el
@@ -0,0 +1,215 @@
+;;; guile.el --- Emacs Guile interface
+
+;; 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.
+
+;; 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.
+
+;; 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., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, 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))))
+
+
+;;;
+;;; 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))
+
+
+;;;
+;;; 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