;;; -*-Scheme-*-
;;;
-;;; $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 $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/buffrm.scm,v 1.36 1990/10/06 00:15:22 cph Exp $
;;;
;;; Copyright (c) 1986, 1989, 1990 Massachusetts Institute of Technology
;;;
(declare (usual-integrations))
\f
(define-class buffer-frame combination-leaf-window
- (text-inferior border-inferior modeline-inferior last-select-time))
+ (text-inferior
+ border-inferior
+ modeline-inferior
+ last-select-time
+ override-message))
(define-integrable (buffer-frame? object)
(object-of-class? buffer-frame object))
(set! text-inferior (make-inferior frame buffer-window))
(set! border-inferior (make-inferior frame vertical-border-window))
(set! last-select-time 0)
+ (set! override-message false)
unspecific)
;;; **** Kludge: The text-inferior will generate modeline events, so
(=> (inferior-window modeline-inferior) :event! type)))
(screen-modeline-event! (window-screen frame) frame type))
-(define-integrable (window-set-override-message! window message)
+(define (window-set-override-message! window message)
+ (with-instance-variables buffer-frame window (message)
+ (set! override-message message))
(set-override-message! (frame-text-inferior window) message))
-(define-integrable (window-clear-override-message! window)
- (clear-override-message! (frame-text-inferior window)))
+(define (window-clear-override-message! window)
+ (clear-override-message! (frame-text-inferior window))
+ (with-instance-variables buffer-frame window ()
+ (set! override-message false)))
+
+(define (window-override-message window)
+ (with-instance-variables buffer-frame window ()
+ override-message))
(define-integrable (window-home-cursor! window)
(home-cursor! (frame-text-inferior window)))
;;; -*-Scheme-*-
;;;
-;;; $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 $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/curren.scm,v 1.89 1990/10/06 00:15:33 cph Exp $
;;;
;;; Copyright (c) 1986, 1989, 1990 Massachusetts Institute of Technology
;;;
\f
;;;; Screens
-(define (select-buffer-in-new-screen buffer)
+(define (make-screen buffer)
(without-interrupts
(lambda ()
(let ((screen (make-editor-screen)))
- (initialize-screen-root-window! screen buffer)
+ (initialize-screen-root-window! screen (current-bufferset) 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 (screen-selected-window (selected-screen)))
- buffer
- (lambda () (set-editor-selected-screen! current-editor screen)))
- (bufferset-select-buffer! (current-bufferset) buffer)))))))
+ (update-screen! screen false)
+ screen))))
(define (delete-screen! screen)
(editor-delete-screen! current-editor screen)
(screen-discard! screen))
+(define (select-screen screen)
+ (without-interrupts
+ (lambda ()
+ (let ((message (current-message)))
+ (set-current-message! "")
+ (change-selected-buffer
+ (window-buffer (screen-selected-window screen))
+ true
+ (lambda ()
+ (set-editor-selected-screen! current-editor screen)))
+ (set-current-message! message)))))
+
+(define (select-buffer-in-new-screen buffer)
+ (select-screen (make-screen buffer)))
+
(define (update-screens! display-style)
(let loop ((screens (screen-list)))
(or (null? screens)
(define-integrable (selected-screen? screen)
(eq? screen (selected-screen)))
-(define-integrable (current-typein-bufferset)
- (screen-typein-bufferset (selected-screen)))
+(define-integrable (screen0)
+ (car (screen-list)))
-(define (screen-next screen)
+(define (screen1+ screen)
(let ((screens (screen-list)))
(let ((s (memq screen screens)))
(if (not s)
(car screens)
(cadr s)))))
-(define (screen-previous screen)
+(define (screen-1+ screen)
(let ((screens (screen-list)))
(if (eq? screen (car screens))
(car (last-pair screens))
(if (eq? screen (car screens))
(car previous)
(loop screens (cdr screens)))))))
+
+(define (screen+ screen n)
+ (cond ((positive? n)
+ (let loop ((n n) (screen screen))
+ (if (= n 1)
+ (screen1+ screen)
+ (loop (-1+ n) (screen1+ screen)))))
+ ((negative? n)
+ (let loop ((n n) (screen screen))
+ (if (= n -1)
+ (screen-1+ screen)
+ (loop (1+ n) (screen-1+ screen)))))
+ (else
+ screen)))
\f
;;;; Windows
(define-integrable (window0)
(screen-window0 (selected-screen)))
-(define-integrable (typein-window)
- (screen-typein-window (selected-screen)))
-
-(define-integrable (typein-window? window)
- (eq? window (screen-typein-window (window-screen window))))
-
(define (select-window window)
(without-interrupts
(lambda ()
- (let ((screen (window-screen window))
- (buffer (window-buffer window)))
- (change-local-bindings!
- (window-buffer (screen-selected-window screen))
- buffer
- (lambda () (screen-select-window! screen window)))
- (bufferset-select-buffer! (current-bufferset) buffer)))))
+ (let ((screen (window-screen window)))
+ (if (selected-screen? screen)
+ (change-selected-buffer (window-buffer window) true
+ (lambda ()
+ (screen-select-window! screen window)))
+ (screen-select-window! screen window))))))
(define-integrable (select-cursor window)
(screen-select-cursor! (window-screen window) window))
(else
window))))
\f
+(define-integrable (typein-window)
+ (screen-typein-window (selected-screen)))
+
+(define-integrable (typein-window? window)
+ (eq? window (screen-typein-window (window-screen window))))
+
+(define-integrable (current-message)
+ (window-override-message (typein-window)))
+
+(define (set-current-message! message)
+ (let ((window (typein-window)))
+ (if message
+ (window-set-override-message! window message)
+ (window-clear-override-message! window))
+ (if (not *executing-keyboard-macro?*)
+ (window-direct-update! window true))))
+
+(define (clear-current-message!)
+ (let ((window (typein-window)))
+ (window-clear-override-message! window)
+ (if (not *executing-keyboard-macro?*)
+ (window-direct-update! window true))))
+\f
;;;; Buffers
(define-integrable (buffer-list)
- (list-copy (bufferset-buffer-list (current-bufferset))))
+ (bufferset-buffer-list (current-bufferset)))
(define-integrable (buffer-alive? buffer)
- (memq buffer (bufferset-buffer-list (current-bufferset))))
+ (memq buffer (buffer-list)))
(define-integrable (buffer-names)
(bufferset-names (current-bufferset)))
(loop (cdr windows) new-buffer))))
(bufferset-kill-buffer! (current-bufferset) buffer))
\f
-(define-variable select-buffer-hook
- "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."
- (make-event-distributor))
-
(define-integrable (select-buffer buffer)
(set-window-buffer! (current-window) buffer true))
(without-interrupts
(lambda ()
(if (current-window? window)
- (begin
- (change-local-bindings!
- (window-buffer window)
- buffer
- (lambda () (%set-window-buffer! window buffer)))
- (if record?
- (bufferset-select-buffer! (current-bufferset) buffer))
- (if (not (minibuffer? buffer))
- (event-distributor/invoke! (ref-variable select-buffer-hook)
- buffer
- window)))
+ (change-selected-buffer buffer record?
+ (lambda ()
+ (%set-window-buffer! window buffer)))
(%set-window-buffer! window buffer)))))
+(define-variable select-buffer-hook
+ "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."
+ (make-event-distributor))
+
+(define (change-selected-buffer buffer record? selection-thunk)
+ (change-local-bindings! (current-buffer) buffer selection-thunk)
+ (if record?
+ (bufferset-select-buffer! (current-bufferset) buffer))
+ (if (not (minibuffer? buffer))
+ (event-distributor/invoke! (ref-variable select-buffer-hook) buffer)))
+
(define (with-selected-buffer buffer thunk)
(let ((old-buffer))
(dynamic-wind (lambda ()
;;; -*-Scheme-*-
;;;
-;;; $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 $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/editor.scm,v 1.196 1990/10/06 00:15:39 cph Exp $
;;;
;;; Copyright (c) 1986, 1989, 1990 Massachusetts Institute of Technology
;;;
(fluid-let ((current-editor editor)
(recursive-edit-continuation false)
(recursive-edit-level 0))
- (using-screen (selected-screen)
- (lambda ()
- (with-editor-input-port (current-editor-input-port)
- thunk)))))
+ (using-screen (selected-screen) thunk)))
(define (within-editor?)
(not (unassigned? current-editor)))
;;; -*-Scheme-*-
;;;
-;;; $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 $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edtfrm.scm,v 1.82 1990/10/06 00:15:44 cph Exp $
;;;
;;; Copyright (c) 1985, 1989, 1990 Massachusetts Institute of Technology
;;;
(=> (window-cursor cursor-window) :disable!)
(set! cursor-window window*)
(=> (window-cursor cursor-window) :enable!)))
-\f
-;;;; Button Events
(define-method editor-frame (:button-event! editor-frame button x y)
(with-values
(let ((command
(comtab-entry (buffer-comtabs (window-buffer frame))
button)))
- (if command
- (with-current-button-event
- (make-button-event frame relative-x relative-y)
- (lambda () (execute-command command)))
- (editor-beep))))
- ((down-button? button)
- (editor-beep)))))))
-
-(define-integrable (button-upify button-number)
- (vector-ref up-buttons button-number))
-
-(define-integrable (button-downify button-number)
- (vector-ref down-buttons button-number))
-
-(define (button? object)
- (or (up-button? object)
- (down-button? object)))
-
-(define-integrable (up-button? object)
- (vector-find-next-element up-buttons object))
-
-(define-integrable (down-button? object)
- (vector-find-next-element down-buttons object))
-
-(define up-buttons '#())
-(define down-buttons '#())
-
-(define (initialize-buttons! number-of-buttons)
- (set! up-buttons
- (make-initialized-vector number-of-buttons make-up-button))
- (set! down-buttons
- (make-initialized-vector number-of-buttons make-down-button))
- unspecific)
-
-(define (make-down-button button-number)
- (string->symbol
- (string-append "#[button-down-" (number->string button-number) "]")))
-
-(define (make-up-button button-number)
- (string->symbol
- (string-append "#[button-up-" (number->string button-number) "]")))
\ No newline at end of file
+ (cond (command
+ (with-current-button-event
+ (make-button-event frame relative-x relative-y)
+ (lambda () (execute-command command))))
+ ((button/down? button)
+ (editor-beep)))))
+ ((button/down? button)
+ (editor-beep)))))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $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 $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edtstr.scm,v 1.10 1990/10/06 00:15:49 cph Exp $
;;;
;;; Copyright (c) 1989, 1990 Massachusetts Institute of Technology
;;;
(define (make-editor name screen)
(let ((initial-buffer (make-buffer initial-buffer-name initial-buffer-mode)))
- (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)))
+ (let ((bufferset (make-bufferset initial-buffer)))
+ (initialize-screen-root-window! screen bufferset initial-buffer)
+ (%make-editor name
+ (list screen)
+ screen
+ bufferset
+ (make-ring 10)
+ (make-ring 100)
+ (make-editor-input-port screen)
+ false))))
(define (editor-add-screen! editor screen)
- (set-editor-screens! editor (cons screen (editor-screens editor))))
+ (set-editor-screens! editor
+ (append! (editor-screens editor)
+ (list screen))))
(define (editor-delete-screen! editor screen)
(let ((screens (delq! screen (editor-screens editor))))
(set-editor-screens! editor screens)
(if (eq? screen (editor-selected-screen editor))
(set-editor-selected-screen! editor (car screens)))))
-\f
+
(define (screen-list)
(editor-screens (if (within-editor?) current-editor edwin-editor)))
(define-integrable (current-char-history)
(editor-char-history current-editor))
-
-(define-integrable (current-editor-input-port)
- (editor-input-port current-editor))
-
+\f
(define-structure (button-event (conc-name button-event/))
(window false read-only true)
(x false read-only true)
(set! button-event (editor-button-event current-editor))
(set-editor-button-event! current-editor old-button-event)
(set! old-button-event false)
- unspecific))))
\ No newline at end of file
+ unspecific))))
+
+(define button-record-type
+ (make-record-type 'BUTTON '(NUMBER DOWN?)))
+
+(define make-down-button)
+(define make-up-button)
+(let ((%make-button
+ (let ((constructor
+ (record-constructor button-record-type '(NUMBER DOWN?))))
+ (lambda (buttons number down?)
+ (or (vector-ref buttons number)
+ (let ((button (constructor number down?)))
+ (vector-set! buttons number button)
+ button)))))
+ (down-buttons '#())
+ (up-buttons '#()))
+ (set! make-down-button
+ (lambda (number)
+ (if (>= number (vector-length down-buttons))
+ (set! down-buttons (vector-grow down-buttons (1+ number))))
+ (%make-button down-buttons number true)))
+ (set! make-up-button
+ (lambda (number)
+ (if (>= number (vector-length up-buttons))
+ (set! up-buttons (vector-grow up-buttons (1+ number))))
+ (%make-button up-buttons number false))))
+
+(define button?
+ (record-predicate button-record-type))
+
+(define button/number
+ (record-accessor button-record-type 'NUMBER))
+
+(define button/down?
+ (record-accessor button-record-type 'DOWN?))
+
+(define (down-button? object)
+ (and (button? object)
+ (button/down? object)))
+
+(define (up-button? object)
+ (and (button? object)
+ (not (button/down? object))))
+
+(set-record-type-unparser-method! button-record-type
+ (unparser/standard-method (record-type-name button-record-type)
+ (lambda (state button)
+ (unparse-string state (if (button/down? button) "down" "up"))
+ (unparse-char state #\space)
+ (unparse-object state (button/number button)))))
\ No newline at end of file
#| -*-Scheme-*-
-$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 $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edwin.pkg,v 1.19 1990/10/06 00:15:54 cph Exp $
Copyright (c) 1989, 1990 Massachusetts Institute of Technology
(parent (edwin))
(export (edwin)
initialize-screen-root-window!
- make-screen
screen-beep
screen-discard!
screen-enter!
screen-exit!
screen-flush!
+ screen-highlight?
screen-in-update?
screen-modeline-event!
screen-root-window
screen-select-window!
screen-selected-window
screen-state
- screen-typein-bufferset
screen-typein-window
screen-window-list
screen-window0
window-screen
with-screen-in-update!
with-screen-inverse-video!)
+ (export (edwin console-screen)
+ make-screen)
(export (edwin x-screen)
+ make-screen
set-screen-x-size!
set-screen-y-size!))
(files "xterm")
(parent (edwin))
(export (edwin)
- button1-down
- button2-down
- button3-down
- button4-down
- button5-down
- button1-up
- button2-up
- button3-up
- button4-up
- button5-up
- x-display-type
- x-display-type-name)
+ x-display-type)
(export (edwin x-commands)
screen-xterm)
(initialization (initialize-package!)))
(define-package (edwin x-commands)
(files "xcom")
(parent (edwin))
+ (export (edwin)
+ x-button1-down
+ x-button2-down
+ x-button3-down
+ x-button4-down
+ x-button5-down
+ x-button1-up
+ x-button2-up
+ x-button3-up
+ x-button4-up
+ x-button5-up)
(export (edwin x-screen)
update-xterm-screen-names!))
(export ()
reset-editor-windows)
(export (edwin)
- button-downify
- button-upify
- button?
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!
set-window-point!
set-window-start-mark!
window-buffer
window-mark-visible?
window-modeline-event!
window-needs-redisplay?
+ window-override-message
window-point
window-point-coordinates
window-point-x
window-setup-truncate-lines!
window-start-index
window-y-center)
- (export (edwin prompt)
- clear-override-message!
- frame-text-inferior
- home-cursor!
- set-override-message!)
(export (edwin screen)
editor-frame-screen
editor-frame-select-cursor!
message-args->string
reset-command-prompt!
set-command-prompt!
- set-editor-input-port!
- temporary-message
- with-editor-input-port))
+ temporary-message))
(define-package (edwin prompt)
(files "prompt")
typein-edit-other-window
within-typein-edit
within-typein-edit?)
- (export (edwin keyboard)
- clear-message!
- set-message!)
(export (edwin screen)
make-typein-buffer-name))
;;; -*-Scheme-*-
;;;
-;;; $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 $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/input.scm,v 1.85 1990/10/06 00:16:04 cph Exp $
;;;
;;; Copyright (c) 1986, 1989, 1990 Massachusetts Institute of Technology
;;;
(begin
(set! command-prompt-string string)
(if command-prompt-displayed?
- (set-message! string)))))
+ (set-current-message! string)))))
(define (append-command-prompt! string)
(if (not (string-null? string))
(set! command-prompt-displayed? false)))
(set! message-string string)
(set! message-should-be-erased? temporary?)
- (set-message! string))
+ (set-current-message! string))
(define (message-args->string args)
(apply string-append
(error "Attempt to append to nonexistent message"))
(let ((string (string-append message-string (message-args->string args))))
(set! message-string string)
- (set-message! string)))
+ (set-current-message! string)))
(define (clear-message)
(if message-string
(set! message-string false)
(set! message-should-be-erased? false)
(if (not command-prompt-displayed?)
- (clear-message!)))))
+ (clear-current-message!)))))
\f
-(define editor-input-port)
-
-(define (with-editor-input-port new-port thunk)
- (fluid-let ((editor-input-port new-port))
- (thunk)))
-
-(define-integrable (set-editor-input-port! new-port)
- (set! editor-input-port new-port)
- unspecific)
-
(define-integrable (keyboard-active? interval)
- (char-ready? editor-input-port interval))
+ (char-ready? (editor-input-port current-editor) interval))
(define (keyboard-peek-char)
(if *executing-keyboard-macro?*
(keyboard-macro-peek-char)
- (keyboard-read-char-1 peek-char)))
+ (keyboard-read-char-1 input-port/peek-char)))
(define (keyboard-read-char)
(set! keyboard-chars-read (1+ keyboard-chars-read))
(if *executing-keyboard-macro?*
(keyboard-macro-read-char)
- (let ((char (keyboard-read-char-1 read-char)))
+ (let ((char (keyboard-read-char-1 input-port/read-char)))
(set! *auto-save-keystroke-count* (1+ *auto-save-keystroke-count*))
(ring-push! (current-char-history) char)
(if *defining-keyboard-macro?* (keyboard-macro-write-char char))
(keyboard-active? read-char-timeout/slow)
(set! message-string false)
(set! message-should-be-erased? false)
- (clear-message!))))
+ (clear-current-message!))))
((and (or message-should-be-erased?
(and command-prompt-string
(not command-prompt-displayed?)))
(if command-prompt-string
(begin
(set! command-prompt-displayed? true)
- (set-message! command-prompt-string))
- (clear-message!))))
- (remap-alias-char (read-char editor-input-port)))
\ No newline at end of file
+ (set-current-message! command-prompt-string))
+ (clear-current-message!))))
+ (remap-alias-char (read-char (editor-input-port current-editor))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $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 $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/prompt.scm,v 1.139 1990/10/06 00:16:12 cph Rel $
;;;
;;; Copyright (c) 1986, 1989, 1990 Massachusetts Institute of Technology
;;;
(let ((window (typein-window)))
(select-window window)
(select-buffer
- (bufferset-find-or-create-buffer
- (current-typein-bufferset)
+ (find-or-create-buffer
(make-typein-buffer-name typein-edit-depth)))
(buffer-reset! (current-buffer))
(reset-command-prompt!)
(let ((window (typein-window)))
(select-window window)
(let ((buffer (car typein-saved-buffers)))
- (bufferset-guarantee-buffer! (current-typein-bufferset)
- buffer)
+ (bufferset-guarantee-buffer! (current-bufferset) buffer)
(select-buffer buffer))
(reset-command-prompt!)
(window-clear-override-message! window))
(region-delete! (buffer-region (current-buffer)))
(insert-string (map-name/internal->external string))
(if (not dont-update?) (update-typein!))))
-\f
-;;; The following are used by MESSAGE and friends.
-
-(define (set-message! message)
- (let ((window (typein-window)))
- (window-set-override-message! window message)
- (if (not *executing-keyboard-macro?*)
- (window-direct-update! window true))))
-
-(define (clear-message!)
- (let ((window (typein-window)))
- (window-clear-override-message! window)
- (if (not *executing-keyboard-macro?*)
- (window-direct-update! window true))
- (window-direct-update! window true)))
(define (update-typein!)
(if (not *executing-keyboard-macro?*)
;;; -*-Scheme-*-
;;;
-;;; $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 $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/screen.scm,v 1.83 1990/10/06 00:16:20 cph Exp $
;;;
;;; Copyright (c) 1989, 1990 Massachusetts Institute of Technology
;;;
operation/flush!
operation/inverse-video!
operation/modeline-event!
+ operation/normal-video!
operation/start-update!
operation/subscreen-clear!
operation/wipe!
(operation/flush! false read-only true)
(operation/inverse-video! false read-only true)
(operation/modeline-event! false read-only true)
+ (operation/normal-video! false read-only true)
(operation/start-update! false read-only true)
(operation/subscreen-clear! false read-only true)
(operation/wipe! false read-only true)
(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))
+ (highlight? false))
-(define (initialize-screen-root-window! screen buffer)
+(define (initialize-screen-root-window! screen bufferset buffer)
(set-screen-root-window!
screen
- (make-editor-frame screen
- buffer
- (bufferset-find-buffer (screen-typein-bufferset screen)
- (make-typein-buffer-name 0)))))
+ (make-editor-frame
+ screen
+ buffer
+ (bufferset-find-or-create-buffer bufferset (make-typein-buffer-name 0)))))
\f
(define (using-screen screen thunk)
(dynamic-wind (lambda ()
((screen-operation/exit! screen) screen))))
(define (with-screen-in-update! screen thunk)
- (let ((old-flag)
- (new-flag true)
+ (call-with-current-continuation
+ (lambda (continuation)
+ (let ((old-flag)
+ (new-flag true)
+ (transition
+ (lambda (old new)
+ (if old
+ (if (not new)
+ (begin
+ ((screen-operation/finish-update! screen) screen)
+ (set-screen-in-update?! screen false)))
+ (if new
+ (begin
+ ((screen-operation/start-update! screen) screen)
+ (set-screen-in-update?! screen continuation)))))))
+ (dynamic-wind (lambda ()
+ (set! old-flag (screen-in-update? screen))
+ (transition old-flag new-flag))
+ thunk
+ (lambda ()
+ (set! new-flag (screen-in-update? screen))
+ (transition new-flag old-flag)))))))
+
+(define (with-screen-inverse-video! screen thunk)
+ (let ((old-highlight?)
+ (new-highlight? true)
(transition
(lambda (old new)
(if old
(if (not new)
- ((screen-operation/finish-update! screen) screen))
+ (begin
+ ((screen-operation/normal-video! screen) screen)
+ (set-screen-highlight?! screen false)))
(if new
- ((screen-operation/start-update! screen) screen))))))
- (dynamic-wind (lambda ()
- (set! old-flag (screen-in-update? screen))
- (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)
- (transition new-flag old-flag)))))
-
-(define (with-screen-inverse-video! screen thunk)
- (let ((old-highlight?)
- (new-highlight? true))
+ (begin
+ ((screen-operation/inverse-video! screen) screen)
+ (set-screen-highlight?! screen true)))))))
(dynamic-wind (lambda ()
- (set! old-highlight?
- (screen-inverse-video! screen new-highlight?))
- unspecific)
+ (set! old-highlight? (screen-highlight? screen))
+ (transition old-highlight? new-highlight?))
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?))
+ (set! new-highlight? (screen-highlight? screen))
+ (transition new-highlight? old-highlight?)))))
\f
(define (screen-beep screen)
((screen-operation/beep screen) screen))
;;; -*-Scheme-*-
;;;
-;;; $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 $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/xcom.scm,v 1.6 1990/10/06 00:16:28 cph Rel $
;;;
;;; Copyright (c) 1989, 1990 Massachusetts Institute of Technology
;;;
()
(lambda () unspecific))
-;;; Prevent beeps on button-up. If the button isn't bound to
-;;; anything, it will beep on button-down.
-(define-key 'fundamental button1-up 'x-mouse-ignore)
-(define-key 'fundamental button2-up 'x-mouse-ignore)
-(define-key 'fundamental button3-up 'x-mouse-ignore)
-(define-key 'fundamental button4-up 'x-mouse-ignore)
-(define-key 'fundamental button5-up 'x-mouse-ignore)
+(define x-button1-down (make-down-button 0))
+(define x-button2-down (make-down-button 1))
+(define x-button3-down (make-down-button 2))
+(define x-button4-down (make-down-button 3))
+(define x-button5-down (make-down-button 4))
+(define x-button1-up (make-up-button 0))
+(define x-button2-up (make-up-button 1))
+(define x-button3-up (make-up-button 2))
+(define x-button4-up (make-up-button 3))
+(define x-button5-up (make-up-button 4))
-(define-key 'fundamental button1-down 'x-mouse-set-point)
\ No newline at end of file
+(define-key 'fundamental x-button1-down 'x-mouse-set-point)
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/xterm.scm,v 1.10 1990/10/03 04:56:28 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/xterm.scm,v 1.11 1990/10/06 00:16:37 cph Exp $
;;;
;;; Copyright (c) 1989, 1990 Massachusetts Institute of Technology
;;;
(conc-name xterm-screen-state/))
(xterm false read-only true)
(display false read-only true)
- (highlight 0)
(redisplay-flag true))
(define screen-list)
xterm-screen/flush!
xterm-screen/inverse-video!
xterm-screen/modeline-event!
+ xterm-screen/normal-video!
xterm-screen/start-update!
xterm-screen/subscreen-clear!
xterm-screen/wipe!
(xterm-screen-state/display (screen-state screen)))
(define-integrable (screen-highlight screen)
- (xterm-screen-state/highlight (screen-state screen)))
-
-(define-integrable (set-screen-highlight! screen highlight)
- (set-xterm-screen-state/highlight! (screen-state screen) highlight))
+ (if (screen-highlight? screen) 1 0))
(define-integrable (screen-redisplay-flag screen)
(xterm-screen-state/redisplay-flag (screen-state screen)))
(set-screen-redisplay-flag! screen false)))
(xterm-screen/flush! screen))
+(define (xterm-screen/discard! screen)
+ (set! screen-list (delq! screen screen-list))
+ (x-close-window (screen-xterm screen)))
+
+(define (xterm-screen/modeline-event! screen window type)
+ window type ; ignored
+ (set-screen-redisplay-flag! screen true))
+
+(define (xterm-screen/enter! screen)
+ screen ; ignored
+ unspecific)
+
+(define (xterm-screen/exit! screen)
+ screen ; ignored
+ unspecific)
+
+(define (xterm-screen/inverse-video! screen)
+ screen ; ignored
+ unspecific)
+
+(define (xterm-screen/normal-video! screen)
+ screen ; ignored
+ unspecific)
+\f
(define (xterm-screen/beep screen)
(x-window-beep (screen-xterm screen))
(xterm-screen/flush! 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)))))
- (set-screen-highlight! screen (if highlight? 1 0))
- result))
-
(define (xterm-screen/write-char! screen x y char)
(xterm-write-char! (screen-xterm screen) x y char (screen-highlight screen)))
(define (xterm-screen/wipe! screen)
(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)
- screen ; ignored
- unspecific)
-
-(define (xterm-screen/exit! screen)
- screen ; ignored
- unspecific)
-
-(define (xterm-screen/modeline-event! screen window type)
- window type ; ignored
- (set-screen-redisplay-flag! screen true))
\f
;;;; Input Port
(define (make-xterm-input-port screen)
(input-port/copy xterm-input-port-template
- (make-xterm-input-port-state screen)))
+ (make-xterm-input-port-state (screen-display screen))))
(define-structure (xterm-input-port-state
- (constructor make-xterm-input-port-state (screen))
+ (constructor make-xterm-input-port-state (display))
(conc-name xterm-input-port-state/))
- (screen false read-only true)
+ (display false read-only true)
(buffer "")
- (index 0))
+ (index 0)
+ ;; If we receive a non-keypress event while in a display update, we
+ ;; stash it here and abort the update.
+ (pending-event false))
(define (operation/char-ready? port interval)
(let ((state (input-port/state port)))
(if (< (xterm-input-port-state/index state)
(string-length (xterm-input-port-state/buffer state)))
true
- (let ((buffer
- (xterm-screen/read-chars (xterm-input-port-state/screen state)
- (+ (real-time-clock) interval))))
- (and buffer
- (begin
- (check-for-interrupts! state buffer 0)
- true))))))
+ (xterm-read-chars! state (+ (real-time-clock) interval)))))
(define (operation/peek-char port)
(let ((state (input-port/state port)))
(index (xterm-input-port-state/index state)))
(if (< index (string-length buffer))
(string-ref buffer index)
- (refill-buffer! state 0)))))
+ (let ((buffer (xterm-read-chars! state false)))
+ (and buffer
+ (string-ref buffer 0)))))))
(define (operation/discard-char port)
(let ((state (input-port/state port)))
(begin
(set-xterm-input-port-state/index! state (1+ index))
(string-ref buffer index))
- (refill-buffer! state 1)))))
+ (let ((buffer (xterm-read-chars! state false)))
+ (and buffer
+ (begin
+ (set-xterm-input-port-state/index! state 1)
+ (string-ref buffer 0))))))))
(define (operation/print-self state port)
- (unparse-string state "from screen ")
+ (unparse-string state "from display ")
(unparse-object state
- (xterm-input-port-state/screen (input-port/state port))))
+ (xterm-input-port-state/display (input-port/state port))))
(define xterm-input-port-template
(make-input-port `((CHAR-READY? ,operation/char-ready?)
(READ-CHAR ,operation/read-char))
false))
\f
-(define (refill-buffer! state index)
- (let ((screen (xterm-input-port-state/screen state)))
- (let ((buffer (xterm-screen/read-chars screen false)))
- (and buffer
- (begin
- (check-for-interrupts! state buffer index)
- (string-ref buffer 0))))))
-
-(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)
- (let ((^g-index
- (and signal-interrupts?
- (string-find-previous-char buffer #\BEL))))
- (if ^g-index
- (begin
- (set-xterm-input-port-state/index! state (1+ ^g-index))
- (signal-interrupt!))
- (set-xterm-input-port-state/index! state index))))
+;;;; Event Handling
+
+(define (xterm-read-chars! state time-limit)
+ (let ((display (xterm-input-port-state/display state)))
+ (letrec
+ ((loop
+ (lambda ()
+ (let ((event (x-display-process-events display time-limit)))
+ (cond ((not event)
+ false)
+ ((= (vector-ref event 0) event-type:key-press)
+ (let ((buffer (vector-ref event 2)))
+ (set-xterm-input-port-state/buffer! state buffer)
+ (set-xterm-input-port-state/index! state 0)
+ (if signal-interrupts?
+ (let ((^g-index
+ (string-find-previous-char buffer #\BEL)))
+ (if ^g-index
+ (begin
+ (set-xterm-input-port-state/index!
+ state (1+ ^g-index))
+ (signal-interrupt!)))))
+ buffer))
+ (else
+ (process-special-event event))))))
+ (process-special-event
+ (lambda (event)
+ (let ((handler (vector-ref event-handlers (vector-ref event 0)))
+ (screen (xterm->screen (vector-ref event 1))))
+ (if (and handler screen)
+ (begin
+ (let ((continuation (screen-in-update? screen)))
+ (if continuation
+ (begin
+ (set-xterm-input-port-state/pending-event! state
+ event)
+ (continuation false))))
+ (handler screen event))))
+ (loop))))
+ (let ((event (xterm-input-port-state/pending-event state)))
+ (if event
+ (begin
+ (set-xterm-input-port-state/pending-event! state false)
+ (process-special-event event))
+ (loop))))))
(define signal-interrupts?)
(define pending-interrupt?)
;; 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))
(define-event-handler event-type:button-down
(lambda (screen event)
(send (screen-root-window screen) ':button-event!
- (button-downify (vector-ref event 4))
+ (make-down-button (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))
+ (make-up-button (vector-ref event 4))
(vector-ref event 2)
(vector-ref event 3))
(update-screen! screen false)))
(lambda (screen event)
event
(if (not (selected-screen? screen))
- (select-screen screen))))
+ (command-reader/reset-and-execute
+ (lambda ()
+ (select-screen screen))))))
\f
-(define button1-down)
-(define button2-down)
-(define button3-down)
-(define button4-down)
-(define button5-down)
-(define button1-up)
-(define button2-up)
-(define button3-up)
-(define button4-up)
-(define button5-up)
-
(define x-display-type)
(define x-display-data)
(set! x-display-data display)
display)))
-(define x-display-type-name 'X)
-
(define (initialize-package!)
(set! screen-list '())
(set! x-display-type
- (make-display-type x-display-type-name
+ (make-display-type 'X
get-x-display
make-xterm-screen
make-xterm-input-port
with-x-interrupts-enabled
with-x-interrupts-disabled))
(set! x-display-data false)
- (initialize-buttons! 5)
- (set! button1-down (button-downify 0))
- (set! button2-down (button-downify 1))
- (set! button3-down (button-downify 2))
- (set! button4-down (button-downify 3))
- (set! button5-down (button-downify 4))
- (set! button1-up (button-upify 0))
- (set! button2-up (button-upify 1))
- (set! button3-up (button-upify 2))
- (set! button4-up (button-upify 3))
- (set! button5-up (button-upify 4))
unspecific)
\ No newline at end of file
projects / mit-scheme.git / commitdiff