From: Chris Hanson Date: Fri, 20 Nov 1992 18:24:55 +0000 (+0000) Subject: Don't update window and icon names unless they have changed. X-Git-Tag: 20090517-FFI~8732 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=6cdff999321a9ded6d6e60b229cd5dd45ac87cc0;p=mit-scheme.git Don't update window and icon names unless they have changed. --- diff --git a/v7/src/edwin/edwin.pkg b/v7/src/edwin/edwin.pkg index a13558f43..3053de72b 100644 --- a/v7/src/edwin/edwin.pkg +++ b/v7/src/edwin/edwin.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: edwin.pkg,v 1.103 1992/11/17 22:52:27 cph Exp $ +$Id: edwin.pkg,v 1.104 1992/11/20 18:24:38 cph Exp $ Copyright (c) 1989-1992 Massachusetts Institute of Technology @@ -905,32 +905,56 @@ MIT in each case. |# (files "xterm") (parent (edwin screen)) (export (edwin) + edwin-variable$x-screen-name-format + edwin-variable$x-screen-name-length + edwin-variable$x-screen-icon-name-format + edwin-variable$x-screen-icon-name-length x-screen-auto-raise xterm-screen/flush! xterm-screen/grab-focus!) (export (edwin x-commands) - screen-xterm) + screen-xterm + xterm-screen/set-icon-name + xterm-screen/set-name) (initialization (initialize-package!))) (define-package (edwin x-commands) (files "xcom") (parent (edwin)) (export (edwin) + edwin-command$x-auto-raise-mode + edwin-command$x-lower-screen + edwin-command$x-mouse-ignore + edwin-command$x-mouse-keep-one-window + edwin-command$x-mouse-select + edwin-command$x-mouse-select-and-split + edwin-command$x-mouse-set-mark + edwin-command$x-mouse-set-point + edwin-command$x-mouse-show-event + edwin-command$x-raise-screen + edwin-command$x-set-background-color + edwin-command$x-set-border-color + edwin-command$x-set-border-width + edwin-command$x-set-cursor-color + edwin-command$x-set-font + edwin-command$x-set-foreground-color + edwin-command$x-set-icon-name + edwin-command$x-set-internal-border-width + edwin-command$x-set-mouse-color + edwin-command$x-set-mouse-shape + edwin-command$x-set-position + edwin-command$x-set-size + edwin-command$x-set-window-name x-button1-down - x-button2-down - x-button3-down - x-button4-down - x-button5-down x-button1-up + x-button2-down x-button2-up + x-button3-down x-button3-up + x-button4-down x-button4-up - x-button5-up - edwin-variable$x-screen-name-format - edwin-variable$x-screen-icon-name-format - edwin-variable$x-screen-icon-name-length) - (export (edwin screen x-screen) - update-xterm-screen-names!)) + x-button5-down + x-button5-up)) (define-package (edwin keys) (files "key") diff --git a/v7/src/edwin/xcom.scm b/v7/src/edwin/xcom.scm index b31ed9c0a..3e2da22d8 100644 --- a/v7/src/edwin/xcom.scm +++ b/v7/src/edwin/xcom.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/xcom.scm,v 1.8 1992/03/26 22:29:37 cph Exp $ +;;; $Id: xcom.scm,v 1.9 1992/11/20 18:24:46 cph Exp $ ;;; ;;; Copyright (c) 1989-92 Massachusetts Institute of Technology ;;; @@ -52,11 +52,9 @@ (x-window-set-cursor-color 2) (x-window-set-font 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) (xterm-x-size 1) @@ -141,53 +139,14 @@ Useful only if `x-screen-name-format' is false." "sSet X window name" (lambda (name) - (x-window-set-name (current-xterm) name))) + (xterm-screen/set-name (selected-screen) 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'." - "edwin") - -(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)))))) + (xterm-screen/set-icon-name (selected-screen) name))) (define-command x-raise-screen "Raise the editor screen so that it is not obscured by other X windows." diff --git a/v7/src/edwin/xterm.scm b/v7/src/edwin/xterm.scm index 5a76a0653..e044a1d32 100644 --- a/v7/src/edwin/xterm.scm +++ b/v7/src/edwin/xterm.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/xterm.scm,v 1.35 1992/09/14 20:14:31 cph Exp $ +;;; $Id: xterm.scm,v 1.36 1992/11/20 18:24:55 cph Exp $ ;;; ;;; Copyright (c) 1989-92 Massachusetts Institute of Technology ;;; @@ -115,7 +115,9 @@ (xterm false read-only true) (display false read-only true) (redisplay-flag true) - (selected? true)) + (selected? true) + (name false) + (icon-name false)) (define screen-list) @@ -152,10 +154,17 @@ (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 (xterm->screen xterm) + (let loop ((screens screen-list)) + (and (not (null? screens)) + (if (eq? xterm (screen-xterm (car screens))) + (car screens) + (loop (cdr screens)))))) + (define-integrable (screen-display screen) (xterm-screen-state/display (screen-state screen))) @@ -171,29 +180,94 @@ (define-integrable (set-screen-selected?! screen selected?) (set-xterm-screen-state/selected?! (screen-state screen) selected?)) -(define (xterm->screen xterm) - (let loop ((screens screen-list)) - (and (not (null? screens)) - (if (eq? xterm (screen-xterm (car screens))) - (car screens) - (loop (cdr screens)))))) +(define-integrable (screen-name screen) + (xterm-screen-state/name (screen-state screen))) + +(define-integrable (set-screen-name! screen name) + (set-xterm-screen-state/name! (screen-state screen) name)) + +(define (xterm-screen/set-name screen name) + (let ((name* (screen-name screen))) + (if (or (not name*) (not (string=? name name*))) + (begin + (set-screen-name! screen name) + (x-window-set-name (screen-xterm screen) name))))) + +(define-integrable (screen-icon-name screen) + (xterm-screen-state/icon-name (screen-state screen))) + +(define-integrable (set-screen-icon-name! screen name) + (set-xterm-screen-state/icon-name! (screen-state screen) name)) + +(define (xterm-screen/set-icon-name screen name) + (let ((name* (screen-icon-name screen))) + (if (or (not name*) (not (string=? name name*))) + (begin + (set-screen-icon-name! screen name) + (x-window-set-icon-name (screen-xterm screen) name))))) (define (xterm-screen/wrap-update! screen thunk) - (dynamic-wind - (lambda () - (xterm-enable-cursor (screen-xterm screen) false)) - thunk - (lambda () - (if (screen-selected? screen) - (let ((xterm (screen-xterm screen))) - (xterm-enable-cursor xterm true) - (xterm-draw-cursor xterm))) - (if (screen-redisplay-flag screen) - (begin - (update-xterm-screen-names! screen) - (set-screen-redisplay-flag! screen false))) - (xterm-screen/flush! screen)))) - + (let ((finished? false)) + (dynamic-wind + (lambda () + (xterm-enable-cursor (screen-xterm screen) false)) + (lambda () + (let ((result (thunk))) + (set! finished? result) + result)) + (lambda () + (if (screen-selected? screen) + (let ((xterm (screen-xterm screen))) + (xterm-enable-cursor xterm true) + (xterm-draw-cursor xterm))) + (if (and finished? (screen-redisplay-flag screen)) + (begin + (update-xterm-screen-names! screen) + (set-screen-redisplay-flag! screen false))) + (xterm-screen/flush! screen))))) + +(define (update-xterm-screen-names! screen) + (let ((window + (if (and (selected-screen? screen) (within-typein-edit?)) + (typein-edit-other-window) + (screen-selected-window screen)))) + (let ((buffer (window-buffer window)) + (update-name + (lambda (set-name format length) + (if format + (set-name + screen + (string-trim-right + (format-modeline-string window format length))))))) + (update-name xterm-screen/set-name + (ref-variable x-screen-name-format buffer) + (ref-variable x-screen-name-length buffer)) + (update-name xterm-screen/set-icon-name + (ref-variable x-screen-icon-name-format buffer) + (ref-variable x-screen-icon-name-length buffer))))) + +(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-name-length + "Maximum length of X window name. +Used only if `x-screen-name-format' is non-false." + 64 + exact-nonnegative-integer?) + +(define-variable x-screen-icon-name-format + "If not false, template for displaying X window icon name. +Has same format as `mode-line-format'." + "edwin") + +(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 + exact-nonnegative-integer?) + (define (xterm-screen/discard! screen) (set! screen-list (delq! screen screen-list)) (x-close-window (screen-xterm screen)))