mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-20 10:40:19 +02:00
New files for Guile Emacs support.
This commit is contained in:
Keisuke Nishida
parent
253081cf6a
commit
2d857fb1ac
6 changed files with 741 additions and 0 deletions
|
|
@ -1,3 +1,7 @@
|
||||||
|
2001-04-25 Keisuke Nishida <kxn30@po.cwru.edu>
|
||||||
|
|
||||||
|
* guile.el, guile-scheme.el, guile-emacs.scm: New files.
|
||||||
|
|
||||||
2001-03-13 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
|
2001-03-13 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
|
||||||
|
|
||||||
* guile-c.el (guile-c-edit-docstring): Set fill-column to 63, so
|
* guile-c.el (guile-c-edit-docstring): Set fill-column to 63, so
|
||||||
|
|
|
||||||
127
emacs/guile-emacs.scm
Normal file
127
emacs/guile-emacs.scm
Normal file
|
|
@ -0,0 +1,127 @@
|
||||||
|
;;; 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., 59 Temple Place - Suite 330,
|
||||||
|
;; Boston, MA 02111-1307, USA.
|
||||||
|
|
||||||
|
;;; Code:
|
||||||
|
|
||||||
|
(use-modules (ice-9 regex))
|
||||||
|
(use-modules (ice-9 channel))
|
||||||
|
(use-modules (ice-9 session))
|
||||||
|
(use-modules (ice-9 documentation))
|
||||||
|
|
||||||
|
|
||||||
|
;;;
|
||||||
|
;;; 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)))
|
||||||
|
|
||||||
|
|
||||||
|
;;;
|
||||||
|
;;; Scheme channel
|
||||||
|
;;;
|
||||||
|
|
||||||
|
(define (emacs-scheme-channel)
|
||||||
|
(define (print ch val) (channel-print-value ch (object->string val)))
|
||||||
|
(channel-open (make-object-channel print)))
|
||||||
|
|
||||||
|
|
||||||
|
;;;
|
||||||
|
;;; for guile-import and guile-use-modules
|
||||||
|
;;;
|
||||||
|
|
||||||
|
(define (guile-emacs-export-procedure proc)
|
||||||
|
(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
|
||||||
|
`(list* ',name ,@args)
|
||||||
|
`(list ',name ,@args))))
|
||||||
|
|
||||||
|
(let ((name (procedure-name proc))
|
||||||
|
(args (procedure-args proc))
|
||||||
|
(docs (object-documentation proc)))
|
||||||
|
`(defun ,name ,args
|
||||||
|
,@(if docs (list docs) '())
|
||||||
|
(guile-lisp-eval ,(procedure-call name args)))))
|
||||||
|
|
||||||
|
(define (guile-emacs-export proc-name)
|
||||||
|
(guile-emacs-export-procedure (module-ref (current-module) proc-name)))
|
||||||
|
|
||||||
|
(define (guile-emacs-export-procedures module-name)
|
||||||
|
(define (module-public-procedures name)
|
||||||
|
(hash-fold (lambda (s v d)
|
||||||
|
(let ((val (variable-ref v)))
|
||||||
|
(if (procedure? val) (cons val d) d)))
|
||||||
|
'() (module-obarray (resolve-interface name))))
|
||||||
|
`(progn ,@(map guile-emacs-export-procedure
|
||||||
|
(module-public-procedures module-name))))
|
||||||
|
|
||||||
|
|
||||||
|
;;;
|
||||||
|
;;; for guile-emacs-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)))))
|
||||||
|
|
||||||
|
;;; guile-emacs.scm ends here
|
||||||
334
emacs/guile-scheme.el
Normal file
334
emacs/guile-scheme.el
Normal file
|
|
@ -0,0 +1,334 @@
|
||||||
|
;;; guile-scheme.el --- Guile Scheme editing mode
|
||||||
|
|
||||||
|
;; Copyright (C) 2001 Free Software Foundation, Inc.
|
||||||
|
|
||||||
|
;; 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., 59 Temple Place - Suite 330,
|
||||||
|
;; Boston, MA 02111-1307, USA.
|
||||||
|
|
||||||
|
;;; Commentary:
|
||||||
|
|
||||||
|
;; Put the following lines in your ~/.emacs:
|
||||||
|
;;
|
||||||
|
;; (require 'guile-scheme)
|
||||||
|
;; (setq initial-major-mode 'scheme-interaction-mode)
|
||||||
|
|
||||||
|
;;; Code:
|
||||||
|
|
||||||
|
(require 'guile)
|
||||||
|
(require 'scheme)
|
||||||
|
|
||||||
|
(defgroup guile-scheme nil
|
||||||
|
"Editing Guile-Scheme code"
|
||||||
|
:group 'lisp)
|
||||||
|
|
||||||
|
(defvar guile-scheme-syntax-keywords
|
||||||
|
'((begin 0) (if 1) (cond 0) (case 1) (do 2)
|
||||||
|
quote syntax lambda and or else delay receive use-modules
|
||||||
|
(match 1) (match-lambda 0) (match-lambda* 0)
|
||||||
|
(let scheme-let-indent) (let* 1) (letrec 1) (and-let* 1)
|
||||||
|
(let-syntax 1) (letrec-syntax 1) (syntax-rules 1) (syntax-case 2)))
|
||||||
|
|
||||||
|
(defvar guile-scheme-special-procedures
|
||||||
|
'((catch 1) (lazy-catch 1) (stack-catch 1)
|
||||||
|
map for-each (dynamic-wind 3)))
|
||||||
|
|
||||||
|
;; set indent functions
|
||||||
|
(dolist (x (append guile-scheme-syntax-keywords
|
||||||
|
guile-scheme-special-procedures))
|
||||||
|
(when (consp x)
|
||||||
|
(put (car x) 'scheme-indent-function (cadr x))))
|
||||||
|
|
||||||
|
(defconst guile-scheme-font-lock-keywords
|
||||||
|
(eval-when-compile
|
||||||
|
(list
|
||||||
|
(list (concat "(\\(define\\*?\\("
|
||||||
|
;; Function names.
|
||||||
|
"\\(\\|-public\\|-method\\|-generic\\)\\|"
|
||||||
|
;; Macro names, as variable names.
|
||||||
|
"\\(-syntax\\|-macro\\)\\|"
|
||||||
|
;; Others
|
||||||
|
"-\\sw+\\)\\)\\>"
|
||||||
|
;; Any whitespace and declared object.
|
||||||
|
"\\s *(?\\(\\sw+\\)?")
|
||||||
|
'(1 font-lock-keyword-face)
|
||||||
|
'(5 (cond ((match-beginning 3) font-lock-function-name-face)
|
||||||
|
((match-beginning 4) font-lock-variable-name-face)
|
||||||
|
(t font-lock-type-face)) nil t))
|
||||||
|
(list (concat
|
||||||
|
"(" (regexp-opt
|
||||||
|
(mapcar (lambda (e)
|
||||||
|
(prin1-to-string (if (consp e) (car e) e)))
|
||||||
|
(append guile-scheme-syntax-keywords
|
||||||
|
guile-scheme-special-procedures)) 'words))
|
||||||
|
'(1 font-lock-keyword-face))
|
||||||
|
'("<\\sw+>" . font-lock-type-face)
|
||||||
|
'("\\<:\\sw+\\>" . font-lock-builtin-face)
|
||||||
|
))
|
||||||
|
"Expressions to highlight in Guile Scheme mode.")
|
||||||
|
|
||||||
|
|
||||||
|
;;;
|
||||||
|
;;; Guile Scheme mode
|
||||||
|
;;;
|
||||||
|
|
||||||
|
(defvar guile-scheme-mode-map nil
|
||||||
|
"Keymap for Guile Scheme mode.
|
||||||
|
All commands in `lisp-mode-shared-map' are inherited by this map.")
|
||||||
|
|
||||||
|
(unless guile-scheme-mode-map
|
||||||
|
(let ((map (make-sparse-keymap "Guile-Scheme")))
|
||||||
|
(setq guile-scheme-mode-map map)
|
||||||
|
(set-keymap-parent map lisp-mode-shared-map)
|
||||||
|
(define-key map [menu-bar] (make-sparse-keymap))
|
||||||
|
(define-key map [menu-bar guile-scheme] (cons "Guile-Scheme" map))
|
||||||
|
(define-key map [uncomment-region]
|
||||||
|
'("Uncomment Out Region" . (lambda (beg end)
|
||||||
|
(interactive "r")
|
||||||
|
(comment-region beg end '(4)))))
|
||||||
|
(define-key map [comment-region] '("Comment Out Region" . comment-region))
|
||||||
|
(define-key map [indent-region] '("Indent Region" . indent-region))
|
||||||
|
(define-key map [indent-line] '("Indent Line" . lisp-indent-line))
|
||||||
|
(define-key map "\e\C-i" 'guile-scheme-complete-symbol)
|
||||||
|
(define-key map "\e\C-x" 'guile-scheme-eval-define)
|
||||||
|
(define-key map "\C-x\C-e" 'guile-scheme-eval-last-sexp)
|
||||||
|
(define-key map "\C-c\C-b" 'guile-scheme-eval-buffer)
|
||||||
|
(define-key map "\C-c\C-r" 'guile-scheme-eval-region)
|
||||||
|
(define-key map "\C-c:" 'guile-scheme-eval-expression)
|
||||||
|
(define-key map "\C-c\C-a" 'guile-scheme-apropos)
|
||||||
|
(define-key map "\C-c\C-d" 'guile-scheme-describe)
|
||||||
|
|
||||||
|
(put 'comment-region 'menu-enable 'mark-active)
|
||||||
|
(put 'uncomment-region 'menu-enable 'mark-active)
|
||||||
|
(put 'indent-region 'menu-enable 'mark-active)))
|
||||||
|
|
||||||
|
(defcustom guile-scheme-mode-hook nil
|
||||||
|
"Normal hook run when entering `guile-scheme-mode'."
|
||||||
|
:type 'hook
|
||||||
|
:group 'guile-scheme)
|
||||||
|
|
||||||
|
;;;###autoload
|
||||||
|
(defun guile-scheme-mode ()
|
||||||
|
"Major mode for editing Guile Scheme code.
|
||||||
|
Editing commands are similar to those of `scheme-mode'.
|
||||||
|
|
||||||
|
\\{scheme-mode-map}
|
||||||
|
Entry to this mode calls the value of `scheme-mode-hook'
|
||||||
|
if that value is non-nil."
|
||||||
|
(interactive)
|
||||||
|
(kill-all-local-variables)
|
||||||
|
(setq mode-name "Guile Scheme")
|
||||||
|
(setq major-mode 'guile-scheme-mode)
|
||||||
|
(use-local-map guile-scheme-mode-map)
|
||||||
|
(scheme-mode-variables)
|
||||||
|
(setq mode-line-process
|
||||||
|
'(:eval (if (processp guile-scheme-adapter)
|
||||||
|
(format " [%s]" guile-scheme-command)
|
||||||
|
"")))
|
||||||
|
(setq font-lock-defaults
|
||||||
|
'((guile-scheme-font-lock-keywords)
|
||||||
|
nil t (("+-*/.<>=!?$%_&~^:@" . "w")) beginning-of-defun
|
||||||
|
(font-lock-mark-block-function . mark-defun)))
|
||||||
|
(run-hooks 'guile-scheme-mode-hook))
|
||||||
|
|
||||||
|
|
||||||
|
;;;
|
||||||
|
;;; Scheme interaction mode
|
||||||
|
;;;
|
||||||
|
|
||||||
|
(defvar scheme-interaction-mode-map ()
|
||||||
|
"Keymap for Scheme Interaction mode.
|
||||||
|
All commands in `guile-scheme-mode-map' are inherited by this map.")
|
||||||
|
|
||||||
|
(unless scheme-interaction-mode-map
|
||||||
|
(let ((map (make-sparse-keymap)))
|
||||||
|
(setq scheme-interaction-mode-map map)
|
||||||
|
(set-keymap-parent map guile-scheme-mode-map)
|
||||||
|
(define-key map "\C-j" 'guile-scheme-eval-print-last-sexp)
|
||||||
|
))
|
||||||
|
|
||||||
|
(defvar scheme-interaction-mode-hook nil
|
||||||
|
"Normal hook run when entering `scheme-interaction-mode'.")
|
||||||
|
|
||||||
|
(defun scheme-interaction-mode ()
|
||||||
|
"Major mode for evaluating Scheme expressions with Guile.
|
||||||
|
|
||||||
|
\\{scheme-interaction-mode-map}"
|
||||||
|
(interactive)
|
||||||
|
(guile-scheme-mode)
|
||||||
|
(use-local-map scheme-interaction-mode-map)
|
||||||
|
(setq major-mode 'scheme-interaction-mode)
|
||||||
|
(setq mode-name "Scheme Interaction")
|
||||||
|
(run-hooks 'scheme-interaction-mode-hook))
|
||||||
|
|
||||||
|
|
||||||
|
;;;
|
||||||
|
;;; Guile Scheme adapter
|
||||||
|
;;;
|
||||||
|
|
||||||
|
(defvar guile-scheme-command "guile")
|
||||||
|
(defvar guile-scheme-adapter nil)
|
||||||
|
|
||||||
|
(defun guile-scheme-adapter ()
|
||||||
|
(if (and (processp guile-scheme-adapter)
|
||||||
|
(eq (process-status guile-scheme-adapter) 'run))
|
||||||
|
guile-scheme-adapter
|
||||||
|
(setq guile-scheme-adapter
|
||||||
|
(guile:make-adapter guile-scheme-command 'emacs-scheme-channel))))
|
||||||
|
|
||||||
|
(defun guile-scheme-set-module ()
|
||||||
|
"Set the current module based on buffer contents.
|
||||||
|
If there is a (define-module ...) form, evaluate it.
|
||||||
|
Otherwise, choose module (guile-user)."
|
||||||
|
(save-excursion
|
||||||
|
(guile:eval
|
||||||
|
(if (re-search-backward "^(define-module " nil t)
|
||||||
|
(let ((start (match-beginning 0)))
|
||||||
|
(goto-char start)
|
||||||
|
(forward-sexp)
|
||||||
|
(buffer-substring-no-properties start (point)))
|
||||||
|
"(define-module (emacs-user))")
|
||||||
|
(guile-scheme-adapter))))
|
||||||
|
|
||||||
|
(defun guile-scheme-eval-string (string)
|
||||||
|
(guile-scheme-set-module)
|
||||||
|
(guile:eval string (guile-scheme-adapter)))
|
||||||
|
|
||||||
|
(defun guile-scheme-display-result (value flag)
|
||||||
|
(if (string= value "#<unspecified>")
|
||||||
|
(setq value "done"))
|
||||||
|
(if flag
|
||||||
|
(insert value)
|
||||||
|
(message "%s" value)))
|
||||||
|
|
||||||
|
|
||||||
|
;;;
|
||||||
|
;;; Interactive commands
|
||||||
|
;;;
|
||||||
|
|
||||||
|
(defun guile-scheme-eval-expression (string)
|
||||||
|
"Evaluate the expression in STRING and show value in echo area."
|
||||||
|
(interactive "SGuile Scheme Eval: ")
|
||||||
|
(guile-scheme-display-result (guile-scheme-eval-string string) nil))
|
||||||
|
|
||||||
|
(defun guile-scheme-eval-region (start end)
|
||||||
|
"Evaluate the region as Guile Scheme code."
|
||||||
|
(interactive "r")
|
||||||
|
(guile-scheme-eval-expression (buffer-substring-no-properties start end)))
|
||||||
|
|
||||||
|
(defun guile-scheme-eval-buffer ()
|
||||||
|
"Evaluate the current buffer as Guile Scheme code."
|
||||||
|
(interactive)
|
||||||
|
(guile-scheme-eval-expression (buffer-string)))
|
||||||
|
|
||||||
|
(defun guile-scheme-eval-last-sexp (arg)
|
||||||
|
"Evaluate sexp before point; show value in echo area.
|
||||||
|
With argument, print output into current buffer."
|
||||||
|
(interactive "P")
|
||||||
|
(guile-scheme-display-result
|
||||||
|
(guile-scheme-eval-string
|
||||||
|
(buffer-substring-no-properties
|
||||||
|
(point) (save-excursion (backward-sexp) (point)))) arg))
|
||||||
|
|
||||||
|
(defun guile-scheme-eval-print-last-sexp ()
|
||||||
|
"Evaluate sexp before point; print value into current buffer."
|
||||||
|
(interactive)
|
||||||
|
(insert "\n")
|
||||||
|
(guile-scheme-eval-last-sexp t)
|
||||||
|
(insert "\n"))
|
||||||
|
|
||||||
|
(defun guile-scheme-eval-define ()
|
||||||
|
(interactive)
|
||||||
|
(guile-scheme-eval-region (save-excursion (end-of-defun) (point))
|
||||||
|
(save-excursion (beginning-of-defun) (point))))
|
||||||
|
|
||||||
|
(defun guile-scheme-load-file (file)
|
||||||
|
"Load a Guile Scheme file."
|
||||||
|
(interactive "fGuile Scheme load file: ")
|
||||||
|
(guile-scheme-eval-string (format "(load %s)" (expand-file-name file)))
|
||||||
|
(message "done"))
|
||||||
|
|
||||||
|
(defun guile-scheme-complete-symbol ()
|
||||||
|
(interactive)
|
||||||
|
(unless (boundp 'guile-emacs-complete-alist)
|
||||||
|
(guile-import guile-emacs-complete-alist))
|
||||||
|
(let* ((end (point))
|
||||||
|
(start (save-excursion (skip-syntax-backward "w_") (point)))
|
||||||
|
(pattern (buffer-substring-no-properties start end))
|
||||||
|
(alist (guile-emacs-complete-alist pattern)))
|
||||||
|
(goto-char end)
|
||||||
|
(let ((completion (try-completion pattern alist)))
|
||||||
|
(cond ((eq completion t))
|
||||||
|
((not completion)
|
||||||
|
(message "Can't find completion for \"%s\"" pattern)
|
||||||
|
(ding))
|
||||||
|
((not (string= pattern completion))
|
||||||
|
(delete-region start end)
|
||||||
|
(insert completion))
|
||||||
|
(t
|
||||||
|
(message "Making completion list...")
|
||||||
|
(with-output-to-temp-buffer "*Completions*"
|
||||||
|
(display-completion-list alist))
|
||||||
|
(message "Making completion list...done"))))))
|
||||||
|
|
||||||
|
;; (define-command (guile-scheme-apropos regexp)
|
||||||
|
;; (interactive "sGuile-Scheme apropos (regexp): ")
|
||||||
|
;; (guile-scheme-set-module)
|
||||||
|
;; (let ((old #^guile-scheme-output-buffer))
|
||||||
|
;; (dynamic-wind
|
||||||
|
;; (lambda () (set! #^guile-scheme-output-buffer #f))
|
||||||
|
;; (lambda ()
|
||||||
|
;; (with-output-to-temp-buffer "*Help*"
|
||||||
|
;; (lambda ()
|
||||||
|
;; (apropos regexp))))
|
||||||
|
;; (lambda () (set! #^guile-scheme-output-buffer old)))))
|
||||||
|
;;
|
||||||
|
;; (define (guile-scheme-input-symbol prompt)
|
||||||
|
;; (let* ((symbol (thing-at-point 'symbol))
|
||||||
|
;; (table (map (lambda (sym) (list (symbol->string sym)))
|
||||||
|
;; (apropos-list "")))
|
||||||
|
;; (default (if (assoc symbol table)
|
||||||
|
;; (string-append " (default " symbol ")")
|
||||||
|
;; "")))
|
||||||
|
;; (string->symbol (completing-read (string-append prompt default ": ")
|
||||||
|
;; table #f #t #f #f symbol))))
|
||||||
|
;;
|
||||||
|
;; (define-command (guile-scheme-describe symbol)
|
||||||
|
;; "Display the value and documentation of SYMBOL."
|
||||||
|
;; (interactive (list (guile-scheme-input-symbol "Describe Guile-Scheme variable")))
|
||||||
|
;; (guile-scheme-set-module)
|
||||||
|
;; (let ((old #^guile-scheme-output-buffer))
|
||||||
|
;; (dynamic-wind
|
||||||
|
;; (lambda () (set! #^guile-scheme-output-buffer #f))
|
||||||
|
;; (lambda ()
|
||||||
|
;; (begin-with-output-to-temp-buffer "*Help*"
|
||||||
|
;; (describe symbol)))
|
||||||
|
;; (lambda () (set! #^guile-scheme-output-buffer old)))))
|
||||||
|
;;
|
||||||
|
;; (define-command (guile-scheme-find-definition symbol)
|
||||||
|
;; (interactive (list (guile-scheme-input-symbol "Guile-Scheme find definition")))
|
||||||
|
;; (guile-scheme-set-module)
|
||||||
|
;; )
|
||||||
|
|
||||||
|
|
||||||
|
;;;
|
||||||
|
;;; Turn on guile-scheme-mode for .scm files by default.
|
||||||
|
;;;
|
||||||
|
|
||||||
|
(setq auto-mode-alist
|
||||||
|
(cons '("\\.scm\\'" . guile-scheme-mode) auto-mode-alist))
|
||||||
|
|
||||||
|
(provide 'guile-scheme)
|
||||||
|
|
||||||
|
;;; guile-scheme.el ends here
|
||||||
172
emacs/guile.el
Normal file
172
emacs/guile.el
Normal file
|
|
@ -0,0 +1,172 @@
|
||||||
|
;;; guile.el --- Emacs Guile 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., 59 Temple Place - Suite 330,
|
||||||
|
;; Boston, MA 02111-1307, USA.
|
||||||
|
|
||||||
|
;;; Code:
|
||||||
|
|
||||||
|
;;;
|
||||||
|
;;; Low level interface
|
||||||
|
;;;
|
||||||
|
|
||||||
|
(defvar guile-token "<guile>")
|
||||||
|
|
||||||
|
(defvar gulie-emacs-file
|
||||||
|
(catch 'return
|
||||||
|
(mapc (lambda (dir)
|
||||||
|
(let ((file (expand-file-name "guile-emacs.scm" dir)))
|
||||||
|
(if (file-exists-p file) (throw 'return file))))
|
||||||
|
load-path)
|
||||||
|
(error "Cannot find guile-emacs.scm")))
|
||||||
|
|
||||||
|
(defun guile:make-adapter (command channel)
|
||||||
|
(let* ((buff (generate-new-buffer " *guile object channel*"))
|
||||||
|
(proc (start-process "guile-oa" buff command
|
||||||
|
"-q" "-l" gulie-emacs-file)))
|
||||||
|
(process-kill-without-query proc)
|
||||||
|
(accept-process-output proc)
|
||||||
|
(guile-process-require proc (format "(%s)\n" channel) "channel> ")
|
||||||
|
proc))
|
||||||
|
|
||||||
|
(put 'guile-error 'error-conditions '(guile-error error))
|
||||||
|
(put 'guile-error 'error-message "Guile error")
|
||||||
|
|
||||||
|
(defun guile:eval (string adapter)
|
||||||
|
(let ((output (guile-process-require adapter (concat "eval " string "\n")
|
||||||
|
"channel> ")))
|
||||||
|
(cond
|
||||||
|
((string= output "") nil)
|
||||||
|
((string-match "^\\(\\(value\\)\\|\\(token\\)\\|\\(exception\\)\\) = "
|
||||||
|
output)
|
||||||
|
(cond
|
||||||
|
;; value
|
||||||
|
((match-beginning 2)
|
||||||
|
(car (read-from-string (substring output (match-end 0)))))
|
||||||
|
;; token
|
||||||
|
((match-beginning 3)
|
||||||
|
(cons guile-token
|
||||||
|
(car (read-from-string (substring output (match-end 0))))))
|
||||||
|
;; exception
|
||||||
|
((match-beginning 4)
|
||||||
|
(signal 'guile-error
|
||||||
|
(car (read-from-string (substring output (match-end 0))))))))
|
||||||
|
(t
|
||||||
|
(error "Unsupported result" output)))))
|
||||||
|
|
||||||
|
|
||||||
|
;;;
|
||||||
|
;;; Guile Lisp adapter
|
||||||
|
;;;
|
||||||
|
|
||||||
|
(defvar guile-lisp-command "guile")
|
||||||
|
(defvar guile-lisp-adapter nil)
|
||||||
|
|
||||||
|
(defvar true "#t")
|
||||||
|
(defvar false "#f")
|
||||||
|
|
||||||
|
(defun guile-lisp-adapter ()
|
||||||
|
(if (and (processp guile-lisp-adapter)
|
||||||
|
(eq (process-status guile-lisp-adapter) 'run))
|
||||||
|
guile-lisp-adapter
|
||||||
|
(setq guile-lisp-adapter
|
||||||
|
(guile:make-adapter guile-lisp-command 'emacs-lisp-channel))))
|
||||||
|
|
||||||
|
(defun guile-lisp-convert (x)
|
||||||
|
(cond
|
||||||
|
((or (eq x true) (eq x false)) x)
|
||||||
|
((stringp x) (prin1-to-string x))
|
||||||
|
((consp x)
|
||||||
|
(if (eq (car x) guile-token)
|
||||||
|
(cadr x)
|
||||||
|
(cons (guile-lisp-convert (car x)) (guile-lisp-convert (cdr x)))))
|
||||||
|
(t x)))
|
||||||
|
|
||||||
|
(defun guile-lisp-eval (exp)
|
||||||
|
(guile:eval (format "%s" (guile-lisp-convert exp)) (guile-lisp-adapter)))
|
||||||
|
|
||||||
|
;;;###autoload
|
||||||
|
(defmacro guile-import (name)
|
||||||
|
`(guile-process-import ',name))
|
||||||
|
|
||||||
|
(defun guile-process-import (name)
|
||||||
|
(eval (guile-lisp-eval `(guile-emacs-export ',name))))
|
||||||
|
|
||||||
|
;;;###autoload
|
||||||
|
(defmacro guile-use-modules (&rest name-list)
|
||||||
|
`(guile-process-use-modules ',name-list))
|
||||||
|
|
||||||
|
(defun guile-process-use-modules (list)
|
||||||
|
(unless (boundp 'guile-emacs-export-procedures)
|
||||||
|
(guile-import guile-emacs-export-procedures))
|
||||||
|
(guile-lisp-eval `(use-modules ,@list))
|
||||||
|
(mapc (lambda (name) (eval (guile-emacs-export-procedures name))) list))
|
||||||
|
|
||||||
|
|
||||||
|
;;;
|
||||||
|
;;; Process handling
|
||||||
|
;;;
|
||||||
|
|
||||||
|
(defvar guile-process-output-start nil)
|
||||||
|
(defvar guile-process-output-value nil)
|
||||||
|
(defvar guile-process-output-finished nil)
|
||||||
|
(defvar guile-process-output-separator nil)
|
||||||
|
|
||||||
|
(defun guile-process-require (process string separator)
|
||||||
|
(setq guile-process-output-value nil)
|
||||||
|
(setq guile-process-output-finished nil)
|
||||||
|
(setq guile-process-output-separator separator)
|
||||||
|
(let (temp-buffer)
|
||||||
|
(unless (process-buffer process)
|
||||||
|
(setq temp-buffer (guile-temp-buffer))
|
||||||
|
(set-process-buffer process temp-buffer))
|
||||||
|
(with-current-buffer (process-buffer process)
|
||||||
|
(goto-char (point-max))
|
||||||
|
(insert string)
|
||||||
|
(setq guile-process-output-start (point))
|
||||||
|
(set-process-filter process 'guile-process-filter)
|
||||||
|
(process-send-string process string)
|
||||||
|
(while (not guile-process-output-finished)
|
||||||
|
(unless (accept-process-output process 3)
|
||||||
|
(when (> (point) guile-process-output-start)
|
||||||
|
(display-buffer (current-buffer))
|
||||||
|
(error "BUG in Guile object channel!!")))))
|
||||||
|
(when temp-buffer
|
||||||
|
(set-process-buffer process nil)
|
||||||
|
(kill-buffer temp-buffer)))
|
||||||
|
guile-process-output-value)
|
||||||
|
|
||||||
|
(defun guile-process-filter (process string)
|
||||||
|
(with-current-buffer (process-buffer process)
|
||||||
|
(insert string)
|
||||||
|
(forward-line -1)
|
||||||
|
(if (< (point) guile-process-output-start)
|
||||||
|
(goto-char guile-process-output-start))
|
||||||
|
(when (re-search-forward guile-process-output-separator nil 0)
|
||||||
|
(goto-char (match-beginning 0))
|
||||||
|
(setq guile-process-output-value
|
||||||
|
(buffer-substring guile-process-output-start (point)))
|
||||||
|
(setq guile-process-output-finished t))))
|
||||||
|
|
||||||
|
(defun guile-process-kill (process)
|
||||||
|
(set-process-filter process nil)
|
||||||
|
(delete-process process)
|
||||||
|
(if (process-buffer process)
|
||||||
|
(kill-buffer (process-buffer process))))
|
||||||
|
|
||||||
|
(provide 'guile)
|
||||||
|
|
||||||
|
;;; guile.el ends here
|
||||||
|
|
@ -1,3 +1,7 @@
|
||||||
|
2001-04-25 Keisuke Nishida <kxn30@po.cwru.edu>
|
||||||
|
|
||||||
|
* channel.scm: New file.
|
||||||
|
|
||||||
2001-04-19 Keisuke Nishida <kxn30@po.cwru.edu>
|
2001-04-19 Keisuke Nishida <kxn30@po.cwru.edu>
|
||||||
|
|
||||||
* receive.scm (receive): Use `define-macro'.
|
* receive.scm (receive): Use `define-macro'.
|
||||||
|
|
|
||||||
100
ice-9/channel.scm
Normal file
100
ice-9/channel.scm
Normal file
|
|
@ -0,0 +1,100 @@
|
||||||
|
;;; Guile object channel
|
||||||
|
|
||||||
|
;; Copyright (C) 2001 Free Software Foundation, Inc.
|
||||||
|
|
||||||
|
;; This program 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.
|
||||||
|
;;
|
||||||
|
;; This program 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 this program; see the file COPYING. If not, write to
|
||||||
|
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
||||||
|
;; Boston, MA 02111-1307, USA.
|
||||||
|
|
||||||
|
;;; Code:
|
||||||
|
|
||||||
|
(define-module (ice-9 channel)
|
||||||
|
:export (make-object-channel
|
||||||
|
channel-open channel-print-value channel-print-token))
|
||||||
|
|
||||||
|
;;;
|
||||||
|
;;; Channel type
|
||||||
|
;;;
|
||||||
|
|
||||||
|
(define channel-type
|
||||||
|
(make-record-type 'channel '(stdin stdout printer token-module)))
|
||||||
|
|
||||||
|
(define make-channel (record-constructor channel-type))
|
||||||
|
|
||||||
|
(define (make-object-channel printer)
|
||||||
|
(make-channel (current-input-port)
|
||||||
|
(current-output-port)
|
||||||
|
printer
|
||||||
|
(make-module)))
|
||||||
|
|
||||||
|
(define channel-stdin (record-accessor channel-type 'stdin))
|
||||||
|
(define channel-stdout (record-accessor channel-type 'stdout))
|
||||||
|
(define channel-printer (record-accessor channel-type 'printer))
|
||||||
|
(define channel-token-module (record-accessor channel-type 'token-module))
|
||||||
|
|
||||||
|
;;;
|
||||||
|
;;; Channel
|
||||||
|
;;;
|
||||||
|
|
||||||
|
(define (channel-open ch)
|
||||||
|
(let ((stdin (channel-stdin ch))
|
||||||
|
(stdout (channel-stdout ch))
|
||||||
|
(printer (channel-printer ch))
|
||||||
|
(token-module (channel-token-module ch)))
|
||||||
|
(let loop ()
|
||||||
|
(catch #t
|
||||||
|
(lambda ()
|
||||||
|
(channel:prompt stdout)
|
||||||
|
(let ((cmd (read stdin)))
|
||||||
|
(if (eof-object? cmd)
|
||||||
|
(throw 'quit)
|
||||||
|
(case cmd
|
||||||
|
((eval)
|
||||||
|
(module-use! (current-module) token-module)
|
||||||
|
(printer ch (eval (read stdin) (current-module))))
|
||||||
|
((destroy)
|
||||||
|
(let ((token (read stdin)))
|
||||||
|
(if (module-defined? token-module token)
|
||||||
|
(module-remove! token-module token)
|
||||||
|
(channel:error stdout "Invalid token: ~S" token))))
|
||||||
|
((quit)
|
||||||
|
(throw 'quit))
|
||||||
|
(else
|
||||||
|
(channel:error stdout "Unknown command: ~S" cmd)))))
|
||||||
|
(loop))
|
||||||
|
(lambda (key . args)
|
||||||
|
(case key
|
||||||
|
((quit) (throw 'quit))
|
||||||
|
(else
|
||||||
|
(format stdout "exception = ~S\n"
|
||||||
|
(list key (apply format #f (cadr args) (caddr args))))
|
||||||
|
(loop))))))))
|
||||||
|
|
||||||
|
(define (channel-print-value ch val)
|
||||||
|
(format (channel-stdout ch) "value = ~S\n" val))
|
||||||
|
|
||||||
|
(define (channel-print-token ch val)
|
||||||
|
(let* ((token (symbol-append (gensym "%%") '%%))
|
||||||
|
(pair (cons token (object->string val))))
|
||||||
|
(format (channel-stdout ch) "token = ~S\n" pair)
|
||||||
|
(module-define! (channel-token-module ch) token val)))
|
||||||
|
|
||||||
|
(define (channel:prompt port)
|
||||||
|
(display "channel> " port)
|
||||||
|
(force-output port))
|
||||||
|
|
||||||
|
(define (channel:error port msg . args)
|
||||||
|
(display "ERROR: " port)
|
||||||
|
(apply format port msg args)
|
||||||
|
(newline port))
|
||||||
Loading…
Add table
Add a link
Reference in a new issue