1 ;;; guile-emacs.scm --- Guile Emacs interface
3 ;; Copyright (C) 2001 Keisuke Nishida <kxn30@po.cwru.edu>
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)
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.
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.
22 (use-modules (ice-9 regex))
23 (use-modules (ice-9 channel))
24 (use-modules (ice-9 session))
25 (use-modules (ice-9 documentation))
29 ;;; Emacs Lisp channel
32 (define (emacs-lisp-channel)
34 (define (native-type? x)
35 (or (integer? x) (symbol? x) (string? x) (pair? x) (vector? x)))
37 (define (emacs-lisp-print ch val)
40 ((eq? val #t) (channel-print-value ch 't))
41 ((or (eq? val #f) (null? val)) (channel-print-value ch 'nil))
42 ((native-type? val) (channel-print-value ch val))
43 (else (channel-print-token ch val))))
45 (channel-open (make-object-channel emacs-lisp-print)))
52 (define (emacs-scheme-channel)
53 (define (print ch val) (channel-print-value ch (object->string val)))
54 (channel-open (make-object-channel print)))
58 ;;; for guile-import and guile-import-module
61 (define (guile-emacs-export-procedure name proc docs)
62 (define (procedure-arity proc)
63 (assq-ref (procedure-properties proc) 'arity))
65 (define (procedure-args proc)
66 (let ((source (procedure-source proc)))
68 ;; formals -> emacs args
69 (let loop ((formals (cadr source)))
72 ((symbol? formals) `(&rest ,formals))
73 (else (cons (car formals) (loop (cdr formals))))))
74 ;; arity -> emacs args
75 (let* ((arity (procedure-arity proc))
78 (restp (caddr arity)))
80 (if (= n 0) '() (cons (gensym "a") (nsyms (1- n)))))
81 (append! (nsyms nreqs)
82 (if (> nopts 0) (cons '&optional (nsyms nopts)) '())
83 (if restp (cons '&rest (nsyms 1)) '()))))))
85 (define (procedure-call name args)
86 (let ((restp (memq '&rest args))
87 (args (delq '&rest (delq '&optional args))))
89 `('apply ',name ,@args)
92 (let ((args (procedure-args proc))
93 (docs (and docs (object-documentation proc))))
95 ,@(if docs (list docs) '())
96 (guile-lisp-flat-eval ,@(procedure-call (procedure-name proc) args)))))
98 (define (guile-emacs-export proc-name func-name docs)
99 (let ((proc (module-ref (current-module) proc-name)))
100 (guile-emacs-export-procedure func-name proc docs)))
102 (define (guile-emacs-export-procedures module-name docs)
103 (define (module-public-procedures name)
104 (hash-fold (lambda (s v d)
105 (let ((val (variable-ref v)))
106 (if (procedure? val) (acons s val d) d)))
107 '() (module-obarray (resolve-interface name))))
108 `(progn ,@(map (lambda (n+p)
109 (guile-emacs-export-procedure (car n+p) (cdr n+p) docs))
110 (module-public-procedures module-name))))
114 ;;; for guile-scheme-complete-symbol
117 (define (guile-emacs-complete-alist str)
118 (sort! (apropos-fold (lambda (module name val data)
119 (cons (list (symbol->string name)
120 (cond ((procedure? val) " <p>")
121 ((macro? val) " <m>")
124 '() (string-append "^" (regexp-quote str))
126 (lambda (p1 p2) (string<? (car p1) (car p2)))))
130 ;;; for guile-scheme-apropos
133 (define (guile-emacs-apropos regexp)
134 (with-output-to-string (lambda () (apropos regexp))))
138 ;;; for guile-scheme-describe
141 (define (guile-emacs-describe sym)
142 (object-documentation (eval sym (current-module))))
146 ;;; Guile 1.4 compatibility
149 (define object->string
150 (if (defined? 'object->string)
152 (lambda (x) (format #f "~S" x))))
154 ;;; guile-emacs.scm ends here