summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorNeil Jerram <neil@ossau.uklinux.net>2003-08-20 19:00:44 +0000
committerNeil Jerram <neil@ossau.uklinux.net>2003-08-20 19:00:44 +0000
commitdb24983896ecc30853707cfbf684ca9b1d9414d9 (patch)
treee25a903acad46c069e40caa8b68f1ec23b20f728
parent2388d9af3e7d43e93c690e2c9f344a2a51b1513c (diff)
downloadguile-db24983896ecc30853707cfbf684ca9b1d9414d9.tar.gz
Import Mikael's Emacs interface code (guileint-1.5.2) into Guile CVS.
-rw-r--r--emacs/ChangeLog6
-rw-r--r--emacs/README1
-rw-r--r--emacs/guileint/ChangeLog235
-rw-r--r--emacs/guileint/README0
-rw-r--r--emacs/guileint/README.mdj0
-rw-r--r--emacs/guileint/cmuscheme.el.diff0
-rw-r--r--emacs/guileint/comint.el.diff0
-rw-r--r--emacs/guileint/defmenu.el94
-rw-r--r--emacs/guileint/fcreate.el0
-rw-r--r--emacs/guileint/guile-init.el152
-rw-r--r--emacs/guileint/guile.el2457
-rw-r--r--emacs/guileint/guileint.el117
-rw-r--r--emacs/guileint/inda-scheme.el201
-rw-r--r--emacs/guileint/scheme.el.diff0
-rw-r--r--emacs/guileint/xscheme.el.diff0
15 files changed, 3263 insertions, 0 deletions
diff --git a/emacs/ChangeLog b/emacs/ChangeLog
index 5189f107f..4d7b0bf53 100644
--- a/emacs/ChangeLog
+++ b/emacs/ChangeLog
@@ -1,3 +1,9 @@
+2003-08-20 Neil Jerram <neil@ossau.uklinux.net>
+
+ * guileint: New subdirectory.
+
+ * README: Mention it.
+
2001-11-19 Thien-Thi Nguyen <ttn@giblet.glug.org>
* README: Use less forking for indexing command.
diff --git a/emacs/README b/emacs/README
index 73e021581..4d39c6111 100644
--- a/emacs/README
+++ b/emacs/README
@@ -9,5 +9,6 @@ patch.el --- mail/apply a patch
ppexpand.el --- temporarily expanding macros in a pretty way.
update-changelog.el --- stitch rcs2log output to ChangeLog
+guileint --- directory containing experimental Emacs interface for Guile
Generated using: for f in *.el ; do sed -e 's/^....//g' -e '1q' $f ; done
diff --git a/emacs/guileint/ChangeLog b/emacs/guileint/ChangeLog
new file mode 100644
index 000000000..11c6de786
--- /dev/null
+++ b/emacs/guileint/ChangeLog
@@ -0,0 +1,235 @@
+2003-08-20 Neil Jerram <neil@ossau.uklinux.net>
+
+ Import of Mikael's guileint-1.5.2.tgz into Guile CVS ...
+
+ * defmenu.el, fcreate.el, guile-init.el, guile.el, guileint.el,
+ inda-scheme.el: Imported unchanged.
+
+ * cmuscheme.el.diff, comint.el.diff, scheme.el.diff,
+ xscheme.el.diff: Created by diffing Mikael's versions against the
+ nearest revisions I could find in Emacs CVS, so as to show the
+ changes made.
+
+ * README.mdj: Renamed from Mikael's `README'.
+
+ * README: New.
+
+1999-08-23 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * guile.el (guile-frame-eval): Made interactive.
+ (guile-error-map): Added guile-frame-eval under "e".
+
+1999-03-17 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * guile.el (guile-file-readable-p, guile-find-file-noselect): New
+ functions. Sets buffer to scheme-buffer before doing there
+ action.
+ (guile-display-scheme-sexp): Use the above functions.
+
+1999-03-16 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * guile.el (guile-buffer-file-name): Version of buffer-file-name
+ which uses file-truename;
+ Use guile-buffer-file-name throughout.
+
+1999-03-15 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * guileint.el: Add conditional in order not to load the interface
+ multiple times.
+
+ * guile.el (scheme-virtual-file-list-find): New function. Finds
+ an finfo entry using a file name. Uses `file-truename';
+ Replaced all assoc calls with scheme-vertual-file-list-find
+ everywhere.
+ (guile-real-safe-backward-sexp): New function. Can skip backwards
+ over special scheme hash-syntax.
+ (guile-send-input): Use `guile-real-safe-backward-sexp'.
+
+1999-03-01 Mikael Djurfeldt <mdj@barbara.nada.kth.se>
+
+ * inda-scheme.el (scheme-electric-open-paren),
+ guile.el (guile-indent-or-complete): Use indent-for-tab-command
+ instead of scheme-indent-line.
+
+ * scheme.el: Merge changes from Emacs-20.3.
+
+1998-06-18 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * guile.el (guile-send-region): Bugfix: Calculate new value for
+ start if overlays have been skipped.
+ (guile-send-overlay): Send define-module overlay to define the
+ module before sending any other overlay belonging to that module.
+ (guile-reparse-buffer): Detect define-module expressions.
+
+1998-06-14 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * guile.el (guile-select-stackframe): Increment line number.
+
+1998-06-10 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * guile.el: Removed calls to the former debugging function `cb'.
+
+1998-05-21 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * guile.el: Added nil nil t arguments in calls to make-overlay in
+ order to make the overlays rear-sticky. (This is an adaption to
+ Emacs-20.)
+
+1997-10-22 Mikael Djurfeldt <mdj@nada.kth.se>
+
+ * guile.el (guile-stack-frame-map): Need to be fset in Emacs-20.
+
+Wed Oct 1 22:02:19 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * inda-scheme.el (inda-inferior-initializations): Disable
+ font-lock-mode in inferior-scheme buffers. (For some strange
+ reason, the inda-read-only-overlay modification hook gets called
+ when a character is inserted after the prompt if font-lock mode
+ has been activated.)
+
+Fri Aug 29 01:34:34 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * guile.el (guile-display-name): Bugfix: filler -->
+ guile-define-filler.
+ (guile-send-overlay): Bugfix: Don't print "DEFINED" if start /=
+ overlay-start.
+ Added (require 'cl).
+ (guile-insert-before-prompt): Use guile-last-output-end
+
+Wed Aug 27 17:24:28 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * guile.el (guile-complete-symbol): Bugfix: Don't do anything if
+ word is nil.
+ (guile-backtrace-in-source-window): New customization option.
+ (guile-display-error): Don't place backtrace in source window if
+ guile-backtrace-in-source-window is nil.
+ (guile-prep-backtrace): Set syntax-table to
+ scheme-mode-syntax-table.
+
+Tue Aug 26 00:01:01 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * guile.el (guile-insert-before-prompt): Move the recenter code
+ here.
+ (guile-display-name): Use guile-insert-before-prompt.
+
+Mon Aug 25 22:46:23 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * guile.el (guile-display-name): Recenter display if prompt
+ started at the beginning of the buffer, so that the first text
+ inserted before prompt will be visible.
+
+Mon Aug 25 19:36:50 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * guile.el: New variable: guile-frame-overlay.
+ (guile-inferior-initialize): Initialize guile-frame-overlay to
+ nil.
+ (guile-place-frame-overlay, guile-turn-off-frame-overlay,
+ guile-unselect-stackframe): New functions.
+ (guile-unselect-stackframe): Turn off overlay and set
+ guile-selected-frame to nil.
+ (guile-stack-frame): New overlay category.
+ (guile-selected-frame): defun --> defvar
+ (guile-exit-debug): Turn off frame overlay.
+ (guile-prep-backtrace): Call `guile-unselect-stackframe'.
+ (guile-turn-off-sexp-overlay, guile-turn-off-frame-overlay): Check
+ (car args) before applying `delete-overlay'.
+ (guile-error-map): Bind S-mouse-2 to guile-frame-eval-at-click.
+
+ * inda-scheme.el (inda-scheme-mode-initializations): Bind
+ S-mouse-2 to guile-frame-eval-at-click; Bind M-TAB to
+ guile-complete-symbol.
+
+ * guile.el (guile-complete-symbol): Made a command.
+ (guile-frame-eval-at-click, guile-frame-eval): New functions.
+ Enables clicking on expressions in the source buffer to show their
+ values.
+ (guile-complete-symbol, guile-list-completions): Bugfix: Use
+ `buffer-name' instead of `current-buffer' in order to obtain the
+ buffer name.
+ (guile-select-frame): Always set guile-selected-frame.
+
+Mon Aug 25 16:21:18 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * guile.el (guile-eval): Must wait for scheme-ready-p so that the
+ filter functions don't get called.
+ (guile-describe-variable): Put `guile-force-splittable' around
+ call to `with-output-to-temp-buffer' so that documentation can be
+ displayed also in *scheme* window even if it is dedicated.
+
+Sun Aug 24 22:19:16 1997 Mikael Djurfeldt <mdj@kenneth>
+
+ * *** Transferred code to guile-emacs. ***
+
+ * inda-scheme.el (inda-inferior-initializations): Removed
+ assignment to scheme-pop-to-buffer.
+
+Thu Aug 21 01:47:31 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * guile.el (guile-eval-result, guile-receive-result, guile-eval):
+ guile-eval-result now contains the printed representation as a
+ string instead of an elisp object.
+ (guile-eval-output): New variable.
+ (guile-receive-result): Set guile-eval-output to
+ guile-unallowed-output.
+ (guile-define-startcol, guile-define-filler,
+ guile-define-fillcol): New variables. Buffer-local.
+ (guile-define-header-emitted-p): New variable.
+ (scheme-send-region): Print result of last sent overlay or show
+ message "Defined." if definitions have been made.
+ (guile-insert-before-prompt): Don't use guile-pre-prompt-marker.
+ (guile-pre-prompt-marker): New name: guile-define-name-marker.
+ (guile-send-region): Moved printing of defined names to
+ guile-display-name.
+ (guile-send-overlay): New parameters; Zeros guile-eval-output;
+ Adapted to new format of %%emacs-load; Can now send sub-parts of
+ an overlay; Use guile-display-name.
+ (guile-display-name): New function.
+ (guile-receive-result): Reset guile-unallowed-output after having
+ stored its value in guile-eval-output.
+
+Sat Aug 16 02:53:00 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * guile.el (guile-display-error): Limit height of *Scheme Error*
+ window to half of guile-backtrace-max-height.
+
+Thu Jul 24 18:41:56 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * guile.el (guile-normal-edit): Don't set
+ scheme-buffer-modified-p. This will be done by
+ guile-scheme-buffer-modified next time the buffer is modified.
+ (guile-scheme-buffer-modified): New function.
+ (guile-inferior-initialize): Make first-change-hook buffer-local,
+ add guile-scheme-modified; Pass t for initialp to
+ guile-enhanced-edit if the scheme-buffer seems untouched.
+
+ * guile.el (guile-normal-edit): Unlink overlays and buffer.
+
+ * inda-scheme.el (inda-send-definition, inda-mark-sexp): Make it
+ possible to send expressions to scheme just by clicking on them.
+
+ * guileint.el: Removed statements that doesn't have anything to do
+ with the Guile interface per se (transient-mark-mode, iso-syntax
+ etc)
+
+Wed Jul 23 19:11:15 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * inda-scheme.el: Changed inda menu --> interpret.
+
+Thu Jul 17 10:43:58 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * inda96.el (devel-binary): Changed to unstable.
+
+ * guile.el (guile-display-buffers): Check for window system before
+ deleting windows on buffer1.
+ (guile-get-create-error-window): Treat non-window system
+ differently.
+ (scheme-send-region): Don't check for (scheme-ready-p) here. This
+ is checked in guile-send-region.
+ (guile-send-region): Check for (scheme-ready-p) here instead.
+ Go to end-of-buffer before determining proper place for "DEFINED
+ %s (".
+
+Tue Oct 15 16:56:18 1996 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * Start of revision history for misc elisp files.
+
diff --git a/emacs/guileint/README b/emacs/guileint/README
new file mode 100644
index 000000000..e69de29bb
--- /dev/null
+++ b/emacs/guileint/README
diff --git a/emacs/guileint/README.mdj b/emacs/guileint/README.mdj
new file mode 100644
index 000000000..e69de29bb
--- /dev/null
+++ b/emacs/guileint/README.mdj
diff --git a/emacs/guileint/cmuscheme.el.diff b/emacs/guileint/cmuscheme.el.diff
new file mode 100644
index 000000000..e69de29bb
--- /dev/null
+++ b/emacs/guileint/cmuscheme.el.diff
diff --git a/emacs/guileint/comint.el.diff b/emacs/guileint/comint.el.diff
new file mode 100644
index 000000000..e69de29bb
--- /dev/null
+++ b/emacs/guileint/comint.el.diff
diff --git a/emacs/guileint/defmenu.el b/emacs/guileint/defmenu.el
new file mode 100644
index 000000000..d63d32182
--- /dev/null
+++ b/emacs/guileint/defmenu.el
@@ -0,0 +1,94 @@
+;;; @(#) defmenu.el -- A GNU Emacs extension which helps building menus
+;;; @(#) $Keywords: X, menu $
+
+;; Copyright (C) 1995 Mikael Djurfeldt
+
+;; LCD Archive Entry:
+;; defmenu|djurfeldt@nada.kth.se|
+;; A GNU Emacs extension which helps building menus|
+;; $Date: 2003-08-20 19:00:44 $|$Revision: 1.1 $|~/misc/defmenu.el.Z|
+
+;; Author: Mikael Djurfeldt <djurfeldt@nada.kth.se>
+;; Version: 1.0
+
+;; 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:
+;;
+;;
+
+(defun define-menu (keymap key name entries)
+ "Define a menu in KEYMAP on fake function key KEY with label NAME.
+Every entry in the list ENTRIES defines a menu item and looks like this:
+
+ (LABEL DEFINITION [ENABLE-EXP])
+
+LABEL is a string which will appear in the menu.
+DEFINITION is either a symbol, in which case it will be used both as
+fake function key and binding, or a pair, where the car is the fake
+function key and the cdr is the binding.
+The optional ENABLE-EXP is an expression which will be evaluated every
+time the menu is displayed. If it returns nil the menu item will
+be disabled.
+
+You can get a separator by including nil in the ENTRIES list."
+ (define-key keymap
+ (vector 'menu-bar key)
+ (cons name (make-menu name entries))))
+
+(defun make-menu (name entries)
+ "Make a menu with label NAME.
+Every entry in the list ENTRIES defines a menu item and looks like this:
+
+ (LABEL DEFINITION [ENABLE-EXP])
+
+LABEL is a string which will appear in the menu.
+DEFINITION is either a symbol, in which case it will be used both as
+fake function key and binding, or a pair, where the car is the fake
+function key and the cdr is the binding.
+The optional ENABLE-EXP is an expression which will be evaluated every
+time the menu is displayed. If it returns nil the menu item will
+be disabled.
+
+You can get a separator by including nil in the ENTRIES list."
+ (let ((menu (make-sparse-keymap name))
+ (entries (reverse entries)))
+ (while entries
+ (let ((entry (car entries)))
+ (if (null entry)
+ (define-key menu (vector (defmenu-gensym "separator")) '("--"))
+ (if (symbolp (nth 1 entry))
+ (define-key menu (vector (nth 1 entry))
+ (cons (car entry) (nth 1 entry)))
+ (define-key menu (vector (car (nth 1 entry)))
+ (cons (car entry) (cdr (nth 1 entry)))))
+ (if (not (null (nthcdr 2 entry)))
+ (put (nth 1 entry) 'menu-enable (nth 2 entry)))))
+ (setq entries (cdr entries)))
+ menu))
+
+(defun defmenu-gensym (prefix)
+ (let ((counter (intern (concat "defmenu-" prefix "count"))))
+ (if (boundp counter) (set counter (1+ (symbol-value counter)))
+ (set counter 0))
+ (intern (concat prefix (int-to-string (symbol-value counter))))))
+
+(provide 'defmenu)
diff --git a/emacs/guileint/fcreate.el b/emacs/guileint/fcreate.el
new file mode 100644
index 000000000..e69de29bb
--- /dev/null
+++ b/emacs/guileint/fcreate.el
diff --git a/emacs/guileint/guile-init.el b/emacs/guileint/guile-init.el
new file mode 100644
index 000000000..e75f4b69b
--- /dev/null
+++ b/emacs/guileint/guile-init.el
@@ -0,0 +1,152 @@
+;;; @(#) guile-init.el --
+;;; @(#) $Keywords: $
+
+;; Copyright (C) 1995 Mikael Djurfeldt
+
+;; LCD Archive Entry:
+;; guile-init|djurfeldt@nada.kth.se|
+;; A GNU Emacs extension which |
+;; $Date: 2003-08-20 19:00:44 $|$Revision: 1.1 $|~/misc/<package>.el.Z|
+
+;; Author: Mikael Djurfeldt <djurfeldt@nada.kth.se>
+;; Version: 1.0
+
+;; 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:
+;;
+;;
+
+(defvar guile-init-load-hook nil
+ "*Hook run when file is loaded")
+
+(require 'guile)
+
+;;; Misc. interactivity
+;;;
+;;;
+(defun inda-barf-at-modifications (&rest args)
+ (or inhibit-read-only
+ (error "Attempt to modify read-only text")))
+
+(defun inda-boldify-previous-character ()
+ ;; Must check this so that we don't point outside buffer...
+ (if (> (point) (point-min))
+ (let ((inhibit-read-only t))
+ (put-text-property (1- (point)) (point) 'face 'bold))))
+
+(defun inda-make-input-memory (string)
+ ;; If input consists of many lines, the read-only overlay will
+ ;; cover the previous line, so we have to disable the protection.
+ (let ((inhibit-read-only t))
+ ;(setq n (1+ n)
+ ; l (append l (list (list n 'input-filter string))))
+ (if (marker-position guile-last-output-end)
+ (add-text-properties guile-last-output-end (1- (point))
+ '(input-memory t rear-nonsticky t mouse-face highlight)))))
+
+(defun inda-reset-guile-last-output (string)
+ ;(setq n (1+ n)
+ ; l (append l (list (list n 'output-filter string))))
+ (if (not scheme-ready-p)
+ (set-marker guile-last-output-end nil)))
+
+(define-key inferior-scheme-mode-map [mouse-2] 'inda-mouse-yank-at-click)
+(define-key inferior-scheme-mode-map [S-mouse-2] 'inda-mouse-yank-at-click)
+
+;; Should rather be implemented with advice.
+(defun inda-mouse-yank-at-click (click arg)
+ "Insert the last stretch of killed text at the position clicked on.
+Also move point to one end of the text thus inserted (normally the end).
+Prefix arguments are interpreted as with \\[yank].
+If `mouse-yank-at-point' is non-nil, insert at point
+regardless of where you click."
+ (interactive "e\nP")
+ (if (get-char-property (posn-point (event-start click)) 'input-memory)
+ (if (memq 'shift (event-modifiers (car click)))
+ (inda-insert-input-memory click)
+ (inda-insert-input-memory-and-send click))
+ ;; Give temporary modes such as isearch a chance to turn off.
+ (run-hooks 'mouse-leave-buffer-hook)
+ (or mouse-yank-at-point (mouse-set-point click))
+ (setq this-command 'yank)
+ (yank arg)))
+
+(defun inda-insert-input-memory (event)
+ (interactive "e")
+ (let* ((pos (posn-point (event-start event)))
+ (beg (previous-single-property-change (1+ pos) 'mouse-face))
+ (end (next-single-property-change pos 'mouse-face)))
+ (goto-char (point-max))
+ (let ((input-start (point)))
+ (comint-kill-input)
+ (insert (buffer-substring beg end))
+ (add-text-properties input-start (point)
+ '(mouse-face nil
+ rear-nonsticky nil
+ input-memory nil)))))
+
+(defun inda-insert-input-memory-and-send (event)
+ (interactive "e")
+ (inda-insert-input-memory event)
+ (guile-send-input))
+
+(defun inda-boldify (string)
+ (put-text-property comint-last-input-start (point) 'face 'bold))
+
+(defun inda-extend-read-only-overlay (string)
+ (if guile-input-sent-p
+ (let ((inhibit-read-only t))
+ (move-overlay inda-read-only-overlay (point-min) (point)))))
+
+;;; Misc. utilities
+;;;
+(defun scheme-send-buffer ()
+ "Send the current buffer to the inferior Scheme process."
+ (interactive)
+ (let (begin end)
+ (save-excursion
+ (goto-char (point-max))
+ (setq end (point))
+ (goto-char (point-min))
+ (setq begin (point)))
+ (scheme-send-region begin end)))
+
+(defun indent-buffer ()
+ "Indent entire buffer."
+ (interactive)
+ (save-excursion
+ (end-of-buffer)
+ (let ((end (point)))
+ (beginning-of-buffer)
+ (indent-region (point) end nil))))
+
+(defun indent-defun ()
+ "Indent lisp definition."
+ (interactive)
+ (save-excursion
+ (end-of-defun)
+ (let ((end (point)))
+ (beginning-of-defun)
+ (indent-region (point) end nil))))
+
+(provide 'guile-init)
+(run-hooks 'guile-init-load-hook)
diff --git a/emacs/guileint/guile.el b/emacs/guileint/guile.el
new file mode 100644
index 000000000..e78e4ac4d
--- /dev/null
+++ b/emacs/guileint/guile.el
@@ -0,0 +1,2457 @@
+;;; @(#) 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ÅÄÖa-zåäö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)
diff --git a/emacs/guileint/guileint.el b/emacs/guileint/guileint.el
new file mode 100644
index 000000000..93c03c7a2
--- /dev/null
+++ b/emacs/guileint/guileint.el
@@ -0,0 +1,117 @@
+;;; NAME: guileint.el
+;;; SYNOPSIS: A Guile/Emacs interface prototype
+;;; VERSION: 1.5
+;;; LAST CHANGE: 2002-10-19
+;;; CREATED: 1997-07-17
+;;; AUTHOR: Mikael Djurfeldt <djurfeldt@nada.kth.se>
+;;; COPYRIGHT: (C) 1997, 2002 Mikael Djurfeldt
+;;;
+;;; Verbatim copies of this file may be freely redistributed.
+;;;
+;;; Modified versions of this file may be redistributed provided that this
+;;; notice remains unchanged, the file contains prominent notice of
+;;; author and time of modifications, and redistribution of the file
+;;; is not further restricted in any way.
+;;;
+;;; This file is distributed `as is', without warranties of any kind.
+;;;
+;;; REQUIREMENTS:
+;;;
+;;; USAGE:
+;;;
+;;; BUGS:
+;;;
+;;;
+;;; Setup load-path
+
+(if (featurep 'guileint)
+ nil
+
+(require 'cl-19 "cl")
+
+(defconst guileint-init-file "guileint")
+
+(defvar guileint-emacs-dir nil)
+(let ((pathlist (getenv "EMACSSITELOAD")))
+ (if (and pathlist
+ (string-match (concat "\\(\\(/[^:/]+\\)*\\)/?"
+ guileint-init-file
+ "\\(\.elc?\\)?\\(:\\|\\'\\)")
+ pathlist))
+ (setq guileint-emacs-dir (match-string 1 pathlist))))
+
+(defvar guileint-default-load-path load-path)
+(setq load-path
+ (append (list
+ guileint-emacs-dir
+ )
+ guileint-default-load-path
+ '(
+ )))
+
+(setq scheme-program-name
+ (let ((v (getenv "SCHEME_PROGRAM_NAME")))
+ (or v
+ (concat "guile"
+ (and window-system " --emacs")))))
+
+;;; Select buffers to pop up as separate windows
+(if window-system
+ (progn
+ (defvar default-special-display-buffer-names
+ special-display-buffer-names)
+ (setq special-display-buffer-names
+ (union default-special-display-buffer-names '("*scheme*")))
+
+ (setq same-window-buffer-names
+ (delete "*scheme*" same-window-buffer-names))
+
+ (setq special-display-frame-alist
+ '((height . 24) (width . 80) (unsplittable . t)))
+ ))
+
+;;; Do things to support lisp-hacking better
+(if (equal (substring emacs-version 0 2) "19")
+ ;; Emacs version 19 specific initializations
+ (progn
+ (copy-face 'default 'paren)
+ (condition-case err
+ (make-face-bold 'paren)
+ (error))
+ (setq show-paren-face 'paren)
+ (require 'paren)
+ ;; The old parenthesis matcher has the advantage of displaying
+ ;; non-visible matching parenthesis in the minibuffer.
+ ;; Since paren.el adds (setq blink-paren-function nil) to the
+ ;; window-setup-hook it's necessary to put this setq there
+ ;; also.
+ (add-hook 'window-setup-hook (function restore-blink-paren) t)
+ (setq blink-matching-delay 0.5)
+ ))
+
+(defun restore-blink-paren ()
+ (interactive)
+ (setq blink-matching-paren-on-screen t)
+ (set-face-underline-p 'paren t))
+
+;;; Menus
+;;;
+
+(require 'defmenu)
+
+;(setq menu-bar-final-items
+; '(completion inout signals scheme help-menu))
+(setq menu-bar-final-items
+ '(interpret scheme help-menu))
+
+;; The global menu
+;;
+(define-menu global-map 'interpret "Interpret"
+ '(("Guile" run-scheme (not (comint-check-proc "*scheme*")))
+ ("Switch to *scheme*" guile-switch-to-scheme
+ (comint-check-proc "*scheme*"))))
+
+(load "inda-scheme")
+
+(provide 'guileint)
+)
diff --git a/emacs/guileint/inda-scheme.el b/emacs/guileint/inda-scheme.el
new file mode 100644
index 000000000..8c2f8b502
--- /dev/null
+++ b/emacs/guileint/inda-scheme.el
@@ -0,0 +1,201 @@
+;;; NAME: inda-scheme.el
+;;; SYNOPSIS: Customizations of the scheme modes for
+;;; the INDA course at NADA/KTH
+;;; VERSION: 1.0
+;;; LAST CHANGE: 950827
+;;; CREATED: 950827
+;;; AUTHOR: Mikael Djurfeldt <djurfeldt@nada.kth.se>
+;;; COPYRIGHT: (C) Mikael Djurfeldt 1995
+;;;
+;;; Verbatim copies of this file may be freely redistributed.
+;;;
+;;; Modified versions of this file may be redistributed provided that this
+;;; notice remains unchanged, the file contains prominent notice of
+;;; author and time of modifications, and redistribution of the file
+;;; is not further restricted in any way.
+;;;
+;;; This file is distributed `as is', without warranties of any kind.
+;;;
+;;; REQUIREMENTS:
+;;;
+;;; USAGE:
+;;;
+;;; BUGS:
+;;;
+;;;
+
+(require 'guile-init)
+
+;;; Customizations of the scheme modes
+
+(defun inda-scheme-mode-initializations ()
+ (define-key scheme-mode-map "\r" 'newline-and-indent)
+ ;(define-key scheme-mode-map "\C-c\C-e" 'scheme-send-definition-and-go)
+ (define-key scheme-mode-map [S-mouse-2] 'guile-frame-eval-at-click)
+ (define-key scheme-mode-map [triple-mouse-1] 'inda-mark-sexp) ;*fixme*
+ (define-key scheme-mode-map "\C-c\C-b" 'scheme-send-buffer)
+ (define-key scheme-mode-map "(" 'scheme-electric-open-paren)
+ (define-key scheme-mode-map "[" 'scheme-electric-open-paren)
+ (define-key scheme-mode-map ")" 'scheme-close-paren)
+ (define-key scheme-mode-map "]" 'scheme-close-paren)
+ (define-key scheme-mode-map "\M-?" 'guile-list-completions)
+ (define-key scheme-mode-map "\C-cd" 'guile-describe-variable)
+ (define-key scheme-mode-map "\M-\t" 'guile-complete-symbol)
+ (put 'procedure->macro 'scheme-indent-function 0)
+ (put 'procedure->memoizing-macro 'scheme-indent-function 0)
+ (put 'bind 'scheme-indent-function 1)
+ (put 'letrec* 'scheme-indent-function 1)
+ (put 'syntax-rules 'scheme-indent-function 1)
+ (put 'syntax-case 'scheme-indent-function 2)
+ (put 'define-syntax 'scheme-indent-function 1)
+ (put 'with-syntax 'scheme-indent-function 1))
+
+(add-hook 'scheme-mode-hook (function inda-scheme-mode-initializations))
+
+(defun scheme-electric-open-paren ()
+ (interactive)
+ (insert last-input-char)
+ (let ((old-point (point)))
+ (indent-for-tab-command)
+ (if (not (eq (char-after (1- (point))) last-input-char))
+ (goto-char old-point))))
+
+(defun scheme-close-paren ()
+ (interactive)
+ (insert last-input-char)
+ (if (guile-enhancedp)
+ (guile-repair-overlays))
+ (if blink-paren-function
+ (funcall blink-paren-function)))
+
+(defun inda-send-definition (click)
+ "Position point and send definition to the inferior Scheme process."
+ (interactive "e")
+ (mouse-set-point click)
+ (sit-for 0)
+ (scheme-send-definition))
+
+(defun inda-mark-sexp ()
+ (interactive)
+ (beginning-of-defun)
+ (mark-sexp))
+
+(defvar inda-read-only-overlay nil)
+
+(defun inda-inferior-initializations ()
+ (setq guile-kill-buffer-on-death t)
+ ;; The following seems already to be done in comint-mode...
+ ;;(add-hook 'pre-command-hook (function comint-preinput-scroll-to-bottom))
+ (setq comint-scroll-to-bottom-on-input 'this)
+ (setq comint-scroll-to-bottom-on-output nil)
+
+ ;; Some key bindings.
+ (define-key inferior-scheme-mode-map "\C-a" 'comint-bol)
+ (define-key inferior-scheme-mode-map [C-a] 'comint-bol)
+ (define-key inferior-scheme-mode-map "\C-c\C-a" 'beginning-of-line)
+ (define-key inferior-scheme-mode-map [C-c C-a] 'beginning-of-line)
+ (define-key inferior-scheme-mode-map "\r" 'guile-send-input)
+ (define-key inferior-scheme-mode-map "\t" 'guile-indent-or-complete)
+ (define-key inferior-scheme-mode-map "\M-?" 'guile-list-completions)
+ (define-key inferior-scheme-mode-map "\C-cd" 'guile-describe-variable)
+ (define-key inferior-scheme-mode-map [C-c d] 'guile-describe-variable)
+
+ ;; Create the read-only overlay.
+ (make-local-variable 'inda-read-only-overlay)
+ (cond ((not (overlayp inda-read-only-overlay))
+ (setq inda-read-only-overlay (make-overlay 1 (point)))
+ (overlay-put inda-read-only-overlay 'modification-hooks
+ '(inda-barf-at-modifications))))
+
+ ;; Disable font-lock
+ (make-local-variable 'font-lock-fontify-region-function)
+ (setq font-lock-fontify-region-function 'ignore)
+
+ ;; We don't want all comint modes to have these values
+ (add-hook 'comint-input-filter-functions
+ (function inda-make-input-memory) 'append 'local)
+ (add-hook 'comint-input-filter-functions
+ (function inda-extend-read-only-overlay) 'append 'local)
+ (add-hook 'comint-output-filter-functions
+ (function inda-extend-read-only-overlay) 'append 'local)
+ (add-hook 'comint-output-filter-functions
+ (function inda-reset-guile-last-output) 'append 'local)
+ ;; This is a bit kludgy...
+ (add-hook 'scheme-enter-input-wait-hook (function inda-boldify-previous-character))
+)
+
+;; No message about reason when process dies
+
+(setq guile-insert-reason nil)
+
+(add-hook 'inferior-scheme-mode-hook
+ (function inda-inferior-initializations)
+ 'append)
+
+(require 'defmenu)
+
+;; Scheme mode menu
+;;
+(fset 'scheme-advanced-menu
+ (make-menu
+ "Advanced"
+ '(
+ ("Sync with scheme" guile-sync-with-scheme
+ (and (> guile-n-enhanced-buffers 0)
+ (not (guile-synchronizedp))
+ scheme-ready-p))
+ ("Re-eval buffer" guile-reread-buffer (and (guile-attachedp)
+ scheme-ready-p))
+ ()
+ ("Enhanced edit" guile-enhanced-edit (not (guile-enhancedp)))
+ ("Normal edit" guile-normal-edit (and (guile-enhancedp)
+ (not (guile-attachedp))))
+ ()
+ ("Eval definition" scheme-send-definition (comint-check-proc "*scheme*"))
+ ("Eval region" scheme-send-region (comint-check-proc "*scheme*"))
+ ("Eval buffer" scheme-send-buffer (comint-check-proc "*scheme*"))
+ )))
+
+(define-menu scheme-mode-map 'scheme "Scheme"
+ '(
+ ("Eval definition" scheme-send-definition (comint-check-proc "*scheme*"))
+ ("Eval region" scheme-send-region (comint-check-proc "*scheme*"))
+ ("Eval buffer" scheme-send-buffer (comint-check-proc "*scheme*"))
+ ("Eval all changes" guile-send-changes (comint-check-proc "*scheme*"))
+ ()
+ ("Indent buffer" indent-buffer)
+ ("Indent region" indent-region)
+ ("Indent definition" indent-defun)
+ ()
+ ("Enhanced edit" guile-enhanced-edit (not (guile-enhancedp)))
+ ("Normal edit" guile-normal-edit (and (guile-enhancedp)
+ (not (guile-attachedp))))
+ ()
+ ("Attach buffer" guile-attach-buffer (and (comint-check-proc "*scheme*")
+ scheme-ready-p
+ (not (guile-attachedp))))
+ ("Detach buffer" guile-detach-buffer (guile-attachedp))
+ ()
+ ("Re-init buffer" guile-reread-buffer (and (guile-attachedp)
+ scheme-ready-p))
+ ("Find bad expressions" guile-check-all (> guile-n-enhanced-buffers 0))
+ ))
+
+;(define-key scheme-mode-map [menu-bar interpret] 'undefined)
+
+;; Inferior scheme menu
+;;
+(define-menu inferior-scheme-mode-map 'scheme "Scheme"
+ '(("Start scheme" run-scheme (not (comint-check-proc "*scheme*")))
+ ("Restart scheme" guile-restart-scheme (comint-check-proc "*scheme*"))
+ ("Exit scheme" guile-exit-scheme (comint-check-proc "*scheme*"))
+ ()
+ ("Load file..." guile-load-file
+ (and (comint-check-proc "*scheme*")
+ scheme-ready-p))
+ ("Eval all changes" guile-send-changes (comint-check-proc "*scheme*"))
+ ("Find bad expressions" guile-check-all (comint-check-proc "*scheme*"))
+ ()
+ ("Clear transcript" guile-clear-transcript (comint-check-proc "*scheme*"))))
+
+(define-key inferior-scheme-mode-map [menu-bar interpret] 'undefined)
diff --git a/emacs/guileint/scheme.el.diff b/emacs/guileint/scheme.el.diff
new file mode 100644
index 000000000..e69de29bb
--- /dev/null
+++ b/emacs/guileint/scheme.el.diff
diff --git a/emacs/guileint/xscheme.el.diff b/emacs/guileint/xscheme.el.diff
new file mode 100644
index 000000000..e69de29bb
--- /dev/null
+++ b/emacs/guileint/xscheme.el.diff