;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/buffer.scm,v 1.134 1989/08/10 04:42:50 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/buffer.scm,v 1.135 1989/08/11 11:49:53 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
(buffer-local-bindings buffer))
(vector-set! buffer buffer-index:local-bindings '()))
unspecific)
+\f
+(define (with-current-local-bindings! thunk)
+ (let ((wind-bindings
+ (lambda (buffer)
+ (for-each (lambda (binding)
+ (let ((variable (car binding)))
+ (let ((old-value (variable-value variable)))
+ (%set-variable-value! variable (cdr binding))
+ (set-cdr! binding old-value))))
+ (buffer-local-bindings buffer)))))
+ (dynamic-wind
+ (lambda ()
+ (let ((buffer (current-buffer)))
+ (wind-bindings buffer)
+ (perform-buffer-initializations! buffer)))
+ thunk
+ (lambda ()
+ (wind-bindings (current-buffer))))))
+
(define (change-local-bindings! old-buffer new-buffer select-buffer!)
;; Assumes that interrupts are disabled and that OLD-BUFFER is selected.
(let ((variables '()))
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/buffrm.scm,v 1.33 1989/08/08 10:05:25 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/buffrm.scm,v 1.34 1989/08/11 11:49:58 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
(maybe-recompute-image! window)
(%window-scroll-y-relative! window delta)))
-(define-integrable (window-y-center frame)
- (%window-y-center (frame-text-inferior frame)))
-
-(define (window-start-mark frame)
- (let ((window (frame-text-inferior frame)))
- (maybe-recompute-image! window)
- (%window-start-mark window)))
-
(define (set-window-start-mark! frame mark force?)
(let ((window (frame-text-inferior frame)))
(maybe-recompute-image! window)
(clip-mark-to-display window mark)
force?)))
-(define (window-end-mark frame)
+(define-integrable (window-y-center frame)
+ (%window-y-center (frame-text-inferior frame)))
+
+(define (window-start-index frame)
+ (let ((window (frame-text-inferior frame)))
+ (maybe-recompute-image! window)
+ (%window-start-index window)))
+
+(define (window-end-index frame)
(let ((window (frame-text-inferior frame)))
(maybe-recompute-image! window)
- (%window-end-mark window)))\f
+ (%window-end-index window)))
+\f
(define (window-mark-visible? frame mark)
(let ((window (frame-text-inferior frame)))
(maybe-recompute-image! window)
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufmnu.scm,v 1.110 1989/04/28 22:47:30 cph Rel $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufmnu.scm,v 1.111 1989/08/11 11:50:01 cph Rel $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
false)
(define-command list-buffers
- "Display a list of names of existing buffers."
- ()
- (lambda ()
- (pop-up-buffer (update-buffer-list) false)))
+ "Display a list of names of existing buffers.
+Inserts it in buffer *Buffer-List* and displays that.
+Note that buffers with names starting with spaces are omitted.
+Non-null optional arg FILES-ONLY? means mention only file buffers.
+
+The M column contains a * for buffers that are modified.
+The R column contains a % for buffers that are read-only."
+ "P"
+ (lambda (files-only?)
+ (pop-up-buffer (update-buffer-list files-only?) false)))
(define-command buffer-menu
- "Display a list of names of existing buffers."
- ()
- (lambda ()
- (pop-up-buffer (update-buffer-list) true)
+ "Make a menu of buffers so you can save, delete or select them.
+With argument, show only buffers that are visiting files.
+Type ? after invocation to get help on commands available.
+Type q immediately to make the buffer menu go away."
+ "P"
+ (lambda (files-only?)
+ (pop-up-buffer (update-buffer-list files-only?) true)
(message "Commands: d, s, x; 1, 2, m, u, q; rubout; ? for help.")))
-(define (update-buffer-list)
+(define (update-buffer-list files-only?)
(let ((buffer (temporary-buffer "*Buffer-List*")))
(set-buffer-major-mode! buffer (ref-mode-object buffer-menu))
+ (buffer-put! buffer 'REVERT-BUFFER-FILES-ONLY? files-only?)
(buffer-put! buffer 'REVERT-BUFFER-METHOD revert-buffer-menu)
- (fill-buffer-menu! buffer)
+ (fill-buffer-menu! buffer files-only?)
buffer))
(define (revert-buffer-menu buffer dont-use-auto-save? dont-confirm?)
dont-use-auto-save? dont-confirm? ;ignore
(set-buffer-writeable! buffer)
(region-delete! (buffer-region buffer))
- (fill-buffer-menu! buffer))
+ (fill-buffer-menu! buffer (buffer-get buffer 'REVERT-BUFFER-FILES-ONLY?)))
-(define (fill-buffer-menu! buffer)
+(define (fill-buffer-menu! buffer files-only?)
(with-output-to-mark (buffer-point buffer)
(lambda ()
(write-string list-buffers-header)
(let ((current (current-buffer)))
(for-each (lambda (buffer)
- (if (not (minibuffer? buffer)) (begin
+ (if (not (or (minibuffer? buffer)
+ (and files-only?
+ (not (buffer-pathname buffer)))))
+ (begin
(write-string
(list-buffers-format
(if (eq? buffer current) "." " ")
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufwfs.scm,v 1.5 1989/04/28 22:47:49 cph Rel $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufwfs.scm,v 1.6 1989/08/11 11:50:05 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
(%set-buffer-point! buffer (%window-coordinates->mark window 0 y))
(set! point (buffer-point buffer))
(set-inferior-start! cursor-inferior 0 y)
- (set-buffer-cursor-y! buffer y) (set! point-moved? false)
+ (set! point-moved? false)
(window-modeline-event! superior 'WINDOW-SCROLLED))))))
(define (redraw-at! window mark)
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufwin.scm,v 1.280 1989/08/08 10:05:29 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufwin.scm,v 1.281 1989/08/11 11:50:08 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
(declare (usual-integrations))
\f
+;;; The following instance variables contain marks which must -NEVER-
+;;; be passed to anyone who will keep a pointer to them. The reason
+;;; is that the `mark-temporary!' operation is called on these marks,
+;;; which invalidates them as soon as some change happens to the
+;;; buffer. Remember, you were warned!
+;;;
+;;; start-line-mark
+;;; start-mark
+;;; end-mark
+;;; end-line-mark
+;;; start-changes-mark
+;;; end-changes-mark
+;;; start-clip-mark
+;;; end-clip-mark
+
(define-class buffer-window vanilla-window
(buffer point changes-daemon clip-daemon
cursor-inferior blank-inferior
(set! changes-daemon (make-changes-daemon window))
(set! clip-daemon (make-clip-daemon window))
(set! override-inferior false)
- (set! force-redraw? 'BUFFER-CURSOR-Y)
+ (set! force-redraw? 'CENTER)
unspecific)
(define-method buffer-window (:kill! window)
(update-buffer-window! window screen x-start y-start
xl xu yl yu display-style))
+(define-method buffer-window (:salvage! window)
+ (%set-buffer-point! buffer
+ (make-mark (buffer-group buffer)
+ (group-start-index (buffer-group buffer))))
+ (set! point (buffer-point buffer))
+ (window-modeline-event! superior 'SALVAGE)
+ (%window-redraw! window false))
+\f
(define (set-buffer-window-size! window x y)
(with-instance-variables buffer-window window (x y)
(set! saved-screen false)
(usual=> window :set-size! x y)
;; Preserve point y unless it is offscreen now.
(%window-setup-truncate-lines! window false)
- (%window-force-redraw!
- window
- (or (and old-y
- (let ((y (inferior-y-start cursor-inferior)))
- (and (< y y-size) y)))
- (%window-buffer-cursor-y window))))))
+ (%window-force-redraw! window (and old-y (%window-cursor-y window))))))
(define (%window-setup-truncate-lines! window redraw-type)
(with-instance-variables buffer-window window ()
(with-instance-variables buffer-window window ()
buffer))
+(define (%window-buffer-cursor-y window)
+ (with-instance-variables buffer-window window ()
+ (let ((py (buffer-cursor-y buffer)))
+ (and py
+ (begin
+ (set-buffer-cursor-y! buffer false)
+ (and (= (car py) (mark-index point))
+ (< (cdr py) y-size)
+ (cdr py)))))))
+
(define (%set-window-buffer! window new-buffer)
(with-instance-variables buffer-window window (new-buffer)
(if (not (buffer? new-buffer)) (error "Argument not a buffer" new-buffer))
+ (set-buffer-cursor-y! buffer
+ (let ((y (%window-cursor-y window)))
+ (and y (cons (mark-index point) y))))
(delete-window-buffer! window)
(initial-buffer! window new-buffer)
(window-modeline-event! superior 'NEW-BUFFER)
(%window-force-redraw! window (%window-buffer-cursor-y window))))
-(define (%window-buffer-cursor-y window)
- (with-instance-variables buffer-window window (new-buffer)
- (let ((y (buffer-cursor-y buffer)))
- (and y (< y y-size) y))))
-
(define (initial-buffer! window new-buffer)
(with-instance-variables buffer-window window (new-buffer)
(set! buffer new-buffer)
(with-instance-variables buffer-window window ()
(inferior-window cursor-inferior)))
-(define-method buffer-window (:salvage! window)
- (%set-buffer-point! buffer
- (make-mark (buffer-group buffer)
- (group-start-index (buffer-group buffer))))
- (set! point (buffer-point buffer))
- (window-modeline-event! superior 'SALVAGE)
- (%window-redraw! window false))
+(define (%window-cursor-y window)
+ (with-instance-variables buffer-window window ()
+ (let ((y (inferior-y-start cursor-inferior)))
+ (and y (< y y-size) y))))
\f
;;;; Override Message
(set! override-inferior false)
(set! inferiors
(cons* cursor-inferior blank-inferior line-inferiors))
- (let ((coordinates (%window-mark->coordinates window point)))
- (set-inferior-position! cursor-inferior coordinates)
- (set-buffer-cursor-y! buffer (cdr coordinates)))
+ (set-inferior-position! cursor-inferior
+ (%window-mark->coordinates window point))
(blank-inferior-changed! window)
(for-each inferior-needs-redisplay! inferiors)))))
(define-integrable (set-line-inferiors! window inferiors start)
(with-instance-variables buffer-window window (inferiors start)
(set! line-inferiors inferiors)
+ (destroy-mark! start-line-mark)
(set! start-line-mark
(%make-permanent-mark (buffer-group buffer) start false))
unspecific))
(with-instance-variables buffer-window window ()
(define (loop inferiors start)
(if (null? (cdr inferiors))
- (begin (set! last-line-inferior (car inferiors))
- (set! end-line-mark
- (let ((group (buffer-group buffer)))
- (%make-permanent-mark group
- (line-end-index group start)
- true))))
+ (begin
+ (set! last-line-inferior (car inferiors))
+ (destroy-mark! end-line-mark)
+ (set! end-line-mark
+ (let ((group (buffer-group buffer)))
+ (%make-permanent-mark group
+ (line-end-index group start)
+ true))))
(loop (cdr inferiors)
(+ start (line-inferior-length inferiors)))))
(loop line-inferiors (mark-index start-line-mark))
(define (update-cursor! window if-not-visible)
(with-instance-variables buffer-window window (if-not-invisible)
(if (%window-mark-visible? window point)
- (let ((coordinates (%window-mark->coordinates window point)))
- (set-inferior-position! cursor-inferior coordinates)
- (set-buffer-cursor-y! buffer (cdr coordinates))
+ (begin
+ (set-inferior-position! cursor-inferior
+ (%window-mark->coordinates window point))
(set! point-moved? false)
(window-modeline-event! superior 'CURSOR-MOVED))
(if-not-visible window))))
(with-instance-variables buffer-window window ()
(set! force-redraw? (or redraw-type 'CENTER))
(setup-redisplay-flags! redisplay-flags)))
-\f
+
(define (%window-redraw-preserving-start! window)
(with-instance-variables buffer-window window ()
(let ((group (mark-group start-mark))
(cons inferior (fill-bottom window (inferior-y-end inferior) end))
start)))))
(everything-changed! window maybe-recenter!))
-
+\f
(define (%window-redraw! window y)
(with-instance-variables buffer-window window (y)
(redraw-screen! window
(start-mark-changed! window)
(end-mark-changed! window)
(update-cursor! window if-not-visible)))
-\f
+
(define (maybe-marks-changed! window inferiors y-end)
(with-instance-variables buffer-window window (inferiors y-end)
(no-outstanding-changes! window)
(define (no-outstanding-changes! window)
(with-instance-variables buffer-window window ()
+ (destroy-mark! start-changes-mark)
(set! start-changes-mark false)
+ (destroy-mark! end-changes-mark)
(set! end-changes-mark false)
+ (destroy-mark! start-clip-mark)
(set! start-clip-mark false)
+ (destroy-mark! end-clip-mark)
(set! end-clip-mark false)
(set! force-redraw? false)
unspecific))
-
+\f
(define (start-mark-changed! window)
(with-instance-variables buffer-window window ()
+ (destroy-mark! start-mark)
(set! start-mark
(%make-permanent-mark
(buffer-group buffer)
(define (end-mark-changed! window)
(with-instance-variables buffer-window window ()
+ (destroy-mark! end-mark)
(set! end-mark
(let ((group (buffer-group buffer)))
(%make-permanent-mark
true)))
(window-modeline-event! superior 'END-MARK-CHANGED!)))
-(define-integrable (%window-start-mark window)
+(define (destroy-mark! mark)
+ (if mark
+ (mark-temporary! mark)))
+
+(define-integrable (%window-start-index window)
(with-instance-variables buffer-window window ()
- start-mark))
+ (mark-index start-mark)))
-(define-integrable (%window-end-mark window)
+(define-integrable (%window-end-index window)
(with-instance-variables buffer-window window ()
- end-mark))
+ (mark-index end-mark)))
+
(define-integrable (%window-mark-visible? window mark)
(with-instance-variables buffer-window window (mark)
(and (mark<= start-mark mark)
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufwiu.scm,v 1.10 1989/08/08 10:05:33 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufwiu.scm,v 1.11 1989/08/11 11:50:13 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
(<= point-index end)
(%window-point-y window))))
(else
+ (destroy-mark! start-clip-mark)
(set! start-clip-mark false)
+ (destroy-mark! end-clip-mark)
(set! end-clip-mark false)))))
(if start-changes-mark
(let ((start-changes (mark-index start-changes-mark))
(recompute-image!:bottom-changed window)
(recompute-image!:middle-changed window)))
(begin
- (set! start-changes-mark false) (set! end-changes-mark false))))))
+ (destroy-mark! start-changes-mark)
+ (set! start-changes-mark false)
+ (destroy-mark! end-changes-mark)
+ (set! end-changes-mark false))))))
(if point-moved?
(update-cursor! window maybe-recenter!))))))
\f
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/comman.scm,v 1.61 1989/08/10 04:42:31 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/comman.scm,v 1.62 1989/08/11 11:50:16 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
name
description
value
- assignment-daemons
- buffer-local?)
+ buffer-local?
+ initial-value
+ assignment-daemons)
(unparser/set-tagged-vector-method!
%variable-tag
(define (variable-name-string variable)
(editor-name/internal->external (symbol->string (variable-name variable))))
-(define (make-variable name description value)
+(define (make-variable name description value buffer-local?)
(let ((variable
(let ((name (symbol->string name)))
(or (string-table-get editor-variables name)
(vector-set! variable variable-index:name name)
(vector-set! variable variable-index:description description)
(vector-set! variable variable-index:value value)
+ (vector-set! variable variable-index:buffer-local? buffer-local?)
+ (vector-set! variable variable-index:initial-value value)
(vector-set! variable variable-index:assignment-daemons '())
- (vector-set! variable variable-index:buffer-local? false)
variable))
+(define-integrable (%set-variable-value! variable value)
+ (vector-set! variable variable-index:value value)
+ unspecific)
+
(define-integrable (make-variable-buffer-local! variable)
(vector-set! variable variable-index:buffer-local? true)
unspecific)
-
+\f
(define (add-variable-assignment-daemon! variable daemon)
(let ((daemons (variable-assignment-daemons variable)))
(if (not (memq daemon daemons))
(define (name->variable name)
(let ((name (canonicalize-name name)))
(or (string-table-get editor-variables (symbol->string name))
- (make-variable name "" false))))
+ (make-variable name "" false false))))
(define (->variable object)
(if (variable? object) object (name->variable object)))
(%set-variable-value! variable value)
(invoke-variable-assignment-daemons! variable)))))
-(define-integrable (%set-variable-value! variable value)
- (vector-set! variable variable-index:value value)
- unspecific)
(define (with-variable-value! variable new-value thunk)
(let ((old-value))
(dynamic-wind (lambda ()
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/comtab.scm,v 1.55 1989/06/21 11:55:22 cph Rel $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/comtab.scm,v 1.56 1989/08/11 11:50:20 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
(comtab? (cadr comtabs))
(comtab-entry (cdr comtabs) key)))
(lambda ()
- (cond ((null? (cdr comtabs)) bad-command)
- ((comtab? (cadr comtabs)) (comtab-entry (cdr comtabs) key))
- (else (cadr comtabs)))))))
+ (cond ((null? (cdr comtabs))
+ bad-command)
+ ((comtab? (cadr comtabs))
+ (comtab-entry (cdr comtabs) key))
+ (else
+ (cadr comtabs)))))))
(let ((try
(lambda (key alist)
(let ((entry (assq key alist)))
(comtab? (cadr comtabs))
(prefix-char-list? (cdr comtabs) chars)))))))
-(define (define-key mode-name key command)
- (let ((comtabs (mode-comtabs (name->mode mode-name))))
+(define (define-key mode key command)
+ (let ((comtabs (mode-comtabs (->mode mode)))
+ (command (->command command)))
(if (button? key)
(let ((alist (comtab-button-alist (car comtabs))))
(let ((entry (assq key alist)))
(set-comtab-button-alist! (car comtabs)
(cons (cons key command) alist)))))
(let ((normal-key
- (let ((command
- (if (command? command) command (name->command command))))
- (lambda (key)
- (comtab-lookup-prefix comtabs key false
- (lambda (alists char)
- (set-comtab-entry! alists char command)))))))
+ (lambda (key)
+ (comtab-lookup-prefix comtabs key false
+ (lambda (alists char)
+ (set-comtab-entry! alists char command))))))
(cond ((or (char? key) (pair? key))
(normal-key key))
((char-set? key)
(error "Illegal comtab key" key))))))
key)
-(define (define-prefix-key mode-name key command-name)
- (let ((comtabs (mode-comtabs (name->mode mode-name)))
- (command (name->command command-name)))
+(define (define-prefix-key mode key command)
+ (let ((comtabs (mode-comtabs (->mode mode)))
+ (command (->command command)))
(if (or (char? key) (pair? key))
(comtab-lookup-prefix comtabs key false
(lambda (alists char)
(error "Illegal comtab key" key)))
key)
-(define (define-default-key mode-name command-name)
- (let ((comtabs (mode-comtabs (name->mode mode-name))))
+(define (define-default-key mode command)
+ (let ((comtabs (mode-comtabs (->mode mode)))
+ (command (->command command)))
(if (not (or (null? (cdr comtabs)) (command? (cadr comtabs))))
- (error "Can't define default key for this mode" mode-name))
- (set-cdr! comtabs (list (name->command command-name)))) 'DEFAULT-KEY)
+ (error "Can't define default key for this mode" mode))
+ (set-cdr! comtabs (list command)))
+ 'DEFAULT-KEY)
\f
(define (comtab-key-bindings comtabs command)
(define (search-comtabs comtabs)
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/debuge.scm,v 1.37 1989/04/28 22:49:09 cph Rel $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/debuge.scm,v 1.38 1989/08/11 11:50:23 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
(buffer-not-modified! buffer)))))))))
(define-command debug-show-rings
- ""
+ "Show the number of items in the mark and kill rings."
()
(lambda ()
(message "Mark Ring: "
(write-to-string (ring-size (current-kill-ring))))))
(define-command debug-count-marks
- ""
+ "Show the number of in-use and GC'ed marks for the current buffer."
()
(lambda ()
(count-marks-group (buffer-group (current-buffer))
(if (weak-pair/car? marks)
(receiver (1+ n-existing) n-gced)
(receiver n-existing (1+ n-gced)))))
- (receiver 0 0))))\f
+ (receiver 0 0))))
+\f
+(define-command debug-clean-marks
+ "Perform a GC, then remove GC'ed marks from all buffers."
+ ()
+ (lambda ()
+ (gc-flip)
+ ((ref-command debug-count-marks))
+ (for-each (lambda (buffer) (clean-group-marks! (buffer-group buffer)))
+ (buffer-list))))
+
+(define-command debug-show-standard-marks
+ ""
+ ()
+ (lambda ()
+ (with-output-to-temporary-buffer "*standard-marks*"
+ (lambda ()
+ (let ((buffer-frame (current-window)))
+ (let ((window (car (instance-ref buffer-frame 'text-inferior)))
+ (buffer (window-buffer buffer-frame)))
+ (let ((show-mark
+ (lambda (name mark)
+ (write-string
+ (string-pad-right (write-to-string name) 24))
+ (write mark)
+ (newline))))
+ (let ((show-instance
+ (lambda (name)
+ (show-mark name (instance-ref window name)))))
+ (show-instance 'point)
+ (show-instance 'start-line-mark)
+ (show-instance 'start-mark)
+ (show-instance 'end-mark)
+ (show-instance 'end-line-mark))
+ (let ((group (buffer-group buffer)))
+ (show-mark 'group-start-mark (group-start-mark group))
+ (show-mark 'group-end-mark (group-end-mark group))
+ (show-mark 'group-display-start (group-display-start group))
+ (show-mark 'group-display-end (group-display-end group)))
+ (let ((marks (ring-list (buffer-mark-ring buffer))))
+ (if (not (null? marks))
+ (begin
+ (write-string "mark-ring\t\t")
+ (write (car marks))
+ (newline)
+ (for-each (lambda (mark)
+ (write-string "\t\t\t")
+ (write mark)
+ (newline))
+ (cdr marks))))))))))))
+\f
;;;; Object System Debugging
(define (po object)
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/editor.scm,v 1.189 1989/08/08 10:05:54 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/editor.scm,v 1.190 1989/08/11 11:50:27 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
(lambda ()
(with-editor-interrupts
(lambda ()
- (bind-condition-handler '() internal-error-handler
+ (with-current-local-bindings!
(lambda ()
- (perform-buffer-initializations! (current-buffer))
- (dynamic-wind
- (lambda () (update-screens! true))
- (lambda ()
- ;; Should this be in a dynamic wind? -- Jinx
- (if edwin-initialization (edwin-initialization))
- (let ((message (cmdl-message/null)))
- (push-cmdl (lambda (cmdl)
- cmdl ;ignore
- (top-level-command-reader)
- message)
- false
- message)))
- (lambda () unspecific))))))))))))))) ;; Should this be here or in a dynamic wind? -- Jinx
+ (bind-condition-handler '() internal-error-handler
+ (lambda ()
+ (dynamic-wind
+ (lambda () (update-screens! true))
+ (lambda ()
+ ;; Should this be in a dynamic wind? -- Jinx
+ (if edwin-initialization
+ (edwin-initialization))
+ (let ((message (cmdl-message/null)))
+ (push-cmdl (lambda (cmdl)
+ cmdl ;ignore
+ (top-level-command-reader)
+ message)
+ false
+ message)))
+ (lambda () unspecific)))))))))))))))))
+ ;; Should this be here or in a dynamic wind? -- Jinx
(if edwin-finalization (edwin-finalization))
unspecific)
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edtfrm.scm,v 1.78 1989/08/08 10:05:57 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edtfrm.scm,v 1.79 1989/08/11 11:50:30 cph Exp $
;;;
;;; Copyright (c) 1985, 1989 Massachusetts Institute of Technology
;;;
\f
;;;; Button Events
-(define (editor-frame-button-event editor-frame button x y)
- (values-let (((frame relative-x relative-y)
- (values-let (((window relative-x relative-y)
- (inferior-containing-coordinates editor-frame
- x
- y
- buffer-frame?)))
- (if window
- (=> window :leaf-containing-coordinates
- relative-x relative-y)
- (values false false false)))))
- (if frame
- (let ((button-command
- (comtab-entry (buffer-comtabs (window-buffer frame)) button)))
- (if button-command
- (button-command
- frame
- (min relative-x (buffer-frame-x-size frame))
- (min relative-y (buffer-frame-y-size frame))))))))
-
-(define-method editor-frame :button-event! editor-frame-button-event)
+(define-method editor-frame (:button-event! editor-frame button x y)
+ (with-values
+ (lambda ()
+ (inferior-containing-coordinates editor-frame x y buffer-frame?))
+ (lambda (frame relative-x relative-y)
+ (if frame
+ ;; Make sure the event is inside the text portion of the
+ ;; buffer, not in the modeline or other decoration.
+ (cond ((and (< -1 relative-x (buffer-frame-x-size frame))
+ (< -1 relative-y (buffer-frame-y-size frame)))
+ (let ((command
+ (comtab-entry (buffer-comtabs (window-buffer frame))
+ button)))
+ (if command
+ (with-current-button-event
+ (make-button-event frame relative-x relative-y)
+ (lambda () (execute-command command)))
+ (editor-beep))))
+ ((down-button? button)
+ (editor-beep)))))))
(define-integrable (button-upify button-number)
(vector-ref up-buttons button-number))
(vector-ref down-buttons button-number))
(define (button? object)
- (or (vector-find-next-element up-buttons object)
- (vector-find-next-element down-buttons object)))
+ (or (up-button? object)
+ (down-button? object)))
+
+(define-integrable (up-button? object)
+ (vector-find-next-element up-buttons object))
+
+(define-integrable (down-button? object)
+ (vector-find-next-element down-buttons object))
+
(define up-buttons '#())
(define down-buttons '#())
(frame-window false read-only true)
(bufferset false read-only true)
(kill-ring false read-only true)
- (char-history false read-only true))
+ (char-history false read-only true)
+ (button-event false))
(define (make-editor name screen)
(let ((initial-buffer (make-buffer initial-buffer-name initial-buffer-mode)))
frame
bufferset
(make-ring 10)
- (make-ring 100))))))
+ (make-ring 100)
+ false)))))
(define-integrable (current-screen)
(editor-screen current-editor))
(editor-kill-ring current-editor))
(define-integrable (current-char-history)
- (editor-char-history current-editor))
\ No newline at end of file
+ (editor-char-history current-editor))
+\f
+(define-structure (button-event
+ (conc-name button-event/))
+ (window false read-only true)
+ (x false read-only true)
+ (y false read-only true))
+
+(define (current-button-event)
+ (or (editor-button-event current-editor)
+ ;; Create a "dummy" event at point.
+ (let ((window (current-window)))
+ (let ((coordinates (window-point-coordinates window)))
+ (make-button-event window
+ (car coordinates)
+ (cdr coordinates))))))
+
+(define (with-current-button-event button-event thunk)
+ (let ((old-button-event))
+ (dynamic-wind
+ (lambda ()
+ (set! old-button-event (editor-button-event current-editor))
+ (set-editor-button-event! current-editor button-event)
+ (set! button-event false)
+ unspecific)
+ thunk
+ (lambda ()
+ (set! button-event (editor-button-event current-editor))
+ (set-editor-button-event! current-editor old-button-event)
+ (set! old-button-event false)
+ unspecific))))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edwin.pkg,v 1.9 1989/08/09 13:17:16 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edwin.pkg,v 1.10 1989/08/11 11:50:37 cph Exp $
Copyright (c) 1989 Massachusetts Institute of Technology
window-direct-output-insert-newline!
window-direct-output-insert-substring!
window-direct-update!
- window-end-mark
+ window-end-index
window-home-cursor!
window-mark->coordinates
window-mark->x
window-select-time
window-set-override-message!
window-setup-truncate-lines!
- window-start-mark
+ window-start-index
window-y-center
with-editor-interrupts
with-editor-interrupts-enabled
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/macros.scm,v 1.48 1989/08/08 10:06:18 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/macros.scm,v 1.49 1989/08/11 11:50:41 cph Rel $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
(define (command-name->scheme-name name)
(symbol-append 'EDWIN-COMMAND$ name))
-(syntax-table-define edwin-syntax-table 'DEFINE-VARIABLE
- (lambda (name description #!optional value)
- (let ((name (canonicalize-name name)))
- `(BEGIN
- (DEFINE ,(variable-name->scheme-name name)
- (MAKE-VARIABLE ',name
- ',description
- ,(if (default-object? value) '#F value)))
- ',name))))
-
-(syntax-table-define edwin-syntax-table 'DEFINE-VARIABLE-PER-BUFFER
- (lambda (name description #!optional value)
- (let ((name (canonicalize-name name)))
- (let ((scheme-name (variable-name->scheme-name name)))
- `(BEGIN
- (DEFINE ,scheme-name
- (MAKE-VARIABLE ',name
- ',description
- ,(if (default-object? value) '#F value)))
- (MAKE-VARIABLE-BUFFER-LOCAL! ,scheme-name)
- ',name)))))
+(let ((variable-definition
+ (lambda (buffer-local?)
+ (lambda (name description #!optional value)
+ (let ((name (canonicalize-name name)))
+ `(BEGIN
+ (DEFINE ,(variable-name->scheme-name name)
+ (MAKE-VARIABLE ',name
+ ',description
+ ,(if (default-object? value) '#F value)
+ ',buffer-local?))
+ ',name))))))
+ (syntax-table-define edwin-syntax-table 'DEFINE-VARIABLE
+ (variable-definition false))
+ (syntax-table-define edwin-syntax-table 'DEFINE-VARIABLE-PER-BUFFER
+ (variable-definition true)))
(syntax-table-define edwin-syntax-table 'REF-VARIABLE-OBJECT
(lambda (name)
(syntax-table-define edwin-syntax-table 'VALUES-LET
(lambda (bindings . forms)
+
(define (transform/binding binding forms)
(if (or (not (pair? binding))
(not (pair? (cdr binding))))
- (error "values-let: bad binding clause"
- binding)
- `(WITH-VALUES
- (LAMBDA () ,(cadr binding))
- (LAMBDA (,@(car binding))
- ,@forms))))
+ (error "values-let: bad binding clause" binding))
+ `(WITH-VALUES (LAMBDA () ,(cadr binding))
+ (LAMBDA (,@(car binding)) ,@forms)))
+
(define (transform/values-let bindings forms)
(transform/binding
(car bindings)
(if (null? (cdr bindings))
forms
- (list
- (transform/values-let (cdr bindings)
- forms)))))
+ (list (transform/values-let (cdr bindings) forms)))))
+
(if (not (pair? bindings))
- (error "values-let: missing bindings"
- (cons bindings forms))
- (transform/values-let bindings
- forms))))
\ No newline at end of file
+ (error "values-let: missing bindings" (cons bindings forms))
+ (transform/values-let bindings forms))))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/make.scm,v 3.14 1989/08/09 13:17:47 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/make.scm,v 3.15 1989/08/11 11:50:45 cph Exp $
Copyright (c) 1989 Massachusetts Institute of Technology
(declare (usual-integrations))
(package/system-loader "edwin" '() 'QUERY)
-(add-system! (make-system "Edwin" 3 14 '()))
\ No newline at end of file
+(add-system! (make-system "Edwin" 3 15 '()))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/struct.scm,v 1.69 1989/06/19 22:42:29 markf Rel $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/struct.scm,v 1.70 1989/08/11 11:50:48 cph Exp $
;;;
;;; Copyright (c) 1985, 1989 Massachusetts Institute of Technology
;;;
(group-marks group)))
mark))))
\f
-;;; Here is a simple algorithm that is haired up the wazoo for speed.
+;;; The next few procedures are simple algorithms that are haired up
+;;; the wazoo for maximum speed.
+(define (clean-group-marks! group)
+
+ (define (scan-head marks)
+ (cond ((null? marks)
+ (set-group-marks! group '()))
+ ((not (system-pair-car marks))
+ (scan-head (system-pair-cdr marks)))
+ (else
+ (set-group-marks! group marks)
+ (scan-tail marks (system-pair-cdr marks)))))
+
+ (define (scan-tail previous marks)
+ (cond ((null? marks)
+ unspecific)
+ ((not (system-pair-car marks))
+ (skip-nulls previous (system-pair-cdr marks)))
+ (else
+ (scan-tail marks (system-pair-cdr marks)))))
+
+ (define (skip-nulls previous marks)
+ (cond ((null? marks)
+ (system-pair-set-cdr! previous '())
+ unspecific)
+ ((not (system-pair-car marks))
+ (skip-nulls previous (system-pair-cdr marks)))
+ (else
+ (system-pair-set-cdr! previous marks)
+ (scan-tail marks (system-pair-cdr marks)))))
+
+ (let ((marks (group-marks group)))
+ (cond ((null? marks)
+ unspecific)
+ ((not (system-pair-car marks))
+ (scan-head (system-pair-cdr marks)))
+ (else
+ (scan-tail marks (system-pair-cdr marks))))))
+\f
+(define (mark-temporary! mark)
+ ;; I'd think twice about using this one.
+ (if (not recycle-permanent-marks?)
+ (let ((group (mark-group mark)))
+
+ (define (scan-head marks)
+ (if (null? marks)
+ (set-group-marks! group '())
+ (let ((mark* (system-pair-car marks)))
+ (cond ((not mark*)
+ (scan-head (system-pair-cdr marks)))
+ ((eq? mark mark*)
+ (set-group-marks! group (system-pair-cdr marks)))
+ (else
+ (set-group-marks! group marks)
+ (scan-tail marks (system-pair-cdr marks)))))))
+
+ (define (scan-tail previous marks)
+ (if (not (null? marks))
+ (let ((mark* (system-pair-car marks)))
+ (cond ((not mark*)
+ (skip-nulls previous (system-pair-cdr marks)))
+ ((eq? mark mark*)
+ (system-pair-set-cdr! previous marks)
+ unspecific)
+ (else
+ (scan-tail marks (system-pair-cdr marks)))))))
+
+ (define (skip-nulls previous marks)
+ (if (null? marks)
+ (begin
+ (system-pair-set-cdr! previous '())
+ unspecific)
+ (let ((mark* (system-pair-car marks)))
+ (cond ((not mark*)
+ (skip-nulls previous (system-pair-cdr marks)))
+ ((eq? mark mark*)
+ (system-pair-set-cdr! previous (system-pair-cdr marks))
+ unspecific)
+ (else
+ (system-pair-set-cdr! previous marks)
+ (scan-tail marks (system-pair-cdr marks)))))))
+
+ (let ((marks (group-marks group)))
+ (if (not (null? marks))
+ (let ((mark* (system-pair-car marks)))
+ (cond ((not mark*)
+ (scan-head (system-pair-cdr marks)))
+ ((eq? mark mark*)
+ (set-group-marks! group (system-pair-cdr marks)))
+ (else
+ (scan-tail marks (system-pair-cdr marks))))))))))
+\f
(define (find-permanent-mark group position left-inserting?)
(define (scan-head marks)
mark
(scan-tail marks (system-pair-cdr marks))))))))
- (scan-head (group-marks group)))
+ (let ((marks (group-marks group)))
+ (and (not (null? marks))
+ (let ((mark (system-pair-car marks)))
+ (cond ((not mark)
+ (scan-head (system-pair-cdr marks)))
+ ((and (if (mark-left-inserting? mark)
+ left-inserting?
+ (not left-inserting?))
+ (= (mark-position mark) position))
+ mark)
+ (else
+ (scan-tail marks (system-pair-cdr marks))))))))
\f
(define (for-each-mark group procedure)
(scan-tail marks rest))
(skip-nulls previous rest)))))
- (scan-head (group-marks group)))\f
+ (let ((marks (group-marks group)))
+ (if (not (null? marks))
+ (let ((mark (system-pair-car marks))
+ (rest (system-pair-cdr marks)))
+ (if mark
+ (begin
+ (procedure mark)
+ (scan-tail marks rest))
+ (scan-head rest))))))
+\f
;;;; Regions
(define-integrable %make-region cons)
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/wincom.scm,v 1.94 1989/08/08 10:06:36 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/wincom.scm,v 1.95 1989/08/11 11:50:52 cph Exp $
;;;
;;; Copyright (c) 1987, 1989 Massachusetts Institute of Technology
;;;
(define (scroll-window window n #!optional limit)
(if (if (negative? n)
- (mark= (window-start-mark window)
- (buffer-start (window-buffer window)))
- (mark= (window-end-mark window)
- (buffer-end (window-buffer window)))) ((if (default-object? limit) editor-error limit))
+ (= (window-start-index window)
+ (mark-index (buffer-start (window-buffer window))))
+ (= (window-end-index window)
+ (mark-index (buffer-end (window-buffer window)))))
+ ((if (default-object? limit) editor-error limit))
(window-scroll-y-relative! window n)))
(define (standard-scroll-window-argument window argument factor)
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/xcom.scm,v 1.1 1989/06/21 10:42:34 cph Rel $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/xcom.scm,v 1.2 1989/08/11 11:50:55 cph Exp $
;;;
;;; Copyright (c) 1989 Massachusetts Institute of Technology
;;;
"watch"
"xterm"))
\f
-(define (x-switch-to-window window x y)
- x y ;ignore
- (select-window window))
-
-(define (x-move-to-coordinates window x y)
- (select-window window)
- (set-current-point!
- (or (window-coordinates->mark window x y)
- (buffer-end (window-buffer window)))))
-
-(define-key 'fundamental button1-down x-move-to-coordinates)
-(define-key 'fundamental button3-down x-switch-to-window)
\ No newline at end of file
+;;;; Mouse Commands
+
+(define-command x-mouse-select
+ "Select window the mouse is on."
+ ()
+ (lambda ()
+ (select-window (button-event/window (current-button-event)))))
+
+(define-command x-mouse-keep-one-window
+ "Select window mouse is on, then kill all other windows."
+ ()
+ (lambda ()
+ ((ref-command x-mouse-select))
+ ((ref-command delete-other-windows))))
+
+(define-command x-mouse-select-and-split
+ "Select window mouse is on, then split it vertically in half."
+ ()
+ (lambda ()
+ ((ref-command x-mouse-select))
+ ((ref-command split-window-vertically) false)))
+
+(define-command x-mouse-set-point
+ "Select window mouse is on, and move point to mouse position."
+ ()
+ (lambda ()
+ (let ((button-event (current-button-event)))
+ (let ((window (button-event/window button-event)))
+ (select-window window)
+ (set-current-point!
+ (or (window-coordinates->mark window
+ (button-event/x button-event)
+ (button-event/y button-event))
+ (buffer-end (window-buffer window))))))))
+
+(define-command x-mouse-set-mark
+ "Select window mouse is on, and set mark at mouse position.
+Display cursor at that position for a second."
+ ()
+ (lambda ()
+ (let ((button-event (current-button-event)))
+ (let ((window (button-event/window button-event)))
+ (select-window window)
+ (let ((mark
+ (or (window-coordinates->mark window
+ (button-event/x button-event)
+ (button-event/y button-event))
+ (buffer-end (window-buffer window)))))
+ (push-current-mark! mark)
+ (mark-flash mark))))))
+
+(define-command x-mouse-show-event
+ "Show the mouse position in the minibuffer."
+ ()
+ (lambda ()
+ (let ((button-event (current-button-event)))
+ (message "window: " (button-event/window button-event)
+ " x: " (button-event/x button-event)
+ " y: " (button-event/y button-event)))))
+
+(define-command x-mouse-ignore
+ "Don't do anything."
+ ()
+ (lambda () unspecific))
+
+;;; Prevent beeps on button-up. If the button isn't bound to
+;;; anything, it will beep on button-down.
+(define-key 'fundamental button1-up 'x-mouse-ignore)
+(define-key 'fundamental button2-up 'x-mouse-ignore)
+(define-key 'fundamental button3-up 'x-mouse-ignore)
+(define-key 'fundamental button4-up 'x-mouse-ignore)
+(define-key 'fundamental button5-up 'x-mouse-ignore)
+
+(define-key 'fundamental button1-down 'x-mouse-set-point)
\ No newline at end of file
projects / mit-scheme.git / commitdiff