From: Chris Hanson Date: Wed, 3 Oct 1990 04:56:28 +0000 (+0000) Subject: * X terminal interface extensively changed to use new event-handling X-Git-Tag: 20090517-FFI~11162 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=429fef5a43dbe7e689ec87b08159b4c193c0c61f;p=mit-scheme.git * X terminal interface extensively changed to use new event-handling 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". --- diff --git a/v7/src/edwin/basic.scm b/v7/src/edwin/basic.scm index c8f001b2b..0b6a7c06a 100644 --- a/v7/src/edwin/basic.scm +++ b/v7/src/edwin/basic.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -249,7 +249,7 @@ procedure when it fails to find a command." (keyboard-macro-disable)) (define-integrable (editor-beep) - (screen-beep (current-screen))) + (screen-beep (selected-screen))) (define (not-implemented) (editor-error "Not yet implemented")) @@ -295,11 +295,13 @@ With prefix arg, silently save all file-visiting buffers, then kill." "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. diff --git a/v7/src/edwin/bufcom.scm b/v7/src/edwin/bufcom.scm index bf4a21a52..3a7be8852 100644 --- a/v7/src/edwin/bufcom.scm +++ b/v7/src/edwin/bufcom.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -76,17 +76,9 @@ specifying a non-existent buffer will cause it to be created." (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." @@ -98,9 +90,13 @@ specifying a non-existent buffer will cause it to be created." "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." @@ -112,7 +108,7 @@ specifying a non-existent buffer will cause it to be created." (region->string (buffer-region (find-buffer buffer)))) (push-current-mark! (current-point)) (set-current-point! point)))) - + (define-command twiddle-buffers "Select previous buffer." () @@ -134,7 +130,7 @@ thus, the least likely buffer for \\[switch-to-buffer] to select by default." (begin (select-buffer previous) (bury-buffer buffer)))))) - + (define-command kill-buffer "One arg, a string or a buffer. Get rid of the specified buffer." "bKill buffer" @@ -164,9 +160,7 @@ thus, the least likely buffer for \\[switch-to-buffer] to select by default." (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))) @@ -197,15 +191,14 @@ Just like what happens when the file is first visited." (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))) @@ -230,7 +223,6 @@ Just like what happens when the file is first visited." (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)))) diff --git a/v7/src/edwin/buffer.scm b/v7/src/edwin/buffer.scm index 5d88908b3..68a54accf 100644 --- a/v7/src/edwin/buffer.scm +++ b/v7/src/edwin/buffer.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -73,13 +73,16 @@ (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) @@ -110,8 +113,7 @@ The buffer is guaranteed to be deselected at that time." (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)))) (define (buffer-modeline-event! buffer type) @@ -261,9 +263,12 @@ The buffer is guaranteed to be deselected at that time." (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) diff --git a/v7/src/edwin/buffrm.scm b/v7/src/edwin/buffrm.scm index 343af46b3..6a94b8d1f 100644 --- a/v7/src/edwin/buffrm.scm +++ b/v7/src/edwin/buffrm.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -185,7 +185,8 @@ (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)) diff --git a/v7/src/edwin/bufwin.scm b/v7/src/edwin/bufwin.scm index d37fc8484..9559230ba 100644 --- a/v7/src/edwin/bufwin.scm +++ b/v7/src/edwin/bufwin.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -157,7 +157,7 @@ and this buffer is not full-screen width." (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!) @@ -463,8 +463,7 @@ and this buffer is not full-screen width." (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) diff --git a/v7/src/edwin/c-mode.scm b/v7/src/edwin/c-mode.scm index c25d54597..726b33e4e 100644 --- a/v7/src/edwin/c-mode.scm +++ b/v7/src/edwin/c-mode.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -93,7 +93,7 @@ Variables controlling indentation style: (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))) (define-key 'c #\linefeed 'reindent-then-newline-and-indent) (define-key 'c #\{ 'electric-c-brace) diff --git a/v7/src/edwin/comred.scm b/v7/src/edwin/comred.scm index 57a2ac425..be5e0ec6d 100644 --- a/v7/src/edwin/comred.scm +++ b/v7/src/edwin/comred.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -55,21 +55,40 @@ (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)) + (define (command-reader #!optional initialization) (define (command-reader-loop) (let ((value (with-command-variables start-next-command))) diff --git a/v7/src/edwin/curren.scm b/v7/src/edwin/curren.scm index b3c1cf36a..12916ef99 100644 --- a/v7/src/edwin/curren.scm +++ b/v7/src/edwin/curren.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -46,121 +46,104 @@ (declare (usual-integrations)) -;;;; 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))) - -;;;; 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))))))) ;;;; 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) @@ -260,11 +243,10 @@ (bufferset-kill-buffer! (current-bufferset) buffer)) (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)) @@ -284,11 +266,13 @@ The buffer is guaranteed to be selected at that time." (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)) diff --git a/v7/src/edwin/decls.scm b/v7/src/edwin/decls.scm index cc8c2d125..d77e0b49a 100644 --- a/v7/src/edwin/decls.scm +++ b/v7/src/edwin/decls.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -95,7 +95,6 @@ MIT in each case. |# "rename" "rgxcmp" "ring" - "screen" "search" "simple" "strpad" @@ -155,6 +154,7 @@ MIT in each case. |# "replaz" "schmod" "scrcom" + "screen" "sercom" "struct" "syntax" @@ -172,8 +172,7 @@ MIT in each case. |# "modwin" "buffrm" "edtfrm" - "winmis" - "rescrn")) + "winmis")) (sf-edwin "grpops" "struct") (sf-edwin "regops" "struct") (sf-edwin "motion" "struct") diff --git a/v7/src/edwin/ed-ffi.scm b/v7/src/edwin/ed-ffi.scm index 4bf82582c..e872bb3ec 100644 --- a/v7/src/edwin/ed-ffi.scm +++ b/v7/src/edwin/ed-ffi.scm @@ -153,8 +153,10 @@ 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) diff --git a/v7/src/edwin/editor.scm b/v7/src/edwin/editor.scm index 6a0890450..560b7b825 100644 --- a/v7/src/edwin/editor.scm +++ b/v7/src/edwin/editor.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -136,14 +136,18 @@ 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) @@ -172,7 +176,7 @@ with the contents of the startup message." (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))))) @@ -242,9 +246,9 @@ This does not affect editor errors or evaluation errors." (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")) diff --git a/v7/src/edwin/edtfrm.scm b/v7/src/edwin/edtfrm.scm index 05b9fd37c..9c3cff380 100644 --- a/v7/src/edwin/edtfrm.scm +++ b/v7/src/edwin/edtfrm.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -55,15 +55,7 @@ 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))) @@ -76,9 +68,6 @@ (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) @@ -89,40 +78,24 @@ (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) @@ -166,22 +139,19 @@ (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*) diff --git a/v7/src/edwin/edtstr.scm b/v7/src/edwin/edtstr.scm index f96218cac..913e81c01 100644 --- a/v7/src/edwin/edtstr.scm +++ b/v7/src/edwin/edtstr.scm @@ -1,6 +1,8 @@ ;;; -*-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 @@ -47,69 +49,41 @@ (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))))) + +(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)) @@ -119,9 +93,11 @@ (define-integrable (current-char-history) (editor-char-history current-editor)) - -(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)) diff --git a/v7/src/edwin/edwin.pkg b/v7/src/edwin/edwin.pkg index 290775de5..af4cc1101 100644 --- a/v7/src/edwin/edwin.pkg +++ b/v7/src/edwin/edwin.pkg @@ -1,6 +1,6 @@ #| -*-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 @@ -205,6 +205,7 @@ MIT in each case. |# (files "screen") (parent (edwin)) (export (edwin) + initialize-screen-root-window! make-screen screen-beep screen-discard! @@ -212,20 +213,32 @@ MIT in each case. |# 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") @@ -249,7 +262,9 @@ MIT in each case. |# (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") @@ -277,28 +292,14 @@ MIT in each case. |# 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 @@ -334,7 +335,17 @@ MIT in each case. |# 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") @@ -370,6 +381,7 @@ MIT in each case. |# 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) @@ -380,6 +392,7 @@ MIT in each case. |# command-history-list command-message-receive command-reader + command-reader/reset-and-execute current-command current-command-char dispatch-on-char @@ -414,7 +427,6 @@ MIT in each case. |# reset-command-prompt! set-command-prompt! set-editor-input-port! - set-reader-do-before-next-read! temporary-message with-editor-input-port)) @@ -438,11 +450,14 @@ MIT in each case. |# 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") diff --git a/v7/src/edwin/filcom.scm b/v7/src/edwin/filcom.scm index 229c540d4..f41be1653 100644 --- a/v7/src/edwin/filcom.scm +++ b/v7/src/edwin/filcom.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -53,7 +53,7 @@ (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)))) diff --git a/v7/src/edwin/info.scm b/v7/src/edwin/info.scm index 0158b54f9..e510794b6 100644 --- a/v7/src/edwin/info.scm +++ b/v7/src/edwin/info.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -243,7 +243,7 @@ s Search through this Info file for specified regexp, (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)))) diff --git a/v7/src/edwin/input.scm b/v7/src/edwin/input.scm index d22a8e3a7..43f3a2f16 100644 --- a/v7/src/edwin/input.scm +++ b/v7/src/edwin/input.scm @@ -1,6 +1,6 @@ ;;; -*-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 ;;; @@ -172,12 +172,6 @@ B 3BAB8C (if (not command-prompt-displayed?) (clear-message!))))) -;; 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) @@ -185,7 +179,8 @@ B 3BAB8C (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)) @@ -240,39 +235,4 @@ B 3BAB8C (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)))))) - -#| 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 diff --git a/v7/src/edwin/iserch.scm b/v7/src/edwin/iserch.scm index 189f66d61..10b5a6fe4 100644 --- a/v7/src/edwin/iserch.scm +++ b/v7/src/edwin/iserch.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -52,11 +52,14 @@ (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)) diff --git a/v7/src/edwin/loadef.scm b/v7/src/edwin/loadef.scm index 763048ded..5b1dfa866 100644 --- a/v7/src/edwin/loadef.scm +++ b/v7/src/edwin/loadef.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -132,16 +132,6 @@ Previous contents of that buffer are killed first.") (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.") ;;;; Tags Package @@ -195,8 +185,8 @@ replace with the command \\[tags-loop-continue].") "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))) @@ -208,8 +198,8 @@ replace with the command \\[tags-loop-continue].") "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." @@ -234,8 +224,8 @@ modified version of TeX input format.") "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)) (define-library 'C-MODE '("c-mode" (EDWIN)) @@ -275,8 +265,8 @@ Variables controlling indentation style: "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." diff --git a/v7/src/edwin/make.scm b/v7/src/edwin/make.scm index ea868ab23..041752bf7 100644 --- a/v7/src/edwin/make.scm +++ b/v7/src/edwin/make.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -37,4 +37,4 @@ MIT in each case. |# (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 diff --git a/v7/src/edwin/midas.scm b/v7/src/edwin/midas.scm index f8a1ac94e..48de454e9 100644 --- a/v7/src/edwin/midas.scm +++ b/v7/src/edwin/midas.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -63,7 +63,7 @@ (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 #\; "< ") diff --git a/v7/src/edwin/modefs.scm b/v7/src/edwin/modefs.scm index b16a7b767..255f743d8 100644 --- a/v7/src/edwin/modefs.scm +++ b/v7/src/edwin/modefs.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -56,12 +56,11 @@ All normal editing modes are defined relative to this mode." (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." diff --git a/v7/src/edwin/modlin.scm b/v7/src/edwin/modlin.scm index 54ce2eb95..2151633e3 100644 --- a/v7/src/edwin/modlin.scm +++ b/v7/src/edwin/modlin.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -115,15 +115,15 @@ If #F, the normal method is used." (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) diff --git a/v7/src/edwin/modwin.scm b/v7/src/edwin/modwin.scm index 5cd731c79..35f7fc879 100644 --- a/v7/src/edwin/modwin.scm +++ b/v7/src/edwin/modwin.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -45,15 +45,12 @@ ;;;; Modeline Window (declare (usual-integrations)) - -(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) @@ -68,7 +65,7 @@ (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) @@ -76,30 +73,5 @@ "*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 diff --git a/v7/src/edwin/pasmod.scm b/v7/src/edwin/pasmod.scm index ade8f3498..567548336 100644 --- a/v7/src/edwin/pasmod.scm +++ b/v7/src/edwin/pasmod.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -66,7 +66,7 @@ (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 ") diff --git a/v7/src/edwin/prompt.scm b/v7/src/edwin/prompt.scm index b8ddb4b93..63b3001dd 100644 --- a/v7/src/edwin/prompt.scm +++ b/v7/src/edwin/prompt.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -47,21 +47,11 @@ (declare (usual-integrations)) -(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) @@ -69,11 +59,14 @@ recursive minibuffers." (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 @@ -83,17 +76,17 @@ recursive minibuffers." (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))) @@ -102,14 +95,15 @@ recursive minibuffers." (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) @@ -117,8 +111,24 @@ recursive minibuffers." 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))))) +(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)) diff --git a/v7/src/edwin/schmod.scm b/v7/src/edwin/schmod.scm index 855d3194a..b40292441 100644 --- a/v7/src/edwin/schmod.scm +++ b/v7/src/edwin/schmod.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -78,11 +78,11 @@ normally they record the associated output in a transcript buffer: (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) diff --git a/v7/src/edwin/scrcom.scm b/v7/src/edwin/scrcom.scm index d663b0923..0f84e8690 100644 --- a/v7/src/edwin/scrcom.scm +++ b/v7/src/edwin/scrcom.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -45,21 +45,11 @@ ;;;; Screen Commands (declare (usual-integrations)) - + (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 diff --git a/v7/src/edwin/screen.scm b/v7/src/edwin/screen.scm index 4e1b1c507..04784def3 100644 --- a/v7/src/edwin/screen.scm +++ b/v7/src/edwin/screen.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -50,41 +50,57 @@ (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))))) + (define (using-screen screen thunk) (dynamic-wind (lambda () ((screen-operation/enter! screen) screen)) @@ -94,32 +110,46 @@ (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))))) - -(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?)) + (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)) @@ -136,9 +166,6 @@ ((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)) @@ -146,4 +173,35 @@ ((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 diff --git a/v7/src/edwin/texcom.scm b/v7/src/edwin/texcom.scm index 29d5c7908..29d2e8c8b 100644 --- a/v7/src/edwin/texcom.scm +++ b/v7/src/edwin/texcom.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -49,7 +49,7 @@ (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) @@ -63,8 +63,8 @@ (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))) diff --git a/v7/src/edwin/tximod.scm b/v7/src/edwin/tximod.scm index 157a9be02..0bc241ee9 100644 --- a/v7/src/edwin/tximod.scm +++ b/v7/src/edwin/tximod.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -70,7 +70,7 @@ modified version of TeX input format." (local-set-variable! paragraph-separate (string-append "^\\|^@[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 #\" " ") diff --git a/v7/src/edwin/wincom.scm b/v7/src/edwin/wincom.scm index 5059040e1..1aefb886c 100644 --- a/v7/src/edwin/wincom.scm +++ b/v7/src/edwin/wincom.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -92,7 +92,7 @@ negative args count from the bottom." (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))))))) @@ -460,4 +460,30 @@ Also kills any pop up window it may have created." (if (not (eq? window start)) (begin (window-delete! window) - (loop (window1+ window)))))) \ No newline at end of file + (loop (window1+ window)))))) + +(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 diff --git a/v7/src/edwin/xcom.scm b/v7/src/edwin/xcom.scm index 5898bac65..b910a1c85 100644 --- a/v7/src/edwin/xcom.scm +++ b/v7/src/edwin/xcom.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -48,40 +48,39 @@ (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))) - + (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." @@ -90,7 +89,7 @@ (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." @@ -120,7 +119,7 @@ (if (not (x-window-set-font xterm font)) (editor-error "Unknown font name: " font)) (xterm-set-size xterm x-size y-size))))) - + (define-command x-set-size "Set size of editor screen to WIDTH x HEIGHT." "nScreen width (chars)\nnScreen height (chars)" @@ -138,13 +137,67 @@ "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)))))) (define-command x-set-mouse-shape "Set mouse cursor shape to SHAPE. @@ -245,18 +298,6 @@ When called interactively, completion is available on the input." "watch" "xterm")) -(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))) - ;;;; Mouse Commands (define-command x-mouse-select @@ -330,23 +371,4 @@ Display cursor at that position for a second." (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 diff --git a/v7/src/edwin/xterm.scm b/v7/src/edwin/xterm.scm index 8adffea95..24c2886cc 100644 --- a/v7/src/edwin/xterm.scm +++ b/v7/src/edwin/xterm.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -45,96 +45,119 @@ ;;;; X Terminal (declare (usual-integrations)) - + (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)) + (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)))))) -(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))))) @@ -154,55 +177,51 @@ (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))))))))))) - + (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)) ;;;; Input Port @@ -223,15 +242,8 @@ (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) @@ -276,18 +288,14 @@ (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) @@ -334,91 +342,80 @@ (if (and old-mask pending-interrupt?) (signal-interrupt!)))))) - -;;; 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)))) (define button1-down) (define button2-down) @@ -431,25 +428,19 @@ (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 @@ -458,6 +449,7 @@ 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)) @@ -469,4 +461,4 @@ (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