;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufwfs.scm,v 1.7 1989/08/14 09:21:59 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufwfs.scm,v 1.8 1990/10/09 16:23:21 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
(redraw-screen! window 0)))
\f
(define (scroll-lines-down! window inferiors y-start)
+ ;; Returns new list of new inferiors.
(with-instance-variables buffer-window window (inferiors y-start)
- ;; Returns new list of new inferiors.
- (let loop ((inferiors inferiors) (y-start y-start))
- (if (or (null? inferiors)
- (not (fix:< y-start y-size)))
- '()
- (begin
- (set-inferior-start! (car inferiors) 0 y-start)
- (cons (car inferiors)
- (loop (cdr inferiors)
- (inferior-y-end (car inferiors)))))))))
+ (let ((scrolled?
+ (let ((yl (inferior-y-start (car inferiors))))
+ (let ((amount (fix:- y-start yl)))
+ (and (fix:< yl saved-yu)
+ (fix:< amount (fix:- saved-yu saved-yl))
+ (screen-scroll-lines-down! saved-screen
+ (fix:+ saved-xl saved-x-start)
+ (fix:+ saved-xu saved-x-start)
+ (fix:+ (fix:max yl saved-yl)
+ saved-y-start)
+ (fix:+ saved-yu saved-y-start)
+ amount))))))
+ (let loop ((inferiors inferiors) (y-start y-start))
+ (%set-inferior-y-start! (car inferiors) y-start)
+ (if (not scrolled?)
+ (inferior-needs-redisplay! (car inferiors)))
+ (cons (car inferiors)
+ (let ((inferiors (cdr inferiors))
+ (y-start (inferior-y-end (car inferiors))))
+ (if (or (null? inferiors)
+ (not (fix:< y-start y-size)))
+ '()
+ (loop inferiors y-start))))))))
(define (scroll-lines-up! window inferiors y-start start-index)
+ ;; Returns new list of new inferiors.
(with-instance-variables buffer-window window (inferiors y-start start-index)
- ;; Returns new list of new inferiors.
- (let loop
- ((inferiors inferiors) (y-start y-start) (start-index start-index))
- (set-inferior-start! (car inferiors) 0 y-start)
- (cons (car inferiors)
- (if (null? (cdr inferiors))
- (fill-bottom window
- (inferior-y-end (car inferiors))
- (line-end-index (buffer-group buffer)
- start-index))
- (let ((y-start (inferior-y-end (car inferiors))))
- (if (fix:< y-start y-size)
- (loop (cdr inferiors)
- y-start
- (fix:+ start-index
- (line-inferior-length inferiors)))
- '())))))))
\ No newline at end of file
+ (let ((scrolled?
+ (let ((yl (inferior-y-start (car inferiors))))
+ (let ((amount (fix:- yl y-start)))
+ (and (fix:< yl saved-yu)
+ (fix:< amount (fix:- saved-yu saved-yl))
+ (screen-scroll-lines-up! saved-screen
+ (fix:+ saved-xl saved-x-start)
+ (fix:+ saved-xu saved-x-start)
+ (fix:+ (fix:max y-start saved-yl)
+ saved-y-start)
+ (fix:+ saved-yu saved-y-start)
+ amount))))))
+ (let loop
+ ((inferiors inferiors) (y-start y-start) (start-index start-index))
+ (%set-inferior-y-start! (car inferiors) y-start)
+ (if (not scrolled?)
+ (inferior-needs-redisplay! (car inferiors)))
+ (cons (car inferiors)
+ (let ((y-start (inferior-y-end (car inferiors))))
+ (cond ((null? (cdr inferiors))
+ (fill-bottom window
+ y-start
+ (line-end-index (buffer-group buffer)
+ start-index)))
+ ((fix:< y-start y-size)
+ (loop (cdr inferiors)
+ y-start
+ (fix:+ start-index
+ (line-inferior-length inferiors))))
+ (else '()))))))))
+
+(define-integrable (fix:max x y)
+ (if (fix:> x y) x y))
\ No newline at end of file
#| -*-Scheme-*-
-$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 $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/decls.scm,v 1.14 1990/10/09 16:23:47 cph Exp $
Copyright (c) 1989, 1990 Massachusetts Institute of Technology
'("comwin"
"modwin"
"buffrm"
- "edtfrm"
- "winmis"))
+ "edtfrm"))
(sf-edwin "grpops" "struct")
(sf-edwin "regops" "struct")
(sf-edwin "motion" "struct")
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/display.scm,v 1.1 1989/08/12 08:33:51 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/display.scm,v 1.2 1990/10/09 16:23:54 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
\f
(define-structure (display-type
(conc-name display-type/)
- (constructor %make-display-type))
+ (constructor %make-display-type)
+ (print-procedure
+ (unparser/standard-method 'DISPLAY-TYPE
+ (lambda (state display-type)
+ (unparse-object state
+ (display-type/name display-type))))))
(name false read-only true)
+ (multiple-screens? false read-only true)
(operation/available? false read-only true)
(operation/make-screen false read-only true)
(operation/make-input-port false read-only true)
(operation/with-interrupts-disabled false read-only true))
(define (make-display-type name
+ multiple-screens?
available?
make-screen
make-input-port
with-interrupts-disabled)
(let ((display-type
(%make-display-type name
+ multiple-screens?
available?
make-screen
make-input-port
display-type))
(define display-types '())
-(define edwin-display-type false)
(define (display-type/available? display-type)
((display-type/operation/available? display-type)))
-(define (make-editor-screen . args)
- (apply (display-type/operation/make-screen edwin-display-type) args))
+(define (display-type/make-screen display-type args)
+ (apply (display-type/operation/make-screen display-type) args))
-(define (make-editor-input-port screen)
- ((display-type/operation/make-input-port edwin-display-type) screen))
+(define (display-type/make-input-port display-type screen)
+ ((display-type/operation/make-input-port display-type) screen))
-(define (with-editor-interrupts thunk)
- ((display-type/operation/with-interrupt-source edwin-display-type) thunk))
+(define (display-type/with-interrupt-source display-type thunk)
+ ((display-type/operation/with-interrupt-source display-type) thunk))
-(define (with-editor-interrupts-enabled thunk)
- ((display-type/operation/with-interrupts-enabled edwin-display-type) thunk))
+(define (display-type/with-interrupts-enabled display-type thunk)
+ ((display-type/operation/with-interrupts-enabled display-type) thunk))
-(define (with-editor-interrupts-disabled thunk)
- ((display-type/operation/with-interrupts-disabled edwin-display-type) thunk))
-
-(define (initialize-display-type!)
- (set! edwin-display-type
- (cond (edwin-display-type)
- ((display-type/available? x-display-type) x-display-type)
- ((list-search-positive display-types display-type/available?))
- (else (error "No display available"))))
- unspecific)
+(define (display-type/with-interrupts-disabled display-type thunk)
+ ((display-type/operation/with-interrupts-disabled display-type) thunk))
(define (editor-display-types)
- (map display-type/name
- (list-transform-positive display-types display-type/available?)))
-
-(define (editor-display-type)
- (and edwin-display-type (display-type/name edwin-display-type)))
+ (list-transform-positive display-types display-type/available?))
-(define (set-editor-display-type! type-name)
- (set! edwin-display-type
- (and type-name
- (or (list-search-positive display-types
- (lambda (display-type)
- (eq? type-name (display-type/name display-type))))
- (error "Unknown display-type name" type-name))))
- unspecific)
\ No newline at end of file
+(define (name->display-type name)
+ (let ((display-type
+ (list-search-positive display-types
+ (lambda (display-type)
+ (eq? name (display-type/name display-type))))))
+ (if (not display-type)
+ (error "Unknown display-type name" name))
+ display-type))
\ No newline at end of file
edwin-syntax-table)
("window" (edwin window)
class-syntax-table)
- ("winmis" (edwin window)
- class-syntax-table)
("winout" (edwin window-output-port)
syntax-table/system-internal)
("winren" (edwin)
;;; -*-Scheme-*-
;;;
-;;; $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 $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/editor.scm,v 1.197 1990/10/09 16:24:08 cph Exp $
;;;
;;; Copyright (c) 1986, 1989, 1990 Massachusetts Institute of Technology
;;;
(*auto-save-keystroke-count* 0))
(within-editor edwin-editor
(lambda ()
- (with-editor-interrupts
+ (with-current-local-bindings!
(lambda ()
- (with-current-local-bindings!
+ (bind-condition-handler '() internal-error-handler
(lambda ()
- (bind-condition-handler '() internal-error-handler
- (lambda ()
- (dynamic-wind
- (lambda () (update-screens! true))
- (lambda ()
- (let ((cmdl (nearest-cmdl))
- (message (cmdl-message/null)))
- (let ((input-port (cmdl/input-port cmdl)))
- (input-port/immediate-mode input-port
- (lambda ()
- (make-cmdl cmdl
- input-port
- (cmdl/output-port cmdl)
- (lambda (cmdl)
- cmdl ;ignore
- (top-level-command-reader
- edwin-initialization)
- message)
- false
- message))))))
- (lambda () unspecific)))))))))))))
+ (dynamic-wind
+ (lambda () (update-screens! true))
+ (lambda ()
+ (let ((cmdl (nearest-cmdl))
+ (message (cmdl-message/null)))
+ (let ((input-port (cmdl/input-port cmdl)))
+ (input-port/immediate-mode input-port
+ (lambda ()
+ (make-cmdl cmdl
+ input-port
+ (cmdl/output-port cmdl)
+ (lambda (cmdl)
+ cmdl ;ignore
+ (top-level-command-reader
+ edwin-initialization)
+ message)
+ false
+ message))))))
+ (lambda () unspecific)))))))))))
(if edwin-finalization (edwin-finalization))
unspecific)
-(define create-editor-args (list false))
+(define create-editor-args (list 'X))
(define editor-abort)
(define edwin-editor false)
;; reset and then reenter the editor.
(define edwin-finalization false)
\f
-(define (create-editor display-type . make-screen-args)
+(define (create-editor display-type-name . make-screen-args)
(reset-editor)
(initialize-typein!)
(initialize-typeout!)
(initialize-syntax-table!)
(initialize-command-reader!)
- (if display-type
- (set-editor-display-type! display-type)
- (initialize-display-type!))
(set! edwin-editor
- (let ((screen (apply make-editor-screen make-screen-args)))
- (make-editor "Edwin" screen)))
+ (make-editor "Edwin"
+ (name->display-type display-type-name)
+ make-screen-args))
(set! edwin-initialization
(lambda ()
(set! edwin-initialization false)
(screen-discard! screen))
(editor-screens edwin-editor))
(set! edwin-editor false)
+ (set! *previous-popped-up-buffer* (object-hash false))
+ (set! *previous-popped-up-window* (object-hash false))
unspecific)))))
+(define (reset-editor-windows)
+ (for-each (lambda (screen)
+ (send (screen-root-window screen) ':salvage!))
+ (editor-screens edwin-editor)))
+
(define (standard-editor-initialization)
(if (not init-file-loaded?)
(begin
(fluid-let ((current-editor editor)
(recursive-edit-continuation false)
(recursive-edit-level 0))
- (using-screen (selected-screen) thunk)))
+ (dynamic-wind
+ (lambda ()
+ (screen-enter! (selected-screen)))
+ (lambda ()
+ (display-type/with-interrupt-source (editor-display-type editor)
+ thunk))
+ (lambda ()
+ (screen-exit! (selected-screen))))))
(define (within-editor?)
(not (unassigned? current-editor)))
;;; -*-Scheme-*-
;;;
-;;; $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 $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edtstr.scm,v 1.11 1990/10/09 16:24:14 cph Exp $
;;;
;;; Copyright (c) 1989, 1990 Massachusetts Institute of Technology
;;;
\f
(define-structure (editor (constructor %make-editor))
(name false read-only true)
+ (display-type false read-only true)
(screens false)
(selected-screen false)
(bufferset false read-only true)
(input-port false read-only true)
(button-event false))
-(define (make-editor name screen)
+(define (make-editor name display-type make-screen-args)
(let ((initial-buffer (make-buffer initial-buffer-name initial-buffer-mode)))
- (let ((bufferset (make-bufferset initial-buffer)))
+ (let ((bufferset (make-bufferset initial-buffer))
+ (screen (display-type/make-screen display-type make-screen-args)))
(initialize-screen-root-window! screen bufferset initial-buffer)
(%make-editor name
+ display-type
(list screen)
screen
bufferset
(make-ring 10)
(make-ring 100)
- (make-editor-input-port screen)
+ (display-type/make-input-port display-type screen)
false))))
-(define (editor-add-screen! editor screen)
- (set-editor-screens! editor
- (append! (editor-screens editor)
- (list screen))))
+(define-integrable (current-display-type)
+ (editor-display-type current-editor))
-(define (editor-delete-screen! editor screen)
- (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-integrable (with-editor-interrupts-enabled thunk)
+ (display-type/with-interrupts-enabled (current-display-type) thunk))
-(define (screen-list)
- (editor-screens (if (within-editor?) current-editor edwin-editor)))
-
-(define-integrable (selected-screen)
- (editor-selected-screen current-editor))
+(define-integrable (with-editor-interrupts-disabled thunk)
+ (display-type/with-interrupts-disabled (current-display-type) thunk))
(define-integrable (current-bufferset)
(editor-bufferset current-editor))
;;; -*-Scheme-*-
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edwin.ldr,v 1.9 1990/09/12 19:33:34 markf Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edwin.ldr,v 1.10 1990/10/09 16:24:19 cph Exp $
;;; program to load package contents
;;; **** This program (unlike most .ldr files) is not generated by a program.
(load "comwin" (->environment '(EDWIN WINDOW COMBINATION)))
(load "modwin" environment)
(load "buffrm" environment)
- (load "edtfrm" environment)
- (load "winmis" environment))
+ (load "edtfrm" environment))
(let ((env (->environment '(EDWIN X-SCREEN))))
(load "xterm" env)
((access initialize-package! env)))
#| -*-Scheme-*-
-$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 $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edwin.pkg,v 1.20 1990/10/09 16:24:23 cph Exp $
Copyright (c) 1989, 1990 Massachusetts Institute of Technology
create-editor-args
edit
inhibit-editor-init-file?
- reset-editor))
+ reset-editor
+ reset-editor-windows))
(define-package (edwin class-macros)
(files "clsmac")
(files "display")
(parent (edwin))
(export ()
- editor-display-type
editor-display-types)
(export (edwin)
display-type?
- initialize-display-type!
+ display-type/make-input-port
+ display-type/make-screen
+ display-type/multiple-screens?
+ display-type/name
+ display-type/with-interrupt-source
+ display-type/with-interrupts-disabled
+ display-type/with-interrupts-enabled
make-display-type
- make-editor-input-port
- make-editor-screen
- set-editor-display-type!
- with-editor-interrupts
- with-editor-interrupts-disabled
- with-editor-interrupts-enabled))
+ name->display-type))
(define-package (edwin screen)
(files "screen")
screen-select-cursor!
screen-select-window!
screen-selected-window
+ screen-scroll-lines-down!
+ screen-scroll-lines-up!
screen-state
screen-typein-window
screen-window-list
set-screen-root-window!
subscreen-clear!
update-screen!
- using-screen
window-screen
with-screen-in-update!
with-screen-inverse-video!)
(parent (edwin))
(export (edwin)
console-display-type)
+ (import (runtime interrupt-handler)
+ hook/^g-interrupt)
(initialization (initialize-package!)))
(define-package (edwin window)
"bufwmc"
"modwin"
"buffrm"
- "edtfrm"
- "winmis")
+ "edtfrm")
(parent (edwin))
- (export ()
- reset-editor-windows)
(export (edwin)
edwin-variable$cursor-centering-point
edwin-variable$mode-line-inverse-video
;;; -*-Scheme-*-
;;;
-;;; $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 $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/filcom.scm,v 1.142 1990/10/09 16:24:29 cph Exp $
;;;
;;; Copyright (c) 1986, 1989, 1990 Massachusetts Institute of Technology
;;;
(define (find-file-other-window filename)
(select-buffer-other-window (find-file-noselect filename true)))
-(define (find-file-in-new-screen filename)
- (select-buffer-in-new-screen (find-file-noselect filename true)))
+(define (find-file-other-screen filename)
+ (select-buffer-other-screen (find-file-noselect filename true)))
(define (find-file-noselect filename warn?)
(let ((pathname (pathname->absolute-pathname (->pathname filename))))
(do-it)
(kill-buffer buffer*)))))))
-(define-command find-file-in-new-screen
- "Visit a file in a new screen."
- "FFind file in new screen"
- find-file-in-new-screen)
+(define-command find-file-other-screen
+ "Visit a file in another screen."
+ "FFind file in other screen"
+ find-file-other-screen)
\f
(define-command revert-buffer
"Replace the buffer text with the text of the visited file on disk.
;;; -*-Scheme-*-
;;;
-;;; $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 $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/modlin.scm,v 1.4 1990/10/09 16:24:36 cph Exp $
;;;
;;; Copyright (c) 1989, 1990 Massachusetts Institute of Technology
;;;
(else
(display-mode-element
value window line column min-end max-end)))))
+ ((procedure? element)
+ (display-mode-element (element window)
+ window line column min-end max-end))
(else
(display-string "*invalid*" line column min-end max-end))))
\f
;;; -*-Scheme-*-
;;;
-;;; $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 $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/screen.scm,v 1.84 1990/10/09 16:24:41 cph Exp $
;;;
;;; Copyright (c) 1989, 1990 Massachusetts Institute of Technology
;;;
operation/inverse-video!
operation/modeline-event!
operation/normal-video!
+ operation/scroll-lines-down!
+ operation/scroll-lines-up!
operation/start-update!
operation/subscreen-clear!
operation/wipe!
operation/write-char!
operation/write-cursor!
operation/write-substring!
- operation/write-substrings!
x-size
y-size)))
(state 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/scroll-lines-down! false read-only true)
+ (operation/scroll-lines-up! 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)
(root-window false)
(make-editor-frame
screen
buffer
- (bufferset-find-or-create-buffer bufferset (make-typein-buffer-name 0)))))
+ (bufferset-find-or-create-buffer bufferset (make-typein-buffer-name -1)))))
\f
-(define (using-screen screen thunk)
- (dynamic-wind (lambda ()
- ((screen-operation/enter! screen) screen))
- thunk
- (lambda ()
- ((screen-operation/exit! screen) screen))))
-
(define (with-screen-in-update! screen thunk)
(call-with-current-continuation
(lambda (continuation)
((screen-operation/write-substring! screen) screen x y string start end))
(define (screen-write-substrings! screen x y strings bil biu bjl bju)
- ((screen-operation/write-substrings! screen)
- screen x y strings bil biu bjl bju))
+ (let ((write-substring! (screen-operation/write-substring! screen)))
+ (clip (screen-x-size screen) x bil biu
+ (lambda (bxl ail aiu)
+ (clip (screen-y-size screen) y bjl bju
+ (lambda (byl ajl aju)
+ (let loop ((y byl) (j ajl))
+ (if (fix:< j aju)
+ (begin
+ (write-substring! screen bxl y
+ (vector-ref strings j) ail aiu)
+ (loop (fix:1+ y) (fix:1+ j)))))))))))
+
+(define (clip axu x bil biu receiver)
+ (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 (screen-scroll-lines-down! screen xl xu yl yu amount)
+ ((screen-operation/scroll-lines-down! screen) screen xl xu yl yu amount))
+
+(define (screen-scroll-lines-up! screen xl xu yl yu amount)
+ ((screen-operation/scroll-lines-up! screen) screen xl xu yl yu amount))
(define (screen-enter! screen)
- ((screen-operation/enter! screen) screen))
+ ((screen-operation/enter! screen) screen)
+ (screen-modeline-event! screen
+ (screen-selected-window screen)
+ 'SELECT-SCREEN))
(define (screen-exit! screen)
- ((screen-operation/exit! screen) screen))
+ ((screen-operation/exit! screen) screen)
+ (screen-modeline-event! screen
+ (screen-selected-window screen)
+ 'DESELECT-SCREEN))
(define (screen-discard! screen)
(for-each (lambda (window) (send window ':kill!))
(define (screen-modeline-event! screen window type)
((screen-operation/modeline-event! screen) screen window type))
-
+\f
(define-integrable (screen-selected-window screen)
(editor-frame-selected-window (screen-root-window screen)))
-(define-integrable (screen-select-window! screen window)
+(define (screen-select-window! screen window)
(editor-frame-select-window! (screen-root-window screen) window)
(screen-modeline-event! screen window 'SELECT-WINDOW))
;;; -*-Scheme-*-
;;;
-;;; $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 $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/wincom.scm,v 1.98 1990/10/09 16:24:47 cph Exp $
;;;
;;; Copyright (c) 1987, 1989, 1990 Massachusetts Institute of Technology
;;;
"*Number of lines of continuity when scrolling by screenfuls."
2)
+(define-variable use-multiple-screens
+ "If true, commands try to use multiple screens rather than multiple windows.
+Has no effect unless multiple-screen support is available."
+ false)
+
(define-variable pop-up-windows
"True enables the use of pop-up windows."
true)
"Delete the current window from the screen."
()
(lambda ()
- (window-delete! (current-window))))
+ (let ((window (current-window)))
+ (if (and (window-has-no-neighbors? window)
+ (use-multiple-screens?)
+ (other-screen (selected-screen)))
+ (delete-screen! (selected-screen))
+ (window-delete! window)))))
(define-command delete-other-windows
"Make the current window fill the screen."
"P"
(lambda (argument)
(select-window (other-window-interactive argument))))
-
+\f
(define (other-window-interactive n)
- (let ((window (other-window n)))
- (if (eq? window (current-window))
- (editor-error "No other window")
- window)))
+ (let ((window
+ (let ((window (other-window n)))
+ (if (current-window? window)
+ (and (use-multiple-screens?)
+ (let ((screen (other-screen (selected-screen))))
+ (and screen
+ (screen-selected-window screen))))
+ window))))
+ (if (not window)
+ (editor-error "No other window"))
+ window))
(define (disallow-typein)
(if (typein-window? (current-window))
(editor-error "Not implemented for typein window")))
+
+(define (use-multiple-screens?)
+ (and (ref-variable use-multiple-screens)
+ (multiple-screens?)))
+
+(define (select-buffer-other-window buffer)
+ (let ((window (current-window))
+ (use-window
+ (lambda (window)
+ (select-buffer-in-window buffer window)
+ (select-window window))))
+ (cond ((not (window-has-no-neighbors? window))
+ (let ((window*
+ (list-search-negative (buffer-windows buffer)
+ (lambda (window*)
+ (eq? window window*)))))
+ (if window*
+ (select-window window*)
+ (use-window (window1+ window)))))
+ ((not (use-multiple-screens?))
+ (use-window (window-split-vertically! window false)))
+ (else
+ (select-buffer-other-screen buffer)))))
+
+(define (select-buffer-other-screen buffer)
+ (if (multiple-screens?)
+ (select-screen
+ (let ((screen (other-screen (selected-screen))))
+ (if screen
+ (begin
+ (select-buffer-in-window buffer (screen-selected-window screen))
+ screen)
+ (make-screen buffer))))
+ (editor-error "Display doesn't support multiple screens")))
\f
;;;; Pop-up Buffers
(*previous-popped-up-buffer* (object-hash false)))
(dynamic-wind (lambda () unspecific)
thunk
- kill-pop-up-buffer)))
+ (lambda () (kill-pop-up-buffer false)))))
-(define (kill-pop-up-buffer #!optional error-if-none?)
+(define (kill-pop-up-buffer error-if-none?)
(let ((window (object-unhash *previous-popped-up-window*)))
- (if (and window (window-visible? window))
+ (if window
(begin
(set! *previous-popped-up-window* (object-hash false))
- (window-delete! window))))
+ (if (and (window-visible? window)
+ (not (window-has-no-neighbors? window)))
+ (window-delete! window)))))
(let ((buffer (object-unhash *previous-popped-up-buffer*)))
(cond ((and buffer (buffer-alive? buffer))
(set! *previous-popped-up-buffer* (object-hash false))
(kill-buffer-interactive buffer))
- ((and (not (default-object? error-if-none?)) error-if-none?)
+ (error-if-none?
(editor-error "No previous pop up buffer")))))
(define *previous-popped-up-buffer* (object-hash false))
(let ((limit (* 2 (ref-variable window-minimum-height))))
(if (< (ref-variable split-height-threshold) limit)
(set-variable! split-height-threshold limit))
- (cond ((ref-variable preserve-window-arrangement)
+ (cond ((and (use-multiple-screens?)
+ (other-screen (selected-screen)))
+ =>
+ (lambda (screen)
+ (pop-into-window (screen-selected-window screen))))
+ ((ref-variable preserve-window-arrangement)
(pop-into-window (largest-window)))
- ((ref-variable pop-up-windows)
+ ((not (ref-variable pop-up-windows))
+ (pop-into-window (lru-window)))
+ ((use-multiple-screens?)
+ (maybe-record-window
+ (screen-selected-window (make-screen buffer))))
+ (else
(let ((window (largest-window)))
(if (and (>= (window-y-size window)
(ref-variable split-height-threshold))
(window1+ window))))
(>= (window-y-size window) limit))
(pop-up-window window)
- (pop-into-window window))))))
- (else
- (pop-into-window (lru-window)))))))))
+ (pop-into-window window))))))))))))
(set! *previous-popped-up-window* (object-hash window))
(set! *previous-popped-up-buffer* (object-hash buffer))
window)))
\f
(define (get-buffer-window buffer)
- (let ((start (window0)))
- (if (eq? buffer (window-buffer start))
- start
- (let loop ((window (window1+ start)))
- (and (not (eq? window start))
- (if (eq? buffer (window-buffer window))
- window
- (loop (window1+ window))))))))
+ (or (let ((start (window0)))
+ (if (eq? buffer (window-buffer start))
+ start
+ (let loop ((window (window1+ start)))
+ (and (not (eq? window start))
+ (if (eq? buffer (window-buffer window))
+ window
+ (loop (window1+ window)))))))
+ (and (use-multiple-screens?)
+ (or (let ((screen (other-screen (selected-screen))))
+ (and screen
+ (list-search-positive (screen-window-list screen)
+ (lambda (window)
+ (eq? buffer window)))))
+ (let ((windows (buffer-windows buffer)))
+ (and (not (null? windows))
+ (car windows)))))))
(define (largest-window)
(let ((start (window0)))
;;; -*-Scheme-*-
;;;
-;;; $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 $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/xterm.scm,v 1.12 1990/10/09 16:24:53 cph Exp $
;;;
;;; Copyright (c) 1989, 1990 Massachusetts Institute of Technology
;;;
(x-window-set-name 2)
(xterm-clear-rectangle! 6)
(xterm-draw-cursor 1)
+ (xterm-enable-cursor 2)
(xterm-erase-cursor 1)
(xterm-open-window 3)
(xterm-restore-contents 6)
(conc-name xterm-screen-state/))
(xterm false read-only true)
(display false read-only true)
- (redisplay-flag true))
+ (redisplay-flag true)
+ (selected? true))
(define screen-list)
xterm-screen/inverse-video!
xterm-screen/modeline-event!
xterm-screen/normal-video!
+ xterm-screen/scroll-lines-down!
+ xterm-screen/scroll-lines-up!
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))
(define-integrable (set-screen-redisplay-flag! screen flag)
(set-xterm-screen-state/redisplay-flag! (screen-state screen) flag))
+(define-integrable (screen-selected? screen)
+ (xterm-screen-state/selected? (screen-state screen)))
+
+(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))
(loop (cdr screens))))))
\f
(define (xterm-screen/start-update! screen)
- (xterm-erase-cursor (screen-xterm screen)))
+ (xterm-enable-cursor (screen-xterm screen) false))
(define (xterm-screen/finish-update! screen)
- (xterm-draw-cursor (screen-xterm screen))
+ (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 true))
(define (xterm-screen/enter! screen)
- screen ; ignored
- unspecific)
+ (set-screen-selected?! screen true)
+ (let ((xterm (screen-xterm screen)))
+ (xterm-enable-cursor xterm true)
+ (xterm-draw-cursor xterm))
+ (xterm-screen/flush! screen))
(define (xterm-screen/exit! screen)
- screen ; ignored
- unspecific)
+ (set-screen-selected?! screen false)
+ (let ((xterm (screen-xterm screen)))
+ (xterm-enable-cursor xterm false)
+ (xterm-erase-cursor xterm))
+ (xterm-screen/flush! screen))
(define (xterm-screen/inverse-video! screen)
screen ; ignored
(define (xterm-screen/normal-video! screen)
screen ; ignored
unspecific)
-\f
+
+(define (xterm-screen/scroll-lines-down! screen xl xu yl yu amount)
+ (xterm-scroll-lines-down (screen-xterm screen) xl xu yl yu amount 0)
+ true)
+
+(define (xterm-screen/scroll-lines-up! screen xl xu yl yu amount)
+ (xterm-scroll-lines-up (screen-xterm screen) xl xu yl yu amount 0)
+ true)
+
(define (xterm-screen/beep screen)
(x-window-beep (screen-xterm screen))
(xterm-screen/flush! screen))
(xterm-write-substring! (screen-xterm screen) x y string start end
(screen-highlight screen)))
-(define (xterm-screen/write-substrings! screen x y strings bil biu bjl bju)
- (let ((xterm (screen-xterm screen))
- (highlight (screen-highlight screen)))
- (clip (screen-x-size screen) x bil biu
- (lambda (bxl ail aiu)
- (clip (screen-y-size screen) y bjl bju
- (lambda (byl ajl aju)
- (let loop ((y byl) (j ajl))
- (if (fix:< j aju)
- (begin
- (xterm-write-substring! xterm
- bxl y
- (vector-ref strings j)
- ail aiu
- highlight)
- (loop (fix:1+ y) (fix:1+ j)))))))))))
-
-(define (clip axu x bil biu receiver)
- (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)))
(set! screen-list '())
(set! x-display-type
(make-display-type 'X
+ true
get-x-display
make-xterm-screen
make-xterm-input-port
projects / mit-scheme.git / commitdiff