mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-03 13:20:26 +02:00
2457 lines
79 KiB
EmacsLisp
2457 lines
79 KiB
EmacsLisp
;;; @(#) guile.el -- A GNU Emacs interface to Guile
|
||
;;; @(#) $Keywords: guile, comint, scheme-mode $
|
||
|
||
;; Copyright (C) 1995, 2002 Mikael Djurfeldt
|
||
|
||
;; LCD Archive Entry:
|
||
;; guile|djurfeldt@nada.kth.se|
|
||
;; A GNU Emacs extension which |
|
||
;; $Date: 2003-08-20 19:00:44 $|$Revision: 1.1 $|~/misc/guile.el.Z|
|
||
|
||
;; Author: Mikael Djurfeldt <djurfeldt@nada.kth.se>
|
||
;; Version: 1.5.2
|
||
|
||
;; 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 of the License, 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 GNU Emacs. If you did not, write to the Free Software Foundation,
|
||
;; Inc., 675 Mass Ave., Cambridge, MA 02139, USA.
|
||
|
||
;;; Commentary:
|
||
;;
|
||
;; Requirements:
|
||
;;
|
||
;; Usage:
|
||
;;
|
||
;; Bugs:
|
||
;;
|
||
;;
|
||
;;; *************************************************************************
|
||
;;; * This is code is currently under development *
|
||
;;; * Mail any problems to djurfeldt@nada.kth.se *
|
||
;;; *************************************************************************
|
||
|
||
(require 'cl)
|
||
(require 'fcreate)
|
||
|
||
(defvar guile-auto-attach nil)
|
||
|
||
(defvar guile-load-hook nil
|
||
"*Hook run when file is loaded")
|
||
|
||
;;(require 'cmuscheme)
|
||
(load "comint") ; `comint' and `cmuscheme' are already loaded.
|
||
(load "cmuscheme") ; We need to replace them.
|
||
|
||
;; Faces are set in the cond expression below.
|
||
|
||
(defvar guile-error-face nil
|
||
"Face used to highlight erroneous scheme forms.")
|
||
|
||
(defvar guile-backtrace-mouse-face nil
|
||
"Face used when the mouse is over a backtrace frame.")
|
||
|
||
(defvar guile-modified-face nil
|
||
"Face for modified top-level forms in scheme-mode buffers.")
|
||
|
||
(defvar guile-broken-face nil
|
||
"Face for broken top-level forms in scheme-mode buffers.")
|
||
|
||
;; These faces are used during debugging of the list parsing code.
|
||
|
||
(defvar guile-unmodified-face-1 nil)
|
||
(defvar guile-unmodified-face-2 nil)
|
||
(defvar guile-modified-face-1 nil)
|
||
(defvar guile-modified-face-2 nil)
|
||
(defvar guile-broken-face-1 nil)
|
||
(defvar guile-broken-face-2 nil)
|
||
|
||
;;; Customization
|
||
;;;
|
||
|
||
(defvar guile-backtrace-in-source-window t
|
||
"*If non-nil, let backtrace windows appear in bottom of source window.
|
||
This only occurs if the erring expression can be located.")
|
||
|
||
(defvar guile-show-runlight-in-scheme-mode nil
|
||
"*If non-nil, show process status also in attached scheme-mode buffers.
|
||
Otherwise the mode-line shows if the buffer is attached or not.")
|
||
|
||
(defvar guile-default-enhanced-edit t
|
||
"If non-nil, automatically enter enhanced edit mode for scheme buffers.")
|
||
|
||
(defvar guile-popup-restart-on-death t)
|
||
|
||
(defvar guile-popup-restart-on-stop t)
|
||
|
||
(defvar guile-insert-reason t)
|
||
|
||
(defvar guile-kill-buffer-on-death nil)
|
||
|
||
(defvar guile-process-timeout 500
|
||
"Milliseconds")
|
||
|
||
(defconst guile-backtrace-buffer-name "*Scheme Backtrace*")
|
||
|
||
(defconst guile-error-buffer-name "*Scheme Error*")
|
||
|
||
(defconst guile-backtrace-min-height 10)
|
||
(defconst guile-backtrace-max-height 30)
|
||
(defconst guile-backtrace-min-width 30)
|
||
(defconst guile-backtrace-max-width 90)
|
||
|
||
(cond ((not window-system)
|
||
;; Faces for text terminals
|
||
(setq guile-error-face 'modeline)
|
||
(setq guile-backtrace-mouse-face 'highlight)
|
||
(setq guile-modified-face nil) ; no special face
|
||
(setq guile-broken-face nil)
|
||
(setq guile-unmodified-face-1 nil)
|
||
(setq guile-unmodified-face-2 'modeline)
|
||
(setq guile-modified-face-1 'bold)
|
||
(setq guile-modified-face-2 guile-error-face)
|
||
(setq guile-broken-face-1 nil)
|
||
(setq guile-broken-face-2 nil))
|
||
((x-display-color-p)
|
||
;; Faces for color screens
|
||
(setq guile-error-face (lookup-face-create 'black/red-bold))
|
||
(setq guile-backtrace-mouse-face 'highlight)
|
||
(setq guile-modified-face nil) ; no special face
|
||
(setq guile-broken-face 'bold)
|
||
(setq guile-unmodified-face-1 (lookup-face-create 'black/lightblue))
|
||
(setq guile-unmodified-face-2 'secondary-selection)
|
||
(setq guile-modified-face-1 'highlight)
|
||
(setq guile-modified-face-2 (lookup-face-create 'black/pink))
|
||
(setq guile-broken-face-1
|
||
(let ((face (make-face 'broken-form-1)))
|
||
(copy-face guile-modified-face-1 face)
|
||
(set-face-underline-p face t)
|
||
face))
|
||
(setq guile-broken-face-2
|
||
(let ((face (make-face 'broken-form-2)))
|
||
(copy-face guile-modified-face-2 face)
|
||
(set-face-underline-p face t)
|
||
face)))
|
||
(t
|
||
;; Faces for monochrome screens
|
||
(setq guile-error-face (lookup-face-create 'white/black-bold))
|
||
(setq guile-backtrace-mouse-face 'highlight)
|
||
(setq guile-modified-face nil) ; no special face
|
||
(setq guile-broken-face 'bold)
|
||
(setq guile-unmodified-face-1 nil)
|
||
(setq guile-unmodified-face-2 'modeline)
|
||
(setq guile-modified-face-1 'bold)
|
||
(setq guile-modified-face-2 guile-error-face)
|
||
(setq guile-broken-face-1
|
||
(let ((face (make-face 'broken-form-1)))
|
||
(copy-face guile-modified-face-1 face)
|
||
(set-face-underline-p face t)
|
||
face))
|
||
(setq guile-broken-face-2
|
||
(let ((face (make-face 'broken-form-2)))
|
||
(copy-face guile-modified-face-2 face)
|
||
(set-face-underline-p face t)
|
||
face))))
|
||
|
||
(if (not (fboundp 'lisp-mode-auto-fill))
|
||
(defun lisp-mode-auto-fill ()
|
||
(if (> (current-column) (current-fill-column))
|
||
(if (save-excursion
|
||
(nth 4 (parse-partial-sexp (save-excursion
|
||
(beginning-of-defun)
|
||
(point))
|
||
(point))))
|
||
(do-auto-fill)
|
||
(let ((comment-start nil) (comment-start-skip nil))
|
||
(do-auto-fill))))))
|
||
|
||
(defconst guile-symclash-obarray-size 521)
|
||
|
||
(defconst guile-big-integer 33333333)
|
||
|
||
;;; Mode initializers
|
||
;;;
|
||
|
||
(defvar guile-inferior-scheme-frame nil)
|
||
|
||
;; Inferior Scheme Mode
|
||
;;
|
||
(defun guile-inferior-initialize ()
|
||
;; Buffer local variables
|
||
(make-local-variable 'guile-eval-result)
|
||
(make-local-variable 'guile-eval-output)
|
||
(make-local-variable 'guile-last-output-end)
|
||
(make-local-variable 'guile-last-prompt-end)
|
||
(make-local-variable 'guile-define-name-marker)
|
||
(make-local-variable 'guile-unallowed-output)
|
||
(make-local-variable 'guile-define-startcol)
|
||
(make-local-variable 'guile-define-filler)
|
||
(make-local-variable 'guile-define-fillcol)
|
||
(set-process-sentinel (scheme-proc) (function guile-sentinel))
|
||
(setq comint-dispatch-alist guile-dispatch-alist)
|
||
(add-hook 'comint-input-filter-functions
|
||
(function guile-sync-on-input) nil 'local)
|
||
(add-hook 'comint-unallowed-output-filter-functions
|
||
(function guile-remember-unallowed-output) nil 'local)
|
||
(setq comint-dynamic-complete-functions '(guile-complete-symbol))
|
||
(make-local-hook 'scheme-enter-input-wait-hook)
|
||
;; Some initializations
|
||
(setq scheme-ready-p nil)
|
||
(setq scheme-load-p nil)
|
||
(setq guile-no-stack-p nil)
|
||
(setq guile-no-source-p nil)
|
||
(setq guile-last-output-end (make-marker))
|
||
(setq guile-last-prompt-end (make-marker))
|
||
(setq guile-input-sent-p t)
|
||
(setq guile-define-name-marker (make-marker))
|
||
(setq guile-error-p nil)
|
||
(setq guile-sexp-overlay nil)
|
||
(setq guile-frame-overlay nil)
|
||
(let ((enhanced (guile-get-enhanced-buffers)))
|
||
(and scheme-buffer (guile-detach-all))
|
||
(for-each (function guile-normal-edit) enhanced)
|
||
(guile-kill-overlays)
|
||
(for-each (function (lambda (buffer)
|
||
(save-excursion
|
||
(set-buffer buffer)
|
||
(guile-enhanced-edit
|
||
buffer
|
||
(not scheme-buffer-modified-p)))))
|
||
enhanced))
|
||
(setq guile-synchronizedp t)
|
||
(setq comint-allow-output-p t)
|
||
(setq guile-unallowed-output nil)
|
||
)
|
||
|
||
(defvar default-handle-switch-frame-binding
|
||
(lookup-key global-map [switch-frame]))
|
||
(define-key global-map [switch-frame] 'guile-handle-switch-frame)
|
||
|
||
(defun guile-handle-switch-frame (event)
|
||
(interactive "e")
|
||
(let ((frame (nth 1 event)))
|
||
(if (eq frame guile-inferior-scheme-frame)
|
||
(guile-sync-with-scheme))
|
||
(funcall default-handle-switch-frame-binding frame)))
|
||
|
||
(defun guile-sync-on-input (string)
|
||
(if scheme-load-p
|
||
(progn
|
||
nil))
|
||
(setq guile-error-p nil) ;; What is this??? *fixme*
|
||
(guile-sync-with-scheme)
|
||
(if guile-error-p
|
||
(progn
|
||
;; The read-only-overlay extends during transfer of error and
|
||
;; backtrace information. Check why! *fixme*
|
||
(let ((inhibit-read-only t))
|
||
(comint-kill-input))
|
||
;; By generating an error we interrupt the execution
|
||
;; of the comint-input-filter-functions hook.
|
||
(error "Bad expression! Please correct."))))
|
||
|
||
(defvar guile-unallowed-output nil)
|
||
|
||
(defun guile-remember-unallowed-output (string)
|
||
(if guile-unallowed-output
|
||
(setq guile-unallowed-output
|
||
(concat guile-unallowed-output string))))
|
||
|
||
(add-hook 'inferior-scheme-mode-hook (function guile-inferior-initialize))
|
||
|
||
;; Scheme Mode
|
||
;;
|
||
(defvar scheme-buffer-overlays ()
|
||
"The overlays containing top-level sexps when in enhanced edit mode.
|
||
A nil value indicates that the buffer is not in enhanced edit mode.")
|
||
|
||
(defvar scheme-buffer-last-overlay nil
|
||
"When in enhanced edit mode, this variable contains the lowermost
|
||
overlay.")
|
||
|
||
(defvar scheme-buffer-modified-p nil
|
||
"Non-nil if any overlay has been modified since last synchronization.")
|
||
|
||
(defvar scheme-buffer-overlays-modified-p nil)
|
||
|
||
(defvar scheme-associated-process-buffer nil
|
||
"The buffer of the scheme process to which this buffer is associated.
|
||
A value of nil means that this buffer is detached.")
|
||
|
||
(defvar scheme-overlay-repair-function nil)
|
||
|
||
(make-variable-buffer-local 'scheme-overlay-repair-function)
|
||
|
||
(defvar scheme-overlay-repair-idle-timer nil)
|
||
|
||
(defun guile-scheme-mode-initialize ()
|
||
"Initialize a scheme mode buffer."
|
||
(make-local-variable 'scheme-buffer-overlays)
|
||
(make-local-variable 'scheme-buffer-modified-p)
|
||
(make-local-variable 'scheme-buffer-last-overlay)
|
||
(make-local-variable 'scheme-buffer-overlays-modified-p)
|
||
(make-local-variable 'scheme-associated-process-buffer)
|
||
(make-local-variable 'guile-last-broken)
|
||
(make-local-variable 'guile-repair-limit)
|
||
(make-local-hook 'first-change-hook)
|
||
(add-hook 'first-change-hook (function guile-scheme-buffer-modified) nil t)
|
||
(make-local-hook 'kill-buffer-hook)
|
||
(add-hook 'kill-buffer-hook (function guile-scheme-mode-cleanup) nil t)
|
||
(if guile-default-enhanced-edit
|
||
(guile-enhanced-edit (current-buffer)
|
||
;; If buffer not modified, take a chance...
|
||
(and (not scheme-buffer-modified-p)
|
||
(not (buffer-modified-p (current-buffer))))
|
||
))
|
||
)
|
||
|
||
(add-hook 'scheme-mode-hook (function guile-scheme-mode-initialize))
|
||
|
||
(defun guile-scheme-buffer-modified ()
|
||
(setq scheme-buffer-modified-p t))
|
||
|
||
(defun guile-scheme-mode-cleanup ()
|
||
(if (guile-attachedp (current-buffer))
|
||
(progn
|
||
(guile-sync-buffer (current-buffer))
|
||
(guile-detach-buffer (current-buffer))))
|
||
(if (guile-enhancedp (current-buffer))
|
||
(guile-normal-edit (current-buffer))))
|
||
|
||
;;; User interface support
|
||
;;;
|
||
|
||
(defun guile-clear-transcript ()
|
||
"Delete all text before the last prompt in the scheme process buffer."
|
||
(interactive)
|
||
(if (or (not (buffer-name))
|
||
(not (string= (buffer-name) scheme-buffer)))
|
||
(error "This command must be issued in the scheme process buffer!"))
|
||
(save-excursion
|
||
(goto-char (or (marker-position guile-last-prompt-end)
|
||
(point-max)))
|
||
(if (re-search-backward comint-prompt-regexp nil t)
|
||
(goto-char (match-beginning 0))
|
||
(beginning-of-line))
|
||
(let ((inhibit-read-only t))
|
||
(delete-region (point-min) (point)))))
|
||
|
||
(defun guile-switch-to-scheme ()
|
||
"Switch to the scheme process buffer and places cursor at the end.
|
||
Also update the scheme process with all changes made in attached buffers."
|
||
(interactive)
|
||
(guile-sync-with-scheme)
|
||
;(if (not guile-error-p)
|
||
; (switch-to-scheme t))
|
||
(switch-to-scheme t))
|
||
|
||
;;; Process control
|
||
;;;
|
||
;(defvar scheme-running-p nil
|
||
; "This variable, if nil, indicates that the process is waiting for input.")
|
||
|
||
(defvar scheme-ready-p nil
|
||
"If non-nil, the process is waiting for input at the top-level repl.")
|
||
|
||
(defvar scheme-load-p nil)
|
||
|
||
(defvar guile-no-stack-p nil)
|
||
|
||
(defvar guile-no-source-p nil)
|
||
|
||
(defun guile-inferior-dialog (contents)
|
||
(let ((window (display-buffer "*scheme*")))
|
||
(x-popup-dialog window contents)))
|
||
|
||
(defun guile-sentinel (process reason)
|
||
(let ((status (process-status process)))
|
||
(if guile-insert-reason
|
||
(let ((old-buffer (current-buffer)))
|
||
(unwind-protect
|
||
(progn
|
||
(set-buffer (process-buffer process))
|
||
(goto-char (point-max))
|
||
(insert reason)
|
||
(goto-char (point-max))
|
||
(sit-for 0))
|
||
(set-buffer old-buffer))))
|
||
(cond ((eq status 'run)
|
||
(scheme-set-runlight scheme-last-runlight))
|
||
((eq status 'stop)
|
||
(scheme-set-runlight 'stopped)
|
||
(if guile-popup-restart-on-stop
|
||
(if (guile-inferior-dialog '("The scheme process has been stopped.
|
||
Do you want to restart it?" ("Yes" . t) nil ("No" . nil)))
|
||
(continue-process process))))
|
||
(t
|
||
(guile-inferior-death-cleanup)
|
||
(if guile-popup-restart-on-death
|
||
(if (guile-inferior-dialog '("The scheme process has died.
|
||
Do you want to restart it?" ("Yes" . t) nil ("No" . nil)))
|
||
(run-scheme scheme-program-name)
|
||
(or guile-kill-buffer-on-death
|
||
(kill-buffer "*scheme*")))
|
||
(or guile-kill-buffer-on-death
|
||
(kill-buffer "*scheme*")))))))
|
||
|
||
(defun guile-inferior-death-cleanup ()
|
||
(scheme-set-runlight nil)
|
||
(setq scheme-ready-p nil)
|
||
(setq scheme-virtual-file-list nil)
|
||
(guile-detach-all))
|
||
|
||
;; It would be too late to set this variable in the inferior-scheme-mode-hook:
|
||
;;(setq comint-output-filter-function (function comint-dispatch-output-filter))
|
||
;; *fixme* This should rather be done with advice.
|
||
|
||
(defun run-scheme (cmd)
|
||
"Run an inferior Scheme process, input and output via buffer *scheme*.
|
||
If there is a process already running in *scheme*, just switch to that buffer.
|
||
With argument, allows you to edit the command line (default is value
|
||
of scheme-program-name). Runs the hooks from inferior-scheme-mode-hook
|
||
\(after the comint-mode-hook is run).
|
||
\(Type \\[describe-mode] in the process buffer for a list of commands.)"
|
||
|
||
(interactive (list (if current-prefix-arg
|
||
(read-string "Run Scheme: " scheme-program-name)
|
||
scheme-program-name)))
|
||
(if (not (comint-check-proc "*scheme*"))
|
||
(let ((cmdlist (scheme-args-to-list cmd))
|
||
(comint-output-filter-function
|
||
(function comint-dispatch-output-filter)))
|
||
(set-buffer (apply 'make-comint "scheme" (car cmdlist)
|
||
nil (cdr cmdlist)))
|
||
(inferior-scheme-mode)))
|
||
(setq scheme-program-name cmd)
|
||
(setq scheme-buffer "*scheme*")
|
||
(pop-to-buffer "*scheme*")
|
||
;; *fixme* Ugly to specialize `run-scheme' in this way...
|
||
(setq guile-inferior-scheme-frame (selected-frame)))
|
||
|
||
(defun guile-restart-scheme ()
|
||
(interactive)
|
||
(let ((old-buffer (current-buffer)))
|
||
(unwind-protect
|
||
(progn
|
||
(set-buffer scheme-buffer)
|
||
(let ((attached-buffers inferior-scheme-associated-buffers))
|
||
(guile-shutdown)
|
||
(let ((inhibit-read-only t))
|
||
(erase-buffer))
|
||
(setq comint-allow-output-p t)
|
||
(run-scheme scheme-program-name)
|
||
;(sit-for 0 200)
|
||
(for-each (function (lambda (buffer)
|
||
(if (buffer-name buffer)
|
||
(guile-attach-buffer buffer))))
|
||
(reverse attached-buffers))))
|
||
(set-buffer old-buffer))))
|
||
|
||
(defun guile-shutdown ()
|
||
(interactive)
|
||
(let ((guile-popup-restart-on-death nil)
|
||
(old-buffer (current-buffer)))
|
||
(unwind-protect
|
||
(progn
|
||
(set-buffer scheme-buffer)
|
||
(setq comint-allow-output-p nil) ; Hide output
|
||
(setq guile-unallowed-output nil)
|
||
(if scheme-ready-p
|
||
(let ((inhibit-read-only t))
|
||
(comint-kill-input)
|
||
(comint-send-string (scheme-proc) "(quit)\n")
|
||
(let ((countdown 5))
|
||
(while (and scheme-ready-p (> countdown 0))
|
||
(sit-for 0 300)
|
||
(setq countdown (1- countdown))))))
|
||
(sit-for 0 100)
|
||
(if (comint-check-proc "*scheme*")
|
||
(progn
|
||
(kill-process (scheme-proc))
|
||
(while (comint-check-proc "*scheme*")
|
||
(sit-for 0 300))))
|
||
(sit-for 0 100))
|
||
(set-buffer old-buffer))))
|
||
|
||
(defun guile-exit-scheme ()
|
||
"Stop the running scheme process and kill the corresponding window"
|
||
(interactive)
|
||
(guile-shutdown)
|
||
(if (not (comint-check-proc "*scheme*"))
|
||
(kill-buffer "*scheme*")))
|
||
|
||
;;; Basic process protocol
|
||
|
||
(setq guile-dispatch-alist
|
||
'((?f scheme-exit-input-wait scheme:simple-action)
|
||
(?l scheme-load-acknowledge scheme:simple-action)
|
||
(?r scheme-enter-read scheme:simple-action)
|
||
(?s scheme-enter-input-wait scheme:simple-action)
|
||
(?B guile-receive-backtrace scheme:buffer-action)
|
||
(?F guile-receive-error scheme:buffer-action)
|
||
(?x guile-receive-result scheme:string-action)
|
||
(?S guile-no-stack scheme:simple-action)
|
||
(?R guile-no-source scheme:simple-action)
|
||
))
|
||
|
||
(defun scheme:simple-action (action)
|
||
(setq comint-dispatch-state 'idle)
|
||
(funcall action))
|
||
|
||
(defun scheme:string-action (action)
|
||
(setq comint-string-receiver action)
|
||
(setq comint-string-accumulator "")
|
||
(setq comint-dispatch-state 'reading-string))
|
||
|
||
(defun scheme:buffer-action (action)
|
||
(setq comint-buffer-receiver action)
|
||
(setq comint-receiving-buffer (generate-new-buffer "*receiving-buffer*"))
|
||
(setq comint-dispatch-state 'reading-to-buffer))
|
||
|
||
;;; Guile protocol
|
||
|
||
(defun guile-no-stack ()
|
||
(setq guile-no-stack-p t))
|
||
|
||
(defun guile-no-source ()
|
||
(setq guile-no-source-p t))
|
||
|
||
(defvar guile-eval-result nil)
|
||
(defvar guile-eval-output nil)
|
||
|
||
(defun guile-receive-result (string)
|
||
(setq comint-allow-output-p nil)
|
||
(setq guile-eval-result string)
|
||
(setq guile-eval-output guile-unallowed-output)
|
||
(setq guile-unallowed-output nil))
|
||
|
||
(defun guile-eval (sexp &optional stringp)
|
||
(let ((process (scheme-proc)) ;*fixme*
|
||
(comint-input-filter-functions '())
|
||
(comint-output-filter-functions '()))
|
||
(if (not scheme-ready-p)
|
||
(error "Scheme process not ready to receive commands."))
|
||
(setq guile-eval-result nil)
|
||
(comint-send-string process
|
||
(format "(%%%%emacs-eval-request '%S)\n" sexp))
|
||
(while (not guile-eval-result)
|
||
(accept-process-output process))
|
||
(while (not scheme-ready-p)
|
||
(accept-process-output process))
|
||
(if stringp
|
||
guile-eval-result
|
||
(car (read-from-string guile-eval-result)))))
|
||
|
||
(defun scheme-set-runlight (runlight)
|
||
(setq inferior-scheme-mode-line-process
|
||
(or runlight "no process"))
|
||
(setq scheme-last-runlight runlight)
|
||
(if guile-show-runlight-in-scheme-mode
|
||
(let ((old-buffer (current-buffer))
|
||
(buffers inferior-scheme-associated-buffers))
|
||
(unwind-protect
|
||
(while buffers
|
||
(set-buffer (car buffers))
|
||
(setq scheme-mode-line-process runlight)
|
||
(setq buffers (cdr buffers)))
|
||
(set-buffer old-buffer))))
|
||
(force-mode-line-update t))
|
||
|
||
(defconst scheme-runlight:running "eval"
|
||
"The character displayed when the Scheme process is running.")
|
||
|
||
(defconst scheme-runlight:input "ready"
|
||
"The character displayed when the Scheme process is waiting for input.")
|
||
|
||
(defconst scheme-runlight:read "input"
|
||
"The character displayed when the Scheme process is waiting for input.")
|
||
|
||
(defconst scheme-runlight:load "loading"
|
||
"The character displayed when the Scheme process is loading forms.")
|
||
|
||
(defvar guile-last-output-end)
|
||
|
||
(setq count 0)
|
||
(defun scheme-enter-input-wait ()
|
||
(scheme-set-runlight scheme-runlight:input)
|
||
(setq scheme-running-p nil)
|
||
(setq scheme-ready-p t)
|
||
(setq count (1+ count))
|
||
;(insert-before-markers (format "#%d\n" count))
|
||
;(setq n (1+ n)
|
||
; l (append l (list (list n 'enter-input-wait))))
|
||
(if comint-allow-output-p
|
||
(progn
|
||
(set-marker guile-last-output-end (point))
|
||
(if (and guile-input-sent-p
|
||
;; This code can be invoked multiple times
|
||
(or (not (marker-position guile-last-prompt-end))
|
||
(/= (marker-position guile-last-prompt-end)
|
||
(point))))
|
||
(progn
|
||
(setq guile-input-sent-p nil)
|
||
(set-marker guile-last-prompt-end (point))))))
|
||
(setq comint-allow-output-p t)
|
||
(run-hooks 'scheme-enter-input-wait-hook))
|
||
|
||
(defun guile-on-error ()
|
||
(setq guile-input-sent-p t) ;*fixme*
|
||
(if comint-allow-output-p
|
||
(progn
|
||
(goto-char (point-max))
|
||
(if (not (zerop (current-column)))
|
||
(insert "\n"))
|
||
(set-marker (process-mark (get-buffer-process scheme-buffer))
|
||
(point)))))
|
||
|
||
(defun scheme-exit-input-wait ()
|
||
(scheme-set-runlight scheme-runlight:running)
|
||
(setq scheme-ready-p nil)
|
||
(setq scheme-running-p t))
|
||
|
||
(defun scheme-enter-read ()
|
||
(scheme-set-runlight scheme-runlight:read)
|
||
(setq scheme-ready-p nil)
|
||
(setq scheme-running-p nil))
|
||
|
||
(defun scheme-enter-load ()
|
||
(scheme-set-runlight scheme-runlight:load)
|
||
(setq scheme-ready-p nil)
|
||
(setq scheme-load-p t))
|
||
|
||
(defun scheme-load-acknowledge ()
|
||
(setq scheme-load-p nil))
|
||
|
||
;;; Error reporting and backtrace
|
||
;;;
|
||
(defvar guile-error-p nil)
|
||
|
||
(defvar guile-last-displayed-position nil)
|
||
|
||
(defvar guile-positional-reliability nil)
|
||
|
||
(defvar guile-last-erring-overlay nil)
|
||
|
||
(defvar guile-sexp-overlay nil)
|
||
|
||
(defvar guile-frame-overlay nil)
|
||
|
||
;(defconst guile-position-regexp
|
||
; " at line \\([0-9]+\\), column \\([0-9]+\\) in file \\(.+\\):$")
|
||
(defconst guile-position-regexp
|
||
"^\\(.+\\):\\([0-9]+\\):\\([0-9]+\\): ")
|
||
|
||
(defconst guile-position-regexp-line 2)
|
||
(defconst guile-position-regexp-column 3)
|
||
(defconst guile-position-regexp-filename 1)
|
||
|
||
(defvar guile-error-width 0)
|
||
(defvar guile-backtrace-length nil)
|
||
(defvar guile-backtrace-width 0)
|
||
|
||
(defvar guile-error-map nil)
|
||
(if guile-error-map
|
||
nil
|
||
(setq guile-error-map ;(copy-keymap global-map) copies menus too...
|
||
(cons 'keymap (copy-sequence (nth 1 global-map))))
|
||
(suppress-keymap guile-error-map)
|
||
(define-key guile-error-map "\e" 'guile-exit-debug)
|
||
(define-key guile-error-map "e" 'guile-frame-eval)
|
||
(define-key guile-error-map "q" 'guile-exit-debug)
|
||
;; The following line is included since `local-map' doesn't seem to work.
|
||
(define-key guile-error-map [mouse-2] 'guile-select-stackframe)
|
||
(define-key guile-error-map [S-mouse-2] 'guile-frame-eval-at-click)
|
||
)
|
||
|
||
(defvar guile-stack-frame-map nil)
|
||
(if guile-stack-frame-map
|
||
nil
|
||
(setq guile-stack-frame-map (copy-list guile-error-map))
|
||
(fset 'guile-stack-frame-map guile-stack-frame-map) ;*fixme*
|
||
(define-key guile-stack-frame-map [mouse-2] 'guile-select-stackframe)
|
||
)
|
||
|
||
(setplist 'guile-backtrace-button
|
||
(list 'mouse-face guile-backtrace-mouse-face
|
||
'local-map 'guile-stack-frame-map))
|
||
|
||
(defun guile-exit-debug ()
|
||
(interactive)
|
||
(if (eq (selected-frame) guile-error-frame)
|
||
(iconify-frame)
|
||
(if guile-sexp-overlay
|
||
(delete-overlay guile-sexp-overlay))
|
||
(delete-other-windows (frame-first-window)))
|
||
(guile-unselect-stackframe))
|
||
|
||
(setq guile-backtrace-received-p nil) ;*fixme*
|
||
|
||
(defun guile-receive-backtrace (buffer)
|
||
(let ((backtrace (get-buffer-create guile-backtrace-buffer-name)))
|
||
(save-excursion
|
||
(set-buffer backtrace)
|
||
(toggle-read-only 0)
|
||
(erase-buffer)
|
||
(insert-buffer-substring buffer)
|
||
(kill-buffer buffer)
|
||
(use-local-map guile-error-map)
|
||
(toggle-read-only 1)
|
||
(setq truncate-lines t)
|
||
(setq guile-backtrace-received-p t)))) ;*fixme*
|
||
|
||
(defun guile-prep-backtrace ()
|
||
(guile-unselect-stackframe)
|
||
(let ((buffer (get-buffer-create guile-backtrace-buffer-name)))
|
||
(and guile-got-backtrace-p ;*fixme*
|
||
(save-excursion
|
||
(set-buffer buffer)
|
||
(set-syntax-table scheme-mode-syntax-table)
|
||
(toggle-read-only 0)
|
||
(goto-char (point-max))
|
||
(delete-backward-char 1)
|
||
(goto-char (point-min))
|
||
;; Parse
|
||
(save-match-data
|
||
(if (not (looking-at "\\(.\\|\n\\)*Backtrace:\n"))
|
||
nil
|
||
(replace-match "")
|
||
(let ((beg (point))
|
||
(width 0)
|
||
(len 0))
|
||
(while (not (eobp))
|
||
(forward-line 1)
|
||
(let ((o (make-overlay beg (point)))) ;(1- (point))
|
||
(overlay-put o 'category 'guile-backtrace-button)
|
||
(overlay-put o 'frame-number-pos beg))
|
||
(setq width (- (point) beg 1))
|
||
(if (> width guile-backtrace-width)
|
||
(setq guile-backtrace-width width))
|
||
(setq beg (point))
|
||
(setq len (1+ len)))
|
||
(setq guile-backtrace-length len))))
|
||
(toggle-read-only 1)))
|
||
buffer))
|
||
|
||
(defvar guile-selected-frame nil)
|
||
|
||
(defun guile-select-stackframe (click)
|
||
(interactive "e")
|
||
(setq guile-no-stack-p nil)
|
||
(setq guile-no-source-p nil)
|
||
(let* ((frame (save-excursion
|
||
(mouse-set-point click)
|
||
(goto-char (get-char-property (point) 'frame-number-pos))
|
||
(guile-place-frame-overlay)
|
||
(let ((start (point)))
|
||
(skip-chars-forward " ")
|
||
(skip-chars-forward "0-9")
|
||
(if (= (char-after) ?:)
|
||
;; new backtrace format
|
||
(progn
|
||
(forward-char)
|
||
(skip-chars-forward " ")
|
||
(setq start (point))
|
||
(skip-chars-forward "0-9")))
|
||
(string-to-number (buffer-substring-no-properties start (point))))))
|
||
(oldpos (save-excursion
|
||
(set-buffer scheme-buffer)
|
||
(guile-eval `(%%emacs-select-frame ,frame))))
|
||
(pos (and oldpos (list (nth 0 oldpos)
|
||
(1+ (nth 1 oldpos)) ;Increment line number
|
||
(nth 2 oldpos)))))
|
||
(setq guile-selected-frame frame)
|
||
(cond (pos (if guile-source-window ;This is just insane *fixme*
|
||
(apply 'guile-display-scheme-sexp
|
||
(append pos (list guile-source-window t)))
|
||
(guile-display-error (get-buffer guile-error-buffer-name)
|
||
(get-buffer guile-backtrace-buffer-name)
|
||
pos)))
|
||
(guile-no-stack-p (message "No stack."))
|
||
(guile-no-source-p (message "No source.")))))
|
||
|
||
(defun guile-unselect-stackframe ()
|
||
(guile-turn-off-frame-overlay)
|
||
(setq guile-selected-frame nil))
|
||
|
||
(defun guile-frame-eval (string)
|
||
(interactive "sEval: ")
|
||
(if (not guile-selected-frame)
|
||
(message "No frame selected.")
|
||
(setq guile-no-stack-p nil)
|
||
(setq guile-no-source-p nil)
|
||
(let ((res (save-excursion
|
||
(set-buffer scheme-buffer)
|
||
(guile-eval `(%%emacs-frame-eval ,guile-selected-frame
|
||
,string)))))
|
||
(cond (guile-no-stack-p (message "No stack."))
|
||
(guile-no-source-p (message "No source."))
|
||
((eq (car res) 'result) (message "%s = %s" string (cadr res)))
|
||
(t (message "%s" (cadr res)))))))
|
||
|
||
(defun guile-frame-eval-at-click (click)
|
||
(interactive "e")
|
||
(save-excursion
|
||
(mouse-set-point click)
|
||
(forward-sexp)
|
||
(let ((end (point)))
|
||
(backward-sexp)
|
||
(guile-frame-eval (buffer-substring-no-properties (point) end)))))
|
||
|
||
(defun guile-receive-error (buffer)
|
||
(guile-on-error)
|
||
(setq guile-got-backtrace-p guile-backtrace-received-p)
|
||
(setq guile-backtrace-received-p nil) ;*fixme*
|
||
(setq guile-error-p t)
|
||
(let ((errbuf (get-buffer-create guile-error-buffer-name)))
|
||
(save-excursion
|
||
(set-buffer errbuf)
|
||
(toggle-read-only 0)
|
||
(erase-buffer)
|
||
(insert-buffer-substring buffer)
|
||
(kill-buffer buffer)
|
||
(use-local-map guile-error-map)
|
||
(toggle-read-only 1)
|
||
(setq guile-error-width 0)
|
||
(goto-char (point-min))
|
||
(let ((beg (point))
|
||
(width 0))
|
||
(while (not (eobp))
|
||
(forward-line 1)
|
||
(setq width (- (point) beg 1))
|
||
(if (> width guile-error-width)
|
||
(setq guile-error-width width))
|
||
(setq beg (point))))
|
||
(setq guile-backtrace-width guile-error-width)
|
||
(guile-display-error errbuf (guile-prep-backtrace)))))
|
||
|
||
(defvar guile-source-window nil)
|
||
|
||
(defun guile-display-error (errbuf backbuf &optional pos)
|
||
(set-buffer errbuf)
|
||
(setq guile-source-window nil)
|
||
(let* ((errbuf-len (progn
|
||
(goto-char (point-max))
|
||
(1- (guile-current-line))))
|
||
(selected-window (selected-window))
|
||
(mini-window nil)
|
||
(window
|
||
(if pos
|
||
(apply 'guile-display-scheme-sexp pos)
|
||
(and (progn
|
||
(goto-char (point-min))
|
||
(re-search-forward guile-position-regexp nil t))
|
||
(save-match-data
|
||
(guile-display-scheme-sexp
|
||
(car (read-from-string
|
||
(concat "\""
|
||
(match-string guile-position-regexp-filename)
|
||
"\"")))
|
||
(string-to-number (match-string guile-position-regexp-line))
|
||
(1- (string-to-number (match-string guile-position-regexp-column))))))))
|
||
(errbuf-lines
|
||
(min (+ errbuf-len
|
||
(* 2 (/ guile-error-width
|
||
(if window
|
||
(window-width window)
|
||
guile-backtrace-max-width))))
|
||
;;In case we get big error messages
|
||
(/ guile-backtrace-max-height 2)))
|
||
(total-height
|
||
(if guile-got-backtrace-p
|
||
(min (max (+ guile-backtrace-length errbuf-lines 2)
|
||
guile-backtrace-min-height)
|
||
guile-backtrace-max-height)
|
||
(+ errbuf-lines 1))))
|
||
(if (and window guile-backtrace-in-source-window)
|
||
(progn
|
||
(set-buffer errbuf) ;*fixme* This is awkward...
|
||
(or pos
|
||
(let ((inhibit-read-only t))
|
||
(replace-match "")
|
||
(re-search-forward guile-position-regexp nil t)
|
||
(replace-match "")))
|
||
(setq guile-source-window window) ;*fixme*
|
||
(and (frame-live-p guile-error-frame)
|
||
(make-frame-invisible guile-error-frame))
|
||
(let* ((window-min-height 2)
|
||
(size (max (- (window-height window) total-height)
|
||
(/ (window-height window) 2)))
|
||
(new-window (split-window window size)))
|
||
(set-buffer (window-buffer window))
|
||
(goto-char guile-last-displayed-position)
|
||
(guile-safe-forward-sexp)
|
||
(recenter (/ size 2))
|
||
(setq x errbuf-lines)
|
||
(guile-display-buffers errbuf (1+ errbuf-lines) backbuf new-window
|
||
pos)))
|
||
(setq guile-source-window nil)
|
||
(guile-display-buffers
|
||
errbuf (1+ errbuf-lines) backbuf
|
||
(setq mini-window
|
||
(guile-get-create-error-window
|
||
total-height
|
||
(+ (min (max guile-backtrace-width
|
||
guile-backtrace-min-width)
|
||
guile-backtrace-max-width)
|
||
2)))
|
||
pos))
|
||
(cond ((window-live-p selected-window)
|
||
(select-window selected-window))
|
||
((window-live-p window)
|
||
(select-window window))
|
||
((window-live-p mini-window)
|
||
(select-window mini-window)))
|
||
;; Warn if unreliable position
|
||
(if (and window (not guile-positional-reliability))
|
||
(message "Warning: Couldn't reliably locate erring expression."))
|
||
))
|
||
|
||
(defun guile-display-buffers (buffer1 split buffer2 window no-ding)
|
||
"Display BUFFER1 and BUFFER2 in WINDOW and raise the containing frame.
|
||
Display BUFFER1 and BUFFER2 in two windows obtained by splitting WINDOW
|
||
and ring the bell. Make sure that the whole contents of BUFFER1 and the
|
||
lower part of BUFFER2 will be visible. Also delete all other windows
|
||
displaying the buffers."
|
||
;; Delete other windows displaying the buffers
|
||
(or (not window-system) (delete-windows-on buffer1)) ; *fixme*
|
||
(delete-windows-on buffer2)
|
||
;; Split the window
|
||
(let ((lower-window
|
||
(and guile-got-backtrace-p
|
||
(let ((window-min-height 2) ;; Parameter to split-window
|
||
)
|
||
(split-window window split)))))
|
||
;; Contents
|
||
(set-window-buffer window buffer1)
|
||
(and guile-got-backtrace-p
|
||
(set-window-buffer lower-window buffer2))
|
||
;; Look
|
||
(set-window-start window 1)
|
||
(if guile-got-backtrace-p
|
||
(progn
|
||
(let ((pos (save-excursion
|
||
(set-buffer buffer2)
|
||
(goto-char (point-max))
|
||
(forward-line -1)
|
||
(point))))
|
||
(set-window-point lower-window pos))
|
||
(select-window lower-window)
|
||
(recenter -1)))
|
||
;; Raise frame
|
||
(make-frame-visible (window-frame window))
|
||
(raise-frame (window-frame window))
|
||
;; Beep
|
||
(or no-ding (ding))
|
||
))
|
||
|
||
(defvar guile-error-frame nil)
|
||
|
||
(defun guile-get-create-error-window (height width)
|
||
(if window-system
|
||
(progn
|
||
(if (frame-live-p guile-error-frame)
|
||
(set-frame-size guile-error-frame width height)
|
||
(setq guile-error-frame (make-frame (list (cons 'height height)
|
||
(cons 'width width)
|
||
'(minibuffer . nil)
|
||
'(menu-bar-lines . 0)))))
|
||
(let ((window (frame-first-window guile-error-frame)))
|
||
(delete-other-windows window)
|
||
window))
|
||
(let ((window (get-buffer-window (pop-to-buffer guile-error-buffer-name))))
|
||
(sit-for 0) ; necessary because of an Emacs bug
|
||
window)))
|
||
|
||
(defun guile-display-scheme-sexp (filename line column &optional swindow no-error-p)
|
||
(let ((finfo (scheme-virtual-file-list-find filename)))
|
||
(if finfo
|
||
(guile-display-sexp finfo line column swindow no-error-p)
|
||
(if (stringp filename)
|
||
(let ((buffer (guile-get-file-buffer filename)))
|
||
(if buffer
|
||
(if (and (guile-attachedp buffer)
|
||
(not guile-known-by-scheme))
|
||
(progn
|
||
;(ding) ; We shouldn't generate errors inside a filter.
|
||
;(message "Internal data structures corrupt: guile-display-scheme-sexp")
|
||
(error "Internal data structures corrupt: guile-display-scheme-sexp"))
|
||
(if (and (not scheme-buffer-modified-p)
|
||
(not (buffer-modified-p buffer)))
|
||
;; Take a chance and let's hope the file looks
|
||
;; like it did when scheme saw it...
|
||
(progn
|
||
(if guile-auto-attach
|
||
(guile-attach-buffer buffer t)
|
||
;*fixme*
|
||
(guile-dont-attach-buffer buffer t))
|
||
(guile-display-scheme-sexp
|
||
(guile-buffer-file-name buffer) line column swindow no-error-p))
|
||
nil ; Can't trust this one...
|
||
))
|
||
(if (guile-file-readable-p filename)
|
||
(let ((guile-known-by-scheme t))
|
||
(let ((buffer (guile-find-file-noselect filename)))
|
||
(if guile-auto-attach
|
||
(guile-attach-buffer buffer t)
|
||
;*fixme*
|
||
(guile-dont-attach-buffer buffer t))
|
||
(guile-display-scheme-sexp
|
||
(guile-buffer-file-name buffer)
|
||
line column swindow no-error-p)))
|
||
(ding)
|
||
(message "Couldn't find the erring file.")
|
||
nil)))))))
|
||
|
||
(defun guile-file-readable-p (filename)
|
||
(save-excursion
|
||
(set-buffer scheme-buffer)
|
||
(file-readable-p filename)))
|
||
|
||
(defun guile-find-file-noselect (filename)
|
||
(save-excursion
|
||
(set-buffer scheme-buffer)
|
||
(find-file-noselect filename)))
|
||
|
||
(defun guile-display-sexp (finfo line column &optional swindow no-error-p)
|
||
;; Returns the window containing the displayed sexp
|
||
(let ((overlay-list (cdr finfo))
|
||
(overlay nil))
|
||
;; Select an overlay candidate
|
||
(while overlay-list
|
||
(if (not (overlay-get (car overlay-list) 'original-line))
|
||
(setq overlay-list (cdr overlay-list))
|
||
(if (>= line (overlay-get (car overlay-list) 'original-line))
|
||
(progn
|
||
(setq overlay (car overlay-list))
|
||
(setq overlay-list nil))
|
||
(setq overlay-list (cdr overlay-list)))))
|
||
(let ((buffer (and overlay (overlay-buffer overlay))))
|
||
(if buffer
|
||
(progn
|
||
(set-buffer buffer)
|
||
(guile-goto-position line column overlay)
|
||
(if (< (point) (overlay-end overlay))
|
||
(progn
|
||
(setq guile-positional-reliability
|
||
(not (overlay-get overlay 'modifiedp)))
|
||
(if (not (eq (char-syntax (following-char)) ?\())
|
||
(progn
|
||
(setq guile-positional-reliability nil)
|
||
(goto-char (overlay-start overlay))))
|
||
(setq guile-last-erring-overlay overlay)
|
||
(guile-display-sexp-at-point swindow no-error-p))))))))
|
||
|
||
(defun guile-display-sexp-at-point (&optional swindow no-error-p)
|
||
"Move sexp overlay to sexp at point and display window.
|
||
Returns the displayed window."
|
||
(let ((start (point))
|
||
(end nil))
|
||
(save-excursion
|
||
(setq end
|
||
(if (guile-safe-forward-sexp)
|
||
(point)
|
||
(goto-char (1+ start))
|
||
(if (re-search-forward "^\\((\\|$\\)" nil t)
|
||
(1- (match-beginning 0))
|
||
(point-max)))))
|
||
(if (overlayp guile-sexp-overlay)
|
||
(move-overlay guile-sexp-overlay start end (current-buffer))
|
||
(setq guile-sexp-overlay (make-overlay start end))
|
||
(overlay-put guile-sexp-overlay 'category 'guile-error-sexp))
|
||
(if (window-live-p swindow)
|
||
(set-window-buffer swindow (current-buffer)))
|
||
(guile-display-position start nil swindow no-error-p)))
|
||
|
||
(setplist 'guile-error-sexp
|
||
(list 'face guile-error-face
|
||
'evaporate t
|
||
'modification-hooks '(guile-turn-off-sexp-overlay)
|
||
'insert-behind-hooks '(guile-turn-off-sexp-overlay)))
|
||
|
||
(setplist 'guile-stack-frame
|
||
(list 'face guile-error-face
|
||
'mouse-face guile-error-face
|
||
'evaporate t
|
||
'modification-hooks '(guile-turn-off-frame-overlay)
|
||
'insert-behind-hooks '(guile-turn-off-frame-overlay)))
|
||
|
||
(defun guile-place-frame-overlay ()
|
||
(let ((end (save-excursion (forward-line) (point))))
|
||
(if (and guile-frame-overlay (overlayp guile-frame-overlay))
|
||
(move-overlay guile-frame-overlay (point) end)
|
||
(setq guile-frame-overlay (make-overlay (point) end)))
|
||
(overlay-put guile-frame-overlay 'category 'guile-stack-frame)))
|
||
|
||
(defun guile-turn-off-sexp-overlay (&rest args)
|
||
(cond (guile-sexp-overlay (delete-overlay guile-sexp-overlay))
|
||
;; For stability.
|
||
((overlayp (car args)) (delete-overlay (car args)))))
|
||
|
||
(defun guile-turn-off-frame-overlay (&rest args)
|
||
(cond (guile-frame-overlay (delete-overlay guile-frame-overlay))
|
||
;; For stability.
|
||
((overlayp (car args)) (delete-overlay (car args)))))
|
||
|
||
(defun guile-display-position (pos &optional buffer swindow no-delete-p)
|
||
"Display position POS in BUFFER.
|
||
If BUFFER is omitted, the current buffer is used.
|
||
Returns the displaying window."
|
||
(let ((buffer (or buffer (current-buffer))))
|
||
(set-buffer buffer)
|
||
(let ((window (or (and (window-live-p swindow) swindow)
|
||
(get-buffer-window buffer t)
|
||
(if (frame-live-p guile-error-frame)
|
||
(delete-frame guile-error-frame))
|
||
(display-buffer buffer))))
|
||
(or no-delete-p
|
||
(delete-other-windows window))
|
||
(select-window window)
|
||
(goto-char pos)
|
||
(setq guile-last-displayed-position pos)
|
||
window)))
|
||
|
||
(defun guile-goto-position (line column overlay)
|
||
(goto-char (overlay-start overlay))
|
||
(forward-line (- line (overlay-get overlay 'original-line)))
|
||
(move-to-column column))
|
||
|
||
|
||
;;; Scheme process associated buffers
|
||
;;;
|
||
|
||
;; This function must be fixed to handle rel/absol filenames
|
||
(defun guile-get-file-buffer (filename)
|
||
(get-file-buffer filename))
|
||
|
||
(defun guile-attachedp (&optional buffer)
|
||
(if buffer
|
||
(save-excursion
|
||
(set-buffer buffer)
|
||
scheme-associated-process-buffer)
|
||
scheme-associated-process-buffer))
|
||
|
||
(defun guile-attach-buffer (buffer &optional known-by-scheme)
|
||
"Put the buffer in enhanced editing mode and attach it to the scheme
|
||
process: load it into scheme, and make sure to send any changes to it
|
||
hereafter to scheme at synchronization points."
|
||
(interactive (list (current-buffer)))
|
||
(if (memq buffer inferior-scheme-associated-buffers)
|
||
(error "Scheme buffer already attached!"))
|
||
(if (not (guile-enhancedp buffer))
|
||
(guile-enhanced-edit buffer known-by-scheme))
|
||
(save-excursion
|
||
(set-buffer scheme-buffer)
|
||
(setq inferior-scheme-associated-buffers
|
||
(cons buffer
|
||
inferior-scheme-associated-buffers))
|
||
(set-buffer buffer)
|
||
(setq scheme-associated-process-buffer scheme-buffer)
|
||
(if (not guile-show-runlight-in-scheme-mode)
|
||
(setq scheme-mode-line-process "attached"))
|
||
;; Now link it to the scheme process
|
||
(if (and (guile-buffer-file-name)
|
||
(not (guile-virtually-linked-p (guile-buffer-file-name))))
|
||
(guile-virtual-link (guile-buffer-file-name) scheme-buffer-overlays))
|
||
;; And sync.
|
||
(if (not known-by-scheme)
|
||
(progn
|
||
(for-each (function (lambda (overlay)
|
||
(overlay-put overlay 'modifiedp t)))
|
||
scheme-buffer-overlays)
|
||
(setq scheme-buffer-modified-p t)
|
||
(setq guile-synchronizedp nil)
|
||
(guile-sync-with-scheme))))
|
||
;; Rebuild menus...
|
||
(force-mode-line-update))
|
||
|
||
;;*fixme*
|
||
(defun guile-dont-attach-buffer (buffer &optional known-by-scheme)
|
||
"Put the buffer in enhanced editing mode and attach it to the scheme
|
||
process: load it into scheme, and make sure to send any changes to it
|
||
hereafter to scheme at synchronization points."
|
||
(interactive (list (current-buffer)))
|
||
(if (memq buffer inferior-scheme-associated-buffers)
|
||
(error "Scheme buffer already attached!"))
|
||
(if (not (guile-enhancedp buffer))
|
||
(guile-enhanced-edit buffer known-by-scheme))
|
||
(save-excursion
|
||
; (set-buffer scheme-buffer)
|
||
; (setq inferior-scheme-associated-buffers
|
||
; (cons buffer
|
||
; inferior-scheme-associated-buffers))
|
||
(set-buffer buffer)
|
||
; (setq scheme-associated-process-buffer scheme-buffer) == attach
|
||
; (if (not guile-show-runlight-in-scheme-mode)
|
||
; (setq scheme-mode-line-process "attached"))
|
||
;; Now link it to the scheme process
|
||
(if (guile-buffer-file-name)
|
||
(guile-virtual-link (guile-buffer-file-name) scheme-buffer-overlays))
|
||
;; And sync.
|
||
(if (not known-by-scheme)
|
||
(progn
|
||
(for-each (function (lambda (overlay)
|
||
(overlay-put overlay 'modifiedp t)))
|
||
scheme-buffer-overlays)
|
||
(setq scheme-buffer-modified-p t)
|
||
(setq guile-synchronizedp nil)
|
||
;(guile-sync-with-scheme)
|
||
)))
|
||
;; Rebuild menus...
|
||
(force-mode-line-update))
|
||
|
||
(defun guile-detach-buffer (buffer)
|
||
"Disconnect the buffer from the scheme process."
|
||
(interactive (list (current-buffer)))
|
||
(save-excursion
|
||
(set-buffer buffer)
|
||
;; Unlink any virtual overlay files associated with the buffer...
|
||
;(let ((overlays scheme-buffer-overlays))
|
||
; (while overlays
|
||
; (if (guile-virtual-p (car overlays))
|
||
; (scheme-virtual-unlink (overlay-get (car overlays) 'id)))
|
||
; (setq overlays (cdr overlays))))
|
||
(setq scheme-associated-process-buffer nil)
|
||
(if (not guile-show-runlight-in-scheme-mode)
|
||
(setq scheme-mode-line-process nil))
|
||
(set-buffer scheme-buffer)
|
||
(setq inferior-scheme-associated-buffers
|
||
(delq buffer
|
||
inferior-scheme-associated-buffers))
|
||
;(scheme-virtual-unlink (guile-buffer-file-name buffer))
|
||
)
|
||
(force-mode-line-update))
|
||
|
||
(defun guile-detach-all ()
|
||
"Disconnect all buffers from the scheme process."
|
||
(interactive)
|
||
(save-excursion
|
||
(set-buffer scheme-buffer)
|
||
(while inferior-scheme-associated-buffers
|
||
;; Is it alive?
|
||
(if (buffer-name (car inferior-scheme-associated-buffers))
|
||
(save-excursion
|
||
(set-buffer (car inferior-scheme-associated-buffers))
|
||
(setq scheme-associated-process-buffer nil)
|
||
(if (not guile-show-runlight-in-scheme-mode)
|
||
(setq scheme-mode-line-process nil))))
|
||
(setq inferior-scheme-associated-buffers
|
||
(cdr inferior-scheme-associated-buffers)))))
|
||
|
||
;;; Linkage of files to scheme space
|
||
;;;
|
||
(defvar scheme-virtual-file-list '())
|
||
|
||
(defun scheme-virtual-file-list-find (name)
|
||
(let ((name (file-truename name)))
|
||
(assoc name scheme-virtual-file-list)))
|
||
|
||
(defun guile-buffer-file-name (&optional buffer)
|
||
(let ((name (buffer-file-name buffer)))
|
||
(and name
|
||
(file-truename name))))
|
||
|
||
(defvar guile-synchronizedp t)
|
||
|
||
(defvar guile-last-virtual-id 0)
|
||
|
||
(defun guile-synchronizedp ()
|
||
guile-synchronizedp)
|
||
|
||
;;*fixme*
|
||
(defun guile-alloc-virtual-id (overlay)
|
||
(let ((n (setq guile-last-virtual-id (1+ guile-last-virtual-id))))
|
||
(let* ((buffer (overlay-buffer overlay))
|
||
(name (or (guile-buffer-file-name buffer)
|
||
(buffer-name buffer))))
|
||
(format "%s(%d)" name n))))
|
||
|
||
(defun guile-virtual-p (overlay)
|
||
(overlay-get overlay 'virtualp))
|
||
|
||
(defun guile-virtually-linked-p (name)
|
||
(scheme-virtual-file-list-find name))
|
||
|
||
(defun guile-virtual-link (name overlay-list)
|
||
(let ((finfo (scheme-virtual-file-list-find name)))
|
||
(if finfo
|
||
(progn
|
||
(guile-kill-overlays (cdr finfo))
|
||
(setcdr finfo (copy-sequence overlay-list)))
|
||
(setq scheme-virtual-file-list
|
||
(cons (cons name
|
||
(copy-sequence overlay-list))
|
||
scheme-virtual-file-list)))))
|
||
|
||
(defun scheme-virtual-unlink (name)
|
||
(let ((finfo (scheme-virtual-file-list-find name)))
|
||
(if finfo
|
||
(setq scheme-virtual-file-list
|
||
(delq finfo scheme-virtual-file-list)))))
|
||
|
||
(defun guile-load-file (filename)
|
||
"Load a Scheme file into the inferior Scheme process."
|
||
(interactive (comint-get-source "Load Scheme file: " scheme-prev-l/c-dir/file
|
||
scheme-source-modes t)) ; T because LOAD
|
||
; needs an exact name
|
||
(if (not scheme-ready-p)
|
||
(error "Scheme not ready."))
|
||
(comint-check-source filename) ; Check to see if buffer needs to be saved.
|
||
(setq scheme-prev-l/c-dir/file (cons (file-name-directory filename)
|
||
(file-name-nondirectory filename)))
|
||
(let ((old-buffer (current-buffer)))
|
||
(set-buffer scheme-buffer)
|
||
(setq comint-allow-output-p nil)
|
||
(setq guile-unallowed-output nil)
|
||
(set-buffer old-buffer))
|
||
(scheme-set-runlight scheme-runlight:load)
|
||
(setq scheme-ready-p nil)
|
||
(comint-send-string (scheme-proc) (concat "(load \""
|
||
filename
|
||
"\"\)\n"))
|
||
;; Syncronize...
|
||
(while (not scheme-ready-p)
|
||
(accept-process-output (scheme-proc) 0 guile-process-timeout))
|
||
)
|
||
|
||
(defun guile-reread-buffer (buffer)
|
||
"Make the scheme interpreter read the buffer contents again."
|
||
(interactive (list (current-buffer)))
|
||
(if (not scheme-ready-p)
|
||
(error "Scheme not ready."))
|
||
(save-excursion
|
||
(set-buffer buffer)
|
||
(for-each (function (lambda (overlay)
|
||
(overlay-put overlay 'modifiedp t)))
|
||
scheme-buffer-overlays)
|
||
(setq scheme-buffer-modified-p t))
|
||
(setq guile-synchronizedp nil)
|
||
(guile-sync-with-scheme))
|
||
|
||
(defun guile-get-associated-buffers ()
|
||
(save-excursion
|
||
(set-buffer scheme-buffer)
|
||
inferior-scheme-associated-buffers))
|
||
|
||
(defvar guile-symclash-obarray (make-vector guile-symclash-obarray-size 0))
|
||
|
||
(defun guile-reset-symclash-obarray ()
|
||
(mapatoms (function makunbound) guile-symclash-obarray))
|
||
|
||
(defvar guile-displayed-erring-buffers nil)
|
||
(defvar guile-quiet t)
|
||
|
||
(defun guile-check-all ()
|
||
(interactive)
|
||
(setq guile-quiet t)
|
||
(guile-check-all-1))
|
||
|
||
(defun guile-check-all-1 ()
|
||
(guile-show-check-error
|
||
(catch 'erroneous-overlay
|
||
(guile-reset-symclash-obarray)
|
||
(if (not (and guile-last-displayed-erring-overlay
|
||
(eq (overlay-buffer guile-last-displayed-erring-overlay)
|
||
(current-buffer))))
|
||
(progn
|
||
(setq guile-last-displayed-erring-overlay nil)
|
||
(setq guile-displayed-erring-buffers nil)))
|
||
(for-each (function (lambda (buffer)
|
||
(guile-check-buffer-1 buffer)
|
||
(setq guile-displayed-erring-buffers
|
||
(cons buffer
|
||
guile-displayed-erring-buffers))))
|
||
(let ((ls (guile-get-enhanced-buffers))
|
||
(rem guile-displayed-erring-buffers))
|
||
(while rem
|
||
(setq ls (delq (car rem) ls))
|
||
(setq rem (cdr rem)))
|
||
ls))
|
||
nil)))
|
||
|
||
(defun guile-check-buffer (buffer)
|
||
(interactive (list (current-buffer)))
|
||
(guile-show-check-error
|
||
(catch 'erroneous-overlay
|
||
(save-excursion
|
||
(guile-reset-symclash-obarray)
|
||
(guile-check-buffer-1 buffer)
|
||
;(set-buffer old-buffer)
|
||
nil))))
|
||
|
||
(defun guile-show-check-error (oinfo)
|
||
(if (not oinfo)
|
||
(progn
|
||
(if guile-last-displayed-erring-overlay
|
||
(message "No more errors found among buffers in enhanced editing mode!")
|
||
(message "No errors found among buffers in enhanced editing mode!"))
|
||
(setq guile-last-displayed-erring-overlay nil)
|
||
(setq guile-displayed-erring-buffers nil)
|
||
t)
|
||
(setq guile-last-displayed-erring-overlay (car oinfo))
|
||
(set-buffer (overlay-buffer (car oinfo)))
|
||
(goto-char (overlay-start (car oinfo)))
|
||
(if (not guile-quiet)
|
||
(ding))
|
||
(guile-display-sexp-at-point)
|
||
(recenter)
|
||
(message "%s" (cdr oinfo))
|
||
nil))
|
||
|
||
(defvar guile-last-displayed-erring-overlay nil)
|
||
|
||
(defun guile-check-buffer-1 (buffer)
|
||
(set-buffer buffer)
|
||
(save-excursion
|
||
(for-each (function guile-check-overlay)
|
||
(let* ((ls (reverse scheme-buffer-overlays))
|
||
(tail (memq guile-last-displayed-erring-overlay ls)))
|
||
(if tail
|
||
(cdr tail)
|
||
ls)))))
|
||
|
||
(defconst guile-defexpr "(\\(define\\|defmacro\\)[^ \t\n()]*[ \t\n]+(*\\([^ \t\n()]+\\)")
|
||
(defconst guile-defexpr-name 2)
|
||
|
||
(defun guile-check-overlay (overlay)
|
||
(if (overlay-get overlay 'brokenp)
|
||
(throw 'erroneous-overlay
|
||
(cons overlay "Bad expression."))
|
||
(goto-char (overlay-start overlay))
|
||
(if (looking-at guile-defexpr)
|
||
(let ((sym (intern (match-string guile-defexpr-name)
|
||
guile-symclash-obarray)))
|
||
(if (boundp sym)
|
||
(let* ((overlay1 (symbol-value sym))
|
||
(buffer (overlay-buffer overlay1))
|
||
(line (save-excursion
|
||
(set-buffer buffer)
|
||
(save-excursion
|
||
(goto-char (overlay-start overlay1))
|
||
(guile-current-line)))))
|
||
(throw 'erroneous-overlay
|
||
(cons overlay
|
||
(format "Symbol \"%s\" already defined in %s, line %d."
|
||
sym
|
||
(file-name-nondirectory
|
||
(or (guile-buffer-file-name buffer)
|
||
(buffer-name buffer)))
|
||
line))))
|
||
(set sym overlay))))))
|
||
|
||
(defun guile-sync-with-scheme ()
|
||
(interactive)
|
||
(if (and (not guile-synchronizedp)
|
||
scheme-ready-p)
|
||
(progn
|
||
(setq guile-error-p nil)
|
||
(setq guile-last-erring-overlay nil)
|
||
(catch 'exit
|
||
(for-each (function guile-sync-buffer-1)
|
||
(guile-get-associated-buffers))
|
||
(setq guile-synchronizedp t))
|
||
(if guile-last-erring-overlay
|
||
(progn
|
||
(overlay-put guile-last-erring-overlay 'brokenp t)
|
||
(overlay-put guile-last-erring-overlay
|
||
'face guile-broken-face)
|
||
(if guile-show-overlays-p
|
||
(save-excursion
|
||
(set-buffer (overlay-buffer guile-last-erring-overlay))
|
||
(guile-show-overlays))))))))
|
||
|
||
(defun guile-sync-buffer (buffer)
|
||
(interactive (list (current-buffer)))
|
||
(catch 'exit
|
||
(guile-sync-buffer-1 buffer)))
|
||
|
||
(defun guile-sync-buffer-1 (buffer)
|
||
(save-excursion
|
||
(set-buffer buffer)
|
||
(if scheme-buffer-modified-p
|
||
(progn
|
||
;; Can we do it by loading the file again?
|
||
(if (and (not (buffer-modified-p buffer))
|
||
(file-readable-p (guile-buffer-file-name))
|
||
(not (let ((overlays scheme-buffer-overlays))
|
||
(while (and overlays
|
||
(not (overlay-get (car overlays) 'brokenp)))
|
||
(goto-char (overlay-start (car overlays)))
|
||
(overlay-put (car overlays) 'original-line
|
||
(guile-current-line)) ; non-optimal *fixme*
|
||
(setq overlays (cdr overlays)))
|
||
overlays)))
|
||
(progn
|
||
(guile-load-file (guile-buffer-file-name))
|
||
(if guile-error-p
|
||
(progn
|
||
(throw 'exit nil)))
|
||
(let ((overlays scheme-buffer-overlays))
|
||
(while overlays
|
||
(overlay-put (car overlays) 'modifiedp nil)
|
||
(setq overlays (cdr overlays)))))
|
||
;; No - we have to send the overlays separately from top to bottom
|
||
(let ((overlays (reverse scheme-buffer-overlays)))
|
||
(if (or (= (point-min) (point-max))
|
||
(not (eq (char-syntax (char-after (point-min))) ?\()))
|
||
(setq overlays (cdr overlays)))
|
||
(while overlays
|
||
(if (and (overlay-get (car overlays) 'modifiedp)
|
||
(not (overlay-get (car overlays) 'brokenp)))
|
||
(progn
|
||
(guile-send-overlay (guile-alloc-finfo (car overlays)))
|
||
(if guile-error-p (throw 'exit nil))))
|
||
(setq overlays (cdr overlays)))))
|
||
(setq scheme-buffer-modified-p nil)))
|
||
(if guile-show-overlays-p
|
||
(guile-show-overlays))))
|
||
|
||
(defun guile-alloc-finfo (overlay)
|
||
(if (not (overlay-get overlay 'id))
|
||
(progn
|
||
(let ((finfo (scheme-virtual-file-list-find (guile-buffer-file-name))))
|
||
(if finfo
|
||
(setcdr finfo (delq overlay (cdr finfo)))))
|
||
(guile-new-finfo overlay))
|
||
(let ((finfo (assq (overlay-get overlay 'id)
|
||
scheme-virtual-file-list)))
|
||
(if finfo
|
||
(let ((id (guile-alloc-virtual-id overlay)))
|
||
(setcar finfo id)
|
||
(overlay-put overlay 'id id)
|
||
(overlay-put overlay 'virtualp t)
|
||
finfo)
|
||
(guile-new-finfo overlay)))))
|
||
|
||
(defun guile-new-finfo (overlay)
|
||
(let* ((id (guile-alloc-virtual-id overlay))
|
||
(finfo (cons id (list overlay))))
|
||
(overlay-put overlay 'id id)
|
||
(overlay-put overlay 'virtualp t)
|
||
(goto-char (overlay-start overlay))
|
||
(overlay-put overlay 'original-line (guile-current-line))
|
||
(setq scheme-virtual-file-list
|
||
(cons finfo scheme-virtual-file-list))
|
||
finfo))
|
||
|
||
(defvar guile-last-prompt-end nil)
|
||
(defvar guile-input-sent-p t)
|
||
|
||
(defun guile-send-input ()
|
||
(interactive)
|
||
(if (and (marker-position guile-last-prompt-end)
|
||
scheme-ready-p)
|
||
(let ((start (save-excursion
|
||
(goto-char (point-max))
|
||
(and (guile-real-safe-backward-sexp)
|
||
(point)))))
|
||
(if (not (and start
|
||
(<= (marker-position guile-last-prompt-end) start)
|
||
(guile-whitespace-between-p guile-last-prompt-end
|
||
start)))
|
||
(progn
|
||
(insert "\n")
|
||
(put-text-property (1- (point)) (point) 'face 'bold))
|
||
(goto-char (point-max))
|
||
(comint-send-input)
|
||
(setq guile-input-sent-p t)))
|
||
(comint-send-input)))
|
||
|
||
(defconst guile-whitespace-chars " \t\n\r\f")
|
||
|
||
(defun guile-whitespace-between-p (beg end)
|
||
(let ((beg (if (markerp beg) (marker-position beg) beg))
|
||
(end (if (markerp end) (marker-position end) end)))
|
||
(if (> beg end)
|
||
(let ((swap beg))
|
||
(setq beg end end swap)))
|
||
(save-excursion
|
||
(goto-char beg)
|
||
(skip-chars-forward guile-whitespace-chars end)
|
||
(= (point) end))))
|
||
|
||
;;*fixme* This is redundant code. Compare sync.
|
||
(defun guile-send-changes ()
|
||
(interactive)
|
||
(setq guile-last-displayed-erring-overlay nil)
|
||
(setq guile-displayed-erring-buffers nil)
|
||
(setq guile-quiet nil)
|
||
(if (guile-check-all-1)
|
||
(progn
|
||
(setq guile-error-p nil)
|
||
(catch 'exit
|
||
(let ((old-buffer (current-buffer)))
|
||
(for-each (function
|
||
(lambda (buffer)
|
||
(set-buffer buffer)
|
||
(save-excursion
|
||
(goto-char (point-max))
|
||
(let ((end (point)))
|
||
(beginning-of-buffer)
|
||
(guile-send-region (point) end nil t)))
|
||
(if guile-show-overlays-p
|
||
(guile-show-overlays))))
|
||
(guile-get-enhanced-buffers))
|
||
(set-buffer old-buffer))))))
|
||
|
||
(defun scheme-send-region (start end)
|
||
"Send the current region to the inferior Scheme process."
|
||
(interactive "r")
|
||
(if (not (guile-enhancedp (current-buffer)))
|
||
(progn
|
||
(comint-send-region (scheme-proc) start end)
|
||
(comint-send-string (scheme-proc) "\n"))
|
||
(setq guile-error-p nil)
|
||
(catch 'exit
|
||
(guile-send-region start end t)
|
||
(cond (guile-define-header-emitted-p
|
||
(message "Defined."))
|
||
(guile-last-result
|
||
(guile-insert-before-prompt
|
||
(concat "RESULT: " guile-last-result "\n"))
|
||
(message "%s" (concat "Result: " guile-last-result)))))
|
||
(if guile-show-overlays-p
|
||
(guile-show-overlays))))
|
||
|
||
(defvar guile-define-name-marker)
|
||
|
||
(defun guile-insert-before-prompt (string)
|
||
(save-excursion
|
||
(set-buffer scheme-buffer)
|
||
(save-excursion
|
||
(goto-char guile-last-prompt-end)
|
||
(forward-line 0) ;; ignore field boundary
|
||
(let ((inhibit-read-only t)
|
||
(before-prompt (point))
|
||
(w (or (get-buffer-window scheme-buffer 'visible)
|
||
(get-buffer-window scheme-buffer t))))
|
||
(let ((w-start (and w (window-start w))))
|
||
(insert-before-markers string)
|
||
(if (and w (= before-prompt w-start))
|
||
(let ((selected (selected-window)))
|
||
(unwind-protect
|
||
(progn
|
||
(select-window w)
|
||
(recenter))
|
||
(select-window selected)
|
||
(set-buffer scheme-buffer)))))))))
|
||
|
||
(defvar guile-define-header-emitted-p nil)
|
||
(defvar guile-define-startcol 0)
|
||
(defvar guile-define-filler "")
|
||
(defvar guile-define-fillcol 0)
|
||
(defvar guile-last-result nil)
|
||
|
||
(defun guile-send-region (start end send-all-p &optional multip)
|
||
(if (not scheme-ready-p)
|
||
(error "Scheme is not ready to receive expressions from Emacs."))
|
||
(let ((overlays (reverse scheme-buffer-overlays)))
|
||
(if (or (= (point-min) (point-max))
|
||
(not (eq (char-syntax (char-after (point-min))) ?\()))
|
||
(setq overlays (cdr overlays)))
|
||
;; First skip some overlays
|
||
(while (and overlays (<= (overlay-end (car overlays)) start))
|
||
(setq overlays (cdr overlays)))
|
||
(setq guile-define-header-emitted-p nil)
|
||
(setq guile-last-result nil)
|
||
(let ((start (max start (overlay-start (car overlays)))))
|
||
(if (/= start (overlay-start (car overlays)))
|
||
(guile-send-overlay (save-excursion
|
||
(guile-alloc-finfo (car overlays)))
|
||
t
|
||
multip
|
||
start
|
||
end)
|
||
(while (and overlays
|
||
(< (overlay-start (car overlays)) end))
|
||
(if (and (not (overlay-get (car overlays) 'brokenp))
|
||
(or send-all-p
|
||
(overlay-get (car overlays) 'modifiedp)))
|
||
(guile-send-overlay (save-excursion
|
||
(guile-alloc-finfo (car overlays)))
|
||
t
|
||
multip))
|
||
(setq overlays (cdr overlays)))))))
|
||
|
||
(defconst guile-end-of-chunk "\001\n")
|
||
|
||
;; *fixme* Improve code.
|
||
(defun guile-send-overlay (finfo &optional interactivep multip start end)
|
||
(let* ((filename (car finfo))
|
||
(overlay (car (cdr finfo)))
|
||
(module-overlay (overlay-get overlay 'module-overlay))
|
||
(module (or (and module-overlay
|
||
(overlay-get module-overlay 'define-module))
|
||
"#f"))
|
||
(old-buffer (current-buffer))
|
||
(old-pos (point)))
|
||
|
||
;; Define the module of the overlay if not done before
|
||
(if (and module-overlay
|
||
(overlay-get module-overlay 'modifiedp))
|
||
(guile-send-overlay (save-excursion
|
||
(guile-alloc-finfo module-overlay))))
|
||
|
||
(set-buffer scheme-buffer)
|
||
;; Inhibit process output and hamster it
|
||
(setq comint-allow-output-p nil)
|
||
(setq guile-eval-output nil)
|
||
(setq guile-unallowed-output "")
|
||
|
||
(set-buffer old-buffer)
|
||
;; Turn on runlight
|
||
(scheme-enter-load)
|
||
;; Send load command
|
||
(comint-send-string
|
||
(scheme-proc)
|
||
(if start
|
||
(let ((column (save-excursion
|
||
(goto-char start)
|
||
(current-column))))
|
||
(format "(%%%%emacs-load %S %d %d '%s #%c)\n"
|
||
filename
|
||
(+ (overlay-get overlay 'original-line)
|
||
-1
|
||
(count-lines (overlay-get overlay 'original-line)
|
||
start)
|
||
(if (zerop column) 0 -1))
|
||
column
|
||
module
|
||
(if interactivep ?t ?f)))
|
||
(format "(%%%%emacs-load %S %d %d '%s #%c)\n"
|
||
filename
|
||
(1- (overlay-get overlay 'original-line))
|
||
0
|
||
module
|
||
(if interactivep ?t ?f))))
|
||
;; Send overlay contents
|
||
(comint-send-string
|
||
(scheme-proc)
|
||
(buffer-substring-no-properties (or start (overlay-start overlay))
|
||
(or end (overlay-end overlay))))
|
||
;; If this is the last overlay we may have to send a final newline
|
||
;;(if (and (eq overlay scheme-buffer-last-overlay)
|
||
;; (/= (overlay-start overlay)
|
||
;; (overlay-end overlay))
|
||
;; (not (eq (char-after (1- (overlay-end overlay))) ?\n)))
|
||
(comint-send-string (scheme-proc) "\n")
|
||
;; Remove modified mark so that Emacs will trust its idea about positions.
|
||
(or start (overlay-put overlay 'modifiedp nil))
|
||
;; Send end-of-text
|
||
(comint-send-string (scheme-proc) guile-end-of-chunk)
|
||
;; Wait for acknowledge.
|
||
(while (and scheme-load-p (not guile-error-p))
|
||
(accept-process-output (scheme-proc) 0 guile-process-timeout))
|
||
|
||
;; Have we received an error?
|
||
(if guile-error-p
|
||
(progn
|
||
(if interactivep
|
||
(save-excursion
|
||
(set-buffer scheme-buffer)
|
||
(let ((output guile-unallowed-output))
|
||
(if (string-match "\\(^ABORT:.*\n\\)+" output)
|
||
(guile-insert-before-prompt (match-string 1 output))))))
|
||
(overlay-put overlay 'modifiedp t)
|
||
(setq scheme-load-p nil)
|
||
(throw 'exit nil))) ;Abort whatever we was doing.
|
||
|
||
;; The transfer has been successful. Display defined symbol.
|
||
(if interactivep
|
||
(progn
|
||
(goto-char (overlay-start overlay))
|
||
(if (and (not (and start (/= start (overlay-start overlay))))
|
||
(looking-at guile-defexpr))
|
||
(progn
|
||
(guile-display-name (match-string guile-defexpr-name)
|
||
multip)
|
||
(setq guile-last-result nil))
|
||
(set-buffer scheme-buffer)
|
||
(if guile-eval-output
|
||
(guile-insert-before-prompt guile-eval-output))
|
||
(setq guile-last-result guile-eval-result)
|
||
(set-buffer old-buffer))
|
||
(goto-char old-pos)
|
||
(sit-for 0))
|
||
|
||
(goto-char old-pos))))
|
||
|
||
(defun guile-display-name (name multip)
|
||
(save-excursion
|
||
(let ((buffer-file (guile-buffer-file-name))
|
||
(buffer-name (buffer-name)))
|
||
(set-buffer scheme-buffer)
|
||
(save-excursion
|
||
(let ((inhibit-read-only t))
|
||
(if (not guile-define-header-emitted-p)
|
||
(let ((header
|
||
(format "DEFINED:%s ()\n"
|
||
(if multip
|
||
(concat " "
|
||
(or (and buffer-file
|
||
(file-name-nondirectory
|
||
buffer-file))
|
||
buffer-name))
|
||
""))))
|
||
(guile-insert-before-prompt header)
|
||
(set-marker guile-define-name-marker
|
||
(save-excursion
|
||
(goto-char guile-last-prompt-end)
|
||
(forward-line 0)
|
||
(- (point) 2)))
|
||
(setq guile-define-startcol (- (length header) 2))
|
||
(setq guile-define-filler
|
||
(concat "\n"
|
||
(make-string guile-define-startcol ? )))
|
||
(setq guile-define-fillcol
|
||
(let ((window (get-buffer-window scheme-buffer t)))
|
||
(if window
|
||
(- (window-width window) 3)
|
||
fill-column)))
|
||
(setq guile-define-header-emitted-p t)))
|
||
(goto-char guile-define-name-marker)
|
||
(cond ((= (current-column) guile-define-startcol))
|
||
((> (+ (current-column) (length name)) guile-define-fillcol)
|
||
(insert-before-markers guile-define-filler))
|
||
(t (insert-before-markers " ")))
|
||
(insert-before-markers name))))))
|
||
|
||
;;; Enhanced editing
|
||
;;;
|
||
|
||
(defvar guile-n-enhanced-buffers 0
|
||
"Number of buffers in enhanced edit mode.")
|
||
|
||
(defun guile-enhancedp (&optional buffer)
|
||
(interactive)
|
||
(if (not buffer)
|
||
scheme-buffer-overlays
|
||
(save-excursion
|
||
(set-buffer buffer)
|
||
scheme-buffer-overlays)))
|
||
|
||
(defun guile-get-enhanced-buffers ()
|
||
(let ((ls (buffer-list))
|
||
(ans '()))
|
||
(while ls
|
||
(if (guile-enhancedp (car ls))
|
||
(setq ans (cons (car ls) ans)))
|
||
(setq ls (cdr ls)))
|
||
(reverse ans)))
|
||
|
||
(defun guile-enhanced-edit (buffer &optional known-by-scheme)
|
||
"Put the current scheme buffer into enhanced editing mode."
|
||
(interactive (list (current-buffer)))
|
||
(if (guile-enhancedp buffer)
|
||
(error "Already in enhanced editing mode!"))
|
||
(save-excursion
|
||
(set-buffer buffer)
|
||
(guile-parse-buffer known-by-scheme)
|
||
(setq scheme-overlay-repair-function 'guile-repair-overlays)
|
||
(if (not (memq scheme-overlay-repair-idle-timer timer-idle-list))
|
||
(setq scheme-overlay-repair-idle-timer
|
||
(run-with-idle-timer 0.1 t 'run-hook-with-args
|
||
'scheme-overlay-repair-function)))
|
||
(setq guile-n-enhanced-buffers (1+ guile-n-enhanced-buffers)))
|
||
(force-mode-line-update))
|
||
|
||
(defun guile-normal-edit (buffer)
|
||
"Exit enhanced editing mode."
|
||
(interactive (list (current-buffer)))
|
||
(if (guile-attachedp)
|
||
(error "Can't exit enhanced editing mode while attached to scheme. Detach first."))
|
||
(save-excursion
|
||
(set-buffer buffer)
|
||
(for-each (function (lambda (overlay)
|
||
(if (overlayp overlay) ; For stability's sake
|
||
(progn
|
||
(if (guile-virtual-p overlay)
|
||
(scheme-virtual-unlink (overlay-get overlay 'id)))
|
||
(delete-overlay overlay)))))
|
||
scheme-buffer-overlays)
|
||
(setq scheme-buffer-overlays ())
|
||
(setq scheme-buffer-last-overlay nil)
|
||
;; Since we let go of the control, we have to mark the buffer...
|
||
;(setq scheme-buffer-modified-p t) Now using first-change-hook.
|
||
(setq scheme-overlay-repair-function nil)
|
||
(scheme-virtual-unlink (guile-buffer-file-name buffer))
|
||
(setq guile-n-enhanced-buffers (1- guile-n-enhanced-buffers)))
|
||
(force-mode-line-update))
|
||
|
||
;;; Overlay lists
|
||
;;;
|
||
;;; Every non-broken overlay containing a sexp starts with a character
|
||
;;; with syntax ?\(.
|
||
;;; The first overlay in the overlay list is never broken.
|
||
|
||
(defun guile-current-line ()
|
||
(+ (count-lines 1 (point))
|
||
(if (= (current-column) 0) 1 0)))
|
||
|
||
(defun guile-safe-forward-sexp ()
|
||
"Move point one sexp forwards.
|
||
Returns non-nil if no error was encountered."
|
||
(not (condition-case err
|
||
(forward-sexp)
|
||
(error err))))
|
||
|
||
(defun guile-safe-backward-sexp ()
|
||
"Move point one sexp forwards.
|
||
Returns non-nil if no error was encountered."
|
||
(not (condition-case err
|
||
(backward-sexp)
|
||
(error err))))
|
||
|
||
(defun guile-real-safe-backward-sexp ()
|
||
(and (guile-safe-backward-sexp)
|
||
(progn
|
||
(and (char-before)
|
||
(char-before (1- (point)))
|
||
(eq (char-before (1- (point))) ?#)
|
||
(eq (char-syntax (char-before)) ?w)
|
||
(forward-char -2))
|
||
t)))
|
||
|
||
(defun guile-parse-buffer (&optional initialp)
|
||
(interactive)
|
||
(if (= (point-min) (point-max))
|
||
;; Apparently, the buffer is empty
|
||
(progn
|
||
(setq overlay (make-overlay (point-min) (point-max) nil nil t))
|
||
(overlay-put overlay 'modification-hooks
|
||
'(guile-handle-modification))
|
||
(overlay-put overlay 'insert-behind-hooks
|
||
'(rear-sticky-overlay-function guile-handle-modification))
|
||
(setq scheme-buffer-overlays (list overlay))
|
||
(setq scheme-buffer-last-overlay overlay))
|
||
(setq scheme-buffer-last-overlay nil)
|
||
(guile-reparse-buffer nil (point-min) initialp)
|
||
(guile-modularize scheme-buffer-overlays)))
|
||
|
||
(defvar guile-tail-cons (cons nil nil))
|
||
|
||
(defun guile-cons-before-match (x ls)
|
||
"Match X against successive elements of LS.
|
||
Return cons before the one with car matching X."
|
||
(if (or (null ls)
|
||
(eq (car ls) x))
|
||
nil
|
||
(while (and (cdr ls) (not (eq (car (cdr ls)) x)))
|
||
(setq ls (cdr ls)))
|
||
(and (cdr ls)
|
||
ls)))
|
||
|
||
;; Here I've sacrificed readability for speed...
|
||
;; Geeh! What a monstrum!
|
||
;;
|
||
(defun guile-reparse-buffer (start-overlay limit &optional initialp)
|
||
"Reparse buffer backwards to build/update `scheme-buffer-overlays'.
|
||
Start with overlay START-OVERLAY. Stop when we have passed LIMIT.
|
||
If START-OVERLAY is nil parsing starts from (point-max).
|
||
The optional third argument INITIALP should be non-nil if parsing
|
||
for the first time. This will cause initialization of the
|
||
original-line property."
|
||
(let* ((tailp (and start-overlay
|
||
(progn
|
||
(goto-char (overlay-end start-overlay))
|
||
(if (bolp)
|
||
(guile-cons-before-match start-overlay
|
||
scheme-buffer-overlays)
|
||
(let ((after (guile-cons-before-match
|
||
start-overlay
|
||
scheme-buffer-overlays)))
|
||
(if after
|
||
(progn
|
||
(overlay-put (car after) 'brokenp t)
|
||
(guile-cons-before-match
|
||
after
|
||
scheme-buffer-overlays))))))))
|
||
(tail (or tailp guile-tail-cons))
|
||
(overlays (if tailp (cdr tail) scheme-buffer-overlays))
|
||
(overlay nil)
|
||
(first-broken nil)
|
||
(last-broken nil)
|
||
(last-end (if tailp
|
||
(overlay-end (car (cdr tail)))
|
||
(point-max))))
|
||
(goto-char last-end)
|
||
;; Parse buffer backwards...
|
||
(save-match-data
|
||
(while (> (point) limit)
|
||
;; First try to move one sexp backwards...
|
||
(if (and (guile-safe-backward-sexp)
|
||
(bolp))
|
||
(progn
|
||
;; Do we have it in the list?
|
||
(while (and overlays
|
||
(> (overlay-start (car overlays)) (point)))
|
||
;; First throw away some trash overlays...
|
||
(let ((id (overlay-get (car overlays) 'id)))
|
||
(delete-overlay (car overlays))
|
||
(if id
|
||
;; It's a stand-alone sexp, remove it from the list
|
||
(scheme-virtual-unlink id)))
|
||
(setq overlays (cdr overlays)))
|
||
(if (and overlays
|
||
(= (overlay-start (car overlays)) (point)))
|
||
;; Yes!
|
||
(progn ; Is it intact?
|
||
(if (or (overlay-get (car overlays) 'brokenp)
|
||
(/= (overlay-end (car overlays)) last-end))
|
||
;; No...
|
||
(progn
|
||
;; Adjust it.
|
||
(move-overlay (car overlays) (point) last-end)
|
||
;; Can we repair it?
|
||
(if (if (bobp)
|
||
(or (eolp)
|
||
(eq (char-syntax (following-char)) ?\()
|
||
(eq (char-syntax (following-char)) ?<)
|
||
(eq (char-syntax (following-char)) ? ))
|
||
(eq (char-syntax (following-char)) ?\())
|
||
;; Yes!
|
||
(progn
|
||
(overlay-put (car overlays) 'brokenp nil)
|
||
(overlay-put (car overlays) 'face nil)
|
||
(overlay-put (car overlays) 'modifiedp t)
|
||
(overlay-put (car overlays)
|
||
'define-module
|
||
(and (looking-at "(define-module \\((.*)\\)")
|
||
(condition-case err
|
||
(save-excursion
|
||
(goto-char (match-beginning 1))
|
||
(read (current-buffer)))
|
||
(error nil)))))
|
||
;; No...
|
||
(overlay-put (car overlays) 'face guile-broken-face)
|
||
(overlay-put (car overlays) 'modifiedp t))))
|
||
;; Link it in.
|
||
(setcdr tail overlays)
|
||
(setq tail (cdr tail))
|
||
(setq overlays (cdr overlays)))
|
||
;; We probably have to make a new overlay...
|
||
;; First check if it's OK.
|
||
(if (if (bobp)
|
||
(or (eolp)
|
||
(eq (char-syntax (following-char)) ?\()
|
||
(eq (char-syntax (following-char)) ?<)
|
||
(eq (char-syntax (following-char)) ? ))
|
||
(eq (char-syntax (following-char)) ?\())
|
||
;; Everything seems OK with this one.
|
||
(progn
|
||
(setq overlay (make-overlay (point) last-end nil nil t))
|
||
(if initialp
|
||
(overlay-put overlay 'original-line
|
||
(guile-current-line))
|
||
(overlay-put overlay 'modifiedp t))
|
||
(overlay-put overlay 'modification-hooks
|
||
'(guile-handle-modification))
|
||
(overlay-put overlay
|
||
'define-module
|
||
(and (looking-at "(define-module \\((.*)\\)")
|
||
(condition-case err
|
||
(save-excursion
|
||
(goto-char (match-beginning 1))
|
||
(read (current-buffer)))
|
||
(error nil))))
|
||
;; And link it in...
|
||
(setcdr tail (cons overlay overlays))
|
||
(setq tail (cdr tail)))
|
||
;; But this one is broken!
|
||
;; Try to find some structure...
|
||
(guile-backward-broken-sexp)
|
||
(while (and overlays
|
||
(> (overlay-start (car overlays)) (point)))
|
||
(let ((id (overlay-get (car overlays) 'id)))
|
||
(delete-overlay (car overlays))
|
||
(if id
|
||
(scheme-virtual-unlink id)))
|
||
(setq overlays (cdr overlays)))
|
||
;; Is it possibly the first one in the overlay list?
|
||
(if (and overlays
|
||
(= (overlay-start (car overlays)) (point)))
|
||
(progn
|
||
;; Adjust it.
|
||
(move-overlay (car overlays) (point) last-end)
|
||
(overlay-put (car overlays) 'face guile-broken-face)
|
||
(overlay-put (car overlays) 'modifiedp t)
|
||
;; Link it in.
|
||
(setcdr tail overlays)
|
||
(setq tail (cdr tail))
|
||
(setq overlays (cdr overlays)))
|
||
;; It wasn't - make a new overlay.
|
||
(setq overlay (make-overlay (point) last-end nil nil t))
|
||
(overlay-put overlay 'brokenp t)
|
||
(overlay-put overlay 'face guile-broken-face)
|
||
(overlay-put overlay 'modification-hooks
|
||
'(guile-handle-modification))
|
||
;; And link it in...
|
||
(setcdr tail (cons overlay overlays))
|
||
(setq tail (cdr tail))))))
|
||
;; Broken overlay... Here we go again!
|
||
(guile-backward-broken-sexp)
|
||
(while (and overlays
|
||
(> (overlay-start (car overlays)) (point)))
|
||
(let ((id (overlay-get (car overlays) 'id)))
|
||
(delete-overlay (car overlays))
|
||
(if id
|
||
(scheme-virtual-unlink id)))
|
||
(setq overlays (cdr overlays)))
|
||
(if (and overlays
|
||
(= (overlay-start (car overlays)) (point)))
|
||
(progn
|
||
(setq overlay (car overlays))
|
||
(move-overlay overlay (point) last-end)
|
||
(setcdr tail overlays)
|
||
(setq tail (cdr tail))
|
||
(setq overlays (cdr overlays)))
|
||
(setq overlay (make-overlay (point) last-end nil nil t))
|
||
(overlay-put overlay 'modification-hooks
|
||
'(guile-handle-modification))
|
||
(setcdr tail (cons overlay overlays))
|
||
(setq tail (cdr tail)))
|
||
(overlay-put overlay 'brokenp t)
|
||
(overlay-put overlay 'face guile-broken-face))
|
||
(if (overlay-get (car tail) 'brokenp)
|
||
(progn
|
||
(setq first-broken (car tail))
|
||
(if (not last-broken)
|
||
(setq last-broken (car tail)))))
|
||
(setq last-end (point))))
|
||
(if (not tailp)
|
||
(progn
|
||
(setq scheme-buffer-overlays
|
||
(cdr guile-tail-cons))
|
||
;; Don't let the rear-stickiness propagate upwards...
|
||
(if scheme-buffer-last-overlay
|
||
(if (not (eq (car scheme-buffer-overlays)
|
||
scheme-buffer-last-overlay))
|
||
(progn
|
||
(overlay-put scheme-buffer-last-overlay
|
||
'insert-behind-hooks
|
||
nil)
|
||
(overlay-put (car scheme-buffer-overlays)
|
||
'insert-behind-hooks
|
||
'(rear-sticky-overlay-function
|
||
guile-handle-modification))))
|
||
(overlay-put (car scheme-buffer-overlays)
|
||
'insert-behind-hooks
|
||
'(rear-sticky-overlay-function guile-handle-modification)))
|
||
(setq scheme-buffer-last-overlay
|
||
(car scheme-buffer-overlays))))
|
||
(setq guile-last-broken last-broken)
|
||
(setq guile-repair-limit
|
||
(if first-broken
|
||
;(overlay-start
|
||
; (let ((ovls (memq first-broken scheme-buffer-overlays)))
|
||
; (or (and ovls (cdr ovls) (car (cdr ovls)))
|
||
; first-broken)
|
||
(overlay-start first-broken)
|
||
guile-big-integer)))
|
||
(if guile-show-overlays-p
|
||
(guile-show-overlays))
|
||
)
|
||
|
||
(defvar guile-last-broken nil)
|
||
(defvar guile-repair-limit guile-big-integer)
|
||
|
||
(defun guile-handle-modification (overlay after from to &optional length)
|
||
(if after
|
||
(progn
|
||
(overlay-put overlay 'brokenp t)
|
||
(setq scheme-buffer-overlays-modified-p t)
|
||
(if guile-last-broken
|
||
(if (< (overlay-start overlay) guile-repair-limit)
|
||
(setq guile-repair-limit
|
||
;(overlay-start
|
||
; (let ((ovls (memq overlay scheme-buffer-overlays)))
|
||
; (or (and ovls (cdr ovls) (car (cdr ovls)))
|
||
; overlay)))
|
||
(overlay-start overlay))
|
||
(if (> (overlay-start overlay)
|
||
(overlay-start guile-last-broken))
|
||
(setq guile-last-broken overlay)))
|
||
(setq guile-last-broken overlay)
|
||
(setq guile-repair-limit
|
||
;(overlay-start
|
||
; (let ((ovls (memq overlay scheme-buffer-overlays)))
|
||
; (or (and ovls (cdr ovls) (car (cdr ovls)))
|
||
; overlay)))
|
||
(overlay-start overlay))))))
|
||
|
||
(defun guile-repair-overlays ()
|
||
(if (and (eq major-mode 'scheme-mode)
|
||
scheme-buffer-overlays-modified-p)
|
||
(save-excursion
|
||
;(ding)
|
||
;(message "Repair!")
|
||
(setq scheme-buffer-modified-p t)
|
||
(if scheme-associated-process-buffer
|
||
(setq guile-synchronizedp nil))
|
||
(guile-reparse-buffer guile-last-broken guile-repair-limit)
|
||
(guile-modularize scheme-buffer-overlays)
|
||
(setq scheme-buffer-overlays-modified-p nil))))
|
||
|
||
(defun guile-modularize (r-overlays)
|
||
(let ((overlays (reverse r-overlays))
|
||
(module nil))
|
||
(while overlays
|
||
(if (overlay-get (car overlays) 'define-module)
|
||
(progn
|
||
(overlay-put (car overlays) 'module-overlay nil)
|
||
(setq module (car overlays)))
|
||
(overlay-put (car overlays) 'module-overlay module))
|
||
(setq overlays (cdr overlays)))))
|
||
|
||
(defun guile-backward-broken-sexp ()
|
||
(interactive)
|
||
(beginning-of-line)
|
||
(let ((last (point)))
|
||
(while (not (or (bobp)
|
||
(and (eq (following-char) ?\()
|
||
(guile-safe-backward-sexp)
|
||
(bolp))))
|
||
(forward-line -1)
|
||
(beginning-of-line)
|
||
(setq last (point)))
|
||
(let ((end (point)))
|
||
(goto-char (if (guile-safe-forward-sexp)
|
||
last
|
||
end)))))
|
||
|
||
;; rear-sticky-overlay-function:
|
||
;; Put this function in the `insert-behind-hooks' of an overlay
|
||
;; in order to make the overlay rear-sticky.
|
||
|
||
(defun rear-sticky-overlay-function (overlay after from to &optional length)
|
||
(if after
|
||
(move-overlay overlay (overlay-start overlay) to)))
|
||
|
||
;;; Some debugging utilities
|
||
;;;
|
||
|
||
(defvar guile-show-overlays-p nil)
|
||
|
||
(defun guile-show-overlays ()
|
||
(interactive)
|
||
(if (guile-enhancedp)
|
||
(let ((n 1)
|
||
(color nil)
|
||
(previous nil)
|
||
(overlays scheme-buffer-overlays))
|
||
(if (null overlays)
|
||
(progn
|
||
(ding)
|
||
(message "Empty overlay list!"))
|
||
(if (not (memq 'rear-sticky-overlay-function
|
||
(overlay-get (car overlays) 'insert-behind-hooks)))
|
||
(progn
|
||
(ding)
|
||
(message "Last overlay not rear-sticky!")))
|
||
(while overlays
|
||
(overlay-put (car overlays)
|
||
'face
|
||
(if (setq color (not color))
|
||
(if (overlay-get (car overlays) 'brokenp)
|
||
guile-broken-face-1
|
||
(if (overlay-get (car overlays) 'modifiedp)
|
||
guile-modified-face-1
|
||
guile-unmodified-face-1))
|
||
(if (overlay-get (car overlays) 'brokenp)
|
||
guile-broken-face-2
|
||
(if (overlay-get (car overlays) 'modifiedp)
|
||
guile-modified-face-2
|
||
guile-unmodified-face-2))))
|
||
(if previous
|
||
(progn
|
||
(if (/= (overlay-end (car overlays))
|
||
(overlay-start previous))
|
||
(progn (ding)
|
||
(message "Bad end boundary at overlay no. %d" n)))
|
||
(if (overlay-get (car overlays) 'insert-behind-hooks)
|
||
(progn
|
||
(ding)
|
||
(message "Inner overlay no. %d rear-sticky!" n)))))
|
||
(setq previous (car overlays))
|
||
(setq n (1+ n))
|
||
(setq overlays (cdr overlays)))
|
||
(if (/= (overlay-start previous) (point-min))
|
||
(progn
|
||
(ding)
|
||
(message "First overlay doesn't start at %d" (point-min)))))))
|
||
(setq guile-show-overlays-p t))
|
||
|
||
(defun guile-hide-overlays ()
|
||
(interactive)
|
||
(let ((color nil)
|
||
(overlays scheme-buffer-overlays))
|
||
(while overlays
|
||
(overlay-put (car overlays)
|
||
'face
|
||
(if (overlay-get (car overlays) 'brokenp)
|
||
guile-broken-face
|
||
nil))
|
||
(setq overlays (cdr overlays))))
|
||
(setq guile-show-overlays-p nil))
|
||
|
||
;; *fixme* Consider removing this function
|
||
(defun guile-kill-overlays (&optional ls)
|
||
(interactive)
|
||
(if (not ls)
|
||
(progn
|
||
(setq ls (apply (function append)
|
||
(mapcar (function cdr)
|
||
scheme-virtual-file-list)))
|
||
(setq scheme-virtual-file-list ())))
|
||
(while ls
|
||
(delete-overlay (car ls))
|
||
(setq ls (cdr ls))))
|
||
|
||
;; *fixme* Consider removing this function
|
||
(defun overlay-kill ()
|
||
(interactive)
|
||
(delete-overlay (car (overlays-at (point)))))
|
||
|
||
(defun for-each (func ls)
|
||
(while ls
|
||
(funcall func (car ls))
|
||
(setq ls (cdr ls))))
|
||
|
||
|
||
;;; Completion
|
||
|
||
(defconst guile-symbol-chars "---A-Z<><5A><EFBFBD>a-z<><7A><EFBFBD>0-9!$%&/=?@+*<>|-_:.")
|
||
|
||
(defun guile-match-symnames (word &optional exactp)
|
||
(if (not word)
|
||
'()
|
||
(save-excursion
|
||
(set-buffer scheme-buffer)
|
||
(guile-eval `(map symbol->string
|
||
(%%apropos-internal
|
||
,(concat "^"
|
||
(regexp-quote word)
|
||
(and exactp "$"))))))))
|
||
|
||
(defmacro guile-force-splittable (&rest forms)
|
||
`(let ((f (selected-frame))
|
||
(w (selected-window)))
|
||
(let ((unsplittable (assq 'unsplittable (frame-parameters f)))
|
||
(dedicatedp (window-dedicated-p w))
|
||
(same-window-buffer-names
|
||
(append same-window-buffer-names
|
||
(list (buffer-name (window-buffer w))))))
|
||
(unwind-protect
|
||
(progn
|
||
(modify-frame-parameters f '((unsplittable . nil)))
|
||
(set-window-dedicated-p w nil)
|
||
,@forms)
|
||
(modify-frame-parameters f (list unsplittable))
|
||
(set-window-dedicated-p w dedicatedp)))))
|
||
|
||
(defvar guile-complete-function 'comint-dynamic-complete)
|
||
|
||
(defun guile-indent-or-complete ()
|
||
(interactive)
|
||
(let ((beg (save-excursion
|
||
(beginning-of-line)
|
||
(point))))
|
||
(if (guile-whitespace-between-p beg (point))
|
||
(funcall 'indent-for-tab-command)
|
||
(funcall guile-complete-function))))
|
||
|
||
(defun guile-complete-symbol ()
|
||
(interactive)
|
||
(let ((word (comint-word guile-symbol-chars)))
|
||
(if word
|
||
(progn
|
||
(guile-force-splittable
|
||
(comint-dynamic-simple-complete word (guile-match-symnames word)))
|
||
(if (string= (buffer-name) scheme-buffer)
|
||
(put-text-property comint-last-output-start
|
||
(point) 'face 'bold))))))
|
||
|
||
(defun guile-list-completions ()
|
||
(interactive)
|
||
(let* ((word (comint-word guile-symbol-chars))
|
||
(candidates (mapcar (function (lambda (x) (list x)))
|
||
(guile-match-symnames word)))
|
||
(completions (all-completions word candidates)))
|
||
(if (null completions)
|
||
(message "No completions of %s" word)
|
||
(guile-force-splittable
|
||
(comint-dynamic-list-completions completions))
|
||
(if (string= (buffer-name) scheme-buffer)
|
||
(put-text-property comint-last-output-start (point) 'face 'bold)))))
|
||
|
||
;;; Documentation
|
||
|
||
(defun guile-documentation-symbols ()
|
||
(save-excursion
|
||
(set-buffer scheme-buffer)
|
||
(guile-eval '(map symbol->string (%%apropos-internal "")))))
|
||
|
||
(defun guile-variable-at-point (symnames)
|
||
(condition-case ()
|
||
(let ((stab (syntax-table)))
|
||
(unwind-protect
|
||
(save-excursion
|
||
(set-syntax-table scheme-mode-syntax-table)
|
||
(or (not (zerop (skip-syntax-backward "_w")))
|
||
(eq (char-syntax (following-char)) ?w)
|
||
(eq (char-syntax (following-char)) ?_)
|
||
(forward-sexp -1))
|
||
(skip-chars-forward "'")
|
||
(let ((obj (read (current-buffer))))
|
||
(and (symbolp obj) (member (symbol-name obj) symnames) obj)))
|
||
(set-syntax-table stab)))
|
||
(error nil)))
|
||
|
||
(defun guile-describe-variable (variable)
|
||
"Display the full documentation of Guile variable VARIABLE."
|
||
(interactive
|
||
(let ((symnames (guile-documentation-symbols)))
|
||
(let ((symbol (guile-variable-at-point symnames))
|
||
(enable-recursive-minibuffers t)
|
||
val)
|
||
(setq val (completing-read (if symbol
|
||
(format "Describe Guile variable (default %s): " symbol)
|
||
"Describe Guile variable: ")
|
||
(mapcar (lambda (s)
|
||
(cons s '()))
|
||
symnames)
|
||
nil t))
|
||
(list (if (equal val "")
|
||
symbol
|
||
(intern val))))))
|
||
(guile-force-splittable
|
||
(with-output-to-temp-buffer "*Help*"
|
||
(prin1 variable)
|
||
(princ ": ")
|
||
(princ (save-excursion
|
||
(set-buffer scheme-buffer)
|
||
(guile-eval variable t)))
|
||
(terpri)
|
||
(terpri)
|
||
(let ((doc (save-excursion
|
||
(set-buffer scheme-buffer)
|
||
(guile-eval `(%%emacs-symdoc ',variable)))))
|
||
(if doc
|
||
(princ doc)
|
||
(princ "not documented")))
|
||
(print-help-return-message)
|
||
(save-excursion
|
||
(set-buffer standard-output)
|
||
(help-mode)
|
||
;; Return the text we displayed.
|
||
(buffer-string)))))
|
||
|
||
(provide 'guile)
|
||
(run-hooks 'guile-load-hook)
|