model -- this requires microcode 11.45 or later.
* `delete-screen' command now works. `create-new-screen' command
removed.
* `save-buffers-kill-scheme' command now prompts for confirmation.
* Changed all "event" hook variables to have event distributors as
their values. Users get access to an event by adding themselves to
the event distributor.
* X screens now update their window and icon names under the control
of the new variables `x-screen-name-format' and
`x-screen-icon-name-format'.
Changes to programming interface:
* Changed names:
current-screen selected-screen
all-windows window-list (replacing old definition)
all-screens screen-list
create-new-frame select-buffer-in-new-screen
screen-window screen-root-window
change-screen select-screen
* `typein-window?' is now true if the window is a typein window of any
screen. Previously it was only true of the typein window of the
selected screen.
* `select-window' and `select-cursor' now work for windows in any
screen, rather than just for the selected screen.
* Changed `make-buffer' to use `editor-default-mode' for new buffers,
rather than `fundamental-mode'.
* New procedure `typein-edit-other-window' returns the non-typein
window that was active immediately before the current typein edit
began.
* New procedure `format-modeline-string' permits more general use of
the formatting language used for `mode-line-format'.
* Implemented `command-reader/reset-and-execute', which aborts to the
top-level command reader and executes a thunk there before reading
the next command. This mechanism replaces the
`set-reader-do-before-next-read!' procedure.
Internal changes:
* Modeline events for each window are now passed to the window's
screen, in case the screen needs them.
* Guaranteed that `buffer-modified' modeline event is only signalled
when the "modified" bit of the buffer changes.
* Eliminated `cursor-moved' modeline event.
* Screens now cache their dimensions. X screens use this cached
information to determine when a screen's size has changed.
* Removed `reader-continuation' stuff, which was commented out anyway.
Current assumption is that, no matter how many screens there are,
there is only one input port. For X, this means that all screens
are on the same display.
* Editor-frame operations are now subsumed by screen operations.
There are no editor-frame operations in the (edwin) package.
* Many references to `update-screens!' changed to be calls to
`update-selected-screen!'.
* Incremental search bullet-proofed to remove its message when it is
aborted by any means.
* `standard-editor-initialization' bullet-proofed against aborts.
* Typein edits must consistenly use `current-typein-bufferset' for
typein buffers.
* Eliminated "rescrn" by moving `toggle-screen-width' into "wincom".
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/basic.scm,v 1.104 1989/08/12 08:31:18 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/basic.scm,v 1.105 1990/10/03 04:53:58 cph Rel $
;;;
-;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
+;;; Copyright (c) 1986, 1989, 1990 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
(keyboard-macro-disable))
(define-integrable (editor-beep)
- (screen-beep (current-screen)))
+ (screen-beep (selected-screen)))
(define (not-implemented)
(editor-error "Not yet implemented"))
"P"
(lambda (no-confirmation?)
(save-some-buffers no-confirmation?)
- (set! edwin-finalization
- (lambda ()
- (set! edwin-finalization false)
- (%exit)))
- ((ref-command suspend-edwin))))
+ (if (prompt-for-yes-or-no? "Kill Scheme")
+ (begin
+ (set! edwin-finalization
+ (lambda ()
+ (set! edwin-finalization false)
+ (%exit)))
+ ((ref-command suspend-edwin))))))
(define-command save-buffers-kill-edwin
"Offer to save each buffer, then kill Edwin, returning to Scheme.
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufcom.scm,v 1.84 1990/08/31 20:11:47 markf Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufcom.scm,v 1.85 1990/10/03 04:54:03 cph Exp $
;;;
-;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
+;;; Copyright (c) 1986, 1989, 1990 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
(define-command switch-to-buffer-in-new-screen
"Select buffer in a new screen."
- (prompt-for-select-buffer "Switch to buffer in a new screen.")
+ (prompt-for-select-buffer "Switch to buffer in new screen")
(lambda (buffer)
- (create-new-frame (find-buffer buffer))))
-
-(define-command create-buffer-in-new-screen
- "Create a new buffer with a given name, and select it in a new screen."
- "sCreate buffer in a new screen"
- (lambda (name)
- (let ((buffer (new-buffer name)))
- (set-buffer-major-mode! buffer (ref-variable editor-default-mode))
- (create-new-frame buffer))))
+ (select-buffer-in-new-screen (find-buffer buffer))))
(define-command switch-to-buffer-other-window
"Select buffer in another window."
"Create a new buffer with a given name, and select it."
"sCreate buffer"
(lambda (name)
- (let ((buffer (new-buffer name)))
- (set-buffer-major-mode! buffer (ref-variable editor-default-mode))
- (select-buffer buffer))))
+ (select-buffer (new-buffer name))))
+
+(define-command create-buffer-in-new-screen
+ "Create a new buffer with a given name, and select it in a new screen."
+ "sCreate buffer in new screen"
+ (lambda (name)
+ (select-buffer-in-new-screen (new-buffer name))))
(define-command insert-buffer
"Insert the contents of a specified buffer at point."
(region->string (buffer-region (find-buffer buffer))))
(push-current-mark! (current-point))
(set-current-point! point))))
-
+\f
(define-command twiddle-buffers
"Select previous buffer."
()
(begin
(select-buffer previous)
(bury-buffer buffer))))))
-\f
+
(define-command kill-buffer
"One arg, a string or a buffer. Get rid of the specified buffer."
"bKill buffer"
(kill-buffer-interactive buffer)
(let ((dummy (new-buffer "*Dummy*")))
(kill-buffer-interactive buffer)
- (set-buffer-major-mode!
- (create-buffer initial-buffer-name)
- (ref-variable editor-default-mode))
+ (create-buffer initial-buffer-name)
(kill-buffer dummy)))))
(buffer-list)))
(write-buffer-interactive buffer)))
(define (new-buffer name)
- (define (search-loop n)
- (let ((new-name (string-append name "<" (write-to-string n) ">")))
- (if (find-buffer new-name)
- (search-loop (1+ n))
- new-name)))
- (create-buffer (let ((buffer (find-buffer name)))
- (if buffer
- (search-loop 2)
- name))))
+ (create-buffer
+ (if (find-buffer name)
+ (let search-loop ((n 2))
+ (let ((new-name (string-append name "<" (write-to-string n) ">")))
+ (if (find-buffer new-name)
+ (search-loop (1+ n))
+ new-name)))
+ name)))
(define (string->temporary-buffer string name)
(let ((buffer (temporary-buffer name)))
(let ((name (prompt-for-buffer-name prompt default-buffer false)))
(or (find-buffer name)
(let ((buffer (create-buffer name)))
- (set-buffer-major-mode! buffer (ref-variable editor-default-mode))
(temporary-message "(New Buffer)")
buffer))))
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/buffer.scm,v 1.136 1989/08/12 08:31:27 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/buffer.scm,v 1.137 1990/10/03 04:54:07 cph Exp $
;;;
-;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
+;;; Copyright (c) 1986, 1989, 1990 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
(unparse-object state (buffer-name buffer)))))
(define-variable buffer-creation-hook
- "If not false, a procedure to call when a new buffer is created.
-The procedure is passed the new buffer as its argument.
+ "An event distributor that is invoked when a new buffer is created.
+The new buffer is passed as its argument.
The buffer is guaranteed to be deselected at that time."
- false)
+ (make-event-distributor))
(define (make-buffer name #!optional mode)
- (let ((mode (if (default-object? mode) (ref-mode-object fundamental) mode)))
+ (let ((mode
+ (if (default-object? mode)
+ (ref-variable editor-default-mode)
+ mode)))
(let ((group (region-group (string->region ""))))
(let ((buffer (%make-buffer)))
(vector-set! buffer buffer-index:name name)
(vector-set! buffer buffer-index:save-length 0)
(vector-set! buffer buffer-index:backed-up? false)
(vector-set! buffer buffer-index:modification-time false)
- (let ((hook (ref-variable buffer-creation-hook)))
- (if hook (hook buffer)))
+ (event-distributor/invoke! (ref-variable buffer-creation-hook) buffer)
buffer))))
\f
(define (buffer-modeline-event! buffer type)
(set-buffer-modified! buffer true))
(define (set-buffer-modified! buffer sense)
- (set-group-modified! (buffer-group buffer) sense)
- (vector-set! buffer buffer-index:auto-save-modified? sense)
- (buffer-modeline-event! buffer 'BUFFER-MODIFIED))
+ (let ((group (buffer-group buffer)))
+ (if (not (eq? sense (group-modified? group)))
+ (begin
+ (set-group-modified! group sense)
+ (vector-set! buffer buffer-index:auto-save-modified? sense)
+ (buffer-modeline-event! buffer 'BUFFER-MODIFIED)))))
(define (buffer-modification-daemon buffer)
(lambda (group start end)
;;; -*-Scheme-*-
;;;
-;;; $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 $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/buffrm.scm,v 1.35 1990/10/03 04:54:12 cph Exp $
;;;
-;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
+;;; Copyright (c) 1986, 1989, 1990 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
(define (window-modeline-event! frame type)
(with-instance-variables buffer-frame frame (type)
(if modeline-inferior
- (=> (inferior-window modeline-inferior) :event! type))))
+ (=> (inferior-window modeline-inferior) :event! type)))
+ (screen-modeline-event! (window-screen frame) frame type))
(define-integrable (window-set-override-message! window message)
(set-override-message! (frame-text-inferior window) message))
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufwin.scm,v 1.283 1989/08/14 10:23:32 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufwin.scm,v 1.284 1990/10/03 04:54:16 cph Exp $
;;;
-;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
+;;; Copyright (c) 1986, 1989, 1990 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
(let ((setup-truncate-lines!
(lambda (variable)
variable ;ignore
- (for-each window-setup-truncate-lines! (all-windows)))))
+ (for-each window-setup-truncate-lines! (window-list)))))
(add-variable-assignment-daemon!
(ref-variable-object truncate-lines)
setup-truncate-lines!)
(begin
(set-inferior-position! cursor-inferior
(%window-mark->coordinates window point))
- (set! point-moved? false)
- (window-modeline-event! superior 'CURSOR-MOVED))
+ (set! point-moved? false))
(if-not-visible window))))
(define (maybe-recenter! window)
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/c-mode.scm,v 1.43 1989/04/28 22:48:10 cph Rel $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/c-mode.scm,v 1.44 1990/10/03 04:54:21 cph Rel $
;;;
-;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
+;;; Copyright (c) 1986, 1989, 1990 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
(local-set-variable! comment-start "/* ")
(local-set-variable! comment-end " */")
(local-set-variable! comment-column 32)
- (if (ref-variable c-mode-hook) ((ref-variable c-mode-hook))))
+ (event-distributor/invoke! (ref-variable c-mode-hook)))
\f
(define-key 'c #\linefeed 'reindent-then-newline-and-indent)
(define-key 'c #\{ 'electric-c-brace)
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/comred.scm,v 1.82 1989/08/29 20:03:49 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/comred.scm,v 1.83 1990/10/03 04:54:25 cph Rel $
;;;
-;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
+;;; Copyright (c) 1986, 1989, 1990 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
(define keyboard-chars-read) ;# of chars read from keyboard
(define command-history)
(define command-history-limit 30)
+(define command-reader-reset-thunk)
+(define command-reader-reset-continuation)
(define (initialize-command-reader!)
(set! keyboard-chars-read 0)
(set! command-history (make-circular-list command-history-limit false))
+ (set! command-reader-reset-thunk false)
unspecific)
(define (top-level-command-reader initialization)
(let loop ((initialization initialization))
(with-keyboard-macro-disabled
(lambda ()
- (intercept-^G-interrupts (lambda () unspecific)
- (lambda ()
- (command-reader initialization)))))
+ (call-with-current-continuation
+ (lambda (continuation)
+ (fluid-let ((command-reader-reset-continuation continuation))
+ (dynamic-wind
+ (lambda () unspecific)
+ (lambda ()
+ (intercept-^G-interrupts (lambda () unspecific)
+ (lambda ()
+ (command-reader initialization))))
+ (lambda ()
+ (let ((thunk command-reader-reset-thunk))
+ (if thunk
+ (begin
+ (set! command-reader-reset-thunk false)
+ (thunk)))))))))))
(loop false)))
+(define (command-reader/reset-and-execute thunk)
+ (set! command-reader-reset-thunk thunk)
+ (command-reader-reset-continuation false))
+\f
(define (command-reader #!optional initialization)
(define (command-reader-loop)
(let ((value (with-command-variables start-next-command)))
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/curren.scm,v 1.87 1990/08/31 20:11:51 markf Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/curren.scm,v 1.88 1990/10/03 04:54:33 cph Exp $
;;;
-;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
+;;; Copyright (c) 1986, 1989, 1990 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
(declare (usual-integrations))
\f
-;;;; Editor frames
-
-(define (change-frame new-frame)
- (set-editor-current-frame-window! current-editor new-frame))
+;;;; Screens
-(define (create-new-frame #!optional buffer)
+(define (select-buffer-in-new-screen buffer)
(without-interrupts
(lambda ()
- (let* ((new-screen (make-editor-screen #f))
- (new-frame
- (make-editor-frame
- new-screen
- (if (default-object? buffer)
- (current-buffer)
- buffer)
- (make-buffer " *Typein-0*"))))
- (set-screen-window! new-screen new-frame)
- (editor-add-screen! current-editor new-screen)
- (editor-add-frame! current-editor new-frame)
- (let ((hook (ref-variable select-buffer-hook)))
- (if hook (hook buffer new-frame)))))))
-
-(define (delete-frame! frame)
- (let ((screen (editor-frame-screen frame)))
- (editor-delete-screen! current-editor screen)
- (editor-delete-frame! current-editor frame)
- (screen-discard! screen)))
-
-(define (delete-current-frame!) (delete-frame! (current-editor-frame)))
-\f
-;;;; Screens
-
-;; This version of change-screen was meant to be used in conjunction
-;; with the reader-continuation stuff in edtfrm.scm and input.scm. But
-;; since that stuff doesn't quite work I'm commenting out this
-;; version.
-#|
-(define (change-screen screen)
- (let ((old-frame (current-editor-frame))
- (my-frame (screen-window screen)))
- (change-frame my-frame)
- (set-editor-input-port! (current-editor-input-port))
- (without-interrupts
- (lambda ()
- (change-local-bindings!
- (window-buffer (editor-frame-selected-window old-frame))
- (window-buffer (editor-frame-selected-window my-frame))
- (lambda () unspecific))))
- (update-screens! #t)
- (change-reading my-frame old-frame)))
-|#
-
-(define (change-screen screen)
- (let ((old-frame (current-editor-frame))
- (my-frame (screen-window screen)))
- (set-reader-do-before-next-read!
- (lambda ()
- (change-frame my-frame)
- (set-editor-input-port! (current-editor-input-port))
- (without-interrupts
- (lambda ()
+ (let ((screen (make-editor-screen)))
+ (initialize-screen-root-window! screen buffer)
+ (editor-add-screen! current-editor screen)
+ (select-screen screen)
+ (event-distributor/invoke! (ref-variable select-buffer-hook)
+ buffer
+ (screen-selected-window screen))))))
+
+(define (select-screen screen)
+ (command-reader/reset-and-execute
+ (lambda ()
+ (without-interrupts
+ (lambda ()
+ (let ((buffer (window-buffer (screen-selected-window screen))))
(change-local-bindings!
- (window-buffer (editor-frame-selected-window old-frame))
- (window-buffer (editor-frame-selected-window my-frame))
- (lambda () unspecific))))
- (update-screens! #t)))
- (^G-signal)))
+ (window-buffer (screen-selected-window (selected-screen)))
+ buffer
+ (lambda () (set-editor-selected-screen! current-editor screen)))
+ (bufferset-select-buffer! (current-bufferset) buffer)))))))
(define (delete-screen! screen)
- (let ((frame (screen-window screen)))
- (editor-delete-frame! current-editor frame)
- (editor-delete-screen! current-editor screen)
- (screen-discard! screen)))
-
-(define (delete-current-screen!) (delete-screen! (current-screen)))
+ (editor-delete-screen! current-editor screen)
+ (screen-discard! screen))
+
+(define (update-screens! display-style)
+ (let loop ((screens (screen-list)))
+ (or (null? screens)
+ (and (not (screen-in-update? (car screens)))
+ (update-screen! (car screens) display-style)
+ (loop (cdr screens))))))
+
+(define (update-selected-screen! display-style)
+ (update-screen! (selected-screen) display-style))
+
+(define-integrable (selected-screen? screen)
+ (eq? screen (selected-screen)))
+
+(define-integrable (current-typein-bufferset)
+ (screen-typein-bufferset (selected-screen)))
+
+(define (screen-next screen)
+ (let ((screens (screen-list)))
+ (let ((s (memq screen screens)))
+ (if (not s)
+ (error "not a member of screen-list" screen))
+ (if (null? (cdr s))
+ (car screens)
+ (cadr s)))))
+
+(define (screen-previous screen)
+ (let ((screens (screen-list)))
+ (if (eq? screen (car screens))
+ (car (last-pair screens))
+ (let loop ((previous screens) (screens (cdr screens)))
+ (if (null? screens)
+ (error "not a member of screen-list" screen))
+ (if (eq? screen (car screens))
+ (car previous)
+ (loop screens (cdr screens)))))))
\f
;;;; Windows
(define-integrable (current-window)
- (editor-frame-selected-window (current-editor-frame)))
+ (screen-selected-window (selected-screen)))
+
+(define (window-list)
+ (append-map screen-window-list (screen-list)))
(define-integrable (current-window? window)
(eq? window (current-window)))
(define-integrable (window0)
- (editor-frame-window0 (current-editor-frame)))
+ (screen-window0 (selected-screen)))
(define-integrable (typein-window)
- (editor-frame-typein-window (current-editor-frame)))
+ (screen-typein-window (selected-screen)))
(define-integrable (typein-window? window)
- (eq? window (typein-window)))
+ (eq? window (screen-typein-window (window-screen window))))
(define (select-window window)
(without-interrupts
(lambda ()
- (let ((frame (current-editor-frame))
+ (let ((screen (window-screen window))
(buffer (window-buffer window)))
(change-local-bindings!
- (window-buffer (editor-frame-selected-window frame))
+ (window-buffer (screen-selected-window screen))
buffer
- (lambda ()
- (editor-frame-select-window! frame window)))
+ (lambda () (screen-select-window! screen window)))
(bufferset-select-buffer! (current-bufferset) buffer)))))
(define-integrable (select-cursor window)
- (editor-frame-select-cursor! (current-editor-frame) window))
-
-(define (window-list)
- (let ((window0 (window0)))
- (let loop ((window (window1+ window0)))
- (cons window
- (if (eq? window window0)
- '()
- (loop (window1+ window)))))))
+ (screen-select-cursor! (window-screen window) window))
(define (window-visible? window)
(or (typein-window? window)
(bufferset-kill-buffer! (current-bufferset) buffer))
\f
(define-variable select-buffer-hook
- "If not false, a procedure to call when a buffer is selected.
-The procedure is passed the new buffer and the window in which
-it is selected.
+ "An event distributor that is invoked when a buffer is selected.
+The new buffer and the window in which it is selected are passed as arguments.
The buffer is guaranteed to be selected at that time."
- false)
+ (make-event-distributor))
(define-integrable (select-buffer buffer)
(set-window-buffer! (current-window) buffer true))
(window-buffer window)
buffer
(lambda () (%set-window-buffer! window buffer)))
- (if record? (bufferset-select-buffer! (current-bufferset) buffer)))
- (%set-window-buffer! window buffer))
- (if (not (minibuffer? buffer))
- (let ((hook (ref-variable select-buffer-hook)))
- (if hook (hook buffer window)))))))
+ (if record?
+ (bufferset-select-buffer! (current-bufferset) buffer))
+ (if (not (minibuffer? buffer))
+ (event-distributor/invoke! (ref-variable select-buffer-hook)
+ buffer
+ window)))
+ (%set-window-buffer! window buffer)))))
(define (with-selected-buffer buffer thunk)
(let ((old-buffer))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/decls.scm,v 1.12 1990/09/07 18:39:41 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/decls.scm,v 1.13 1990/10/03 04:54:38 cph Exp $
-Copyright (c) 1989 Massachusetts Institute of Technology
+Copyright (c) 1989, 1990 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
"rename"
"rgxcmp"
"ring"
- "screen"
"search"
"simple"
"strpad"
"replaz"
"schmod"
"scrcom"
+ "screen"
"sercom"
"struct"
"syntax"
"modwin"
"buffrm"
"edtfrm"
- "winmis"
- "rescrn"))
+ "winmis"))
(sf-edwin "grpops" "struct")
(sf-edwin "regops" "struct")
(sf-edwin "motion" "struct")
syntax-table/system-internal)
("schmod" (edwin)
edwin-syntax-table)
+ ("scrcom" (edwin)
+ edwin-syntax-table)
("screen" (edwin screen)
- syntax-table/system-internal)
+ edwin-syntax-table)
("search" (edwin)
syntax-table/system-internal)
("sercom" (edwin)
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/editor.scm,v 1.194 1990/08/31 20:12:00 markf Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/editor.scm,v 1.195 1990/10/03 04:54:47 cph Exp $
;;;
-;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
+;;; Copyright (c) 1986, 1989, 1990 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
unspecific))
(if (not (ref-variable inhibit-startup-message))
(let ((window (current-window)))
- (with-output-to-mark (window-point window)
- write-initial-buffer-greeting!)
(let ((buffer (window-buffer window)))
- (set-window-start-mark! window (buffer-start buffer) false)
- (buffer-not-modified! buffer)
- (sit-for 120000)
- (region-delete! (buffer-unclipped-region buffer))
- (buffer-not-modified! buffer)))))
+ (dynamic-wind
+ (lambda () unspecific)
+ (lambda ()
+ (with-output-to-mark (window-point window)
+ write-initial-buffer-greeting!)
+ (set-window-start-mark! window (buffer-start buffer) false)
+ (buffer-not-modified! buffer)
+ (sit-for 120000))
+ (lambda ()
+ (region-delete! (buffer-unclipped-region buffer))
+ (buffer-not-modified! buffer)))))))
(define inhibit-editor-init-file? false)
(define init-file-loaded? false)
(fluid-let ((current-editor editor)
(recursive-edit-continuation false)
(recursive-edit-level 0))
- (using-screen (current-screen)
+ (using-screen (selected-screen)
(lambda ()
(with-editor-input-port (current-editor-input-port)
thunk)))))
(define (^G-signal)
(let ((continuations *^G-interrupt-continuations*))
- (if (pair? continuations)
- ((car continuations))
- (error "can't signal ^G interrupt"))))
+ (if (not (pair? continuations))
+ (error "can't signal ^G interrupt"))
+ ((car continuations))))
(define (intercept-^G-interrupts interceptor thunk)
(let ((signal-tag "signal-tag"))
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edtfrm.scm,v 1.80 1990/08/31 20:12:04 markf Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edtfrm.scm,v 1.81 1990/10/03 04:54:53 cph Exp $
;;;
-;;; Copyright (c) 1985, 1989 Massachusetts Institute of Technology
+;;; Copyright (c) 1985, 1989, 1990 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
selected-window
cursor-window
select-time
- properties
- typein-bufferset
- input-port
- ;; The reader-continuation is intended to be used to switch
- ;; between reader loops for different editor frames. However,
- ;; its interactions with typein and typeout don't quite work, so
- ;; I'm commenting out the code that deals with this.
- ;reader-continuation
- ))
+ properties))
(define (make-editor-frame root-screen main-buffer typein-buffer)
(let ((window (make-object editor-frame)))
(set! redisplay-flags (list false))
(set! inferiors '())
(set! properties (make-1d-table))
- (set! typein-bufferset (make-bufferset typein-buffer))
- (set! input-port (make-editor-input-port root-screen))
- (bufferset-guarantee-buffer! typein-bufferset typein-buffer)
(let ((main-window (make-buffer-frame window main-buffer true))
(typein-window (make-buffer-frame window typein-buffer false)))
(set! screen root-screen)
(set! select-time 2)
(set-window-select-time! main-window 1)
(=> (window-cursor main-window) :enable!))
- (set-editor-frame-size! window x-size y-size)
-#|
- (set! reader-continuation (lambda (who-cares)
- who-cares ;ignore
- (top-level-command-reader
- (lambda ()
- (initialize-typein!)
- (initialize-typeout!)))))
-|#
- )
+ (set-editor-frame-size! window x-size y-size))
window))
-#|
-(define (set-editor-frame-reader-continuation! window cont)
- (with-instance-variables editor-frame window (cont)
- (set! reader-continuation cont)))
-(define (change-reader new-window old-window)
- (with-instance-variables editor-frame new-window ()
- (switch-reader
- reader-continuation
- (lambda (current-reader)
- (set-editor-frame-reader-continuation!
- old-window
- current-reader)))))
-|#
-(define-method editor-frame (:update-root-display! window display-style)
+(define (editor-frame-update-display! window display-style)
+ ;; Returns true if update is successfully completed (or unnecessary).
(with-instance-variables editor-frame window (display-style)
(with-screen-in-update! screen
(lambda ()
- (if (and (or display-style (car redisplay-flags))
- (update-inferiors! window screen 0 0
- 0 x-size 0 y-size
- display-style))
- (set-car! redisplay-flags false))))))
+ (if (and (not display-style)
+ (not (car redisplay-flags)))
+ true
+ (let ((finished?
+ (update-inferiors! window screen 0 0
+ 0 x-size 0 y-size
+ display-style)))
+ (if finished?
+ (set-car! redisplay-flags false))
+ finished?))))))
(define (set-editor-frame-size! window x y)
(with-instance-variables editor-frame window (x y)
(with-instance-variables editor-frame window ()
screen))
-(define-integrable (editor-frame-typein-bufferset window)
+(define-integrable (editor-frame-properties window)
(with-instance-variables editor-frame window ()
- typein-bufferset))
-
-(define-integrable (editor-frame-input-port window)
- (with-instance-variables editor-frame window ()
- input-port))
+ properties))
(define (editor-frame-windows window)
(cons (editor-frame-typein-window window)
(let ((start (editor-frame-window0 window)))
- (cons start
- (let loop ((window (window1+ start)))
- (if (eq? window start)
- '()
- (cons window (loop (window1+ window)))))))))
+ (let loop ((window start))
+ (cons window
+ (let ((window (window1+ window)))
+ (if (eq? window start)
+ '()
+ (loop window))))))))
(define (editor-frame-select-window! window window*)
(with-instance-variables editor-frame window (window*)
;;; -*-Scheme-*-
;;;
-;;; Copyright (c) 1989 Massachusetts Institute of Technology
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edtstr.scm,v 1.9 1990/10/03 04:54:57 cph Exp $
+;;;
+;;; Copyright (c) 1989, 1990 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
(define-structure (editor (constructor %make-editor))
(name false read-only true)
(screens false)
- (current-frame-window false)
+ (selected-screen false)
(bufferset false read-only true)
(kill-ring false read-only true)
(char-history false read-only true)
- (button-event false)
- (frame-windows false))
+ (input-port false read-only true)
+ (button-event false))
(define (make-editor name screen)
(let ((initial-buffer (make-buffer initial-buffer-name initial-buffer-mode)))
- (let ((bufferset (make-bufferset initial-buffer)))
- (let ((frame
- (make-editor-frame screen
- initial-buffer
- (make-buffer " *Typein-0*"))))
- (set-screen-window! screen frame)
- (%make-editor name
- (list screen)
- frame
- bufferset
- (make-ring 10)
- (make-ring 100)
- false
- (list frame))))))
+ (initialize-screen-root-window! screen initial-buffer)
+ (%make-editor name
+ (list screen)
+ screen
+ (make-bufferset initial-buffer)
+ (make-ring 10)
+ (make-ring 100)
+ (make-editor-input-port screen)
+ false)))
(define (editor-add-screen! editor screen)
- (if (not (memq screen (editor-screens editor)))
- (set-editor-screens! editor
- (cons screen
- (editor-screens editor)))))
+ (set-editor-screens! editor (cons screen (editor-screens editor))))
(define (editor-delete-screen! editor screen)
- (set-editor-screens! editor
- (delq screen
- (editor-screens editor))))
-
-(define (editor-add-frame! editor screen)
- (if (not (memq screen (editor-frame-windows editor)))
- (set-editor-frame-windows! editor
- (cons screen
- (editor-frame-windows editor)))))
-
-(define (editor-delete-frame! editor screen)
- (set-editor-frame-windows! editor
- (delq screen
- (editor-frame-windows editor))))
-
-(define-integrable (current-screen)
- (editor-frame-screen (current-editor-frame)))
-
-(define-integrable (all-screens)
- (editor-screens current-editor))
-
-(define-integrable (current-editor-input-port)
- (editor-frame-input-port (current-editor-frame)))
-
-(define-integrable (current-editor-frame)
- (editor-current-frame-window current-editor))
-
-(define-integrable (all-editor-frames)
- (editor-frame-windows current-editor))
+ (let ((screens (delq! screen (editor-screens editor))))
+ (if (null? screens)
+ (error "deleted only editor screen" editor))
+ (set-editor-screens! editor screens)
+ (if (eq? screen (editor-selected-screen editor))
+ (set-editor-selected-screen! editor (car screens)))))
+\f
+(define (screen-list)
+ (editor-screens (if (within-editor?) current-editor edwin-editor)))
-(define-integrable (all-windows)
- (append-map editor-frame-windows (all-editor-frames)))
+(define-integrable (selected-screen)
+ (editor-selected-screen current-editor))
(define-integrable (current-bufferset)
(editor-bufferset current-editor))
(define-integrable (current-char-history)
(editor-char-history current-editor))
-\f
-(define-structure (button-event
- (conc-name button-event/))
+
+(define-integrable (current-editor-input-port)
+ (editor-input-port current-editor))
+
+(define-structure (button-event (conc-name button-event/))
(window false read-only true)
(x false read-only true)
(y false read-only true))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edwin.pkg,v 1.17 1990/09/12 16:45:01 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edwin.pkg,v 1.18 1990/10/03 04:55:02 cph Exp $
Copyright (c) 1989, 1990 Massachusetts Institute of Technology
(files "screen")
(parent (edwin))
(export (edwin)
+ initialize-screen-root-window!
make-screen
screen-beep
screen-discard!
screen-exit!
screen-flush!
screen-in-update?
- screen-inverse-video!
+ screen-modeline-event!
+ screen-root-window
+ screen-select-cursor!
+ screen-select-window!
+ screen-selected-window
screen-state
- screen-window
- screen-wipe!
+ screen-typein-bufferset
+ screen-typein-window
+ screen-window-list
+ screen-window0
screen-write-char!
screen-write-cursor!
screen-write-substring!
screen-write-substrings!
screen-x-size
screen-y-size
- set-screen-window!
+ set-screen-root-window!
subscreen-clear!
+ update-screen!
using-screen
- with-screen-in-update!))
+ window-screen
+ with-screen-in-update!
+ with-screen-inverse-video!)
+ (export (edwin x-screen)
+ set-screen-x-size!
+ set-screen-y-size!))
(define-package (edwin x-screen)
(files "xterm")
(define-package (edwin x-commands)
(files "xcom")
- (parent (edwin)))
+ (parent (edwin))
+ (export (edwin x-screen)
+ update-xterm-screen-names!))
(define-package (edwin console-screen)
(files "cterm")
button-downify
button-upify
button?
- change-reading
- editor-frame-input-port
- editor-frame-select-cursor!
- editor-frame-select-window!
- editor-frame-selected-window
- editor-frame-typein-window
- editor-frame-typein-bufferset
- editor-frame-window0
- editor-frame-windows
- editor-frame-screen
edwin-variable$cursor-centering-point
edwin-variable$mode-line-inverse-video
edwin-variable$scroll-step
edwin-variable$truncate-lines
edwin-variable$truncate-partial-width-windows
initialize-buttons!
- make-editor-frame
set-window-point!
set-window-start-mark!
- update-screen!
- update-screens!
- update-window-screen!
window-buffer
window-clear-override-message!
window-coordinates->mark
clear-override-message!
frame-text-inferior
home-cursor!
- set-override-message!))
+ set-override-message!)
+ (export (edwin screen)
+ editor-frame-screen
+ editor-frame-select-cursor!
+ editor-frame-select-window!
+ editor-frame-selected-window
+ editor-frame-typein-window
+ editor-frame-update-display!
+ editor-frame-window0
+ editor-frame-windows
+ make-editor-frame))
(define-package (edwin window combination)
(files "comwin")
edwin-variable$mode-line-modified
edwin-variable$mode-line-procedure
edwin-variable$mode-line-process
+ format-modeline-string
modeline-string))
(define-package (edwin command-reader)
command-history-list
command-message-receive
command-reader
+ command-reader/reset-and-execute
current-command
current-command-char
dispatch-on-char
reset-command-prompt!
set-command-prompt!
set-editor-input-port!
- set-reader-do-before-next-read!
temporary-message
with-editor-input-port))
prompt-for-typein
prompt-for-variable
prompt-for-yes-or-no?
+ typein-edit-other-window
within-typein-edit
within-typein-edit?)
(export (edwin keyboard)
clear-message!
- set-message!))
+ set-message!)
+ (export (edwin screen)
+ make-typein-buffer-name))
(define-package (edwin buffer-input-port)
(files "bufinp")
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/filcom.scm,v 1.140 1990/08/31 20:12:39 markf Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/filcom.scm,v 1.141 1990/10/03 04:55:07 cph Exp $
;;;
-;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
+;;; Copyright (c) 1986, 1989, 1990 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
(select-buffer-other-window (find-file-noselect filename true)))
(define (find-file-in-new-screen filename)
- (create-new-frame (find-file-noselect filename true)))
+ (select-buffer-in-new-screen (find-file-noselect filename true)))
(define (find-file-noselect filename warn?)
(let ((pathname (pathname->absolute-pathname (->pathname filename))))
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/info.scm,v 1.94 1989/08/11 11:06:49 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/info.scm,v 1.95 1990/10/03 04:55:12 cph Rel $
;;;
-;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
+;;; Copyright (c) 1986, 1989, 1990 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
(with-selected-buffer buffer
(lambda ()
(let loop ()
- (update-screens! false)
+ (update-selected-screen! false)
(let ((end-visible?
(window-mark-visible? (current-window)
(buffer-end buffer))))
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/input.scm,v 1.83 1990/09/12 02:29:32 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/input.scm,v 1.84 1990/10/03 04:55:17 cph Exp $
;;;
;;; Copyright (c) 1986, 1989, 1990 Massachusetts Institute of Technology
;;;
(if (not command-prompt-displayed?)
(clear-message!)))))
\f
-;; The reader-continuation is intended to be used to switch
-;; between reader loops for different editor frames. However,
-;; its interactions with typein and typeout don't quite work, so
-;; I'm commenting out the code that deals with this.
-;(define *reader-continuation* #f)
-
(define editor-input-port)
(define (with-editor-input-port new-port thunk)
(thunk)))
(define-integrable (set-editor-input-port! new-port)
- (set! editor-input-port new-port))
+ (set! editor-input-port new-port)
+ unspecific)
(define-integrable (keyboard-active? interval)
(char-ready? editor-input-port interval))
(set! command-prompt-displayed? true)
(set-message! command-prompt-string))
(clear-message!))))
- (remap-alias-char
- (let loop ()
- (before-reading-maybe-do-something)
- (let ((char
-#| see comment for *reader-continuation*
- (call-with-current-continuation
- (lambda (continuation)
- (fluid-let ((*reader-continuation* continuation))
-|#
- (read-char editor-input-port)))
-#|
- )))
-|#
- (if (and char (not (eof-object? char)))
- char
- (loop))))))
-\f
-#| see comment for *reader-continuation*
-(define (switch-reader new-reader save-old-reader)
- (if *reader-continuation*
- (save-old-reader *reader-continuation*))
- (if (within-typein-edit?)
- (abort-current-command (lambda () (new-reader #f)))
- (new-reader #f)))
-|#
-
-(define *reader-do-before-next-read* #f)
-
-(define (set-reader-do-before-next-read! to-do)
- (set! *reader-do-before-next-read* to-do))
-
-(define (before-reading-maybe-do-something)
- (if *reader-do-before-next-read*
- (begin
- (*reader-do-before-next-read*)
- (set! *reader-do-before-next-read* #f))))
\ No newline at end of file
+ (remap-alias-char (read-char editor-input-port)))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/iserch.scm,v 1.7 1989/08/09 13:17:41 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/iserch.scm,v 1.8 1990/10/03 04:55:22 cph Rel $
;;;
-;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
+;;; Copyright (c) 1986, 1989, 1990 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
(let ((point (window-point window))
(y-point (window-point-y window)))
(let ((result
- (with-editor-interrupts-disabled
+ (dynamic-wind
+ (lambda () unspecific)
(lambda ()
- (isearch-loop
- (initial-search-state false forward? regexp? point))))))
- (clear-message)
+ (with-editor-interrupts-disabled
+ (lambda ()
+ (isearch-loop
+ (initial-search-state false forward? regexp? point)))))
+ clear-message)))
(cond ((eq? result 'ABORT)
(set-window-point! window point)
(window-scroll-y-absolute! window y-point))
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/loadef.scm,v 1.6 1989/08/14 09:22:45 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/loadef.scm,v 1.7 1990/10/03 04:55:26 cph Rel $
;;;
-;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
+;;; Copyright (c) 1986, 1989, 1990 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
(define-autoload-command 'describe-bindings 'COMMAND-SUMMARY
"Show a list of all defined keys, and their definitions.
The list is put in a buffer, which is displayed.")
-
-(define-library 'RESTRICT-SCREEN
- '("rescrn" (EDWIN WINDOW)))
-
-(define-autoload-command 'toggle-screen-width 'RESTRICT-SCREEN
- "Restrict the editor's width on the screen.
-With no argument, restricts the width to 80 columns,
- unless it is already restricted, in which case it undoes the restriction.
-With \\[universal-argument] only, undoes all restrictions.
-Otherwise, the argument is the number of columns desired.")
\f
;;;; Tags Package
"Enter Midas mode.")
(define-variable midas-mode-hook
- "If not false, a thunk to call when entering Midas mode."
- false)
+ "An event distributor that is invoked when entering Midas mode."
+ (make-event-distributor))
(define-library 'PASCAL-MODE
'("pasmod" (EDWIN)))
"Enter Pascal mode.")
(define-variable pascal-mode-hook
- "If not false, a thunk to call when entering Pascal mode."
- false)
+ "An event distributor that is invoked when entering Pascal mode."
+ (make-event-distributor))
(define-variable pascal-shift-increment
"Indentation increment for Pascal Shift commands."
"Make the current mode be Texinfo mode.")
(define-variable texinfo-mode-hook
- "A procedure to be called when Texinfo mode is entered, or false."
- false)
+ "An event distributor that is invoked when entering Texinfo mode."
+ (make-event-distributor))
\f
(define-library 'C-MODE
'("c-mode" (EDWIN))
"Enter C mode.")
(define-variable c-mode-hook
- "If not false, a thunk to call when entering C mode."
- false)
+ "An event distributor that is invoked when entering C mode."
+ (make-event-distributor))
(define-variable c-indent-level
"Indentation of C statements with respect to containing block."
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/make.scm,v 3.20 1990/09/12 20:12:53 markf Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/make.scm,v 3.21 1990/10/03 04:55:30 cph Exp $
Copyright (c) 1989, 1990 Massachusetts Institute of Technology
(declare (usual-integrations))
(package/system-loader "edwin" '() 'QUERY)
-(add-system! (make-system "Edwin" 3 20 '()))
\ No newline at end of file
+(add-system! (make-system "Edwin" 3 21 '()))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/midas.scm,v 1.14 1989/04/28 22:51:23 cph Rel $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/midas.scm,v 1.15 1990/10/03 04:55:33 cph Rel $
;;;
-;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
+;;; Copyright (c) 1986, 1989, 1990 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
(local-set-variable! paragraph-start "^$")
(local-set-variable! paragraph-separate (ref-variable paragraph-start))
(local-set-variable! indent-line-procedure (ref-command insert-tab))
- (if (ref-variable midas-mode-hook) ((ref-variable midas-mode-hook))))
+ (event-distributor/invoke! (ref-variable midas-mode-hook)))
(define midas-mode:syntax-table (make-syntax-table))
(modify-syntax-entry! midas-mode:syntax-table #\; "< ")
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/modefs.scm,v 1.122 1989/08/14 09:22:49 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/modefs.scm,v 1.123 1990/10/03 04:55:37 cph Rel $
;;;
-;;; Copyright (c) 1985, 1989 Massachusetts Institute of Technology
+;;; Copyright (c) 1985, 1989, 1990 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
(define-major-mode fundamental #f "Fundamental"
"Major mode not specialized for anything in particular.
Most other major modes are defined by comparison to this one."
- (if (ref-variable fundamental-mode-hook)
- ((ref-variable fundamental-mode-hook))))
+ (event-distributor/invoke! (ref-variable fundamental-mode-hook)))
(define-variable fundamental-mode-hook
- "If not false, a thunk to call when entering Fundamental mode."
- false)
+ "An event distributor that is invoked when entering Fundamental mode."
+ (make-event-distributor))
(define-variable editor-default-mode
"The default major mode for new buffers."
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/modlin.scm,v 1.2 1989/08/11 11:28:59 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/modlin.scm,v 1.3 1990/10/03 04:55:41 cph Exp $
;;;
-;;; Copyright (c) 1989 Massachusetts Institute of Technology
+;;; Copyright (c) 1989, 1990 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
(ref-variable-object mode-line-procedure))))
(if procedure
(procedure window)
- (standard-modeline-string window))))
+ (format-modeline-string
+ window
+ (variable-local-value (window-buffer window)
+ (ref-variable-object mode-line-format))
+ (window-x-size window)))))
-(define (standard-modeline-string window)
- (let* ((x-size (window-x-size window))
- (line (string-allocate x-size)))
- (display-mode-element
- (variable-local-value (window-buffer window)
- (ref-variable-object mode-line-format))
- window line 0 x-size x-size)
+(define (format-modeline-string window format size)
+ (let ((line (string-allocate size)))
+ (display-mode-element format window line 0 size size)
line))
(define (display-mode-element element window line column min-end max-end)
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/modwin.scm,v 1.32 1989/08/14 10:23:41 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/modwin.scm,v 1.33 1990/10/03 04:55:45 cph Exp $
;;;
-;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
+;;; Copyright (c) 1986, 1989, 1990 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;;; Modeline Window
(declare (usual-integrations))
-\f
-(define-class modeline-window vanilla-window
- (old-buffer-modified?))
+
+(define-class modeline-window vanilla-window ())
(define-method modeline-window (:initialize! window window*)
(usual=> window :initialize! window*)
- (set! y-size 1)
- (set! old-buffer-modified? 'UNKNOWN)
- unspecific)
+ (set! y-size 1))
(define-method modeline-window (:update-display! window screen x-start y-start
xl xu yl yu display-style)
(if (variable-local-value
(window-buffer superior)
(ref-variable-object mode-line-inverse-video))
- (with-inverse-video! screen thunk)
+ (with-screen-inverse-video! screen thunk)
(thunk))))
true)
"*True means use inverse video, or other suitable display mode, for the mode line."
true)
-(define (with-inverse-video! screen thunk)
- (let ((old-inverse? (screen-inverse-video! screen false))
- (new-inverse? true))
- (screen-inverse-video! screen old-inverse?)
- (dynamic-wind (lambda ()
- (set! old-inverse?
- (screen-inverse-video! screen new-inverse?)))
- thunk
- (lambda ()
- (set! new-inverse?
- (screen-inverse-video! screen old-inverse?))))))
-
(define-method modeline-window (:event! window type)
- (case type
- ((BUFFER-MODIFIED)
- (let ((new (buffer-modified? (window-buffer superior))))
- (if (not (eq? old-buffer-modified? new))
- (begin
- (setup-redisplay-flags! redisplay-flags)
- (set! old-buffer-modified? new)))))
- ((NEW-BUFFER)
- (set! old-buffer-modified? 'UNKNOWN))
- ((CURSOR-MOVED)
- unspecific)
- (else
- (setup-redisplay-flags! redisplay-flags)))
- unspecific)
\ No newline at end of file
+ (setup-redisplay-flags! redisplay-flags))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/pasmod.scm,v 1.42 1989/04/28 22:51:56 cph Rel $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/pasmod.scm,v 1.43 1990/10/03 04:55:48 cph Rel $
;;;
-;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
+;;; Copyright (c) 1986, 1989, 1990 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
(local-set-variable! paragraph-separate (ref-variable "Paragraph Start"))
(local-set-variable! delete-indentation-right-protected (char-set #\( #\[))
(local-set-variable! delete-indentation-left-protected (char-set #\) #\]))
- (if (ref-variable pascal-mode-hook) ((ref-variable pascal-mode-hook))))
+ (event-distributor/invoke! (ref-variable pascal-mode-hook)))
(define pascal-mode:syntax-table (make-syntax-table))
(modify-syntax-entry! pascal-mode:syntax-table #\( "()1 ")
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/prompt.scm,v 1.137 1990/08/31 20:12:48 markf Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/prompt.scm,v 1.138 1990/10/03 04:55:53 cph Exp $
;;;
-;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
+;;; Copyright (c) 1986, 1989, 1990 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
(declare (usual-integrations))
\f
-(define-variable enable-recursive-minibuffers
- "If true, allow minibuffers to invoke commands which use
-recursive minibuffers."
- false)
-
-(define-variable completion-auto-help
- "*True means automatically provide help for invalid completion input."
- true)
-
(define typein-edit-abort-flag "Abort")
-
(define typein-edit-continuation)
(define typein-edit-depth)
(define typein-saved-buffers)
-(define typein-saved-window)
+(define typein-saved-windows)
(define map-name/internal->external)
(define map-name/external->internal)
(set! typein-edit-continuation false)
(set! typein-edit-depth -1)
(set! typein-saved-buffers '())
- (set! typein-saved-window)
+ (set! typein-saved-windows '())
(set! map-name/internal->external identity-procedure)
(set! map-name/external->internal identity-procedure)
unspecific)
+(define (make-typein-buffer-name depth)
+ (string-append " *Typein-" (number->string depth) "*"))
+
(define (within-typein-edit thunk)
(let ((value
(call-with-current-continuation
(typein-saved-buffers
(cons (window-buffer (typein-window))
typein-saved-buffers))
- (typein-saved-window (current-window)))
+ (typein-saved-windows
+ (cons (current-window)
+ typein-saved-windows)))
(dynamic-wind
(lambda ()
(let ((window (typein-window)))
(select-window window)
(select-buffer
(bufferset-find-or-create-buffer
- (editor-frame-typein-bufferset (current-editor-frame))
- (string-append " *Typein-"
- (number->string typein-edit-depth)
- "*")))
+ (current-typein-bufferset)
+ (make-typein-buffer-name typein-edit-depth)))
(buffer-reset! (current-buffer))
(reset-command-prompt!)
(window-clear-override-message! window)))
(let ((window (typein-window)))
(select-window window)
(let ((buffer (car typein-saved-buffers)))
- (bufferset-guarantee-buffer! (current-bufferset) buffer)
+ (bufferset-guarantee-buffer! (current-typein-bufferset)
+ buffer)
(select-buffer buffer))
(reset-command-prompt!)
(window-clear-override-message! window))
(if (zero? typein-edit-depth)
(buffer-reset! (current-buffer)))
- (cond ((window-visible? typein-saved-window)
- (select-window typein-saved-window))
+ (cond ((window-visible? (car typein-saved-windows))
+ (select-window (car typein-saved-windows)))
((zero? typein-edit-depth)
(select-window (other-window)))))))))))
(if (eq? value typein-edit-abort-flag)
value)))
(define-integrable (within-typein-edit?)
- (not (false? typein-edit-continuation)))
+ (not (null? typein-saved-windows)))
+
+(define (typein-edit-other-window)
+ (let loop ((windows typein-saved-windows))
+ (and (not (null? windows))
+ (if (typein-window? (car windows))
+ (loop (cdr windows))
+ (car windows)))))
\f
+(define-variable enable-recursive-minibuffers
+ "If true, allow minibuffers to invoke commands which use
+recursive minibuffers."
+ false)
+
+(define-variable completion-auto-help
+ "*True means automatically provide help for invalid completion input."
+ true)
+
(define (prompt-for-typein prompt-string check-recursion? thunk)
(if (and check-recursion?
(not (ref-variable enable-recursive-minibuffers))
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/schmod.scm,v 1.13 1989/08/09 13:18:07 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/schmod.scm,v 1.14 1990/10/03 04:55:57 cph Rel $
;;;
-;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
+;;; Copyright (c) 1986, 1989, 1990 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
(local-set-variable! paragraph-start "^$")
(local-set-variable! paragraph-separate (ref-variable paragraph-start))
(local-set-variable! indent-line-procedure (ref-command lisp-indent-line))
- (if (ref-variable scheme-mode-hook) ((ref-variable scheme-mode-hook))))
+ (event-distributor/invoke! (ref-variable scheme-mode-hook)))
(define-variable scheme-mode-hook
- "If not false, a thunk to call when entering Scheme mode."
- false)
+ "An event distributor that is invoked when entering Scheme mode."
+ (make-event-distributor))
(define-key 'scheme #\rubout 'backward-delete-char-untabify)
(define-key 'scheme #\tab 'lisp-indent-line)
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/scrcom.scm,v 1.2 1990/09/12 19:56:55 markf Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/scrcom.scm,v 1.3 1990/10/03 04:56:01 cph Rel $
;;;
-;;; Copyright (c) 1987, 1989 Massachusetts Institute of Technology
+;;; Copyright (c) 1990 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;;; Screen Commands
(declare (usual-integrations))
-\f
+
(define-command delete-screen
- "Delete the screen that point is in. If this is the last screen,
-then a message is diplayed and the screen is not deleted."
+ "Delete the screen that point is in."
()
(lambda ()
- (message "Not yet implemented")
-#|
- (if (> (length (all-screens)) 1)
- (delete-current-screen!)
- (message "Can't delete the last screen."))
-|#
- ))
-
-(define-command create-new-screen
- "Create a new screen with the current buffer in it."
- ()
- (lambda () (create-new-frame (current-buffer))))
\ No newline at end of file
+ (if (null? (cdr (screen-list)))
+ (editor-error "Can't delete the only screen"))
+ (delete-screen! (selected-screen))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/screen.scm,v 1.81 1989/04/28 22:53:06 cph Rel $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/screen.scm,v 1.82 1990/10/03 04:56:04 cph Exp $
;;;
-;;; Copyright (c) 1989 Massachusetts Institute of Technology
+;;; Copyright (c) 1989, 1990 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
(constructor make-screen
(state
operation/beep
+ operation/discard!
+ operation/enter!
+ operation/exit!
operation/finish-update!
operation/flush!
operation/inverse-video!
+ operation/modeline-event!
operation/start-update!
operation/subscreen-clear!
+ operation/wipe!
operation/write-char!
operation/write-cursor!
operation/write-substring!
operation/write-substrings!
- operation/x-size
- operation/y-size
- operation/wipe!
- operation/enter!
- operation/exit!
- operation/discard!)))
+ x-size
+ y-size)))
(state false read-only true)
(operation/beep false read-only true)
+ (operation/discard! false read-only true)
+ (operation/enter! false read-only true)
+ (operation/exit! false read-only true)
(operation/finish-update! false read-only true)
(operation/flush! false read-only true)
(operation/inverse-video! false read-only true)
+ (operation/modeline-event! false read-only true)
(operation/start-update! false read-only true)
(operation/subscreen-clear! false read-only true)
+ (operation/wipe! false read-only true)
(operation/write-char! false read-only true)
(operation/write-cursor! false read-only true)
(operation/write-substring! false read-only true)
(operation/write-substrings! false read-only true)
(operation/x-size false read-only true)
(operation/y-size false read-only true)
- (operation/wipe! false read-only true)
- (operation/enter! false read-only true)
- (operation/exit! false read-only true)
- (operation/discard! false read-only true)
- (window false)
- (in-update? false))
-
+ (root-window false)
+ (in-update? false)
+ (x-size false)
+ (y-size false)
+ (typein-bufferset (make-bufferset
+ (make-buffer (make-typein-buffer-name 0)
+ (ref-mode-object fundamental)))
+ read-only true))
+
+(define (initialize-screen-root-window! screen buffer)
+ (set-screen-root-window!
+ screen
+ (make-editor-frame screen
+ buffer
+ (bufferset-find-buffer (screen-typein-bufferset screen)
+ (make-typein-buffer-name 0)))))
+\f
(define (using-screen screen thunk)
(dynamic-wind (lambda ()
((screen-operation/enter! screen) screen))
(define (with-screen-in-update! screen thunk)
(let ((old-flag)
- (new-flag true))
+ (new-flag true)
+ (transition
+ (lambda (old new)
+ (if old
+ (if (not new)
+ ((screen-operation/finish-update! screen) screen))
+ (if new
+ ((screen-operation/start-update! screen) screen))))))
(dynamic-wind (lambda ()
- ((screen-operation/start-update! screen) screen)
(set! old-flag (screen-in-update? screen))
- (set-screen-in-update?! screen new-flag))
+ (set-screen-in-update?! screen new-flag)
+ (transition old-flag new-flag))
thunk
(lambda ()
(set! new-flag (screen-in-update? screen))
(set-screen-in-update?! screen old-flag)
- ((screen-operation/finish-update! screen) screen)))))
-\f
-(define (screen-x-size screen)
- ((screen-operation/x-size screen) screen))
+ (transition new-flag old-flag)))))
-(define (screen-y-size screen)
- ((screen-operation/y-size screen) screen))
+(define (with-screen-inverse-video! screen thunk)
+ (let ((old-highlight?)
+ (new-highlight? true))
+ (dynamic-wind (lambda ()
+ (set! old-highlight?
+ (screen-inverse-video! screen new-highlight?))
+ unspecific)
+ thunk
+ (lambda ()
+ (set! new-highlight?
+ (screen-inverse-video! screen old-highlight?))
+ unspecific))))
+(define (screen-inverse-video! screen highlight?)
+ ((screen-operation/inverse-video! screen) screen highlight?))
+\f
(define (screen-beep screen)
((screen-operation/beep screen) screen))
(define (screen-flush! screen)
((screen-operation/flush! screen) screen))
-(define (screen-inverse-video! screen highlight?)
- ((screen-operation/inverse-video! screen) screen highlight?))
-
(define (subscreen-clear! screen xl xu yl yu)
((screen-operation/subscreen-clear! screen) screen xl xu yl yu))
((screen-operation/write-substrings! screen)
screen x y strings bil biu bjl bju))
-(define (screen-wipe! screen)
- ((screen-operation/wipe! screen) screen))
-
(define (screen-enter! screen)
((screen-operation/enter! screen) screen))
((screen-operation/exit! screen) screen))
(define (screen-discard! screen)
- ((screen-operation/discard! screen) screen))
\ No newline at end of file
+ (for-each (lambda (window) (send window ':kill!))
+ (screen-window-list screen))
+ ((screen-operation/discard! screen) screen))
+
+(define (screen-modeline-event! screen window type)
+ ((screen-operation/modeline-event! screen) screen window type))
+
+(define-integrable (screen-selected-window screen)
+ (editor-frame-selected-window (screen-root-window screen)))
+
+(define-integrable (screen-select-window! screen window)
+ (editor-frame-select-window! (screen-root-window screen) window)
+ (screen-modeline-event! screen window 'SELECT-WINDOW))
+
+(define-integrable (screen-select-cursor! screen window)
+ (editor-frame-select-cursor! (screen-root-window screen) window))
+
+(define-integrable (screen-window-list screen)
+ (editor-frame-windows (screen-root-window screen)))
+
+(define-integrable (screen-window0 screen)
+ (editor-frame-window0 (screen-root-window screen)))
+
+(define-integrable (screen-typein-window screen)
+ (editor-frame-typein-window (screen-root-window screen)))
+
+(define (window-screen window)
+ (editor-frame-screen (window-root-window window)))
+
+(define (update-screen! screen display-style)
+ (if display-style ((screen-operation/wipe! screen) screen))
+ (editor-frame-update-display! (screen-root-window screen) display-style))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/texcom.scm,v 1.32 1989/04/28 22:53:52 cph Rel $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/texcom.scm,v 1.33 1990/10/03 04:56:08 cph Rel $
;;;
-;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
+;;; Copyright (c) 1986, 1989, 1990 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
(define-major-mode text fundamental "Text"
"Major mode for editing english text."
(local-set-variable! syntax-table text-mode:syntax-table)
- (if (ref-variable text-mode-hook) ((ref-variable text-mode-hook))))
+ (event-distributor/invoke! (ref-variable text-mode-hook)))
(define-key 'text #\m-s 'center-line)
(modify-syntax-entry! text-mode:syntax-table #\' "w ")
(define-variable text-mode-hook
- "If not false, a thunk to call when entering Text mode."
- false)
+ "An event distributor that is invoked when entering Text mode."
+ (make-event-distributor))
(define (turn-on-auto-fill)
(enable-current-minor-mode! (ref-mode-object auto-fill)))
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/tximod.scm,v 1.12 1989/04/28 22:54:08 cph Rel $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/tximod.scm,v 1.13 1990/10/03 04:56:12 cph Rel $
;;;
-;;; Copyright (c) 1987, 1989 Massachusetts Institute of Technology
+;;; Copyright (c) 1987, 1989, 1990 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
(local-set-variable! paragraph-separate
(string-append "^\b\\|^@[a-z]*[ \n]\\|"
(ref-variable paragraph-separate)))
- (if (ref-variable texinfo-mode-hook) ((ref-variable texinfo-mode-hook))))
+ (event-distributor/invoke! (ref-variable texinfo-mode-hook)))
(define texinfo-mode:syntax-table (make-syntax-table))
(modify-syntax-entry! texinfo-mode:syntax-table #\" " ")
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/wincom.scm,v 1.96 1989/08/14 10:23:44 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/wincom.scm,v 1.97 1990/10/03 04:56:16 cph Exp $
;;;
-;;; Copyright (c) 1987, 1989 Massachusetts Institute of Technology
+;;; Copyright (c) 1987, 1989, 1990 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
(if (not argument)
(begin
(window-redraw! window false)
- (update-screens! true))
+ (update-selected-screen! true))
(window-scroll-y-absolute!
window
(modulo argument (window-y-size window)))))))
(if (not (eq? window start))
(begin
(window-delete! window)
- (loop (window1+ window))))))
\ No newline at end of file
+ (loop (window1+ window))))))
+\f
+(define-command toggle-screen-width
+ "Restrict the editor's width on the screen.
+With no argument, restricts the width to 80 columns,
+ unless it is already restricted, in which case it undoes the restriction.
+With \\[universal-argument] only, undoes all restrictions.
+Otherwise, the argument is the number of columns desired."
+ "P"
+ (lambda (argument)
+ (let ((screen (selected-screen)))
+ (let ((window (screen-root-window screen)))
+ (send window ':set-size!
+ (let ((x-size (screen-x-size screen)))
+ (cond ((command-argument-multiplier-only?)
+ x-size)
+ ((not argument)
+ (let ((x-size* (window-x-size window)))
+ (if (< x-size* x-size)
+ x-size
+ (min 80 x-size))))
+ (else
+ (if (< argument 10)
+ (editor-error "restriction too small: " argument))
+ (min x-size argument))))
+ (screen-y-size screen)))
+ (update-screen! screen true))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/xcom.scm,v 1.4 1990/08/31 20:13:00 markf Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/xcom.scm,v 1.5 1990/10/03 04:56:24 cph Exp $
;;;
-;;; Copyright (c) 1989 Massachusetts Institute of Technology
+;;; Copyright (c) 1989, 1990 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
(x-close-display 1)
(x-close-all-displays 0)
(x-close-window 1)
- (x-window-x-size 1)
- (x-window-y-size 1)
- (x-window-set-size 3)
- (x-window-set-position 3)
- (x-window-map 1)
- (x-window-unmap 1)
(x-window-beep 1)
(x-window-clear 1)
- (x-window-flush 1)
(x-window-get-default 3)
- (x-window-set-foreground-color 2)
+ (x-window-map 1)
(x-window-set-background-color 2)
(x-window-set-border-color 2)
+ (x-window-set-border-width 2)
(x-window-set-cursor-color 2)
- (x-window-set-mouse-color 2)
- (x-window-set-mouse-shape 2)
(x-window-set-font 2)
- (x-window-set-border-width 2)
+ (x-window-set-foreground-color 2)
+ (x-window-set-icon-name 2)
(x-window-set-internal-border-width 2)
+ (x-window-set-mouse-color 2)
+ (x-window-set-mouse-shape 2)
+ (x-window-set-name 2)
+ (x-window-set-position 3)
+ (x-window-set-size 3)
+ (x-window-unmap 1)
+ (x-window-x-size 1)
+ (x-window-y-size 1)
(xterm-x-size 1)
(xterm-y-size 1)
- (xterm-set-size 3)
- (x-set-window-name 2)
- (x-set-icon-name 2))
+ (xterm-set-size 3))
(define (current-xterm)
- (screen-xterm (current-screen)))
-\f
+ (screen-xterm (selected-screen)))
+
(define-command x-set-foreground-color
"Set foreground (text) color to COLOR."
"sSet foreground color"
(lambda (color)
(x-window-set-foreground-color (current-xterm) color)
- (update-screen! (current-screen) true)))
+ (update-screen! (selected-screen) true)))
(define-command x-set-background-color
"Set background color to COLOR."
(let ((xterm (current-xterm)))
(x-window-set-background-color xterm color)
(x-window-clear xterm))
- (update-screen! (current-screen) true)))
+ (update-screen! (selected-screen) true)))
(define-command x-set-border-color
"Set border color to COLOR."
(if (not (x-window-set-font xterm font))
(editor-error "Unknown font name: " font))
(xterm-set-size xterm x-size y-size)))))
-
+\f
(define-command x-set-size
"Set size of editor screen to WIDTH x HEIGHT."
"nScreen width (chars)\nnScreen height (chars)"
"nSet border width"
(lambda (width)
(x-window-set-border-width (current-xterm) (max 0 width))
- (update-screen! (current-screen) true)))
+ (update-screen! (selected-screen) true)))
(define-command x-set-internal-border-width
"Set width of internal border to WIDTH."
"nSet internal border width"
(lambda (width)
(x-window-set-internal-border-width (current-xterm) (max 0 width))))
+
+(define-command x-set-window-name
+ "Set X window name to NAME.
+Useful only if `x-screen-name-format' is false."
+ "sSet X window name"
+ (lambda (name)
+ (x-window-set-name (current-xterm) name)))
+
+(define-command x-set-icon-name
+ "Set X window icon name to NAME.
+Useful only if `x-screen-icon-name-format' is false."
+ "sSet X window icon name"
+ (lambda (name)
+ (x-window-set-icon-name (current-xterm) name)))
+
+(define-variable x-screen-name-format
+ "If not false, template for displaying X window name.
+Has same format as `mode-line-format'."
+ 'mode-line-buffer-identification)
+
+(define-variable x-screen-icon-name-format
+ "If not false, template for displaying X window icon name.
+Has same format as `mode-line-format'."
+ 'mode-line-buffer-identification)
+
+(define-variable x-screen-icon-name-length
+ "Maximum length of X window icon name.
+Used only if `x-screen-icon-name-format' is non-false."
+ 32)
+
+(define (update-xterm-screen-names! screen)
+ (let ((window
+ (if (and (selected-screen? screen)
+ (within-typein-edit?))
+ (typein-edit-other-window)
+ (screen-selected-window screen)))
+ (xterm (screen-xterm screen)))
+ (let ((update-name
+ (lambda (set-name variable length)
+ (let ((format
+ (variable-local-value (window-buffer window) variable)))
+ (if format
+ (set-name
+ xterm
+ (string-trim-right
+ (format-modeline-string window format length))))))))
+ (update-name x-window-set-name
+ (ref-variable-object x-screen-name-format)
+ (screen-x-size screen))
+ (update-name x-window-set-icon-name
+ (ref-variable-object x-screen-icon-name-format)
+ (variable-local-value
+ (window-buffer window)
+ (ref-variable-object x-screen-icon-name-length))))))
\f
(define-command x-set-mouse-shape
"Set mouse cursor shape to SHAPE.
"watch"
"xterm"))
\f
-(define-command x-set-window-name
- "Set X window name to NAME."
- "sSet X window name"
- (lambda (name)
- (x-set-window-name (current-xterm) name)))
-
-(define-command x-set-icon-name
- "Set X window icon name to NAME."
- "sSet X window icon name"
- (lambda (name)
- (x-set-icon-name (current-xterm) name)))
-\f
;;;; Mouse Commands
(define-command x-mouse-select
(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)
-
-;;; set X window name and X icon name to current buffer name
-(let ((old-hook (ref-variable select-buffer-hook))
- (new-hook
- (lambda (buffer window)
- (if (eq? (editor-display-type) x-display-type-name)
- (let ((xterm
- (screen-xterm
- (editor-frame-screen (window-root-window window))))
- (name (buffer-name buffer)))
- (x-set-window-name xterm name)
- (x-set-icon-name xterm name))))))
- (set-variable!
- select-buffer-hook
- (if old-hook
- (lambda (buffer window)
- (old-hook buffer window)
- (new-hook buffer window))
- new-hook)))
\ No newline at end of file
+(define-key 'fundamental button1-down 'x-mouse-set-point)
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/xterm.scm,v 1.9 1990/08/31 20:13:06 markf Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/xterm.scm,v 1.10 1990/10/03 04:56:28 cph Exp $
;;;
-;;; Copyright (c) 1989 Massachusetts Institute of Technology
+;;; Copyright (c) 1989, 1990 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;;; X Terminal
(declare (usual-integrations))
-\f
+
(define-primitives
(x-open-display 1)
- (x-close-display 1)
(x-close-all-displays 0)
+ (x-close-display 1)
(x-close-window 1)
+ (x-display-flush 1)
+ (x-display-process-events 2)
+ (x-display-sync 2)
(x-window-beep 1)
- (x-window-flush 1)
- (x-window-read-event-flags! 1)
+ (x-window-clear 1)
+ (x-window-display 1)
+ (x-window-set-event-mask 2)
+ (x-window-set-icon-name 2)
+ (x-window-set-name 2)
+ (xterm-clear-rectangle! 6)
+ (xterm-draw-cursor 1)
+ (xterm-erase-cursor 1)
(xterm-open-window 3)
- (xterm-x-size 1)
- (xterm-y-size 1)
+ (xterm-restore-contents 6)
+ (xterm-save-contents 5)
+ (xterm-scroll-lines-down 7)
+ (xterm-scroll-lines-up 7)
(xterm-set-size 3)
- (xterm-write-cursor! 3)
(xterm-write-char! 5)
+ (xterm-write-cursor! 3)
(xterm-write-substring! 7)
- (xterm-clear-rectangle! 6)
- (xterm-read-chars 2)
- (xterm-button 1)
- (xterm-pointer-x 1)
- (xterm-pointer-y 1)
- (x-dequeue-global-event 0)
- (x-window-pixel-coord->char-coord 2)
- (x-set-window-name 2)
- (x-set-icon-name 2))
-
+ (xterm-x-size 1)
+ (xterm-y-size 1))
+\f
(define-structure (xterm-screen-state
- (constructor make-xterm-screen-state (xterm))
+ (constructor make-xterm-screen-state (xterm display))
(conc-name xterm-screen-state/))
(xterm false read-only true)
- (highlight 0))
+ (display false read-only true)
+ (highlight 0)
+ (redisplay-flag true))
+
+(define screen-list)
(define (make-xterm-screen #!optional geometry)
- (let* ((xterm (xterm-open-window (or (get-x-display)
+ (let ((screen
+ (let ((xterm
+ (xterm-open-window (or (get-x-display)
(error "unable to open display"))
(and (not (default-object? geometry))
geometry)
- false))
- (screen (make-screen (make-xterm-screen-state xterm)
- xterm-screen/beep
- xterm-screen/finish-update!
- xterm-screen/flush!
- xterm-screen/inverse-video!
- xterm-screen/start-update!
- xterm-screen/subscreen-clear!
- xterm-screen/write-char!
- xterm-screen/write-cursor!
- xterm-screen/write-substring!
- xterm-screen/write-substrings!
- xterm-screen/x-size
- xterm-screen/y-size
- xterm-screen/wipe!
- xterm-screen/enter!
- xterm-screen/exit!
- xterm-screen/discard!)))
- (add-to-xterm-screen-alist xterm screen)
+ false)))
+ (x-window-set-event-mask xterm event-mask)
+ (make-screen (make-xterm-screen-state xterm
+ (x-window-display xterm))
+ xterm-screen/beep
+ xterm-screen/discard!
+ xterm-screen/enter!
+ xterm-screen/exit!
+ xterm-screen/finish-update!
+ xterm-screen/flush!
+ xterm-screen/inverse-video!
+ xterm-screen/modeline-event!
+ xterm-screen/start-update!
+ xterm-screen/subscreen-clear!
+ xterm-screen/wipe!
+ xterm-screen/write-char!
+ xterm-screen/write-cursor!
+ xterm-screen/write-substring!
+ xterm-screen/write-substrings!
+ (xterm-x-size xterm)
+ (xterm-y-size xterm)))))
+ (set! screen-list (cons screen screen-list))
screen))
(define-integrable (screen-xterm screen)
(xterm-screen-state/xterm (screen-state screen)))
+(define-integrable (screen-display screen)
+ (xterm-screen-state/display (screen-state screen)))
+
(define-integrable (screen-highlight screen)
(xterm-screen-state/highlight (screen-state screen)))
-(define xterm-screen-alist '())
+(define-integrable (set-screen-highlight! screen highlight)
+ (set-xterm-screen-state/highlight! (screen-state screen) highlight))
+
+(define-integrable (screen-redisplay-flag screen)
+ (xterm-screen-state/redisplay-flag (screen-state screen)))
-(define (add-to-xterm-screen-alist xterm screen)
- (set! xterm-screen-alist (cons (cons xterm screen) xterm-screen-alist)))
+(define-integrable (set-screen-redisplay-flag! screen flag)
+ (set-xterm-screen-state/redisplay-flag! (screen-state screen) flag))
(define (xterm->screen xterm)
- (let ((entry (assv xterm xterm-screen-alist)))
- (and entry (cdr entry))))
+ (let loop ((screens screen-list))
+ (and (not (null? screens))
+ (if (eqv? xterm (screen-xterm (car screens)))
+ (car screens)
+ (loop (cdr screens))))))
\f
-(define-integrable (set-screen-highlight! screen highlight)
- (set-xterm-screen-state/highlight! (screen-state screen) highlight))
-
(define (xterm-screen/start-update! screen)
- screen ;ignored
- unspecific)
+ (xterm-erase-cursor (screen-xterm screen)))
(define (xterm-screen/finish-update! screen)
- (x-window-flush (screen-xterm screen)))
+ (xterm-draw-cursor (screen-xterm screen))
+ (if (screen-redisplay-flag screen)
+ (begin
+ (update-xterm-screen-names! screen)
+ (set-screen-redisplay-flag! screen false)))
+ (xterm-screen/flush! screen))
(define (xterm-screen/beep screen)
- (let ((xterm (screen-xterm screen)))
- (x-window-beep xterm)
- (x-window-flush xterm)))
+ (x-window-beep (screen-xterm screen))
+ (xterm-screen/flush! screen))
-(define (xterm-screen/flush! screen)
- (x-window-flush (screen-xterm screen)))
+(define-integrable (xterm-screen/flush! screen)
+ (x-display-flush (screen-display screen)))
(define (xterm-screen/inverse-video! screen highlight?)
(let ((result (not (zero? (screen-highlight screen)))))
(define (xterm-screen/write-substrings! screen x y strings bil biu bjl bju)
(let ((xterm (screen-xterm screen))
(highlight (screen-highlight screen)))
- (clip (xterm-x-size xterm) x bil biu
+ (clip (screen-x-size screen) x bil biu
(lambda (bxl ail aiu)
- (clip (xterm-y-size xterm) y bjl bju
+ (clip (screen-y-size screen) y bjl bju
(lambda (byl ajl aju)
(let loop ((y byl) (j ajl))
- (if (< j aju)
+ (if (fix:< j aju)
(begin
(xterm-write-substring! xterm
bxl y
(vector-ref strings j)
ail aiu
highlight)
- (loop (1+ y) (1+ j)))))))))))
-\f
+ (loop (fix:1+ y) (fix:1+ j)))))))))))
+
(define (clip axu x bil biu receiver)
- (let ((ail (- bil x)))
- (if (< ail biu)
- (let ((aiu (+ ail axu)))
- (cond ((not (positive? x))
- (receiver 0 ail (if (< aiu biu) aiu biu)))
- ((< x axu)
- (receiver x bil (if (< aiu biu) aiu biu))))))))
+ (let ((ail (fix:- bil x)))
+ (if (fix:< ail biu)
+ (let ((aiu (fix:+ ail axu)))
+ (cond ((not (fix:positive? x))
+ (receiver 0 ail (if (fix:< aiu biu) aiu biu)))
+ ((fix:< x axu)
+ (receiver x bil (if (fix:< aiu biu) aiu biu))))))))
(define (xterm-screen/subscreen-clear! screen xl xu yl yu)
(xterm-clear-rectangle! (screen-xterm screen) xl xu yl yu
(screen-highlight screen)))
-(define (xterm-screen/x-size screen)
- (xterm-x-size (screen-xterm screen)))
-
-(define (xterm-screen/y-size screen)
- (xterm-y-size (screen-xterm screen)))
-
(define (xterm-screen/wipe! screen)
- screen ; ignored
- unspecific)
+ (x-window-clear (screen-xterm screen)))
+
+(define (xterm-screen/discard! screen)
+ (set! screen-list (delq! screen screen-list))
+ (x-close-window (screen-xterm screen)))
(define (xterm-screen/enter! screen)
- (if (not (eq? screen (current-screen)))
- (change-screen screen))
+ screen ; ignored
unspecific)
(define (xterm-screen/exit! screen)
screen ; ignored
unspecific)
-(define (xterm-screen/discard! screen)
- screen ; ignored
- (close-x-display))
+(define (xterm-screen/modeline-event! screen window type)
+ window type ; ignored
+ (set-screen-redisplay-flag! screen true))
\f
;;;; Input Port
(string-length (xterm-input-port-state/buffer state)))
true
(let ((buffer
- (let ((screen (xterm-input-port-state/screen state)))
- (if (zero? interval)
- (xterm-screen/read-chars screen 0)
- (let loop ((interval interval))
- (let ((result
- (xterm-screen/read-chars screen interval)))
- (if (integer? result)
- (loop result)
- result)))))))
+ (xterm-screen/read-chars (xterm-input-port-state/screen state)
+ (+ (real-time-clock) interval))))
(and buffer
(begin
(check-for-interrupts! state buffer 0)
\f
(define (refill-buffer! state index)
(let ((screen (xterm-input-port-state/screen state)))
- (let ((buffer (xterm-screen/read-chars screen #f)))
+ (let ((buffer (xterm-screen/read-chars screen false)))
(and buffer
(begin
(check-for-interrupts! state buffer index)
(string-ref buffer 0))))))
-(define (xterm-screen/read-chars screen interval)
- (let ((result (xterm-read-chars (screen-xterm screen) interval)))
- (if (and (not (screen-in-update? screen))
- (xterm-process-events!))
- (update-screens! false))
- result))
+(define-integrable (xterm-screen/read-chars screen time-limit)
+ (process-events! (screen-display screen) time-limit))
(define (check-for-interrupts! state buffer index)
(set-xterm-input-port-state/buffer! state buffer)
(if (and old-mask pending-interrupt?)
(signal-interrupt!))))))
\f
-
-;;; The values of these flags must be equal to the corresponding
-;;; event types in microcode/x11.h
-
-(define-integrable x-event-type:unknown 0)
-(define-integrable x-event-type:resized 1)
-(define-integrable x-event-type:button-down 2)
-(define-integrable x-event-type:button-up 3)
-(define-integrable x-event-type:focus_in 4)
-(define-integrable x-event-type:focus_out 5)
-(define-integrable x-event-type:enter 6)
-(define-integrable x-event-type:leave 7)
-(define-integrable x-event-type:motion 8)
-(define-integrable x-event-type:configure 9)
-(define-integrable x-event-type:map 10)
-(define-integrable x-event-type:unmap 11)
-(define-integrable x-event-type:expose 12)
-(define-integrable x-event-type:no_expose 13)
-(define-integrable x-event-type:graphics_expose 14)
-(define-integrable x-event-type:key_press 15)
-
-(define-integrable xterm-number-of-event-types 16)
-
-(define-integrable event-type car)
-(define-integrable event-xterm cadr)
-(define-integrable event-extra cddr)
-
-(define (xterm-process-events!)
- (let ((event (x-dequeue-global-event)))
- (and event
- (let loop ((event event))
- (if (null? event)
- true
- (let ((event-type (event-type event))
- (screen (xterm->screen (event-xterm event)))
- (extra (event-extra event)))
- (let ((handler (x-event-type->handler event-type)))
- (if handler (apply handler screen extra))
- (if (eq? event-type x-event-type:key_press)
- true
- (loop (x-dequeue-global-event))))))))))
-
-(define xterm-event-handlers
- (make-vector xterm-number-of-event-types false))
-
-(define-integrable (x-event-type->handler event-type)
- (vector-ref xterm-event-handlers event-type))
-
-(define (define-xterm-event-handler event handler)
- (vector-set! xterm-event-handlers event handler)
- unspecific)
-
-(define-xterm-event-handler x-event-type:configure
- (lambda (screen)
- (let ((xterm (screen-xterm screen)))
- (send (screen-window screen) ':set-size!
- (xterm-x-size xterm)
- (xterm-y-size xterm)))))
-
-(define-xterm-event-handler x-event-type:button-down
- (lambda (screen button x y)
- (let ((character-coords
- (x-window-pixel-coord->char-coord
- (screen-xterm screen)
- (cons x y))))
- (send (screen-window screen) ':button-event!
- (button-downify button)
- (car character-coords)
- (cdr character-coords)))))
-
-(define-xterm-event-handler x-event-type:button-up
- (lambda (screen button x y)
- (let ((character-coords
- (x-window-pixel-coord->char-coord
- (screen-xterm screen)
- (cons x y))))
- (send (screen-window screen) ':button-event!
- (button-upify button)
- (car character-coords)
- (cdr character-coords)))))
-
-(define-xterm-event-handler x-event-type:focus_in
- (lambda (screen)
- (xterm-screen/enter! screen)))
-
+;;; The values of these flags must be equal to the corresponding event
+;;; types in "microcode/x11base.c"
+
+(define-integrable event-type:button-down 0)
+(define-integrable event-type:button-up 1)
+(define-integrable event-type:configure 2)
+(define-integrable event-type:enter 3)
+(define-integrable event-type:focus-in 4)
+(define-integrable event-type:focus-out 5)
+(define-integrable event-type:key-press 6)
+(define-integrable event-type:leave 7)
+(define-integrable event-type:motion 8)
+(define-integrable number-of-event-types 9)
+
+;; This mask contains button-down, button-up, configure, focus-in, and
+;; key-press.
+(define-integrable event-mask #x057)
+
+(define (process-events! display time-limit)
+ (let loop ()
+ (let ((event (x-display-process-events display time-limit)))
+ (and event
+ (if (= (vector-ref event 0) event-type:key-press)
+ (vector-ref event 2)
+ (begin
+ (let ((handler
+ (vector-ref event-handlers (vector-ref event 0)))
+ (screen (xterm->screen (vector-ref event 1))))
+ (if (and handler screen)
+ (handler screen event)))
+ (loop)))))))
+
+(define event-handlers
+ (make-vector number-of-event-types false))
+
+(define-integrable (define-event-handler event-type handler)
+ (vector-set! event-handlers event-type handler))
+
+;; These events can cause problems if they are handled during an
+;; update. Unfortunately, there's no mechanism to check for other
+;; events while ignoring these.
+(define-event-handler event-type:configure
+ (lambda (screen event)
+ (let ((x-size (vector-ref event 2))
+ (y-size (vector-ref event 3)))
+ (if (not (and (= x-size (screen-x-size screen))
+ (= y-size (screen-y-size screen))))
+ (begin
+ (set-screen-x-size! screen x-size)
+ (set-screen-y-size! screen y-size)
+ (send (screen-root-window screen) ':set-size! x-size y-size)
+ (update-screen! screen true))))))
+
+(define-event-handler event-type:button-down
+ (lambda (screen event)
+ (send (screen-root-window screen) ':button-event!
+ (button-downify (vector-ref event 4))
+ (vector-ref event 2)
+ (vector-ref event 3))
+ (update-screen! screen false)))
+
+(define-event-handler event-type:button-up
+ (lambda (screen event)
+ (send (screen-root-window screen) ':button-event!
+ (button-upify (vector-ref event 4))
+ (vector-ref event 2)
+ (vector-ref event 3))
+ (update-screen! screen false)))
+
+(define-event-handler event-type:focus-in
+ (lambda (screen event)
+ event
+ (if (not (selected-screen? screen))
+ (select-screen screen))))
\f
(define button1-down)
(define button2-down)
(define button4-up)
(define button5-up)
-;;;; Display description for X displays
-
(define x-display-type)
-(define x-display-data false)
+(define x-display-data)
(define (get-x-display)
(or x-display-data
(let ((display (x-open-display false)))
(set! x-display-data display)
- display)))
-
-(define (close-x-display)
- (x-close-all-displays)
- (set! x-display-data false)
- unspecific)
+ display)))
(define x-display-type-name 'X)
(define (initialize-package!)
+ (set! screen-list '())
(set! x-display-type
(make-display-type x-display-type-name
get-x-display
with-editor-interrupts-from-x
with-x-interrupts-enabled
with-x-interrupts-disabled))
+ (set! x-display-data false)
(initialize-buttons! 5)
(set! button1-down (button-downify 0))
(set! button2-down (button-downify 1))
(set! button3-up (button-upify 2))
(set! button4-up (button-upify 3))
(set! button5-up (button-upify 4))
- unspecific)
+ unspecific)
\ No newline at end of file
projects / mit-scheme.git / commitdiff