summaryrefslogtreecommitdiff
path: root/emacs
diff options
context:
space:
mode:
authorNeil Jerram <neil@ossau.uklinux.net>2004-03-10 10:09:33 +0000
committerNeil Jerram <neil@ossau.uklinux.net>2004-03-10 10:09:33 +0000
commit464620ec63d8b5e0de725f089da8b4d9f7edfc21 (patch)
tree4123b7080ce634e93f2bc2dbe7f57fcb20500023 /emacs
parent62055253bd05185814e04e01c31577e90b734bb3 (diff)
downloadguile-464620ec63d8b5e0de725f089da8b4d9f7edfc21.tar.gz
Remove guileint files.
Diffstat (limited to 'emacs')
-rw-r--r--emacs/guileint/ChangeLog0
-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.el2457
-rw-r--r--emacs/guileint/guileint.el0
-rw-r--r--emacs/guileint/inda-scheme.el0
-rw-r--r--emacs/guileint/scheme.el.diff0
-rw-r--r--emacs/guileint/sexp-track.el0
12 files changed, 0 insertions, 2551 deletions
diff --git a/emacs/guileint/ChangeLog b/emacs/guileint/ChangeLog
deleted file mode 100644
index e69de29bb..000000000
--- a/emacs/guileint/ChangeLog
+++ /dev/null
diff --git a/emacs/guileint/README b/emacs/guileint/README
deleted file mode 100644
index e69de29bb..000000000
--- a/emacs/guileint/README
+++ /dev/null
diff --git a/emacs/guileint/README.mdj b/emacs/guileint/README.mdj
deleted file mode 100644
index e69de29bb..000000000
--- a/emacs/guileint/README.mdj
+++ /dev/null
diff --git a/emacs/guileint/cmuscheme.el.diff b/emacs/guileint/cmuscheme.el.diff
deleted file mode 100644
index e69de29bb..000000000
--- a/emacs/guileint/cmuscheme.el.diff
+++ /dev/null
diff --git a/emacs/guileint/comint.el.diff b/emacs/guileint/comint.el.diff
deleted file mode 100644
index e69de29bb..000000000
--- a/emacs/guileint/comint.el.diff
+++ /dev/null
diff --git a/emacs/guileint/defmenu.el b/emacs/guileint/defmenu.el
deleted file mode 100644
index d63d32182..000000000
--- a/emacs/guileint/defmenu.el
+++ /dev/null
@@ -1,94 +0,0 @@
-;;; @(#) 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
deleted file mode 100644
index e69de29bb..000000000
--- a/emacs/guileint/fcreate.el
+++ /dev/null
diff --git a/emacs/guileint/guile.el b/emacs/guileint/guile.el
deleted file mode 100644
index e78e4ac4d..000000000
--- a/emacs/guileint/guile.el
+++ /dev/null
@@ -1,2457 +0,0 @@
-;;; @(#) 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
deleted file mode 100644
index e69de29bb..000000000
--- a/emacs/guileint/guileint.el
+++ /dev/null
diff --git a/emacs/guileint/inda-scheme.el b/emacs/guileint/inda-scheme.el
deleted file mode 100644
index e69de29bb..000000000
--- a/emacs/guileint/inda-scheme.el
+++ /dev/null
diff --git a/emacs/guileint/scheme.el.diff b/emacs/guileint/scheme.el.diff
deleted file mode 100644
index e69de29bb..000000000
--- a/emacs/guileint/scheme.el.diff
+++ /dev/null
diff --git a/emacs/guileint/sexp-track.el b/emacs/guileint/sexp-track.el
deleted file mode 100644
index e69de29bb..000000000
--- a/emacs/guileint/sexp-track.el
+++ /dev/null