Import guile-1.8 as multiple upstream tarball component

[lilypond.git] / guile18 / emacs / guile-emacs.scm

diff --git a/guile18/emacs/guile-emacs.scm b/guile18/emacs/guile-emacs.scm
new file mode 100644 (file)
index 0000000..000d0cc
--- /dev/null
+++ b/guile18/emacs/guile-emacs.scm
@@ -0,0 +1,154 @@
+;;; guile-emacs.scm --- Guile Emacs 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:
+
+(use-modules (ice-9 regex))
+(use-modules (ice-9 channel))
+(use-modules (ice-9 session))
+(use-modules (ice-9 documentation))
+
+\f
+;;;
+;;; Emacs Lisp channel
+;;;
+
+(define (emacs-lisp-channel)
+
+  (define (native-type? x)
+    (or (integer? x) (symbol? x) (string? x) (pair? x) (vector? x)))
+
+  (define (emacs-lisp-print ch val)
+    (cond
+      ((unspecified? val))
+      ((eq? val #t) (channel-print-value ch 't))
+      ((or (eq? val #f) (null? val)) (channel-print-value ch 'nil))
+      ((native-type? val) (channel-print-value ch val))
+      (else (channel-print-token ch val))))
+
+  (channel-open (make-object-channel emacs-lisp-print)))
+
+\f
+;;;
+;;; Scheme channel
+;;;
+
+(define (emacs-scheme-channel)
+  (define (print ch val) (channel-print-value ch (object->string val)))
+  (channel-open (make-object-channel print)))
+
+\f
+;;;
+;;; for guile-import and guile-import-module
+;;;
+
+(define (guile-emacs-export-procedure name proc docs)
+  (define (procedure-arity proc)
+    (assq-ref (procedure-properties proc) 'arity))
+
+  (define (procedure-args proc)
+    (let ((source (procedure-source proc)))
+      (if source
+       ;; formals -> emacs args
+       (let loop ((formals (cadr source)))
+         (cond
+           ((null? formals) '())
+           ((symbol? formals) `(&rest ,formals))
+           (else (cons (car formals) (loop (cdr formals))))))
+       ;; arity -> emacs args
+       (let* ((arity (procedure-arity proc))
+              (nreqs (car arity))
+              (nopts (cadr arity))
+              (restp (caddr arity)))
+         (define (nsyms n)
+           (if (= n 0) '() (cons (gensym "a") (nsyms (1- n)))))
+         (append! (nsyms nreqs)
+                  (if (> nopts 0) (cons '&optional (nsyms nopts)) '())
+                  (if restp (cons '&rest (nsyms 1)) '()))))))
+
+  (define (procedure-call name args)
+    (let ((restp (memq '&rest args))
+         (args (delq '&rest (delq '&optional args))))
+      (if restp
+       `('apply ',name ,@args)
+       `(',name ,@args))))
+
+  (let ((args (procedure-args proc))
+       (docs (and docs (object-documentation proc))))
+    `(defun ,name ,args
+       ,@(if docs (list docs) '())
+       (guile-lisp-flat-eval ,@(procedure-call (procedure-name proc) args)))))
+
+(define (guile-emacs-export proc-name func-name docs)
+  (let ((proc (module-ref (current-module) proc-name)))
+    (guile-emacs-export-procedure func-name proc docs)))
+
+(define (guile-emacs-export-procedures module-name docs)
+  (define (module-public-procedures name)
+    (hash-fold (lambda (s v d)
+                (let ((val (variable-ref v)))
+                  (if (procedure? val) (acons s val d) d)))
+              '() (module-obarray (resolve-interface name))))
+  `(progn ,@(map (lambda (n+p)
+                  (guile-emacs-export-procedure (car n+p) (cdr n+p) docs))
+                (module-public-procedures module-name))))
+
+\f
+;;;
+;;; for guile-scheme-complete-symbol
+;;;
+
+(define (guile-emacs-complete-alist str)
+  (sort! (apropos-fold (lambda (module name val data)
+                        (cons (list (symbol->string name)
+                                    (cond ((procedure? val) " <p>")
+                                          ((macro? val)     " <m>")
+                                          (else "")))
+                              data))
+                      '() (string-append "^" (regexp-quote str))
+                      apropos-fold-all)
+        (lambda (p1 p2) (string<? (car p1) (car p2)))))
+
+\f
+;;;
+;;; for guile-scheme-apropos
+;;;
+
+(define (guile-emacs-apropos regexp)
+  (with-output-to-string (lambda () (apropos regexp))))
+
+\f
+;;;
+;;; for guile-scheme-describe
+;;;
+
+(define (guile-emacs-describe sym)
+  (object-documentation (eval sym (current-module))))
+
+\f
+;;;
+;;; Guile 1.4 compatibility
+;;;
+
+(define object->string
+  (if (defined? 'object->string)
+    object->string
+    (lambda (x) (format #f "~S" x))))
+
+;;; guile-emacs.scm ends here