emacs/guile-emacs.scm

   1 ;;; guile-emacs.scm --- Guile Emacs interface
   2
   3 ;; Copyright (C) 2001, 2010 Keisuke Nishida <kxn30@po.cwru.edu>
   4
   5 ;;;; This library is free software; you can redistribute it and/or
   6 ;;;; modify it under the terms of the GNU Lesser General Public
   7 ;;;; License as published by the Free Software Foundation; either
   8 ;;;; version 3 of the License, or (at your option) any later version.
   9 ;;;;
  10 ;;;; This library 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 GNU
  13 ;;;; Lesser General Public License for more details.
  14 ;;;;
  15 ;;;; You should have received a copy of the GNU Lesser General Public
  16 ;;;; License along with this library; if not, write to the Free
  17 ;;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
  18 ;;;; 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 ;;;
  58 ;;; for guile-import and guile-import-module
  59 ;;;
  60
  61 (define (guile-emacs-export-procedure name proc docs)
  62   (define (procedure-args proc)
  63     (let ((source (procedure-source proc)))
  64       (if source
  65         ;; formals -> emacs args
  66         (let loop ((formals (cadr source)))
  67           (cond
  68             ((null? formals) '())
  69             ((symbol? formals) `(&rest ,formals))
  70             (else (cons (car formals) (loop (cdr formals))))))
  71         ;; arity -> emacs args
  72         (let* ((arity (procedure-minimum-arity proc))
  73                (nreqs (car arity))
  74                (nopts (cadr arity))
  75                (restp (caddr arity)))
  76           (define (nsyms n)
  77             (if (= n 0) '() (cons (gensym "a") (nsyms (1- n)))))
  78           (append! (nsyms nreqs)
  79                    (if (> nopts 0) (cons '&optional (nsyms nopts)) '())
  80                    (if restp (cons '&rest (nsyms 1)) '()))))))
  81
  82   (define (procedure-call name args)
  83     (let ((restp (memq '&rest args))
  84           (args (delq '&rest (delq '&optional args))))
  85       (if restp
  86         `('apply ',name ,@args)
  87         `(',name ,@args))))
  88
  89   (let ((args (procedure-args proc))
  90         (docs (and docs (object-documentation proc))))
  91     `(defun ,name ,args
  92        ,@(if docs (list docs) '())
  93        (guile-lisp-flat-eval ,@(procedure-call (procedure-name proc) args)))))
  94
  95 (define (guile-emacs-export proc-name func-name docs)
  96   (let ((proc (module-ref (current-module) proc-name)))
  97     (guile-emacs-export-procedure func-name proc docs)))
  98
  99 (define (guile-emacs-export-procedures module-name docs)
 100   (define (module-public-procedures name)
 101     (hash-fold (lambda (s v d)
 102                  (let ((val (variable-ref v)))
 103                    (if (procedure? val) (acons s val d) d)))
 104                '() (module-obarray (resolve-interface name))))
 105   `(progn ,@(map (lambda (n+p)
 106                    (guile-emacs-export-procedure (car n+p) (cdr n+p) docs))
 107                  (module-public-procedures module-name))))
 108
 109 \f
 110 ;;;
 111 ;;; for guile-scheme-complete-symbol
 112 ;;;
 113
 114 (define (guile-emacs-complete-alist str)
 115   (sort! (apropos-fold (lambda (module name val data)
 116                          (cons (list (symbol->string name)
 117                                      (cond ((procedure? val) " <p>")
 118                                            ((macro? val)     " <m>")
 119                                            (else "")))
 120                                data))
 121                        '() (string-append "^" (regexp-quote str))
 122                        apropos-fold-all)
 123          (lambda (p1 p2) (string<? (car p1) (car p2)))))
 124
 125 \f
 126 ;;;
 127 ;;; for guile-scheme-apropos
 128 ;;;
 129
 130 (define (guile-emacs-apropos regexp)
 131   (with-output-to-string (lambda () (apropos regexp))))
 132
 133 \f
 134 ;;;
 135 ;;; for guile-scheme-describe
 136 ;;;
 137
 138 (define (guile-emacs-describe sym)
 139   (object-documentation (eval sym (current-module))))
 140
 141 \f
 142 ;;;
 143 ;;; Guile 1.4 compatibility
 144 ;;;
 145
 146 (define object->string
 147   (if (defined? 'object->string)
 148     object->string
 149     (lambda (x) (format #f "~S" x))))
 150
 151 ;;; guile-emacs.scm ends here