mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-09 15:10:29 +02:00
Code Activity

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

Browse source 
guile-scheme-kill-process.

Bug fixed for GNU Emacs 20.7.
This commit is contained in:
Keisuke Nishida 2001-05-06 21:35:14 +00:00
parent fe7c2f88c2
commit 19a96c8ae4
4 changed files with 138 additions and 77 deletions
Download patch file Download diff file Expand all files Collapse all files

21
emacs/ChangeLog
View file

@ -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> 2001-04-25 Keisuke Nishida <kxn30@po.cwru.edu>
* guile.el, guile-scheme.el, guile-emacs.scm: New files. * guile.el, guile-scheme.el, guile-emacs.scm: New files.

21
emacs/guile-emacs.scm
View file

@ -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) (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) (define (guile-emacs-complete-alist str)
@ -125,6 +125,23 @@
apropos-fold-all) apropos-fold-all)
(lambda (p1 p2) (string<? (car p1) (car p2))))) (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 ;;; Guile 1.4 compatibility
;;; ;;;

116
emacs/guile-scheme.el
View file

@ -90,7 +90,10 @@ All commands in `lisp-mode-shared-map' are inherited by this map.")
(unless guile-scheme-mode-map (unless guile-scheme-mode-map
(let ((map (make-sparse-keymap "Guile-Scheme"))) (let ((map (make-sparse-keymap "Guile-Scheme")))
(setq guile-scheme-mode-map map) (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] (make-sparse-keymap))
(define-key map [menu-bar guile-scheme] (cons "Guile-Scheme" map)) (define-key map [menu-bar guile-scheme] (cons "Guile-Scheme" map))
(define-key map [uncomment-region] (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:" 'guile-scheme-eval-expression)
(define-key map "\C-c\C-a" 'guile-scheme-apropos) (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-d" 'guile-scheme-describe)
(define-key map "\C-c\C-k" 'guile-scheme-kill-process)
(put 'comment-region 'menu-enable 'mark-active) (put 'comment-region 'menu-enable 'mark-active)
(put 'uncomment-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-command "guile")
(defvar guile-scheme-adapter nil) (defvar guile-scheme-adapter nil)
(defvar guile-scheme-module nil)
(defun guile-scheme-adapter () (defun guile-scheme-adapter ()
(if (and (processp guile-scheme-adapter) (if (and (processp guile-scheme-adapter)
(eq (process-status guile-scheme-adapter) 'run)) (eq (process-status guile-scheme-adapter) 'run))
guile-scheme-adapter guile-scheme-adapter
(setq guile-scheme-module nil)
(setq guile-scheme-adapter (setq guile-scheme-adapter
(guile:make-adapter guile-scheme-command 'emacs-scheme-channel)))) (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. If there is a (define-module ...) form, evaluate it.
Otherwise, choose module (guile-user)." Otherwise, choose module (guile-user)."
(save-excursion (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)))
(let ((start (match-beginning 0))) (goto-char start)
(goto-char start) (forward-sexp)
(forward-sexp) (buffer-substring-no-properties start (point)))
(buffer-substring-no-properties start (point))) "(define-module (emacs-user))")))
"(define-module (emacs-user))") (unless (string= guile-scheme-module module)
(guile-scheme-adapter)))) (prog1 (guile:eval module (guile-scheme-adapter))
(setq guile-scheme-module module))))))
(defun guile-scheme-eval-string (string) (defun guile-scheme-eval-string (string)
(guile-scheme-set-module) (guile-scheme-set-module)
@ -244,9 +251,10 @@ With argument, print output into current buffer."
(defun guile-scheme-eval-print-last-sexp () (defun guile-scheme-eval-print-last-sexp ()
"Evaluate sexp before point; print value into current buffer." "Evaluate sexp before point; print value into current buffer."
(interactive) (interactive)
(insert "\n") (let ((start (point)))
(guile-scheme-eval-last-sexp t) (guile-scheme-eval-last-sexp t)
(insert "\n")) (insert "\n")
(save-excursion (goto-char start) (insert "\n"))))
(defun guile-scheme-eval-define () (defun guile-scheme-eval-define ()
(interactive) (interactive)
@ -259,10 +267,10 @@ With argument, print output into current buffer."
(guile-scheme-eval-string (format "(load %s)" (expand-file-name file))) (guile-scheme-eval-string (format "(load %s)" (expand-file-name file)))
(message "done")) (message "done"))
(guile-import guile-emacs-complete-alist)
(defun guile-scheme-complete-symbol () (defun guile-scheme-complete-symbol ()
(interactive) (interactive)
(unless (boundp 'guile-emacs-complete-alist)
(guile-import guile-emacs-complete-alist))
(let* ((end (point)) (let* ((end (point))
(start (save-excursion (skip-syntax-backward "w_") (point))) (start (save-excursion (skip-syntax-backward "w_") (point)))
(pattern (buffer-substring-no-properties start end)) (pattern (buffer-substring-no-properties start end))
@ -282,44 +290,48 @@ With argument, print output into current buffer."
(display-completion-list alist)) (display-completion-list alist))
(message "Making completion list...done")))))) (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))))
;;; ;;;

57
emacs/guile.el
View file

@ -63,26 +63,30 @@
;;;###autoload ;;;###autoload
(defun guile:eval (string adapter) (defun guile:eval (string adapter)
(let ((output (guile-process-require adapter (concat "eval " string "\n") (condition-case error
"channel> "))) (let ((output (guile-process-require adapter (concat "eval " string "\n")
(cond "channel> ")))
((string= output "") nil) (cond
((string-match "^\\(\\(value\\)\\|\\(token\\)\\|\\(exception\\)\\) = " ((string= output "") nil)
output) ((string-match "^\\(\\(value\\)\\|\\(token\\)\\|\\(exception\\)\\) = "
(cond output)
;; value (cond
((match-beginning 2) ;; value
(car (read-from-string (substring output (match-end 0))))) ((match-beginning 2)
;; token (car (read-from-string (substring output (match-end 0)))))
((match-beginning 3) ;; token
(cons guile-token-tag ((match-beginning 3)
(car (read-from-string (substring output (match-end 0)))))) (cons guile-token-tag
;; exception (car (read-from-string (substring output (match-end 0))))))
((match-beginning 4) ;; exception
(signal 'guile-error ((match-beginning 4)
(car (read-from-string (substring output (match-end 0)))))))) (signal 'guile-error
(t (car (read-from-string (substring output (match-end 0))))))))
(error "Unsupported result" output))))) (t
(error "Unsupported result" output))))
(quit
(signal-process (process-id adapter) 'SIGINT)
(signal 'quit nil))))
;;; ;;;
@ -95,6 +99,9 @@
(defvar true "#t") (defvar true "#t")
(defvar false "#f") (defvar false "#f")
(unless (boundp 'keywordp)
(defun keywordp (x) (and (symbolp x) (eq (aref (symbol-name x) 0) ?:))))
(defun guile-lisp-adapter () (defun guile-lisp-adapter ()
(if (and (processp guile-lisp-adapter) (if (and (processp guile-lisp-adapter)
(eq (process-status guile-lisp-adapter) 'run)) (eq (process-status guile-lisp-adapter) 'run))
@ -135,10 +142,14 @@
(eval (guile-lisp-eval `(guile-emacs-export ',name ',real ,docs))))) (eval (guile-lisp-eval `(guile-emacs-export ',name ',real ,docs)))))
;;;###autoload ;;;###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) (unless (boundp 'guile-emacs-export-procedures)
(guile-import guile-emacs-export-procedures)) (guile-import guile-emacs-export-procedures))
(let ((docs (if (memq :with-docs opts) true false))) (let ((docs (if (memq :with-docs opts) true false)))