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 + + * guileint: New subdirectory. + + * README: Mention it. + 2001-11-19 Thien-Thi Nguyen * 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 + + 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 + + * guile.el (guile-frame-eval): Made interactive. + (guile-error-map): Added guile-frame-eval under "e". + +1999-03-17 Mikael Djurfeldt + + * 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 + + * 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 + + * 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 + + * 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 + + * 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 + + * guile.el (guile-select-stackframe): Increment line number. + +1998-06-10 Mikael Djurfeldt + + * guile.el: Removed calls to the former debugging function `cb'. + +1998-05-21 Mikael Djurfeldt + + * 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 + + * guile.el (guile-stack-frame-map): Need to be fset in Emacs-20. + +Wed Oct 1 22:02:19 1997 Mikael Djurfeldt + + * 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 + + * 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 + + * 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 + + * 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 + + * 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 + + * 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 + + * 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 + + * *** 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 + + * 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 + + * 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 + + * 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 + + * inda-scheme.el: Changed inda menu --> interpret. + +Thu Jul 17 10:43:58 1997 Mikael Djurfeldt + + * 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 + + * 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 diff --git a/emacs/guileint/README.mdj b/emacs/guileint/README.mdj new file mode 100644 index 000000000..e69de29bb diff --git a/emacs/guileint/cmuscheme.el.diff b/emacs/guileint/cmuscheme.el.diff new file mode 100644 index 000000000..e69de29bb diff --git a/emacs/guileint/comint.el.diff b/emacs/guileint/comint.el.diff new file mode 100644 index 000000000..e69de29bb 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 +;; 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 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/.el.Z| + +;; Author: Mikael Djurfeldt +;; 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 +;; 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 +;;; 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 +;;; 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 diff --git a/emacs/guileint/xscheme.el.diff b/emacs/guileint/xscheme.el.diff new file mode 100644 index 000000000..e69de29bb