From 2d857fb1accfef2948063cf16ecde13f8b7fcd37 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Wed, 25 Apr 2001 12:15:24 +0000 Subject: [PATCH] New files for Guile Emacs support. --- emacs/ChangeLog | 4 + emacs/guile-emacs.scm | 127 ++++++++++++++++ emacs/guile-scheme.el | 334 ++++++++++++++++++++++++++++++++++++++++++ emacs/guile.el | 172 ++++++++++++++++++++++ ice-9/ChangeLog | 4 + ice-9/channel.scm | 100 +++++++++++++ 6 files changed, 741 insertions(+) create mode 100644 emacs/guile-emacs.scm create mode 100644 emacs/guile-scheme.el create mode 100644 emacs/guile.el create mode 100644 ice-9/channel.scm diff --git a/emacs/ChangeLog b/emacs/ChangeLog index ef5058742..025a0cd53 100644 --- a/emacs/ChangeLog +++ b/emacs/ChangeLog @@ -1,3 +1,7 @@ +2001-04-25 Keisuke Nishida + + * guile.el, guile-scheme.el, guile-emacs.scm: New files. + 2001-03-13 Martin Grabmueller * guile-c.el (guile-c-edit-docstring): Set fill-column to 63, so diff --git a/emacs/guile-emacs.scm b/emacs/guile-emacs.scm new file mode 100644 index 000000000..7bc0ee785 --- /dev/null +++ b/emacs/guile-emacs.scm @@ -0,0 +1,127 @@ +;;; guile-emacs.scm --- Guile Emacs interface + +;; Copyright (C) 2001 Keisuke Nishida + +;; 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) "

") + ((macro? val) " ") + (else ""))) + data)) + '() (string-append "^" (regexp-quote str)) + apropos-fold-all) + (lambda (p1 p2) (string" + ;; 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 "#") + (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 diff --git a/emacs/guile.el b/emacs/guile.el new file mode 100644 index 000000000..f27bc4b7c --- /dev/null +++ b/emacs/guile.el @@ -0,0 +1,172 @@ +;;; guile.el --- Emacs Guile interface + +;; Copyright (C) 2001 Keisuke Nishida + +;; 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 "") + +(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 diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index e098ab4a5..36238456a 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,7 @@ +2001-04-25 Keisuke Nishida + + * channel.scm: New file. + 2001-04-19 Keisuke Nishida * receive.scm (receive): Use `define-macro'. diff --git a/ice-9/channel.scm b/ice-9/channel.scm new file mode 100644 index 000000000..f453ab85c --- /dev/null +++ b/ice-9/channel.scm @@ -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)) -- 2.20.1