emacs/guile-emacs.scm

   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., 51 Franklin Street, Fifth Floor,
  18 ;; Boston, MA 02110-1301, 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 ;;;
  58 ;;; for guile-import and guile-import-module
  59 ;;;
  60
  61 (define (guile-emacs-export-procedure name proc docs)
  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))
  87           (args (delq '&rest (delq '&optional args))))
  88       (if restp
  89         `('apply ',name ,@args)
  90         `(',name ,@args))))
  91
  92   (let ((args (procedure-args proc))
  93         (docs (and docs (object-documentation proc))))
  94     `(defun ,name ,args
  95        ,@(if docs (list docs) '())
  96        (guile-lisp-flat-eval ,@(procedure-call (procedure-name proc) args)))))
  97
  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)))
 101
 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))))
 111
 112 \f
 113 ;;;
 114 ;;; for guile-scheme-complete-symbol
 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
 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
 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
 154 ;;; guile-emacs.scm ends here