Commit | Line | Data |
---|---|---|
2d857fb1 KN |
1 | ;;; guile-emacs.scm --- Guile Emacs 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., 59 Temple Place - Suite 330, | |
18 | ;; Boston, MA 02111-1307, USA. | |
19 | ||
20 | ;;; Code: | |
21 | ||
22 | (use-modules (ice-9 regex)) | |
23 | (use-modules (ice-9 channel)) | |
24 | (use-modules (ice-9 session)) | |
25 | (use-modules (ice-9 documentation)) | |
26 | ||
27 | \f | |
28 | ;;; | |
29 | ;;; Emacs Lisp channel | |
30 | ;;; | |
31 | ||
32 | (define (emacs-lisp-channel) | |
33 | ||
34 | (define (native-type? x) | |
35 | (or (integer? x) (symbol? x) (string? x) (pair? x) (vector? x))) | |
36 | ||
37 | (define (emacs-lisp-print ch val) | |
38 | (cond | |
39 | ((unspecified? 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)))) | |
44 | ||
45 | (channel-open (make-object-channel emacs-lisp-print))) | |
46 | ||
47 | \f | |
48 | ;;; | |
49 | ;;; Scheme channel | |
50 | ;;; | |
51 | ||
52 | (define (emacs-scheme-channel) | |
53 | (define (print ch val) (channel-print-value ch (object->string val))) | |
54 | (channel-open (make-object-channel print))) | |
55 | ||
56 | \f | |
57 | ;;; | |
19a96c8a | 58 | ;;; for guile-import and guile-import-module |
2d857fb1 KN |
59 | ;;; |
60 | ||
9ab0d788 | 61 | (define (guile-emacs-export-procedure name proc docs) |
2d857fb1 KN |
62 | (define (procedure-arity proc) |
63 | (assq-ref (procedure-properties proc) 'arity)) | |
64 | ||
65 | (define (procedure-args proc) | |
66 | (let ((source (procedure-source proc))) | |
67 | (if source | |
68 | ;; formals -> emacs args | |
69 | (let loop ((formals (cadr source))) | |
70 | (cond | |
71 | ((null? formals) '()) | |
72 | ((symbol? formals) `(&rest ,formals)) | |
73 | (else (cons (car formals) (loop (cdr formals)))))) | |
74 | ;; arity -> emacs args | |
75 | (let* ((arity (procedure-arity proc)) | |
76 | (nreqs (car arity)) | |
77 | (nopts (cadr arity)) | |
78 | (restp (caddr arity))) | |
79 | (define (nsyms n) | |
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)) '())))))) | |
84 | ||
85 | (define (procedure-call name args) | |
86 | (let ((restp (memq '&rest args)) | |
9ab0d788 | 87 | (args (delq '&rest (delq '&optional args)))) |
2d857fb1 | 88 | (if restp |
9ab0d788 KN |
89 | `('apply ',name ,@args) |
90 | `(',name ,@args)))) | |
2d857fb1 | 91 | |
9ab0d788 KN |
92 | (let ((args (procedure-args proc)) |
93 | (docs (and docs (object-documentation proc)))) | |
2d857fb1 KN |
94 | `(defun ,name ,args |
95 | ,@(if docs (list docs) '()) | |
7405a09d | 96 | (guile-lisp-flat-eval ,@(procedure-call (procedure-name proc) args))))) |
2d857fb1 | 97 | |
9ab0d788 KN |
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))) | |
2d857fb1 | 101 | |
9ab0d788 | 102 | (define (guile-emacs-export-procedures module-name docs) |
2d857fb1 KN |
103 | (define (module-public-procedures name) |
104 | (hash-fold (lambda (s v d) | |
105 | (let ((val (variable-ref v))) | |
9ab0d788 | 106 | (if (procedure? val) (acons s val d) d))) |
2d857fb1 | 107 | '() (module-obarray (resolve-interface name)))) |
9ab0d788 KN |
108 | `(progn ,@(map (lambda (n+p) |
109 | (guile-emacs-export-procedure (car n+p) (cdr n+p) docs)) | |
2d857fb1 KN |
110 | (module-public-procedures module-name)))) |
111 | ||
112 | \f | |
113 | ;;; | |
19a96c8a | 114 | ;;; for guile-scheme-complete-symbol |
2d857fb1 KN |
115 | ;;; |
116 | ||
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>") | |
122 | (else ""))) | |
123 | data)) | |
124 | '() (string-append "^" (regexp-quote str)) | |
125 | apropos-fold-all) | |
126 | (lambda (p1 p2) (string<? (car p1) (car p2))))) | |
127 | ||
19a96c8a KN |
128 | \f |
129 | ;;; | |
130 | ;;; for guile-scheme-apropos | |
131 | ;;; | |
132 | ||
133 | (define (guile-emacs-apropos regexp) | |
134 | (with-output-to-string (lambda () (apropos regexp)))) | |
135 | ||
136 | \f | |
137 | ;;; | |
138 | ;;; for guile-scheme-describe | |
139 | ;;; | |
140 | ||
141 | (define (guile-emacs-describe sym) | |
142 | (object-documentation (eval sym (current-module)))) | |
143 | ||
144 | \f | |
1c446a7f KN |
145 | ;;; |
146 | ;;; Guile 1.4 compatibility | |
147 | ;;; | |
148 | ||
149 | (define object->string | |
150 | (if (defined? 'object->string) | |
151 | object->string | |
152 | (lambda (x) (format #f "~S" x)))) | |
153 | ||
2d857fb1 | 154 | ;;; guile-emacs.scm ends here |