New commands: guile-scheme-apropos, guile-scheme-describe,

guile-scheme-kill-process.

Bug fixed for GNU Emacs 20.7.

emacs/ChangeLog

@@ -1,3 +1,24 @@
+2001-05-06  Keisuke Nishida  <kxn30@po.cwru.edu>
+
+	* guile.el (guile:eval): Propagate user interrupt.
+	(keywordp): Define it if not defined yet.
+	(guile-use-module): New macro.
+	(guile-process-import-module): Renamed from guile-process-use-module.
+
+	* guile-emacs.scm (guile-emacs-apropos, guile-emacs-describe):
+	New procedures. 
+
+	* guile-scheme.el (guile-scheme-mode-map): Use
+	`shared-lisp-mode-map' as the parent keymap if
+	`lisp-mode-shared-map' is not defined.
+	(guile-scheme-module): New variable.
+	(guile-scheme-set-module): Set module only when necessary.
+	(guile-scheme-eval-print-last-sexp): Insert newline after eval.
+	(guile-scheme-complete-table): New variable.
+	(guile-scheme-input-symbol): New function.
+	(guile-scheme-apropos, guile-scheme-describe,
+	guile-scheme-kill-process): New commands.
+
 2001-04-25  Keisuke Nishida  <kxn30@po.cwru.edu>
 
 	* guile.el, guile-scheme.el, guile-emacs.scm: New files.

emacs/guile-emacs.scm

@@ -55,7 +55,7 @@
 
 
 ;;;
-;;; for guile-import and guile-use-modules
+;;; for guile-import and guile-import-module
 ;;;
 
 (define (guile-emacs-export-procedure name proc docs)
@@ -111,7 +111,7 @@
 
 
 ;;;
-;;; for guile-emacs-complete-symbol
+;;; for guile-scheme-complete-symbol
 ;;;
 
 (define (guile-emacs-complete-alist str)
@@ -125,6 +125,23 @@
 		       apropos-fold-all)
 	 (lambda (p1 p2) (string<? (car p1) (car p2)))))
 
+
+;;;
+;;; for guile-scheme-apropos
+;;;
+
+(define (guile-emacs-apropos regexp)
+  (with-output-to-string (lambda () (apropos regexp))))
+
+
+;;;
+;;; for guile-scheme-describe
+;;;
+
+(define (guile-emacs-describe sym)
+  (object-documentation (eval sym (current-module))))
+
+
 ;;;
 ;;; Guile 1.4 compatibility
 ;;;

emacs/guile-scheme.el

@@ -90,7 +90,10 @@ 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)
+    (cond ((boundp 'lisp-mode-shared-map)
+	   (set-keymap-parent map lisp-mode-shared-map))
+	  ((boundp 'shared-lisp-mode-map)
+	   (set-keymap-parent map shared-lisp-mode-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]
@@ -108,6 +111,7 @@ All commands in `lisp-mode-shared-map' are inherited by this map.")
     (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)
+    (define-key map "\C-c\C-k" 'guile-scheme-kill-process)
 
     (put 'comment-region 'menu-enable 'mark-active)
     (put 'uncomment-region 'menu-enable 'mark-active)
@@ -179,11 +183,13 @@ All commands in `guile-scheme-mode-map' are inherited by this map.")
 
 (defvar guile-scheme-command "guile")
 (defvar guile-scheme-adapter nil)
+(defvar guile-scheme-module nil)
 
 (defun guile-scheme-adapter ()
   (if (and (processp guile-scheme-adapter)
 	   (eq (process-status guile-scheme-adapter) 'run))
       guile-scheme-adapter
+    (setq guile-scheme-module nil)
     (setq guile-scheme-adapter
 	  (guile:make-adapter guile-scheme-command 'emacs-scheme-channel))))
 
@@ -192,14 +198,15 @@ All commands in `guile-scheme-mode-map' are inherited by this map.")
 If there is a (define-module ...) form, evaluate it.
 Otherwise, choose module (guile-user)."
   (save-excursion
-    (guile:eval
+    (let ((module (if (re-search-backward "^(define-module " nil t)
-     (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))")
+		    "(define-module (emacs-user))")))
-     (guile-scheme-adapter))))
+      (unless (string= guile-scheme-module module)
+	(prog1 (guile:eval module (guile-scheme-adapter))
+	  (setq guile-scheme-module module))))))
 
 (defun guile-scheme-eval-string (string)
   (guile-scheme-set-module)
@@ -244,9 +251,10 @@ With argument, print output into current buffer."
 (defun guile-scheme-eval-print-last-sexp ()
   "Evaluate sexp before point; print value into current buffer."
   (interactive)
-  (insert "\n")
+  (let ((start (point)))
     (guile-scheme-eval-last-sexp t)
-  (insert "\n"))
+    (insert "\n")
+    (save-excursion (goto-char start) (insert "\n"))))
 
 (defun guile-scheme-eval-define ()
   (interactive)
@@ -259,10 +267,10 @@ With argument, print output into current buffer."
   (guile-scheme-eval-string (format "(load %s)" (expand-file-name file)))
   (message "done"))
 
+(guile-import guile-emacs-complete-alist)
+
 (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))
@@ -282,44 +290,48 @@ With argument, print output into current buffer."
 	       (display-completion-list alist))
 	     (message "Making completion list...done"))))))
 
-;; (define-command (guile-scheme-apropos regexp)
+(guile-import guile-emacs-apropos)
-;;   (interactive "sGuile-Scheme apropos (regexp): ")
+
-;;   (guile-scheme-set-module)
+(defun guile-scheme-apropos (regexp)
-;;   (let ((old #^guile-scheme-output-buffer))
+  (interactive "sGuile Scheme apropos (regexp): ")
-;;     (dynamic-wind
+  (guile-scheme-set-module)
-;; 	(lambda () (set! #^guile-scheme-output-buffer #f))
+  (with-output-to-temp-buffer "*Help*"
-;; 	(lambda ()
+    (princ (guile-emacs-apropos regexp))))
-;; 	  (with-output-to-temp-buffer "*Help*"
+
-;; 	    (lambda ()
+(guile-import guile-emacs-describe)
-;; 	      (apropos regexp))))
+
-;; 	(lambda () (set! #^guile-scheme-output-buffer old)))))
+(defun guile-scheme-describe (symbol)
-;; 
+  (interactive (list (guile-scheme-input-symbol "Describe Guile variable")))
-;; (define (guile-scheme-input-symbol prompt)
+  (guile-scheme-set-module)
-;;   (let* ((symbol (thing-at-point 'symbol))
+  (with-output-to-temp-buffer "*Help*"
-;; 	 (table (map (lambda (sym) (list (symbol->string sym)))
+    (princ (guile-emacs-describe symbol))))
-;; 		     (apropos-list "")))
+
-;; 	 (default (if (assoc symbol table)
+(defun guile-scheme-kill-process ()
-;; 		      (string-append " (default " symbol ")")
+  (interactive)
-;; 		      "")))
+  (if guile-scheme-adapter
-;;     (string->symbol (completing-read (string-append prompt default ": ")
+      (guile-process-kill guile-scheme-adapter))
-;; 				     table #f #t #f #f symbol))))
+  (setq guile-scheme-adapter nil))
-;; 
+
-;; (define-command (guile-scheme-describe symbol)
+
-;;   "Display the value and documentation of SYMBOL."
+;;;
-;;   (interactive (list (guile-scheme-input-symbol "Describe Guile-Scheme variable")))
+;;; Internal functions
-;;   (guile-scheme-set-module)
+;;;
-;;   (let ((old #^guile-scheme-output-buffer))
+
-;;     (dynamic-wind
+(guile-import apropos-internal guile-apropos-internal)
-;; 	(lambda () (set! #^guile-scheme-output-buffer #f))
+
-;; 	(lambda ()
+(defvar guile-scheme-complete-table (make-vector 151 nil))
-;; 	  (begin-with-output-to-temp-buffer "*Help*"
+
-;; 	    (describe symbol)))
+(defun guile-scheme-input-symbol (prompt)
-;; 	(lambda () (set! #^guile-scheme-output-buffer old)))))
+  (mapc (lambda (sym)
-;; 
+	  (if (symbolp sym)
-;; (define-command (guile-scheme-find-definition symbol)
+	      (intern (symbol-name sym) guile-scheme-complete-table)))
-;;   (interactive (list (guile-scheme-input-symbol "Guile-Scheme find definition")))
+	(guile-apropos-internal ""))
-;;   (guile-scheme-set-module)
+  (let* ((str (thing-at-point 'symbol))
-;;   )
+	 (default (if (intern-soft str guile-scheme-complete-table)
+		      (concat " (default " str ")")
+		    "")))
+    (intern (completing-read (concat prompt default ": ")
+			     guile-scheme-complete-table nil t nil nil str))))
 
 
 ;;;

emacs/guile.el

@@ -63,6 +63,7 @@
 
 ;;;###autoload
 (defun guile:eval (string adapter)
+  (condition-case error
       (let ((output (guile-process-require adapter (concat "eval " string "\n")
 					   "channel> ")))
 	(cond
@@ -82,7 +83,10 @@
 	    (signal 'guile-error
 		    (car (read-from-string (substring output (match-end 0))))))))
 	 (t
-      (error "Unsupported result" output)))))
+	  (error "Unsupported result" output))))
+    (quit
+     (signal-process (process-id adapter) 'SIGINT)
+     (signal 'quit nil))))
 
 
 ;;;
@@ -95,6 +99,9 @@
 (defvar true "#t")
 (defvar false "#f")
 
+(unless (boundp 'keywordp)
+  (defun keywordp (x) (and (symbolp x) (eq (aref (symbol-name x) 0) ?:))))
+
 (defun guile-lisp-adapter ()
   (if (and (processp guile-lisp-adapter)
 	   (eq (process-status guile-lisp-adapter) 'run))
@@ -135,10 +142,14 @@
     (eval (guile-lisp-eval `(guile-emacs-export ',name ',real ,docs)))))
 
 ;;;###autoload
-(defmacro guile-import-module (name &rest opts)
+(defmacro guile-use-module (name)
-  `(guile-process-use-module ',name ',opts))
+  `(guile-lisp-eval '(use-modules ,name)))
 
-(defun guile-process-use-module (name opts)
+;;;###autoload
+(defmacro guile-import-module (name &rest opts)
+  `(guile-process-import-module ',name ',opts))
+
+(defun guile-process-import-module (name opts)
   (unless (boundp 'guile-emacs-export-procedures)
     (guile-import guile-emacs-export-procedures))
   (let ((docs (if (memq :with-docs opts) true false)))